1 ;;;; various extensions (including SB-INT "internal extensions")
2 ;;;; available both in the cross-compilation host Lisp and in the
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; This software is derived from the CMU CL system, which was
9 ;;;; written at Carnegie Mellon University and released into the
10 ;;;; public domain. The software is in the public domain and is
11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
12 ;;;; files for more information.
14 (in-package "SB!IMPL")
16 ;;; something not EQ to anything we might legitimately READ
17 (defparameter *eof-object
* (make-symbol "EOF-OBJECT"))
19 ;;; a type used for indexing into arrays, and for related quantities
20 ;;; like lengths of lists
22 ;;; It's intentionally limited to one less than the
23 ;;; ARRAY-DIMENSION-LIMIT for efficiency reasons, because in SBCL
24 ;;; ARRAY-DIMENSION-LIMIT is MOST-POSITIVE-FIXNUM, and staying below
25 ;;; that lets the system know it can increment a value of this type
26 ;;; without having to worry about using a bignum to represent the
29 ;;; (It should be safe to use ARRAY-DIMENSION-LIMIT as an exclusive
30 ;;; bound because ANSI specifies it as an exclusive bound.)
31 (def!type index
() `(integer 0 (,sb
!xc
:array-dimension-limit
)))
33 ;;; like INDEX, but augmented with -1 (useful when using the index
34 ;;; to count downwards to 0, e.g. LOOP FOR I FROM N DOWNTO 0, with
35 ;;; an implementation which terminates the loop by testing for the
36 ;;; index leaving the loop range)
37 (def!type index-or-minus-1
() `(integer -
1 (,sb
!xc
:array-dimension-limit
)))
39 ;;; A couple of VM-related types that are currently used only on the
40 ;;; alpha platform. -- CSR, 2002-06-24
41 (def!type unsigned-byte-with-a-bite-out
(s bite
)
42 (cond ((eq s
'*) 'integer
)
43 ((and (integerp s
) (> s
0))
44 (let ((bound (ash 1 s
)))
45 `(integer 0 ,(- bound bite
1))))
47 (error "Bad size specified for UNSIGNED-BYTE type specifier: ~S." s
))))
49 ;;; Motivated by the mips port. -- CSR, 2002-08-22
50 (def!type signed-byte-with-a-bite-out
(s bite
)
51 (cond ((eq s
'*) 'integer
)
52 ((and (integerp s
) (> s
1))
53 (let ((bound (ash 1 (1- s
))))
54 `(integer ,(- bound
) ,(- bound bite
1))))
56 (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s
))))
58 (def!type load
/store-index
(scale lowtag min-offset
59 &optional
(max-offset min-offset
))
60 `(integer ,(- (truncate (+ (ash 1 16)
61 (* min-offset sb
!vm
:n-word-bytes
)
64 ,(truncate (- (+ (1- (ash 1 16)) lowtag
)
65 (* max-offset sb
!vm
:n-word-bytes
))
68 ;;; the default value used for initializing character data. The ANSI
69 ;;; spec says this is arbitrary, so we use the value that falls
70 ;;; through when we just let the low-level consing code initialize
71 ;;; all newly-allocated memory to zero.
73 ;;; KLUDGE: It might be nice to use something which is a
74 ;;; STANDARD-CHAR, both to reduce user surprise a little and, probably
75 ;;; more significantly, to help SBCL's cross-compiler (which knows how
76 ;;; to dump STANDARD-CHARs). Unfortunately, the old CMU CL code is
77 ;;; shot through with implicit assumptions that it's #\NULL, and code
78 ;;; in several places (notably both DEFUN MAKE-ARRAY and DEFTRANSFORM
79 ;;; MAKE-ARRAY) would have to be rewritten. -- WHN 2001-10-04
80 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
81 ;; an expression we can use to construct a DEFAULT-INIT-CHAR value
82 ;; at load time (so that we don't need to teach the cross-compiler
83 ;; how to represent and dump non-STANDARD-CHARs like #\NULL)
84 (defparameter *default-init-char-form
* '(code-char 0)))
86 ;;; CHAR-CODE values for ASCII characters which we care about but
87 ;;; which aren't defined in section "2.1.3 Standard Characters" of the
88 ;;; ANSI specification for Lisp
90 ;;; KLUDGE: These are typically used in the idiom (CODE-CHAR
91 ;;; FOO-CHAR-CODE). I suspect that the current implementation is
92 ;;; expanding this idiom into a full call to CODE-CHAR, which is an
93 ;;; annoying overhead. I should check whether this is happening, and
94 ;;; if so, perhaps implement a DEFTRANSFORM or something to stop it.
95 ;;; (or just find a nicer way of expressing characters portably?) --
97 (def!constant bell-char-code
7)
98 (def!constant backspace-char-code
8)
99 (def!constant tab-char-code
9)
100 (def!constant line-feed-char-code
10)
101 (def!constant form-feed-char-code
12)
102 (def!constant return-char-code
13)
103 (def!constant escape-char-code
27)
104 (def!constant rubout-char-code
127)
106 ;;;; type-ish predicates
108 ;;; a helper function for various macros which expect clauses of a
109 ;;; given length, etc.
110 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
111 ;; Return true if X is a proper list whose length is between MIN and
113 (defun proper-list-of-length-p (x min
&optional
(max min
))
114 ;; FIXME: This implementation will hang on circular list
115 ;; structure. Since this is an error-checking utility, i.e. its
116 ;; job is to deal with screwed-up input, it'd be good style to fix
117 ;; it so that it can deal with circular list structure.
124 (proper-list-of-length-p (cdr x
)
131 ;;; Is X a list containing a cycle?
132 (defun cyclic-list-p (x)
134 (labels ((safe-cddr (x) (if (listp (cdr x
)) (cddr x
))))
135 (do ((y x
(safe-cddr y
))
138 ((not (and (consp z
) (consp y
))) nil
)
139 (when (and started-p
(eq y z
))
142 ;;; Is X a (possibly-improper) list of at least N elements?
143 (declaim (ftype (function (t index
)) list-of-length-at-least-p
))
144 (defun list-of-length-at-least-p (x n
)
145 (or (zerop n
) ; since anything can be considered an improper list of length 0
147 (list-of-length-at-least-p (cdr x
) (1- n
)))))
149 ;;; Is X is a positive prime integer?
150 (defun positive-primep (x)
151 ;; This happens to be called only from one place in sbcl-0.7.0, and
152 ;; only for fixnums, we can limit it to fixnums for efficiency. (And
153 ;; if we didn't limit it to fixnums, we should use a cleverer
154 ;; algorithm, since this one scales pretty badly for huge X.)
157 (and (>= x
2) (/= x
4))
159 (not (zerop (rem x
3)))
162 (inc 2 (logxor inc
6)) ;; 2,4,2,4...
164 ((or (= r
0) (> d q
)) (/= r
0))
165 (declare (fixnum inc
))
166 (multiple-value-setq (q r
) (truncate x d
))))))
168 ;;; Could this object contain other objects? (This is important to
169 ;;; the implementation of things like *PRINT-CIRCLE* and the dumper.)
170 (defun compound-object-p (x)
173 (typep x
'(array t
*))))
175 ;;;; the COLLECT macro
177 ;;;; comment from CMU CL: "the ultimate collection macro..."
179 ;;; helper functions for COLLECT, which become the expanders of the
180 ;;; MACROLET definitions created by COLLECT
182 ;;; COLLECT-NORMAL-EXPANDER handles normal collection macros.
184 ;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
185 ;;; is the pointer to the current tail of the list, or NIL if the list
187 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
188 (defun collect-normal-expander (n-value fun forms
)
190 ,@(mapcar (lambda (form) `(setq ,n-value
(,fun
,form
,n-value
))) forms
)
192 (defun collect-list-expander (n-value n-tail forms
)
193 (let ((n-res (gensym)))
195 ,@(mapcar (lambda (form)
196 `(let ((,n-res
(cons ,form nil
)))
198 (setf (cdr ,n-tail
) ,n-res
)
199 (setq ,n-tail
,n-res
))
201 (setq ,n-tail
,n-res
,n-value
,n-res
)))))
205 ;;; Collect some values somehow. Each of the collections specifies a
206 ;;; bunch of things which collected during the evaluation of the body
207 ;;; of the form. The name of the collection is used to define a local
208 ;;; macro, a la MACROLET. Within the body, this macro will evaluate
209 ;;; each of its arguments and collect the result, returning the
210 ;;; current value after the collection is done. The body is evaluated
211 ;;; as a PROGN; to get the final values when you are done, just call
212 ;;; the collection macro with no arguments.
214 ;;; INITIAL-VALUE is the value that the collection starts out with,
215 ;;; which defaults to NIL. FUNCTION is the function which does the
216 ;;; collection. It is a function which will accept two arguments: the
217 ;;; value to be collected and the current collection. The result of
218 ;;; the function is made the new value for the collection. As a
219 ;;; totally magical special-case, FUNCTION may be COLLECT, which tells
220 ;;; us to build a list in forward order; this is the default. If an
221 ;;; INITIAL-VALUE is supplied for COLLECT, the stuff will be RPLACD'd
222 ;;; onto the end. Note that FUNCTION may be anything that can appear
223 ;;; in the functional position, including macros and lambdas.
224 (defmacro collect
(collections &body body
)
227 (dolist (spec collections
)
228 (unless (proper-list-of-length-p spec
1 3)
229 (error "malformed collection specifier: ~S" spec
))
230 (let* ((name (first spec
))
231 (default (second spec
))
232 (kind (or (third spec
) 'collect
))
233 (n-value (gensym (concatenate 'string
236 (push `(,n-value
,default
) binds
)
237 (if (eq kind
'collect
)
238 (let ((n-tail (gensym (concatenate 'string
242 (push `(,n-tail
(last ,n-value
)) binds
)
244 (push `(,name
(&rest args
)
245 (collect-list-expander ',n-value
',n-tail args
))
247 (push `(,name
(&rest args
)
248 (collect-normal-expander ',n-value
',kind args
))
250 `(macrolet ,macros
(let* ,(nreverse binds
) ,@body
))))
252 ;;;; some old-fashioned functions. (They're not just for old-fashioned
253 ;;;; code, they're also used as optimized forms of the corresponding
254 ;;;; general functions when the compiler can prove that they're
257 ;;; like (MEMBER ITEM LIST :TEST #'EQ)
258 (defun memq (item list
)
260 "Return tail of LIST beginning with first element EQ to ITEM."
261 ;; KLUDGE: These could be and probably should be defined as
262 ;; (MEMBER ITEM LIST :TEST #'EQ)),
263 ;; but when I try to cross-compile that, I get an error from
264 ;; LTN-ANALYZE-KNOWN-CALL, "Recursive known function definition". The
265 ;; comments for that error say it "is probably a botched interpreter stub".
266 ;; Rather than try to figure that out, I just rewrote this function from
267 ;; scratch. -- WHN 19990512
268 (do ((i list
(cdr i
)))
270 (when (eq (car i
) item
)
273 ;;; like (ASSOC ITEM ALIST :TEST #'EQ):
274 ;;; Return the first pair of ALIST where ITEM is EQ to the key of
276 (defun assq (item alist
)
277 ;; KLUDGE: CMU CL defined this with
278 ;; (DECLARE (INLINE ASSOC))
279 ;; (ASSOC ITEM ALIST :TEST #'EQ))
280 ;; which is pretty, but which would have required adding awkward
281 ;; build order constraints on SBCL (or figuring out some way to make
282 ;; inline definitions installable at build-the-cross-compiler time,
283 ;; which was too ambitious for now). Rather than mess with that, we
284 ;; just define ASSQ explicitly in terms of more primitive
287 (when (eq (car pair
) item
)
290 ;;; like (DELETE .. :TEST #'EQ):
291 ;;; Delete all LIST entries EQ to ITEM (destructively modifying
292 ;;; LIST), and return the modified LIST.
293 (defun delq (item list
)
295 (do ((x list
(cdr x
))
298 (cond ((eq item
(car x
))
301 (rplacd splice
(cdr x
))))
302 (t (setq splice x
)))))) ; Move splice along to include element.
305 ;;; like (POSITION .. :TEST #'EQ):
306 ;;; Return the position of the first element EQ to ITEM.
307 (defun posq (item list
)
308 (do ((i list
(cdr i
))
311 (when (eq (car i
) item
)
314 (declaim (inline neq
))
318 ;;; not really an old-fashioned function, but what the calling
319 ;;; convention should've been: like NTH, but with the same argument
320 ;;; order as in all the other dereferencing functions, with the
321 ;;; collection first and the index second
322 (declaim (inline nth-but-with-sane-arg-order
))
323 (declaim (ftype (function (list index
) t
) nth-but-with-sane-arg-order
))
324 (defun nth-but-with-sane-arg-order (list index
)
327 ;;;; miscellaneous iteration extensions
329 ;;; "the ultimate iteration macro"
331 ;;; note for Schemers: This seems to be identical to Scheme's "named LET".
332 (defmacro named-let
(name binds
&body body
)
335 (unless (proper-list-of-length-p x
2)
336 (error "malformed NAMED-LET variable spec: ~S" x
)))
337 `(labels ((,name
,(mapcar #'first binds
) ,@body
))
338 (,name
,@(mapcar #'second binds
))))
340 ;;; just like DOLIST, but with one-dimensional arrays
341 (defmacro dovector
((elt vector
&optional result
) &rest forms
)
342 (let ((index (gensym))
345 `(let ((,vec
,vector
))
346 (declare (type vector
,vec
))
347 (do ((,index
0 (1+ ,index
))
348 (,length
(length ,vec
)))
349 ((>= ,index
,length
) ,result
)
350 (let ((,elt
(aref ,vec
,index
)))
353 ;;; Iterate over the entries in a HASH-TABLE.
354 (defmacro dohash
((key-var value-var table
&optional result
) &body body
)
355 (multiple-value-bind (forms decls
) (parse-body body nil
)
358 `(with-hash-table-iterator (,gen
,table
)
360 (multiple-value-bind (,n-more
,key-var
,value-var
) (,gen
)
362 (unless ,n-more
(return ,result
))
365 ;;;; hash cache utility
367 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
368 (defvar *profile-hash-cache
* nil
))
370 ;;; a flag for whether it's too early in cold init to use caches so
371 ;;; that we have a better chance of recovering so that we have a
372 ;;; better chance of getting the system running so that we have a
373 ;;; better chance of diagnosing the problem which caused us to use the
376 (defvar *hash-caches-initialized-p
*)
378 ;;; Define a hash cache that associates some number of argument values
379 ;;; with a result value. The TEST-FUNCTION paired with each ARG-NAME
380 ;;; is used to compare the value for that arg in a cache entry with a
381 ;;; supplied arg. The TEST-FUNCTION must not error when passed NIL as
382 ;;; its first arg, but need not return any particular value.
383 ;;; TEST-FUNCTION may be any thing that can be placed in CAR position.
385 ;;; NAME is used to define these functions:
386 ;;; <name>-CACHE-LOOKUP Arg*
387 ;;; See whether there is an entry for the specified ARGs in the
388 ;;; cache. If not present, the :DEFAULT keyword (default NIL)
389 ;;; determines the result(s).
390 ;;; <name>-CACHE-ENTER Arg* Value*
391 ;;; Encache the association of the specified args with VALUE.
392 ;;; <name>-CACHE-CLEAR
393 ;;; Reinitialize the cache, invalidating all entries and allowing
394 ;;; the arguments and result values to be GC'd.
396 ;;; These other keywords are defined:
398 ;;; The size of the cache as a power of 2.
399 ;;; :HASH-FUNCTION function
400 ;;; Some thing that can be placed in CAR position which will compute
401 ;;; a value between 0 and (1- (expt 2 <hash-bits>)).
403 ;;; the number of return values cached for each function call
404 ;;; :INIT-WRAPPER <name>
405 ;;; The code for initializing the cache is wrapped in a form with
406 ;;; the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS
407 ;;; in type system definitions so that caches will be created
408 ;;; before top level forms run.)
409 (defmacro define-hash-cache
(name args
&key hash-function hash-bits default
410 (init-wrapper 'progn
)
412 (let* ((var-name (symbolicate "*" name
"-CACHE-VECTOR*"))
413 (nargs (length args
))
414 (entry-size (+ nargs values
))
415 (size (ash 1 hash-bits
))
416 (total-size (* entry-size size
))
417 (default-values (if (and (consp default
) (eq (car default
) 'values
))
423 (unless (= (length default-values
) values
)
424 (error "The number of default values ~S differs from :VALUES ~W."
436 (values-indices `(+ ,n-index
,(+ nargs i
)))
437 (values-names (gensym)))
440 (unless (= (length arg
) 2)
441 (error "bad argument spec: ~S" arg
))
442 (let ((arg-name (first arg
))
445 (tests `(,test
(svref ,n-cache
(+ ,n-index
,n
)) ,arg-name
))
446 (sets `(setf (svref ,n-cache
(+ ,n-index
,n
)) ,arg-name
)))
449 (when *profile-hash-cache
*
450 (let ((n-probe (symbolicate "*" name
"-CACHE-PROBES*"))
451 (n-miss (symbolicate "*" name
"-CACHE-MISSES*")))
452 (inits `(setq ,n-probe
0))
453 (inits `(setq ,n-miss
0))
454 (forms `(defvar ,n-probe
))
455 (forms `(defvar ,n-miss
))
456 (forms `(declaim (fixnum ,n-miss
,n-probe
)))))
458 (let ((fun-name (symbolicate name
"-CACHE-LOOKUP")))
461 `(defun ,fun-name
,(arg-vars)
462 ,@(when *profile-hash-cache
*
463 `((incf ,(symbolicate "*" name
"-CACHE-PROBES*"))))
464 (let ((,n-index
(* (,hash-function
,@(arg-vars)) ,entry-size
))
465 (,n-cache
,var-name
))
466 (declare (type fixnum
,n-index
))
467 (cond ((and ,@(tests))
468 (values ,@(mapcar (lambda (x) `(svref ,n-cache
,x
))
471 ,@(when *profile-hash-cache
*
472 `((incf ,(symbolicate "*" name
"-CACHE-MISSES*"))))
475 (let ((fun-name (symbolicate name
"-CACHE-ENTER")))
478 `(defun ,fun-name
(,@(arg-vars) ,@(values-names))
479 (let ((,n-index
(* (,hash-function
,@(arg-vars)) ,entry-size
))
480 (,n-cache
,var-name
))
481 (declare (type fixnum
,n-index
))
483 ,@(mapcar (lambda (i val
)
484 `(setf (svref ,n-cache
,i
) ,val
))
489 (let ((fun-name (symbolicate name
"-CACHE-CLEAR")))
492 (do ((,n-index
,(- total-size entry-size
) (- ,n-index
,entry-size
))
493 (,n-cache
,var-name
))
495 (declare (type fixnum
,n-index
))
496 ,@(collect ((arg-sets))
498 (arg-sets `(setf (svref ,n-cache
(+ ,n-index
,i
)) nil
)))
500 ,@(mapcar (lambda (i val
)
501 `(setf (svref ,n-cache
,i
) ,val
))
505 (forms `(,fun-name
)))
507 (inits `(unless (boundp ',var-name
)
508 (setq ,var-name
(make-array ,total-size
))))
509 #!+sb-show
(inits `(setq *hash-caches-initialized-p
* t
))
513 (declaim (type (simple-vector ,total-size
) ,var-name
))
514 #!-sb-fluid
(declaim (inline ,@(inlines)))
515 (,init-wrapper
,@(inits))
519 ;;; some syntactic sugar for defining a function whose values are
520 ;;; cached by DEFINE-HASH-CACHE
521 (defmacro defun-cached
((name &rest options
&key
(values 1) default
523 args
&body body-decls-doc
)
524 (let ((default-values (if (and (consp default
) (eq (car default
) 'values
))
527 (arg-names (mapcar #'car args
)))
528 (collect ((values-names))
530 (values-names (gensym)))
531 (multiple-value-bind (body decls doc
) (parse-body body-decls-doc
)
533 (define-hash-cache ,name
,args
,@options
)
534 (defun ,name
,arg-names
538 ((not (boundp '*hash-caches-initialized-p
*))
539 ;; This shouldn't happen, but it did happen to me
540 ;; when revising the type system, and it's a lot
541 ;; easier to figure out what what's going on with
542 ;; that kind of problem if the system can be kept
543 ;; alive until cold boot is complete. The recovery
544 ;; mechanism should definitely be conditional on
545 ;; some debugging feature (e.g. SB-SHOW) because
546 ;; it's big, duplicating all the BODY code. -- WHN
547 (/show0
,name
" too early in cold init, uncached")
548 (/show0
,(first arg-names
) "=..")
549 (/hexstr
,(first arg-names
))
552 (multiple-value-bind ,(values-names)
553 (,(symbolicate name
"-CACHE-LOOKUP") ,@arg-names
)
554 (if (and ,@(mapcar (lambda (val def
)
556 (values-names) default-values
))
557 (multiple-value-bind ,(values-names)
559 (,(symbolicate name
"-CACHE-ENTER") ,@arg-names
561 (values ,@(values-names)))
562 (values ,@(values-names))))))))))))
566 ;;; Note: Almost always you want to use FIND-UNDELETED-PACKAGE-OR-LOSE
567 ;;; instead of this function. (The distinction only actually matters when
568 ;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case
569 ;;; you generally do want to signal an error instead of proceeding.)
570 (defun %find-package-or-lose
(package-designator)
571 (or (find-package package-designator
)
572 (error 'sb
!kernel
:simple-package-error
573 :package package-designator
574 :format-control
"The name ~S does not designate any package."
575 :format-arguments
(list package-designator
))))
577 ;;; ANSI specifies (in the section for FIND-PACKAGE) that the
578 ;;; consequences of most operations on deleted packages are
579 ;;; unspecified. We try to signal errors in such cases.
580 (defun find-undeleted-package-or-lose (package-designator)
581 (let ((maybe-result (%find-package-or-lose package-designator
)))
582 (if (package-name maybe-result
) ; if not deleted
584 (error 'sb
!kernel
:simple-package-error
585 :package maybe-result
586 :format-control
"The package ~S has been deleted."
587 :format-arguments
(list maybe-result
)))))
589 ;;;; various operations on names
591 ;;; Is NAME a legal function name?
592 (defun legal-fun-name-p (name)
595 (eq (car name
) 'setf
)
597 (symbolp (cadr name
))
598 (null (cddr name
)))))
600 ;;; Signal an error unless NAME is a legal function name.
601 (defun legal-fun-name-or-type-error (name)
602 (unless (legal-fun-name-p name
)
603 (error 'simple-type-error
605 :expected-type
'(or symbol list
)
606 :format-control
"invalid function name: ~S"
607 :format-arguments
(list name
))))
609 ;;; Given a function name, return the name for the BLOCK which
610 ;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
611 (declaim (ftype (function ((or symbol cons
)) symbol
) fun-name-block-name
))
612 (defun fun-name-block-name (fun-name)
613 (cond ((symbolp fun-name
)
615 ((and (consp fun-name
)
616 (= (length fun-name
) 2)
617 (eq (first fun-name
) 'setf
))
620 (error "not legal as a function name: ~S" fun-name
))))
622 (defun looks-like-name-of-special-var-p (x)
624 (let ((name (symbol-name x
)))
625 (and (> (length name
) 2) ; to exclude '* and '**
626 (char= #\
* (aref name
0))
627 (char= #\
* (aref name
(1- (length name
))))))))
629 ;;; Some symbols are defined by ANSI to be self-evaluating. Return
630 ;;; non-NIL for such symbols (and make the non-NIL value a traditional
631 ;;; message, for use in contexts where the user asks us to change such
633 (defun symbol-self-evaluating-p (symbol)
634 (declare (type symbol symbol
))
636 "Veritas aeterna. (can't change T)")
638 "Nihil ex nihil. (can't change NIL)")
640 "Keyword values can't be changed.")
644 ;;; This function is to be called just before a change which would
645 ;;; affect the symbol value. (We don't absolutely have to call this
646 ;;; function before such changes, since such changes are given as
647 ;;; undefined behavior. In particular, we don't if the runtime cost
648 ;;; would be annoying. But otherwise it's nice to do so.)
649 (defun about-to-modify-symbol-value (symbol)
650 (declare (type symbol symbol
))
651 (let ((reason (symbol-self-evaluating-p symbol
)))
654 ;; (Note: Just because a value is CONSTANTP is not a good enough
655 ;; reason to complain here, because we want DEFCONSTANT to be able
656 ;; to use this function, and it's legal to DEFCONSTANT a constant as
657 ;; long as the new value is EQL to the old value.)
661 ;;; If COLD-FSET occurs not at top level, just treat it as an ordinary
662 ;;; assignment instead of doing cold static linking. That way things like
663 ;;; (FLET ((FROB (X) ..))
664 ;;; (DEFUN FOO (X Y) (FROB X) ..)
665 ;;; (DEFUN BAR (Z) (AND (FROB X) ..)))
666 ;;; can still "work" for cold init: they don't do magical static
667 ;;; linking the way that true toplevel DEFUNs do, but at least they do
668 ;;; the linking eventually, so as long as #'FOO and #'BAR aren't
669 ;;; needed until "cold toplevel forms" have executed, it's OK.
670 (defmacro cold-fset
(name lambda
)
672 "~@<COLD-FSET ~S not cross-compiled at top level: demoting to ~
673 (SETF FDEFINITION)~:@>"
675 ;; We convert the LAMBDA expression to the corresponding NAMED-LAMBDA
676 ;; expression so that the compiler can use NAME in debug names etc.
677 (destructuring-bind (lambda-symbol &rest lambda-rest
) lambda
678 (assert (eql lambda-symbol
'lambda
)) ; else dunno how to do conversion
679 `(setf (fdefinition ',name
)
680 (named-lambda ,name
,@lambda-rest
))))
684 ;;;; "The macro ONCE-ONLY has been around for a long time on various
685 ;;;; systems [..] if you can understand how to write and when to use
686 ;;;; ONCE-ONLY, then you truly understand macro." -- Peter Norvig,
687 ;;;; _Paradigms of Artificial Intelligence Programming: Case Studies
688 ;;;; in Common Lisp_, p. 853
690 ;;; ONCE-ONLY is a utility useful in writing source transforms and
691 ;;; macros. It provides a concise way to wrap a LET around some code
692 ;;; to ensure that some forms are only evaluated once.
694 ;;; Create a LET* which evaluates each value expression, binding a
695 ;;; temporary variable to the result, and wrapping the LET* around the
696 ;;; result of the evaluation of BODY. Within the body, each VAR is
697 ;;; bound to the corresponding temporary variable.
698 (defmacro once-only
(specs &body body
)
699 (named-let frob
((specs specs
)
703 (let ((spec (first specs
)))
704 ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
705 (unless (proper-list-of-length-p spec
2)
706 (error "malformed ONCE-ONLY binding spec: ~S" spec
))
707 (let* ((name (first spec
))
708 (exp-temp (gensym (symbol-name name
))))
709 `(let ((,exp-temp
,(second spec
))
710 (,name
(gensym "ONCE-ONLY-")))
711 `(let ((,,name
,,exp-temp
))
712 ,,(frob (rest specs
) body
))))))))
714 ;;;; various error-checking utilities
716 ;;; This function can be used as the default value for keyword
717 ;;; arguments that must be always be supplied. Since it is known by
718 ;;; the compiler to never return, it will avoid any compile-time type
719 ;;; warnings that would result from a default value inconsistent with
720 ;;; the declared type. When this function is called, it signals an
721 ;;; error indicating that a required &KEY argument was not supplied.
722 ;;; This function is also useful for DEFSTRUCT slot defaults
723 ;;; corresponding to required arguments.
724 (declaim (ftype (function () nil
) missing-arg
))
725 (defun missing-arg ()
727 (/show0
"entering MISSING-ARG")
728 (error "A required &KEY or &OPTIONAL argument was not supplied."))
730 ;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
732 ;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT.
733 ;;; The CL:ASSERT restarts and whatnot expand into a significant
734 ;;; amount of code when you multiply them by 400, so replacing them
735 ;;; with this should reduce the size of the system by enough to be
736 ;;; worthwhile. ENFORCE-TYPE is much less common, but might still be
737 ;;; worthwhile, and since I don't really like CERROR stuff deep in the
738 ;;; guts of complex systems anyway, I replaced it too.)
739 (defmacro aver
(expr)
741 (%failed-aver
,(format nil
"~A" expr
))))
743 (defun %failed-aver
(expr-as-string)
744 (bug "~@<failed AVER: ~2I~_~S~:>" expr-as-string
))
746 ;;; We need a definition of BUG here for the host compiler to be able
747 ;;; to deal with BUGs in sbcl. This should never affect an end-user,
748 ;;; who will pick up the definition that signals a CONDITION of
749 ;;; condition-class BUG; however, this is not defined on the host
750 ;;; lisp, but for the target. SBCL developers sometimes trigger BUGs
751 ;;; in their efforts, and it is useful to get the details of the BUG
752 ;;; rather than an undefined function error. - CSR, 2002-04-12
754 (defun bug (format-control &rest format-arguments
)
756 :format-control
"~@< ~? ~:@_~?~:>"
757 :format-arguments
`(,format-control
759 "~@<If you see this and are an SBCL ~
760 developer, then it is probable that you have made a change to the ~
761 system that has broken the ability for SBCL to compile, usually by ~
762 removing an assumed invariant of the system, but sometimes by making ~
763 an averrance that is violated (check your code!). If you are a user, ~
764 please submit a bug report to the developers' mailing list, details of ~
765 which can be found at <http://sbcl.sourceforge.net/>.~:@>"
768 (defmacro enforce-type
(value type
)
769 (once-only ((value value
))
770 `(unless (typep ,value
',type
)
771 (%failed-enforce-type
,value
',type
))))
773 (defun %failed-enforce-type
(value type
)
774 (error 'simple-type-error
; maybe should be TYPE-BUG, subclass of BUG?
777 :format-string
"~@<~S ~_is not a ~_~S~:>"
778 :format-arguments
(list value type
)))
780 ;;; Return a list of N gensyms. (This is a common suboperation in
781 ;;; macros and other code-manipulating code.)
782 (declaim (ftype (function (index) list
) make-gensym-list
))
783 (defun make-gensym-list (n)
784 (loop repeat n collect
(gensym)))
786 ;;; Return a function like FUN, but expecting its (two) arguments in
787 ;;; the opposite order that FUN does.
788 (declaim (inline swapped-args-fun
))
789 (defun swapped-args-fun (fun)
790 (declare (type function fun
))
794 ;;; Return the numeric value of a type bound, i.e. an interval bound
795 ;;; more or less in the format of bounds in ANSI's type specifiers,
796 ;;; where a bare numeric value is a closed bound and a list of a
797 ;;; single numeric value is an open bound.
799 ;;; The "more or less" bit is that the no-bound-at-all case is
800 ;;; represented by NIL (not by * as in ANSI type specifiers); and in
801 ;;; this case we return NIL.
802 (defun type-bound-number (x)
804 (destructuring-bind (result) x result
)
807 ;;; some commonly-occuring CONSTANTLY forms
808 (macrolet ((def-constantly-fun (name constant-expr
)
809 `(setf (symbol-function ',name
)
810 (constantly ,constant-expr
))))
811 (def-constantly-fun constantly-t t
)
812 (def-constantly-fun constantly-nil nil
)
813 (def-constantly-fun constantly-0
0))
815 ;;; If X is an atom, see whether it is present in *FEATURES*. Also
816 ;;; handle arbitrary combinations of atoms using NOT, AND, OR.
822 (error "too many subexpressions in feature expression: ~S" x
)
823 (not (featurep (cadr x
)))))
824 ((:and and
) (every #'featurep
(cdr x
)))
825 ((:or or
) (some #'featurep
(cdr x
)))
827 (error "unknown operator in feature expression: ~S." x
)))
828 (not (null (memq x
*features
*)))))
830 ;;; Given a list of keyword substitutions `(,OLD ,NEW), and a
831 ;;; &KEY-argument-list-style list of alternating keywords and
832 ;;; arbitrary values, return a new &KEY-argument-list-style list with
833 ;;; all substitutions applied to it.
835 ;;; Note: If efficiency mattered, we could do less consing. (But if
836 ;;; efficiency mattered, why would we be using &KEY arguments at
837 ;;; all, much less renaming &KEY arguments?)
839 ;;; KLUDGE: It would probably be good to get rid of this. -- WHN 19991201
840 (defun rename-key-args (rename-list key-args
)
841 (declare (type list rename-list key-args
))
842 ;; Walk through RENAME-LIST modifying RESULT as per each element in
844 (do ((result (copy-list key-args
))) ; may be modified below
845 ((null rename-list
) result
)
846 (destructuring-bind (old new
) (pop rename-list
)
847 ;; ANSI says &KEY arg names aren't necessarily KEYWORDs.
848 (declare (type symbol old new
))
849 ;; Walk through RESULT renaming any OLD key argument to NEW.
850 (do ((in-result result
(cddr in-result
)))
852 (declare (type list in-result
))
853 (when (eq (car in-result
) old
)
854 (setf (car in-result
) new
))))))
856 ;;; ANSI Common Lisp's READ-SEQUENCE function, unlike most of the
857 ;;; other ANSI input functions, is defined to communicate end of file
858 ;;; status with its return value, not by signalling. That is not the
859 ;;; behavior that we usually want. This function is a wrapper which
860 ;;; restores the behavior that we usually want, causing READ-SEQUENCE
861 ;;; to communicate end-of-file status by signalling.
862 (defun read-sequence-or-die (sequence stream
&key start end
)
863 ;; implementation using READ-SEQUENCE
864 #-no-ansi-read-sequence
865 (let ((read-end (read-sequence sequence
869 (unless (= read-end end
)
870 (error 'end-of-file
:stream stream
))
872 ;; workaround for broken READ-SEQUENCE
873 #+no-ansi-read-sequence
875 (aver (<= start end
))
876 (let ((etype (stream-element-type stream
)))
877 (cond ((equal etype
'(unsigned-byte 8))
878 (do ((i start
(1+ i
)))
881 (setf (aref sequence i
)
882 (read-byte stream
))))
883 (t (error "unsupported element type ~S" etype
))))))
885 ;;;; utilities for two-VALUES predicates
887 ;;; sort of like ANY and EVERY, except:
888 ;;; * We handle two-VALUES predicate functions, as SUBTYPEP does.
889 ;;; (And if the result is uncertain, then we return (VALUES NIL NIL),
890 ;;; as SUBTYPEP does.)
891 ;;; * THING is just an atom, and we apply OP (an arity-2 function)
892 ;;; successively to THING and each element of LIST.
893 (defun any/type
(op thing list
)
894 (declare (type function op
))
896 (dolist (i list
(values nil certain?
))
897 (multiple-value-bind (sub-value sub-certain?
) (funcall op thing i
)
899 (when sub-value
(return (values t t
)))
900 (setf certain? nil
))))))
901 (defun every/type
(op thing list
)
902 (declare (type function op
))
904 (dolist (i list
(if certain?
(values t t
) (values nil nil
)))
905 (multiple-value-bind (sub-value sub-certain?
) (funcall op thing i
)
907 (unless sub-value
(return (values nil t
)))
908 (setf certain? nil
))))))
912 ;;; These functions are called by the expansion of the DEFPRINTER
913 ;;; macro to do the actual printing.
914 (declaim (ftype (function (symbol t stream
) (values))
915 defprinter-prin1 defprinter-princ
))
916 (defun defprinter-prin1 (name value stream
)
917 (defprinter-prinx #'prin1 name value stream
))
918 (defun defprinter-princ (name value stream
)
919 (defprinter-prinx #'princ name value stream
))
920 (defun defprinter-prinx (prinx name value stream
)
921 (declare (type function prinx
))
923 (pprint-newline :linear stream
))
924 (format stream
":~A " name
)
925 (funcall prinx value stream
)
927 (defun defprinter-print-space (stream)
928 (write-char #\space stream
))
930 ;;; Define some kind of reasonable PRINT-OBJECT method for a
931 ;;; STRUCTURE-OBJECT class.
933 ;;; NAME is the name of the structure class, and CONC-NAME is the same
936 ;;; The SLOT-DESCS describe how each slot should be printed. Each
937 ;;; SLOT-DESC can be a slot name, indicating that the slot should
938 ;;; simply be printed. A SLOT-DESC may also be a list of a slot name
939 ;;; and other stuff. The other stuff is composed of keywords followed
940 ;;; by expressions. The expressions are evaluated with the variable
941 ;;; which is the slot name bound to the value of the slot. These
942 ;;; keywords are defined:
944 ;;; :PRIN1 Print the value of the expression instead of the slot value.
945 ;;; :PRINC Like :PRIN1, only PRINC the value
946 ;;; :TEST Only print something if the test is true.
948 ;;; If no printing thing is specified then the slot value is printed
951 ;;; The structure being printed is bound to STRUCTURE and the stream
952 ;;; is bound to STREAM.
953 (defmacro defprinter
((name
955 (conc-name (concatenate 'simple-string
962 (reversed-prints nil
)
963 (stream (gensym "STREAM")))
964 (flet ((sref (slot-name)
965 `(,(symbolicate conc-name slot-name
) structure
)))
966 (dolist (slot-desc slot-descs
)
968 (setf maybe-print-space nil
970 (setf maybe-print-space
`(defprinter-print-space ,stream
)))
971 (cond ((atom slot-desc
)
972 (push maybe-print-space reversed-prints
)
973 (push `(defprinter-prin1 ',slot-desc
,(sref slot-desc
) ,stream
)
976 (let ((sname (first slot-desc
))
979 (do ((option (rest slot-desc
) (cddr option
)))
981 (push `(let ((,sname
,(sref sname
)))
986 ',sname
,sname
,stream
)))))
990 (stuff `(defprinter-prin1
991 ',sname
,(second option
) ,stream
)))
993 (stuff `(defprinter-princ
994 ',sname
,(second option
) ,stream
)))
995 (:test
(setq test
(second option
)))
997 (error "bad option: ~S" (first option
)))))))))))
998 `(def!method print-object
((structure ,name
) ,stream
)
999 (pprint-logical-block (,stream nil
)
1000 (print-unreadable-object (structure
1003 :identity
,identity
)
1004 ,@(nreverse reversed-prints
))))))
1008 ;;; Given a pathname, return a corresponding physical pathname.
1009 (defun physicalize-pathname (possibly-logical-pathname)
1010 (if (typep possibly-logical-pathname
'logical-pathname
)
1011 (translate-logical-pathname possibly-logical-pathname
)
1012 possibly-logical-pathname
))
1014 (defun deprecation-warning (bad-name &optional good-name
)
1015 (warn "using deprecated ~S~@[, should use ~S instead~]"