;;;
;;; DEFINE-DECL-MACRO
;;;
;;; A Common Lisp macro which provides a concise, easy notation for
;;; writing macros which insert declarations into binding constructs.
;;;
;;; Written by Kaz Kylheku <········@gmail.com>
;;; Version 9
;;; December 4, 2006
;;;
#|
;;; Best explained with examples!
;;; Write a macro called DECLARATIVE-LET which expands into LET.
;;; The &VAR-LIST symbol tells DEFINE-DECL-MACRO where in the LET
;;; form is the list of variable bindings located. The &BODY
;;; symbol indicates where the body of declarations and forms is.
;;; That's it!
(define-decl-macro declarative-let
(let &var-list &body))
;;; Now use the macro
(declarative-let ((x integer 3) (y string) z)
(setf y "abc")
(push x z))
;;; What does the expansion look like? The type declarations
;;; are removed from the &VAR-LIST, and are transferred to the &BODY.
(macroexpand '(declarative-let ((x integer 3) (y string) z)
(setf y "abc")
(push x z)))
--> (LET ((X 3) Y Z)
(DECLARE (TYPE INTEGER X) (TYPE STRING Y))
(SETF Y "abc")
(PUSH X Z))
;;;
;;; Let's illustrate deeper nesting by wrapping DESTRUCTURING-BIND.
;;; Without destructuring lambda list support in our macro, we
;;; can't do this in a general way for all possible instances of
;;; DESTRUCTURING-BIND, but we can add declarations to particular
;;; kinds of instances of DESTRUCTURING-BIND.
;;;
;;;
;;; Add declarations to forms patterned after:
;;;
;;; (destructuring-bind ((a b c ...) (i j k ...)) ...)
;;;
(define-decl-macro decl-double-destructure
(destructuring-bind (&var-list &var-list) ¶m &body))
(macroexpand-1 '(decl-double-destructure (((a fixnum 3) (b fixnum 4))
((c string) (d string)))
some-list
(form1)
(form2)))
--> (DESTRUCTURING-BIND ((A B) (C D))
(DECLARE (TYPE FIXNUM A) (TYPE FIXNUM B)
(TYPE STRING C) (TYPE STRING D))
SOME-LIST
(FORM1) (FORM2))
;;;
;;; How to define a version of DEFUN:
;;;
;;; &PARAM matches function name
;;; &LAMBDA list is scanned for declarations
;;; &RESULT-TYPE specifies where the type for the body goes
;;; &BODY is wrapped with declarations
;;;
(define-decl-macro decl-defun
(defun ¶m &lambda-list &result-type &body))
(decl-defun add ((a integer) (b integer)) integer
(+ a b))
;;;
;;; LABELS with declarations:
;;;
;;; Note how the functions matched by &FUNCTION-LIST are not
;;; only used to gather FTYPE declarations for the LABELS body,
;;; but are also themselves transformed to regular syntax with
;;; declarations in their own bodies.
;;;
(define-decl-macro decl-labels (labels &function-list &body))
(macroexpand-1 '(decl-labels ((f1 ((x float) (y integer)) float
body)
(f2 ((x complex) (y bignum)) t
body2))
body3 body4))
--> (LABELS ((F1 (X Y)
(DECLARE (TYPE FLOAT X) (TYPE INTEGER Y))
(THE FLOAT (PROGN BODY)))
(F2 (X Y)
(DECLARE (TYPE COMPLEX X) (TYPE BIGNUM Y))
BODY2))
(DECLARE (FTYPE (FUNCTION (FLOAT INTEGER) FLOAT) F1)
(FTYPE (FUNCTION (COMPLEX BIGNUM) T) F2))
BODY3 BODY4)
;;;
;;; Keyword reference:
;;;
;;; - &PARAM indicates a meta-variable anywhere in the
;;; binding construct which is not one of the binding variables.
;;; For instance, a filename in a WITH-OPEN-FILE, the object
;;; expression in WITH-SLOTS, or the list in DESTRUCTURING-BIND.
;;; Code is generated in the wrapping macro to capture the
;;; parameter as an argument and pass it to the wrapped macro.
;;;
;;; - &REST is like &PARAM, but matches and transfers the entire
;;; remaining trailing portion of the subform into the target form.
;;;
;;; - &VAR indicates the location of simple variable that can be
;;; SYM (SYM TYPE) or (SYM TYPE INITVAL).
;;;
;;; - &VAR-LIST indicates the location of an arbitrarily long list
;;; of simple variables.
;;;
;;; - &LAMBDA-LIST matches an ordinary lambda list, with optional
;;; parameters, keyword parameters, rest and auxiliary parameters.
;;;
;;; - &FUNCTION matches a function definition of the form
;;; (SYM LAMBDA-LIST RESULT-TYPE BODY). It gathers the
;;; type signature and will produce an FTYPE declaration for
;;; the SYM. Additionally, the function definition will itself
;;; be transformed by removing declarations from the lambda
;;; list and the result-type expression, and moving these
;;; into a DECLARE block in the body.
;;;
;;; - &FUNCTION-LIST matches a list of &FUNCTION elements.
;;;
;;; - &BODY indicates where in the form the body occurs.
;;; This behaves a lot like &REST except that the declarations
;;; are wrapped around its expansion. Specifying the &BODY
;;; more than once has unspecified consquences. Only one body
;;; will have declarations put around it, for all of the variables
;;; identified in the form.
;;;
;;; - &RESULT-TYPE specifies a match for a type specification
;;; which is transferred to the body.
;;;
;;; - All other list structure specifies material to be copied to
;;; the target form, but not into the variable pattern form.
;;;
;;; - The syntax of the target macro is pruned of all levels of
;;; nesting which do not contain variables. However, the structure
;;; of the macro replacement template does contain the full
;;; structure without the deletion. So for instance
;;; the pattern (a (b (c &var))) will turn into the macro
;;; lambda list (#:G0025) rather than the syntax (((#:G0025)))
;;; where #:G0025 represents the gensym chosen for binding
;;; the variable form. But the output template will be
;;; be `(A (B (C ,#:G0025)), retaining the full tree structure.
;;;
|#
(defmacro second-value (expr)
`(multiple-value-bind (first second) ,expr
(declare (ignore first)) second))
;;; Convert a variable binding form in the type declaration syntax
;;; into an ordinary Common Lisp variable binding form. Return the
;;; declaration information, if any, as as second value.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun separate-decl-from-simple-var (var-form)
(cond
((atom var-form)
(values var-form `((type t ,var-form))))
((rest (rest var-form))
(values `(,(first var-form) ,(third var-form))
`((type ,(second var-form)
,(first var-form)))))
((rest var-form)
(values (first var-form) `((type ,(second var-form)
,(first var-form)))))
(t (values (first var-form)
`((type t ,(first var-form))))))))
;;; Plural variant of above function
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun separate-decls-from-simple-var-list (var-forms)
(loop for var-form in var-forms
with std-var-form
with decl
do (multiple-value-setq (std-var-form decl)
(separate-decl-from-simple-var var-form))
collect std-var-form into var-list
when decl
append decl into decl-list
finally (return (values var-list decl-list)))))
;;; Convert a lambda list with type declarations into an ordinary
;;; Common Lisp lambda list without the type declarations.
;;; The list of extracted declarations is returned as a second value.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant *key-state-map* '((&optional :optional-args)
(&rest :rest-args)
(&key :key-args)
(&aux :aux-args)))
(defun separate-decls-from-lambda-list (lambda-list)
(loop for element in lambda-list
with state = :required-args
if (assoc element *key-state-map*)
collect element into lam-list and
do (setq state (second (assoc element *key-state-map*)))
else if (member state '(:required-args :rest-args))
;; &rest argument declared? Why not.
if (consp element)
collect (first element) into lam-list and
collect `(type ,(second element)
,(first element)) into decl-list
else
collect element into lam-list and
collect `(type t ,element) into decl-list
else if (eq state :aux-args)
if (atom element)
collect element into lam-list and
collect `(type t ,element) into decl-list
else if (and (consp element) (rest (rest element)))
collect `(,(first element)
,(third element)) into lam-list and
collect `(type ,(second element)
,(first element)) into decl-list
else if (and (consp element) (rest element))
collect (first element) into lam-list and
collect `(type ,(second element)
,(first element)) into decl-list
else
collect (first element) into lam-list and
collect `(type t ,(first element)) into decl-list
else if (member state '(:optional-args :key-args))
if (atom element)
collect element into lam-list and
collect `(type t ,element) into decl-list
else if (and (consp element) (rest (rest element)))
collect `(,(first element)
,@(rest (rest element))) into lam-list and
collect `(type ,(second element)
,(first element)) into decl-list
else if (and (consp element) (rest element))
collect (first element) into lam-list and
collect `(type ,(second element)
,(first element)) into decl-list
else
collect (first element) into lam-list and
collect `(type t ,(first element)) into decl-list
finally (return (values lam-list decl-list)))))
;;; Scan a LABELS-like function definition embellished with
;;; declarations in the lambda list as well as a return type after
;;; the lambda list, and extract the (FTYPE ...) declaration.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun extract-ftype-from-function (function)
(destructuring-bind (name decl-lambda-list &optional result-type
&rest body) function
(declare (ignore body))
(let* ((decls (second-value
(separate-decls-from-lambda-list
decl-lambda-list)))
(signature (loop for (type type-expr) in decls
collecting type-expr)))
`((ftype (function ,signature ,result-type) ,name))))))
;;; Convert a LABELS-like function definition embellished with
;;; declarations and result type into standard syntax, with the
;;; declarations moved into a DECLARE block in the body.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun transform-decls-in-function (function)
(destructuring-bind (name decl-lambda-list &optional result-type
&rest body) function
(multiple-value-bind (standard-lambda-list decls)
(separate-decls-from-lambda-list
decl-lambda-list)
`(,name ,standard-lambda-list
(declare ,@decls)
,@(if (eq result-type t)
body
`((the ,result-type (progn ,@body)))))))))
;;; Verify that two forms are the same. This is done
;;; whenever a decl pattern form contains an atom that
;;; is not one of the supported keywords like ¶m.
;;; Whereas ¶m specifies a piece of the input form
;;; which is copied into the generated form, a random
;;; atom specifies a match. The macro call must have
;;; a matching object in the same place, or an error
;;; is raised.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun verify-match (macro-name pattern input)
(if (equal pattern input)
pattern
(error "~s: ~s does not match ~s" macro-name input pattern))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun parse-decl-syntax (macro-name arguments)
(loop for arg in arguments
for sym = (gensym)
with body-sym = nil
with result-type-sym = t
with recursed-target-args
with recursed-replacement-form
with recursed-var-specs
with recursed-body-sym
with recursed-result-type-sym
with extracted-decl
with extracted-standard-syntax
if (eq arg '&var)
collect sym into target-macro-args and
collect ``(,,sym) into replacement-form and
collect `(:simple-var ,sym) into var-specs
else if (eq arg '&var-list)
collect `(&rest ,sym) into target-macro-args and
collect ``(,,sym) into replacement-form and
collect `(:simple-var-list ,sym) into var-specs
else if (eq arg '&lambda-list)
collect `(&rest ,sym) into target-macro-args and
collect ``(,,sym) into replacement-form and
collect `(:lambda-list ,sym) into var-specs
else if (eq arg '&function)
collect sym into target-macro-args and
collect ``(,,sym) into replacement-form and
collect `(:function ,sym) into var-specs
else if (eq arg '&function-list)
collect `(&rest ,sym) into target-macro-args and
collect ``(,,sym) into replacement-form and
collect `(:function-list ,sym) into var-specs
else if (eq arg '&rest)
collect '&rest into target-macro-args and
collect sym into target-macro-args and
collect sym into replacement-form
else if (eq arg '¶m)
collect sym into target-macro-args and
collect ``(,,sym) into replacement-form
else if (eq arg '&body)
collect '&body into target-macro-args and
collect sym into target-macro-args and
collect sym into replacement-form and
do (setf body-sym sym)
else if (eq arg '&result-type)
collect sym into target-macro-args and
do (setf result-type-sym sym)
else if (consp arg)
do (multiple-value-setq (recursed-target-args
recursed-replacement-form
recursed-var-specs
recursed-body-sym
recursed-result-type-sym)
(parse-decl-syntax macro-name arg)) and
collect recursed-target-args into target-macro-args and
collect ``((,@,@recursed-replacement-form))
into replacement-form and
append recursed-var-specs into var-specs and
do (setf body-sym recursed-body-sym) and
do (setf result-type-sym recursed-result-type-sym)
else
collect ``(,',arg)
into replacement-form
finally
(return (values
(if (every #'proper-list-p target-macro-args)
(mapcan #'identity target-macro-args)
target-macro-args)
replacement-form
var-specs body-sym result-type-sym)))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun decl-expand-helper (form-name target-macro-args
replacement-form var-specs body-sym
result-type-sym)
`(let* ((declarations
,(loop for (spec-type sym) in var-specs
appending
(ecase spec-type
(:simple-var
`(second-value
(separate-decl-from-simple-var ,sym)))
(:simple-var-list
`(second-value
(separate-decls-from-simple-var-list
,sym)))
(:lambda-list
`(second-value
(separate-decls-from-lambda-list ,sym)))
(:function
`(extract-ftype-from-function ,sym))
(:function-list
`(loop for function in ,sym
appending
(extract-ftype-from-function
function))))))
(,body-sym (if (eq ,result-type-sym t)
,body-sym
`((the ,,result-type-sym
(progn ,@,body-sym)))))
(,body-sym (if declarations
`((declare ,@declarations)
,@,body-sym)
,body-sym))
,@(loop for (spec-type sym) in var-specs
collecting
`(,sym
,(ecase spec-type
(:simple-var
`(separate-decl-from-simple-var ,sym))
(:simple-var-list
`(separate-decls-from-simple-var-list
,sym))
(:lambda-list
`(separate-decls-from-lambda-list ,sym))
(:function
`(transform-decls-in-function ,sym))
(:function-list
`(loop for func in ,sym
collecting
(transform-decls-in-function
func)))))))
`(,',form-name ,@,@replacement-form))))
(defmacro define-decl-macro (macro-name pattern-form)
(destructuring-bind (form-name &rest source-decl-args) pattern-form
(multiple-value-bind (target-macro-args replacement-form
var-specs body-sym result-type-sym)
(parse-decl-syntax macro-name
source-decl-args)
`(defmacro ,macro-name ,target-macro-args
,(decl-expand-helper form-name target-macro-args
replacement-form var-specs body-sym
result-type-sym)))))
(defmacro decl-macrolet ((&rest name-pattern-pairs) &body body)
(loop for (name (form-name . decl-args)) in name-pattern-pairs
collecting name into macrolet-names
collecting
(multiple-value-bind (target-macro-args replacement-form
var-specs body-sym result-type-sym)
(parse-decl-syntax name decl-args)
`(,target-macro-args
,(decl-expand-helper form-name target-macro-args
replacement-form var-specs body-sym
result-type-sym)))
into macrolet-bodies
finally
(return `(macrolet (,@(mapcar #'cons
macrolet-names
macrolet-bodies))
,@body))))
"Kaz Kylheku" <········@gmail.com> writes:
> ;;;
>
> #|
>
> ;;; Best explained with examples!
>
> ;;; Write a macro called DECLARATIVE-LET which expands into LET.
> ;;; The &VAR-LIST symbol tells DEFINE-DECL-MACRO where in the LET
> ;;; form is the list of variable bindings located. The &BODY
> ;;; symbol indicates where the body of declarations and forms is.
> ;;; That's it!
>
> (define-decl-macro declarative-let
> (let &var-list &body))
>
> ;;; Now use the macro
>
> (declarative-let ((x integer 3) (y string) z)
> (setf y "abc")
> (push x z))
I don't have time to read your entire post, but does it allow for an
initial value without a type declaration?
Ari Johnson wrote:
> "Kaz Kylheku" <········@gmail.com> writes:
> > (define-decl-macro declarative-let
> > (let &var-list &body))
> >
> > ;;; Now use the macro
> >
> > (declarative-let ((x integer 3) (y string) z)
> > (setf y "abc")
> > (push x z))
>
> I don't have time to read your entire post, but does it allow for an
> initial value without a type declaration?
Not in the way you might be thinking, but of course you can use the
type T to effectively express the same thing:
(x t 3)
means that we are giving X the initial value 3, but not committing it
to a type.
I thought about this issue, and rationalized it like this: a user of
these macros is probably interested in heavy use of declarations, where
it doesn't matter if the occasional need for an undeclared variable
with an initial value requires extra syntax.
I don't see how it can even be designed otherwise. If you just want a
simple three-element syntax where the variable name is first, it has to
be either followed by the type and then the initial value or vice
versa. To allow either orders you need some additional in-band signal
to distinguish which is which. Any such scheme is going to be at least
as syntactically complex as writing that T.
BTW, version 9 doesn't handle docstrings properly. I have a fix for
that already, but I need a better fix which will handle bodies where
the docstring is placed after declarations. e.g
(decl-defun abc ((arg integer)) integer (declare (optimize ...))
"docstring" expr ...)
The transformer should recognize and skip any initial declarations and
docstring, and generate a body which looks like
(declare (optimize ...)) "docstring" (the integer (progn expr ...))
I will also develop a way to be able to express global declaim's for
functions. An easy way would be to support the keywords
@lambda-signature and @result-type, which are references to the
&lambda-list and &result-type. Also @param-1 trough @param-9 to refer
to ¶m's. The @lambda-signature will expand to the argument
signature gathered from a &lambda-list, and the @result-type will play
back a type expression collected from a &resulit-type position. So with
these elements, you could write something like:
(declare-decl-macro decl-defun
(progn
(declaim (ftype (function @lambda-signature @result-type)
@param-1)
(defun ¶m &lambda-list &result-type &body)))
Because of the empty-structure squashing logic in the expander,
decl-defun would still end up as a macro having the signature
(defmacro decl-defun <sym> (&rest <lambda-list>) <type> &body <body>)
in spite of the wrapping progn and declaim material.
Now can do:
(define-decl-macro decl-defun
(progn
(declaim
(ftype (function @lambda-signature @result-type) @param-1))
(defun ¶m-1 @param-1 &lambda-list &result-type &body)))
--> DECL-DEFUN
(macroexpand '(decl-defun add ((a integer) (b real)) real (+ a b)))
--> (PROGN
(DECLAIM (FTYPE (FUNCTION (INTEGER REAL) REAL) ADD))
(DEFUN ADD (A B)
(DECLARE (TYPE INTEGER A) (TYPE REAL B))
(THE REAL (PROGN (+ A B)))))
(decl-defun add ((a integer) (b real)) real (+ a b))
--> ADD
(add 1 3.0)
I'm actually more excited, than anything, by this concept of writing
the source and target template as one object. This could be used to
develop an alternate macro-writing system to augment the one we have
based on analysis with destructuring, and synthesis with backquote.
You simply express the form that you want to come out, and the
macro-writer deduces the argument syntax.
A lot of the time you don't care what the syntax is as long as it gets
all the arguments and otherwise makes sense. Maybe the machine should
choose the syntax for the macro based on hunting down the parameters in
the structure of the form.
I'm going to develop this idea further.