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 ;;; Is X a list containing a cycle?
109 (defun cyclic-list-p (x)
111 (labels ((safe-cddr (x) (if (listp (cdr x
)) (cddr x
))))
112 (do ((y x
(safe-cddr y
))
115 ((not (and (consp z
) (consp y
))) nil
)
116 (when (and started-p
(eq y z
))
119 ;;; Is X a (possibly-improper) list of at least N elements?
120 (declaim (ftype (function (t index
)) list-of-length-at-least-p
))
121 (defun list-of-length-at-least-p (x n
)
122 (or (zerop n
) ; since anything can be considered an improper list of length 0
124 (list-of-length-at-least-p (cdr x
) (1- n
)))))
126 ;;; Is X is a positive prime integer?
127 (defun positive-primep (x)
128 ;; This happens to be called only from one place in sbcl-0.7.0, and
129 ;; only for fixnums, we can limit it to fixnums for efficiency. (And
130 ;; if we didn't limit it to fixnums, we should use a cleverer
131 ;; algorithm, since this one scales pretty badly for huge X.)
134 (and (>= x
2) (/= x
4))
136 (not (zerop (rem x
3)))
139 (inc 2 (logxor inc
6)) ;; 2,4,2,4...
141 ((or (= r
0) (> d q
)) (/= r
0))
142 (declare (fixnum inc
))
143 (multiple-value-setq (q r
) (truncate x d
))))))
145 ;;; Could this object contain other objects? (This is important to
146 ;;; the implementation of things like *PRINT-CIRCLE* and the dumper.)
147 (defun compound-object-p (x)
150 (typep x
'(array t
*))))
152 ;;;; the COLLECT macro
154 ;;;; comment from CMU CL: "the ultimate collection macro..."
156 ;;; helper functions for COLLECT, which become the expanders of the
157 ;;; MACROLET definitions created by COLLECT
159 ;;; COLLECT-NORMAL-EXPANDER handles normal collection macros.
161 ;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
162 ;;; is the pointer to the current tail of the list, or NIL if the list
164 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
165 (defun collect-normal-expander (n-value fun forms
)
167 ,@(mapcar (lambda (form) `(setq ,n-value
(,fun
,form
,n-value
))) forms
)
169 (defun collect-list-expander (n-value n-tail forms
)
170 (let ((n-res (gensym)))
172 ,@(mapcar (lambda (form)
173 `(let ((,n-res
(cons ,form nil
)))
175 (setf (cdr ,n-tail
) ,n-res
)
176 (setq ,n-tail
,n-res
))
178 (setq ,n-tail
,n-res
,n-value
,n-res
)))))
182 ;;; Collect some values somehow. Each of the collections specifies a
183 ;;; bunch of things which collected during the evaluation of the body
184 ;;; of the form. The name of the collection is used to define a local
185 ;;; macro, a la MACROLET. Within the body, this macro will evaluate
186 ;;; each of its arguments and collect the result, returning the
187 ;;; current value after the collection is done. The body is evaluated
188 ;;; as a PROGN; to get the final values when you are done, just call
189 ;;; the collection macro with no arguments.
191 ;;; INITIAL-VALUE is the value that the collection starts out with,
192 ;;; which defaults to NIL. FUNCTION is the function which does the
193 ;;; collection. It is a function which will accept two arguments: the
194 ;;; value to be collected and the current collection. The result of
195 ;;; the function is made the new value for the collection. As a
196 ;;; totally magical special-case, FUNCTION may be COLLECT, which tells
197 ;;; us to build a list in forward order; this is the default. If an
198 ;;; INITIAL-VALUE is supplied for COLLECT, the stuff will be RPLACD'd
199 ;;; onto the end. Note that FUNCTION may be anything that can appear
200 ;;; in the functional position, including macros and lambdas.
201 (defmacro collect
(collections &body body
)
204 (dolist (spec collections
)
205 (unless (proper-list-of-length-p spec
1 3)
206 (error "malformed collection specifier: ~S" spec
))
207 (let* ((name (first spec
))
208 (default (second spec
))
209 (kind (or (third spec
) 'collect
))
210 (n-value (gensym (concatenate 'string
213 (push `(,n-value
,default
) binds
)
214 (if (eq kind
'collect
)
215 (let ((n-tail (gensym (concatenate 'string
219 (push `(,n-tail
(last ,n-value
)) binds
)
221 (push `(,name
(&rest args
)
222 (collect-list-expander ',n-value
',n-tail args
))
224 (push `(,name
(&rest args
)
225 (collect-normal-expander ',n-value
',kind args
))
227 `(macrolet ,macros
(let* ,(nreverse binds
) ,@body
))))
229 ;;;; some old-fashioned functions. (They're not just for old-fashioned
230 ;;;; code, they're also used as optimized forms of the corresponding
231 ;;;; general functions when the compiler can prove that they're
234 ;;; like (MEMBER ITEM LIST :TEST #'EQ)
235 (defun memq (item list
)
237 "Return tail of LIST beginning with first element EQ to ITEM."
238 ;; KLUDGE: These could be and probably should be defined as
239 ;; (MEMBER ITEM LIST :TEST #'EQ)),
240 ;; but when I try to cross-compile that, I get an error from
241 ;; LTN-ANALYZE-KNOWN-CALL, "Recursive known function definition". The
242 ;; comments for that error say it "is probably a botched interpreter stub".
243 ;; Rather than try to figure that out, I just rewrote this function from
244 ;; scratch. -- WHN 19990512
245 (do ((i list
(cdr i
)))
247 (when (eq (car i
) item
)
250 ;;; like (ASSOC ITEM ALIST :TEST #'EQ):
251 ;;; Return the first pair of ALIST where ITEM is EQ to the key of
253 (defun assq (item alist
)
254 ;; KLUDGE: CMU CL defined this with
255 ;; (DECLARE (INLINE ASSOC))
256 ;; (ASSOC ITEM ALIST :TEST #'EQ))
257 ;; which is pretty, but which would have required adding awkward
258 ;; build order constraints on SBCL (or figuring out some way to make
259 ;; inline definitions installable at build-the-cross-compiler time,
260 ;; which was too ambitious for now). Rather than mess with that, we
261 ;; just define ASSQ explicitly in terms of more primitive
264 (when (eq (car pair
) item
)
267 ;;; like (DELETE .. :TEST #'EQ):
268 ;;; Delete all LIST entries EQ to ITEM (destructively modifying
269 ;;; LIST), and return the modified LIST.
270 (defun delq (item list
)
272 (do ((x list
(cdr x
))
275 (cond ((eq item
(car x
))
278 (rplacd splice
(cdr x
))))
279 (t (setq splice x
)))))) ; Move splice along to include element.
282 ;;; like (POSITION .. :TEST #'EQ):
283 ;;; Return the position of the first element EQ to ITEM.
284 (defun posq (item list
)
285 (do ((i list
(cdr i
))
288 (when (eq (car i
) item
)
291 (declaim (inline neq
))
295 ;;; not really an old-fashioned function, but what the calling
296 ;;; convention should've been: like NTH, but with the same argument
297 ;;; order as in all the other dereferencing functions, with the
298 ;;; collection first and the index second
299 (declaim (inline nth-but-with-sane-arg-order
))
300 (declaim (ftype (function (list index
) t
) nth-but-with-sane-arg-order
))
301 (defun nth-but-with-sane-arg-order (list index
)
304 ;;;; miscellaneous iteration extensions
306 ;;; "the ultimate iteration macro"
308 ;;; note for Schemers: This seems to be identical to Scheme's "named LET".
309 (defmacro named-let
(name binds
&body body
)
312 (unless (proper-list-of-length-p x
2)
313 (error "malformed NAMED-LET variable spec: ~S" x
)))
314 `(labels ((,name
,(mapcar #'first binds
) ,@body
))
315 (,name
,@(mapcar #'second binds
))))
317 ;;; just like DOLIST, but with one-dimensional arrays
318 (defmacro dovector
((elt vector
&optional result
) &rest forms
)
319 (let ((index (gensym))
322 `(let ((,vec
,vector
))
323 (declare (type vector
,vec
))
324 (do ((,index
0 (1+ ,index
))
325 (,length
(length ,vec
)))
326 ((>= ,index
,length
) ,result
)
327 (let ((,elt
(aref ,vec
,index
)))
330 ;;; Iterate over the entries in a HASH-TABLE.
331 (defmacro dohash
((key-var value-var table
&optional result
) &body body
)
332 (multiple-value-bind (forms decls
) (parse-body body nil
)
335 `(with-hash-table-iterator (,gen
,table
)
337 (multiple-value-bind (,n-more
,key-var
,value-var
) (,gen
)
339 (unless ,n-more
(return ,result
))
342 ;;;; hash cache utility
344 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
345 (defvar *profile-hash-cache
* nil
))
347 ;;; a flag for whether it's too early in cold init to use caches so
348 ;;; that we have a better chance of recovering so that we have a
349 ;;; better chance of getting the system running so that we have a
350 ;;; better chance of diagnosing the problem which caused us to use the
353 (defvar *hash-caches-initialized-p
*)
355 ;;; Define a hash cache that associates some number of argument values
356 ;;; with a result value. The TEST-FUNCTION paired with each ARG-NAME
357 ;;; is used to compare the value for that arg in a cache entry with a
358 ;;; supplied arg. The TEST-FUNCTION must not error when passed NIL as
359 ;;; its first arg, but need not return any particular value.
360 ;;; TEST-FUNCTION may be any thing that can be placed in CAR position.
362 ;;; NAME is used to define these functions:
363 ;;; <name>-CACHE-LOOKUP Arg*
364 ;;; See whether there is an entry for the specified ARGs in the
365 ;;; cache. If not present, the :DEFAULT keyword (default NIL)
366 ;;; determines the result(s).
367 ;;; <name>-CACHE-ENTER Arg* Value*
368 ;;; Encache the association of the specified args with VALUE.
369 ;;; <name>-CACHE-CLEAR
370 ;;; Reinitialize the cache, invalidating all entries and allowing
371 ;;; the arguments and result values to be GC'd.
373 ;;; These other keywords are defined:
375 ;;; The size of the cache as a power of 2.
376 ;;; :HASH-FUNCTION function
377 ;;; Some thing that can be placed in CAR position which will compute
378 ;;; a value between 0 and (1- (expt 2 <hash-bits>)).
380 ;;; the number of return values cached for each function call
381 ;;; :INIT-WRAPPER <name>
382 ;;; The code for initializing the cache is wrapped in a form with
383 ;;; the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS
384 ;;; in type system definitions so that caches will be created
385 ;;; before top level forms run.)
386 (defmacro define-hash-cache
(name args
&key hash-function hash-bits default
387 (init-wrapper 'progn
)
389 (let* ((var-name (symbolicate "*" name
"-CACHE-VECTOR*"))
390 (nargs (length args
))
391 (entry-size (+ nargs values
))
392 (size (ash 1 hash-bits
))
393 (total-size (* entry-size size
))
394 (default-values (if (and (consp default
) (eq (car default
) 'values
))
400 (unless (= (length default-values
) values
)
401 (error "The number of default values ~S differs from :VALUES ~W."
413 (values-indices `(+ ,n-index
,(+ nargs i
)))
414 (values-names (gensym)))
417 (unless (= (length arg
) 2)
418 (error "bad argument spec: ~S" arg
))
419 (let ((arg-name (first arg
))
422 (tests `(,test
(svref ,n-cache
(+ ,n-index
,n
)) ,arg-name
))
423 (sets `(setf (svref ,n-cache
(+ ,n-index
,n
)) ,arg-name
)))
426 (when *profile-hash-cache
*
427 (let ((n-probe (symbolicate "*" name
"-CACHE-PROBES*"))
428 (n-miss (symbolicate "*" name
"-CACHE-MISSES*")))
429 (inits `(setq ,n-probe
0))
430 (inits `(setq ,n-miss
0))
431 (forms `(defvar ,n-probe
))
432 (forms `(defvar ,n-miss
))
433 (forms `(declaim (fixnum ,n-miss
,n-probe
)))))
435 (let ((fun-name (symbolicate name
"-CACHE-LOOKUP")))
438 `(defun ,fun-name
,(arg-vars)
439 ,@(when *profile-hash-cache
*
440 `((incf ,(symbolicate "*" name
"-CACHE-PROBES*"))))
441 (let ((,n-index
(* (,hash-function
,@(arg-vars)) ,entry-size
))
442 (,n-cache
,var-name
))
443 (declare (type fixnum
,n-index
))
444 (cond ((and ,@(tests))
445 (values ,@(mapcar (lambda (x) `(svref ,n-cache
,x
))
448 ,@(when *profile-hash-cache
*
449 `((incf ,(symbolicate "*" name
"-CACHE-MISSES*"))))
452 (let ((fun-name (symbolicate name
"-CACHE-ENTER")))
455 `(defun ,fun-name
(,@(arg-vars) ,@(values-names))
456 (let ((,n-index
(* (,hash-function
,@(arg-vars)) ,entry-size
))
457 (,n-cache
,var-name
))
458 (declare (type fixnum
,n-index
))
460 ,@(mapcar (lambda (i val
)
461 `(setf (svref ,n-cache
,i
) ,val
))
466 (let ((fun-name (symbolicate name
"-CACHE-CLEAR")))
469 (do ((,n-index
,(- total-size entry-size
) (- ,n-index
,entry-size
))
470 (,n-cache
,var-name
))
472 (declare (type fixnum
,n-index
))
473 ,@(collect ((arg-sets))
475 (arg-sets `(setf (svref ,n-cache
(+ ,n-index
,i
)) nil
)))
477 ,@(mapcar (lambda (i val
)
478 `(setf (svref ,n-cache
,i
) ,val
))
482 (forms `(,fun-name
)))
484 (inits `(unless (boundp ',var-name
)
485 (setq ,var-name
(make-array ,total-size
))))
486 #!+sb-show
(inits `(setq *hash-caches-initialized-p
* t
))
490 (declaim (type (simple-vector ,total-size
) ,var-name
))
491 #!-sb-fluid
(declaim (inline ,@(inlines)))
492 (,init-wrapper
,@(inits))
496 ;;; some syntactic sugar for defining a function whose values are
497 ;;; cached by DEFINE-HASH-CACHE
498 (defmacro defun-cached
((name &rest options
&key
(values 1) default
500 args
&body body-decls-doc
)
501 (let ((default-values (if (and (consp default
) (eq (car default
) 'values
))
504 (arg-names (mapcar #'car args
)))
505 (collect ((values-names))
507 (values-names (gensym)))
508 (multiple-value-bind (body decls doc
) (parse-body body-decls-doc
)
510 (define-hash-cache ,name
,args
,@options
)
511 (defun ,name
,arg-names
515 ((not (boundp '*hash-caches-initialized-p
*))
516 ;; This shouldn't happen, but it did happen to me
517 ;; when revising the type system, and it's a lot
518 ;; easier to figure out what what's going on with
519 ;; that kind of problem if the system can be kept
520 ;; alive until cold boot is complete. The recovery
521 ;; mechanism should definitely be conditional on
522 ;; some debugging feature (e.g. SB-SHOW) because
523 ;; it's big, duplicating all the BODY code. -- WHN
524 (/show0
,name
" too early in cold init, uncached")
525 (/show0
,(first arg-names
) "=..")
526 (/hexstr
,(first arg-names
))
529 (multiple-value-bind ,(values-names)
530 (,(symbolicate name
"-CACHE-LOOKUP") ,@arg-names
)
531 (if (and ,@(mapcar (lambda (val def
)
533 (values-names) default-values
))
534 (multiple-value-bind ,(values-names)
536 (,(symbolicate name
"-CACHE-ENTER") ,@arg-names
538 (values ,@(values-names)))
539 (values ,@(values-names))))))))))))
541 (defmacro define-cached-synonym
542 (name &optional
(original (symbolicate "%" name
)))
543 (let ((cached-name (symbolicate "%%" name
"-cached")))
545 (defun-cached (,cached-name
:hash-bits
8
546 :hash-function
(lambda (x)
547 (logand (sxhash x
) #xff
)))
549 (apply #',original args
))
550 (defun ,name
(&rest args
)
551 (,cached-name args
)))))
553 ;;; FIXME: maybe not the best place
555 ;;; FIXME: think of a better name -- not only does this not have the
556 ;;; CAR recursion of EQUAL, it also doesn't have the special treatment
557 ;;; of pathnames, bit-vectors and strings.
559 ;;; KLUDGE: This means that we will no longer cache specifiers of the
560 ;;; form '(INTEGER (0) 4). This is probably not a disaster.
562 ;;; A helper function for the type system, which is the main user of
563 ;;; these caches: we must be more conservative than EQUAL for some of
564 ;;; our equality tests, because MEMBER and friends refer to EQLity.
566 (defun equal-but-no-car-recursion (x y
)
571 (eql (car x
) (car y
))
572 (equal-but-no-car-recursion (cdr x
) (cdr y
))))
577 ;;; Note: Almost always you want to use FIND-UNDELETED-PACKAGE-OR-LOSE
578 ;;; instead of this function. (The distinction only actually matters when
579 ;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case
580 ;;; you generally do want to signal an error instead of proceeding.)
581 (defun %find-package-or-lose
(package-designator)
582 (or (find-package package-designator
)
583 (error 'sb
!kernel
:simple-package-error
584 :package package-designator
585 :format-control
"The name ~S does not designate any package."
586 :format-arguments
(list package-designator
))))
588 ;;; ANSI specifies (in the section for FIND-PACKAGE) that the
589 ;;; consequences of most operations on deleted packages are
590 ;;; unspecified. We try to signal errors in such cases.
591 (defun find-undeleted-package-or-lose (package-designator)
592 (let ((maybe-result (%find-package-or-lose package-designator
)))
593 (if (package-name maybe-result
) ; if not deleted
595 (error 'sb
!kernel
:simple-package-error
596 :package maybe-result
597 :format-control
"The package ~S has been deleted."
598 :format-arguments
(list maybe-result
)))))
600 ;;;; various operations on names
602 ;;; Is NAME a legal function name?
603 (defun legal-fun-name-p (name)
604 (values (valid-function-name-p name
)))
606 ;;; Signal an error unless NAME is a legal function name.
607 (defun legal-fun-name-or-type-error (name)
608 (unless (legal-fun-name-p name
)
609 (error 'simple-type-error
611 :expected-type
'(or symbol list
)
612 :format-control
"invalid function name: ~S"
613 :format-arguments
(list name
))))
615 ;;; Given a function name, return the symbol embedded in it.
617 ;;; The ordinary use for this operator (and the motivation for the
618 ;;; name of this operator) is to convert from a function name to the
619 ;;; name of the BLOCK which encloses its body.
621 ;;; Occasionally the operator is useful elsewhere, where the operator
622 ;;; name is less mnemonic. (Maybe it should be changed?)
623 (declaim (ftype (function ((or symbol cons
)) symbol
) fun-name-block-name
))
624 (defun fun-name-block-name (fun-name)
625 (cond ((symbolp fun-name
)
628 (multiple-value-bind (legalp block-name
)
629 (valid-function-name-p fun-name
)
632 (error "not legal as a function name: ~S" fun-name
))))
634 (error "not legal as a function name: ~S" fun-name
))))
636 (defun looks-like-name-of-special-var-p (x)
638 (let ((name (symbol-name x
)))
639 (and (> (length name
) 2) ; to exclude '* and '**
640 (char= #\
* (aref name
0))
641 (char= #\
* (aref name
(1- (length name
))))))))
643 ;;; Some symbols are defined by ANSI to be self-evaluating. Return
644 ;;; non-NIL for such symbols (and make the non-NIL value a traditional
645 ;;; message, for use in contexts where the user asks us to change such
647 (defun symbol-self-evaluating-p (symbol)
648 (declare (type symbol symbol
))
650 "Veritas aeterna. (can't change T)")
652 "Nihil ex nihil. (can't change NIL)")
654 "Keyword values can't be changed.")
658 ;;; This function is to be called just before a change which would
659 ;;; affect the symbol value. (We don't absolutely have to call this
660 ;;; function before such changes, since such changes are given as
661 ;;; undefined behavior. In particular, we don't if the runtime cost
662 ;;; would be annoying. But otherwise it's nice to do so.)
663 (defun about-to-modify-symbol-value (symbol)
664 (declare (type symbol symbol
))
665 (let ((reason (symbol-self-evaluating-p symbol
)))
668 ;; (Note: Just because a value is CONSTANTP is not a good enough
669 ;; reason to complain here, because we want DEFCONSTANT to be able
670 ;; to use this function, and it's legal to DEFCONSTANT a constant as
671 ;; long as the new value is EQL to the old value.)
675 ;;; If COLD-FSET occurs not at top level, just treat it as an ordinary
676 ;;; assignment instead of doing cold static linking. That way things like
677 ;;; (FLET ((FROB (X) ..))
678 ;;; (DEFUN FOO (X Y) (FROB X) ..)
679 ;;; (DEFUN BAR (Z) (AND (FROB X) ..)))
680 ;;; can still "work" for cold init: they don't do magical static
681 ;;; linking the way that true toplevel DEFUNs do, but at least they do
682 ;;; the linking eventually, so as long as #'FOO and #'BAR aren't
683 ;;; needed until "cold toplevel forms" have executed, it's OK.
684 (defmacro cold-fset
(name lambda
)
686 "~@<COLD-FSET ~S not cross-compiled at top level: demoting to ~
687 (SETF FDEFINITION)~:@>"
689 ;; We convert the LAMBDA expression to the corresponding NAMED-LAMBDA
690 ;; expression so that the compiler can use NAME in debug names etc.
691 (destructuring-bind (lambda-symbol &rest lambda-rest
) lambda
692 (assert (eql lambda-symbol
'lambda
)) ; else dunno how to do conversion
693 `(setf (fdefinition ',name
)
694 (named-lambda ,name
,@lambda-rest
))))
698 ;;;; "The macro ONCE-ONLY has been around for a long time on various
699 ;;;; systems [..] if you can understand how to write and when to use
700 ;;;; ONCE-ONLY, then you truly understand macro." -- Peter Norvig,
701 ;;;; _Paradigms of Artificial Intelligence Programming: Case Studies
702 ;;;; in Common Lisp_, p. 853
704 ;;; ONCE-ONLY is a utility useful in writing source transforms and
705 ;;; macros. It provides a concise way to wrap a LET around some code
706 ;;; to ensure that some forms are only evaluated once.
708 ;;; Create a LET* which evaluates each value expression, binding a
709 ;;; temporary variable to the result, and wrapping the LET* around the
710 ;;; result of the evaluation of BODY. Within the body, each VAR is
711 ;;; bound to the corresponding temporary variable.
712 (defmacro once-only
(specs &body body
)
713 (named-let frob
((specs specs
)
717 (let ((spec (first specs
)))
718 ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
719 (unless (proper-list-of-length-p spec
2)
720 (error "malformed ONCE-ONLY binding spec: ~S" spec
))
721 (let* ((name (first spec
))
722 (exp-temp (gensym (symbol-name name
))))
723 `(let ((,exp-temp
,(second spec
))
724 (,name
(gensym "ONCE-ONLY-")))
725 `(let ((,,name
,,exp-temp
))
726 ,,(frob (rest specs
) body
))))))))
728 ;;;; various error-checking utilities
730 ;;; This function can be used as the default value for keyword
731 ;;; arguments that must be always be supplied. Since it is known by
732 ;;; the compiler to never return, it will avoid any compile-time type
733 ;;; warnings that would result from a default value inconsistent with
734 ;;; the declared type. When this function is called, it signals an
735 ;;; error indicating that a required &KEY argument was not supplied.
736 ;;; This function is also useful for DEFSTRUCT slot defaults
737 ;;; corresponding to required arguments.
738 (declaim (ftype (function () nil
) missing-arg
))
739 (defun missing-arg ()
741 (/show0
"entering MISSING-ARG")
742 (error "A required &KEY or &OPTIONAL argument was not supplied."))
744 ;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
746 ;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT.
747 ;;; The CL:ASSERT restarts and whatnot expand into a significant
748 ;;; amount of code when you multiply them by 400, so replacing them
749 ;;; with this should reduce the size of the system by enough to be
750 ;;; worthwhile. ENFORCE-TYPE is much less common, but might still be
751 ;;; worthwhile, and since I don't really like CERROR stuff deep in the
752 ;;; guts of complex systems anyway, I replaced it too.)
753 (defmacro aver
(expr)
755 (%failed-aver
,(format nil
"~A" expr
))))
757 (defun %failed-aver
(expr-as-string)
758 (bug "~@<failed AVER: ~2I~_~S~:>" expr-as-string
))
760 ;;; We need a definition of BUG here for the host compiler to be able
761 ;;; to deal with BUGs in sbcl. This should never affect an end-user,
762 ;;; who will pick up the definition that signals a CONDITION of
763 ;;; condition-class BUG; however, this is not defined on the host
764 ;;; lisp, but for the target. SBCL developers sometimes trigger BUGs
765 ;;; in their efforts, and it is useful to get the details of the BUG
766 ;;; rather than an undefined function error. - CSR, 2002-04-12
768 (defun bug (format-control &rest format-arguments
)
770 :format-control
"~@< ~? ~:@_~?~:>"
771 :format-arguments
`(,format-control
773 "~@<If you see this and are an SBCL ~
774 developer, then it is probable that you have made a change to the ~
775 system that has broken the ability for SBCL to compile, usually by ~
776 removing an assumed invariant of the system, but sometimes by making ~
777 an averrance that is violated (check your code!). If you are a user, ~
778 please submit a bug report to the developers' mailing list, details of ~
779 which can be found at <http://sbcl.sourceforge.net/>.~:@>"
782 (defmacro enforce-type
(value type
)
783 (once-only ((value value
))
784 `(unless (typep ,value
',type
)
785 (%failed-enforce-type
,value
',type
))))
787 (defun %failed-enforce-type
(value type
)
788 (error 'simple-type-error
; maybe should be TYPE-BUG, subclass of BUG?
791 :format-string
"~@<~S ~_is not a ~_~S~:>"
792 :format-arguments
(list value type
)))
794 ;;; Return a function like FUN, but expecting its (two) arguments in
795 ;;; the opposite order that FUN does.
796 (declaim (inline swapped-args-fun
))
797 (defun swapped-args-fun (fun)
798 (declare (type function fun
))
802 ;;; Return the numeric value of a type bound, i.e. an interval bound
803 ;;; more or less in the format of bounds in ANSI's type specifiers,
804 ;;; where a bare numeric value is a closed bound and a list of a
805 ;;; single numeric value is an open bound.
807 ;;; The "more or less" bit is that the no-bound-at-all case is
808 ;;; represented by NIL (not by * as in ANSI type specifiers); and in
809 ;;; this case we return NIL.
810 (defun type-bound-number (x)
812 (destructuring-bind (result) x result
)
815 ;;; some commonly-occuring CONSTANTLY forms
816 (macrolet ((def-constantly-fun (name constant-expr
)
817 `(setf (symbol-function ',name
)
818 (constantly ,constant-expr
))))
819 (def-constantly-fun constantly-t t
)
820 (def-constantly-fun constantly-nil nil
)
821 (def-constantly-fun constantly-0
0))
823 ;;; If X is an atom, see whether it is present in *FEATURES*. Also
824 ;;; handle arbitrary combinations of atoms using NOT, AND, OR.
830 (error "too many subexpressions in feature expression: ~S" x
)
831 (not (featurep (cadr x
)))))
832 ((:and and
) (every #'featurep
(cdr x
)))
833 ((:or or
) (some #'featurep
(cdr x
)))
835 (error "unknown operator in feature expression: ~S." x
)))
836 (not (null (memq x
*features
*)))))
838 ;;; Given a list of keyword substitutions `(,OLD ,NEW), and a
839 ;;; &KEY-argument-list-style list of alternating keywords and
840 ;;; arbitrary values, return a new &KEY-argument-list-style list with
841 ;;; all substitutions applied to it.
843 ;;; Note: If efficiency mattered, we could do less consing. (But if
844 ;;; efficiency mattered, why would we be using &KEY arguments at
845 ;;; all, much less renaming &KEY arguments?)
847 ;;; KLUDGE: It would probably be good to get rid of this. -- WHN 19991201
848 (defun rename-key-args (rename-list key-args
)
849 (declare (type list rename-list key-args
))
850 ;; Walk through RENAME-LIST modifying RESULT as per each element in
852 (do ((result (copy-list key-args
))) ; may be modified below
853 ((null rename-list
) result
)
854 (destructuring-bind (old new
) (pop rename-list
)
855 ;; ANSI says &KEY arg names aren't necessarily KEYWORDs.
856 (declare (type symbol old new
))
857 ;; Walk through RESULT renaming any OLD key argument to NEW.
858 (do ((in-result result
(cddr in-result
)))
860 (declare (type list in-result
))
861 (when (eq (car in-result
) old
)
862 (setf (car in-result
) new
))))))
864 ;;; ANSI Common Lisp's READ-SEQUENCE function, unlike most of the
865 ;;; other ANSI input functions, is defined to communicate end of file
866 ;;; status with its return value, not by signalling. That is not the
867 ;;; behavior that we usually want. This function is a wrapper which
868 ;;; restores the behavior that we usually want, causing READ-SEQUENCE
869 ;;; to communicate end-of-file status by signalling.
870 (defun read-sequence-or-die (sequence stream
&key start end
)
871 ;; implementation using READ-SEQUENCE
872 #-no-ansi-read-sequence
873 (let ((read-end (read-sequence sequence
877 (unless (= read-end end
)
878 (error 'end-of-file
:stream stream
))
880 ;; workaround for broken READ-SEQUENCE
881 #+no-ansi-read-sequence
883 (aver (<= start end
))
884 (let ((etype (stream-element-type stream
)))
885 (cond ((equal etype
'(unsigned-byte 8))
886 (do ((i start
(1+ i
)))
889 (setf (aref sequence i
)
890 (read-byte stream
))))
891 (t (error "unsupported element type ~S" etype
))))))
893 ;;;; utilities for two-VALUES predicates
895 (defmacro and
/type
(x y
)
896 `(multiple-value-bind (val1 win1
) ,x
897 (if (and (not val1
) win1
)
899 (multiple-value-bind (val2 win2
) ,y
902 (values nil
(and win2
(not val2
))))))))
904 ;;; sort of like ANY and EVERY, except:
905 ;;; * We handle two-VALUES predicate functions, as SUBTYPEP does.
906 ;;; (And if the result is uncertain, then we return (VALUES NIL NIL),
907 ;;; as SUBTYPEP does.)
908 ;;; * THING is just an atom, and we apply OP (an arity-2 function)
909 ;;; successively to THING and each element of LIST.
910 (defun any/type
(op thing list
)
911 (declare (type function op
))
913 (dolist (i list
(values nil certain?
))
914 (multiple-value-bind (sub-value sub-certain?
) (funcall op thing i
)
916 (when sub-value
(return (values t t
)))
917 (setf certain? nil
))))))
918 (defun every/type
(op thing list
)
919 (declare (type function op
))
921 (dolist (i list
(if certain?
(values t t
) (values nil nil
)))
922 (multiple-value-bind (sub-value sub-certain?
) (funcall op thing i
)
924 (unless sub-value
(return (values nil t
)))
925 (setf certain? nil
))))))
929 ;;; These functions are called by the expansion of the DEFPRINTER
930 ;;; macro to do the actual printing.
931 (declaim (ftype (function (symbol t stream
) (values))
932 defprinter-prin1 defprinter-princ
))
933 (defun defprinter-prin1 (name value stream
)
934 (defprinter-prinx #'prin1 name value stream
))
935 (defun defprinter-princ (name value stream
)
936 (defprinter-prinx #'princ name value stream
))
937 (defun defprinter-prinx (prinx name value stream
)
938 (declare (type function prinx
))
940 (pprint-newline :linear stream
))
941 (format stream
":~A " name
)
942 (funcall prinx value stream
)
944 (defun defprinter-print-space (stream)
945 (write-char #\space stream
))
947 ;;; Define some kind of reasonable PRINT-OBJECT method for a
948 ;;; STRUCTURE-OBJECT class.
950 ;;; NAME is the name of the structure class, and CONC-NAME is the same
953 ;;; The SLOT-DESCS describe how each slot should be printed. Each
954 ;;; SLOT-DESC can be a slot name, indicating that the slot should
955 ;;; simply be printed. A SLOT-DESC may also be a list of a slot name
956 ;;; and other stuff. The other stuff is composed of keywords followed
957 ;;; by expressions. The expressions are evaluated with the variable
958 ;;; which is the slot name bound to the value of the slot. These
959 ;;; keywords are defined:
961 ;;; :PRIN1 Print the value of the expression instead of the slot value.
962 ;;; :PRINC Like :PRIN1, only PRINC the value
963 ;;; :TEST Only print something if the test is true.
965 ;;; If no printing thing is specified then the slot value is printed
968 ;;; The structure being printed is bound to STRUCTURE and the stream
969 ;;; is bound to STREAM.
970 (defmacro defprinter
((name
972 (conc-name (concatenate 'simple-string
979 (reversed-prints nil
)
980 (stream (gensym "STREAM")))
981 (flet ((sref (slot-name)
982 `(,(symbolicate conc-name slot-name
) structure
)))
983 (dolist (slot-desc slot-descs
)
985 (setf maybe-print-space nil
987 (setf maybe-print-space
`(defprinter-print-space ,stream
)))
988 (cond ((atom slot-desc
)
989 (push maybe-print-space reversed-prints
)
990 (push `(defprinter-prin1 ',slot-desc
,(sref slot-desc
) ,stream
)
993 (let ((sname (first slot-desc
))
996 (do ((option (rest slot-desc
) (cddr option
)))
998 (push `(let ((,sname
,(sref sname
)))
1003 ',sname
,sname
,stream
)))))
1005 (case (first option
)
1007 (stuff `(defprinter-prin1
1008 ',sname
,(second option
) ,stream
)))
1010 (stuff `(defprinter-princ
1011 ',sname
,(second option
) ,stream
)))
1012 (:test
(setq test
(second option
)))
1014 (error "bad option: ~S" (first option
)))))))))))
1015 `(def!method print-object
((structure ,name
) ,stream
)
1016 (pprint-logical-block (,stream nil
)
1017 (print-unreadable-object (structure
1020 :identity
,identity
)
1021 ,@(nreverse reversed-prints
))))))
1025 ;;; Given a pathname, return a corresponding physical pathname.
1026 (defun physicalize-pathname (possibly-logical-pathname)
1027 (if (typep possibly-logical-pathname
'logical-pathname
)
1028 (translate-logical-pathname possibly-logical-pathname
)
1029 possibly-logical-pathname
))
1031 (defun deprecation-warning (bad-name &optional good-name
)
1032 (warn "using deprecated ~S~@[, should use ~S instead~]"
1036 ;;; Anaphoric macros
1037 (defmacro awhen
(test &body body
)
1041 (defmacro acond
(&rest clauses
)
1044 (destructuring-bind ((test &body body
) &rest rest
) clauses
1045 (once-only ((test test
))
1047 (let ((it ,test
)) (declare (ignorable it
)),@body
)