defconstant uses eval-when

[jscl.git] / src / boot.lisp

diff --git a/src/boot.lisp b/src/boot.lisp
index 59b97a0..edfc576 100644 (file)
--- a/src/boot.lisp
+++ b/src/boot.lisp
@@ -22,13 +22,15 @@
 ;;; Lisp world from scratch. This code has to define enough language
 ;;; to the compiler to be able to run.
 
-(eval-when-compile
+(/debug "loading boot.lisp!")
+
+(eval-when (:compile-toplevel)
   (let ((defmacro-macroexpander
          '#'(lambda (form)
               (destructuring-bind (name args &body body)
                   form
                 (let ((whole (gensym)))
-                  `(eval-when-compile
+                  `(eval-when (:compile-toplevel :execute)
                      (%compile-defmacro ',name
                                         '#'(lambda (,whole)
                                              (destructuring-bind ,args ,whole
@@ -36,7 +38,7 @@
     (%compile-defmacro 'defmacro defmacro-macroexpander)))
 
 (defmacro declaim (&rest decls)
-  `(eval-when-compile
+  `(eval-when (:compile-toplevel :execute)
      ,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls)))
 
 (defmacro defconstant (name value &optional docstring)
@@ -44,7 +46,7 @@
      (declaim (special ,name))
      (declaim (constant ,name))
      (setq ,name ,value)
-     ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
+     ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
      ',name))
 
 (defconstant t 't)
@@ -64,13 +66,13 @@
   `(progn
      (declaim (special ,name))
      ,@(when value-p `((unless (boundp ',name) (setq ,name ,value))))
-     ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
+     ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
      ',name))
 
 (defmacro defparameter (name value &optional docstring)
   `(progn
      (setq ,name ,value)
-     ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
+     ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
      ',name))
 
 (defmacro defun (name args &rest body)
@@ -291,7 +293,9 @@
 
 (defmacro do (varlist endlist &body body)
   `(block nil
-     (let ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
+     (let ,(mapcar (lambda (x) (if (symbolp x)
+                                   (list x nil)
+                                 (list (first x) (second x)))) varlist)
        (while t
          (when ,(car endlist)
            (return (progn ,@(cdr endlist))))
@@ -299,13 +303,16 @@
          (psetq
           ,@(apply #'append
                    (mapcar (lambda (v)
-                             (and (consp (cddr v))
+                             (and (listp v)
+                                  (consp (cddr v))
                                   (list (first v) (third v))))
                            varlist)))))))
 
 (defmacro do* (varlist endlist &body body)
   `(block nil
-     (let* ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
+     (let* ,(mapcar (lambda (x1) (if (symbolp x1)
+                                     (list x1 nil)
+                                   (list (first x1) (second x1)))) varlist)
        (while t
          (when ,(car endlist)
            (return (progn ,@(cdr endlist))))
@@ -313,7 +320,8 @@
          (setq
           ,@(apply #'append
                    (mapcar (lambda (v)
-                             (and (consp (cddr v))
+                             (and (listp v)
+                                  (consp (cddr v))
                                   (list (first v) (third v))))
                            varlist)))))))
 
@@ -411,17 +419,6 @@
   (write-line (lambda-code (fdefinition function)))
   nil)
 
-(defun documentation (x type)
-  "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION."
-  (ecase type
-    (function
-     (let ((func (fdefinition x)))
-       (oget func "docstring")))
-    (variable
-     (unless (symbolp x)
-       (error "The type of documentation `~S' is not a symbol." type))
-     (oget x "vardoc"))))
-
 (defmacro multiple-value-bind (variables value-from &body body)
   `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
                           ,@body)
@@ -466,14 +463,15 @@
     ((null (cddr pairs))
      (let ((place (!macroexpand-1 (first pairs)))
            (value (second pairs)))
-       (multiple-value-bind (vars vals store-vars writer-form)
+       (multiple-value-bind (vars vals store-vars writer-form reader-form)
            (get-setf-expansion place)
          ;; TODO: Optimize the expansion a little bit to avoid let*
          ;; or multiple-value-bind when unnecesary.
          `(let* ,(mapcar #'list vars vals)
             (multiple-value-bind ,store-vars
                 ,value
-              ,writer-form)))))
+              ,writer-form
+              ,reader-form)))))
     (t
      `(progn
         ,@(do ((pairs pairs (cddr pairs))
@@ -487,16 +485,23 @@
     `(let ((,value ,x))
        (cond
          ,@(mapcar (lambda (c)
-                     (if (eq (car c) t)
-                         `((t ,@(rest c)))
+                     (if (find (car c) '(t otherwise))
+                         `(t ,@(rest c))
                          `((,(ecase (car c)
                                     (integer 'integerp)
                                     (cons 'consp)
+                                    (list 'listp)
+                                    (vector 'vectorp)
+                                    (character 'characterp)
+                                    (sequence 'sequencep)
                                     (symbol 'symbolp)
+                                    (function 'functionp)
+                                    (float 'floatp)
                                     (array 'arrayp)
                                     (string 'stringp)
                                     (atom 'atom)
-                                    (null 'null))
+                                    (null 'null)
+                                    (package 'packagep))
                              ,value)
                            ,@(or (rest c)
                                  (list nil)))))
@@ -507,7 +512,7 @@
     `(let ((,g!x ,x))
        (typecase ,g!x
          ,@clausules
-         (t (error "~X fell through etypeacase expression." ,g!x))))))
+         (t (error "~S fell through etypecase expression." ,g!x))))))
 
 (defun notany (fn seq)
   (not (some fn seq)))
@@ -531,3 +536,8 @@
 
 (defun error (fmt &rest args)
   (%throw (apply #'format nil fmt args)))
+
+(defmacro nth-value (n form)
+  `(multiple-value-call (lambda (&rest values)
+                          (nth ,n values))
+     ,form))