From cce2b39f1059fae462ca8e85e81522e4c3199b61 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 30 Jun 2015 08:06:53 +0200 Subject: [PATCH] define-compiler-macro: clhs compliance MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This change is incorporated from CLASP. Fixes #82. Signed-off-by: Daniel Kochmański --- src/lsp/defmacro.lsp | 25 ++++++++++++++++++------- src/lsp/evalmacros.lsp | 4 ++-- 2 files changed, 20 insertions(+), 9 deletions(-) diff --git a/src/lsp/defmacro.lsp b/src/lsp/defmacro.lsp index d058eaa46..85bfa8a50 100644 --- a/src/lsp/defmacro.lsp +++ b/src/lsp/defmacro.lsp @@ -107,7 +107,15 @@ (ppn (+ (length reqs) (first opts))) all-keywords) ;; In macros, eliminate the name of the macro from the list - (dm-v pointer (if macro `(cdr (truly-the cons ,whole)) whole)) + (dm-v pointer (if macro + ;; Special handling if define-compiler-macro called this + (if (eq macro 'define-compiler-macro) + `(if (and (eq (car ,whole) 'cl:funcall) + (eq (caadr ,whole) 'cl:function)) + (cddr (truly-the cons ,whole)) + (cdr (truly-the cons ,whole))) + `(cdr (truly-the cons ,whole))) + whole)) (dolist (v (cdr reqs)) (dm-v v `(progn (if (null ,pointer) @@ -155,7 +163,8 @@ (dm-v (v init) (cond ((and v (symbolp v)) - (push (if init (list v init) v) *dl*)) + (let ((push-val (if init (list v init) v))) + (push push-val *dl*))) ((and v (atom v)) (error "destructure: ~A is not a list nor a symbol" v)) ((eq (first v) '&whole) @@ -168,8 +177,9 @@ (dm-v whole-var init)) (dm-vl (cddr v) whole-var nil))) (t - (let ((temp (tempsym))) - (push (if init (list temp init) temp) *dl*) + (let* ((temp (tempsym)) + (push-val (if init (list temp init) temp))) + (push push-val *dl*) (dm-vl v temp nil)))))) (let* ((whole basis-form) @@ -233,9 +243,10 @@ (values (if decls `((declare ,@decls)) nil) body doc))) -(defun sys::expand-defmacro (name vl body) +;; Optional argument context can be 'cl:define-compiler-macro or 'cl:defmacro (default) +(defun sys::expand-defmacro (name vl body &optional (context 'cl:defmacro)) (multiple-value-bind (decls body doc) - (find-declarations body) + (find-declarations body) ;; We turn (a . b) into (a &rest b) ;; This is required because MEMBER (used below) does not like improper lists (let ((cell (last vl))) @@ -250,7 +261,7 @@ (setq env (gensym) decls (list* `(declare (ignore ,env)) decls))) (multiple-value-bind (ppn whole dl arg-check ignorables) - (destructure vl t) + (destructure vl context) (values `(ext::lambda-block ,name (,whole ,env &aux ,@dl) (declare (ignorable ,@ignorables)) ,@decls diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index c42ed480f..a7b87afa3 100644 --- a/src/lsp/evalmacros.lsp +++ b/src/lsp/evalmacros.lsp @@ -111,7 +111,7 @@ VARIABLE doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'VARIABLE)." ;;; (defmacro define-compiler-macro (&whole whole name vl &rest body) (multiple-value-bind (function pprint doc-string) - (sys::expand-defmacro name vl body) + (sys::expand-defmacro name vl body 'cl:define-compiler-macro) (declare (ignore pprint)) (setq function `(function ,function)) (when *dump-defun-definitions* @@ -125,7 +125,7 @@ VARIABLE doc and can be retrieved by (DOCUMENTATION 'SYMBOL 'VARIABLE)." (defun compiler-macro-function (name &optional env) (declare (ignorable env)) - (get-sysprop name 'sys::compiler-macro)) + (values (get-sysprop name 'sys::compiler-macro))) ;;; Each of the following macros is also defined as a special form, ;;; as required by CLtL. Some of them are used by the compiler (e.g.