source: trunk/j/src/org/armedbear/lisp/boot.lisp @ 8428

Last change on this file since 8428 was 8428, checked in by piso, 17 years ago

(setf *warn-on-redefinition* t) at end of file.

File size: 11.1 KB
Line 
1;;; boot.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: boot.lisp,v 1.201 2005-01-31 17:24:28 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20(sys::%in-package "SYSTEM")
21
22(setq *autoload-verbose* nil)
23(setq *load-verbose* nil)
24
25(defmacro in-package (name)
26  (list 'sys::%in-package (string name)))
27
28(defmacro lambda (lambda-list &rest body)
29  (list 'function (list* 'lambda lambda-list body)))
30
31(defmacro when (pred &rest body)
32  (list 'if pred (if (> (length body) 1)
33                     (append '(progn) body)
34                     (car body))))
35
36(defmacro unless (pred &rest body)
37  (list 'if (list 'not pred) (if (> (length body) 1)
38                                 (append '(progn) body)
39                                 (car body))))
40
41(defmacro return (&optional result)
42  (list 'return-from nil result))
43
44(defmacro defun (name lambda-list &rest body)
45  (list 'sys::%defun (list 'QUOTE name) (list 'QUOTE lambda-list) (list 'QUOTE body)))
46
47(defmacro defconstant (name initial-value &optional docstring)
48  (list 'sys::%defconstant (list 'QUOTE name) initial-value docstring))
49
50(defmacro defparameter (name initial-value &optional docstring)
51  (list 'sys::%defparameter (list 'QUOTE name) initial-value docstring))
52
53;; EVAL is redefined in precompiler.lisp.
54(defun eval (form)
55  (sys::%eval form))
56
57(defun terpri (&optional output-stream)
58  (sys::%terpri output-stream))
59
60(defun fresh-line (&optional output-stream)
61  (sys::%fresh-line output-stream))
62
63(defun write-char (character &optional output-stream)
64  (sys::%write-char character output-stream))
65
66(defun simple-format (destination control-string &rest args)
67  (apply *simple-format-function* destination control-string args))
68
69(export 'simple-format '#:system)
70
71;; INVOKE-DEBUGGER is redefined in debug.lisp.
72(defun invoke-debugger (condition)
73  (sys::%format t "~A~%" condition)
74  (ext:quit))
75
76(sys:load-system-file "autoloads")
77(sys:load-system-file "early-defuns")
78(sys:load-system-file "backquote")
79(sys:load-system-file "setf")
80(sys:load-system-file "documentation")
81
82(defmacro defvar (var &optional (val nil valp) (doc nil docp))
83  `(progn
84     (sys::%defvar ',var)
85     ,@(when valp
86         `((unless (boundp ',var)
87             (setq ,var ,val))))
88     ,@(when docp
89         `((sys::%set-documentation ',var 'variable ',doc)))
90     ',var))
91
92(defun make-package (package-name &key nicknames use)
93  (sys::%make-package package-name nicknames use))
94
95(defun make-keyword (symbol)
96  (intern (symbol-name symbol) *keyword-package*))
97
98(defun featurep (form)
99  (cond ((atom form)
100         (ext:memq form *features*))
101        ((eq (car form) :not)
102         (not (featurep (cadr form))))
103        ((eq (car form) :and)
104         (dolist (subform (cdr form) t)
105           (unless (featurep subform) (return))))
106        ((eq (car form) :or)
107         (dolist (subform (cdr form) nil)
108           (when (featurep subform) (return t))))
109        (t
110         (error "READ-FEATURE"))))
111
112(export 'featurep '#:system)
113
114;;; READ-CONDITIONAL (from OpenMCL)
115(defun read-feature (stream)
116  (let* ((f (let* ((*package* sys::*keyword-package*))
117              (read stream t nil t))))
118    (if (featurep f) #\+ #\-)))
119
120(defun read-conditional (stream subchar int)
121  (cond (*read-suppress*
122         (read stream t nil t)
123         (values))
124        ((eql subchar (read-feature stream))
125         (read stream t nil t))
126        (t
127         (let ((*read-suppress* t))
128           (read stream t nil t)
129           (values)))))
130
131(set-dispatch-macro-character #\# #\+ #'read-conditional *standard-readtable*)
132(set-dispatch-macro-character #\# #\- #'read-conditional *standard-readtable*)
133
134
135
136;;; Reading circular data: the #= and ## reader macros (from SBCL)
137
138;;; Objects already seen by CIRCLE-SUBST.
139(defvar *sharp-equal-circle-table*)
140
141;; This function is kind of like NSUBLIS, but checks for circularities and
142;; substitutes in arrays and structures as well as lists. The first arg is an
143;; alist of the things to be replaced assoc'd with the things to replace them.
144(defun circle-subst (old-new-alist tree)
145  (cond ((not (typep tree
146                     '(or cons (array t) structure-object standard-object)))
147         (let ((entry (find tree old-new-alist :key #'second)))
148           (if entry (third entry) tree)))
149        ((null (gethash tree *sharp-equal-circle-table*))
150         (setf (gethash tree *sharp-equal-circle-table*) t)
151         (cond
152          ((typep tree 'structure-object)
153           (do ((i 0 (1+ i))
154                (end (structure-length tree)))
155               ((= i end))
156             (let* ((old (%structure-ref tree i))
157                    (new (circle-subst old-new-alist old)))
158               (unless (eq old new)
159                 (%structure-set tree i new)))))
160;;           ((typep tree 'standard-object)
161;;            (do ((i 1 (1+ i))
162;;                 (end (%instance-length tree)))
163;;                ((= i end))
164;;              (let* ((old (%instance-ref tree i))
165;;                     (new (circle-subst old-new-alist old)))
166;;                (unless (eq old new)
167;;                  (setf (%instance-ref tree i) new)))))
168          ((arrayp tree)
169           (do ((i 0 (1+ i))
170                (end (array-total-size tree)))
171               ((>= i end))
172             (let* ((old (row-major-aref tree i))
173                    (new (circle-subst old-new-alist old)))
174               (unless (eq old new)
175                 (setf (row-major-aref tree i) new)))))
176         (t
177          (let ((a (circle-subst old-new-alist (car tree)))
178                (d (circle-subst old-new-alist (cdr tree))))
179            (unless (eq a (car tree))
180              (rplaca tree a))
181            (unless (eq d (cdr tree))
182              (rplacd tree d)))))
183        tree)
184  (t tree)))
185
186;;; Sharp-equal works as follows. When a label is assigned (i.e. when
187;;; #= is called) we GENSYM a symbol is which is used as an
188;;; unforgeable tag. *SHARP-SHARP-ALIST* maps the integer tag to this
189;;; gensym.
190;;;
191;;; When SHARP-SHARP encounters a reference to a label, it returns the
192;;; symbol assoc'd with the label. Resolution of the reference is
193;;; deferred until the read done by #= finishes. Any already resolved
194;;; tags (in *SHARP-EQUAL-ALIST*) are simply returned.
195;;;
196;;; After reading of the #= form is completed, we add an entry to
197;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved
198;;; object. Then for each entry in the *SHARP-SHARP-ALIST, the current
199;;; object is searched and any uses of the gensysm token are replaced
200;;; with the actual value.
201
202(defvar *sharp-sharp-alist* ())
203
204(defun sharp-equal (stream ignore label)
205  (declare (ignore ignore))
206  (when *read-suppress* (return-from sharp-equal (values)))
207  (unless label
208    (error 'reader-error
209           :stream stream
210           :format-control "Missing label for #="))
211  (when (or (assoc label *sharp-sharp-alist*)
212            (assoc label *sharp-equal-alist*))
213    (error 'reader-error
214           :stream stream
215           :format-control "Multiply defined label: #~D="
216           :format-arguments (list label)))
217  (let* ((tag (gensym))
218         (*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*))
219         (obj (read stream t nil t)))
220    (when (eq obj tag)
221      (error 'reader-error
222             :stream stream
223             :format-control "Must tag something more than just #~D#"
224             :format-arguments (list label)))
225    (push (list label tag obj) *sharp-equal-alist*)
226    (let ((*sharp-equal-circle-table* (make-hash-table :test 'eq :size 20)))
227      (circle-subst *sharp-equal-alist* obj))))
228
229(defun sharp-sharp (stream ignore label)
230  (declare (ignore ignore))
231  (when *read-suppress* (return-from sharp-sharp nil))
232  (unless label
233    (error 'reader-error :stream stream :format-control "Missing label for ##"))
234  (let ((entry (assoc label *sharp-equal-alist*)))
235    (if entry
236        (third entry)
237        (let ((pair (assoc label *sharp-sharp-alist*)))
238          (unless pair
239            (error 'reader-error
240                   :stream stream
241                   :format-control "Object is not labelled #~S#"
242                   :format-arguments (list label)))
243          (cdr pair)))))
244
245(set-dispatch-macro-character #\# #\= #'sharp-equal *standard-readtable*)
246(set-dispatch-macro-character #\# #\# #'sharp-sharp *standard-readtable*)
247
248
249(copy-readtable *standard-readtable* *readtable*)
250
251;; SYS::%COMPILE is redefined in precompiler.lisp.
252(defun sys::%compile (name definition)
253  (values (if name name definition) nil nil))
254
255(load-system-file "macros")
256(load-system-file "fixme")
257(load-system-file "destructuring-bind")
258(load-system-file "arrays")
259(load-system-file "compiler-macro")
260(load-system-file "subtypep")
261(load-system-file "typep")
262(load-system-file "precompiler")
263
264(precompile-package "PRECOMPILER")
265(precompile-package "EXTENSIONS")
266(precompile-package "SYSTEM")
267(precompile-package "COMMON-LISP")
268
269(load-system-file "signal")
270(load-system-file "list")
271(load-system-file "sequences")
272(load-system-file "error")
273(load-system-file "defpackage")
274(load-system-file "define-modify-macro")
275
276;;; Package definitions.
277(defpackage "FORMAT" (:use "CL" "EXT"))
278
279(defpackage "XP"
280  (:use "CL")
281  (:export
282   #:output-pretty-object))
283
284;;; PROVIDE, REQUIRE (from SBCL)
285(defun provide (module-name)
286  (pushnew (string module-name) *modules* :test #'string=)
287  t)
288
289(defun require (module-name &optional pathnames)
290  (unless (member (string module-name) *modules* :test #'string=)
291    (let ((saved-modules (copy-list *modules*)))
292      (cond (pathnames
293             (unless (listp pathnames) (setf pathnames (list pathnames)))
294             (dolist (x pathnames)
295               (load x)))
296            (t
297             (let ((*readtable* (copy-readtable nil)))
298               (load-system-file (string-downcase (string module-name))))))
299      (set-difference *modules* saved-modules))))
300
301(defun read-from-string (string &optional (eof-error-p t) eof-value
302                                &key (start 0) end preserve-whitespace)
303  (sys::%read-from-string string eof-error-p eof-value start end preserve-whitespace))
304
305(defconstant lambda-list-keywords
306  '(&optional &rest &key &aux &body &whole &allow-other-keys &environment))
307
308(defconstant call-arguments-limit 50)
309
310(defconstant lambda-parameters-limit 50)
311
312(defconstant multiple-values-limit 20)
313
314(defconstant internal-time-units-per-second 1000)
315
316(load-system-file "restart")
317(load-system-file "late-setf")
318(load-system-file "debug")
319(load-system-file "print")
320(load-system-file "pprint-dispatch")
321(load-system-file "pprint")
322
323(unless (sys::featurep :j)
324  (load-system-file "top-level")
325  (setf *warn-on-redefinition* t)
326  (%format t "Startup completed in ~A seconds.~%" (float (/ (ext:uptime) 1000))))
327
Note: See TracBrowser for help on using the repository browser.