Lisp Macrology

Post crazy Lisp macros you've written in this thread.

I'll start off with a quick one I wrote 15minutes ago, PROGK:


(defun split-at-n (list n)
  "Splits after N elements."
  (cond
    ((zerop n) (values nil list))
    (t (loop for i from 0 below n
           for rest on list          
           collect (car rest) into first
           finally (return (values first (cdr rest)))))))

;;; Not tail-recursive, might be worth re-writing a bit to be tail-recursive or just use a loop
(defun split-at (list &rest split-points)
  "Splits after each split point in split-points.
   Split points are amount of elements that must pass for there to be a split"
  (if (null split-points)
      list
      (let ((first-split (car split-points)))
        (multiple-value-bind (first rest) (split-at-n list first-split)
          (multiple-value-call #'values first
                               (apply #'split-at rest (cdr split-points)))))))

;;; Just wrote this because it was similar to the first version
;;; of SPLIT-AT that I wrote.
(defun split-at-offset (list &rest split-points)
  (split-at list
   (cons (car split-points)
         (mapcar #'(lambda (a b) (- a b)) (cdr split-points) split-points))))


;;; Works similar to Norvig's ONCE-ONLY macro
(defmacro once-only (variables &body body)
  (let ((gensyms (loop repeat (length variables) collect (gensym))))
    ``(let (,,@(mapcar #'(lambda (g v) ``(,',g ,,v)) gensyms variables))
        ,(let ,(mapcar #'(lambda (g v) `(,v ',g)) gensyms variables)
              ,@body))))

(defmacro progk (k &body forms)
  "Evaluates forms in order, and returns the values of k-th form.
   Index starts at 0. If k is out of the bounds, NIL will be returned."
  (let ((kv (gensym)))
    (typecase k
      ;; Known value - optimized, handle at macroexpansion time
      (integer
       (multiple-value-bind (first second third)
           (split-at forms k (1+ k))
         `(let ((,kv nil))
            (progn ,@first
                   ,(when second
                          `(setf ,kv
                                 ;; Remove this conditional if you want an
                                 ;; error to be signaled if K is out of bounds
                                 (multiple-value-list ,@second)))
                   ,@third
                   (values-list ,kv)))))
      ;; Unknown value - handle at runtime
      (t
       (let ((glist (gensym "GLIST-"))
             (gs (loop repeat (length forms) collect (gensym))))
         (once-only (k)
           `(let ,gs
              (declare (special ,@gs)) ; this feels very hacky, is there a safer way?
              (let ((,glist ',gs))
                (progn
                  ,@(mapcar #'(lambda (form g) `(setf ,g (multiple-value-list ,form))) forms gs)
                  (values-list (symbol-value (nth ,k ,glist))))))))))))

;;;; Example usage:

;;; Optimized case
(progk 0
  (loop for i from 1 to 10 collect i) ;=> (1 2 3 4 5 6 7 8 9 10)
  (values 'whatever 1))

;;; General case
(let ((n 1))
  (progk n
    'abc
    (values 'def 1)
    'ghj)) ; => DEF,1

Criticism, improvements welcome, as I've only been coding in CL for about 2 months now.
I wonder if the general case can be done without the hack above, or without involving a (dynamic) symbol's value.

Maybe like this? Not really tested or debugged. And probably if you actually use this you're writing confusing code. Better to write it out so you can put the SETF visually by the code it actually applies to.
(defmacro progk (k &body forms)
  (let ((vs (gensym "VS")))
    `(let (,vs)
       ,@(loop for f in forms
            for i = 0 then (1+ i)
            collect (if (= i k)
                        `(setf ,vs (multiple-value-list ,f))
                        f))
       (values-list ,vs))))

Oops,
(split-at forms k (1+ k))
is supposed to be
(split-at forms k 1)
I forgot to update it after rewriting SPLIT-AT (it was originally like SPLIT-AT-OFFSET

>>3
That works too, as long as k is a number, my version handles cases where it's a form too.
Anyway, I don't use PROGK, it was just something I was wondering how to do, and decided to write it as an exercise in macro writing.

(defmacro progk (k &body forms)
  (let ((vs (gensym "VS"))
        (kv (gensym "KV")))
    `(let (,vs
           (,kv ,k))
       ,@(loop for f in forms
            for i = 0 then (1+ i)
            collect `(if (= ,i ,kv)
                         (setf ,vs (multiple-value-list ,f))
                         ,f))
       (values-list ,vs))))
Even less pretty, tested, and well-thought-out.

>>1
Why are you even using a macro for this?

(defun progk (k &rest body)
  (if (<= k (length body))
      nil
    (nth k body)))

>>7
Did you even read the macro? Your code just returns the k-th expression.
What PROGK does is evaluate(at runtime, of course) all forms, then returns the value of the k-th form. K can be a number of a form which is evaluated(at runtime, again). If it's a number, the macro generates more efficient code, if it's an expression, it arranges so it would be evaluated at runtime, and then returns the k-th form.

It's a generalization of PROGN,PROG1,PROG2.

Oh, fuck... A function would work too I suppose, it may be just slightly slower, but shouldn't be very costly. Thank you for the interesting insight >>7

*face-palm*

>>10
What if one of my body forms refers to a variable outside PROGK?

Hmm, how about generating code for all possible values of K, then jumping to the correct version at runtime?

>>12
Isn't that what all the other macros posted in this thread do, in one form or another?
However, there is no jumping, all forms are evaluated, and the value(s) of the k-th form are returned. If you just jump to one of the forms, then it would have different semantics (prog* forms are usually used for side-effects, jumping would change the semantics). It would be easy to do it by using a CASE or COND form.

However, using COND, would avoid the need for the dynamic variable hack used in the generic version. Thank you for the idea >>12

>>12
Just implemented your idea, finally got rid of the hacky specials used in the general case:

(defmacro progk (k &body forms)
  "Evaluates forms in order, and returns the values of k-th form.
   Index starts at 0. If k is out of the bounds, NIL will be returned."
  (let ((kv (gensym)))
    (typecase k
      ;; Known value - optimized, handle at macroexpansion time
      (integer
       (multiple-value-bind (first second third)
           (split-at forms k 1)
         `(let ((,kv nil))
            (progn ,@first
                   ,(when second
                          `(setf ,kv
                                 ;; Remove this conditional if you want an
                                 ;; error to be signaled if K is out of bounds
                                 (multiple-value-list ,@second)))
                   ,@third
                   (values-list ,kv)))))
      ;; Unknown value - handle at runtime
      (t
       (let ((gs (loop repeat (length forms) collect (gensym))))
         (once-only (k)
           `(let ,gs
              (progn
                  ,@(mapcar #'(lambda (form g) `(setf ,g (multiple-value-list ,form))) forms gs)
                  (case ,k
                    ,@(loop for i from 0 to (length forms)
                           for g in gs collect `(,i ,g)))))))))))

>>13
What I mean is: generate code for k=0 that consists of the zeroth form in a SETF followed by the other forms, then follow that up with the same thing except the SETF wraps the oneth form, and so on. Then at runtime, when the value of k is actually known, jump to the proper version. By this means we could avoid having to do a comparison for every single form.

Damn, I should test my code before I post, minor fix:

(defmacro progk (k &body forms)
  "Evaluates forms in order, and returns the values of k-th form.
   Index starts at 0. If k is out of the bounds, NIL will be returned."
  (let ((kv (gensym)))
    (typecase k
      ;; Known value - optimized, handle at macroexpansion time
      (integer
       (multiple-value-bind (first second third)
           (split-at forms k 1)
         `(let ((,kv nil))
            (progn ,@first
                   ,(when second
                          `(setf ,kv
                                 ;; Remove this conditional if you want an
                                 ;; error to be signaled if K is out of bounds
                                 (multiple-value-list ,@second)))
                   ,@third
                   (values-list ,kv)))))
      ;; Unknown value - handle at runtime
      (t
       (let* ((nforms (length forms))
              (gs (loop repeat nforms collect (gensym))))
         (once-only (k)
           `(let ,gs
              (progn
                  ,@(mapcar #'(lambda (form g) `(setf ,g (multiple-value-list ,form))) forms gs)
                  (case ,k
                    ,@(loop for i from 0 to nforms
                         for g in gs collect `(,i (values-list,g))))))))))))

>>16, isn't this what >>15,17 does?

>>18
No, it stores all the results then returns the proper one.

>>19
I think I see what you mean, that would reduce the number of needed temporary variables to one, but it would probably increase the code size by a bit.

>>20
Yes. I have no idea which would end up being faster.

(defmacro progk (k &body forms)
  (flet ((for-k (k)
           `(,k ,@(subseq forms 0 k)
                (multiple-value-prog1 ,@(subseq forms k)))))
    `(case ,k
       ,@(loop for case from 0 below (length forms) collect (for-k case)))))

Heh.

Let's do this some more.

>>23
Let's do YOUR MOM some more LOL

>>24
Okay, I'm down.

>>24
Me three...No sloppy seconds!

>>24-26
Room for one more, chaps?

Now you know why I'm called Guy "Steele".

>>28
Gay for Gee Ess Jay

Here's a macro that might be of interest: LETF and LETF*, their goal is to bind places to specified values, akin to LET and LET*.

This is Erik Naggum's implementation of these operators:

(defun letf-bindings (bindings environment)
  (let ((savers ())
        (setters ())
        (restorers ()))
    (loop
     for (place values-form) in bindings do
      (multiple-value-bind (vars vals stores setter getter)
          (get-setf-expansion place environment)
        (let ((save (gensym))
              (store (first stores))
              (multiple-values (rest stores)))
          (setf savers (nconc (nreverse (mapcar #'list vars vals)) savers))
          (push `(,save ,(if multiple-values
                           `(multiple-value-list ,getter)
                           getter))
                savers)
          (push (if multiple-values
                  `(multiple-value-bind ,stores ,values-form ,setter)
                  `(let ((,store ,values-form)) ,setter))
                setters)
          (push (if multiple-values
                  `(multiple-value-bind ,stores (values-list ,save) ,setter)
                  `(let ((,store ,save)) ,setter))
                restorers))))
    (values (nreverse savers) (nreverse setters) (nreverse restorers))))

(defmacro letf* (bindings &body body &environment environment)
  "Simulate serial shallow binding of places in BINDINGS around BODY."
  (if bindings
    (multiple-value-bind (savers setters restorers)
        (letf-bindings (list (first bindings)) environment)
      `(let* (,@savers)
         ,@setters
         (unwind-protect
             ,`(letf* ,(rest bindings) ,@body)
           ,@restorers)))
    `(progn ,@body)))

(defmacro letf (bindings &body body &environment environment)
  "Simulate parallell shallow binding of places in BINDINGS around BODY."
  (if bindings
    (multiple-value-bind (savers setters restorers)
        (letf-bindings bindings environment)
      `(let* (,@savers)
         ,@setters
         (unwind-protect
             (progn ,@body)
           ,@restorers)))
    `(progn ,@body)))

Example usage:

(let ((some-place (cons 1 2)))
  (letf (((car some-place) 'new-car)
         ((cdr some-place) 'new-cdr))
    (values
     (car some-place)
     (cdr some-place))))            ;=> NEW-CAR, NEW-CDR

The implementation itself is fine, but the concept used here means that the actual places are modifed then restored when the code terminates normally, or an exceptional situation occurs and control is transferred out of the function. The problem with that is, of course that places are modified, which means that if you had another thread accessing data out of context, it could see modified data, which is the incorrect behaviour. The right solution would be to somehow rebind the places, in the same way that LET/LET* works. This could be done by creating a copy, or by redefining how the setf expander machinery works, but there are some subtle issues with such aproaches. Probably the best ``right'' implementation is Pascal Constanza's DLETF/DLETF*, you can find it in AspectJ or in some other projects of his. It's not that big of a piece of code, but I didn't bother posting it now, as I'd have to copy a huge license header along with it.
Another interesting fact is that Lisp machines actually implemented LETF/LETF* in hardware properly. They had a hardware mechanism for defining dynamic bindings of arbitrary memory addresses.

Does /prog/ have better ideas about properly implementing LETF/LETF* on general-purpose hardware?

s/AspectJ/AspectL/

Not exactly macro related, but I was thinking today how easy it is to implement all kinds of `advanced features' various modern language possess in Lisp, like that one-page implementation of a message-passing OO system in only a page of code in P.G.'s ANSI CL book. So I've tried my hand to see how easy it would be to implement a somewhat useful feature in a day to day language like C#, the feature is events (delegates):


(defun make-event ()
  (let (funs)
    (lambda (&rest functions)
      (if functions
      (dolist (fn functions)
        (pushnew fn funs))
      (lambda (&rest args)       
        (dolist (fn funs)
          (apply fn args)))))))

;;; Example usage:

(defun event-handler1 (a b)
  (format t "~&In event handler 1, got arguments: ~A ~A~&" a b))

(defun event-handler2 (&rest args)
  (format t "~&In event handler 2, got these &rest arguments: ~A~&" args))

;;; Quick hack to create functional bindings for a local var
(defmacro with-functional-values (fns &body body)
  `(flet ,(mapcar #'(lambda (fn) `(,fn (&rest args) (apply ,fn args))) fns)
     ,@body))

(let ((event (make-event)))
  (with-functional-values (event)
    ;; Register handler 1 and 2
    (event #'event-handler1 #'event-handler2)
    ;; Register an anonymous handler
    (event #'(lambda (&rest args)
           (declare (ignore args))
           (format t "~&In anonymous event handler.~&")))
    ;; Let's fire up the event
    (funcall (event) 123 456)))

;;; Output from the example:

;In anonymous event handler.
;Event handler 2 got these &rest arguments: (123 456)
;Event handler 1 got arguments: 123 456

The actual implementation,MAKE-EVENT took only 9 lines, and a small utility macro to make the example code slightly simpler(3 lines). To think of it in an abstract way, you create an event object with MAKE-EVENT, and then you're free to pass that around as you wish (unlike the C# version which seems to tie invocation to only the class where it was created), then when you pass arguments to that object(funcall/apply) it, it will add those arguments(which have to be functional values, such as lambda expressions or normal functions associated with a symbol) to the event's list of functions to be called when the event is fired. If you call the created event without any arguments, it will return a closure which you can call with any of the arguments you desire to pass to the delegated functions. I think the example speaks better than my explanation.

Please note that the code itself is minimalistic and lacks the ability to remove a delegated function from its internal list of events, such thing could be accomplished in some ~5+ additional lines of code, and maybe slightly more involved calling syntax. In practice, I'd just make some macros generate functions for me for easier adding/removing/firing up the event, but the code would be slightly longer and slightly more involved.

This example should be enough to illustrate how easy is to implement some more advanced features in other high-level languages in Lisp.

blabla bla erik naggum blabla constanza blabla

shut the fuck up

>>33
back into /g/

4chan.org/g/$ popd
4chan.org/prog/$

37 Name: Anonymous 2011-01-15 5:41

Bumping this thread to say how much I love /prog/ and to show that there were some smart guys in past.