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 (expr)
  90 "Expand a macro"
  91   `(pprint (macroexpand-1 ',expr)))
  92
  93 (defmacro print-form-and-results (form)
  94   `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))
  95
  96
  97 ;;; Loop macros
  98
  99 (defmacro until (test &body body)
 100   `(do ()
 101        (,test)
 102      ,@body))
 103
 104 (defmacro while (test &body body)
 105   `(do ()
 106        ((not ,test))
 107      ,@body))
 108
 109 (defmacro for ((var start stop) &body body)
 110   (let ((gstop (gensym)))
 111     `(do ((,var ,start (1+ ,var))
 112           (,gstop ,stop))
 113          ((> ,var ,gstop))
 114        ,@body)))
 115
 116 (defmacro with-each-stream-line ((var stream) &body body)
 117   (let ((eof (gensym))
 118         (eof-value (gensym))
 119         (strm (gensym)))
 120     `(let ((,strm ,stream)
 121            (,eof ',eof-value))
 122       (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
 123           ((eql ,var ,eof))
 124         ,@body))))
 125
 126 (defmacro with-each-file-line ((var file) &body body)
 127   (let ((stream (gensym)))
 128     `(with-open-file (,stream ,file :direction :input)
 129       (with-each-stream-line (,var ,stream)
 130         ,@body))))
 131
 132
 133 (defmacro in (obj &rest choices)
 134   (let ((insym (gensym)))
 135     `(let ((,insym ,obj))
 136        (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
 137                      choices)))))
 138
 139 (defmacro mean (&rest args)
 140   `(/ (+ ,@args) ,(length args)))
 141
 142 (defmacro with-gensyms (syms &body body)
 143   `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
 144           syms)
 145      ,@body))
 146
 147
 148 (defmacro time-seconds (&body body)
 149   (let ((t1 (gensym)))
 150     `(let ((,t1 (get-internal-real-time)))
 151        (values
 152         (progn ,@body)
 153         (coerce (/ (- (get-internal-real-time) ,t1)
 154                    internal-time-units-per-second)
 155                 'double-float)))))
 156
 157 (defmacro time-iterations (n &body body)
 158   (let ((i (gensym))
 159         (count (gensym)))
 160     `(progn
 161        (let ((,count ,n))
 162          (format t "~&Test with ~d iterations: ~W" ,count (quote ,body))
 163          (let ((t1 (get-internal-real-time)))
 164            (dotimes (,i ,count)
 165              ,@body)
 166            (let* ((t2 (get-internal-real-time))
 167                   (secs (coerce (/ (- t2 t1)
 168                                    internal-time-units-per-second)
 169                                 'double-float)))
 170              (format t "~&Total time: ")
 171              (print-seconds secs)
 172              (format t ", time per iteration: ")
 173              (print-seconds (coerce (/ secs ,n) 'double-float))))))))
 174
 175 (defmacro mv-bind (vars form &body body)
 176   `(multiple-value-bind ,vars ,form
 177      ,@body))
 178
 179 ;; From USENET
 180 (defmacro deflex (var val &optional (doc nil docp))
 181   "Defines a top level (global) lexical VAR with initial value VAL,
 182       which is assigned unconditionally as with DEFPARAMETER. If a DOC
 183       string is provided, it is attached to both the name |VAR| and the
 184       name *STORAGE-FOR-DEFLEX-VAR-|VAR|* as a documentation string of
 185       kind 'VARIABLE. The new VAR will have lexical scope and thus may
 186       be shadowed by LET bindings without affecting its global value."
 187   (let* ((s0 (load-time-value (symbol-name '#:*storage-for-deflex-var-)))
 188          (s1 (symbol-name var))
 189          (p1 (symbol-package var))
 190          (s2 (load-time-value (symbol-name '#:*)))
 191          (backing-var (intern (concatenate 'string s0 s1 s2) p1)))
 192     `(progn
 193       (defparameter ,backing-var ,val ,@(when docp `(,doc)))
 194       ,@(when docp
 195               `((setf (documentation ',var 'variable) ,doc)))
 196       (define-symbol-macro ,var ,backing-var))))
 197
 198 (defmacro def-cached-vector (name element-type)
 199   (let ((get-name (concat-symbol "get-" name "-vector"))
 200         (release-name (concat-symbol "release-" name "-vector"))
 201         (table-name (concat-symbol "*cached-" name "-table*"))
 202         (lock-name (concat-symbol "*cached-" name "-lock*")))
 203     `(eval-when (:compile-toplevel :load-toplevel :execute)
 204        (defvar ,table-name (make-hash-table :test 'equal))
 205        (defvar ,lock-name (kmrcl::make-lock ,name))
 206
 207          (defun ,get-name (size)
 208            (kmrcl::with-lock-held (,lock-name)
 209              (let ((buffers (gethash (cons size ,element-type) ,table-name)))
 210                (if buffers
 211                    (let ((buffer (pop buffers)))
 212                      (setf (gethash (cons size ,element-type) ,table-name) buffers)
 213                      buffer)
 214                  (make-array size :element-type ,element-type)))))
 215
 216          (defun ,release-name (buffer)
 217            (kmrcl::with-lock-held (,lock-name)
 218              (let ((buffers (gethash (cons (array-total-size buffer)
 219                                            ,element-type)
 220                                      ,table-name)))
 221                (setf (gethash (cons (array-total-size buffer)
 222                                     ,element-type) ,table-name)
 223                  (cons buffer buffers))))))))
 224
 225 (defmacro def-cached-instance (name)
 226   (let* ((new-name (concat-symbol "new-" name "-instance"))
 227          (release-name (concat-symbol "release-" name "-instance"))
 228          (cache-name (concat-symbol "*cached-" name "-instance-table*"))
 229          (lock-name (concat-symbol "*cached-" name "-instance-lock*")))
 230     `(eval-when (:compile-toplevel :load-toplevel :execute)
 231        (defvar ,cache-name nil)
 232        (defvar ,lock-name (kmrcl::make-lock ',name))
 233
 234          (defun ,new-name ()
 235            (kmrcl::with-lock-held (,lock-name)
 236              (if ,cache-name
 237                  (pop ,cache-name)
 238                  (make-instance ',name))))
 239
 240          (defun ,release-name (instance)
 241            (kmrcl::with-lock-held (,lock-name)
 242              (push instance ,cache-name))))))
 243
 244 (defmacro with-ignore-errors (&rest forms)
 245   `(progn
 246      ,@(mapcar
 247         (lambda (x) (list 'ignore-errors x))
 248         forms)))
 249
 250 (defmacro ppmx (form)
 251   "Pretty prints the macro expansion of FORM."
 252   `(let* ((exp1 (macroexpand-1 ',form))
 253           (exp (macroexpand exp1))
 254           (*print-circle* nil))
 255      (cond ((equal exp exp1)
 256             (format t "~&Macro expansion:")
 257             (pprint exp))
 258            (t (format t "~&First step of expansion:")
 259               (pprint exp1)
 260               (format t "~%~%Final expansion:")
 261               (pprint exp)))
 262      (format t "~%~%")
 263      (values)))
 264
 265 (defmacro defconstant* (sym value &optional doc)
 266   "Ensure VALUE is evaluated only once."
 267    `(defconstant ,sym (if (boundp ',sym)
 268                           (symbol-value ',sym)
 269                           ,value)
 270      ,@(when doc (list doc))))
 271
 272 (defmacro defvar-unbound (sym &optional (doc ""))
 273     "defvar with a documentation string."
 274     `(progn
 275       (defvar ,sym)
 276       (setf (documentation ',sym 'variable) ,doc)))
 277