Explanation of macros; Haskell macros
prunesquallor at comcast.net
prunesquallor at comcast.net
Mon Oct 6 22:51:28 EDT 2003
mike420 at ziplip.com writes:
> I think others dropped the ball while trying to explain macros
> to non-Lispers recently. The examples I saw posted were either
> too difficult or easily doable without macros (maybe even easier).
Macros from production code:
(defmacro debug-message (noise format-string &rest args)
"Print a message on *DEBUG-IO* using FORMAT-STRING and ARGS
iff the *DEBUG-NOISE-LEVEL* is equal to or greater than NOISE.
When writing code, sprinkle calls to DEBUG-MESSAGE at strategic
points to aid in debugging. The different noise levels should be
used at different semantic levels in the code. Level 0 is
for only the highest level of functionality, Level 3 is for
module level, Level 5 is for extreme detail."
(if (and (boundp '*disable-debug-messages*)
(eq *disable-debug-messages* t))
`(PROGN)
(let ((noise-var (gensym "NOISE-VAR-")))
`(LET ((,noise-var ,noise))
#+ALLEGRO (DECLARE (:FBOUND FORMAT-DEBUG-MESSAGE))
(WHEN-DEBUGGING ,noise-var
(FORMAT-DEBUG-MESSAGE ,noise-var ,format-string (LIST , at args)))))))
This macro lets me write thing like:
(debug-message 2 "Beginning major phase ~s" *phase*)
at various places in the code. The amount of debugging noise is
determined by a global variable. If the variable
*DISABLE-DEBUG-MESSAGES* is bound to 't at compile time, the code is
omitted completely. This is done when a customer build is created.
(defmacro ignore-errors-unless (condition &body forms)
"Unless CONDITION evaluates to TRUE, act as IGNORE-ERRORS does while executing FORMS, with the
the same return values. If CONDITION evaluates to TRUE, when we don't ignore errors, however
the return value is as if an IGNORE-ERRORS were around the form.
Example: (ignore-errors-unless *debugging* (do stuff) (do more stuff) ...)
(ignore-errors-unless (eq *debugging* 2) (do stuff) (do more stuff) ...)"
(let ((block-name (gensym "IGNORE-ERRORS-UNLESS-BLOCK-"))
(cond-value (gensym "IGNORE-ERRORS-UNLESS-COND-VALUE-")))
;; Evaluate the cond value before the body for less confusing semantics.
;; (We don't want the block established around the conditional).
`(LET ((,cond-value ,condition))
(BLOCK ,block-name
(HANDLER-BIND (#+allegro (EXCL:INTERRUPT-SIGNAL #'SIGNAL)
(CL:ERROR (FUNCTION
(LAMBDA (CONDITION)
#+ALLEGRO (DECLARE (:FBOUND DEBUG-NOTE-CONDITION))
(UNLESS ,cond-value
(DEBUG-NOTE-CONDITION "caught by an ignore-errors-unless form" CONDITION)
(RETURN-FROM ,block-name
(values NIL CONDITION)))))))
(VALUES (LOCALLY , at forms) NIL))))))
As you might imagine, this one discards errors unless some
condition is true.
(defmacro ignore-errors-unless-debugging (&rest body)
"Just like IGNORE-ERRORS, except that if *debug-noise-level* is non-nil,
errors are not ignored."
`(IGNORE-ERRORS-UNLESS (AND *DEBUG-NOISE-LEVEL*
(NULL *IGNORE-ERRORS-EVEN-IF-DEBUGGING*))
, at body))
Very handy when debugging a server. When serving web requests, you don't
want errors to take down the entire server. Yet when you are debugging
it, you don't want to suppress them. Of course, when you are running
test regressions during debugging, you *do* want to suppress them....
Occasionally I have to move large amounts of data very fast. There
are common-lisp functions for doing this, but sometimes you need to go
flat out as fast as possible. This generally requires adding a lot of
declarations. But a function that is declared to operate solely on,
say, 1-byte wide vectors looks amazingly like one that operates on
2-byte wide vectors, except for the declarations. Hence the macro:
(define-fast-subvector-mover %simple-subvector-8b-move simple-array (unsigned-byte 8))
which expands into:
(PROGN
(DECLAIM (FTYPE
#'((SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)) (INTEGER 0 (8388608)) (INTEGER 0 (8388608)) (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)) (INTEGER 0 (8388608)))
%SIMPLE-SUBVECTOR-8B-MOVE-LEFT
%SIMPLE-SUBVECTOR-8B-MOVE-RIGHT))
(DEFUN %SIMPLE-SUBVECTOR-8B-MOVE-LEFT (SOURCE SRC-START SRC-LIMIT DEST DEST-START)
(DECLARE (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)) SOURCE)
(TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)) DEST)
(TYPE (INTEGER 0 (8388608)) SRC-START SRC-LIMIT DEST-START)
(OPTIMIZE
(COMPILATION-SPEED 0)
(DEBUG 0)
(SAFETY 0)
(SPACE 0)
(SPEED 3)))
(PROGN
(LOOP
(PROGN
(WHEN (= SRC-START SRC-LIMIT) (RETURN-FROM NIL NIL))
(SETF (AREF DEST DEST-START) (AREF SOURCE SRC-START))
(INCF SRC-START)
(INCF DEST-START)))))
(DEFUN %SIMPLE-SUBVECTOR-8B-MOVE-RIGHT (SOURCE SRC-START SRC-LIMIT DEST DEST-START)
(DECLARE (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)) SOURCE)
(TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)) DEST)
(TYPE (INTEGER 0 (8388608)) SRC-START SRC-LIMIT DEST-START)
(OPTIMIZE
(COMPILATION-SPEED 0)
(DEBUG 0)
(SAFETY 0)
(SPACE 0)
(SPEED 3)))
(PROGN
(PROGN
(INCF DEST-START (- SRC-LIMIT SRC-START))
(LOOP
(WHEN (= SRC-LIMIT SRC-START) (RETURN-FROM NIL NIL))
(DECF SRC-LIMIT)
(DECF DEST-START)
(SETF (AREF DEST DEST-START) (AREF SOURCE SRC-LIMIT)))))))
A decent lisp compiler can compile this into *very* tight code.
But even better is the fact that if you need to move 2-byte arrays
around, you don't have to write anything more than:
(define-fast-subvector-mover %simple-subvector-16b-move simple-array (unsigned-byte 16))
Let us suppose that we have a function that takes function
as an argument. For instance,
(defun my-mapc (func list)
(dolist (element list)
(funcall func element)))
Now this works, but in performance critical code it may
be a bottleneck (closure creation and funcalling).
It'd be nice if the compiler knew how to handle this specially.
This following function is a parser for literal lambda expressions:
(defun destructure-function-lambda (arity fl receiver if-not-function)
"If fl is of the form (FUNCTION (LAMBDA (bound-variable-list) docstring decls body))
invoke receiver on the bound-variable-list, docstring, decls, and the body.
If fl is of the form (FUNCTION name), invoke receiver on a
fake eta-expanded form.
If fl is of the form NAME, invoke receiver on a
fake eta-expanded form.
Otherwise invoke if-not-function."
(macrolet ((list-length-equals-one (list)
`(AND (CONSP ,list)
(NULL (CDR ,list))))
(list-length-greater-than-one (list)
`(AND (CONSP ,list)
(CONSP (CDR ,list))))
(is-function-form (form)
`(AND (CONSP ,form)
(EQ (CAR ,form) 'FUNCTION)
(LIST-LENGTH-EQUALS-ONE (CDR ,form))))
(function-form-body (function-form)
`(CADR ,function-form))
(is-lambda-form (form)
`(AND (CONSP ,form)
(EQ (CAR ,form) 'LAMBDA)
(LIST-LENGTH-GREATER-THAN-ONE (CDR ,form))))
(lambda-form-arguments (lambda-form)
`(CADR ,lambda-form))
(lambda-form-body (lambda-form)
`(CDDR ,lambda-form)))
(cond ((is-function-form fl)
(let ((pl (function-form-body fl)))
;; Look for `(LAMBDA ...)
(cond ((is-lambda-form pl)
(multiple-value-bind (docstring declarations body)
(split-declarations (lambda-form-body pl))
(funcall receiver (lambda-form-arguments pl) docstring declarations body)))
;; can't fake eta expand if arity is unknown
((null arity) (funcall if-not-function))
((symbolp pl) ; is something like (function foo)
;; perform eta expansion
(let ((arglist nil))
(dotimes (i arity)
(push (gensym "ARG-") arglist))
(funcall receiver arglist nil nil `((,pl , at arglist)))))
(t (funcall if-not-function)))))
;; Look for naked '(lambda ...)
;; treat as if it were '(function (lambda ...))
((is-lambda-form fl)
(multiple-value-bind (docstring declarations body)
(split-declarations (lambda-form-body fl))
(funcall receiver (lambda-form-arguments fl) docstring declarations body)))
;; Can't fake an eta expansion if we don't know the arity.
((null arity) (funcall if-not-function))
;; Perform an ETA expansion
((symbolp fl)
(let ((arglist nil))
(dotimes (i arity)
(push (gensym "ARG-") arglist))
(funcall receiver arglist nil nil `((FUNCALL ,fl , at arglist)))))
(t (funcall if-not-function)))))
Now we can use it as follows:
(defmacro my-mapc (func list)
(destructure-function-lambda 1 func
(lambda (bvl docstr decls body)
(declare (ignore docstr))
`(DOLIST (,(car bvl) ,list)
, at decls
, at body))
(lambda ()
(error "~s cannot be destructured." func))))
And here is the result:
(macroexpand-1 '(my-mapc #'(lambda (x) (+ x 2)) some-list))
=> (DOLIST (X SOME-LIST) (+ X 2))
(macroexpand-1 '(my-mapc (lambda (x) (+ x 2)) some-list))
=> (DOLIST (X SOME-LIST) (+ X 2))
(macroexpand-1 '(my-mapc #'print some-list))
=> (DOLIST (#:ARG-9909 SOME-LIST) (PRINT #:ARG-9909))
When I want to emit a web page with an applet on it,
there is a ton of boilerplate that has to go out. But the
boilerplate is parameterized, so you can't just write a text
file and be done with it. This macro abstracts that away:
(defmacro html-with-applet (req &body body)
(with-unique-names (command ticket comment success-page fail-page)
`(PROGN
(EMIT-HTML-HEADER (NET.ASERVE:REQUEST-REPLY-STREAM ,req))
(MACROLET ((EMBED-APPLET (,COMMAND ,TICKET ,COMMENT ,SUCCESS-PAGE ,FAIL-PAGE)
`(NET.ASERVE::HTML
((:div :id "applet-container")
(:P ,,comment)
((:object
:code "Applet.class"
:id "applet"
:width "100%"
:height "300"
:standby "Loading applet...")
((:param :name "URL"
:value (render-uri (extend-uri-query
(net.aserve:request-uri req)
'(:absolute "applet-callback.htm")
`((:command . ,',,command)
(:ticket . ,,,ticket)))
nil)))
((:param name "SUCCESSURL" value (render-uri
(extend-uri-query
(net.aserve:request-uri req)
`(:absolute ,',,success-page)
`((:ticket . ,,,ticket)))
nil)))
((:param name "FAILURL" value (render-uri
(extend-uri-query
(net.aserve:request-uri req)
`(:absolute ,',,fail-page)
`((:ticket . ,,,ticket)))
nil))))))))
(NET.ASERVE::HTML , at body))
(EMIT-HTML-TRAILER (NET.ASERVE:REQUEST-REPLY-STREAM ,req)))))
This macro writes a macro with backquoted list structure in it.
The user of this macro simply writes:
(embed-applet :file-browser
ticket
"Select a file."
"file-selected.htm"
"cancel.htm")
Within the template.
I don't think these are too complicated to understand, and
although some of them could be handled by functions and such,
they pretty much capture *exactly* what I want write. You don't
need to understand `idioms' and `patterns' to know to
embed an applet.
More information about the Python-list
mailing list