Handy implementations of famous macros for Common Lisp (and-let, destructure-case)

_contents

with-gensyms, once-only (with-gensyms.lisp -- from Practical Common Lisp by Peter Seibel)
destructure-case (destructure-case.lisp)
and-let* (and-let.lisp)

and-let.lisp

;;;-*- Mode: Lisp; Syntax: Common-Lisp -*-

;;; (and-let* (binding ..) . body) of SRFI-2
;;;                                             2015/07/06 @nfunato
;;;                                             placed in the public domain

;;; binding is one of:
;;;   bound-var
;;;   (var expr)
;;;   (expr)

(defmacro and-let* (bindings . body)
  (labels ((expand-and-let* (bindings body)
             (cond ((null bindings)
                    `(progn ,@body))

                   ((symbolp (car bindings))
                    `(if ,(car bindings)
                         ,(expand-and-let* (cdr bindings) body)))

                   ((and (consp (car bindings))
                         (symbolp (caar bindings))
                         (null (cddar bindings)))
                    `(let (,(car bindings))
                       (if ,(caar bindings)
                           ,(expand-and-let* (cdr bindings) body))))

                   ((and (consp (car bindings))
                         (null (cdar bindings)))
                    `(if ,(caar bindings)
                         ,(expand-and-let* (cdr bindings) body)))

                   (t (error "and-let*")))))
    (expand-and-let* bindings body)))

#| examples (from Gauche reference manual)

(defun assoc-value (key alist)
  ;; search a value for KEY from ALIST, and return the value if found:
  (and-let* ((entry (assoc key alist)))
    (cdr entry)))

(defun string->number (str)
  ;; :junk-allowed keyword is nil
  (parse-integer str))

;; return num (if ARG is the string representation of an exact integer), or 0:
(or (and-let* ((num (string->number arg))
               ( (exact? num) )
               ( (integer? num) ))
      num)
    ;; default
    0)

;; search the port number of a server from a few possible places:
(or (and-let* ((val (sys-getenv "SERVER_PORT")))
      (string->number val))
    (and-let* ((portfile (expand-path "~/.server_port"))
               ( (file-exists? portfile) )
               (val (call-with-input-string portfile port->string)))
      (string->number val))
    ;; default
    8080)

|#

destructure-case.lisp

;;;-*- Mode: Lisp; Syntax: Common-Lisp -*-

;;;
;;; Destructure-case Macro
;;;                                             2013/08/12 @nfunato
;;;                                             placed in the public domain
;;;

(defmacro destructure-case (value-expr &rest clauses)
  (assert clauses)
  (let ((var (gensym "V-")))
    (labels ((normalize-clauses (cls)
               (if (eq (caar (last cls)) 'otherwise)
                   cls
                   (let ((default '(otherwise (error "No macthing clause."))))
                     (append cls (list default)))))
             (gen-destructure-clause (var pat body-expr next)
               (labels ((cons?  (p) (and (consp p) (not (eq (car p) 'quote))))
                        (quote? (p) (and (consp p) (eq (car p) 'quote)))
                        (lit?   (p) (or (KEYWORDP p) (integerp p) (stringp p)))
                        (ign (v)
                          (if (char= (aref (symbol-name v) 0) #\_)
                              `((declare (IGNORABLE ,v)))))
                        (dc (v p e)
                          (cond ((cons? p)
                                 `(if (consp ,v)
                                      ,(dc `(car ,v)
                                           (car p)
                                           (dc `(cdr ,v) (cdr p) e))
                                      (,next)))
                                ((eq p T)    e)
                                ((quote? p)  `(if (eq ,v ,p)    ,e (,next)))
                                ((lit? p)    `(if (equal ,v ,p) ,e (,next)))
                                ((null p)    `(if (null ,v)     ,e (,next)))
                                ((symbolp p) `(let ((,p ,v)) ,@(IGN p) ,e))
                                (t (error "Illegal pattern: ~s" p)))))
                 (if (eq pat 'otherwise)
                     body-expr
                     (dc var pat body-expr))))
             (gen-labels-clause (curr next clause)
               (destructuring-bind (pat . body) clause
                 `(,curr ()
                   ,(gen-destructure-clause var pat `(progn ,@body) next)))))
      (let* ((clauses* (normalize-clauses clauses))
             (currs (loop for nil in clauses* collect (gensym "L-")))
             (nexts (append (cdr currs) '(nil))))
        `(let ((,var ,value-expr))
           (labels ,(mapcar #'gen-labels-clause currs nexts clauses*)
             (,(car currs))))))))

with-gensyms.lisp

;; Here I record two famous classical macro-writing macros as a memo
;; (from Practical Common Lisp by Peter Seibel),
;; since they are often used with a sort of destructurers.

(defmacro with-gensyms ((&rest names) &body body)
  `(let ,(loop for n in names collect `(,n (gensym)))
     ,@body))

(defmacro once-only ((&rest names) &body body)
  (let ((gensyms (loop for n in names collect (gensym))))
    `(let (,@(loop for g in gensyms collect `(,g (gensym))))
       `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
          ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
                ,@body)))))