/[gcl]/gcl/lsp/gcl_autoload.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_autoload.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:04 2003 UTC
# Line 0  Line 1 
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)

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26