mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-01 02:00:36 -08:00
Code Issues Projects Releases Packages Wiki Activity

define-compiler-macro: clhs compliance

Browse source 
This change is incorporated from CLASP. Fixes #82.

Signed-off-by: Daniel Kochmański <dkochmanski@turtle-solutions.eu>
This commit is contained in:
Daniel Kochmański 2015-06-30 08:06:53 +02:00
parent 2b1892a47e
commit cce2b39f10
2 changed files with 20 additions and 9 deletions
Download patch file Download diff file Expand all files Collapse all files

25
src/lsp/defmacro.lsp
View file

@ -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

4
src/lsp/evalmacros.lsp
View file

@ -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.