external/ch-util/src/macros.cl

   1 ;;;
   2 ;;; macros.cl -- macro writing macros
   3 ;;;
   4 ;;; Author: Cyrus Harmon <ch-lisp@bobobeach.com>
   5 ;;;
   6
   7 (in-package :ch-util)
   8
   9 ;;; this is taken from Peter Seibel's Practical Common Lisp
  10 ;;; book, p. 102
  11 (defmacro once-only ((&rest names) &body body)
  12   (let ((gensyms (loop for n in names collect (gensym))))
  13     `(let (,@(loop for g in gensyms collect `(,g (gensym))))
  14        `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
  15           ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
  16                 ,@body)))))
  17
  18 ;;
  19 ;; Reference implementation of with-unique-names from cliki
  20 ;;
  21 (defmacro with-unique-names ((&rest bindings) &body body)
  22   `(let ,(mapcar #'(lambda (binding)
  23                      (destructuring-bind (var prefix)
  24                          (if (consp binding) binding (list binding binding))
  25                        `(,var (gensym ,(string prefix)))))
  26                  bindings)
  27     ,@body))
  28
  29 (defmacro time-to-string (&body body)
  30   (let ((strstr (gensym))
  31         (time-string (make-array '(0) :element-type 'character
  32                                  :fill-pointer 0 :adjustable t)))
  33     `(with-output-to-string (,strstr ,time-string)
  34        (let ((*trace-output* ,strstr))
  35          (time ,@body))
  36        ,time-string)))
  37