mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-25 22:12:40 -08:00
cmp: fix compiler macro for make-array
The previous version had several problems: argument evaluation order was not handled correctly and the compiler-macro produced an error for valid code like (let ((etype :element-type)) (make-array 10 etype 'character)) Introduce a new generally applicable macro define-compiler-macro* which fixes these issues.
This commit is contained in:
Marius Gerbershagen
parent
d54c110361
commit
23dde9625d
2 changed files with 226 additions and 10 deletions
|
|
@ -50,13 +50,11 @@
|
|||
(cmpwarn "The first argument to MAKE-ARRAY~%~A~%is not a valid set of dimensions" orig-dimensions)
|
||||
'*))))
|
||||
|
||||
(define-compiler-macro make-array (&whole form dimensions &key (element-type t)
|
||||
(initial-element nil initial-element-supplied-p)
|
||||
(initial-contents nil initial-contents-supplied-p)
|
||||
adjustable fill-pointer
|
||||
displaced-to (displaced-index-offset 0)
|
||||
&environment env)
|
||||
(declare (ignore env))
|
||||
(define-compiler-macro* make-array (&whole form dimensions &key (element-type t)
|
||||
(initial-element nil initial-element-supplied-p)
|
||||
(initial-contents nil initial-contents-supplied-p)
|
||||
adjustable fill-pointer
|
||||
displaced-to (displaced-index-offset 0))
|
||||
;; This optimization is always done unless we provide content. There
|
||||
;; is no speed, debug or space reason not to do it, unless the user
|
||||
;; specifies not to inline MAKE-ARRAY, but in that case the compiler
|
||||
|
|
@ -78,11 +76,11 @@
|
|||
(setf function 'si::make-vector
|
||||
dimensions (first dimensions-type)))
|
||||
(setf form
|
||||
`(,function ,element-type ,dimensions ,adjustable ,fill-pointer
|
||||
,displaced-to ,displaced-index-offset)))
|
||||
`(,function ,%element-type ,%dimensions ,%adjustable ,%fill-pointer
|
||||
,%displaced-to ,%displaced-index-offset)))
|
||||
;; Then we may fill the array with a given value
|
||||
(when initial-element-supplied-p
|
||||
(setf form `(si::fill-array-with-elt ,form ,initial-element 0 nil)))
|
||||
(setf form `(si::fill-array-with-elt ,form ,%initial-element 0 nil)))
|
||||
(setf form `(truly-the (array ,guessed-element-type ,dimensions-type)
|
||||
,form))))
|
||||
form)
|
||||
|
|
|
|||
|
|
@ -411,3 +411,221 @@
|
|||
(loop for line = (read-line stream nil nil)
|
||||
while line
|
||||
collect line))
|
||||
|
||||
(defmacro define-compiler-macro* (name lambda-list &body body)
|
||||
"A version of define-compiler-macro that helps avoiding incorrect
|
||||
evaluation order and double evaluation.
|
||||
|
||||
Example: A naive (simplified) definition of the compiler macro for
|
||||
make-array could look as follows
|
||||
|
||||
(define-compiler-macro make-array (&whole form dimensions &key (element-type t) ...)
|
||||
(let ((dimensions-type (guess-array-dimensions-type dimensions)))
|
||||
(if (and (listp dimensions-type)
|
||||
(null (rest dimensions-type))
|
||||
(integerp (first dimensions-type)))
|
||||
`(si::make-vector ,element-type ,(first dimensions-type) ...)
|
||||
`(si::make-pure-array ,element-type ,dimensions ...))))
|
||||
|
||||
However this has several problems: first element-type and dimensions
|
||||
are evaluated in the wrong order and second the compiler macro will
|
||||
not accept perfectly valid forms like
|
||||
|
||||
(let ((etype :element-type))
|
||||
(make-array 10 etype 'character))
|
||||
|
||||
A correct version could be implemented using define-compiler-macro* as
|
||||
follows
|
||||
|
||||
(define-compiler-macro make-array (&whole form dimensions &key (element-type t) ...)
|
||||
(let ((dimensions-type (guess-array-dimensions-type dimensions)))
|
||||
(if (and (listp dimensions-type)
|
||||
(null (rest dimensions-type))
|
||||
(integerp (first dimensions-type)))
|
||||
`(si::make-vector ,%element-type ,(first dimensions-type) ...)
|
||||
`(si::make-pure-array ,%element-type ,%dimensions ...))))
|
||||
|
||||
which would expand (make-array dim :element-type 'character) to
|
||||
|
||||
(let ((#:dimensions dim)
|
||||
(#:element-type 'character))
|
||||
(si::make-pure-array #:element-type #:dimensions))
|
||||
|
||||
Note that dimensions and element-type are evaluated in the correct
|
||||
order. In the case of (let ((etype :element-type))
|
||||
(make-array 10 etype 'character))
|
||||
the corrected version using define-compiler-macro* will simply
|
||||
decline to produce an expansion. On the other hand, for
|
||||
(make-array 10 :element-type 'character), the corrected version would
|
||||
expand to
|
||||
|
||||
(let ((#:dimensions 10)
|
||||
(#:element-type 'character))
|
||||
(si::make-vector #:element-type 10))
|
||||
|
||||
|
||||
How it works:
|
||||
|
||||
For each argument two let bindings are established: one for the
|
||||
variable holding the actual argument and one for a symbol (prefixed
|
||||
with %) which will be bound to the value that the argument evaluates
|
||||
to. In the compiler macro expansion, the % prefixed symbols are
|
||||
evaluated in the order in which the corresponding arguments are given
|
||||
to the compiler macro.
|
||||
|
||||
This allows the compiler-macro to look at the actual form provided for
|
||||
the arguments and also use these values produced by these forms in the
|
||||
final expansion.
|
||||
|
||||
Keyword arguments are handled specially: we try to match keywords in
|
||||
the list of arguments to the compiler macro to the corresponding &key
|
||||
arguments, but if we a non-keyword form in place where we expect a
|
||||
keyword argument, the compiler-macro declines to provide an expansion.
|
||||
"
|
||||
;; General info: parsing happens in three steps. In the first pass,
|
||||
;; the keyword arguments given to the compiler-macro are matched.
|
||||
;; Then the body of the compiler macro is evaluated. In the second
|
||||
;; pass, let bindings are constructed in the correct order for all
|
||||
;; arguments given to the compiler macro. In the third pass, let
|
||||
;; bindings for default initforms of arguments not given to the
|
||||
;; compiler-macro are constructed.
|
||||
(ext:with-unique-names (;; local vars
|
||||
given-keyword given-arg some-keyword-found output
|
||||
all-found-keywords
|
||||
;; bindings-for-expansion: these bindings
|
||||
;; are active around the expansion returned
|
||||
;; by the compiler macro
|
||||
bindings-for-expansion)
|
||||
(let* ((whole (gensym)) ; symbol for &whole compiler-macro argument
|
||||
(new-lambda-list (list whole '&whole)) ; lambda-list after we have stripped out &key, collected in reverse order
|
||||
aux-setf-forms ; forms for &aux vars
|
||||
parse-forms-pass1 parse-forms-pass2 parse-forms-pass3 ; lists of parse-forms generated below
|
||||
keyword-parse-forms-pass2
|
||||
;; bindings-for-body: these bindings are active around the
|
||||
;; body of the compiler macro
|
||||
(bindings-for-body (list all-found-keywords bindings-for-expansion)))
|
||||
;; lambda-list handling:
|
||||
;; 1. extract &whole and &environment
|
||||
(when (eq (first lambda-list) '&whole)
|
||||
(push `(,(second lambda-list) ,whole) bindings-for-body)
|
||||
(setf lambda-list (cddr lambda-list)))
|
||||
(when-let ((env (member '&environment lambda-list)))
|
||||
(push '&environment new-lambda-list)
|
||||
(push (second env) new-lambda-list)
|
||||
(setq lambda-list (nconc (ldiff lambda-list env) (cddr env))))
|
||||
;; 2. parse the remaining lambda-list
|
||||
(multiple-value-bind (reqs opts rest key-flag keywords allow-other-keys auxs)
|
||||
(si::process-lambda-list lambda-list 'si::macro)
|
||||
(when (and rest (or key-flag allow-other-keys))
|
||||
(error "define-compiler-macro* can't deal with lambda-lists with both &key and &rest arguments"))
|
||||
;; utility functions
|
||||
(labels ((prefix-symbol (s)
|
||||
(intern (concatenate 'string "%" (symbol-name s))))
|
||||
(pass1-parse ()
|
||||
(when key-flag
|
||||
`(progn
|
||||
(unless (zerop (mod (length ,rest) 2))
|
||||
(return-from ,name ,whole))
|
||||
(loop for ,given-keyword in ,rest by #'cddr
|
||||
for ,given-arg in (rest ,rest) by #'cddr
|
||||
for ,some-keyword-found = nil
|
||||
do (when (not (keywordp ,given-keyword))
|
||||
(return-from ,name ,whole))
|
||||
,@parse-forms-pass1
|
||||
(when (not ,some-keyword-found)
|
||||
(if ,allow-other-keys
|
||||
(push
|
||||
;; &allow-other-keys: we still
|
||||
;; have to evaluate the argument
|
||||
`(list ,(gensym) ,,given-arg)
|
||||
,bindings-for-expansion)
|
||||
(return-from ,name ,whole)))))))
|
||||
(handle-required-parameter (symbol)
|
||||
(let ((%symbol (prefix-symbol symbol)))
|
||||
(push `(,%symbol (gensym)) bindings-for-body)
|
||||
(push symbol new-lambda-list)
|
||||
(push `(push (list ,%symbol ,symbol) ,bindings-for-expansion)
|
||||
parse-forms-pass2)))
|
||||
(handle-optional-parameter (opt-spec)
|
||||
(let* ((symbol (first opt-spec))
|
||||
(init (second opt-spec))
|
||||
(supplied-p (or (third opt-spec) (gensym)))
|
||||
(%symbol (prefix-symbol symbol)))
|
||||
(push `(,%symbol (gensym)) bindings-for-body)
|
||||
(push `(,symbol ,init ,supplied-p) new-lambda-list)
|
||||
(push `(when ,supplied-p
|
||||
(push (list ,%symbol ,symbol) ,bindings-for-expansion))
|
||||
parse-forms-pass2)
|
||||
(push `(unless ,supplied-p
|
||||
(push (list ,%symbol ,symbol) ,bindings-for-expansion))
|
||||
parse-forms-pass3)))
|
||||
(handle-keyword-parameter (key-spec)
|
||||
(let* ((keyword (first key-spec))
|
||||
(symbol (second key-spec))
|
||||
(init (third key-spec))
|
||||
(supplied-p (or (fourth key-spec) (gensym)))
|
||||
(%symbol (prefix-symbol symbol)))
|
||||
(push `(,%symbol (gensym)) bindings-for-body)
|
||||
(push `(,symbol ,init) bindings-for-body)
|
||||
(push `(,supplied-p nil) bindings-for-body)
|
||||
(push `(when (and (eq ,given-keyword ,keyword)
|
||||
(not ,supplied-p))
|
||||
(setf ,some-keyword-found t)
|
||||
(setf ,symbol ,given-arg)
|
||||
(setf ,supplied-p t)
|
||||
(push ,keyword ,all-found-keywords))
|
||||
parse-forms-pass1)
|
||||
(push `(when (eq ,given-keyword ,keyword)
|
||||
(push (list ,%symbol ,symbol) ,bindings-for-expansion))
|
||||
keyword-parse-forms-pass2)
|
||||
(push `(unless ,supplied-p
|
||||
(push (list ,%symbol ,symbol) ,bindings-for-expansion))
|
||||
parse-forms-pass3))))
|
||||
;; 3. required, optional and rest parameters are simply
|
||||
;; copied to the new lambda-list
|
||||
(mapcar #'handle-required-parameter (rest reqs))
|
||||
(when (> (first opts) 0)
|
||||
(push '&optional new-lambda-list)
|
||||
(loop for o on (rest opts) by #'cdddr
|
||||
do (handle-optional-parameter o)))
|
||||
(when rest
|
||||
(let ((%rest (prefix-symbol rest)))
|
||||
(push `(,%rest (gensym)) bindings-for-body)
|
||||
(push `(push (list ,%rest ,rest) ,bindings-for-expansion)
|
||||
parse-forms-pass2)
|
||||
(push '&rest new-lambda-list)
|
||||
(push rest new-lambda-list)))
|
||||
;; 4. keyword parameters: first put all remaining parameters
|
||||
;; in a rest argument, then parse keywords from this rest
|
||||
;; argument
|
||||
(when (or key-flag allow-other-keys)
|
||||
(unless rest
|
||||
(setf rest (gensym))
|
||||
(push '&rest new-lambda-list)
|
||||
(push rest new-lambda-list))
|
||||
(loop for key-spec on (rest keywords) by #'cddddr
|
||||
do (handle-keyword-parameter key-spec))
|
||||
(push `(loop for ,given-keyword in (nreverse ,all-found-keywords)
|
||||
do ,@keyword-parse-forms-pass2)
|
||||
parse-forms-pass2))
|
||||
;; 5. &aux vars: these are simply set to their initforms after
|
||||
;; parsing of keywords has finished
|
||||
(loop for a on auxs
|
||||
do (push (first auxs) bindings-for-body)
|
||||
(push `(setf ,(first auxs) ,(second auxs)) aux-setf-forms))
|
||||
;; 6. Finally, we are ready to create the compiler-macro definition
|
||||
`(define-compiler-macro ,name ,(nreverse new-lambda-list)
|
||||
(let* ,(nreverse bindings-for-body)
|
||||
;; parse arguments
|
||||
,(pass1-parse)
|
||||
,@aux-setf-forms
|
||||
;; evaluate the body of the compiler-macro
|
||||
(let ((,output (locally ,@body)))
|
||||
(if (eq ,output ,whole)
|
||||
,whole
|
||||
(progn
|
||||
,@(nreverse parse-forms-pass2)
|
||||
,@(nreverse parse-forms-pass3)
|
||||
;; create bindings for the arguments passed to the compiler-macro
|
||||
`(let ,(nreverse ,bindings-for-expansion)
|
||||
,,output)))))))))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue