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