| 1 | ;;; boot.lisp |
|---|
| 2 | ;;; |
|---|
| 3 | ;;; Copyright (C) 2003 Peter Graves |
|---|
| 4 | ;;; $Id: boot.lisp,v 1.118 2003-10-18 22:34: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 | |
|---|
| 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 | (setq *load-verbose* t) |
|---|
