...formerly, this was called the "Lisp-1 vs. Lisp-2" issue. However,
this code shows that Lisp-1 vs Lisp-2 is not what the fuzz is all about
- it is in fact just about a certain programming style that treats the
first positions in cons expressions specially. And you can get that in
CL as well without resorting to Lisp-1 semantics.
The following code has two parts:
- with-funcalls is a low-level macro that allows you to specify that
either conses in first positions are funcall'ed in its body, or symbols
from a specific set, or both. Here is how it goes:
(with-funcalls t (a b c)
...)
The first parameter is a boolean flag that turns funcalls for conses on
or off; the second parameter is a list of symbols that are funcall'ed in
first positions; the rest is an implicit progn in which these settings
are switched on.
- letrec is the high-level access to with-funcalls. It switches funcall
treatment of conses on, and takes a list of function definitons (given
in Scheme style) and turns funcall treatment on for the symbols that are
defined as functions by that letrec form. Examples:
(letrec ((f (lambda (x) (+ x x))))
(list (f 5) (f 6) (f 7)))
=> (10 12 14)
(letrec ((f (lambda (x) (lambda (y) (+ x y)))))
((f 5) 6))
=> 11
I have tested the code to a certain degree with Macintosh Common Lisp
5.0. However, I can't guarantee that it is free of bugs. (Warning: Bugs
can be very annoying because I modify the macro expansion hook, and that
hook is usually used by the CL environment for all macros.)
Still, I am pretty sure by now that it this code is conceptually sound.
Thanks to Erann Gat, Kent Pitman and Dorai Sitaram for giving me the key
ideas.
Any kind of feedback is appreciated - especially with regard to the way
I pass information around between macro calls, because it's the first
time that I have done so.
Here is the code:
(defvar *original-macroexpand-hook* *macroexpand-hook*)
(setq *macroexpand-hook* *original-macroexpand-hook*)
(define-symbol-macro funcall-conses nil)
(define-symbol-macro funcall-symbols nil)
(defun with-funcalls-hook (expander form env)
(if (macro-function (car form) env)
(let ((result (funcall *original-macroexpand-hook* expander form
env))
(funcall-conses (macroexpand 'funcall-conses env))
(funcall-symbols (macroexpand 'funcall-symbols env)))
(if (or funcall-conses funcall-symbols)
(functify result funcall-conses funcall-symbols env)
result))
form))
(defun functify (form conses symbols env)
(labels
((funky-form (form)
(if (consp form)
(cond ((symbolp (car form))
(cond ((member (car form) symbols)
`(funcall ,(car form) ,@(mapcar #'funky-form (cdr
form))))
((eq 'declare (car form))
form)
((eq 'lambda (car form))
(funky-lambda form))
((special-operator-p (car form))
(funky-special form))
((macro-function (car form) env)
form)
(t `(,(car form) ,@(mapcar #'funky-form (cdr
form))))))
((consp (car form))
(cond ((eq 'lambda (caar form))
`(,(funky-lambda (car form)) ,@(mapcar
#'funky-form (cdr form))))
(conses
`(funcall ,@(mapcar #'funky-form form)))
(t form)))
(t form))
form))
(funky-lambda (lambda-form)
`(lambda ,(nth 1 lambda-form) ,@(mapcar #'funky-form (nthcdr 2
lambda-form))))
(funky-special (form)
(ccase (car form)
((block eval-when multiple-value-call return-from the)
(destructuring-bind
(op non-eval &rest forms) form
`(,op ,non-eval ,@(mapcar #'funky-form forms))))
((flet labels macrolet)
(destructuring-bind
(op defs &rest forms) form
`(,op ,(mapcar (lambda (def)
(destructuring-bind
(name args &rest forms) def
`(,name ,args ,@(mapcar #'funky-form
forms))))
defs)
,@(mapcar #'funky-form forms))))
((go load-time-value quote) form)
((catch function if locally multiple-value-prog1 progn progv
tagbody throw unwind-protect)
(destructuring-bind
(op &rest forms) form
`(,op ,@(mapcar #'funky-form forms))))
((let let*)
(destructuring-bind
(op defs &rest forms) form
`(,op ,(mapcar (lambda (def)
(if (consp def)
`(,(car def) ,(funky-form (cadr def)))
def))
defs)
,@(mapcar #'funky-form forms))))
(setq
(destructuring-bind
(op &rest sets) form
`(,op ,@(let (switch)
(mapcar (lambda (elem)
(setf switch (not switch))
(if switch elem (funky-form elem)))
sets)))))
(symbol-macrolet
(destructuring-bind
(op defs &rest forms) form
`(,op ,(mapcar (lambda (def)
(destructuring-bind
(sym form) def
`(,sym ,(funky-form form))))
defs)
,@(mapcar #'funky-form forms)))))))
(funky-form form)))
(defmacro with-funcalls (conses symbols &environment env &body body)
(assert (every (lambda (sym)
(and (not (special-operator-p sym))
(not (member sym '(declare lambda)))))
symbols))
`(let ,symbols
(symbol-macrolet (,(if conses '(funcall-conses t))
(funcall-symbols ,(append symbols (macroexpand
'funcall-symbols env))))
(macrolet ((trigger-with-funcalls (form) form))
(trigger-with-funcalls (progn ,@body))))))
(defmacro letrec (defs &body body)
`(with-funcalls t ,(mapcar (lambda (def) (if (consp def) (car def)
def)) defs)
,@(loop for def in defs
when (consp def) collect `(setf ,(car def) ,(cadr def)))
,@body))
(setq *macroexpand-hook* #'with-funcalls-hook)