Generate codes including unquote-splice by a loop in Common Lisp

Question

I'm writing a macro to generate codes used by another macro in Common Lisp. But I'm new at this and have difficulty in constructing a macro that takes in a list (bar1 bar2 ... barn) and produces the following codes by a loop.

`(foo
   ,@bar1
   ,@bar2
     ...
   ,@barn)

I wonder whether this can be achieved not involving implement-dependent words such as SB-IMPL::UNQUOTE-SPLICE in sbcl.

Maybe I didn't give a clear description about my problem. In fact I want to write a macro gen-case such that

(gen-case
  (simple-array simple-vector)
  ('(dotimes ($1 $5)
      (when (and (= (aref $4 $2 $1) 1) (zerop (aref $3 $1)))
        $0))
   '(dolist ($1 (aref $4 $2))
      (when (zerop (aref $3 $1))
        $0)))
  objname body)

produces something like

`(case (car (type-of ,objname))
   (simple-array
     ,@(progn
         (setf temp
               '(dotimes ($1 $5)
                  (when (and (= (aref $4 $2 $1) 1) (zerop (aref $3 $1)))
                    $0)))
         (code-gen body)))
   (simple-vector
     ,@(progn
         (setf temp
               '(dolist ($1 (aref $4 $2))
                  (when (zerop (aref $3 $1))
                    $0)))
         (code-gen body))))

In general cases, the lists taken in by gen-case may contain more than two items. I have tried

