once-only.lisp

(defpackage #:snippets/once-only
  (:use #:cl))

(in-package #:snippets/once-only)

(defstruct once-only-var
  symbol
  initform
  (gensym (gensym))
  (ignorable nil)
  (type 't))

(defun parse-once-only-spec (spec)
  (etypecase spec
    (symbol
     (make-once-only-var :symbol spec :initform spec))
    (cons
     (destructuring-bind (symbol initform &rest initargs) spec
       (apply #'make-once-only-var :symbol symbol :initform initform initargs)))))

(defmacro once-only (specs &body forms)
  (let ((vars (mapcar #'parse-once-only-spec specs)))
    (macrolet ((collect (form) `(mapcar (lambda (var) ,form) vars))
               (collect-if (test-form form) `(mapcan (lambda (var) (when ,test-form (list ,form))) vars)))
      `(let ,(collect (list (once-only-var-gensym var)
                            `(gensym ,(string (once-only-var-symbol var)))))
         `(let (,,@(collect ``(,,(once-only-var-gensym var)
                               ,,(once-only-var-initform var))))
            (declare (ignorable ,,@(collect-if (once-only-var-ignorable var)
                                               (once-only-var-gensym var)))
                     ,,@(collect ``(type
                                    ,',(once-only-var-type var)
                                    ,,(once-only-var-gensym var))))
            ,(let ,(collect (list (once-only-var-symbol var)
                                  (once-only-var-gensym var)))
               ,@forms))))))

;; CL-USER> (defmacro foo (x)
;;            (once-only ((x x :ignorable t :type symbol))
;;              `(list ,x ,x)))
;; FOO
;; CL-USER> (macroexpand-1 '(foo 'bar))
;; (LET ((#:X1313 'BAR))
;;   (DECLARE (IGNORABLE #:X1313)
;;            (TYPE SYMBOL #:X1313))
;;   (LIST #:X1313 #:X1313))
;; T

;; tcr suggested an alternative syntax:
;;
;; (once-only (x)
;;   (declare (ignorable x))
;;   (declare (type symbol x))
;;   `(list ,x ,x))