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

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

(setq ext:*autoload-verbose* nil)
(setq *load-verbose* nil)

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