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

Contents of /src/code/extensions.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5