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

Contents of /src/code/extensions.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5