DOLIST and DOTIMES use extended lambda lists

[jscl.git] / src / compiler.lisp

diff --git a/src/compiler.lisp b/src/compiler.lisp
index 8421b16..28918e3 100644 (file)
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -87,62 +87,6 @@
 ;;; function call.
 (defvar *multiple-value-p* nil)
 
-;; A very simple defstruct built on lists. It supports just slot with
-;; an optional default initform, and it will create a constructor,
-;; predicate and accessors for you.
-(defmacro def!struct (name &rest slots)
-  (unless (symbolp name)
-    (error "It is not a full defstruct implementation."))
-  (let* ((name-string (symbol-name name))
-         (slot-descriptions
-          (mapcar (lambda (sd)
-                    (cond
-                      ((symbolp sd)
-                       (list sd))
-                      ((and (listp sd) (car sd) (cddr sd))
-                       sd)
-                      (t
-                       (error "Bad slot description `~S'." sd))))
-                  slots))
-         (predicate (intern (concat name-string "-P"))))
-    `(progn
-       ;; Constructor
-       (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
-         (list ',name ,@(mapcar #'car slot-descriptions)))
-       ;; Predicate
-       (defun ,predicate (x)
-         (and (consp x) (eq (car x) ',name)))
-       ;; Copier
-       (defun ,(intern (concat "COPY-" name-string)) (x)
-         (copy-list x))
-       ;; Slot accessors
-       ,@(with-collect
-          (let ((index 1))
-            (dolist (slot slot-descriptions)
-              (let* ((name (car slot))
-                     (accessor-name (intern (concat name-string "-" (string name)))))
-                (collect
-                    `(defun ,accessor-name (x)
-                       (unless (,predicate x)
-                         (error "The object `~S' is not of type `~S'" x ,name-string))
-                       (nth ,index x)))
-                ;; TODO: Implement this with a higher level
-                ;; abstraction like defsetf or (defun (setf ..))
-                (collect
-                    `(define-setf-expander ,accessor-name (x)
-                       (let ((object (gensym))
-                             (new-value (gensym)))
-                         (values (list object)
-                                 (list x)
-                                 (list new-value)
-                                 `(progn
-                                    (rplaca (nthcdr ,',index ,object) ,new-value) 
-                                    ,new-value)
-                                 `(,',accessor-name ,object)))))
-                (incf index)))))
-       ',name)))
-
-
 ;;; Environment
 
 (def!struct binding
@@ -554,18 +498,27 @@
       (incf index))
     output))
 
-(defvar *literal-table* nil)
-(defvar *literal-counter* 0)
-
-;;; BOOTSTRAP MAGIC: During bootstrap, we record the macro definitions
-;;; as lists. Once everything is compiled, we want to dump the whole
-;;; global environment to the output file to reproduce it in the
+;;; BOOTSTRAP MAGIC: We record the macro definitions as lists during
+;;; the bootstrap. Once everything is compiled, we want to dump the
+;;; whole global environment to the output file to reproduce it in the
 ;;; run-time. However, the environment must contain expander functions
 ;;; rather than lists. We do not know how to dump function objects
-;;; itself, so we mark the definitions with this object and the
+;;; itself, so we mark the list definitions with this object and the
 ;;; compiler will be called when this object has to be dumped.
 ;;; Backquote/unquote does a similar magic, but this use is exclusive.
+;;;
+;;; Indeed, perhaps to compile the object other macros need to be
+;;; evaluated. For this reason we define a valid macro-function for
+;;; this symbol.
 (defvar *magic-unquote-marker* (gensym "MAGIC-UNQUOTE"))
+#+common-lisp
+(setf (macro-function *magic-unquote-marker*)
+      (lambda (form &optional environment)
+        (declare (ignore environment))
+        (second form)))
+
+(defvar *literal-table* nil)
+(defvar *literal-counter* 0)
 
 (defun genlit ()
   (code "l" (incf *literal-counter*)))
@@ -611,8 +564,12 @@
                          (symbol (dump-symbol sexp))
                          (string (dump-string sexp))
                          (cons
+                          ;; BOOTSTRAP MAGIC: See the root file
+                          ;; jscl.lisp and the function
+                          ;; `dump-global-environment' for futher
+                          ;; information.
                           (if (eq (car sexp) *magic-unquote-marker*)
-                              (ls-compile (cdr sexp))
+                              (ls-compile (second sexp))
                               (dump-cons sexp)))
                          (array (dump-array sexp)))))
            (if (and recursive (not (symbolp sexp)))
@@ -1670,7 +1627,7 @@
     ((and (consp form) (symbolp (car form)))
      (let ((macrofun (!macro-function (car form))))
        (if macrofun
-           (values (apply macrofun (cdr form)) t)
+           (values (funcall macrofun (cdr form)) t)
            (values form nil))))
     (t
      (values form nil))))