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

Last change on this file since 5164 was 5164, checked in by piso, 18 years ago

READ-CONDITIONAL

File size: 10.1 KB
Line 
1;;; boot.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: boot.lisp,v 1.138 2003-12-16 17:02:50 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 "COMMON-LISP")
21
22(setq ext:*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 defun (name lambda-list &rest body)
42  (list 'sys::%defun (list 'QUOTE name) (list 'QUOTE lambda-list) (list 'QUOTE body)))
43
44(defmacro defconstant (name initial-value &optional docstring)
45  (list 'sys::%defconstant (list 'QUOTE name) initial-value docstring))
46
47(defmacro defparameter (name initial-value &optional docstring)
48  (list 'sys::%defparameter (list 'QUOTE name) initial-value docstring))
49
50(sys::%load "autoloads.lisp")
51(sys::%load "early-defuns.lisp")
52(sys::%load "backquote.lisp")
53(sys::%load "setf.lisp")
54(sys::%load "documentation.lisp")
55
56(defmacro defvar (var &optional (val nil valp) (doc nil docp))
57  `(progn
58     (sys::%defvar ',var)
59     ,@(when valp
60   `((unless (boundp ',var)
61       (setq ,var ,val))))
62     ,@(when docp
63         `((setf (documentation ',var 'variable) ',doc)))
64     ',var))
65
66
67(defvar *features*
68  '(:armedbear))
69
70
71(defun make-package (package-name &key nicknames use)
72  (sys::%make-package package-name nicknames use))
73
74
75;;; READ-CONDITIONAL (from OpenMCL)
76
77(defconstant *keyword-package*
78  (find-package "KEYWORD"))
79
80(defun read-conditional (stream subchar int)
81  (cond (*read-suppress*
82         (read stream t nil t))
83        ((eql subchar (read-feature stream))
84         (read stream t nil t))
85        (t
86         (let* ((*read-suppress* t))
87           (read stream t nil t)))))
88
89(defun read-feature (stream)
90  (let* ((f (let* ((*package* *keyword-package*))
91              (read stream t nil t))))
92    (labels ((eval-feature (form)
93                           (cond ((atom form)
94                                  (ext:memql form *features*))
95                                 ((eq (car form) :not)
96                                  (not (eval-feature (cadr form))))
97                                 ((eq (car form) :and)
98                                  (dolist (subform (cdr form) t)
99                                    (unless (eval-feature subform) (return))))
100                                 ((eq (car form) :or)
101                                  (dolist (subform (cdr form) nil)
102                                    (when (eval-feature subform) (return t))))
103                                 (t (error "READ-FEATURE")))))
104            (if (eval-feature f) #\+ #\-))))
105
106(set-dispatch-macro-character #\# #\+ #'read-conditional)
107(set-dispatch-macro-character #\# #\- #'read-conditional)
108
109(make-package "JVM" :use '("COMMON-LISP" "EXTENSIONS"))
110(defvar jvm::*auto-compile* nil)
111(export 'jvm::*auto-compile* "JVM")
112
113(defun compile (name &optional definition)
114  (values (if name name definition) nil nil))
115
116(sys::%load "macros.lisp")
117(sys::%load "fixme.lisp")
118(sys::%load "destructuring-bind.lisp")
119(sys::%load "arrays.lisp")
120(sys::%load "compiler-macro.lisp")
121(sys::%load "precompiler.lisp")
122
123(sys::precompile-package "PRECOMPILER")
124(sys::precompile-package "EXTENSIONS")
125(sys::precompile-package "SYSTEM")
126(sys::precompile-package "COMMON-LISP")
127
128(sys::%load "signal.lisp")
129(sys::%load "list.lisp")
130(sys::%load "sequences.lisp")
131(sys::%load "error.lisp")
132(sys::%load "defpackage.lisp")
133(sys::%load "define-modify-macro.lisp")
134
135;;; PROVIDE, REQUIRE (from SBCL)
136(defun provide (module-name)
137  (pushnew (string module-name) *modules* :test #'string=)
138  t)
139
140(defun require (module-name &optional pathnames)
141  (unless (member (string module-name) *modules* :test #'string=)
142    (let ((saved-modules (copy-list *modules*)))
143      (cond (pathnames
144             (unless (listp pathnames) (setf pathnames (list pathnames)))
145             (dolist (x pathnames)
146               (load x)))
147            (t
148             (sys::%load (concatenate 'string (string-downcase (string module-name))
149                                      ".lisp"))))
150      (set-difference *modules* saved-modules))))
151
152(defun read-from-string (string &optional eof-error-p eof-value
153        &key (start 0) end preserve-whitespace)
154  (sys::%read-from-string string eof-error-p eof-value start end preserve-whitespace))
155
156(defconstant lambda-list-keywords
157  '(&optional &rest &key &aux &body &whole &allow-other-keys &environment))
158
159(defconstant call-arguments-limit 50)
160
161(defconstant lambda-parameters-limit 50)
162
163(defconstant multiple-values-limit 20)
164
165(defconstant char-code-limit 128)
166
167(defconstant internal-time-units-per-second 1000)
168
169(defconstant boole-clr    0)
170(defconstant boole-set    1)
171(defconstant boole-1      2)
172(defconstant boole-2      3)
173(defconstant boole-c1     4)
174(defconstant boole-c2     5)
175(defconstant boole-and    6)
176(defconstant boole-ior    7)
177(defconstant boole-xor    8)
178(defconstant boole-eqv    9)
179(defconstant boole-nand  10)
180(defconstant boole-nor   11)
181(defconstant boole-andc1 12)
182(defconstant boole-andc2 13)
183(defconstant boole-orc1  14)
184(defconstant boole-orc2  15)
185
186
187;; AND, OR (from CMUCL)
188
189(defmacro and (&rest forms)
190  (cond ((endp forms) t)
191  ((endp (rest forms)) (first forms))
192  (t
193   `(if ,(first forms)
194        (and ,@(rest forms))
195        nil))))
196
197(defmacro or (&rest forms)
198  (cond ((endp forms) nil)
199  ((endp (rest forms)) (first forms))
200  (t
201   (let ((n-result (gensym)))
202     `(let ((,n-result ,(first forms)))
203        (if ,n-result
204      ,n-result
205      (or ,@(rest forms))))))))
206
207(sys::%load "case.lisp")
208
209(defmacro cond (&rest clauses)
210  (if (endp clauses)
211      nil
212      (let ((clause (first clauses)))
213  (when (atom clause)
214    (error "COND clause is not a list: ~S" clause))
215  (let ((test (first clause))
216        (forms (rest clause)))
217    (if (endp forms)
218        (let ((n-result (gensym)))
219    `(let ((,n-result ,test))
220       (if ,n-result
221           ,n-result
222           (cond ,@(rest clauses)))))
223        `(if ,test
224       (progn ,@forms)
225       (cond ,@(rest clauses))))))))
226
227(defmacro dotimes ((var count &optional (result nil)) &body body)
228  (if (numberp count)
229      (let ((tag (gensym)))
230        `(block nil
231           (let ((,var 0))
232             (tagbody
233              ,tag
234              (if (>= ,var ,count)
235                  (return-from nil (progn ,result)))
236              ,@body
237              (setq ,var (1+ ,var))
238              (go ,tag)))))
239      (let ((limit (gensym))
240            (tag (gensym)))
241        `(block nil
242           (let ((,limit ,count)
243                 (,var 0))
244             (tagbody
245              ,tag
246              (if (>= ,var ,limit)
247                  (return-from nil (progn ,result)))
248              ,@body
249              (setq ,var (1+ ,var))
250              (go ,tag)))))))
251
252;;; DOLIST (from CMUCL)
253
254;;; We repeatedly bind the var instead of setting it so that we never give the
255;;; var a random value such as NIL (which might conflict with a declaration).
256;;; If there is a result form, we introduce a gratitous binding of the variable
257;;; to NIL w/o the declarations, then evaluate the result form in that
258;;; environment.  We spuriously reference the gratuitous variable, since we
259;;; don't want to use IGNORABLE on what might be a special var.
260;;;
261(defmacro dolist ((var list &optional (result nil)) &body body)
262  (multiple-value-bind (forms decls)
263    (sys::parse-body body nil nil)
264    (let ((n-list (gensym)))
265      `(do* ((,n-list ,list (cdr ,n-list)))
266      ((endp ,n-list)
267       ,@(if (constantp result)
268       `(,result)
269       `((let ((,var nil))
270           ,@decls
271           ,var
272           ,result))))
273         (let ((,var (car ,n-list)))
274           ,@decls
275           (tagbody
276            ,@forms))))))
277
278(defmacro do-symbols ((var &optional (package '*package*) (result nil)) &body body)
279  `(dolist (,var
280            (append (sys::package-symbols ,package)
281                    (sys::package-inherited-symbols ,package))
282            ,result)
283     ,@body))
284
285(defmacro do-external-symbols ((var &optional (package '*package*) (result nil)) &body body)
286  `(dolist (,var (sys::package-external-symbols ,package) ,result) ,@body))
287
288;;; From CMUCL.
289(defmacro with-output-to-string ((var &optional string &key element-type)
290         &body forms)
291  "If STRING is specified, it must be a string with a fill pointer;
292   the output is incrementally appended to the string (as if by use of
293   VECTOR-PUSH-EXTEND)."
294  (declare (ignore element-type))
295  (if string
296      `(let ((,var (sys::make-fill-pointer-output-stream ,string)))
297   (unwind-protect
298          (progn ,@forms)
299          (close ,var)))
300      `(let ((,var (make-string-output-stream)))
301   (unwind-protect
302          (progn ,@forms)
303          (close ,var))
304   (get-output-stream-string ,var))))
305
306
307;;; MULTIPLE-VALUE-BIND (from CLISP)
308(defmacro multiple-value-bind (varlist form &body body)
309  (let ((g (gensym))
310        (poplist nil))
311    (dolist (var varlist) (setq poplist (cons `(,var (pop ,g)) poplist)))
312    `(let* ((,g (multiple-value-list ,form)) ,@(nreverse poplist))
313           ,@body)))
314
315(sys::%load "late-setf.lisp")
316
317;; MULTIPLE-VALUE-SETQ (from CMUCL)
318(defmacro multiple-value-setq (varlist value-form)
319  (unless (and (listp varlist) (every #'symbolp varlist))
320    (error "~S is not a list of symbols" varlist))
321  `(values (setf (values ,@varlist) ,value-form)))
322
323(sys::%load "debug.lisp")
Note: See TracBrowser for help on using the repository browser.