Is there a way to do this:
(let ((x 5)(y 7))
(get-outer-form) ;; 'get-outer-form would capture the entire LET expression
(* x y))
35 ;; value returned from LET
*current-form-value* ;; variable to hold the form
(let ((x 5))(y 7))(* x y)) ;; value of evaluating *current-form-value*
If it can be done, pseudo-code will suffice. I'll naively assume that this would have to be done with read, however, if there is too much overhead generated from doing this, I will have to find another solution. Thanks.
No its not possible by default. Doing so would need some advanced code and is not likely to work easily:
custom evaluator
code walker which injects the necessary code
I've been fiddling a little around and came up with this. It's not exactly what you want but it's close. It it were possible to rename let and make your own it would be exactly what you want.
(defmacro letc (p &body b)
(when (equal (car b) '(get-outer-form))
(setq b `((setf *current-form-value* '(let ,p ,#(cdr b))),#(cdr b))))
`(let ,p ,#b))
(letc ((x 5)(y 7))
(get-outer-form) ;; 'get-outer-form would capture the entire LET expression
(* x y))
;; ==> 35
*current-form-value*
;; ==> (let ((x 5) (y 7)) (* x y))
Or simpler. Using letc implies you want it captured.
(defmacro letc (p &body b)
`(let ,p (setf *current-form-value* '(letc ,p ,#b)),#b)))
(letc ((x 5)(y 7))
(* x y))
;; ==> 35
*current-form-value*
;; ==> (letc ((x 5) (y 7)) (* x y))
Both of them have problems with nesting:
(letc ((x 5)(y 7))
(letc ((a (+ x y)))
(* 2 a)))
;; ==> 24
*current-form-value*
;; ==> (let ((a (+ x y))) (* 2 a))
I think Rainer is basically correct, but I couldn't help trying for a subset of your goal with either *macroexpand-hook* or a reader approach. I don't bother removing (get-outer-form) from the current form in either case, but that should be straightforward list manipulation.
First a reader approach. Wrap the open parenthesis reader with a function that searches for (get-outer-form) within the result of calling the default open parenthesis reader.
;(in-package |cl-user|)
(defparameter *standard-readtable* (copy-readtable ()))
*STANDARD-READTABLE*
;(in-package |cl-user|)
(defvar *current-form-value* ())
*CURRENT-FORM-VALUE*
;(in-package |cl-user|)
(defun get-outer-form ()
())
GET-OUTER-FORM
;(in-package |cl-user|)
(defun get-outer-form-paren-reader (stream char &optional count)
(declare (ignore count))
(let* ((seen ())
(paren-reader
(get-macro-character #\( *standard-readtable*))
(form (funcall paren-reader stream char)))
(subst-if ()
(lambda (x)
;; never substitute, search only.
(prog1 ()
(when (equalp x '(get-outer-form))
(setq seen t))))
form)
(when seen
(setq *current-form-value* form))
form))
GET-OUTER-FORM-PAREN-READER
;(in-package |cl-user|)
(set-macro-character #\( #'get-outer-form-paren-reader)
T
Second, a *macroexpand-hook* approach. Look for (get-outer-form) in forms before they are macroexpanded.
;(in-package |cl-user|)
(defun get-outer-form ()
(error "get-outer-form only works from within a macro"))
GET-OUTER-FORM
;(in-package |cl-user|)
(defvar *current-form-value* ())
*CURRENT-FORM-VALUE*
;(in-package |cl-user|)
(defun mhook (expander form env)
(let* ((seen ())
(fixed (subst-if ()
(lambda (x)
(when (equalp x '(get-outer-form))
(setq seen t)))
form)))
(when seen (setq *current-form-value* form))
(funcall expander fixed env)))
MHOOK
;(in-package |cl-user|)
(setq *macroexpand-hook* #'mhook)
#<Compiled-function MHOOK #x30200FC5BB1F>
Related
Emacs-lisp is default using call-by-value, but I'm trying use its symbol mechanism to simulate call-by-reference.
For example,
(setq lexical-binding nil)
(defun cbr (x)
(message "cbr (symbol-name x) %s" (symbol-name x))
(message "cbr (symbol-value x) %s" (symbol-value x))
(set x 2))
(let ((a 1))
(cbr 'a)
a)
;; cbr (symbol-name x) a
;; cbr (symbol-value x) 1
;; 2
It works well, because the result of let expression is 2, so it is indeed the call-by-reference behavior.
However, if I change the name from a to x:
(let ((x 1))
(cbr 'x)
x)
;; cbr (symbol-name x) x
;; cbr (symbol-value x) x
;; 1
Now it doesn't work as expected anymore.
Why?
Notice that it even can not get the correct symbol-name in cbr.
I think I have known what happen.
The second program returns 1, because the symbol x is captured by cbr's param x. When the body of cbr is evaluated, there are two bindings in the environment: one is the let binding x = 1, the other is x = x which is created by cbr's application. The symbol x in the (set x 2) uses the later one.
A workaround of this question is:
(let ((gen-x (gensym)))
(set gen-x 1)
(cbr gen-x)
(symbol-value gen-x))
;; cbr (symbol-name x) g36
;; cbr (symbol-value x) 1
;; 2
What should be clear from this is that relying on dynamic scope and symbol-value is a disaster: you need gensyms all over the place. Relying on dynamic scope for anything is generally a disaster, except in the specific, rare but extremely useful, case where you actually want dynamic scope.
But solving this problem trivial, even in elisp, with lexical scope. Here is one simple approach:
(defmacro ref (form)
;; Construct a reference to a form
(unless lexical-binding
(error "doomed"))
(let ((<setting> (gensym)))
`(lambda (&rest ,<setting>) ;hack for &optional (v nil vp)
(cond
((null ,<setting>)
,form)
((null (cdr ,<setting>))
(setf ,form (car ,<setting>)))
(t
(error "mutant"))))))
(defun ref-value (ref)
(funcall ref))
(defun set-ref-value (ref value)
;; should be (setf ref-value), but elisp
(funcall ref value))
And now, for instance, given:
(defun outer (v)
(let ((x 1))
(princ (format "x is first %s\n" x))
(inner (ref x) v)
(princ (format "and x is now %s\n" x))
x))
(defun inner (ref v)
(princ (format " ref is first %s\n" (ref-value ref)))
(set-ref-value ref v)
(princ (format " and ref is now %s\n" (ref-value ref))))
Then
ELISP> (outer 4)
x is first 1
ref is first 1
and ref is now 4
and x is now 4
4 (#o4, #x4, ?\C-d)
I am trying to do the exercises on this tutorial about CLOS using SBCL and Slime (Emacs).
I have this class, instance, and function to set values for the slots:
(defclass point ()
(x y z))
(defvar my-point
(make-instance 'point))
(defun with-slots-set-point-values (point a b c)
(with-slots (x y z) point (setf x a y b z c)))
Using the REPL, it works fine:
CL-USER> (with-slots-set-point-values my-point 111 222 333)
333
CL-USER> (describe my-point)
#<POINT {1003747793}>
[standard-object]
Slots with :INSTANCE allocation:
X = 111
Y = 222
Z = 333
; No value
Now, the exercises indicates that using the symbol-macrolet I need to implement my version of with-slots.
I have a partial implementation of my with-slots (I still need to insert add the operation):
(defun partial-my-with-slots (slot-list object)
(mapcar #'(lambda (alpha beta) (list alpha beta))
slot-list
(mapcar #'(lambda (var) (slot-value object var)) slot-list)))
It works when calling it:
CL-USER> (partial-my-with-slots '(x y z) my-point)
((X 111) (Y 222) (Z 333))
Since this use of symbol-macrolet works:
CL-USER> (symbol-macrolet ((x 111) (y 222) (z 333))
(+ x y z))
666
I tried doing:
CL-USER> (symbol-macrolet (partial-my-with-slots '(x y z) my-point)
(+ x y z))
But, for some reason that I do not know, Slime throws the error:
malformed symbol/expansion pair: PARTIAL-MY-WITH-SLOTS
[Condition of type SB-INT:SIMPLE-PROGRAM-ERROR]
Why does this happen? How can I fix this?
You can't write with-slots as a function which is called at run time. Instead it needs to be a function which takes source code as an argument and returns other source code. In particular if given this argument
(my-with-slots (x ...) <something> <form> ...)
It should return this result:
(let ((<invisible-variable> <something))
(symbol-macrolet ((x (slot-value <invisible-variable>)) ...)
<form> ...))
You need <invisible-variable> so you evaluate <object-form> only once.
Well, here is a function which does most of that:
(defun mws-expander (form)
(destructuring-bind (mws (&rest slot-names) object-form &rest forms) form
(declare (ignore mws))
`(let ((<invisible-variable> ,object-form))
(symbol-macrolet ,(mapcar (lambda (slot-name)
`(,slot-name (slot-value <invisible-variable>
',slot-name)))
slot-names)
,#forms))))
And you can check this:
> (mws-expander '(my-with-slots (x y) a (list x y)))
(let ((<invisible-variable> a))
(symbol-macrolet ((x (slot-value <invisible-variable> 'x))
(y (slot-value <invisible-variable> 'y)))
(list x y)))
So that's almost right, except the invisible variable really needs to be invisible:
(defun mws-expander (form)
(destructuring-bind (mws (&rest slot-names) object-form &rest forms) form
(declare (ignore mws))
(let ((<invisible-variable> (gensym)))
`(let ((,<invisible-variable> ,object-form))
(symbol-macrolet ,(mapcar (lambda (slot-name)
`(,slot-name (slot-value ,<invisible-variable>
',slot-name)))
slot-names)
,#forms)))))
And now:
> (mws-expander '(my-with-slots (x y) a (list x y)))
(let ((#:g1509 a))
(symbol-macrolet ((x (slot-value #:g1509 'x))
(y (slot-value #:g1509 'y)))
(list x y)))
Well, a function which takes source code as an argument and returns other source code is a macro. So, finally, we need to install this function as a macroexpander, arranging to ignore the second argument that macro functions get:
(setf (macro-function 'mws)
(lambda (form environment)
(declare (ignore environment))
(mws-expander form)))
And now:
> (macroexpand '(mws (x y) a (list x y)))
(let ((#:g1434 a))
(symbol-macrolet ((x (slot-value #:g1434 'x)) (y (slot-value #:g1434 'y)))
(list x y)))
This would be more conventionally written using defmacro, of course:
(defmacro mws ((&rest slot-names) object-form &rest forms)
(let ((<invisible-variable> (gensym)))
`(let ((,<invisible-variable> ,object-form))
(symbol-macrolet ,(mapcar (lambda (slot-name)
`(,slot-name (slot-value ,<invisible-variable> ',slot-name)))
slot-names)
,#forms))))
However the two definitions are equivalent (modulo needing some eval-whenery to make the first work properly with the compiler).
You need to return expressions that will call slot-value when substituted into the macro expansion, rather than calling the function immediately. Backquote is useful for this.
(defun partial-my-with-slots (slot-list object)
(mapcar #'(lambda (alpha beta) (list alpha beta))
slot-list
(mapcar #'(lambda (var) `(slot-value ,object ',var)) slot-list)))
> (partial-my-with-slots '(x y z) 'my-point)
((x (slot-value my-point 'x)) (y (slot-value my-point 'y)) (z (slot-value my-point 'z)))
You use this in your with-slots macro like this:
(defmacro my-with-slots ((&rest slot-names) instance-form &body body)
`(symbol-macrolet ,(partial-my-with-slots slot-names instance-form)
,#body))
> (macroexpand '(my-with-slots (x y z) point (setf x a y b z c)))
(SYMBOL-MACROLET ((X (SLOT-VALUE POINT 'X))
(Y (SLOT-VALUE POINT 'Y))
(Z (SLOT-VALUE POINT 'Z)))
(SETF X A
Y B
Z C))
I was thinking about a cond with a twist
(let ((a 0))
(let* ((result nil))
(tagbody
(let ((b1 (+ 0 a)))
(when (eq b1 1)
(print "1")
(setf result b1)
(go finish)))
(let ((b2 (+ 0 a)))
(when (eq b2 2)
(print "2")
(setf result b2)
(go finish)))
(when T
(print "else")
(setf result a))
(format t "=== ~A~%" a)
finish)
result))
where when test-form is wrapped in let. On one hand this seems to fit into a problem I am working on, but also seems overcomplicated. Can it be simplified with a macro? What would be the best way to simplify it if I had lots of test-forms?
Part of the problem in trying to do it that way is restricting the let blocks to only one test-form and its body.
But I wonder if I am going down the wrong path. Playing with an imaginary variant of when-let suggests there is no benefit of going down this path.
Trying cond
The version using cond appears to be more compact.
(let ((a 3))
(let* ((b1 (+ 0 a))
(b2 (+ 0 a)))
(cond
((eq b1 1)
(print "1")
b1)
((eq b2 2)
(print "2")
b2)
(T (print "else")
a))))
All boils down to the variables defined in the let* which in real life example would be used to avoid calculating the same value twice and improve readability. What should I do?
I'd prefer to think more in terms of blocks and returning values from them, instead working with goto and variables. If one really needs separate let-bound variables and their own scope:
(prog ((a 0))
(let ((b1 (+ 0 a)))
(when (eql b1 1)
(print "1")
(return b1)))
(let ((b2 (+ 0 a)))
(when (eql b2 2)
(print "2")
(return b2)))
(return
(progn
(print "else")
(return a))))
Somebody did now. I wanted it to be compatible with cond which raises a trouble: if you want the binding clauses to be like
(cond/binding
...
((var expr) <use var>)
...)
But you want to allow just general test clauses, then a function with one argument is ambiguous: should
(cond/binding
...
((car x) ...)
...)
call car or bind car? To make this work then you need to bind a useless variable in that case:
(cond/binding
...
((useless (car x)) <useless not used here>)
...)
And that means you either need to insert ignore or ignorable declarations all over the place, or live with compiler warnings.
So, well, I decided it would be better to go the other way: you have to say when you want to bind a variable. And you do that by a clause like:
(cond/binding
...
((bind var expr) <var is bound here>)
...)
And note that bind is magic in the syntax (so this means you can't call a function called bind, but that's OK as I already use bind as a keyword in other macros.
The macro also tries hard (well, hard given I basically just typed it in and it's had no testing) to actually behave like cond: returning multiple values, for instance.
So this:
(cond/binding
((f x y z) t)
((bind x 3) (print x) (values x t))
(t (values nil nil))
(1))
expands to
(block #:cond/binding
(when (f x y z)
(return-from #:cond/binding (progn t)))
(let ((x 3))
(when x
(return-from #:cond/binding
(progn (print x) (values x t)))))
(when t
(return-from #:cond/binding (progn (values nil nil))))
(let ((r 1))
(when r
(return-from #:cond/binding r))))
(where all the blocks are the same block).
So, here:
(defmacro cond/binding (&body clauses)
;; Like COND but it can bind variables. All clauses are (should be)
;; like COND, except that a clause of the form ((bind var <expr>)
;; ...) will bind a variable. Note that bind has to be literally
;; the symbol BIND: it's magic in the syntax.
(let ((bn (make-symbol "COND/BINDING")))
`(block ,bn
,#(mapcar
(lambda (clause)
(unless (consp clause)
(error "bad clause ~S" clause))
(case (length clause)
(1
`(let ((r ,(car clause)))
(when r (return-from ,bn r))))
(otherwise
(destructuring-bind (test/binding &body forms) clause
(typecase test/binding
(cons
(case (car test/binding)
((bind)
(unless (and (= (length test/binding) 3)
(symbolp (second test/binding)))
(error "bad binding clause ~S" test/binding))
(destructuring-bind (var expr) (rest test/binding)
`(let ((,var ,expr))
(when ,var
(return-from ,bn
(progn ,#forms))))))
(otherwise
`(when ,test/binding
(return-from ,bn
(progn ,#forms))))))
(t
`(when ,test/binding
(return-from ,bn
(progn ,#forms)))))))))
clauses))))
Caveat emptor.
If I understand you problem correctly, then you can use or and rely on the fact that when is evaluated to nil if the condition is not true, e.g.,
(defun example (a)
(or
(let ((b1 (+ 0 a)))
(when (eql b1 1)
(print "1")
b1))
(let ((b2 (+ 0 a)))
(when (eql b2 2)
(print "2")
b2))
(progn
(print "else")
a)))
Using macrolet is the best solution so far. That allows me to bypass the limitations of when-let and not all bindins in the let form have to evaluate to true.
(let ((a 3))
(let ((result nil))
(macrolet ((ret-go (res)
`(progn
(setf result ,res)
(go finish))))
(tagbody
(let ((b1 (+ 0 a)))
(when (eq b1 1)
(print "1")
(ret-go b1)))
(let ((b2 (+ 0 a)))
(when (eq b2 2)
(print "2")
(ret-go b2)))
(when T
(print "else")
(setf result a))
(format t "=== ~A~%" a)
finish)
result)))
This is probably a stupid question, but I'm walking through the PG lisp book, and I wanted to step through some example macros that he provides with actual values, for instance:
(defmacro our-let (binds &body body)
`(
(lambda ,(
mapcar #'(lambda (x) (if (consp x) (car x) x)) binds
)
,#body
)
,#(mapcar #'(lambda (x) (if (consp x) (cadr x) nil)) binds)
)
)
I naively tried to run (trace our-let) and then (our-let ((x 1) (y 2)) (+ x y)) but I'm getting an error, can't use encapsulation to trace anonymous function #<FUNCTION (MACRO-FUNCTION OUR-LET) {22675BBB}>. Also not sure how to best put print statements into the lambdas. What's the best way to debug this macro/output how it's processing inputs?
EDIT(1): I had the incorrect formatting for macroexpand, which works.
Actually being able to trace macros is not very common in Common Lisp implementations. Compilers will typically expand the macro forms during compilation.
A few implementations support it though - which makes sense when they also support a Lisp interpreter, which runs the actual source. Among those are LispWorks and CLISP.
Here using the code from Sylwester in CLISP:
i i i i i i i ooooo o ooooooo ooooo ooooo
I I I I I I I 8 8 8 8 8 o 8 8
I \ `+' / I 8 8 8 8 8 8
\ `-+-' / 8 8 8 ooooo 8oooo
`-__|__-' 8 8 8 8 8
| 8 o 8 8 o 8 8
------+------ ooooo 8oooooo ooo8ooo ooooo 8
Welcome to GNU CLISP 2.49.93+ (2018-02-18) <http://clisp.org/>
Copyright (c) Bruno Haible, Michael Stoll 1992-1993
Copyright (c) Bruno Haible, Marcus Daniels 1994-1997
Copyright (c) Bruno Haible, Pierpaolo Bernardi, Sam Steingold 1998
Copyright (c) Bruno Haible, Sam Steingold 1999-2000
Copyright (c) Sam Steingold, Bruno Haible 2001-2018
Type :h and hit Enter for context help.
[1]> (defmacro our-let ((&rest bindings) &body body)
(let ((names (mapcar #'(lambda (x) (if (consp x) (car x) x)) bindings))
(exprs (mapcar #'(lambda (x) (if (consp x) (cadr x) nil)) bindings)))
`((lambda ,names ,#body) ,#exprs)))
OUR-LET
[2]> (trace our-let)
;; Tracing macro OUR-LET.
(OUR-LET)
[3]> (dotimes (i 3)
(our-let ((x (* i 10)))
(+ x 3)))
1. Trace: (OUR-LET ((X (* I 10))) (+ X 3))
1. Trace: OUR-LET ==> ((LAMBDA (X) (+ X 3)) (* I 10))
1. Trace: (OUR-LET ((X (* I 10))) (+ X 3))
1. Trace: OUR-LET ==> ((LAMBDA (X) (+ X 3)) (* I 10))
1. Trace: (OUR-LET ((X (* I 10))) (+ X 3))
1. Trace: OUR-LET ==> ((LAMBDA (X) (+ X 3)) (* I 10))
NIL
[4]>
How you debug it:
(macroexpand-1 '(our-let ((x 1) (y 2)) (+ x y)))
; ==> ((lambda (X Y) (+ X Y)) 1 2)
; ==> t
BTW your formatting is not good. Here is how it can look:
(defmacro our-let (binds &body body)
`((lambda ,(mapcar #'(lambda (x) (if (consp x) (car x) x)) binds)
,#body)
,#(mapcar #'(lambda (x) (if (consp x) (cadr x) nil)) binds)))
Or I would prefer:
(defmacro our-let ((&rest bindings) &body body)
(let ((names (mapcar #'(lambda (x) (if (consp x) (car x) x)) bindings))
(exprs (mapcar #'(lambda (x) (if (consp x) (cadr x) nil)) bindings)))
`((lambda ,names ,#body) ,#exprs)))
A nice thing about CL is that its designers thought quite hard about some things. In particular it turns out that you can trace macroexpansion portably in CL, thanks to *macroexpand-hook*. The code at the end of this answer uses it to trace macroexpansion It makes some attempt to cooperate with anything else which might be talking to *macroexpand-hook*, and to avoid recursive tracing, but it's not very well tested. There are controls for how much should be printed which have default values which are 'much less than everything'.
Here is an example of this in LispWorks:
> (macroexpand-traced-p)
nil
> (trace-macroexpand)
t
> (defun foo (x) x)
(defun foo (x) ...)
-> (dspec:def (defun foo) (dspec:install-defun 'foo # ...))
(dspec:def (defun foo) (dspec:install-defun 'foo # ...))
-> (compiler-let (#) (compiler::top-level-form-name # #))
(compiler::top-level-form-name (defun foo)
(dspec:install-defun 'foo # ...))
-> (compiler::tlf-name-binding (compiler-let #)
(dspec:install-defun 'foo # ...))
(compiler::tlf-name-binding (compiler-let #)
(dspec:install-defun 'foo # ...))
-> (compiler-let (# #) (dspec:install-defun 'foo # ...))
(dspec:location)
-> ':listener
foo
As you can see you get a lot of internal expansions which are probably not interesting. To deal with this there is support for filtering the output so you don't see macroexpansions which may not be interesting to you, of which there are a lot.
Here is a filter function which tries to only show expansions where the thing being expanded is visible in the current package:
(defun trace-macroexpand-trace-this-package-p (macro-function macro-form
environment)
(declare (ignore macro-function environment))
(and (consp macro-form)
(symbolp (first macro-form))
(let ((name (first macro-form)))
(eq (find-symbol (symbol-name name) *package*) name))))
And here is the some output for that:
> (setf *trace-macroexpand-trace-p* #'trace-macroexpand-trace-this-package-p)
(setf *trace-macroexpand-trace-p*
#'trace-macroexpand-trace-this-package-p)
-> (let* (#) (setq *trace-macroexpand-trace-p* #:|Store-Var-1102|))
#<Function trace-macroexpand-trace-this-package-p 4060000844>
> (defun foo (x) x)
(defun foo (x) ...)
-> (dspec:def (defun foo) (dspec:install-defun 'foo # ...))
foo
As you can see you only now get 'interesting' macroexpansions. Cleverer filters could be defined, of course.
Here is the code:
(eval-when (:load-toplevel :compile-toplevel :execute)
;; macroexpansion tracing really wants to be off when compiling this
;; code as exciting things may happen during the evaluation of
;; DEFVAR &c otherwise.
(when (fboundp 'trace-macroexpand)
(ignore-errors ;don't barf
(trace-macroexpand nil))))
(defvar *trace-macroexpand-print-length* 3
"The value of *PRINT-LENGTH* used when tracing macroexpansions")
(defvar *trace-macroexpand-print-level* 2
"The value of *PRINT-LEVEL* used when tracing macroexpansions")
(defvar *trace-macroexpand-trace-p* (constantly t)
"Should we trace a given macroexpansion?
If this is bound to a function that function will be called with the
same three arguments that *MACROEXPAND-HOOK* takes, and should return
true if the expansion is to be printed. Otherwise it should be true
if expansion is to be printed, false otherwise.")
(defvar *traced-macroexpand-hook*
;; the old value of *MACROEXPAND-HOOK*, used to restore it and to
;; know if we should trace. Not user-adjustable.
nil)
(defun trace-macroexpand (&optional (tracep t))
"Trace or untrace macroexpansion.
If called with no argument, or an argument which is true, ensure that
macroexpansion is on. If it was already on return NIL, otherwise
return T.
If called with an argument which is NIL then ensure macroexpansion is
not traced. If it was traced return T else return NIL."
(if tracep
(if *traced-macroexpand-hook*
nil
(let ((hook *macroexpand-hook*))
(flet ((macroexpand-hook (macro-function macro-form environment)
(if (if (functionp *trace-macroexpand-trace-p*)
(funcall *trace-macroexpand-trace-p*
macro-function macro-form environment)
*trace-macroexpand-trace-p*)
(let ((expanded-form (funcall hook macro-function
macro-form environment))
(*print-length* *trace-macroexpand-print-length*)
(*print-level* *trace-macroexpand-print-level*)
(*print-pretty* t))
(format *debug-io* "~&~S~% -> ~S~%" macro-form expanded-form)
expanded-form)
(funcall hook macro-function macro-form environment))))
(setf *traced-macroexpand-hook* hook
*macroexpand-hook* #'macroexpand-hook)
t)))
(if *traced-macroexpand-hook*
(progn
(setf *macroexpand-hook* *traced-macroexpand-hook*
*traced-macroexpand-hook* nil)
t)
nil)))
(defun macroexpand-traced-p ()
"Is macroexpansion currently traced?"
(if *traced-macroexpand-hook* t nil))
Here is one way to trace the macro that should work in any Common Lisp:
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun our-let-expander (binds body)
`((lambda ,(mapcar #'(lambda (x) (if (consp x) (car x) x)) binds)
,#body)
,#(mapcar #'(lambda (x) (if (consp x) (cadr x) nil)) binds))))
(defmacro our-let (binds &body body)
(our-let-expander binds body))
Now we just (trace our-let-expander).
In my experience, complicated macros often end up handled via expander helper functions like this anyway, for various reasons.
(One big reason is this: as soon as you have two or more syntactic interfaces to the same expansion logic, you don't want to copy and paste that logic into multiple defmacro forms, but have it in a function.)
P.S. note the reformatting of the backquote form. Do not separate opening parentheses from what follows, and have closing parentheses on lines by themselves.
When I compile the following code, SBCL complains that g!-unit-value and g!-unit are undefined. I'm not sure how to debug this. As far as I can tell, flatten is failing.
When flatten reaches the unquoted part of defunits, it seems like the entire part is being treated as an atom. Does that sound correct?
The following uses code from the book Let over Lambda:
Paul Graham Utilities
(defun symb (&rest args)
(values (intern (apply #'mkstr args))))
(defun mkstr (&rest args)
(with-output-to-string (s)
(dolist (a args) (princ a s))))
(defun group (source n)
(if (zerop n) (error "zero length"))
(labels ((rec (source acc)
(let ((rest (nthcdr n source)))
(if (consp rest)
(rec rest (cons (subseq source 0 n) acc))
(nreverse (cons source acc))))))
(if source (rec source nil) nil)))
(defun flatten (x)
(labels ((rec (x acc)
(cond ((null x) acc)
((atom x) (cons x acc))
(t (rec (car x) (rec (cdr x) acc))))))
(rec x nil)))
Let Over Lambda Utilities - Chapter 3
(defmacro defmacro/g! (name args &rest body)
(let ((g!-symbols (remove-duplicates
(remove-if-not #'g!-symbol-p
(flatten body)))))
`(defmacro ,name ,args
(let ,(mapcar
(lambda (g!-symbol)
`(,g!-symbol (gensym ,(subseq
(symbol-name g!-symbol)
2))))
g!-symbols)
,#body))))
(defun g!-symbol-p (symbol-to-test)
(and (symbolp symbol-to-test)
(> (length (symbol-name symbol-to-test)) 2)
(string= (symbol-name symbol-to-test)
"G!"
:start1 0
:end1 2)))
(defmacro defmacro! (name args &rest body)
(let* ((o!-symbols (remove-if-not #'o!-symbol-p args))
(g!-symbols (mapcar #'o!-symbol-to-g!-symbol o!-symbols)))
`(defmacro/g! ,name ,args
`(let ,(mapcar #'list (list ,#g!-symbols) (list ,#o!-symbols))
,(progn ,#body)))))
(defun o!-symbol-p (symbol-to-test)
(and (symbolp symbol-to-test)
(> (length (symbol-name symbol-to-test)) 2)
(string= (symbol-name symbol-to-test)
"O!"
:start1 0
:end1 2)))
(defun o!-symbol-to-g!-symbol (o!-symbol)
(symb "G!" (subseq (symbol-name o!-symbol) 2)))
Let Over Lambda - Chapter 5
(defun defunits-chaining (u units prev)
(if (member u prev)
(error "~{ ~a~^ depends on~}"
(cons u prev)))
(let ((spec (find u units :key #'car)))
(if (null spec)
(error "Unknown unit ~a" u)
(let ((chain (second spec)))
(if (listp chain)
(* (car chain)
(defunits-chaining
(second chain)
units
(cons u prev)))
chain)))))
(defmacro! defunits (quantity base-unit &rest units)
`(defmacro ,(symb 'unit-of- quantity)
(,g!-unit-value ,g!-unit)
`(* ,,g!-unit-value
,(case ,g!-unit
((,base-unit) 1)
,#(mapcar (lambda (x)
`((,(car x))
,(defunits-chaining
(car x)
(cons
`(,base-unit 1)
(group units 2))
nil)))
(group units 2))))))
This is kind of tricky:
Problem: you assume that backquote/comma expressions are plain lists.
You need to ask yourself this question:
What is the representation of a backquote/comma expression?
Is it a list?
Actually the full representation is unspecified. See here: CLHS: Section 2.4.6.1 Notes about Backquote
We are using SBCL. See this:
* (setf *print-pretty* nil)
NIL
* '`(a ,b)
(SB-INT:QUASIQUOTE (A #S(SB-IMPL::COMMA :EXPR B :KIND 0)))
So a comma expression is represented by a structure of type SB-IMPL::COMMA. The SBCL developers thought that this representation helps when such backquote lists need to be printed by the pretty printer.
Since your flatten treats structures as atoms, it won't look inside...
But this is the specific representation of SBCL. Clozure CL does something else and LispWorks again does something else.
Clozure CL:
? '`(a ,b)
(LIST* 'A (LIST B))
LispWorks:
CL-USER 87 > '`(a ,b)
(SYSTEM::BQ-LIST (QUOTE A) B)
Debugging
Since you found out that somehow flatten was involved, the next debugging steps are:
First: trace the function flatten and see with which data it is called and what it returns.
Since we are not sure what the data actually is, one can INSPECT it.
A debugging example using SBCL:
* (defun flatten (x)
(inspect x)
(labels ((rec (x acc)
(cond ((null x) acc)
((atom x) (cons x acc))
(t (rec (car x) (rec (cdr x) acc))))))
(rec x nil)))
STYLE-WARNING: redefining COMMON-LISP-USER::FLATTEN in DEFUN
FLATTEN
Above calls INSPECT on the argument data. In Common Lisp, the Inspector usually is something where one can interactively inspect data structures.
As an example we are calling flatten with a backquote expression:
* (flatten '`(a ,b))
The object is a proper list of length 2.
0. 0: SB-INT:QUASIQUOTE
1. 1: (A ,B)
We are in the interactive Inspector. The commands now available:
> help
help for INSPECT:
Q, E - Quit the inspector.
<integer> - Inspect the numbered slot.
R - Redisplay current inspected object.
U - Move upward/backward to previous inspected object.
?, H, Help - Show this help.
<other> - Evaluate the input as an expression.
Within the inspector, the special variable SB-EXT:*INSPECTED* is bound
to the current inspected object, so that it can be referred to in
evaluated expressions.
So the command 1 walks into the data structure, here a list.
> 1
The object is a proper list of length 2.
0. 0: A
1. 1: ,B
Walk in further:
> 1
The object is a STRUCTURE-OBJECT of type SB-IMPL::COMMA.
0. EXPR: B
1. KIND: 0
Here the Inspector tells us that the object is a structure of a certain type. That's what we wanted to know.
We now leave the Inspector using the command q and the flatten function continues and returns a value:
> q
(SB-INT:QUASIQUOTE A ,B)
For anyone else who is trying to get defmacro! to work on SBCL, a temporary solution to this problem is to grope inside the unquote structure during the flatten procedure recursively flatten its contents:
(defun flatten (x)
(labels ((flatten-recursively (x flattening-list)
(cond ((null x) flattening-list)
((eq (type-of x) 'SB-IMPL::COMMA) (flatten-recursively (sb-impl::comma-expr x) flattening-list))
((atom x) (cons x flattening-list))
(t (flatten-recursively (car x) (flatten-recursively (cdr x) flattening-list))))))
(flatten-recursively x nil)))
But this is horribly platform dependant. If I find a better way, I'll post it.
In case anyone's still interested in this one, here are my three cents. My objection to the above modification of flatten is that it might be more naturally useful as it were originally, while the problem with representations of unquote is rather endemic to defmacro/g!. I came up with a not-too-pretty modification of defmacro/g! using features to decide what to do. Namely, when dealing with non-SBCL implementations (#-sbcl) we proceed as before, while in the case of SBCL (#+sbcl) we dig into the sb-impl::comma structure, use its expr attribute when necessary and use equalp in remove-duplicates, as we are now dealing with structures, not symbols. Here's the code:
(defmacro defmacro/g! (name args &rest body)
(let ((syms (remove-duplicates
(remove-if-not #-sbcl #'g!-symbol-p
#+sbcl #'(lambda (s)
(and (sb-impl::comma-p s)
(g!-symbol-p (sb-impl::comma-expr s))))
(flatten body))
:test #-sbcl #'eql #+sbcl #'equalp)))
`(defmacro ,name ,args
(let ,(mapcar
(lambda (s)
`(#-sbcl ,s #+sbcl ,(sb-impl::comma-expr s)
(gensym ,(subseq
#-sbcl
(symbol-name s)
#+sbcl
(symbol-name (sb-impl::comma-expr s))
2))))
syms)
,#body))))
It works with SBCL. I have yet to test it thoroughly on other implementations.