macros.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          gentils.lisp
   6 ;;;; Purpose:       Main general utility functions for KMRCL package
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; KMRCL users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19 (in-package #:kmrcl)
  20
  21 (defmacro let-when ((var test-form) &body body)
  22   `(let ((,var ,test-form))
  23       (when ,var ,@body)))
  24
  25 (defmacro let-if ((var test-form) if-true &optional if-false)
  26   `(let ((,var ,test-form))
  27       (if ,var ,if-true ,if-false)))
  28
  29 ;; Anaphoric macros
  30
  31 (defmacro aif (test then &optional else)
  32   `(let ((it ,test))
  33      (if it ,then ,else)))
  34
  35 (defmacro awhen (test-form &body body)
  36   `(aif ,test-form
  37         (progn ,@body)))
  38
  39 (defmacro awhile (expr &body body)
  40   `(do ((it ,expr ,expr))
  41        ((not it))
  42      ,@body))
  43
  44 (defmacro aand (&rest args)
  45   (cond ((null args) t)
  46         ((null (cdr args)) (car args))
  47         (t `(aif ,(car args) (aand ,@(cdr args))))))
  48
  49 (defmacro acond (&rest clauses)
  50   (if (null clauses)
  51       nil
  52       (let ((cl1 (car clauses))
  53             (sym (gensym)))
  54         `(let ((,sym ,(car cl1)))
  55            (if ,sym
  56                (let ((it ,sym)) ,@(cdr cl1))
  57                (acond ,@(cdr clauses)))))))
  58
  59 (defmacro alambda (parms &body body)
  60   `(labels ((self ,parms ,@body))
  61      #'self))
  62
  63 (defmacro aif2 (test &optional then else)
  64   (let ((win (gensym)))
  65     `(multiple-value-bind (it ,win) ,test
  66        (if (or it ,win) ,then ,else))))
  67
  68 (defmacro awhen2 (test &body body)
  69   `(aif2 ,test
  70          (progn ,@body)))
  71
  72 (defmacro awhile2 (test &body body)
  73   (let ((flag (gensym)))
  74     `(let ((,flag t))
  75        (while ,flag
  76          (aif2 ,test
  77                (progn ,@body)
  78                (setq ,flag nil))))))
  79
  80 (defmacro acond2 (&rest clauses)
  81   (if (null clauses)
  82       nil
  83       (let ((cl1 (car clauses))
  84             (val (gensym))
  85             (win (gensym)))
  86         `(multiple-value-bind (,val ,win) ,(car cl1)
  87            (if (or ,val ,win)
  88                (let ((it ,val)) ,@(cdr cl1))
  89                (acond2 ,@(cdr clauses)))))))
  90
  91 (defmacro mac (expr)
  92 "Expand a macro"
  93   `(pprint (macroexpand-1 ',expr)))
  94
  95 (defmacro print-form-and-results (form)
  96   `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))
  97
  98
  99 ;;; Loop macros
 100
 101 (defmacro until (test &body body)
 102   `(do ()
 103        (,test)
 104      ,@body))
 105
 106 (defmacro while (test &body body)
 107   `(do ()
 108        ((not ,test))
 109      ,@body))
 110
 111 (defmacro for ((var start stop) &body body)
 112   (let ((gstop (gensym)))
 113     `(do ((,var ,start (1+ ,var))
 114           (,gstop ,stop))
 115          ((> ,var ,gstop))
 116        ,@body)))
 117
 118 (defmacro with-each-stream-line ((var stream) &body body)
 119   (let ((eof (gensym))
 120         (eof-value (gensym))
 121         (strm (gensym)))
 122     `(let ((,strm ,stream)
 123            (,eof ',eof-value))
 124       (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
 125           ((eql ,var ,eof))
 126         ,@body))))
 127
 128 (defmacro with-each-file-line ((var file) &body body)
 129   (let ((stream (gensym)))
 130     `(with-open-file (,stream ,file :direction :input)
 131       (with-each-stream-line (,var ,stream)
 132         ,@body))))
 133
 134
 135 (defmacro in (obj &rest choices)
 136   (let ((insym (gensym)))
 137     `(let ((,insym ,obj))
 138        (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
 139                      choices)))))
 140
 141 (defmacro mean (&rest args)
 142   `(/ (+ ,@args) ,(length args)))
 143
 144 (defmacro with-gensyms (syms &body body)
 145   `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
 146           syms)
 147      ,@body))
 148
 149
 150 (defmacro time-seconds (&body body)
 151   (let ((t1 (gensym)))
 152     `(let ((,t1 (get-internal-real-time)))
 153        (values
 154         (progn ,@body)
 155         (coerce (/ (- (get-internal-real-time) ,t1)
 156                    internal-time-units-per-second)
 157                 'double-float)))))
 158
 159 (defmacro time-iterations (n &body body)
 160   (let ((i (gensym))
 161         (count (gensym)))
 162     `(progn
 163        (let ((,count ,n))
 164          (format t "~&Test with ~d iterations: ~W" ,count (quote ,body))
 165          (let ((t1 (get-internal-real-time)))
 166            (dotimes (,i ,count)
 167              ,@body)
 168            (let* ((t2 (get-internal-real-time))
 169                   (secs (coerce (/ (- t2 t1)
 170                                    internal-time-units-per-second)
 171                                 'double-float)))
 172              (format t "~&Total time: ")
 173              (print-seconds secs)
 174              (format t ", time per iteration: ")
 175              (print-seconds (coerce (/ secs ,n) 'double-float))))))))
 176
 177 (defmacro mv-bind (vars form &body body)
 178   `(multiple-value-bind ,vars ,form
 179      ,@body))
 180
 181 ;; From USENET
 182 (defmacro deflex (var val &optional (doc nil docp))
 183   "Defines a top level (global) lexical VAR with initial value VAL,
 184       which is assigned unconditionally as with DEFPARAMETER. If a DOC
 185       string is provided, it is attached to both the name |VAR| and the
 186       name *STORAGE-FOR-DEFLEX-VAR-|VAR|* as a documentation string of
 187       kind 'VARIABLE. The new VAR will have lexical scope and thus may
 188       be shadowed by LET bindings without affecting its global value."
 189   (let* ((s0 (load-time-value (symbol-name '#:*storage-for-deflex-var-)))
 190          (s1 (symbol-name var))
 191          (p1 (symbol-package var))
 192          (s2 (load-time-value (symbol-name '#:*)))
 193          (backing-var (intern (concatenate 'string s0 s1 s2) p1)))
 194     `(progn
 195       (defparameter ,backing-var ,val ,@(when docp `(,doc)))
 196       ,@(when docp
 197               `((setf (documentation ',var 'variable) ,doc)))
 198       (define-symbol-macro ,var ,backing-var))))
 199
 200 (defmacro def-cached-vector (name element-type)
 201   (let ((get-name (concat-symbol "get-" name "-vector"))
 202         (release-name (concat-symbol "release-" name "-vector"))
 203         (table-name (concat-symbol "*cached-" name "-table*"))
 204         (lock-name (concat-symbol "*cached-" name "-lock*")))
 205     `(eval-when (:compile-toplevel :load-toplevel :execute)
 206        (defvar ,table-name (make-hash-table :test 'equal))
 207        (defvar ,lock-name (kmrcl::make-lock ,name))
 208
 209          (defun ,get-name (size)
 210            (kmrcl::with-lock-held (,lock-name)
 211              (let ((buffers (gethash (cons size ,element-type) ,table-name)))
 212                (if buffers
 213                    (let ((buffer (pop buffers)))
 214                      (setf (gethash (cons size ,element-type) ,table-name) buffers)
 215                      buffer)
 216                  (make-array size :element-type ,element-type)))))
 217
 218          (defun ,release-name (buffer)
 219            (kmrcl::with-lock-held (,lock-name)
 220              (let ((buffers (gethash (cons (array-total-size buffer)
 221                                            ,element-type)
 222                                      ,table-name)))
 223                (setf (gethash (cons (array-total-size buffer)
 224                                     ,element-type) ,table-name)
 225                  (cons buffer buffers))))))))
 226
 227 (defmacro def-cached-instance (name)
 228   (let* ((new-name (concat-symbol "new-" name "-instance"))
 229          (release-name (concat-symbol "release-" name "-instance"))
 230          (cache-name (concat-symbol "*cached-" name "-instance-table*"))
 231          (lock-name (concat-symbol "*cached-" name "-instance-lock*")))
 232     `(eval-when (:compile-toplevel :load-toplevel :execute)
 233        (defvar ,cache-name nil)
 234        (defvar ,lock-name (kmrcl::make-lock ',name))
 235
 236          (defun ,new-name ()
 237            (kmrcl::with-lock-held (,lock-name)
 238              (if ,cache-name
 239                  (pop ,cache-name)
 240                  (make-instance ',name))))
 241
 242          (defun ,release-name (instance)
 243            (kmrcl::with-lock-held (,lock-name)
 244              (push instance ,cache-name))))))
 245
 246 (defmacro with-ignore-errors (&rest forms)
 247   `(progn
 248      ,@(mapcar
 249         (lambda (x) (list 'ignore-errors x))
 250         forms)))
 251
 252 (defmacro ppmx (form)
 253   "Pretty prints the macro expansion of FORM."
 254   `(let* ((exp1 (macroexpand-1 ',form))
 255           (exp (macroexpand exp1))
 256           (*print-circle* nil))
 257      (cond ((equal exp exp1)
 258             (format t "~&Macro expansion:")
 259             (pprint exp))
 260            (t (format t "~&First step of expansion:")
 261               (pprint exp1)
 262               (format t "~%~%Final expansion:")
 263               (pprint exp)))
 264      (format t "~%~%")
 265      (values)))
 266
 267 (defmacro defconstant* (sym value &optional doc)
 268   "Ensure VALUE is evaluated only once."
 269    `(defconstant ,sym (if (boundp ',sym)
 270                           (symbol-value ',sym)
 271                           ,value)
 272      ,@(when doc (list doc))))
 273
 274 (defmacro defvar-unbound (sym &optional (doc ""))
 275     "defvar with a documentation string."
 276     `(progn
 277       (defvar ,sym)
 278       (setf (documentation ',sym 'variable) ,doc)))
 279