Re: ONCE-ONLY

"Vladimir Zolotykh" <gsmith@xxxxxxxxxxxxx> writes:

> On Fri, 29 Apr 2005 17:27:35 +0200, Pascal Bourguignon
> <pjb@xxxxxxxxxxxxxxxxx> wrote:
>
> [SKIP]
>> Unfortunately the use of anonymous gensyms doesn't help reading this.
>> Let's correct it:
>>
>> [246]> (defmacro once-only ((&rest names) &body body)
>> (let ((gensyms (loop for n in names collect (gensym (string n)))))
>> `(let (,@(loop for g in gensyms collect `(,g (gensym ))))
>> `(let (,,@(loop for g in gensyms for n in names
>> collect ``(,,g ,,n)))
>> ,(let (,@(loop for n in names for g in gensyms
>> collect `(,n ,g)))
>> ,@body)))))
>> ONCE-ONLY
>> [41]> (macroexpand-1 '(once-only (a b) (list 'list a b)))
>> (LET ((#:A4103 (GENSYM)) (#:B4104 (GENSYM)))
>> (LIST 'LET (LIST (LIST #:A4103 A) (LIST #:B4104 B))
>> (LET ((A #:A4103) (B #:B4104)) (LIST 'LIST A B)))) ;
>> T
>>
>> Now we see that this macro expands to code that return a s-expression.
>>
>> If you evaluate this s-expression you get what macros using once-only
>
> This is probably the key of my misunderstanding. You say "If you
> evaluate this s-expression". Isn't this the job of the evaluator?
> This additional level of evaluation proved quite surprising for me. A
> macro produces output (a list), if this list's CAR isn't a macro the
> macroexpansion is done, no further processing is performed during
> macroexpansion time, right? ONCE-ONLY (from your example) expands to a
> list which doesn't contain macro name as its CAR(s). So at that moment
> macroexpansion stopped and so did I, unable to solve the puzzle.
> Where does this additional evaluation come from?

Either it doesn't come:

[45]> (let ((a :a-template) (b :b-template)) (once-only (a b) (list 'list a b)))
(LET ((#:G4022 :A-TEMPLATE) (#:G4023 :B-TEMPLATE)) (LIST #:G4022 #:G4023))

[46]> (caadr (let ((a :a-template) (b :b-template)) (once-only (a b) (list 'list a b))))
(#:G4026 :A-TEMPLATE)

or it comes because you copy-and-paste the result back to the REPL
(removing the #:):

[47]> (LET ((G4022 :A-TEMPLATE) (G4023 :B-TEMPLATE)) (LIST G4022 G4023))
(:A-TEMPLATE :B-TEMPLATE)

or you use eval:

[49]> (let ((a :a-template) (b :b-template)) (once-only (a b) (list 'list a b)))
(LET ((#:G4030 :A-TEMPLATE) (#:G4031 :B-TEMPLATE)) (LIST #:G4030 #:G4031))
[50]> (eval *)
(:A-TEMPLATE :B-TEMPLATE)

or you return the result of once-only in another macro, and let the
macro-expansion mechanism evaluate when it expands this other macro.

[51]> (defmacro m (a b) (once-only (a b) (list 'list a b)))
M
[52]> (m :template-1 :template-2)
(:TEMPLATE-1 :TEMPLATE-2)

Here once-only is expanded at its macro-expansion time returning the
(meta) s-expression, which evaluated returns: (LET ((G4022
:A-TEMPLATE) (G4023 :B-TEMPLATE)) (LIST G4022 G4023)) This
s-expression is used by the macro M, is returned as is, but is
evaluated itself for the macroexansion of M (or DO-PRIMES).


To see it in action read CLHS about *MACROEXPAND-HOOK*.

(defun hook (expander form env)
(format t "Now expanding: ~S~%" form)
(LET ((EXPANSION (MULTIPLE-VALUE-LIST (funcall expander form env))))
(FORMAT T "~&--> ~{~s~%~^ ~}~%" EXPANSION) (VALUES-LIST EXPANSION)))

(LET ((*MACROEXPAND-HOOK* (FUNCTION HOOK)))
(PRINT :DEFMACRO-ONCE-ONLY)(TERPRI)
(defmacro once-only ((&rest names) &body body)
(let ((gensyms (loop for n in names collect (gensym (string n)))))
`(let (,@(loop for g in gensyms collect `(,g (gensym ))))
`(let (,,@(loop for g in gensyms for n in names
collect ``(,,g ,,n)))
,(let (,@(loop for n in names for g in gensyms
collect `(,n ,g)))
,@body)))))
(PRINT :COMPILE-ONCE-ONLY)(TERPRI)
(COMPILE 'ONCE-ONLY)
(PRINT :DEFMACRO-M)(TERPRI)
(defmacro m (a b) (once-only (a b) (list 'list a b)))
(PRINT :COMPILE-M)(TERPRI)
(COMPILE 'M)
(PRINT :EXECUTE-M)(TERPRI)
(m :template-1 :template-2))

;; (the details of the output depend obviously on the implementation).
;; Note that the macroexpansion time occurs here while compiling
;; (because I forced compilation with clisp, otherwise clisp would
;; have do the macroexpansion time at execution time). But the
;; macroexpansion of DEFMACRO is done at the execution time of the
;; REPL.


:DEFMACRO-ONCE-ONLY
Now expanding:
(DEFMACRO ONCE-ONLY ((&REST NAMES) &BODY BODY)
(LET ((GENSYMS (LOOP FOR N IN NAMES COLLECT (GENSYM (STRING N)))))
`(LET (,@(LOOP FOR G IN GENSYMS COLLECT `(,G (GENSYM))))
`(LET (,,@(LOOP FOR G IN GENSYMS FOR N IN NAMES COLLECT ``(,,G ,,N)))
,(LET (,@(LOOP FOR N IN NAMES FOR G IN GENSYMS COLLECT `(,N ,G)))
,@BODY)))))
-->
(LET NIL
(EVAL-WHEN (COMPILE LOAD EVAL) (SYSTEM::REMOVE-OLD-DEFINITIONS 'ONCE-ONLY)
(SYSTEM::%PUTD 'ONCE-ONLY
(SYSTEM::MAKE-MACRO
(FUNCTION ONCE-ONLY
(LAMBDA (SYSTEM::<MACRO-FORM> SYSTEM::<ENV-ARG>)
(DECLARE (CONS SYSTEM::<MACRO-FORM>)) (DECLARE (IGNORE SYSTEM::<ENV-ARG>))
(IF (< (EXT:LIST-LENGTH-DOTTED SYSTEM::<MACRO-FORM>) 2)
(SYSTEM::MACRO-CALL-ERROR SYSTEM::<MACRO-FORM>)
(LET*
((#:G4330 (CADR SYSTEM::<MACRO-FORM>)) (#:G4331 #:G4330) (NAMES #:G4331)
(BODY (CDDR SYSTEM::<MACRO-FORM>)))
(BLOCK ONCE-ONLY
(LET ((GENSYMS (LOOP FOR N IN NAMES COLLECT (GENSYM (STRING N)))))
`(LET (,@(LOOP FOR G IN GENSYMS COLLECT `(,G (GENSYM))))
`(LET
(,,@(LOOP FOR G IN GENSYMS FOR N IN NAMES COLLECT ``(,,G ,,N)))
,(LET (,@(LOOP FOR N IN NAMES FOR G IN GENSYMS COLLECT `(,N ,G)))
,@BODY))))))))))))
(EVAL-WHEN (EVAL)
(SYSTEM::%PUT 'ONCE-ONLY 'SYSTEM::DEFINITION
(CONS
'(DEFMACRO ONCE-ONLY ((&REST NAMES) &BODY BODY)
(LET ((GENSYMS (LOOP FOR N IN NAMES COLLECT (GENSYM (STRING N)))))
`(LET (,@(LOOP FOR G IN GENSYMS COLLECT `(,G (GENSYM))))
`(LET (,,@(LOOP FOR G IN GENSYMS FOR N IN NAMES COLLECT ``(,,G ,,N)))
,(LET (,@(LOOP FOR N IN NAMES FOR G IN GENSYMS COLLECT `(,N ,G)))
,@BODY)))))
(EXT:THE-ENVIRONMENT))))
'ONCE-ONLY)

Now expanding: (EXT:THE-ENVIRONMENT)
-->
(PROGN (EVAL-WHEN ((NOT EVAL)) (SYSTEM::%UNCOMPILABLE 'EXT:THE-ENVIRONMENT))
(LET ((CUSTOM:*EVALHOOK* #'SYSTEM::%THE-ENVIRONMENT)) 0))


:COMPILE-ONCE-ONLY
Now expanding: (LOOP FOR N IN NAMES COLLECT (GENSYM (STRING N)))
-->
(MACROLET ((LOOP-FINISH NIL (SYSTEM::LOOP-FINISH-ERROR)))
(BLOCK NIL
(LET ((#:G4348 NAMES))
(PROGN
(LET ((N NIL))
(LET ((#:ACCULIST-VAR-4349 NIL))
(MACROLET ((LOOP-FINISH NIL '(GO SYSTEM::END-LOOP)))
(TAGBODY SYSTEM::BEGIN-LOOP (WHEN (ENDP #:G4348) (LOOP-FINISH))
(SETQ N (CAR #:G4348))
(PROGN
(SETQ #:ACCULIST-VAR-4349
(CONS (GENSYM (STRING N)) #:ACCULIST-VAR-4349)))
(PSETQ #:G4348 (CDR #:G4348)) (GO SYSTEM::BEGIN-LOOP) SYSTEM::END-LOOP
(MACROLET
((LOOP-FINISH NIL (SYSTEM::LOOP-FINISH-WARN) '(GO SYSTEM::END-LOOP)))
(RETURN-FROM NIL (SYSTEM::LIST-NREVERSE #:ACCULIST-VAR-4349)))))))))))

Now expanding: (LOOP-FINISH)
--> (GO SYSTEM::END-LOOP)

Now expanding:
`(LET (,@(LOOP FOR G IN GENSYMS COLLECT `(,G (GENSYM))))
`(LET (,,@(LOOP FOR G IN GENSYMS FOR N IN NAMES COLLECT ``(,,G ,,N)))
,(LET (,@(LOOP FOR N IN NAMES FOR G IN GENSYMS COLLECT `(,N ,G))) ,@BODY)))
-->
(LIST 'LET (LOOP FOR G IN GENSYMS COLLECT `(,G (GENSYM)))
`(LIST 'LET (LIST ,@(LOOP FOR G IN GENSYMS FOR N IN NAMES COLLECT ``(,,G ,,N)))
(LET (,@(LOOP FOR N IN NAMES FOR G IN GENSYMS COLLECT `(,N ,G))) ,@BODY)))

Now expanding: (LOOP FOR G IN GENSYMS COLLECT `(,G (GENSYM)))
-->
(MACROLET ((LOOP-FINISH NIL (SYSTEM::LOOP-FINISH-ERROR)))
(BLOCK NIL
(LET ((#:G4356 GENSYMS))
(PROGN
(LET ((G NIL))
(LET ((#:ACCULIST-VAR-4357 NIL))
(MACROLET ((LOOP-FINISH NIL '(GO SYSTEM::END-LOOP)))
(TAGBODY SYSTEM::BEGIN-LOOP (WHEN (ENDP #:G4356) (LOOP-FINISH))
(SETQ G (CAR #:G4356))
(PROGN
(SETQ #:ACCULIST-VAR-4357 (CONS `(,G (GENSYM)) #:ACCULIST-VAR-4357)))
(PSETQ #:G4356 (CDR #:G4356)) (GO SYSTEM::BEGIN-LOOP) SYSTEM::END-LOOP
(MACROLET
((LOOP-FINISH NIL (SYSTEM::LOOP-FINISH-WARN) '(GO SYSTEM::END-LOOP)))
(RETURN-FROM NIL (SYSTEM::LIST-NREVERSE #:ACCULIST-VAR-4357)))))))))))

Now expanding: (LOOP-FINISH)
--> (GO SYSTEM::END-LOOP)

Now expanding: `(,G (GENSYM))
--> (CONS G '((GENSYM)))

Now expanding:
`(LIST 'LET (LIST ,@(LOOP FOR G IN GENSYMS FOR N IN NAMES COLLECT ``(,,G ,,N)))
(LET (,@(LOOP FOR N IN NAMES FOR G IN GENSYMS COLLECT `(,N ,G))) ,@BODY))
-->
(LIST 'LIST ''LET
(CONS 'LIST (LOOP FOR G IN GENSYMS FOR N IN NAMES COLLECT ``(,,G ,,N)))
(CONS 'LET
(CONS (LOOP FOR N IN NAMES FOR G IN GENSYMS COLLECT `(,N ,G)) BODY)))

Now expanding: (LOOP FOR G IN GENSYMS FOR N IN NAMES COLLECT ``(,,G ,,N))
-->
(MACROLET ((LOOP-FINISH NIL (SYSTEM::LOOP-FINISH-ERROR)))
(BLOCK NIL
(LET ((#:G4364 GENSYMS))
(PROGN
(LET ((G NIL))
(LET ((#:G4365 NIL))
(LET NIL
(LET ((N NIL))
(LET ((#:ACCULIST-VAR-4366 NIL))
(MACROLET ((LOOP-FINISH NIL '(GO SYSTEM::END-LOOP)))
(TAGBODY (SETQ #:G4365 NAMES) SYSTEM::BEGIN-LOOP
(WHEN (ENDP #:G4364) (LOOP-FINISH)) (SETQ G (CAR #:G4364))
(WHEN (ENDP #:G4365) (LOOP-FINISH)) (SETQ N (CAR #:G4365))
(PROGN
(SETQ #:ACCULIST-VAR-4366 (CONS ``(,,G ,,N) #:ACCULIST-VAR-4366)))
(PSETQ #:G4364 (CDR #:G4364)) (PSETQ #:G4365 (CDR #:G4365))
(GO SYSTEM::BEGIN-LOOP) SYSTEM::END-LOOP
(MACROLET
((LOOP-FINISH NIL (SYSTEM::LOOP-FINISH-WARN)
'(GO SYSTEM::END-LOOP)))
(RETURN-FROM NIL
(SYSTEM::LIST-NREVERSE #:ACCULIST-VAR-4366))))))))))))))

Now expanding: (LOOP-FINISH)
--> (GO SYSTEM::END-LOOP)

Now expanding: (LOOP-FINISH)
--> (GO SYSTEM::END-LOOP)

Now expanding: ``(,,G ,,N)
--> `(LIST ,G ,N)

Now expanding: `(LIST ,G ,N)
--> (LIST 'LIST G N)

Now expanding: (LOOP FOR N IN NAMES FOR G IN GENSYMS COLLECT `(,N ,G))
-->
(MACROLET ((LOOP-FINISH NIL (SYSTEM::LOOP-FINISH-ERROR)))
(BLOCK NIL
(LET ((#:G4374 NAMES))
(PROGN
(LET ((N NIL))
(LET ((#:G4375 NIL))
(LET NIL
(LET ((G NIL))
(LET ((#:ACCULIST-VAR-4376 NIL))
(MACROLET ((LOOP-FINISH NIL '(GO SYSTEM::END-LOOP)))
(TAGBODY (SETQ #:G4375 GENSYMS) SYSTEM::BEGIN-LOOP
(WHEN (ENDP #:G4374) (LOOP-FINISH)) (SETQ N (CAR #:G4374))
(WHEN (ENDP #:G4375) (LOOP-FINISH)) (SETQ G (CAR #:G4375))
(PROGN
(SETQ #:ACCULIST-VAR-4376 (CONS `(,N ,G) #:ACCULIST-VAR-4376)))
(PSETQ #:G4374 (CDR #:G4374)) (PSETQ #:G4375 (CDR #:G4375))
(GO SYSTEM::BEGIN-LOOP) SYSTEM::END-LOOP
(MACROLET
((LOOP-FINISH NIL (SYSTEM::LOOP-FINISH-WARN)
'(GO SYSTEM::END-LOOP)))
(RETURN-FROM NIL
(SYSTEM::LIST-NREVERSE #:ACCULIST-VAR-4376))))))))))))))

Now expanding: (LOOP-FINISH)
--> (GO SYSTEM::END-LOOP)

Now expanding: (LOOP-FINISH)
--> (GO SYSTEM::END-LOOP)

Now expanding: `(,N ,G)
--> (LIST N G)


:DEFMACRO-M
Now expanding: (DEFMACRO M (A B) (ONCE-ONLY (A B) (LIST 'LIST A B)))
-->
(LET NIL
(EVAL-WHEN (COMPILE LOAD EVAL) (SYSTEM::REMOVE-OLD-DEFINITIONS 'M)
(SYSTEM::%PUTD 'M
(SYSTEM::MAKE-MACRO
(FUNCTION M
(LAMBDA (SYSTEM::<MACRO-FORM> SYSTEM::<ENV-ARG>)
(DECLARE (CONS SYSTEM::<MACRO-FORM>)) (DECLARE (IGNORE SYSTEM::<ENV-ARG>))
(IF (/= (EXT:LIST-LENGTH-DOTTED SYSTEM::<MACRO-FORM>) 3)
(SYSTEM::MACRO-CALL-ERROR SYSTEM::<MACRO-FORM>)
(LET* ((A (CADR SYSTEM::<MACRO-FORM>)) (B (CADDR SYSTEM::<MACRO-FORM>)))
(BLOCK M (ONCE-ONLY (A B) (LIST 'LIST A B))))))))))
(EVAL-WHEN (EVAL)
(SYSTEM::%PUT 'M 'SYSTEM::DEFINITION
(CONS '(DEFMACRO M (A B) (ONCE-ONLY (A B) (LIST 'LIST A B)))
(EXT:THE-ENVIRONMENT))))
'M)

Now expanding: (EXT:THE-ENVIRONMENT)
-->
(PROGN (EVAL-WHEN ((NOT EVAL)) (SYSTEM::%UNCOMPILABLE 'EXT:THE-ENVIRONMENT))
(LET ((CUSTOM:*EVALHOOK* #'SYSTEM::%THE-ENVIRONMENT)) 0))


:COMPILE-M
Now expanding: (ONCE-ONLY (A B) (LIST 'LIST A B))
-->
(LET ((#:A4400 (GENSYM)) (#:B4401 (GENSYM)))
(LIST 'LET (LIST (LIST #:A4400 A) (LIST #:B4401 B))
(LET ((A #:A4400) (B #:B4401)) (LIST 'LIST A B))))


:EXECUTE-M
Now expanding: (M :TEMPLATE-1 :TEMPLATE-2)
--> (LET ((#:G4404 :TEMPLATE-1) (#:G4405 :TEMPLATE-2)) (LIST #:G4404 #:G4405))

(:TEMPLATE-1 :TEMPLATE-2)
[73]>


--
__Pascal Bourguignon__ http://www.informatimago.com/
You're always typing.
Well, let's see you ignore my
sitting on your hands.
.

Relevant Pages

  • Re: Thumb Position??
    ... Nil wrote: ... If you were interested in expanding your narrow outlook, ... Back the fuck off. ...
    (alt.guitar.beginner)
  • Re: How can this macro be improved?
    ... > nil))) ... Macro Lambda Lists ... at your macroexpansion. ... there is a matrix-form which I intend to be evaluated ...
    (comp.lang.lisp)
  • Re: Yet another when to use macros question....
    ... macro expanding time can be eliminated ... do you actually have any empirical evidence that macro expansion is ... Since X represents code that you will later execute then before making N ...
    (comp.lang.lisp)
  • Re: Problem with the lambda form
    ... common lisp. ... With CL macros you can have any embedded language expanding to lisp ... Any language feature that can be implemented by a Turing machine can be included, using a suitable macro to implement it. ... Of course there is a guarantee: a macro is guaranteed to be expanded at least once before the code is executed. ...
    (comp.lang.lisp)
  • Re: macro expansion
    ... 'NIL ')) ... If PCL recommended using macroexpansion to debug macros it means of your /application/ of your macro, not of the defmacro form in which you define your macro. ...
    (comp.lang.lisp)