From f6103bee62f1597449b51f6e4480ada375b279d3 Mon Sep 17 00:00:00 2001 From: =?utf8?q?David=20V=C3=A1zquez?= Date: Sun, 5 May 2013 19:49:17 +0100 Subject: [PATCH] DEFMACRO supports extended macro lambda lists It closes #11 --- jscl.lisp | 21 +++++++++++++++++++-- src/boot.lisp | 23 +++++++++++------------ src/compiler.lisp | 18 ++++++------------ src/lambda-list.lisp | 22 ++++++++++++++++++---- 4 files changed, 54 insertions(+), 30 deletions(-) diff --git a/jscl.lisp b/jscl.lisp index 47899f0..03654ed 100644 --- a/jscl.lisp +++ b/jscl.lisp @@ -43,6 +43,24 @@ (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*) @@ -78,7 +96,6 @@ (when (plusp (length compilation)) (write-string compilation out))))))) - (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) - (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. diff --git a/src/boot.lisp b/src/boot.lisp index 8778da2..d2bb0c1 100644 --- a/src/boot.lisp +++ b/src/boot.lisp @@ -23,18 +23,17 @@ ;;; 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 diff --git a/src/compiler.lisp b/src/compiler.lisp index 3dc2f1c..6eaa85d 100644 --- a/src/compiler.lisp +++ b/src/compiler.lisp @@ -501,16 +501,6 @@ (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*))) @@ -555,8 +545,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))) @@ -1614,7 +1608,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)))) diff --git a/src/lambda-list.lisp b/src/lambda-list.lisp index e217333..a0df680 100644 --- a/src/lambda-list.lisp +++ b/src/lambda-list.lisp @@ -217,11 +217,11 @@ (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 '())) - (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 @@ -308,6 +308,20 @@ ,@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 -(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))) -- 1.7.10.4