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

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

LAMBDA

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