/[cmucl]/src/code/extensions.lisp
ViewVC logotype

Contents of /src/code/extensions.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28.42.2 - (hide annotations)
Tue Feb 9 15:18:21 2010 UTC (4 years, 2 months ago) by rtoy
Branch: intl-branch
CVS Tags: intl-branch-working-2010-02-19-1000, intl-branch-working-2010-02-11-1000, intl-branch-2010-03-18-1300
Changes since 1.28.42.1: +26 -26 lines
Mark translatable strings; update cmucl.pot and ko/cmucl.po
accordingly.
1 ram 1.1 ;;; -*- Log: code.log; Package: Extensions -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.8 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 rtoy 1.28.42.2 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/extensions.lisp,v 1.28.42.2 2010/02/09 15:18:21 rtoy Exp $")
9 ram 1.8 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; Spice Lisp extensions to the language.
13     ;;;
14     ;;; Letf written by Steven Handerson.
15     ;;;
16     ;;; **********************************************************************
17     (in-package "EXTENSIONS")
18    
19 rtoy 1.28.42.1 (intl:textdomain "cmucl")
20    
21 ram 1.2 (export '(letf* letf dovector deletef indenting-further file-comment
22 ram 1.1 read-char-no-edit listen-skip-whitespace concat-pnames
23 ram 1.3 iterate once-only collect do-anonymous undefined-value
24 ram 1.6 required-argument define-hash-cache defun-cached
25 ram 1.14 cache-hash-eq do-hash))
26 ram 1.1
27     (import 'lisp::whitespace-char-p)
28    
29    
30 ram 1.2
31 ram 1.1 ;;; Undefined-Value -- Public
32     ;;;
33     ;;; This is here until we figure out what to do with it.
34     ;;;
35 pw 1.24 (declaim (inline undefined-value))
36 ram 1.1 (defun undefined-value ()
37     '%undefined%)
38 ram 1.6
39     ;;; REQUIRED-ARGUMENT -- Public
40     ;;;
41 pw 1.24 (declaim (ftype (function () nil) required-argument))
42 ram 1.6 (defun required-argument ()
43 rtoy 1.28.42.2 _N"This function can be used as the default value for keyword arguments that
44 ram 1.6 must be always be supplied. Since it is known by the compiler to never
45     return, it will avoid any compile-time type warnings that would result from a
46     default value inconsistent with the declared type. When this function is
47     called, it signals an error indicating that a required keyword argument was
48     not supplied. This function is also useful for DEFSTRUCT slot defaults
49     corresponding to required arguments."
50 rtoy 1.28.42.2 (error _"A required keyword argument was not supplied."))
51 ram 1.2
52    
53     ;;; FILE-COMMENT -- Public
54     ;;;
55     (defmacro file-comment (string)
56 rtoy 1.28.42.2 _N"FILE-COMMENT String
57 ram 1.2 When COMPILE-FILE sees this form at top-level, it places the constant string
58     in the run-time source location information. DESCRIBE will print the file
59     comment for the file that a function was defined in. The string is also
60     textually present in the FASL, so the RCS \"ident\" command can find it,
61     etc."
62     (declare (ignore string))
63     '(undefined-value))
64 ram 1.1
65    
66     (defun skip-whitespace (&optional (stream *standard-input*))
67     (loop (let ((char (read-char stream)))
68     (if (not (lisp::whitespacep char))
69     (return (unread-char char stream))))))
70    
71    
72     (defun listen-skip-whitespace (&optional (stream *standard-input*))
73 rtoy 1.28.42.2 _N"See listen. Any whitespace in the input stream will be flushed."
74 ram 1.1 (do ((char (read-char-no-hang stream nil nil nil)
75     (read-char-no-hang stream nil nil nil)))
76     ((null char) nil)
77     (cond ((not (whitespace-char-p char))
78     (unread-char char stream)
79     (return T)))))
80    
81     ;;; These macros waste time as opposed to space.
82    
83     (defmacro letf* (bindings &body body &environment env)
84 rtoy 1.28.42.2 _N"Does what one might expect, saving the old values and setting the generalized
85 ram 1.1 variables to the new values in sequence. Unwind-protects and get-setf-method
86     are used to preserve the semantics one might expect in analogy to let*,
87     and the once-only evaluation of subforms."
88     (labels ((do-bindings
89     (bindings)
90     (cond ((null bindings) body)
91     (t (multiple-value-bind (dummies vals newval setter getter)
92 ram 1.12 (get-setf-method (caar bindings) env)
93 ram 1.1 (let ((save (gensym)))
94     `((let* (,@(mapcar #'list dummies vals)
95     (,(car newval) ,(cadar bindings))
96     (,save ,getter))
97     (unwind-protect
98     (progn ,setter
99     ,@(do-bindings (cdr bindings)))
100     (setq ,(car newval) ,save)
101     ,setter)))))))))
102     (car (do-bindings bindings))))
103    
104    
105     (defmacro letf (bindings &body body &environment env)
106 rtoy 1.28.42.2 _N"Like letf*, but evaluates all the implicit subforms and new values of all
107 ram 1.1 the implied setfs before altering any values. However, the store forms
108     (see get-setf-method) must still be evaluated in sequence. Uses unwind-
109     protects to protect the environment."
110     (let (temps)
111     (labels
112     ((do-bindings
113     (bindings)
114     (cond ((null bindings) body)
115     (t (let ((binding (car bindings)))
116     (multiple-value-bind (dummies vals newval setter getter)
117 ram 1.12 (get-setf-method (car binding) env)
118 ram 1.1 (let ((save (gensym)))
119     (mapcar #'(lambda (a b) (push (list a b) temps))
120     dummies vals)
121     (push (list save getter) temps)
122     (push (list (car newval) (cadr binding)) temps)
123     `((unwind-protect
124     (progn ,setter
125     ,@(do-bindings (cdr bindings)))
126     (setq ,(car newval) ,save)
127     ,setter)))))))))
128     (let ((form (car (do-bindings bindings))))
129     `(let* ,(nreverse temps)
130     ,form)))))
131    
132    
133 pw 1.25 (define-setf-expander logbitp (index int &environment env)
134 ram 1.1 (multiple-value-bind (temps vals stores store-form access-form)
135 ram 1.12 (get-setf-method int env)
136 ram 1.1 (let ((ind (gensym))
137     (store (gensym))
138     (stemp (first stores)))
139     (values `(,ind ,@temps)
140     `(,index
141     ,@vals)
142     (list store)
143     `(let ((,stemp
144     (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form)))
145     ,store-form
146     ,store)
147     `(logbitp ,ind ,access-form)))))
148    
149    
150     ;;; Indenting-Further is a user-level macro which may be used to locally increment
151     ;;; the indentation of a stream.
152    
153     (defmacro indenting-further (stream more &rest body)
154 rtoy 1.28.42.2 _N"Causes the output of the indenting Stream to indent More spaces. More is
155 ram 1.1 evaluated twice."
156     `(unwind-protect
157     (progn
158     (incf (lisp::indenting-stream-indentation ,stream) ,more)
159     ,@body)
160     (decf (lisp::indenting-stream-indentation ,stream) ,more)))
161    
162    
163     ;;; Deletef
164    
165     (defmacro deletef (elt list &rest keys &environment env)
166     (multiple-value-bind (dummies vals newval setter getter)
167 ram 1.12 (get-setf-method list env)
168 ram 1.1 (let ((eltsym (gensym))
169     (listsym (gensym)))
170     `(let* ((,eltsym ,elt)
171     ,@(mapcar #'list dummies vals)
172     (,listsym ,getter)
173     (,(car newval) (delete ,eltsym ,listsym ,@keys)))
174     ,setter))))
175    
176    
177 pmai 1.26 (defmacro dovector ((elt vector &optional default) &rest forms)
178 rtoy 1.28.42.2 _N"Just like dolist, but with one-dimensional arrays."
179 ram 1.1 (let ((index (gensym))
180     (length (gensym))
181     (vec (gensym)))
182     `(let ((,vec ,vector))
183     (do ((,index 0 (1+ ,index))
184     (,length (length ,vec)))
185 pmai 1.26 ((>= ,index ,length) ,default)
186 ram 1.1 (let ((,elt (aref ,vec ,index)))
187     ,@forms)))))
188    
189    
190     (eval-when (compile load eval)
191     (defun concat-pnames (name1 name2)
192 ram 1.13 (declare (symbol name1 name2))
193 ram 1.1 (if name1
194     (intern (concatenate 'simple-string (symbol-name name1)
195     (symbol-name name2)))
196     name2)))
197    
198    
199     ;;; Iterate -- Public
200     ;;;
201     ;;; The ultimate iteration macro...
202     ;;;
203     (defmacro iterate (name binds &body body)
204 rtoy 1.28.42.2 _N"Iterate Name ({(Var Initial-Value)}*) Declaration* Form*
205 ram 1.1 This is syntactic sugar for Labels. It creates a local function Name with
206     the specified Vars as its arguments and the Declarations and Forms as its
207     body. This function is then called with the Initial-Values, and the result
208     of the call is return from the macro."
209     (dolist (x binds)
210     (unless (and (listp x)
211     (= (length x) 2))
212 rtoy 1.28.42.2 (error _"Malformed iterate variable spec: ~S." x)))
213 ram 1.1
214     `(labels ((,name ,(mapcar #'first binds) ,@body))
215     (,name ,@(mapcar #'second binds))))
216    
217    
218     ;;;; The Collect macro:
219    
220     ;;; Collect-Normal-Expander -- Internal
221     ;;;
222     ;;; This function does the real work of macroexpansion for normal collection
223     ;;; macros. N-Value is the name of the variable which holds the current
224     ;;; value. Fun is the function which does collection. Forms is the list of
225     ;;; forms whose values we are supposed to collect.
226     ;;;
227     (defun collect-normal-expander (n-value fun forms)
228     `(progn
229     ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
230     ,n-value))
231    
232     ;;; Collect-List-Expander -- Internal
233     ;;;
234     ;;; This function deals with the list collection case. N-Tail is the pointer
235     ;;; to the current tail of the list, which is NIL if the list is empty.
236     ;;;
237     (defun collect-list-expander (n-value n-tail forms)
238     (let ((n-res (gensym)))
239     `(progn
240     ,@(mapcar #'(lambda (form)
241     `(let ((,n-res (cons ,form nil)))
242     (cond (,n-tail
243     (setf (cdr ,n-tail) ,n-res)
244     (setq ,n-tail ,n-res))
245     (t
246     (setq ,n-tail ,n-res ,n-value ,n-res)))))
247     forms)
248     ,n-value)))
249    
250    
251     ;;; Collect -- Public
252     ;;;
253     ;;; The ultimate collection macro...
254     ;;;
255     (defmacro collect (collections &body body)
256 rtoy 1.28.42.2 _N"Collect ({(Name [Initial-Value] [Function])}*) {Form}*
257 ram 1.1 Collect some values somehow. Each of the collections specifies a bunch of
258     things which collected during the evaluation of the body of the form. The
259     name of the collection is used to define a local macro, a la MACROLET.
260     Within the body, this macro will evaluate each of its arguments and collect
261     the result, returning the current value after the collection is done. The
262     body is evaluated as a PROGN; to get the final values when you are done, just
263     call the collection macro with no arguments.
264    
265     Initial-Value is the value that the collection starts out with, which
266     defaults to NIL. Function is the function which does the collection. It is
267     a function which will accept two arguments: the value to be collected and the
268     current collection. The result of the function is made the new value for the
269     collection. As a totally magical special-case, the Function may be Collect,
270     which tells us to build a list in forward order; this is the default. If an
271     Initial-Value is supplied for Collect, the stuff will be rplacd'd onto the
272     end. Note that Function may be anything that can appear in the functional
273     position, including macros and lambdas."
274    
275     (let ((macros ())
276     (binds ()))
277     (dolist (spec collections)
278     (unless (<= 1 (length spec) 3)
279 rtoy 1.28.42.2 (error _"Malformed collection specifier: ~S." spec))
280 ram 1.1 (let ((n-value (gensym))
281     (name (first spec))
282     (default (second spec))
283     (kind (or (third spec) 'collect)))
284     (push `(,n-value ,default) binds)
285     (if (eq kind 'collect)
286     (let ((n-tail (gensym)))
287     (if default
288     (push `(,n-tail (last ,n-value)) binds)
289     (push n-tail binds))
290     (push `(,name (&rest args)
291     (collect-list-expander ',n-value ',n-tail args))
292     macros))
293     (push `(,name (&rest args)
294     (collect-normal-expander ',n-value ',kind args))
295     macros))))
296     `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
297    
298    
299     ;;;; The Once-Only macro:
300    
301     ;;; Once-Only -- Interface
302     ;;;
303     ;;; Once-Only is a utility useful in writing source transforms and macros.
304     ;;; It provides an easy way to wrap a let around some code to ensure that some
305     ;;; forms are only evaluated once.
306     ;;;
307     (defmacro once-only (specs &body body)
308 rtoy 1.28.42.2 _N"Once-Only ({(Var Value-Expression)}*) Form*
309 ram 1.9 Create a Let* which evaluates each Value-Expression, binding a temporary
310     variable to the result, and wrapping the Let* around the result of the
311 ram 1.1 evaluation of Body. Within the body, each Var is bound to the corresponding
312 ram 1.9 temporary variable."
313 ram 1.11 (iterate frob
314     ((specs specs)
315     (body body))
316     (if (null specs)
317     `(progn ,@body)
318     (let ((spec (first specs)))
319     (when (/= (length spec) 2)
320 rtoy 1.28.42.2 (error _"Malformed Once-Only binding spec: ~S." spec))
321 ram 1.11 (let ((name (first spec))
322     (exp-temp (gensym)))
323     `(let ((,exp-temp ,(second spec))
324     (,name (gensym "OO-")))
325     `(let ((,,name ,,exp-temp))
326     ,,(frob (rest specs) body))))))))
327 ram 1.1
328    
329     ;;;; DO-ANONYMOUS:
330    
331     ;;; ### Bootstrap hack... Renamed to avoid clobbering function in bootstrap
332     ;;; environment.
333     ;;;
334     (defun lisp::do-do-body (varlist endlist code decl bind step name block)
335     (let* ((inits ())
336     (steps ())
337     (l1 (gensym))
338     (l2 (gensym)))
339     ;; Check for illegal old-style do.
340     (when (or (not (listp varlist)) (atom endlist))
341 rtoy 1.28.42.2 (error _"Ill-formed ~S -- possibly illegal old style DO?" name))
342 ram 1.1 ;; Parse the varlist to get inits and steps.
343     (dolist (v varlist)
344     (cond ((symbolp v) (push v inits))
345     ((listp v)
346     (unless (symbolp (first v))
347 rtoy 1.28.42.2 (error _"~S step variable is not a symbol: ~S" name (first v)))
348 ram 1.1 (case (length v)
349     (1 (push (first v) inits))
350     (2 (push v inits))
351     (3 (push (list (first v) (second v)) inits)
352     (setq steps (list* (third v) (first v) steps)))
353 rtoy 1.28.42.2 (t (error _"~S is an illegal form for a ~S varlist." v name))))
354     (t (error _"~S is an illegal form for a ~S varlist." v name))))
355 ram 1.1 ;; And finally construct the new form.
356     `(block ,BLOCK
357     (,bind ,(nreverse inits)
358     ,@decl
359     (tagbody
360     (go ,L2)
361     ,L1
362     ,@code
363     (,step ,@(nreverse steps))
364     ,L2
365     (unless ,(car endlist) (go ,L1))
366     (return-from ,BLOCK (progn ,@(cdr endlist))))))))
367    
368    
369 gerd 1.27 (defmacro do-anonymous (varlist endlist &parse-body (body decls))
370 rtoy 1.28.42.2 _N"DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
371 ram 1.1 Like DO, but has no implicit NIL block. Each Var is initialized in parallel
372     to the value of the specified Init form. On subsequent iterations, the Vars
373     are assigned the value of the Step form (if any) in paralell. The Test is
374     evaluated before each evaluation of the body Forms. When the Test is true,
375 dtc 1.23 the Exit-Forms are evaluated as a PROGN, with the result being the value
376 ram 1.1 of the DO."
377     (lisp::do-do-body varlist endlist body decls 'let 'psetq
378     'do-anonymous (gensym)))
379 ram 1.14
380     (defmacro do-hash ((key-var value-var table &optional result)
381 gerd 1.27 &parse-body (body decls))
382 rtoy 1.28.42.2 _N"DO-HASH (Key-Var Value-Var Table [Result]) Declaration* Form*
383 ram 1.14 Iterate over the entries in a hash-table."
384     (let ((gen (gensym))
385     (n-more (gensym)))
386     `(with-hash-table-iterator (,gen ,table)
387     (loop
388     (multiple-value-bind (,n-more ,key-var ,value-var)
389     (,gen)
390     ,@decls
391     (unless ,n-more (return ,result))
392     ,@body)))))
393 ram 1.3
394    
395     ;;;; Hash cache utility:
396    
397 ram 1.16 (eval-when (compile load eval)
398     (defvar *profile-hash-cache* nil))
399    
400 ram 1.3 ;;; DEFINE-HASH-CACHE -- Public
401     ;;;
402 ram 1.15 ;;; :INIT-FORM passed as COLD-LOAD-INIT in type system definitions so that
403     ;;; caches can be created before top-level forms run.
404     ;;;
405 ram 1.3 (defmacro define-hash-cache (name args &key hash-function hash-bits default
406 ram 1.15 (init-form 'progn)
407 ram 1.3 (values 1))
408 rtoy 1.28.42.2 _N"DEFINE-HASH-CACHE Name ({(Arg-Name Test-Function)}*) {Key Value}*
409 ram 1.3 Define a hash cache that associates some number of argument values to a
410     result value. The Test-Function paired with each Arg-Name is used to compare
411     the value for that arg in a cache entry with a supplied arg. The
412     Test-Function must not error when passed NIL as its first arg, but need not
413     return any particular value. Test-Function may be any thing that can be
414     place in CAR position.
415    
416     Name is used to define functions these functions:
417    
418     <name>-CACHE-LOOKUP Arg*
419     See if there is an entry for the specified Args in the cache. The if not
420     present, the :DEFAULT keyword (default NIL) determines the result(s).
421    
422     <name>-CACHE-ENTER Arg* Value*
423     Encache the association of the specified args with Value.
424    
425     <name>-CACHE-FLUSH-<arg-name> Arg
426     Flush all entries from the cache that have the value Arg for the named
427     arg.
428    
429     <name>-CACHE-CLEAR
430     Reinitialize the cache, invalidating all entries and allowing the
431     arguments and result values to be GC'd.
432    
433     These other keywords are defined:
434    
435     :HASH-BITS <n>
436     The size of the cache as a power of 2.
437    
438     :HASH-FUNCTION function
439     Some thing that can be placed in CAR position which will compute a value
440     between 0 and (1- (expt 2 <hash-bits>)).
441    
442     :VALUES <n>
443 ram 1.15 The number of values cached.
444    
445     :INIT-FORM <name>
446     The DEFVAR for creating the cache is enclosed in a form with the
447     specified name. Default PROGN."
448 ram 1.3
449     (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
450     (nargs (length args))
451     (entry-size (+ nargs values))
452     (size (ash 1 hash-bits))
453     (total-size (* entry-size size))
454     (default-values (if (and (consp default) (eq (car default) 'values))
455     (cdr default)
456     (list default)))
457     (n-index (gensym))
458     (n-cache (gensym)))
459    
460     (unless (= (length default-values) values)
461 rtoy 1.28.42.2 (error _"Number of default values ~S differs from :VALUES ~D."
462 ram 1.3 default values))
463    
464     (collect ((inlines)
465     (forms)
466 ram 1.18 (inits)
467 ram 1.3 (tests)
468     (sets)
469     (arg-vars)
470     (values-indices)
471     (values-names))
472     (dotimes (i values)
473     (values-indices `(+ ,n-index ,(+ nargs i)))
474     (values-names (gensym)))
475    
476     (let ((n 0))
477     (dolist (arg args)
478     (unless (= (length arg) 2)
479 rtoy 1.28.42.2 (error _"Bad arg spec: ~S." arg))
480 ram 1.3 (let ((arg-name (first arg))
481     (test (second arg)))
482     (arg-vars arg-name)
483     (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
484     (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
485    
486     (let ((fun-name (symbolicate name "-CACHE-FLUSH-" arg-name)))
487     (forms
488     `(defun ,fun-name (,arg-name)
489 gerd 1.28 (sys:without-interrupts
490     (do ((,n-index ,(+ (- total-size entry-size) n)
491     (- ,n-index ,entry-size))
492     (,n-cache ,var-name))
493     ((minusp ,n-index))
494     (declare (type fixnum ,n-index))
495     (when (,test (svref ,n-cache ,n-index) ,arg-name)
496     (let ((,n-index (- ,n-index ,n)))
497     ,@(mapcar #'(lambda (i val)
498     `(setf (svref ,n-cache ,i) ,val))
499     (values-indices)
500     default-values))))
501     (values))))))
502 ram 1.3 (incf n)))
503 ram 1.16
504     (when *profile-hash-cache*
505 ram 1.17 (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*"))
506     (n-miss (symbolicate "*" name "-CACHE-MISSES*")))
507 ram 1.18 (inits `(setq ,n-probe 0))
508     (inits `(setq ,n-miss 0))
509     (forms `(defvar ,n-probe))
510     (forms `(defvar ,n-miss))
511 ram 1.19 (forms `(declaim (fixnum ,n-miss ,n-probe)))))
512 ram 1.16
513 ram 1.3 (let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
514     (inlines fun-name)
515     (forms
516     `(defun ,fun-name ,(arg-vars)
517 gerd 1.28 (sys:without-interrupts
518     ,@(when *profile-hash-cache*
519     `((incf ,(symbolicate "*" name "-CACHE-PROBES*"))))
520     (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
521     (,n-cache ,var-name))
522     (declare (type fixnum ,n-index))
523     (cond ((and ,@(tests))
524     (values ,@(mapcar #'(lambda (x) `(svref ,n-cache ,x))
525     (values-indices))))
526     (t
527     ,@(when *profile-hash-cache*
528     `((incf ,(symbolicate "*" name "-CACHE-MISSES*"))))
529     ,default)))))))
530 ram 1.3
531     (let ((fun-name (symbolicate name "-CACHE-ENTER")))
532     (inlines fun-name)
533     (forms
534     `(defun ,fun-name (,@(arg-vars) ,@(values-names))
535 gerd 1.28 (sys:without-interrupts
536     (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
537     (,n-cache ,var-name))
538     (declare (type fixnum ,n-index))
539     ,@(sets)
540     ,@(mapcar #'(lambda (i val)
541     `(setf (svref ,n-cache ,i) ,val))
542     (values-indices)
543     (values-names))
544     (values))))))
545 ram 1.3
546     (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
547     (forms
548     `(defun ,fun-name ()
549 gerd 1.28 (sys:without-interrupts
550     (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
551     (,n-cache ,var-name))
552     ((minusp ,n-index))
553     (declare (type fixnum ,n-index))
554     ,@(collect ((arg-sets))
555     (dotimes (i nargs)
556     (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
557     (arg-sets))
558     ,@(mapcar #'(lambda (i val)
559     `(setf (svref ,n-cache ,i) ,val))
560     (values-indices)
561     default-values))
562     (values))))
563 ram 1.3 (forms `(,fun-name)))
564 ram 1.18
565     (inits `(unless (boundp ',var-name)
566     (setq ,var-name (make-array ,total-size))))
567 ram 1.3
568     `(progn
569 ram 1.15 (defvar ,var-name)
570 ram 1.18 (,init-form ,@(inits))
571 pw 1.24 (declaim (type (simple-vector ,total-size) ,var-name))
572     (declaim (inline ,@(inlines)))
573 ram 1.3 ,@(forms)
574     ',name))))
575    
576    
577     ;;; DEFUN-CACHED -- Public
578     ;;;
579     (defmacro defun-cached ((name &rest options &key (values 1) default
580     &allow-other-keys)
581 gerd 1.27 args &parse-body (body decls doc))
582 rtoy 1.28.42.2 _N"DEFUN-CACHED (Name {Key Value}*) ({(Arg-Name Test-Function)}*) Form*
583 ram 1.3 Some syntactic sugar for defining a function whose values are cached by
584     DEFINE-HASH-CACHE."
585     (let ((default-values (if (and (consp default) (eq (car default) 'values))
586     (cdr default)
587     (list default)))
588 gerd 1.28 (arg-names (mapcar #'car args))
589     (values-names (loop repeat values collect (gensym)))
590     (cache-lookup (symbolicate name "-CACHE-LOOKUP"))
591     (cache-enter (symbolicate name "-CACHE-ENTER")))
592 ram 1.3 `(progn
593     (define-hash-cache ,name ,args ,@options)
594     (defun ,name ,arg-names
595     ,@decls
596     ,doc
597 gerd 1.28 (multiple-value-bind ,values-names
598     (,cache-lookup ,@arg-names)
599     (if (and ,@(mapcar (lambda (val def) `(eq ,val ,def))
600     values-names
601     default-values))
602     (multiple-value-bind ,values-names
603     (progn ,@body)
604     (,cache-enter ,@arg-names ,@values-names)
605     (values ,@values-names))
606     (values ,@values-names)))))))
607 ram 1.3
608    
609     ;;; CACHE-HASH-EQ -- Public
610     ;;;
611 ram 1.21 (defmacro cache-hash-eq (x)
612 rtoy 1.28.42.2 _N"Return an EQ hash of X. The value of this hash for any given object can (of
613 ram 1.3 course) change at arbitary times."
614 ram 1.21 `(lisp::pointer-hash ,x))

  ViewVC Help
Powered by ViewVC 1.1.5