Re: backquote

[harrisr@turing.cs.rpi.edu (Richard Harris)]

I wrote some code that does this a while ago.  It is quite a bit
more complicated than Barry Margolin's solution, but you might
want to look at it anyway.

Rick Harris

(defmacro once-only (vars &body body)   ;from pcl
  (let ((gensym-var (gensym))
        (run-time-vars (gensym))
        (run-time-vals (gensym))
        (expand-time-val-forms ()))    
    `(let* (,run-time-vars
            ,run-time-vals
            (wrapped-body
             (let ,(mapcar #'(lambda (var)
                               `(,var (if (or (symbolp ,var)
                                              (constantp ,var)
                                              (and (consp ,var) (eq (car ,var) 'function)))
                                          ,var
                                          (let ((,gensym-var (gensym)))
                                            (push ,gensym-var ,run-time-vars)
                                            (push ,var ,run-time-vals)
                                            ,gensym-var))))
                           vars)
               ,@body)))
       (if (null ,run-time-vars)
           wrapped-body
           `(let ,(mapcar #'list
                          (reverse ,run-time-vars)
                          (reverse ,run-time-vals))
              ,wrapped-body)))))

(defmacro rest-once-only (rvar &body body)
  (let ((var (gensym))
        (gensym-var (gensym))
        (run-time-vars (gensym))
        (run-time-vals (gensym))
        (expand-time-val-forms ()))    
    `(let* (,run-time-vars
            ,run-time-vals
            (wrapped-body
             (let ((,rvar (mapcar #'(lambda (,var)
                                      (if (or (symbolp ,var)
                                              (constantp ,var)
                                              (and (consp ,var) (eq (car ,var) 'function)))
                                           ,var
                                           (let ((,gensym-var (gensym)))
                                             (push ,gensym-var ,run-time-vars)
                                             (push ,var ,run-time-vals)
                                             ,gensym-var)))
                                  ,rvar)))
               ,@body)))
       (if (null ,run-time-vars)
           wrapped-body
           `(let ,(mapcar #'list
                          (reverse ,run-time-vars)
                          (reverse ,run-time-vals))
              ,wrapped-body)))))

(defmacro define-fixnum-macro (name arg-list &body forms)
  (let* ((&rest (member '&rest arg-list))
         (rest-arg (and &rest (cadr &rest)))
         (required-args (if &rest (ldiff arg-list &rest) arg-list)))
    (if rest-arg
        `(defmacro ,name ,arg-list
           (once-only ,required-args
             (rest-once-only ,rest-arg
               `(and ,@(list ,@(mapcar #'(lambda (arg)
                                         ``(typep ,,arg 'fixnum))
                                     required-args))
                     ,@(mapcar #'(lambda (arg)
                                   `(typep ,arg 'fixnum))
                               ,rest-arg)
                     ,(let (,@(mapcar #'(lambda (arg)
                                          `(,arg `(the fixnum ,,arg)))
                                required-args)
                            (,rest-arg (mapcar #'(lambda (arg)
                                                   `(the fixnum ,arg))
                                               ,rest-arg)))
                        ,@forms)))))
        `(defmacro ,name ,arg-list
           (once-only ,required-args
             `(and ,@(list ,@(mapcar #'(lambda (arg)
                                         ``(typep ,,arg 'fixnum))
                                     required-args))
                   ,(let ,(mapcar #'(lambda (arg)
                                      `(,arg `(the fixnum ,,arg)))
                                  required-args)
                      ,@forms)))))))

(define-fixnum-macro fixnum-logand (&rest args)
  `(logand ,@args))

(define-fixnum-macro fixnum-logior (&rest args)
  `(logior ,@args))

(define-fixnum-macro fixnum-logxor (&rest args)
  `(logxor ,@args))

(define-fixnum-macro fixnum-1+ (x)
  `(1+ ,x))

(define-fixnum-macro fixnum-ash (x n)
  `(ash ,x ,n))