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-seconds (&body body)
152 `(let ((,t1 (get-internal-real-time)))
155 (coerce (/ (- (get-internal-real-time) ,t1)
156 internal-time-units-per-second)
159 (defmacro time-iterations (n &body body)
164 (format t "~&Test with ~d iterations: ~W" ,count (quote ,body))
165 (let ((t1 (get-internal-real-time)))
168 (let* ((t2 (get-internal-real-time))
169 (secs (coerce (/ (- t2 t1)
170 internal-time-units-per-second)
172 (format t "~&Total time: ")
174 (format t ", time per iteration: ")
175 (print-seconds (coerce (/ secs ,n) 'double-float))))))))
177 (defmacro mv-bind (vars form &body body)
178 `(multiple-value-bind ,vars ,form
182 (defmacro deflex (var val &optional (doc nil docp))
183 "Defines a top level (global) lexical VAR with initial value VAL,
184 which is assigned unconditionally as with DEFPARAMETER. If a DOC
185 string is provided, it is attached to both the name |VAR| and the
186 name *STORAGE-FOR-DEFLEX-VAR-|VAR|* as a documentation string of
187 kind 'VARIABLE. The new VAR will have lexical scope and thus may
188 be shadowed by LET bindings without affecting its global value."
189 (let* ((s0 (load-time-value (symbol-name '#:*storage-for-deflex-var-)))
190 (s1 (symbol-name var))
191 (p1 (symbol-package var))
192 (s2 (load-time-value (symbol-name '#:*)))
193 (backing-var (intern (concatenate 'string s0 s1 s2) p1)))
195 (defparameter ,backing-var ,val ,@(when docp `(,doc)))
197 `((setf (documentation ',var 'variable) ,doc)))
198 (define-symbol-macro ,var ,backing-var))))
200 (defmacro def-cached-vector (name element-type)
201 (let ((get-name (concat-symbol "get-" name "-vector"))
202 (release-name (concat-symbol "release-" name "-vector"))
203 (table-name (concat-symbol "*cached-" name "-table*"))
204 (lock-name (concat-symbol "*cached-" name "-lock*")))
205 `(eval-when (:compile-toplevel :load-toplevel :execute)
206 (defvar ,table-name (make-hash-table :test 'equal))
207 (defvar ,lock-name (kmrcl::make-lock ,name))
209 (defun ,get-name (size)
210 (kmrcl::with-lock-held (,lock-name)
211 (let ((buffers (gethash (cons size ,element-type) ,table-name)))
213 (let ((buffer (pop buffers)))
214 (setf (gethash (cons size ,element-type) ,table-name) buffers)
216 (make-array size :element-type ,element-type)))))
218 (defun ,release-name (buffer)
219 (kmrcl::with-lock-held (,lock-name)
220 (let ((buffers (gethash (cons (array-total-size buffer)
223 (setf (gethash (cons (array-total-size buffer)
224 ,element-type) ,table-name)
225 (cons buffer buffers))))))))
227 (defmacro def-cached-instance (name)
228 (let* ((new-name (concat-symbol "new-" name "-instance"))
229 (release-name (concat-symbol "release-" name "-instance"))
230 (cache-name (concat-symbol "*cached-" name "-instance-table*"))
231 (lock-name (concat-symbol "*cached-" name "-instance-lock*")))
232 `(eval-when (:compile-toplevel :load-toplevel :execute)
233 (defvar ,cache-name nil)
234 (defvar ,lock-name (kmrcl::make-lock ',name))
237 (kmrcl::with-lock-held (,lock-name)
240 (make-instance ',name))))
242 (defun ,release-name (instance)
243 (kmrcl::with-lock-held (,lock-name)
244 (push instance ,cache-name))))))
246 (defmacro with-ignore-errors (&rest forms)
249 (lambda (x) (list 'ignore-errors x))
252 (defmacro ppmx (form)
253 "Pretty prints the macro expansion of FORM."
254 `(let* ((exp1 (macroexpand-1 ',form))
255 (exp (macroexpand exp1))
256 (*print-circle* nil))
257 (cond ((equal exp exp1)
258 (format t "~&Macro expansion:")
260 (t (format t "~&First step of expansion:")
262 (format t "~%~%Final expansion:")
267 (defmacro defconst (symbol value &optional doc)
268 `(defconstant ,symbol (if (boundp ',symbol)
269 (symbol-value ',symbol)
271 ,@(when doc (list doc))))