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

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

%load => sys::%load

File size: 9.5 KB
Line 
1;;; boot.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: boot.lisp,v 1.91 2003-08-16 13:24:13 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(defvar *features*
41  '(:armedbear))
42
43
44(defun make-package (package-name &key nicknames use)
45  (sys::%make-package package-name nicknames use))
46
47
48;;; READ-CONDITIONAL (from OpenMCL)
49
50(defconstant *keyword-package*
51  (find-package "KEYWORD"))
52
53(defun read-conditional (stream subchar int)
54  (cond (*read-suppress* (read stream t nil t) (values))
55        ((eql subchar (read-feature stream)) (read stream t nil t))
56        (t (let* ((*read-suppress* t))
57             (read stream t nil t)
58             (values)))))
59
60(defun read-feature (stream)
61  (let* ((f (let* ((*package* *keyword-package*))
62              (read stream t nil t))))
63    (labels ((eval-feature (form)
64                           (cond ((atom form)
65                                  (member form *features*))
66                                 ((eq (car form) :not)
67                                  (not (eval-feature (cadr form))))
68                                 ((eq (car form) :and)
69                                  (dolist (subform (cdr form) t)
70                                    (unless (eval-feature subform) (return))))
71                                 ((eq (car form) :or)
72                                  (dolist (subform (cdr form) nil)
73                                    (when (eval-feature subform) (return t))))
74                                 (t (error "READ-FEATURE")))))
75            (if (eval-feature f) #\+ #\-))))
76
77(set-dispatch-macro-character #\# #\+ #'read-conditional)
78(set-dispatch-macro-character #\# #\- #'read-conditional)
79
80
81(sys::%load "autoloads.lisp")
82(sys::%load "early-defuns.lisp")
83(sys::%load "backquote.lisp")
84(sys::%load "setf.lisp")
85(sys::%load "macros.lisp")
86(sys::%load "fixme.lisp")
87(sys::%load "destructuring-bind.lisp")
88(sys::%load "arrays.lisp")
89(sys::%load "compiler.lisp")
90(sys::%load "list.lisp")
91(sys::%load "sequences.lisp")
92(sys::%load "error.lisp")
93(sys::%load "defpackage.lisp")
94(sys::%load "debug.lisp")
95
96
97(defpackage "JVM" (:use "COMMON-LISP" "EXTENSIONS"))
98
99
100;;; PROVIDE, REQUIRE (from SBCL)
101(defun provide (module-name)
102  (pushnew (string module-name) *modules* :test #'string=)
103  t)
104
105(defun require (module-name &optional pathnames)
106  (finish-output)
107  (unless (member (string module-name) *modules* :test #'string=)
108    (let ((saved-modules (copy-list *modules*)))
109      (cond (pathnames
110             (unless (listp pathnames) (setf pathnames (list pathnames)))
111             (dolist (x pathnames)
112               (load x)))
113            (t
114             (sys::%load (concatenate 'string (string-downcase (string module-name))
115                                      ".lisp"))))
116      (set-difference *modules* saved-modules))))
117
118
119;;; Miscellany.
120
121(defun plusp (n)
122  (> n 0))
123
124(defun minusp (n)
125  (< n 0))
126
127(defun integerp (n)
128  (typep n 'integer))
129
130(defun read-from-string (string &optional eof-error-p eof-value
131        &key (start 0) end preserve-whitespace)
132  (%read-from-string string eof-error-p eof-value start end preserve-whitespace))
133
134(defconstant call-arguments-limit 50)
135
136(defconstant lambda-parameters-limit 50)
137
138(defconstant multiple-values-limit 20)
139
140(defconstant char-code-limit 128)
141
142(defconstant internal-time-units-per-second 1000)
143
144
145;; AND, OR (from CMUCL)
146
147(defmacro and (&rest forms)
148  (cond ((endp forms) t)
149  ((endp (rest forms)) (first forms))
150  (t
151   `(if ,(first forms)
152        (and ,@(rest forms))
153        nil))))
154
155(defmacro or (&rest forms)
156  (cond ((endp forms) nil)
157  ((endp (rest forms)) (first forms))
158  (t
159   (let ((n-result (gensym)))
160     `(let ((,n-result ,(first forms)))
161        (if ,n-result
162      ,n-result
163      (or ,@(rest forms))))))))
164
165
166;; CASE (from CLISP)
167
168(defun case-expand (form-name test keyform clauses)
169  (let ((var (gensym)))
170    `(let ((,var ,keyform))
171       (cond
172        ,@(maplist
173           #'(lambda (remaining-clauses)
174              (let ((clause (first remaining-clauses))
175                    (remaining-clauses (rest remaining-clauses)))
176                (unless (consp clause)
177                  (error 'program-error "~S: missing key list" form-name))
178                (let ((keys (first clause)))
179                  `(,(cond ((or (eq keys 'T) (eq keys 'OTHERWISE))
180                            (if remaining-clauses
181                                (error 'program-error
182                                       "~S: the ~S clause must be the last one"
183                                       form-name keys)
184                                't))
185                           ((listp keys)
186                            `(or ,@(mapcar #'(lambda (key)
187                                              `(,test ,var ',key))
188                                           keys)))
189                           (t `(,test ,var ',keys)))
190                     ,@(rest clause)))))
191           clauses)))))
192
193(defmacro case (keyform &body clauses)
194  (case-expand 'case 'eql keyform clauses))
195
196
197;;; TYPECASE (from CLISP)
198
199(defmacro typecase (keyform &rest typeclauselist)
200  (let* ((tempvar (gensym))
201         (condclauselist nil))
202    (do ((typeclauselistr typeclauselist (cdr typeclauselistr)))
203        ((atom typeclauselistr))
204      (cond ((atom (car typeclauselistr))
205             (error 'program-error
206                    "invalid clause in ~S: ~S"
207                    'typecase (car typeclauselistr)))
208            ((let ((type (caar typeclauselistr)))
209               (or (eq type T) (eq type 'OTHERWISE)))
210             (push `(T ,@(or (cdar typeclauselistr) '(NIL))) condclauselist)
211             (return))
212            (t (push `((TYPEP ,tempvar (QUOTE ,(caar typeclauselistr)))
213                       ,@(or (cdar typeclauselistr) '(NIL)))
214                     condclauselist))))
215    `(LET ((,tempvar ,keyform)) (COND ,@(nreverse condclauselist)))))
216
217
218(defmacro cond (&rest clauses)
219  (if (endp clauses)
220      nil
221      (let ((clause (first clauses)))
222  (when (atom clause)
223    (error "COND clause is not a list: ~S" clause))
224  (let ((test (first clause))
225        (forms (rest clause)))
226    (if (endp forms)
227        (let ((n-result (gensym)))
228    `(let ((,n-result ,test))
229       (if ,n-result
230           ,n-result
231           (cond ,@(rest clauses)))))
232        `(if ,test
233       (progn ,@forms)
234       (cond ,@(rest clauses))))))))
235
236
237;;; PROG, PROG* (from GCL)
238
239(defmacro prog (vl &rest body &aux (decl nil))
240  (do ()
241      ((or (endp body)
242           (not (consp (car body)))
243           (not (eq (caar body) 'declare)))
244       `(block nil (let ,vl ,@decl (tagbody ,@body))))
245      (push (car body) decl)
246      (pop body)))
247
248(defmacro prog* (vl &rest body &aux (decl nil))
249  (do ()
250      ((or (endp body)
251           (not (consp (car body)))
252           (not (eq (caar body) 'declare)))
253       `(block nil (let* ,vl ,@decl (tagbody ,@body))))
254      (push (car body) decl)
255      (pop body)))
256
257
258;;; DOLIST (from CMUCL)
259
260;;; We repeatedly bind the var instead of setting it so that we never give the
261;;; var a random value such as NIL (which might conflict with a declaration).
262;;; If there is a result form, we introduce a gratitous binding of the variable
263;;; to NIL w/o the declarations, then evaluate the result form in that
264;;; environment.  We spuriously reference the gratuitous variable, since we
265;;; don't want to use IGNORABLE on what might be a special var.
266;;;
267(defmacro dolist ((var list &optional (result nil)) &body body)
268  (multiple-value-bind (forms decls)
269    (parse-body body nil nil)
270    (let ((n-list (gensym)))
271      `(do* ((,n-list ,list (cdr ,n-list)))
272      ((endp ,n-list)
273       ,@(if (constantp result)
274       `(,result)
275       `((let ((,var nil))
276           ,@decls
277           ,var
278           ,result))))
279         (let ((,var (car ,n-list)))
280           ,@decls
281           (tagbody
282            ,@forms))))))
283
284
285;;; From CMUCL.
286
287(defmacro with-output-to-string ((var &optional string &key element-type)
288         &body forms)
289  "If STRING is specified, it must be a string with a fill pointer;
290   the output is incrementally appended to the string (as if by use of
291   VECTOR-PUSH-EXTEND)."
292  (declare (ignore element-type))
293  (if string
294      `(let ((,var (sys::make-fill-pointer-output-stream ,string)))
295   (unwind-protect
296          (progn ,@forms)
297          (close ,var)))
298      `(let ((,var (make-string-output-stream)))
299   (unwind-protect
300          (progn ,@forms)
301          (close ,var))
302   (get-output-stream-string ,var))))
Note: See TracBrowser for help on using the repository browser.