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

Contents of /src/code/extensions.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5