1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: gentils.lisp
6 ;;;; Purpose: Main general utility functions for KMRCL package
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
10 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
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 ;;;; *************************************************************************
19 (defmacro let-when ((var test-form) &body body)
20 `(let ((,var ,test-form))
23 (defmacro let-if ((var test-form) if-true &optional if-false)
24 `(let ((,var ,test-form))
25 (if ,var ,if-true ,if-false)))
29 (defmacro aif (test then &optional else)
33 (defmacro awhen (test-form &body body)
37 (defmacro awhile (expr &body body)
38 `(do ((it ,expr ,expr))
42 (defmacro aand (&rest args)
44 ((null (cdr args)) (car args))
45 (t `(aif ,(car args) (aand ,@(cdr args))))))
47 (defmacro acond (&rest clauses)
50 (let ((cl1 (car clauses))
52 `(let ((,sym ,(car cl1)))
54 (let ((it ,sym)) ,@(cdr cl1))
55 (acond ,@(cdr clauses)))))))
57 (defmacro alambda (parms &body body)
58 `(labels ((self ,parms ,@body))
61 (defmacro aif2 (test &optional then else)
63 `(multiple-value-bind (it ,win) ,test
64 (if (or it ,win) ,then ,else))))
66 (defmacro awhen2 (test &body body)
70 (defmacro awhile2 (test &body body)
71 (let ((flag (gensym)))
78 (defmacro acond2 (&rest clauses)
81 (let ((cl1 (car clauses))
84 `(multiple-value-bind (,val ,win) ,(car cl1)
86 (let ((it ,val)) ,@(cdr cl1))
87 (acond2 ,@(cdr clauses)))))))
89 (defmacro mac (form &key (stream *standard-output*) (full nil) (width 80)
92 (multiple-value-bind (expanded expanded-p)
93 (funcall (if full #'macroexpand #'macroexpand-1) form env)
98 :case (if downcase :downcase :upcase)
106 (defmacro print-form-and-results (form)
107 (let ((r (gensym "RES-")))
109 (format t "~&~A --> ~S~%" ',form r)
114 (defmacro until (test &body body)
119 (defmacro while (test &body body)
124 (defmacro for ((var start stop) &body body)
125 (let ((gstop (gensym "STOP-")))
126 `(do ((,var ,start (1+ ,var))
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)
137 (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
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)
148 (defmacro in (obj &rest choices)
149 (let ((insym (gensym)))
150 `(let ((,insym ,obj))
151 (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
154 (defmacro mean (&rest args)
155 `(/ (+ ,@args) ,(length args)))
157 (defmacro with-gensyms (syms &body body)
158 `(let ,(mapcar #'(lambda (s) `(,s (gensym ,(format nil "~A-" s))))
163 (defmacro time-seconds (&body body)
165 `(let ((,t1 (get-internal-real-time)))
168 (coerce (/ (- (get-internal-real-time) ,t1)
169 internal-time-units-per-second)
172 (defmacro time-iterations (n &body body)
177 (format t "~&Test with ~d iterations: ~W" ,count (quote ,body))
178 (let ((t1 (get-internal-real-time)))
181 (let* ((t2 (get-internal-real-time))
182 (secs (coerce (/ (- t2 t1)
183 internal-time-units-per-second)
185 (format t "~&Total time: ")
187 (format t ", time per iteration: ")
188 (print-seconds (coerce (/ secs ,n) 'double-float))))))))
190 (defmacro mv-bind (vars form &body body)
191 `(multiple-value-bind ,vars ,form
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)))
208 (defparameter ,backing-var ,val ,@(when docp `(,doc)))
210 `((setf (documentation ',var 'variable) ,doc)))
211 (define-symbol-macro ,var ,backing-var))))
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))
222 (defun ,get-name (size)
223 (kmrcl::with-lock-held (,lock-name)
224 (let ((buffers (gethash (cons size ,element-type) ,table-name)))
226 (let ((buffer (pop buffers)))
227 (setf (gethash (cons size ,element-type) ,table-name) buffers)
229 (make-array size :element-type ,element-type)))))
231 (defun ,release-name (buffer)
232 (kmrcl::with-lock-held (,lock-name)
233 (let ((buffers (gethash (cons (array-total-size buffer)
236 (setf (gethash (cons (array-total-size buffer)
237 ,element-type) ,table-name)
238 (cons buffer buffers))))))))
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))
250 (kmrcl::with-lock-held (,lock-name)
253 (make-instance ',name))))
255 (defun ,release-name (instance)
256 (kmrcl::with-lock-held (,lock-name)
257 (push instance ,cache-name))))))
259 (defmacro with-ignore-errors (&rest forms)
262 (lambda (x) (list 'ignore-errors x))
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:")
273 (t (format t "~&First step of expansion:")
275 (format t "~%~%Final expansion:")
280 (defmacro defconstant* (sym value &optional doc)
281 "Ensure VALUE is evaluated only once."
282 `(defconstant ,sym (if (boundp ',sym)
285 ,@(when doc (list doc))))
287 (defmacro defvar-unbound (sym &optional (doc ""))
288 "defvar with a documentation string."
291 (setf (documentation ',sym 'variable) ,doc)))