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

Last change on this file since 4555 was 4555, checked in by piso, 19 years ago

(sys::%load "late-setf.lisp")

File size: 13.2 KB
Line 
1;;; boot.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: boot.lisp,v 1.121 2003-10-28 02:28:46 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
23(defmacro in-package (name)
24  (list 'sys::%in-package (string name)))
25
26
27(defmacro when (pred &rest body)
28  (list 'if pred (if (> (length body) 1)
29                     (append '(progn) body)
30                     (car body))))
31
32(defmacro unless (pred &rest body)
33  (list 'if (list 'not pred) (if (> (length body) 1)
34                                 (append '(progn) body)
35                                 (car body))))
36
37(defmacro defun (name lambda-list &rest body)
38  (list 'sys::%defun (list 'QUOTE name) (list 'QUOTE lambda-list) (list 'QUOTE body)))
39
40(defmacro defconstant (name initial-value &optional docstring)
41  (list 'sys::%defconstant (list 'QUOTE name) initial-value docstring))
42
43(defmacro defparameter (name initial-value &optional docstring)
44  (list 'sys::%defparameter (list 'QUOTE name) initial-value docstring))
45
46(sys::%load "autoloads.lisp")
47(sys::%load "early-defuns.lisp")
48(sys::%load "backquote.lisp")
49(sys::%load "setf.lisp")
50(sys::%load "documentation.lisp")
51
52(defmacro defvar (var &optional (val nil valp) (doc nil docp))
53  `(progn
54     (sys::%defvar ',var)
55     ,@(when valp
56   `((unless (boundp ',var)
57       (setq ,var ,val))))
58     ,@(when docp
59         `((setf (documentation ',var 'variable) ',doc)))
60     ',var))
61
62
63(defvar *features*
64  '(:armedbear))
65
66
67(defun make-package (package-name &key nicknames use)
68  (sys::%make-package package-name nicknames use))
69
70
71;;; READ-CONDITIONAL (from OpenMCL)
72
73(defconstant *keyword-package*
74  (find-package "KEYWORD"))
75
76(defun read-conditional (stream subchar int)
77  (cond (*read-suppress* (read stream t nil t) (values))
78        ((eql subchar (read-feature stream)) (read stream t nil t))
79        (t (let* ((*read-suppress* t))
80             (read stream t nil t)
81             (values)))))
82
83(defun read-feature (stream)
84  (let* ((f (let* ((*package* *keyword-package*))
85              (read stream t nil t))))
86    (labels ((eval-feature (form)
87                           (cond ((atom form)
88                                  (member form *features*))
89                                 ((eq (car form) :not)
90                                  (not (eval-feature (cadr form))))
91                                 ((eq (car form) :and)
92                                  (dolist (subform (cdr form) t)
93                                    (unless (eval-feature subform) (return))))
94                                 ((eq (car form) :or)
95                                  (dolist (subform (cdr form) nil)
96                                    (when (eval-feature subform) (return t))))
97                                 (t (error "READ-FEATURE")))))
98            (if (eval-feature f) #\+ #\-))))
99
100(set-dispatch-macro-character #\# #\+ #'read-conditional)
101(set-dispatch-macro-character #\# #\- #'read-conditional)
102
103(sys::%load "macros.lisp")
104(sys::%load "fixme.lisp")
105(sys::%load "destructuring-bind.lisp")
106(sys::%load "arrays.lisp")
107(sys::%load "compiler.lisp")
108(sys::%load "list.lisp")
109(sys::%load "sequences.lisp")
110(sys::%load "error.lisp")
111(sys::%load "defpackage.lisp")
112(sys::%load "define-modify-macro.lisp")
113
114(defpackage "JVM" (:use "COMMON-LISP" "EXTENSIONS"))
115
116(defvar jvm::*auto-compile* nil)
117
118(export 'jvm::*auto-compile* "JVM")
119
120;;; PROVIDE, REQUIRE (from SBCL)
121(defun provide (module-name)
122  (pushnew (string module-name) *modules* :test #'string=)
123  t)
124
125(defun require (module-name &optional pathnames)
126  (finish-output)
127  (unless (member (string module-name) *modules* :test #'string=)
128    (let ((saved-modules (copy-list *modules*)))
129      (cond (pathnames
130             (unless (listp pathnames) (setf pathnames (list pathnames)))
131             (dolist (x pathnames)
132               (load x)))
133            (t
134             (sys::%load (concatenate 'string (string-downcase (string module-name))
135                                      ".lisp"))))
136      (set-difference *modules* saved-modules))))
137
138(defun read-from-string (string &optional eof-error-p eof-value
139        &key (start 0) end preserve-whitespace)
140  (sys::%read-from-string string eof-error-p eof-value start end preserve-whitespace))
141
142(defconstant lambda-list-keywords
143  '(&optional &rest &key &aux &body &whole &allow-other-keys &environment))
144
145(defconstant call-arguments-limit 50)
146
147(defconstant lambda-parameters-limit 50)
148
149(defconstant multiple-values-limit 20)
150
151(defconstant char-code-limit 128)
152
153(defconstant internal-time-units-per-second 1000)
154
155(defconstant boole-clr    0)
156(defconstant boole-set    1)
157(defconstant boole-1      2)
158(defconstant boole-2      3)
159(defconstant boole-c1     4)
160(defconstant boole-c2     5)
161(defconstant boole-and    6)
162(defconstant boole-ior    7)
163(defconstant boole-xor    8)
164(defconstant boole-eqv    9)
165(defconstant boole-nand  10)
166(defconstant boole-nor   11)
167(defconstant boole-andc1 12)
168(defconstant boole-andc2 13)
169(defconstant boole-orc1  14)
170(defconstant boole-orc2  15)
171
172
173;; AND, OR (from CMUCL)
174
175(defmacro and (&rest forms)
176  (cond ((endp forms) t)
177  ((endp (rest forms)) (first forms))
178  (t
179   `(if ,(first forms)
180        (and ,@(rest forms))
181        nil))))
182
183(defmacro or (&rest forms)
184  (cond ((endp forms) nil)
185  ((endp (rest forms)) (first forms))
186  (t
187   (let ((n-result (gensym)))
188     `(let ((,n-result ,(first forms)))
189        (if ,n-result
190      ,n-result
191      (or ,@(rest forms))))))))
192
193
194;; CASE (from CLISP)
195
196(defun case-expand (form-name test keyform clauses)
197  (let ((var (gensym)))
198    `(let ((,var ,keyform))
199       (cond
200        ,@(maplist
201           #'(lambda (remaining-clauses)
202              (let ((clause (first remaining-clauses))
203                    (remaining-clauses (rest remaining-clauses)))
204                (unless (consp clause)
205                  (error 'program-error "~S: missing key list" form-name))
206                (let ((keys (first clause)))
207                  `(,(cond ((or (eq keys 'T) (eq keys 'OTHERWISE))
208                            (if remaining-clauses
209                                (error 'program-error
210                                       "~S: the ~S clause must be the last one"
211                                       form-name keys)
212                                't))
213                           ((listp keys)
214                            `(or ,@(mapcar #'(lambda (key)
215                                              `(,test ,var ',key))
216                                           keys)))
217                           (t `(,test ,var ',keys)))
218                     ,@(rest clause)))))
219           clauses)))))
220
221(defmacro case (keyform &rest clauses)
222  (case-expand 'case 'eql keyform clauses))
223
224
225;; CCASE (from CLISP)
226
227(defun parenthesize-keys (clauses)
228  ;; PARENTHESIZE-KEYS is necessary to avoid confusing
229  ;; the symbols OTHERWISE and T used as keys, with the same
230  ;; symbols used in the syntax of the non exhaustive CASE.
231  (mapcar #'(lambda (c)
232             (cond ((or (eq (car c) 't)
233                        (eq (car c) 'otherwise))
234                    (cons (list (car c)) (cdr c)))
235                   (t c)))
236          clauses))
237
238(defmacro ccase (keyplace &rest clauses)
239  (let ((g (gensym))
240        (h (gensym)))
241    `(block ,g
242            (tagbody
243             ,h
244             (return-from ,g
245                          (case ,keyplace
246                            ,@(parenthesize-keys clauses)
247                            (otherwise
248                             (error 'type-error "CCASE error") ;; FIXME
249                             (go ,h))))))))
250
251
252;;; TYPECASE (from CLISP)
253
254(defmacro typecase (keyform &rest typeclauselist)
255  (let* ((tempvar (gensym))
256         (condclauselist nil))
257    (do ((typeclauselistr typeclauselist (cdr typeclauselistr)))
258        ((atom typeclauselistr))
259      (cond ((atom (car typeclauselistr))
260             (error 'program-error
261                    "invalid clause in ~S: ~S"
262                    'typecase (car typeclauselistr)))
263            ((let ((type (caar typeclauselistr)))
264               (or (eq type T) (eq type 'OTHERWISE)))
265             (push `(T ,@(or (cdar typeclauselistr) '(NIL))) condclauselist)
266             (return))
267            (t (push `((TYPEP ,tempvar (QUOTE ,(caar typeclauselistr)))
268                       ,@(or (cdar typeclauselistr) '(NIL)))
269                     condclauselist))))
270    `(LET ((,tempvar ,keyform)) (COND ,@(nreverse condclauselist)))))
271
272
273(defmacro etypecase (keyform &rest clauses)
274  (let ((var (gensym)))
275    `(let ((,var ,keyform))
276       (typecase ,var
277         ,@clauses
278         (otherwise
279          (error 'type-error "~S fell through ETYPECASE expression" ,var))))))
280
281
282(defmacro ctypecase (keyplace &rest clauses)
283  (let ((g (gensym))
284        (h (gensym)))
285    `(block ,g
286            (tagbody
287             ,h
288             (return-from ,g
289                          (typecase ,keyplace
290                            ,@clauses
291                            (otherwise
292                             (error 'type-error "CTYPECASE error") ;; FIXME
293                             (go ,h))))))))
294
295
296(defmacro cond (&rest clauses)
297  (if (endp clauses)
298      nil
299      (let ((clause (first clauses)))
300  (when (atom clause)
301    (error "COND clause is not a list: ~S" clause))
302  (let ((test (first clause))
303        (forms (rest clause)))
304    (if (endp forms)
305        (let ((n-result (gensym)))
306    `(let ((,n-result ,test))
307       (if ,n-result
308           ,n-result
309           (cond ,@(rest clauses)))))
310        `(if ,test
311       (progn ,@forms)
312       (cond ,@(rest clauses))))))))
313
314
315;;; PROG, PROG* (from GCL)
316
317(defmacro prog (vl &rest body &aux (decl nil))
318  (do ()
319      ((or (endp body)
320           (not (consp (car body)))
321           (not (eq (caar body) 'declare)))
322       `(block nil (let ,vl ,@decl (tagbody ,@body))))
323      (push (car body) decl)
324      (pop body)))
325
326(defmacro prog* (vl &rest body &aux (decl nil))
327  (do ()
328      ((or (endp body)
329           (not (consp (car body)))
330           (not (eq (caar body) 'declare)))
331       `(block nil (let* ,vl ,@decl (tagbody ,@body))))
332      (push (car body) decl)
333      (pop body)))
334
335
336;;; DOTIMES (from CMUCL)
337(defmacro dotimes ((var count &optional (result nil)) &body body)
338  (cond ((numberp count)
339         `(do ((,var 0 (1+ ,var)))
340              ((>= ,var ,count) ,result)
341            ,@body))
342        (t (let ((v1 (gensym)))
343             `(do ((,var 0 (1+ ,var)) (,v1 ,count))
344                  ((>= ,var ,v1) ,result)
345                ,@body)))))
346
347
348;;; DOLIST (from CMUCL)
349
350;;; We repeatedly bind the var instead of setting it so that we never give the
351;;; var a random value such as NIL (which might conflict with a declaration).
352;;; If there is a result form, we introduce a gratitous binding of the variable
353;;; to NIL w/o the declarations, then evaluate the result form in that
354;;; environment.  We spuriously reference the gratuitous variable, since we
355;;; don't want to use IGNORABLE on what might be a special var.
356;;;
357(defmacro dolist ((var list &optional (result nil)) &body body)
358  (multiple-value-bind (forms decls)
359    (sys::parse-body body nil nil)
360    (let ((n-list (gensym)))
361      `(do* ((,n-list ,list (cdr ,n-list)))
362      ((endp ,n-list)
363       ,@(if (constantp result)
364       `(,result)
365       `((let ((,var nil))
366           ,@decls
367           ,var
368           ,result))))
369         (let ((,var (car ,n-list)))
370           ,@decls
371           (tagbody
372            ,@forms))))))
373
374
375;;; From CMUCL.
376
377(defmacro with-output-to-string ((var &optional string &key element-type)
378         &body forms)
379  "If STRING is specified, it must be a string with a fill pointer;
380   the output is incrementally appended to the string (as if by use of
381   VECTOR-PUSH-EXTEND)."
382  (declare (ignore element-type))
383  (if string
384      `(let ((,var (sys::make-fill-pointer-output-stream ,string)))
385   (unwind-protect
386          (progn ,@forms)
387          (close ,var)))
388      `(let ((,var (make-string-output-stream)))
389   (unwind-protect
390          (progn ,@forms)
391          (close ,var))
392   (get-output-stream-string ,var))))
393
394
395(defmacro print-unreadable-object ((object stream &key type identity) &body body)
396  `(let ((s ,stream)
397         (obj ,object))
398     (format s "#<")
399     ,(when type
400        '(format s "~S" (type-of obj)))
401     ,(when (and type (or body identity))
402        '(format s " "))
403     ,@body
404     ,(when (and identity body)
405        '(format s " "))
406     ,(when identity
407        '(format s "@ #x~A" (sys::hashcode-to-string obj)))
408     (format s ">")
409     nil))
410
411
412;;; MULTIPLE-VALUE-BIND (from CLISP)
413(defmacro multiple-value-bind (varlist form &body body)
414  (let ((g (gensym))
415        (poplist nil))
416    (dolist (var varlist) (setq poplist (cons `(,var (pop ,g)) poplist)))
417    `(let* ((,g (multiple-value-list ,form)) ,@(nreverse poplist))
418           ,@body)))
419
420(sys::%load "late-setf.lisp")
Note: See TracBrowser for help on using the repository browser.