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

Contents of /src/code/extensions.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (hide annotations)
Wed Apr 24 20:30:13 1991 UTC (23 years ago) by ram
Branch: MAIN
Changes since 1.8: +6 -7 lines
Changed ONCE-ONLY to use LET* instead of LET, cause I was tired of not being
able to do it, and it can't cause any problems that I can think of.
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     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 ram 1.9 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/extensions.lisp,v 1.9 1991/04/24 20:30:13 ram Exp $")
11 ram 1.8 ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14     ;;; Spice Lisp extensions to the language.
15     ;;;
16     ;;; Letf written by Steven Handerson.
17     ;;;
18     ;;; **********************************************************************
19     (in-package "EXTENSIONS")
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     cache-hash-eq))
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     (proclaim '(inline undefined-value))
36     (defun undefined-value ()
37     '%undefined%)
38 ram 1.6
39     ;;; REQUIRED-ARGUMENT -- Public
40     ;;;
41     (proclaim '(ftype (function () nil) required-argument))
42     (defun required-argument ()
43     "This function can be used as the default value for keyword arguments that
44     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     (error "A required keyword argument was not supplied."))
51 ram 1.2
52    
53     ;;; FILE-COMMENT -- Public
54     ;;;
55     (defmacro file-comment (string)
56     "FILE-COMMENT String
57     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     "See listen. Any whitespace in the input stream will be flushed."
74     (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     "Does what one might expect, saving the old values and setting the generalized
85     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     (lisp::foo-get-setf-method (caar bindings) env)
93     (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     "Like letf*, but evaluates all the implicit subforms and new values of all
107     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     (lisp::foo-get-setf-method (car binding) env)
118     (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     (define-setf-method logbitp (index int &environment env)
134     (multiple-value-bind (temps vals stores store-form access-form)
135     (lisp::foo-get-setf-method int env)
136     (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     "Causes the output of the indenting Stream to indent More spaces. More is
155     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     (lisp::foo-get-setf-method list env)
168     (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     (defmacro dovector ((elt vector) &rest forms)
178     "Just like dolist, but with one-dimensional arrays."
179     (let ((index (gensym))
180     (length (gensym))
181     (vec (gensym)))
182     `(let ((,vec ,vector))
183     (do ((,index 0 (1+ ,index))
184     (,length (length ,vec)))
185     ((>= ,index ,length) nil)
186     (let ((,elt (aref ,vec ,index)))
187     ,@forms)))))
188    
189    
190     (eval-when (compile load eval)
191     (defun concat-pnames (name1 name2)
192     (if name1
193     (intern (concatenate 'simple-string (symbol-name name1)
194     (symbol-name name2)))
195     name2)))
196    
197    
198     ;;; Iterate -- Public
199     ;;;
200     ;;; The ultimate iteration macro...
201     ;;;
202     (defmacro iterate (name binds &body body)
203     "Iterate Name ({(Var Initial-Value)}*) Declaration* Form*
204     This is syntactic sugar for Labels. It creates a local function Name with
205     the specified Vars as its arguments and the Declarations and Forms as its
206     body. This function is then called with the Initial-Values, and the result
207     of the call is return from the macro."
208     (dolist (x binds)
209     (unless (and (listp x)
210     (= (length x) 2))
211     (error "Malformed iterate variable spec: ~S." x)))
212    
213     `(labels ((,name ,(mapcar #'first binds) ,@body))
214     (,name ,@(mapcar #'second binds))))
215    
216    
217     ;;;; The Collect macro:
218    
219     ;;; Collect-Normal-Expander -- Internal
220     ;;;
221     ;;; This function does the real work of macroexpansion for normal collection
222     ;;; macros. N-Value is the name of the variable which holds the current
223     ;;; value. Fun is the function which does collection. Forms is the list of
224     ;;; forms whose values we are supposed to collect.
225     ;;;
226     (defun collect-normal-expander (n-value fun forms)
227     `(progn
228     ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
229     ,n-value))
230    
231     ;;; Collect-List-Expander -- Internal
232     ;;;
233     ;;; This function deals with the list collection case. N-Tail is the pointer
234     ;;; to the current tail of the list, which is NIL if the list is empty.
235     ;;;
236     (defun collect-list-expander (n-value n-tail forms)
237     (let ((n-res (gensym)))
238     `(progn
239     ,@(mapcar #'(lambda (form)
240     `(let ((,n-res (cons ,form nil)))
241     (cond (,n-tail
242     (setf (cdr ,n-tail) ,n-res)
243     (setq ,n-tail ,n-res))
244     (t
245     (setq ,n-tail ,n-res ,n-value ,n-res)))))
246     forms)
247     ,n-value)))
248    
249    
250     ;;; Collect -- Public
251     ;;;
252     ;;; The ultimate collection macro...
253     ;;;
254     (defmacro collect (collections &body body)
255     "Collect ({(Name [Initial-Value] [Function])}*) {Form}*
256     Collect some values somehow. Each of the collections specifies a bunch of
257     things which collected during the evaluation of the body of the form. The
258     name of the collection is used to define a local macro, a la MACROLET.
259     Within the body, this macro will evaluate each of its arguments and collect
260     the result, returning the current value after the collection is done. The
261     body is evaluated as a PROGN; to get the final values when you are done, just
262     call the collection macro with no arguments.
263    
264     Initial-Value is the value that the collection starts out with, which
265     defaults to NIL. Function is the function which does the collection. It is
266     a function which will accept two arguments: the value to be collected and the
267     current collection. The result of the function is made the new value for the
268     collection. As a totally magical special-case, the Function may be Collect,
269     which tells us to build a list in forward order; this is the default. If an
270     Initial-Value is supplied for Collect, the stuff will be rplacd'd onto the
271     end. Note that Function may be anything that can appear in the functional
272     position, including macros and lambdas."
273    
274     (let ((macros ())
275     (binds ()))
276     (dolist (spec collections)
277     (unless (<= 1 (length spec) 3)
278     (error "Malformed collection specifier: ~S." spec))
279     (let ((n-value (gensym))
280     (name (first spec))
281     (default (second spec))
282     (kind (or (third spec) 'collect)))
283     (push `(,n-value ,default) binds)
284     (if (eq kind 'collect)
285     (let ((n-tail (gensym)))
286     (if default
287     (push `(,n-tail (last ,n-value)) binds)
288     (push n-tail binds))
289     (push `(,name (&rest args)
290     (collect-list-expander ',n-value ',n-tail args))
291     macros))
292     (push `(,name (&rest args)
293     (collect-normal-expander ',n-value ',kind args))
294     macros))))
295     `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
296    
297    
298     ;;;; The Once-Only macro:
299    
300     ;;; Once-Only -- Interface
301     ;;;
302     ;;; Once-Only is a utility useful in writing source transforms and macros.
303     ;;; It provides an easy way to wrap a let around some code to ensure that some
304     ;;; forms are only evaluated once.
305     ;;;
306     (defmacro once-only (specs &body body)
307     "Once-Only ({(Var Value-Expression)}*) Form*
308 ram 1.9 Create a Let* which evaluates each Value-Expression, binding a temporary
309     variable to the result, and wrapping the Let* around the result of the
310 ram 1.1 evaluation of Body. Within the body, each Var is bound to the corresponding
311 ram 1.9 temporary variable."
312 ram 1.1 (let ((n-binds (gensym))
313     (n-temp (gensym)))
314     (collect ((names)
315     (temp-binds))
316     (dolist (spec specs)
317     (when (/= (length spec) 2)
318     (error "Malformed Once-Only binding spec: ~S." spec))
319     (let ((name (first spec))
320     (exp (second spec)))
321     (names `(,name ,exp))
322     (temp-binds
323     `(let ((,n-temp (gensym)))
324     (,n-binds `(,,n-temp ,,name))
325     (setq ,name ,n-temp)))))
326 ram 1.9 `(let* ,(names)
327 ram 1.1 (collect ((,n-binds))
328     ,@(temp-binds)
329 ram 1.9 (list 'let* (,n-binds) (progn ,@body)))))))
330 ram 1.1
331    
332     ;;;; DO-ANONYMOUS:
333    
334     ;;; ### Bootstrap hack... Renamed to avoid clobbering function in bootstrap
335     ;;; environment.
336     ;;;
337     (defun lisp::do-do-body (varlist endlist code decl bind step name block)
338     (let* ((inits ())
339     (steps ())
340     (l1 (gensym))
341     (l2 (gensym)))
342     ;; Check for illegal old-style do.
343     (when (or (not (listp varlist)) (atom endlist))
344     (error "Ill-formed ~S -- possibly illegal old style DO?" name))
345     ;; Parse the varlist to get inits and steps.
346     (dolist (v varlist)
347     (cond ((symbolp v) (push v inits))
348     ((listp v)
349     (unless (symbolp (first v))
350     (error "~S step variable is not a symbol: ~S" name (first v)))
351     (case (length v)
352     (1 (push (first v) inits))
353     (2 (push v inits))
354     (3 (push (list (first v) (second v)) inits)
355     (setq steps (list* (third v) (first v) steps)))
356     (t (error "~S is an illegal form for a ~S varlist." v name))))
357     (t (error "~S is an illegal form for a ~S varlist." v name))))
358     ;; And finally construct the new form.
359     `(block ,BLOCK
360     (,bind ,(nreverse inits)
361     ,@decl
362     (tagbody
363     (go ,L2)
364     ,L1
365     ,@code
366     (,step ,@(nreverse steps))
367     ,L2
368     (unless ,(car endlist) (go ,L1))
369     (return-from ,BLOCK (progn ,@(cdr endlist))))))))
370    
371    
372     (defmacro do-anonymous (varlist endlist &body (body decls))
373     "DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
374     Like DO, but has no implicit NIL block. Each Var is initialized in parallel
375     to the value of the specified Init form. On subsequent iterations, the Vars
376     are assigned the value of the Step form (if any) in paralell. The Test is
377     evaluated before each evaluation of the body Forms. When the Test is true,
378     the the Exit-Forms are evaluated as a PROGN, with the result being the value
379     of the DO."
380     (lisp::do-do-body varlist endlist body decls 'let 'psetq
381     'do-anonymous (gensym)))
382 ram 1.3
383    
384     ;;;; Hash cache utility:
385    
386     ;;; DEFINE-HASH-CACHE -- Public
387     ;;;
388     (defmacro define-hash-cache (name args &key hash-function hash-bits default
389     (values 1))
390     "DEFINE-HASH-CACHE Name ({(Arg-Name Test-Function)}*) {Key Value}*
391     Define a hash cache that associates some number of argument values to a
392     result value. The Test-Function paired with each Arg-Name is used to compare
393     the value for that arg in a cache entry with a supplied arg. The
394     Test-Function must not error when passed NIL as its first arg, but need not
395     return any particular value. Test-Function may be any thing that can be
396     place in CAR position.
397    
398     Name is used to define functions these functions:
399    
400     <name>-CACHE-LOOKUP Arg*
401     See if there is an entry for the specified Args in the cache. The if not
402     present, the :DEFAULT keyword (default NIL) determines the result(s).
403    
404     <name>-CACHE-ENTER Arg* Value*
405     Encache the association of the specified args with Value.
406    
407     <name>-CACHE-FLUSH-<arg-name> Arg
408     Flush all entries from the cache that have the value Arg for the named
409     arg.
410    
411     <name>-CACHE-CLEAR
412     Reinitialize the cache, invalidating all entries and allowing the
413     arguments and result values to be GC'd.
414    
415     These other keywords are defined:
416    
417     :HASH-BITS <n>
418     The size of the cache as a power of 2.
419    
420     :HASH-FUNCTION function
421     Some thing that can be placed in CAR position which will compute a value
422     between 0 and (1- (expt 2 <hash-bits>)).
423    
424     :VALUES <n>
425     The number of values cached."
426    
427     (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
428     (nargs (length args))
429     (entry-size (+ nargs values))
430     (size (ash 1 hash-bits))
431     (total-size (* entry-size size))
432     (default-values (if (and (consp default) (eq (car default) 'values))
433     (cdr default)
434     (list default)))
435     (n-index (gensym))
436     (n-cache (gensym)))
437    
438     (unless (= (length default-values) values)
439     (error "Number of default values ~S differs from :VALUES ~D."
440     default values))
441    
442     (collect ((inlines)
443     (forms)
444     (tests)
445     (sets)
446     (arg-vars)
447     (values-indices)
448     (values-names))
449     (dotimes (i values)
450     (values-indices `(+ ,n-index ,(+ nargs i)))
451     (values-names (gensym)))
452    
453     (let ((n 0))
454     (dolist (arg args)
455     (unless (= (length arg) 2)
456     (error "Bad arg spec: ~S." arg))
457     (let ((arg-name (first arg))
458     (test (second arg)))
459     (arg-vars arg-name)
460     (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
461     (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
462    
463     (let ((fun-name (symbolicate name "-CACHE-FLUSH-" arg-name)))
464     (forms
465     `(defun ,fun-name (,arg-name)
466     (do ((,n-index ,(+ (- total-size entry-size) n)
467     (- ,n-index ,entry-size))
468     (,n-cache ,var-name))
469     ((minusp ,n-index))
470 ram 1.5 (declare (type fixnum ,n-index))
471 ram 1.3 (when (,test (svref ,n-cache ,n-index) ,arg-name)
472     (let ((,n-index (- ,n-index ,n)))
473     ,@(mapcar #'(lambda (i val)
474     `(setf (svref ,n-cache ,i) ,val))
475     (values-indices)
476     default-values))))
477     (undefined-value)))))
478     (incf n)))
479    
480     (let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
481     (inlines fun-name)
482     (forms
483     `(defun ,fun-name ,(arg-vars)
484     (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
485     (,n-cache ,var-name))
486 ram 1.5 (declare (type fixnum ,n-index))
487 ram 1.3 (if (and ,@(tests))
488     (values ,@(mapcar #'(lambda (x) `(svref ,n-cache ,x))
489     (values-indices)))
490     ,default)))))
491    
492     (let ((fun-name (symbolicate name "-CACHE-ENTER")))
493     (inlines fun-name)
494     (forms
495     `(defun ,fun-name (,@(arg-vars) ,@(values-names))
496     (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
497     (,n-cache ,var-name))
498 ram 1.5 (declare (type fixnum ,n-index))
499 ram 1.3 ,@(sets)
500     ,@(mapcar #'(lambda (i val)
501     `(setf (svref ,n-cache ,i) ,val))
502     (values-indices)
503     (values-names))
504     (undefined-value)))))
505    
506     (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
507     (forms
508     `(defun ,fun-name ()
509     (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
510     (,n-cache ,var-name))
511     ((minusp ,n-index))
512 ram 1.5 (declare (type fixnum ,n-index))
513 ram 1.3 ,@(collect ((arg-sets))
514     (dotimes (i nargs)
515     (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
516     (arg-sets))
517     ,@(mapcar #'(lambda (i val)
518     `(setf (svref ,n-cache ,i) ,val))
519     (values-indices)
520 ram 1.4 default-values))
521     (undefined-value)))
522 ram 1.3 (forms `(,fun-name)))
523    
524     `(progn
525     (defvar ,var-name (make-array ,total-size))
526     (proclaim '(type (simple-vector ,total-size) ,var-name))
527     (proclaim '(inline ,@(inlines)))
528     ,@(forms)
529     ',name))))
530    
531    
532     ;;; DEFUN-CACHED -- Public
533     ;;;
534     (defmacro defun-cached ((name &rest options &key (values 1) default
535     &allow-other-keys)
536     args &body (body decls doc))
537     "DEFUN-CACHED (Name {Key Value}*) ({(Arg-Name Test-Function)}*) Form*
538     Some syntactic sugar for defining a function whose values are cached by
539     DEFINE-HASH-CACHE."
540     (let ((default-values (if (and (consp default) (eq (car default) 'values))
541     (cdr default)
542     (list default)))
543     (arg-names (mapcar #'car args)))
544     (collect ((values-names))
545     (dotimes (i values)
546     (values-names (gensym)))
547     `(progn
548     (define-hash-cache ,name ,args ,@options)
549     (defun ,name ,arg-names
550     ,@decls
551     ,doc
552     (multiple-value-bind
553     ,(values-names)
554     (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
555     (if (and ,@(mapcar #'(lambda (val def)
556     `(eq ,val ,def))
557     (values-names) default-values))
558     (multiple-value-bind ,(values-names)
559     (progn ,@body)
560     (,(symbolicate name "-CACHE-ENTER") ,@arg-names
561     ,@(values-names))
562     (values ,@(values-names)))
563     (values ,@(values-names)))))))))
564    
565    
566     ;;; CACHE-HASH-EQ -- Public
567     ;;;
568     (proclaim '(inline cache-hash-eq))
569     (defun cache-hash-eq (x)
570     "Return an EQ hash of X. The value of this hash for any given object can (of
571     course) change at arbitary times."
572 wlott 1.7 (the fixnum (ash (truly-the fixnum (%primitive lisp::make-fixnum x)) -3)))
573 ram 1.3

  ViewVC Help
Powered by ViewVC 1.1.5