``(case (car (type-of ,,objname))
    ,',@(#|Some codes that produce target codes|#))

but the target codes are inserted to the quote block and thus throw an exception in the macro who calls the macro gen-case. Moreover, I have no way to insert ,@ to the target codes as a straightforward insertion will cause a "comma not inside a backquote" exception.

The codes generated are part of another macro

(defmacro DSI-Layer ((obj-name tag-name) &body body)
  "Data Structure Independent Layer."
  (let ((temp))
    (defun code-gen (c)
      (if (atom c) c
        (if (eq (car c) tag-name)
          (let ((args (cadr c)) (codes (code-gen (cddr c))) (flag nil))
            (defun gen-code (c)
              (if (atom c) c
                (if (eq (car c) *arg*)
                  (let ((n (cadr c)))
                    (if (zerop n) (progn (setf flag t) codes)
                      (nth (1- n) args)))
                  (let ((h (gen-code (car c))))
                    (if flag
                      (progn
                        (setf flag nil)
                        (append h (gen-code (cdr c))))
                      (cons h (gen-code (cdr c))))))))
            (gen-code temp))
          (cons (code-gen (car c)) (code-gen (cdr c))))))
    `(case (car (type-of ,obj-name))
       (simple-array
         ,@(progn
             (setf temp
               '(dotimes ($1 $5)
                   (when (and (= (aref $4 $2 $1) 1) (zerop (aref $3 $1)))
                     $0)))
             (code-gen body)))
       (simple-vector
         ,@(progn
             (setf temp
               '(dolist ($1 (aref $4 $2))
                  (when (zerop (aref $3 $1))
                    $0)))
             (code-gen body))))))

and I've set up a read-macro

(defvar *arg* (make-symbol "ARG")) 
(set-macro-character #\$
  #'(lambda (stream char)
      (declare (ignore char))
      (list *arg* (read stream t nil t))))

The intention of DSI-Layer is to add a piece of code to determine the type of input parameters. For example, the codes

(defun BFS (G v)
  (let* ((n (car (array-dimensions G)))
         (visited (make-array n :initial-element 0))
         (queue (list v))
         (vl nil))
    (incf (aref visited v))
    (DSI-Layer (G next-vertex)
      (do nil ((null queue) nil)
        (setf v (pop queue)) (push v vl)
        (next-vertex (i v visited G n)
          (setf queue (nconc queue (list i)))
          (incf (aref visited i)))))
    vl))

will be converted to

(defun BFS (G v)
  (let* ((n (car (array-dimensions G)))
         (visited (make-array n :initial-element 0))
         (queue (list v))
         (vl nil))
    (incf (aref visited v))
    (case (car (type-of G))
      (simple-array
       (do nil ((null queue) nil)
         (setf v (pop queue))
         (push v vl)
         (dotimes (i n)
           (when (and (= (aref G v i) 1) (zerop (aref visited i)))
             (setf queue (nconc queue (list i)))
             (incf (aref visited i))))))
      (simple-vector
       (do nil ((null queue) nil)
         (setf v (pop queue))
         (push v vl)
         (dolist (i (aref G v))
           (when (zerop (aref visited i))
             (setf queue (nconc queue (list i)))
             (incf (aref visited i)))))))))

Now I just wonder that whether the DSI-Layer can be generated from another macro gen-case by passing the type names and corresponding code templates to it or not.

By the way, I don't think the specific meaning of generated codes matters in my problem. They are just treated as data.

Answer 1

Don't be tempted to use internal details of backquote. If you have the lists you want to append in distinct variables, simply append them:

`(foo
  ,@(append b1 b2 ... bn))

If you have a list of them in some single variable (for instance if they've come from an &rest or &body argument) then do something like

`(foo
  ,@(loop for b in bs
          appending b))

Answer 2

I see your problem - you need it not for a function call but for a macro-call with case.

One cannot use dynamically macros - in a safe way. One has to use eval but it is not safe for scoping.

@tfb as well as me answered in this question for type-case lengthily.

previous answer (wrong for this case)

No need for a macro.

`(foo
   ,@bar1
   ,@bar2
     ...
   ,@barn)

with evaluation of its result by pure functions would be:

(apply foo (loop for bar in '(bar1 bar2 ... barn)
            nconc bar))
      

nconc or nconcing instead of collect fuses lists together and is very useful in loop. - Ah I see my previous answerer used append btw appending - nconc nconcing however is the "destructive" form of "append". Since the local variable bar is destructed here which we don't need outside of the loop form, using the "destructive" form is safe here - and comes with a performance advantage (less elements are copied than when using append). That is why I wired my brain always to use nconc instead of append inside a loop.

Of course, if you want to get the code construct, one could do

`(foo ,@(loop for bar in list-of-lists
              nconc bar))

Try it out:

`(foo ,@(loop for bar in '((1 2 3) (a b c) (:a :b :c)) nconc bar))
;; => (FOO 1 2 3 A B C :A :B :C)

Answer 3

The answers of all of you inspired me, and I came up with a solution to my problem. The macro

(defmacro Layer-Generator (obj-name tag-name callback body)
  (let ((temp (gensym)) (code-gen (gensym)))
    `(let ((,temp))
       (defun ,code-gen (c)
         (if (atom c) c
           (if (eq (car c) ,tag-name)
             (let ((args (cadr c)) (codes (,code-gen (cddr c))) (flag nil))
               (defun gen-code (c)
                 (if (atom c) c
                   (if (eq (car c) *arg*)
                     (let ((n (cadr c)))
                       (if (zerop n) (progn (setf flag t) codes)
                         (nth (1- n) args)))
                     (let ((h (gen-code (car c))))
                       (if flag
                         (progn
                           (setf flag nil)
                           (append h (gen-code (cdr c))))
                         (cons h (gen-code (cdr c))))))))
               (gen-code ,temp))
             (cons (,code-gen (car c)) (,code-gen (cdr c))))))
       (list 'case `(car (type-of ,,obj-name))
         ,@(let ((codes nil))
             (dolist (item callback)
               (push
                 `(cons ',(car item)
                    (progn
                      (setf ,temp ,(cadr item))
                      (,code-gen ,body)))
                 codes))
             (nreverse codes))))))

produces codes which are not the same as DSI-Layer but produce codes coincident with what the latter produces. Because the codes

`(case (car (type-of ,obj-name))
   (tag1
     ,@(#|codes1|#))
   (tag2
     ,@(#|codes2|#))
    ...)

are equivalent to

(list 'case `(car (type-of ,obj-name))
  (cons 'tag1 (#|codes1|#))
  (cons 'tag2 (#|codes2|#))
   ...)

And now we can use a loop to generate it just as what the Layer-Generator does.