;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: macros.lisp,v 1.2 2003/06/06 21:59:29 kevin Exp $
+;;;; $Id$
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(print-seconds secs)
(format t ", time per iteration: ")
(print-seconds (coerce (/ secs ,n) 'double-float))))))))
+
+(defmacro mv-bind (vars form &body body)
+ `(multiple-value-bind ,vars ,form
+ ,@body))
+
+;; From USENET
+(defmacro deflex (var val &optional (doc nil docp))
+ "Defines a top level (global) lexical VAR with initial value VAL,
+ which is assigned unconditionally as with DEFPARAMETER. If a DOC
+ string is provided, it is attached to both the name |VAR| and the
+ name *STORAGE-FOR-DEFLEX-VAR-|VAR|* as a documentation string of
+ kind 'VARIABLE. The new VAR will have lexical scope and thus may
+ be shadowed by LET bindings without affecting its global value."
+ (let* ((s0 (load-time-value (symbol-name '#:*storage-for-deflex-var-)))
+ (s1 (symbol-name var))
+ (p1 (symbol-package var))
+ (s2 (load-time-value (symbol-name '#:*)))
+ (backing-var (intern (concatenate 'string s0 s1 s2) p1)))
+ `(progn
+ (defparameter ,backing-var ,val ,@(when docp `(,doc)))
+ ,@(when docp
+ `((setf (documentation ',var 'variable) ,doc)))
+ (define-symbol-macro ,var ,backing-var))))
+
+(defmacro def-cached-vector (name element-type)
+ (let ((get-name (concat-symbol "get-" name "-vector"))
+ (release-name (concat-symbol "release-" name "-vector"))
+ (table-name (concat-symbol "*cached-" name "-table*"))
+ (lock-name (concat-symbol "*cached-" name "-lock*")))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar ,table-name (make-hash-table :test 'equal))
+ (defvar ,lock-name (kmrcl::make-lock ,name))
+
+ (defun ,get-name (size)
+ (kmrcl::with-lock-held (,lock-name)
+ (let ((buffers (gethash (cons size ,element-type) ,table-name)))
+ (if buffers
+ (let ((buffer (pop buffers)))
+ (setf (gethash (cons size ,element-type) ,table-name) buffers)
+ buffer)
+ (make-array size :element-type ,element-type)))))
+
+ (defun ,release-name (buffer)
+ (kmrcl::with-lock-held (,lock-name)
+ (let ((buffers (gethash (cons (array-total-size buffer)
+ ,element-type)
+ ,table-name)))
+ (setf (gethash (cons (array-total-size buffer)
+ ,element-type) ,table-name)
+ (cons buffer buffers))))))))
+
+(defmacro def-cached-instance (name)
+ (let* ((new-name (concat-symbol "new-" name "-instance"))
+ (release-name (concat-symbol "release-" name "-instance"))
+ (cache-name (concat-symbol "*cached-" name "-instance-table*"))
+ (lock-name (concat-symbol "*cached-" name "-instance-lock*")))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar ,cache-name nil)
+ (defvar ,lock-name (kmrcl::make-lock ',name))
+
+ (defun ,new-name ()
+ (kmrcl::with-lock-held (,lock-name)
+ (if ,cache-name
+ (pop ,cache-name)
+ (make-instance ',name))))
+
+ (defun ,release-name (instance)
+ (kmrcl::with-lock-held (,lock-name)
+ (push instance ,cache-name))))))