;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
(defmacro let-when ((var test-form) &body body)
`(let ((,var ,test-form))
(when ,var ,@body)))
(defmacro let-when ((var test-form) &body body)
`(let ((,var ,test-form))
(when ,var ,@body)))
(defmacro let-if ((var test-form) if-true &optional if-false)
`(let ((,var ,test-form))
(if ,var ,if-true ,if-false)))
(defmacro let-if ((var test-form) if-true &optional if-false)
`(let ((,var ,test-form))
(if ,var ,if-true ,if-false)))
(let ((it ,val)) ,@(cdr cl1))
(acond2 ,@(cdr clauses)))))))
(let ((it ,val)) ,@(cdr cl1))
(acond2 ,@(cdr clauses)))))))
-(defmacro mac (expr)
-"Expand a macro"
- `(pprint (macroexpand-1 ',expr)))
+(defmacro mac (form &key (stream *standard-output*) (full nil) (width 80)
+ (downcase t)
+ &environment env)
+ (multiple-value-bind (expanded expanded-p)
+ (funcall (if full #'macroexpand #'macroexpand-1) form env)
+ (write expanded
+ :stream stream
+ :pretty t
+ :right-margin width
+ :case (if downcase :downcase :upcase)
+ :length nil
+ :level nil
+ :circle nil
+ :gensym nil)
+ (fresh-line stream)
+ expanded-p))
- `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))
-
+ (let ((r (gensym "RES-")))
+ `(let ((r ,form))
+ (format t "~&~A --> ~S~%" ',form r)
+ r)))
`(do ((,var ,start (1+ ,var))
(,gstop ,stop))
((> ,var ,gstop))
,@body)))
(defmacro with-each-stream-line ((var stream) &body body)
`(do ((,var ,start (1+ ,var))
(,gstop ,stop))
((> ,var ,gstop))
,@body)))
(defmacro with-each-stream-line ((var stream) &body body)
(do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
(do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
(defmacro with-each-file-line ((var file) &body body)
(let ((stream (gensym)))
`(with-open-file (,stream ,file :direction :input)
(with-each-stream-line (,var ,stream)
(defmacro with-each-file-line ((var file) &body body)
(let ((stream (gensym)))
`(with-open-file (,stream ,file :direction :input)
(with-each-stream-line (,var ,stream)
`(/ (+ ,@args) ,(length args)))
(defmacro with-gensyms (syms &body body)
`(/ (+ ,@args) ,(length args)))
(defmacro with-gensyms (syms &body body)
- `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
- syms)
+ `(let ,(mapcar #'(lambda (s) `(,s (gensym ,(format nil "~A-" s))))
+ syms)
+(defmacro time-seconds (&body body)
+ (let ((t1 (gensym)))
+ `(let ((,t1 (get-internal-real-time)))
+ (values
+ (progn ,@body)
+ (coerce (/ (- (get-internal-real-time) ,t1)
+ internal-time-units-per-second)
+ 'double-float)))))
+
- (format t "~&Test with ~d iterations: ~W" ,count (quote ,body))
- (let ((t1 (get-internal-real-time)))
- (dotimes (,i ,count)
- ,@body)
- (let* ((t2 (get-internal-real-time))
- (secs (coerce (/ (- t2 t1)
- internal-time-units-per-second)
- 'double-float)))
- (format t "~&Total time: ")
- (print-seconds secs)
- (format t ", time per iteration: ")
- (print-seconds (coerce (/ secs ,n) 'double-float))))))))
+ (format t "~&Test with ~d iterations: ~W" ,count (quote ,body))
+ (let ((t1 (get-internal-real-time)))
+ (dotimes (,i ,count)
+ ,@body)
+ (let* ((t2 (get-internal-real-time))
+ (secs (coerce (/ (- t2 t1)
+ internal-time-units-per-second)
+ 'double-float)))
+ (format t "~&Total time: ")
+ (print-seconds secs)
+ (format t ", time per iteration: ")
+ (print-seconds (coerce (/ secs ,n) 'double-float))))))))
"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
"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
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-)))
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)))
+ (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
`(progn
(defparameter ,backing-var ,val ,@(when docp `(,doc)))
,@(when docp
(define-symbol-macro ,var ,backing-var))))
(defmacro def-cached-vector (name element-type)
(let ((get-name (concat-symbol "get-" name "-vector"))
(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*")))
+ (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))
`(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))))))))
+
+ (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))))))))
- (release-name (concat-symbol "release-" name "-instance"))
- (cache-name (concat-symbol "*cached-" name "-instance-table*"))
- (lock-name (concat-symbol "*cached-" name "-instance-lock*")))
+ (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))
`(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))))))
+
+ (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))))))
(defmacro ppmx (form)
"Pretty prints the macro expansion of FORM."
`(let* ((exp1 (macroexpand-1 ',form))
(defmacro ppmx (form)
"Pretty prints the macro expansion of FORM."
`(let* ((exp1 (macroexpand-1 ',form))
- (format t "~&Macro expansion:")
- (pprint exp))
- (t (format t "~&First step of expansion:")
- (pprint exp1)
- (format t "~%~%Final expansion:")
- (pprint exp)))
+ (format t "~&Macro expansion:")
+ (pprint exp))
+ (t (format t "~&First step of expansion:")
+ (pprint exp1)
+ (format t "~%~%Final expansion:")
+ (pprint exp)))
-(defmacro defconst (symbol value &optional doc)
- `(defconstant ,symbol (if (boundp ',symbol)
- (symbol-value ',symbol)
- ,value)
+(defmacro defconstant* (sym value &optional doc)
+ "Ensure VALUE is evaluated only once."
+ `(defconstant ,sym (if (boundp ',sym)
+ (symbol-value ',sym)
+ ,value)