DEFMACRO supports extended macro lambda lists

It closes #11

diff --git a/jscl.lisp b/jscl.lisp
index 47899f0..03654ed 100644 (file)
--- a/jscl.lisp
+++ b/jscl.lisp
@@ -43,6 +43,24 @@
       (make-pathname :type type :directory directory :defaults defaults)
       (make-pathname            :directory directory :defaults defaults)))
 
       (make-pathname :type type :directory directory :defaults defaults)
       (make-pathname            :directory directory :defaults defaults)))
 

+;;; 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 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"))
+(setf (macro-function *magic-unquote-marker*)
+      (lambda (form env)
+        (declare (ignore env))
+        (second form)))
+

 ;;; Compile jscl into the host
 (with-compilation-unit ()
   (dolist (input *source*)
 ;;; Compile jscl into the host
 (with-compilation-unit ()
   (dolist (input *source*)

@@ -78,7 +96,6 @@
               (when (plusp (length compilation))
                 (write-string compilation out)))))))
 
               (when (plusp (length compilation))
                 (write-string compilation out)))))))
 

-

 (defun dump-global-environment (stream)
   (flet ((late-compile (form)
            (write-string (ls-compile-toplevel form) stream)))
 (defun dump-global-environment (stream)
   (flet ((late-compile (form)
            (write-string (ls-compile-toplevel form) stream)))

@@ -86,7 +103,7 @@
     ;; for the compiler and it can be dumped.
     (dolist (b (lexenv-function *environment*))
       (when (eq (binding-type b) 'macro)
     ;; for the compiler and it can be dumped.
     (dolist (b (lexenv-function *environment*))
       (when (eq (binding-type b) 'macro)

-        (push *magic-unquote-marker* (binding-value b))))
+        (setf (binding-value b) `(,*magic-unquote-marker* ,(binding-value b)))))

     (late-compile `(setq *environment* ',*environment*))
     ;; Set some counter variable properly, so user compiled code will
     ;; not collide with the compiler itself.
     (late-compile `(setq *environment* ',*environment*))
     ;; Set some counter variable properly, so user compiled code will
     ;; not collide with the compiler itself.

diff --git a/src/boot.lisp b/src/boot.lisp
index 8778da2..d2bb0c1 100644 (file)
--- a/src/boot.lisp
+++ b/src/boot.lisp
@@ -23,18 +23,17 @@
 ;;; to the compiler to be able to run.
 
 (eval-when-compile
 ;;; to the compiler to be able to run.
 
 (eval-when-compile

-  (%compile-defmacro 'defmacro
-                     '(function
-                       (lambda (name args &rest body)
-                        `(eval-when-compile
-                           (%compile-defmacro ',name
-                                              '(function
-                                                (lambda ,(mapcar #'(lambda (x)
-                                                                     (if (eq x '&body)
-                                                                         '&rest
-                                                                         x))
-                                                                 args)
-                                                 ,@body))))))))
+  (let ((defmacro-macroexpander
+         '#'(lambda (form)
+              (destructuring-bind (name args &body body)
+                  form
+                (let ((whole (gensym)))
+                  `(eval-when-compile
+                     (%compile-defmacro ',name
+                                        '#'(lambda (,whole)
+                                             (destructuring-bind ,args ,whole
+                                               ,@body)))))))))
+    (%compile-defmacro 'defmacro defmacro-macroexpander)))

 
 (defmacro declaim (&rest decls)
   `(eval-when-compile
 
 (defmacro declaim (&rest decls)
   `(eval-when-compile

diff --git a/src/compiler.lisp b/src/compiler.lisp
index 3dc2f1c..6eaa85d 100644 (file)
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -501,16 +501,6 @@
 (defvar *literal-table* nil)
 (defvar *literal-counter* 0)
 
 (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
-;;; 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
-;;; compiler will be called when this object has to be dumped.
-;;; Backquote/unquote does a similar magic, but this use is exclusive.
-(defvar *magic-unquote-marker* (gensym "MAGIC-UNQUOTE"))
-

 (defun genlit ()
   (code "l" (incf *literal-counter*)))
 
 (defun genlit ()
   (code "l" (incf *literal-counter*)))
 

@@ -555,8 +545,12 @@
                          (symbol (dump-symbol sexp))
                          (string (dump-string sexp))
                          (cons
                          (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*)
                           (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)))
                               (dump-cons sexp)))
                          (array (dump-array sexp)))))
            (if (and recursive (not (symbolp sexp)))

@@ -1614,7 +1608,7 @@
     ((and (consp form) (symbolp (car form)))
      (let ((macrofun (!macro-function (car form))))
        (if macrofun
     ((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))))
            (values form nil))))
     (t
      (values form nil))))

diff --git a/src/lambda-list.lisp b/src/lambda-list.lisp
index e217333..a0df680 100644 (file)
--- a/src/lambda-list.lisp
+++ b/src/lambda-list.lisp
@@ -217,11 +217,11 @@
       (unless (consp tail)
         (error "Odd number of keyword arguments.")))))
 
       (unless (consp tail)
         (error "Odd number of keyword arguments.")))))
 

-(defmacro !destructuring-bind (lambda-list expression &body body)
+(defun !destructuring-bind-macro-function (lambda-list expression &rest body)

   (multiple-value-bind (d-ll)
       (parse-destructuring-lambda-list lambda-list)
     (let ((bindings '()))
   (multiple-value-bind (d-ll)
       (parse-destructuring-lambda-list lambda-list)
     (let ((bindings '()))

-      (labels (;; Return a chain of the form (CAR (CDR (CDR ... (CDR X))),
+      (labels ( ;; Return a chain of the form (CAR (CDR (CDR ... (CDR X))),

                ;; such that there are N calls to CDR.
                (nth-chain (x n &optional tail)
                  (if tail
                ;; such that there are N calls to CDR.
                (nth-chain (x n &optional tail)
                  (if tail

@@ -308,6 +308,20 @@
                ,@body)))))))
 
 
                ,@body)))))))
 
 

+;;; Because DEFMACRO uses destructuring-bind to parse the arguments of
+;;; the macro-function, we can't define DESTRUCTURING-BIND with
+;;; defmacro to avoid a circularity. So just define the macro function
+;;; explicitly.
+
+#+common-lisp
+(defmacro !destructuring-bind (lambda-list expression &body body)
+  (apply #'!destructuring-bind-macro-function lambda-list expression body))
+

 #+jscl
 #+jscl

-(defmacro destructuring-bind (lambda-list expression &body body)
-  `(!destructuring-bind ,lambda-list ,expression ,@body))
+(eval-when-compile
+  (let ((macroexpander
+         '#'(lambda (form &optional environment)
+              (declare (ignore environment))
+              (apply #'!destructuring-bind-macro-function form))))
+    (%compile-defmacro '!destructuring-bind macroexpander)
+    (%compile-defmacro  'destructuring-bind macroexpander)))