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
12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
14 ;;;; KMRCL users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
17 ;;;; *************************************************************************
21 (defmacro let-when ((var test-form) &body body)
22 `(let ((,var ,test-form))
25 (defmacro let-if ((var test-form) if-true &optional if-false)
26 `(let ((,var ,test-form))
27 (if ,var ,if-true ,if-false)))
31 (defmacro aif (test then &optional else)
35 (defmacro awhen (test-form &body body)
39 (defmacro awhile (expr &body body)
40 `(do ((it ,expr ,expr))
44 (defmacro aand (&rest args)
46 ((null (cdr args)) (car args))
47 (t `(aif ,(car args) (aand ,@(cdr args))))))
49 (defmacro acond (&rest clauses)
52 (let ((cl1 (car clauses))
54 `(let ((,sym ,(car cl1)))
56 (let ((it ,sym)) ,@(cdr cl1))
57 (acond ,@(cdr clauses)))))))
59 (defmacro alambda (parms &body body)
60 `(labels ((self ,parms ,@body))
63 (defmacro aif2 (test &optional then else)
65 `(multiple-value-bind (it ,win) ,test
66 (if (or it ,win) ,then ,else))))
68 (defmacro awhen2 (test &body body)
72 (defmacro awhile2 (test &body body)
73 (let ((flag (gensym)))
80 (defmacro acond2 (&rest clauses)
83 (let ((cl1 (car clauses))
86 `(multiple-value-bind (,val ,win) ,(car cl1)
88 (let ((it ,val)) ,@(cdr cl1))
89 (acond2 ,@(cdr clauses)))))))
93 `(pprint (macroexpand-1 ',expr)))
95 (defmacro print-form-and-results (form)
96 `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))
101 (defmacro until (test &body body)
106 (defmacro while (test &body body)
111 (defmacro for ((var start stop) &body body)
112 (let ((gstop (gensym)))
113 `(do ((,var ,start (1+ ,var))
118 (defmacro with-each-stream-line ((var stream) &body body)
122 `(let ((,strm ,stream)
124 (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
128 (defmacro with-each-file-line ((var file) &body body)
129 (let ((stream (gensym)))
130 `(with-open-file (,stream ,file :direction :input)
131 (with-each-stream-line (,var ,stream)
135 (defmacro in (obj &rest choices)
136 (let ((insym (gensym)))
137 `(let ((,insym ,obj))
138 (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
141 (defmacro mean (&rest args)
142 `(/ (+ ,@args) ,(length args)))
144 (defmacro with-gensyms (syms &body body)
145 `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
150 (defmacro time-iterations (n &body body)
155 (format t "~&Test with ~d iterations: ~W" ,count (quote ,body))
156 (let ((t1 (get-internal-real-time)))
159 (let* ((t2 (get-internal-real-time))
160 (secs (coerce (/ (- t2 t1)
161 internal-time-units-per-second)
163 (format t "~&Total time: ")
165 (format t ", time per iteration: ")
166 (print-seconds (coerce (/ secs ,n) 'double-float))))))))
168 (defmacro mv-bind (vars form &body body)
169 `(multiple-value-bind ,vars ,form
173 (defmacro deflex (var val &optional (doc nil docp))
174 "Defines a top level (global) lexical VAR with initial value VAL,
175 which is assigned unconditionally as with DEFPARAMETER. If a DOC
176 string is provided, it is attached to both the name |VAR| and the
177 name *STORAGE-FOR-DEFLEX-VAR-|VAR|* as a documentation string of
178 kind 'VARIABLE. The new VAR will have lexical scope and thus may
179 be shadowed by LET bindings without affecting its global value."
180 (let* ((s0 (load-time-value (symbol-name '#:*storage-for-deflex-var-)))
181 (s1 (symbol-name var))
182 (p1 (symbol-package var))
183 (s2 (load-time-value (symbol-name '#:*)))
184 (backing-var (intern (concatenate 'string s0 s1 s2) p1)))
186 (defparameter ,backing-var ,val ,@(when docp `(,doc)))
188 `((setf (documentation ',var 'variable) ,doc)))
189 (define-symbol-macro ,var ,backing-var))))
191 (defmacro def-cached-vector (name element-type)
192 (let ((get-name (concat-symbol "get-" name "-vector"))
193 (release-name (concat-symbol "release-" name "-vector"))
194 (table-name (concat-symbol "*cached-" name "-table*"))
195 (lock-name (concat-symbol "*cached-" name "-lock*")))
196 `(eval-when (:compile-toplevel :load-toplevel :execute)
197 (defvar ,table-name (make-hash-table :test 'equal))
198 (defvar ,lock-name (kmrcl::make-lock ,name))
200 (defun ,get-name (size)
201 (kmrcl::with-lock-held (,lock-name)
202 (let ((buffers (gethash (cons size ,element-type) ,table-name)))
204 (let ((buffer (pop buffers)))
205 (setf (gethash (cons size ,element-type) ,table-name) buffers)
207 (make-array size :element-type ,element-type)))))
209 (defun ,release-name (buffer)
210 (kmrcl::with-lock-held (,lock-name)
211 (let ((buffers (gethash (cons (array-total-size buffer)
214 (setf (gethash (cons (array-total-size buffer)
215 ,element-type) ,table-name)
216 (cons buffer buffers))))))))
218 (defmacro def-cached-instance (name)
219 (let* ((new-name (concat-symbol "new-" name "-instance"))
220 (release-name (concat-symbol "release-" name "-instance"))
221 (cache-name (concat-symbol "*cached-" name "-instance-table*"))
222 (lock-name (concat-symbol "*cached-" name "-instance-lock*")))
223 `(eval-when (:compile-toplevel :load-toplevel :execute)
224 (defvar ,cache-name nil)
225 (defvar ,lock-name (kmrcl::make-lock ',name))
228 (kmrcl::with-lock-held (,lock-name)
231 (make-instance ',name))))
233 (defun ,release-name (instance)
234 (kmrcl::with-lock-held (,lock-name)
235 (push instance ,cache-name))))))
237 (defmacro with-ignore-errors (&rest forms)
240 (lambda (x) (list 'ignore-errors x))
243 (defmacro ppmx (form)
244 "Pretty prints the macro expansion of FORM."
245 `(let* ((exp1 (macroexpand-1 ',form))
246 (exp (macroexpand exp1))
247 (*print-circle* nil))
248 (cond ((equal exp exp1)
249 (format t "~&Macro expansion:")
251 (t (format t "~&First step of expansion:")
253 (format t "~%~%Final expansion:")