1 |
|
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
2 |
|
|
3 |
|
;; This file is part of GNU Common Lisp, herein referred to as GCL |
4 |
|
;; |
5 |
|
;; GCL is free software; you can redistribute it and/or modify it under |
6 |
|
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by |
7 |
|
;; the Free Software Foundation; either version 2, or (at your option) |
8 |
|
;; any later version. |
9 |
|
;; |
10 |
|
;; GCL is distributed in the hope that it will be useful, but WITHOUT |
11 |
|
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
12 |
|
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public |
13 |
|
;; License for more details. |
14 |
|
;; |
15 |
|
;; You should have received a copy of the GNU Library General Public License |
16 |
|
;; along with GCL; see the file COPYING. If not, write to the Free Software |
17 |
|
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
18 |
|
|
19 |
|
|
20 |
|
|
21 |
|
;;;; AUTOLOAD |
22 |
|
|
23 |
|
|
24 |
|
;;; Go into LISP. |
25 |
|
(in-package 'lisp) |
26 |
|
|
27 |
|
;(defvar *features*) |
28 |
|
|
29 |
|
(defun eval-feature (x) |
30 |
|
(cond ((atom x) |
31 |
|
(member x *features* |
32 |
|
:test #'(lambda (a b) |
33 |
|
(cond ((symbolp a) |
34 |
|
(and (symbolp b) |
35 |
|
(string-equal (symbol-name a) |
36 |
|
(symbol-name b)))) |
37 |
|
(t (eql a b)))))) |
38 |
|
((eq (car x) 'and) |
39 |
|
(dolist (x (cdr x) t) (unless (eval-feature x) (return nil)))) |
40 |
|
((eq (car x) 'or) |
41 |
|
(dolist (x (cdr x) nil) (when (eval-feature x) (return t)))) |
42 |
|
((eq (car x) 'not) |
43 |
|
(not (eval-feature (cadr x)))) |
44 |
|
(t (error "~S is not a feature expression." x)))) |
45 |
|
|
46 |
|
;;; Revised by Marc Rinfret. |
47 |
|
(defun sharp-+-reader (stream subchar arg) |
48 |
|
(if (eval-feature (let ((*read-suppress* nil) (*read-base* 10.)) |
49 |
|
(read stream t nil t))) |
50 |
|
(values (read stream t nil t)) |
51 |
|
(let ((*read-suppress* t)) (read stream t nil t) (values)))) |
52 |
|
|
53 |
|
(set-dispatch-macro-character #\# #\+ 'sharp-+-reader) |
54 |
|
(set-dispatch-macro-character #\# #\+ 'sharp-+-reader |
55 |
|
(si::standard-readtable)) |
56 |
|
|
57 |
|
(defun sharp---reader (stream subchar arg) |
58 |
|
(if (eval-feature (let ((*read-suppress* nil) (*read-base* 10.)) |
59 |
|
(read stream t nil t))) |
60 |
|
(let ((*read-suppress* t)) (read stream t nil t) (values)) |
61 |
|
(values (read stream t nil t)))) |
62 |
|
|
63 |
|
(set-dispatch-macro-character #\# #\- 'sharp---reader) |
64 |
|
(set-dispatch-macro-character #\# #\- 'sharp---reader |
65 |
|
(si::standard-readtable)) |
66 |
|
|
67 |
|
|
68 |
|
|
69 |
|
(defun lisp-implementation-type () "Kyoto Common Lisp") |
70 |
|
|
71 |
|
(defun machine-type () #+sun "SUN" |
72 |
|
#+hp-ux "HP-UX" |
73 |
|
#+eclipse "ECLIPSE" |
74 |
|
#+vax "VAX" |
75 |
|
) |
76 |
|
|
77 |
|
;(defun machine-type () "DEC VAX11/780") |
78 |
|
|
79 |
|
(defun machine-version () (machine-type)) |
80 |
|
;(defun machine-version () nil) |
81 |
|
|
82 |
|
(defun machine-instance () (machine-type)) |
83 |
|
;(defun machine-instance () nil) |
84 |
|
|
85 |
|
(defun software-type () |
86 |
|
#+aosv "AOS/VS" |
87 |
|
#+bsd "BSD" |
88 |
|
#+system-v "SYSTEM-V" |
89 |
|
#+hp-ux "HP-UX") |
90 |
|
|
91 |
|
;(defun software-type () "UNIX BSD") |
92 |
|
|
93 |
|
(defun software-version () (software-type)) |
94 |
|
;(defun software-version () "4.2BSD") |
95 |
|
|
96 |
|
;(defun short-site-name () "RIMS") |
97 |
|
(defun short-site-name () nil) |
98 |
|
|
99 |
|
;(defun long-site-name () |
100 |
|
; "Research Institute for Mathematical Sciences, Kyoto University") |
101 |
|
(defun long-site-name () nil) |
102 |
|
|
103 |
|
|
104 |
|
|
105 |
|
;;; Compiler functions. |
106 |
|
|
107 |
|
(defun proclaim (d) |
108 |
|
(when (eq (car d) 'special) (mapc #'si:*make-special (cdr d)))) |
109 |
|
|
110 |
|
(defun proclamation (d) |
111 |
|
(and (eq (car d) 'special) |
112 |
|
(dolist (var (cdr d) t) |
113 |
|
(unless (si:specialp var) (return nil))))) |
114 |
|
|
115 |
|
(defun compile-file (&rest args) |
116 |
|
(error "COMPILE-FILE is not defined in this load module.")) |
117 |
|
(defun compile (&rest args) |
118 |
|
(error "COMPILE is not defined in this load module.")) |
119 |
|
(defun disassemble (&rest args) |
120 |
|
(error "DISASSEMBLE is not defined in this load module.")) |
121 |
|
|
122 |
|
|
123 |
|
;;; Editor. |
124 |
|
|
125 |
|
; |
126 |
|
(defun get-decoded-time () |
127 |
|
(decode-universal-time (get-universal-time))) |
128 |
|
|
129 |
|
#+never |
130 |
|
(defun get-universal-time () |
131 |
|
(multiple-value-bind (sec min h d m y dow dstp tz) |
132 |
|
(get-decoded-time) |
133 |
|
(encode-universal-time sec min h d m y tz))) |
134 |
|
|
135 |
|
|
136 |
|
(defun ed (&optional filename) |
137 |
|
(system (format nil "vi ~A" filename))) |
138 |
|
|
139 |
|
;;; Allocator. |
140 |
|
|
141 |
|
(import 'si::allocate) |
142 |
|
(export '(allocate |
143 |
|
;allocated-pages maximum-allocatable-pages |
144 |
|
;allocate-contiguous-pages |
145 |
|
;allocated-contiguous-pages maximum-contiguous-pages |
146 |
|
;allocate-relocatable-pages allocated-relocatable-pages |
147 |
|
sfun gfun cfun cclosure spice structure)) |
148 |
|
|
149 |
|
;(defvar type-character-alist |
150 |
|
; '((cons . #\.) |
151 |
|
; (fixnum . #\N) |
152 |
|
; (bignum . #\B) |
153 |
|
; (ratio . #\R) |
154 |
|
; (short-float . #\F) |
155 |
|
; (long-float . #\L) |
156 |
|
; (complex . #\C) |
157 |
|
; (character . #\#) |
158 |
|
; (symbol . #\|) |
159 |
|
; (package . #\:) |
160 |
|
; (hash-table . #\h) |
161 |
|
; (array . #\a) |
162 |
|
; (vector . #\v) |
163 |
|
; (string . #\") |
164 |
|
; (bit-vector . #\b) |
165 |
|
; (structure . #\S) |
166 |
|
; (sfun . #\g) |
167 |
|
; (stream . #\s) |
168 |
|
; (random-state . #\$) |
169 |
|
; (readtable . #\r) |
170 |
|
; (pathname . #\p) |
171 |
|
; (cfun . #\f) |
172 |
|
; (vfun . #\V) |
173 |
|
; (cclosure . #\c) |
174 |
|
; (spice . #\!))) |
175 |
|
; |
176 |
|
;(defun get-type-character (type) |
177 |
|
; (let ((a (assoc type type-character-alist))) |
178 |
|
; (unless a |
179 |
|
; (error "~S is not an implementation type.~%~ |
180 |
|
; It should be one of:~%~ |
181 |
|
; ~{~10T~S~^~30T~S~^~50T~S~%~}~%" |
182 |
|
; type |
183 |
|
; (mapcar #'car type-character-alist))) |
184 |
|
; (cdr a))) |
185 |
|
|
186 |
|
;(defun allocate (type quantity &optional really-allocate) |
187 |
|
; (si:alloc (get-type-character type) quantity really-allocate)) |
188 |
|
|
189 |
|
;(defun allocated-pages (type) |
190 |
|
; (si:npage (get-type-character type))) |
191 |
|
|
192 |
|
;(defun maximum-allocatable-pages (type) |
193 |
|
; (si:maxpage (get-type-character type))) |
194 |
|
|
195 |
|
;(defun allocate-contiguous-pages (quantity &optional really-allocate) |
196 |
|
; (si::alloc-contpage quantity really-allocate)) |
197 |
|
|
198 |
|
;(defun allocated-contiguous-pages () |
199 |
|
; (si:ncbpage)) |
200 |
|
|
201 |
|
;(defun maximum-contiguous-pages () |
202 |
|
; (si::maxcbpage)) |
203 |
|
|
204 |
|
;(defun allocate-relocatable-pages (quantity &optional really-allocate) |
205 |
|
; (si::alloc-relpage quantity)) |
206 |
|
|
207 |
|
;(defun allocated-relocatable-pages () |
208 |
|
; (si::nrbpage)) |
209 |
|
|
210 |
|
(defvar *type-list* |
211 |
|
'(cons |
212 |
|
fixnum bignum ratio short-float long-float complex |
213 |
|
character symbol package hash-table |
214 |
|
array vector string bit-vector |
215 |
|
structure stream random-state readtable pathname |
216 |
|
cfun cclosure sfun gfun cfdata spice fat-string )) |
217 |
|
|
218 |
|
(defun room (&optional x) |
219 |
|
(let ((l (multiple-value-list (si:room-report))) |
220 |
|
maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage |
221 |
|
rbused rbfree nrbpage |
222 |
|
info-list link-alist) |
223 |
|
(setq maxpage (nth 0 l) leftpage (nth 1 l) |
224 |
|
ncbpage (nth 2 l) maxcbpage (nth 3 l) ncb (nth 4 l) |
225 |
|
cbgbccount (nth 5 l) |
226 |
|
holepage (nth 6 l) |
227 |
|
rbused (nth 7 l) rbfree (nth 8 l) nrbpage (nth 9 l) |
228 |
|
rbgbccount (nth 10 l) |
229 |
|
l (nthcdr 11 l)) |
230 |
|
(do ((l l (nthcdr 5 l)) |
231 |
|
(tl *type-list* (cdr tl)) |
232 |
|
(i 0 (+ i (if (nth 2 l) (nth 2 l) 0)))) |
233 |
|
((null l) (setq npage i)) |
234 |
|
(let ((typename (car tl)) |
235 |
|
(nused (nth 0 l)) |
236 |
|
(nfree (nth 1 l)) |
237 |
|
(npage (nth 2 l)) |
238 |
|
(maxpage (nth 3 l)) |
239 |
|
(gbccount (nth 4 l))) |
240 |
|
(if nused |
241 |
|
(push (list typename npage maxpage |
242 |
|
(if (zerop (+ nused nfree)) |
243 |
|
0 |
244 |
|
(/ nused 0.01 (+ nused nfree))) |
245 |
|
(if (zerop gbccount) nil gbccount)) |
246 |
|
info-list) |
247 |
|
(let ((a (assoc (nth nfree *type-list*) link-alist))) |
248 |
|
(if a |
249 |
|
(nconc a (list typename)) |
250 |
|
(push (list (nth nfree *type-list*) typename) |
251 |
|
link-alist)))))) |
252 |
|
(dolist (info (reverse info-list)) |
253 |
|
(apply #'format t "~4D/~D~10T~5,1F%~@[~3D~]~20T~{~A~^ ~}" |
254 |
|
(append (cdr info) |
255 |
|
(if (assoc (car info) link-alist) |
256 |
|
(list (assoc (car info) link-alist)) |
257 |
|
(list (list (car info)))))) |
258 |
|
(terpri) |
259 |
|
) |
260 |
|
(terpri) |
261 |
|
(format t "~4D/~D~16T~@[~3D~]~20Tcontiguous (~D blocks)~%" |
262 |
|
ncbpage maxcbpage (if (zerop cbgbccount) nil cbgbccount) ncb) |
263 |
|
(format t "~5T~D~20Thole~%" holepage) |
264 |
|
(format t "~5T~D~10T~5,1F%~@[~3D~]~20Trelocatable~%~%" |
265 |
|
nrbpage (/ rbused 0.01 (+ rbused rbfree)) |
266 |
|
(if (zerop rbgbccount) nil rbgbccount)) |
267 |
|
(format t "~5D pages for cells~%" npage) |
268 |
|
(format t "~5D total pages~%" (+ npage ncbpage holepage nrbpage)) |
269 |
|
(format t "~5D pages available~%" leftpage) |
270 |
|
(format t "~5D pages in heap but not gc'd + pages needed for gc marking~%" |
271 |
|
(- maxpage (+ npage ncbpage holepage nrbpage leftpage))) |
272 |
|
(format t "~5D maximum pages~%" maxpage) |
273 |
|
(values) |
274 |
|
)) |
275 |
|
|
276 |
|
|
277 |
|
;;; C Interface. |
278 |
|
|
279 |
|
(defmacro Clines (&rest r) nil) |
280 |
|
(defmacro defCfun (&rest r) nil) |
281 |
|
(defmacro defentry (&rest r) nil) |
282 |
|
|
283 |
|
(defmacro defla (&rest r) (cons 'defun r)) |
284 |
|
|
285 |
|
;;; Help. |
286 |
|
|
287 |
|
(export '(help help*)) |
288 |
|
|
289 |
|
(defun help (&optional (symbol nil s)) |
290 |
|
(if s (si::print-doc symbol) |
291 |
|
(progn |
292 |
|
(princ " |
293 |
|
Welcome to GNU Common Lisp (GCL for short). |
294 |
|
Here are some functions you should learn first. |
295 |
|
|
296 |
|
(HELP symbol) prints the online documentation associated with the |
297 |
|
symbol. For example, (HELP 'CONS) will print the useful information |
298 |
|
about the CONS function, the CONS data type, and so on. |
299 |
|
|
300 |
|
(HELP* string) prints the online documentation associated with those |
301 |
|
symbols whose print-names have the string as substring. For example, |
302 |
|
(HELP* \"PROG\") will print the documentation of the symbols such as |
303 |
|
PROG, PROGN, and MULTIPLE-VALUE-PROG1. |
304 |
|
|
305 |
|
(SI::INFO <some string>) chooses from a list of all references in the |
306 |
|
on-line documentation to <some string>. |
307 |
|
|
308 |
|
(APROPOS <some string>) or (APROPOS <some string> '<a package>) list |
309 |
|
all symbols containing <some string>. |
310 |
|
|
311 |
|
(DESCRIBE '<symbol>) or (HELP '<symbol>) describe particular symbols. |
312 |
|
|
313 |
|
(BYE) or (BY) ends the current GCL session. |
314 |
|
|
315 |
|
Good luck! The GCL Development Team") |
316 |
|
(values)))) |
317 |
|
|
318 |
|
(defun help* (string &optional (package (find-package "LISP"))) |
319 |
|
(si::apropos-doc string package)) |
320 |
|
|
321 |
|
;;; Pretty-print-formats. |
322 |
|
;;; |
323 |
|
;;; The number N as the property of a symbol SYMBOL indicates that, |
324 |
|
;;; in the form (SYMBOL f1 ... fN fN+1 ... fM), the subforms fN+1,...,fM |
325 |
|
;;; are the 'body' of the form and thus are treated in a special way by |
326 |
|
;;; the KCL pretty-printer. |
327 |
|
|
328 |
|
(setf (get 'lambda 'si:pretty-print-format) 1) |
329 |
|
(setf (get 'lambda-block 'si:pretty-print-format) 2) |
330 |
|
(setf (get 'lambda-closure 'si:pretty-print-format) 4) |
331 |
|
(setf (get 'lambda-block-closure 'si:pretty-print-format) 5) |
332 |
|
|
333 |
|
(setf (get 'block 'si:pretty-print-format) 1) |
334 |
|
(setf (get 'case 'si:pretty-print-format) 1) |
335 |
|
(setf (get 'catch 'si:pretty-print-format) 1) |
336 |
|
(setf (get 'ccase 'si:pretty-print-format) 1) |
337 |
|
(setf (get 'clines 'si:pretty-print-format) 0) |
338 |
|
(setf (get 'compiler-let 'si:pretty-print-format) 1) |
339 |
|
(setf (get 'cond 'si:pretty-print-format) 0) |
340 |
|
(setf (get 'ctypecase 'si:pretty-print-format) 1) |
341 |
|
(setf (get 'defcfun 'si:pretty-print-format) 2) |
342 |
|
(setf (get 'define-setf-method 'si:pretty-print-format) 2) |
343 |
|
(setf (get 'defla 'si:pretty-print-format) 2) |
344 |
|
(setf (get 'defmacro 'si:pretty-print-format) 2) |
345 |
|
(setf (get 'defsetf 'si:pretty-print-format) 3) |
346 |
|
(setf (get 'defstruct 'si:pretty-print-format) 1) |
347 |
|
(setf (get 'deftype 'si:pretty-print-format) 2) |
348 |
|
(setf (get 'defun 'si:pretty-print-format) 2) |
349 |
|
(setf (get 'do 'si:pretty-print-format) 2) |
350 |
|
(setf (get 'do* 'si:pretty-print-format) 2) |
351 |
|
(setf (get 'do-symbols 'si:pretty-print-format) 1) |
352 |
|
(setf (get 'do-all-symbols 'si:pretty-print-format) 1) |
353 |
|
(setf (get 'do-external-symbols 'si:pretty-print-format) 1) |
354 |
|
(setf (get 'dolist 'si:pretty-print-format) 1) |
355 |
|
(setf (get 'dotimes 'si:pretty-print-format) 1) |
356 |
|
(setf (get 'ecase 'si:pretty-print-format) 1) |
357 |
|
(setf (get 'etypecase 'si:pretty-print-format) 1) |
358 |
|
(setf (get 'eval-when 'si:pretty-print-format) 1) |
359 |
|
(setf (get 'flet 'si:pretty-print-format) 1) |
360 |
|
(setf (get 'labels 'si:pretty-print-format) 1) |
361 |
|
(setf (get 'let 'si:pretty-print-format) 1) |
362 |
|
(setf (get 'let* 'si:pretty-print-format) 1) |
363 |
|
(setf (get 'locally 'si:pretty-print-format) 0) |
364 |
|
(setf (get 'loop 'si:pretty-print-format) 0) |
365 |
|
(setf (get 'macrolet 'si:pretty-print-format) 1) |
366 |
|
(setf (get 'multiple-value-bind 'si:pretty-print-format) 2) |
367 |
|
(setf (get 'multiple-value-prog1 'si:pretty-print-format) 1) |
368 |
|
(setf (get 'prog 'si:pretty-print-format) 1) |
369 |
|
(setf (get 'prog* 'si:pretty-print-format) 1) |
370 |
|
(setf (get 'prog1 'si:pretty-print-format) 1) |
371 |
|
(setf (get 'prog2 'si:pretty-print-format) 2) |
372 |
|
(setf (get 'progn 'si:pretty-print-format) 0) |
373 |
|
(setf (get 'progv 'si:pretty-print-format) 2) |
374 |
|
(setf (get 'return 'si:pretty-print-format) 0) |
375 |
|
(setf (get 'return-from 'si:pretty-print-format) 1) |
376 |
|
(setf (get 'tagbody 'si:pretty-print-format) 0) |
377 |
|
(setf (get 'the 'si:pretty-print-format) 1) |
378 |
|
(setf (get 'throw 'si:pretty-print-format) 1) |
379 |
|
(setf (get 'typecase 'si:pretty-print-format) 1) |
380 |
|
(setf (get 'unless 'si:pretty-print-format) 1) |
381 |
|
(setf (get 'unwind-protect 'si:pretty-print-format) 0) |
382 |
|
(setf (get 'when 'si:pretty-print-format) 1) |
383 |
|
(setf (get 'with-input-from-string 'si:pretty-print-format) 1) |
384 |
|
(setf (get 'with-open-file 'si:pretty-print-format) 1) |
385 |
|
(setf (get 'with-open-stream 'si:pretty-print-format) 1) |
386 |
|
(setf (get 'with-output-to-string 'si:pretty-print-format) 1) |
387 |
|
|
388 |
|
|
389 |
|
(in-package 'si) |
390 |
|
|
391 |
|
(defvar *lib-directory* (namestring (probe-file "../"))) |
392 |
|
|
393 |
|
(import '(*lib-directory* *load-path* *system-directory*) 'si::user) |