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

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

%READ-FROM-STRING => SYS::%READ-FROM-STRING

File size: 11.9 KB
Line 
1;;; boot.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: boot.lisp,v 1.99 2003-08-25 18:00:29 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
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 "debug.lisp")
114
115
116(defpackage "JVM" (:use "COMMON-LISP" "EXTENSIONS"))
117
118
119;;; PROVIDE, REQUIRE (from SBCL)
120(defun provide (module-name)
121  (pushnew (string module-name) *modules* :test #'string=)
122  t)
123
124(defun require (module-name &optional pathnames)
125  (finish-output)
126  (unless (member (string module-name) *modules* :test #'string=)
127    (let ((saved-modules (copy-list *modules*)))
128      (cond (pathnames
129             (unless (listp pathnames) (setf pathnames (list pathnames)))
130             (dolist (x pathnames)
131               (load x)))
132            (t
133             (sys::%load (concatenate 'string (string-downcase (string module-name))
134                                      ".lisp"))))
135      (set-difference *modules* saved-modules))))
136
137
138;;; Miscellany.
139
140(defun plusp (n)
141  (> n 0))
142
143(defun minusp (n)
144  (< n 0))
145
146(defun integerp (n)
147  (typep n 'integer))
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 call-arguments-limit 50)
154
155(defconstant lambda-parameters-limit 50)
156
157(defconstant multiple-values-limit 20)
158
159(defconstant char-code-limit 128)
160
161(defconstant internal-time-units-per-second 1000)
162
163
164;; AND, OR (from CMUCL)
165
166(defmacro and (&rest forms)
167  (cond ((endp forms) t)
168  ((endp (rest forms)) (first forms))
169  (t
170   `(if ,(first forms)
171        (and ,@(rest forms))
172        nil))))
173
174(defmacro or (&rest forms)
175  (cond ((endp forms) nil)
176  ((endp (rest forms)) (first forms))
177  (t
178   (let ((n-result (gensym)))
179     `(let ((,n-result ,(first forms)))
180        (if ,n-result
181      ,n-result
182      (or ,@(rest forms))))))))
183
184
185;; CASE (from CLISP)
186
187(defun case-expand (form-name test keyform clauses)
188  (let ((var (gensym)))
189    `(let ((,var ,keyform))
190       (cond
191        ,@(maplist
192           #'(lambda (remaining-clauses)
193              (let ((clause (first remaining-clauses))
194                    (remaining-clauses (rest remaining-clauses)))
195                (unless (consp clause)
196                  (error 'program-error "~S: missing key list" form-name))
197                (let ((keys (first clause)))
198                  `(,(cond ((or (eq keys 'T) (eq keys 'OTHERWISE))
199                            (if remaining-clauses
200                                (error 'program-error
201                                       "~S: the ~S clause must be the last one"
202                                       form-name keys)
203                                't))
204                           ((listp keys)
205                            `(or ,@(mapcar #'(lambda (key)
206                                              `(,test ,var ',key))
207                                           keys)))
208                           (t `(,test ,var ',keys)))
209                     ,@(rest clause)))))
210           clauses)))))
211
212(defmacro case (keyform &rest clauses)
213  (case-expand 'case 'eql keyform clauses))
214
215
216;; CCASE (from CLISP)
217
218(defun parenthesize-keys (clauses)
219  ;; PARENTHESIZE-KEYS is necessary to avoid confusing
220  ;; the symbols OTHERWISE and T used as keys, with the same
221  ;; symbols used in the syntax of the non exhaustive CASE.
222  (mapcar #'(lambda (c)
223             (cond ((or (eq (car c) 't)
224                        (eq (car c) 'otherwise))
225                    (cons (list (car c)) (cdr c)))
226                   (t c)))
227          clauses))
228
229(defmacro ccase (keyplace &rest clauses)
230  (let ((g (gensym))
231        (h (gensym)))
232    `(block ,g
233            (tagbody
234             ,h
235             (return-from ,g
236                          (case ,keyplace
237                            ,@(parenthesize-keys clauses)
238                            (otherwise
239                             (error 'type-error "CCASE error") ;; FIXME
240                             (go ,h))))))))
241
242
243;;; TYPECASE (from CLISP)
244
245(defmacro typecase (keyform &rest typeclauselist)
246  (let* ((tempvar (gensym))
247         (condclauselist nil))
248    (do ((typeclauselistr typeclauselist (cdr typeclauselistr)))
249        ((atom typeclauselistr))
250      (cond ((atom (car typeclauselistr))
251             (error 'program-error
252                    "invalid clause in ~S: ~S"
253                    'typecase (car typeclauselistr)))
254            ((let ((type (caar typeclauselistr)))
255               (or (eq type T) (eq type 'OTHERWISE)))
256             (push `(T ,@(or (cdar typeclauselistr) '(NIL))) condclauselist)
257             (return))
258            (t (push `((TYPEP ,tempvar (QUOTE ,(caar typeclauselistr)))
259                       ,@(or (cdar typeclauselistr) '(NIL)))
260                     condclauselist))))
261    `(LET ((,tempvar ,keyform)) (COND ,@(nreverse condclauselist)))))
262
263
264(defmacro etypecase (keyform &rest clauses)
265  (let ((var (gensym)))
266    `(let ((,var ,keyform))
267       (typecase ,var
268         ,@clauses
269         (otherwise
270          (error 'type-error "~S fell through ETYPECASE expression" ,var))))))
271
272
273(defmacro ctypecase (keyplace &rest clauses)
274  (let ((g (gensym))
275        (h (gensym)))
276    `(block ,g
277            (tagbody
278             ,h
279             (return-from ,g
280                          (typecase ,keyplace
281                            ,@clauses
282                            (otherwise
283                             (error 'type-error "CTYPECASE error") ;; FIXME
284                             (go ,h))))))))
285
286
287(defmacro cond (&rest clauses)
288  (if (endp clauses)
289      nil
290      (let ((clause (first clauses)))
291  (when (atom clause)
292    (error "COND clause is not a list: ~S" clause))
293  (let ((test (first clause))
294        (forms (rest clause)))
295    (if (endp forms)
296        (let ((n-result (gensym)))
297    `(let ((,n-result ,test))
298       (if ,n-result
299           ,n-result
300           (cond ,@(rest clauses)))))
301        `(if ,test
302       (progn ,@forms)
303       (cond ,@(rest clauses))))))))
304
305
306;;; PROG, PROG* (from GCL)
307
308(defmacro prog (vl &rest body &aux (decl nil))
309  (do ()
310      ((or (endp body)
311           (not (consp (car body)))
312           (not (eq (caar body) 'declare)))
313       `(block nil (let ,vl ,@decl (tagbody ,@body))))
314      (push (car body) decl)
315      (pop body)))
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
327;;; DOLIST (from CMUCL)
328
329;;; We repeatedly bind the var instead of setting it so that we never give the
330;;; var a random value such as NIL (which might conflict with a declaration).
331;;; If there is a result form, we introduce a gratitous binding of the variable
332;;; to NIL w/o the declarations, then evaluate the result form in that
333;;; environment.  We spuriously reference the gratuitous variable, since we
334;;; don't want to use IGNORABLE on what might be a special var.
335;;;
336(defmacro dolist ((var list &optional (result nil)) &body body)
337  (multiple-value-bind (forms decls)
338    (parse-body body nil nil)
339    (let ((n-list (gensym)))
340      `(do* ((,n-list ,list (cdr ,n-list)))
341      ((endp ,n-list)
342       ,@(if (constantp result)
343       `(,result)
344       `((let ((,var nil))
345           ,@decls
346           ,var
347           ,result))))
348         (let ((,var (car ,n-list)))
349           ,@decls
350           (tagbody
351            ,@forms))))))
352
353
354;;; From CMUCL.
355
356(defmacro with-output-to-string ((var &optional string &key element-type)
357         &body forms)
358  "If STRING is specified, it must be a string with a fill pointer;
359   the output is incrementally appended to the string (as if by use of
360   VECTOR-PUSH-EXTEND)."
361  (declare (ignore element-type))
362  (if string
363      `(let ((,var (sys::make-fill-pointer-output-stream ,string)))
364   (unwind-protect
365          (progn ,@forms)
366          (close ,var)))
367      `(let ((,var (make-string-output-stream)))
368   (unwind-protect
369          (progn ,@forms)
370          (close ,var))
371   (get-output-stream-string ,var))))
372
373
374(defmacro print-unreadable-object ((object stream &key type identity) &body body)
375  `(let ((s ,stream)
376         (obj ,object))
377     (format s "#<")
378     ,(when type
379        '(format s "~S" (type-of obj)))
380     ,(when (and type (or body identity))
381        '(format s " "))
382     ,@body
383     ,(when (and identity body)
384        '(format s " "))
385     ,(when identity
386        '(format s "@ ~A" (sys::hashcode-to-string obj)))
387     (format s ">")
388     nil))
Note: See TracBrowser for help on using the repository browser.