SRFI-26’s cut macro
I’m working on an introduction to lisp presentation for Plug West. I’m trying to think through examples of macros which are a good demonstration of what they’re for. Towards that end I picked Scheme’s srfi-26’s cut macro, which allows for specialization of argument, and try to extend it in a couple of ways. Below is the example code, including a simplified cut, a recursive (or tree) cut, and a pattern cut (which allows the cut points to be named).
;; the scheme cut macro...srfi-26, when written as:
;;
;; (cut #'format "~a~&" <>)
;;
;; it produces:
;;
;; => #'(lambda (x) (format "~a~&" x))
;;
;; 'Lifting' the '<>' out of the form as an argument to the generated lambda.
;; It's 'flat' though, it'd be nice to have something which could work
;; on any form...a recursive cut, which is what we'll write, first a helper:
(defmacro aprog1 (it &rest body)
"Anaphoric prog1, returns the value of the first expression,
executing all subsequent expressions for their side effects. It binds
the symbol 'it' to the result of the first expression. This can also
be seen as a 'construct and initialize' pattern.
(aprog1
(make-hash-table :test #'equal)
(setf (gethash \"a\" it) 1)
(setf (gethash \"b\" it) 2)
(setf (gethash \"c\" it) 3))
=> #<HASH-TABLE :TEST EQUAL :COUNT 3 {BE49831}>
"
`(let ((it ,it))
,@body
it))
(defmacro cut (fn &rest body)
"srfi-26's cut in Common Lisp, some examples:
(cut #'cons (+ a 1) <>) is the same as (lambda (x2) (cons (+ a 1) x2))
(cut #'list 1 <> 3 <> 5) is the same as (lambda (x2 x4) (list 1 x2 3 x4 5))
(cut #'list) is the same as (lambda () (list))
(cut #'list 1 <> 3 <...>) is the same as (lambda (x2 . xs) (apply list 1 x2 3 xs))
The following form is not supported in this version:
(cut <> a b) is the same as (lambda (f) (f a b))
Scheme does that simply by virte that it is a Lisp-1, I didn't go through the
effort of doing the check. "
(let* ((formals (list))
(new-body
(mapcar #'(lambda (item)
(if (equal '<> item)
(aprog1
(gensym)
(push it formals)
it)
item))
body)))
`#'(lambda ,(reverse formals)
(funcall ,fn ,@new-body))))
;; lets take a look at an expansion and try a couple of examples
;; (macroexpand-1 '(cut #'format t "~a: ~a~&" "thing" <>))
;; (funcall (cut #'format t "~a: ~a~&" "thing" <>) 10)
;; (funcall (cut #'format t "~a: ~a~&" <> <>) "thing" 10)
;; Our next helper, the visitor pattern, invoke the function
;; on each non-branch (leaf node) element in the tree, replacing
;; the existing value with fn's result. NB: this is a depth first
;; search.
(defun map-tree (fn tree)
(cond ((null tree)
tree)
((not (listp tree))
(funcall fn tree))
(t
(mapcar #'(lambda (elt) (map-tree fn elt)) tree))))
;; test it out, this should increment each number in the tree:
;; (map-tree #'(lambda (elt) (format t "x:~a~&" elt) (1+ elt)) '(1 2 (3 4 (5 6 (7)))))
;; With those tools we can enhance cut to use map-tree instead of map, providing
;; the recursive search for cut points.
(defmacro rcut (&rest body)
(let* ((formals (list))
(new-body
(map-tree #'(lambda (elt)
(if (equalp '<> elt)
(aprog1
(gensym)
(push it formals)
it)
elt))
body)))
`#'(lambda ,(reverse formals)
,@new-body)))
;; see what it expands to
(macroexpand-1
'(rcut
(cond ((> <> 1)
(format t "first arg was >1, second arg is: ~a~&" <>))
(t
(format t "first arg was <1, third arg is: ~a~&" <>)))))
;; test out the resulting function
(let ((fn
(rcut
(cond ((> <> 1)
(format t "first arg was >1, second arg is: ~a~&" <>))
(t
(format t "first arg was <1, third arg is: ~a~&" <>))))))
(funcall fn 1/2 'a 'b)
(funcall fn 2/1 'a 'b))
;; that's all well and good, but the whole depth first ordering can
;; be hard to think through with respect to how it maps to the
;; ordering of the function arguments. What we want to try next
;; is pcut (pattern cut), for example:
;;
;; (pcut
;; (cond ((> ?fst 1)
;; (format t "first arg (~a) was >1, x is: ~a~&" ?fst ?x))
;; (t
;; (format t "first arg (~a) was <1, x is: ~a, y is:~a~&" ?fst ?x ?y)))
;;
;; The ordering still mattes, it's still depth-first, but now we can re-use arguments by
;; name, without inventing new locals.
;; Helper predicate to see if we have a cut pattern symbol
(defun starts-with-? (sym)
(equal "?" (subseq (format nil "~a" sym) 0 1)))
;; the main difference here is DRY (don't repeat yourself,
;; only capture each named binding once), and use the #'starts-with-?
;; predicate instead of the equality test (#'equalp).
(defmacro pcut (&rest body)
(let* ((formals (list))
(fml-hash (make-hash-table :test #'equal))
(new-body
(map-tree #'(lambda (elt)
(if (starts-with-? elt)
(aprog1
(or (gethash elt fml-hash)
(aprog1
(gensym)
(push it formals)
(setf (gethash elt fml-hash) it)
it))
it)
elt))
body)))
`#'(lambda ,(reverse formals)
,@new-body)))
;; take a look at the expansion
(macroexpand-1
'(pcut
(cond ((> ?fst 1)
(format t "first arg (~a) was >1, x is: ~a~&" ?fst ?x))
(t
(format t "first arg (~a) was <1, x is: ~a, y is:~a~&" ?fst ?x ?y)))))
;; test out the expansion
(let ((fn (pcut
(cond ((> ?fst 1)
(format t "first arg (~a) was >1, x is: ~a~&" ?fst ?x))
(t
(format t "first arg (~a) was <1, x is: ~a, y is:~a~&" ?fst ?x ?y))))))
(funcall fn 1/2 'a 'b)
(funcall fn 2/1 'a 'b))
Conclusion
Hopefully these are useful pedagalogical examples of macros in Common Lisp.