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

Contents of /src/code/extensions.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (show annotations)
Thu Aug 19 14:14:29 1993 UTC (20 years, 8 months ago) by ram
Branch: MAIN
Changes since 1.19: +2 -3 lines
Call pointer-hash instead of %primitive in cache-hash-eq.
1 ;;; -*- Log: code.log; Package: Extensions -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/extensions.lisp,v 1.20 1993/08/19 14:14:29 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Spice Lisp extensions to the language.
15 ;;;
16 ;;; Letf written by Steven Handerson.
17 ;;;
18 ;;; **********************************************************************
19 (in-package "EXTENSIONS")
20
21 (export '(letf* letf dovector deletef indenting-further file-comment
22 read-char-no-edit listen-skip-whitespace concat-pnames
23 iterate once-only collect do-anonymous undefined-value
24 required-argument define-hash-cache defun-cached
25 cache-hash-eq do-hash))
26
27 (import 'lisp::whitespace-char-p)
28
29
30
31 ;;; 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
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
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
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 (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 (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 (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 (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 (declare (symbol name1 name2))
193 (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 "Iterate Name ({(Var Initial-Value)}*) Declaration* Form*
205 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 (error "Malformed iterate variable spec: ~S." x)))
213
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 "Collect ({(Name [Initial-Value] [Function])}*) {Form}*
257 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 (error "Malformed collection specifier: ~S." spec))
280 (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 "Once-Only ({(Var Value-Expression)}*) Form*
309 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 evaluation of Body. Within the body, each Var is bound to the corresponding
312 temporary variable."
313 (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 (error "Malformed Once-Only binding spec: ~S." spec))
321 (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
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
380 (defmacro do-hash ((key-var value-var table &optional result)
381 &body (body decls))
382 "DO-HASH (Key-Var Value-Var Table [Result]) Declaration* Form*
383 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
394
395 ;;;; Hash cache utility:
396
397 (eval-when (compile load eval)
398 (defvar *profile-hash-cache* nil))
399
400 ;;; DEFINE-HASH-CACHE -- Public
401 ;;;
402 ;;; :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 (defmacro define-hash-cache (name args &key hash-function hash-bits default
406 (init-form 'progn)
407 (values 1))
408 "DEFINE-HASH-CACHE Name ({(Arg-Name Test-Function)}*) {Key Value}*
409 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 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
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 (error "Number of default values ~S differs from :VALUES ~D."
462 default values))
463
464 (collect ((inlines)
465 (forms)
466 (inits)
467 (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 (error "Bad arg spec: ~S." arg))
480 (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 (do ((,n-index ,(+ (- total-size entry-size) n)
490 (- ,n-index ,entry-size))
491 (,n-cache ,var-name))
492 ((minusp ,n-index))
493 (declare (type fixnum ,n-index))
494 (when (,test (svref ,n-cache ,n-index) ,arg-name)
495 (let ((,n-index (- ,n-index ,n)))
496 ,@(mapcar #'(lambda (i val)
497 `(setf (svref ,n-cache ,i) ,val))
498 (values-indices)
499 default-values))))
500 (undefined-value)))))
501 (incf n)))
502
503 (when *profile-hash-cache*
504 (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*"))
505 (n-miss (symbolicate "*" name "-CACHE-MISSES*")))
506 (inits `(setq ,n-probe 0))
507 (inits `(setq ,n-miss 0))
508 (forms `(defvar ,n-probe))
509 (forms `(defvar ,n-miss))
510 (forms `(declaim (fixnum ,n-miss ,n-probe)))))
511
512 (let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
513 (inlines fun-name)
514 (forms
515 `(defun ,fun-name ,(arg-vars)
516 ,@(when *profile-hash-cache*
517 `((incf ,(symbolicate "*" name "-CACHE-PROBES*"))))
518 (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
519 (,n-cache ,var-name))
520 (declare (type fixnum ,n-index))
521 (cond ((and ,@(tests))
522 (values ,@(mapcar #'(lambda (x) `(svref ,n-cache ,x))
523 (values-indices))))
524 (t
525 ,@(when *profile-hash-cache*
526 `((incf ,(symbolicate "*" name "-CACHE-MISSES*"))))
527 ,default))))))
528
529 (let ((fun-name (symbolicate name "-CACHE-ENTER")))
530 (inlines fun-name)
531 (forms
532 `(defun ,fun-name (,@(arg-vars) ,@(values-names))
533 (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
534 (,n-cache ,var-name))
535 (declare (type fixnum ,n-index))
536 ,@(sets)
537 ,@(mapcar #'(lambda (i val)
538 `(setf (svref ,n-cache ,i) ,val))
539 (values-indices)
540 (values-names))
541 (undefined-value)))))
542
543 (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
544 (forms
545 `(defun ,fun-name ()
546 (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
547 (,n-cache ,var-name))
548 ((minusp ,n-index))
549 (declare (type fixnum ,n-index))
550 ,@(collect ((arg-sets))
551 (dotimes (i nargs)
552 (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
553 (arg-sets))
554 ,@(mapcar #'(lambda (i val)
555 `(setf (svref ,n-cache ,i) ,val))
556 (values-indices)
557 default-values))
558 (undefined-value)))
559 (forms `(,fun-name)))
560
561 (inits `(unless (boundp ',var-name)
562 (setq ,var-name (make-array ,total-size))))
563
564 `(progn
565 (defvar ,var-name)
566 (,init-form ,@(inits))
567 (proclaim '(type (simple-vector ,total-size) ,var-name))
568 (proclaim '(inline ,@(inlines)))
569 ,@(forms)
570 ',name))))
571
572
573 ;;; DEFUN-CACHED -- Public
574 ;;;
575 (defmacro defun-cached ((name &rest options &key (values 1) default
576 &allow-other-keys)
577 args &body (body decls doc))
578 "DEFUN-CACHED (Name {Key Value}*) ({(Arg-Name Test-Function)}*) Form*
579 Some syntactic sugar for defining a function whose values are cached by
580 DEFINE-HASH-CACHE."
581 (let ((default-values (if (and (consp default) (eq (car default) 'values))
582 (cdr default)
583 (list default)))
584 (arg-names (mapcar #'car args)))
585 (collect ((values-names))
586 (dotimes (i values)
587 (values-names (gensym)))
588 `(progn
589 (define-hash-cache ,name ,args ,@options)
590 (defun ,name ,arg-names
591 ,@decls
592 ,doc
593 (multiple-value-bind
594 ,(values-names)
595 (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
596 (if (and ,@(mapcar #'(lambda (val def)
597 `(eq ,val ,def))
598 (values-names) default-values))
599 (multiple-value-bind ,(values-names)
600 (progn ,@body)
601 (,(symbolicate name "-CACHE-ENTER") ,@arg-names
602 ,@(values-names))
603 (values ,@(values-names)))
604 (values ,@(values-names)))))))))
605
606
607 ;;; CACHE-HASH-EQ -- Public
608 ;;;
609 (proclaim '(inline cache-hash-eq))
610 (defun cache-hash-eq (x)
611 "Return an EQ hash of X. The value of this hash for any given object can (of
612 course) change at arbitary times."
613 (lisp::pointer-hash x))

  ViewVC Help
Powered by ViewVC 1.1.5