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 (defvar *core-pathname* nil
18 "The absolute pathname of the running SBCL core.")
20 (defvar *runtime-pathname* nil
22 "The absolute pathname of the running SBCL runtime.")
24 ;;; something not EQ to anything we might legitimately READ
25 (defparameter *eof-object* (make-symbol "EOF-OBJECT"))
27 (eval-when (:compile-toplevel :load-toplevel :execute)
28 (defconstant max-hash sb!xc:most-positive-fixnum))
31 `(integer 0 ,max-hash))
33 ;;; a type used for indexing into sequences, and for related
34 ;;; quantities like lengths of lists and other sequences.
36 ;;; A more correct value for the exclusive upper bound for indexing
37 ;;; would be (1- ARRAY-DIMENSION-LIMIT) since ARRAY-DIMENSION-LIMIT is
38 ;;; the exclusive maximum *size* of one array dimension (As specified
39 ;;; in CLHS entries for MAKE-ARRAY and "valid array dimensions"). The
40 ;;; current value is maintained to avoid breaking existing code that
41 ;;; also uses that type for upper bounds on indices (e.g. sequence
44 ;;; In SBCL, ARRAY-DIMENSION-LIMIT is arranged to be a little smaller
45 ;;; than MOST-POSITIVE-FIXNUM, for implementation (see comment above
46 ;;; ARRAY-DIMENSION-LIMIT) and efficiency reasons: staying below
47 ;;; MOST-POSITIVE-FIXNUM lets the system know it can increment a value
48 ;;; of type INDEX without having to worry about using a bignum to
49 ;;; represent the result.
50 (def!type index () `(integer 0 (,sb!xc:array-dimension-limit)))
52 ;;; like INDEX, but only up to half the maximum. Used by hash-table
53 ;;; code that does plenty to (aref v (* 2 i)) and (aref v (1+ (* 2 i))).
54 (def!type index/2 () `(integer 0 (,(floor sb!xc:array-dimension-limit 2))))
56 ;;; like INDEX, but augmented with -1 (useful when using the index
57 ;;; to count downwards to 0, e.g. LOOP FOR I FROM N DOWNTO 0, with
58 ;;; an implementation which terminates the loop by testing for the
59 ;;; index leaving the loop range)
60 (def!type index-or-minus-1 () `(integer -1 (,sb!xc:array-dimension-limit)))
62 ;;; A couple of VM-related types that are currently used only on the
63 ;;; alpha platform. -- CSR, 2002-06-24
64 (def!type unsigned-byte-with-a-bite-out (s bite)
65 (cond ((eq s '*) 'integer)
66 ((and (integerp s) (> s 0))
67 (let ((bound (ash 1 s)))
68 `(integer 0 ,(- bound bite 1))))
70 (error "Bad size specified for UNSIGNED-BYTE type specifier: ~S." s))))
72 ;;; Motivated by the mips port. -- CSR, 2002-08-22
73 (def!type signed-byte-with-a-bite-out (s bite)
74 (cond ((eq s '*) 'integer)
75 ((and (integerp s) (> s 1))
76 (let ((bound (ash 1 (1- s))))
77 `(integer ,(- bound) ,(- bound bite 1))))
79 (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
81 (def!type load/store-index (scale lowtag min-offset
82 &optional (max-offset min-offset))
83 `(integer ,(- (truncate (+ (ash 1 16)
84 (* min-offset sb!vm:n-word-bytes)
87 ,(truncate (- (+ (1- (ash 1 16)) lowtag)
88 (* max-offset sb!vm:n-word-bytes))
92 (defun displacement-bounds (lowtag element-size data-offset)
93 (let* ((adjustment (- (* data-offset sb!vm:n-word-bytes) lowtag))
94 (bytes-per-element (ceiling element-size sb!vm:n-byte-bits))
95 (min (truncate (+ sb!vm::minimum-immediate-offset adjustment)
97 (max (truncate (+ sb!vm::maximum-immediate-offset adjustment)
102 (def!type constant-displacement (lowtag element-size data-offset)
103 (flet ((integerify (x)
106 (symbol (symbol-value x)))))
107 (let ((lowtag (integerify lowtag))
108 (element-size (integerify element-size))
109 (data-offset (integerify data-offset)))
110 (multiple-value-bind (min max) (displacement-bounds lowtag
113 `(integer ,min ,max)))))
115 ;;; Similar to FUNCTION, but the result type is "exactly" specified:
116 ;;; if it is an object type, then the function returns exactly one
117 ;;; value, if it is a short form of VALUES, then this short form
118 ;;; specifies the exact number of values.
119 (def!type sfunction (args &optional result)
120 (let ((result (cond ((eq result '*) '*)
122 (not (eq (car result) 'values)))
123 `(values ,result &optional))
124 ((intersection (cdr result) sb!xc:lambda-list-keywords)
126 (t `(values ,@(cdr result) &optional)))))
127 `(function ,args ,result)))
131 ;;; FIXME: The SB!KERNEL:INSTANCE here really means CL:CLASS.
132 ;;; However, the CL:CLASS type is only defined once PCL is loaded,
133 ;;; which is before this is evaluated. Once PCL is moved into cold
134 ;;; init, this might be fixable.
135 (def!type type-specifier () '(or list symbol sb!kernel:instance))
137 ;;; the default value used for initializing character data. The ANSI
138 ;;; spec says this is arbitrary, so we use the value that falls
139 ;;; through when we just let the low-level consing code initialize
140 ;;; all newly-allocated memory to zero.
142 ;;; KLUDGE: It might be nice to use something which is a
143 ;;; STANDARD-CHAR, both to reduce user surprise a little and, probably
144 ;;; more significantly, to help SBCL's cross-compiler (which knows how
145 ;;; to dump STANDARD-CHARs). Unfortunately, the old CMU CL code is
146 ;;; shot through with implicit assumptions that it's #\NULL, and code
147 ;;; in several places (notably both DEFUN MAKE-ARRAY and DEFTRANSFORM
148 ;;; MAKE-ARRAY) would have to be rewritten. -- WHN 2001-10-04
149 (eval-when (:compile-toplevel :load-toplevel :execute)
150 ;; an expression we can use to construct a DEFAULT-INIT-CHAR value
151 ;; at load time (so that we don't need to teach the cross-compiler
152 ;; how to represent and dump non-STANDARD-CHARs like #\NULL)
153 (defparameter *default-init-char-form* '(code-char 0)))
155 ;;; CHAR-CODE values for ASCII characters which we care about but
156 ;;; which aren't defined in section "2.1.3 Standard Characters" of the
157 ;;; ANSI specification for Lisp
159 ;;; KLUDGE: These are typically used in the idiom (CODE-CHAR
160 ;;; FOO-CHAR-CODE). I suspect that the current implementation is
161 ;;; expanding this idiom into a full call to CODE-CHAR, which is an
162 ;;; annoying overhead. I should check whether this is happening, and
163 ;;; if so, perhaps implement a DEFTRANSFORM or something to stop it.
164 ;;; (or just find a nicer way of expressing characters portably?) --
166 (def!constant bell-char-code 7)
167 (def!constant backspace-char-code 8)
168 (def!constant tab-char-code 9)
169 (def!constant line-feed-char-code 10)
170 (def!constant form-feed-char-code 12)
171 (def!constant return-char-code 13)
172 (def!constant escape-char-code 27)
173 (def!constant rubout-char-code 127)
175 ;;;; type-ish predicates
177 ;;; X may contain cycles -- a conservative approximation. This
178 ;;; occupies a somewhat uncomfortable niche between being fast for
179 ;;; common cases (we don't want to allocate a hash-table), and not
180 ;;; falling down to exponential behaviour for large trees (so we set
181 ;;; an arbitrady depth limit beyond which we punt).
182 (defun maybe-cyclic-p (x &optional (depth-limit 12))
184 (labels ((safe-cddr (cons)
185 (let ((cdr (cdr cons)))
188 (check-cycle (object seen depth)
189 (when (and (consp object)
190 (or (> depth depth-limit)
192 (circularp object seen depth)))
193 (return-from maybe-cyclic-p t)))
194 (circularp (list seen depth)
195 ;; Almost regular circular list detection, with a twist:
196 ;; we also check each element of the list for upward
197 ;; references using CHECK-CYCLE.
198 (do ((fast (cons (car list) (cdr list)) (safe-cddr fast))
199 (slow list (cdr slow)))
201 ;; Not CDR-circular, need to check remaining CARs yet
202 (do ((tail slow (and (cdr tail))))
205 (check-cycle (car tail) (cons tail seen) (1+ depth))))
206 (check-cycle (car slow) (cons slow seen) (1+ depth))
209 (circularp x (list x) 0))))
211 ;;; Is X a (possibly-improper) list of at least N elements?
212 (declaim (ftype (function (t index)) list-of-length-at-least-p))
213 (defun list-of-length-at-least-p (x n)
214 (or (zerop n) ; since anything can be considered an improper list of length 0
216 (list-of-length-at-least-p (cdr x) (1- n)))))
218 (declaim (inline singleton-p))
219 (defun singleton-p (list)
223 ;;; Is X is a positive prime integer?
224 (defun positive-primep (x)
225 ;; This happens to be called only from one place in sbcl-0.7.0, and
226 ;; only for fixnums, we can limit it to fixnums for efficiency. (And
227 ;; if we didn't limit it to fixnums, we should use a cleverer
228 ;; algorithm, since this one scales pretty badly for huge X.)
231 (and (>= x 2) (/= x 4))
233 (not (zerop (rem x 3)))
236 (inc 2 (logxor inc 6)) ;; 2,4,2,4...
238 ((or (= r 0) (> d q)) (/= r 0))
239 (declare (fixnum inc))
240 (multiple-value-setq (q r) (truncate x d))))))
242 ;;; Could this object contain other objects? (This is important to
243 ;;; the implementation of things like *PRINT-CIRCLE* and the dumper.)
244 (defun compound-object-p (x)
247 (typep x '(array t *))))
249 ;;;; the COLLECT macro
251 ;;;; comment from CMU CL: "the ultimate collection macro..."
253 ;;; helper functions for COLLECT, which become the expanders of the
254 ;;; MACROLET definitions created by COLLECT
256 ;;; COLLECT-NORMAL-EXPANDER handles normal collection macros.
258 ;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
259 ;;; is the pointer to the current tail of the list, or NIL if the list
261 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
262 (defun collect-normal-expander (n-value fun forms)
264 ,@(mapcar (lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
266 (defun collect-list-expander (n-value n-tail forms)
267 (let ((n-res (gensym)))
269 ,@(mapcar (lambda (form)
270 `(let ((,n-res (cons ,form nil)))
272 (setf (cdr ,n-tail) ,n-res)
273 (setq ,n-tail ,n-res))
275 (setq ,n-tail ,n-res ,n-value ,n-res)))))
279 ;;; Collect some values somehow. Each of the collections specifies a
280 ;;; bunch of things which collected during the evaluation of the body
281 ;;; of the form. The name of the collection is used to define a local
282 ;;; macro, a la MACROLET. Within the body, this macro will evaluate
283 ;;; each of its arguments and collect the result, returning the
284 ;;; current value after the collection is done. The body is evaluated
285 ;;; as a PROGN; to get the final values when you are done, just call
286 ;;; the collection macro with no arguments.
288 ;;; INITIAL-VALUE is the value that the collection starts out with,
289 ;;; which defaults to NIL. FUNCTION is the function which does the
290 ;;; collection. It is a function which will accept two arguments: the
291 ;;; value to be collected and the current collection. The result of
292 ;;; the function is made the new value for the collection. As a
293 ;;; totally magical special-case, FUNCTION may be COLLECT, which tells
294 ;;; us to build a list in forward order; this is the default. If an
295 ;;; INITIAL-VALUE is supplied for COLLECT, the stuff will be RPLACD'd
296 ;;; onto the end. Note that FUNCTION may be anything that can appear
297 ;;; in the functional position, including macros and lambdas.
298 (defmacro collect (collections &body body)
301 (dolist (spec collections)
302 (unless (proper-list-of-length-p spec 1 3)
303 (error "malformed collection specifier: ~S" spec))
304 (let* ((name (first spec))
305 (default (second spec))
306 (kind (or (third spec) 'collect))
307 (n-value (gensym (concatenate 'string
310 (push `(,n-value ,default) binds)
311 (if (eq kind 'collect)
312 (let ((n-tail (gensym (concatenate 'string
316 (push `(,n-tail (last ,n-value)) binds)
318 (push `(,name (&rest args)
319 (collect-list-expander ',n-value ',n-tail args))
321 (push `(,name (&rest args)
322 (collect-normal-expander ',n-value ',kind args))
324 `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
326 ;;;; some old-fashioned functions. (They're not just for old-fashioned
327 ;;;; code, they're also used as optimized forms of the corresponding
328 ;;;; general functions when the compiler can prove that they're
331 ;;; like (MEMBER ITEM LIST :TEST #'EQ)
332 (defun memq (item list)
334 "Return tail of LIST beginning with first element EQ to ITEM."
335 ;; KLUDGE: These could be and probably should be defined as
336 ;; (MEMBER ITEM LIST :TEST #'EQ)),
337 ;; but when I try to cross-compile that, I get an error from
338 ;; LTN-ANALYZE-KNOWN-CALL, "Recursive known function definition". The
339 ;; comments for that error say it "is probably a botched interpreter stub".
340 ;; Rather than try to figure that out, I just rewrote this function from
341 ;; scratch. -- WHN 19990512
342 (do ((i list (cdr i)))
344 (when (eq (car i) item)
347 ;;; like (ASSOC ITEM ALIST :TEST #'EQ):
348 ;;; Return the first pair of ALIST where ITEM is EQ to the key of
350 (defun assq (item alist)
351 ;; KLUDGE: CMU CL defined this with
352 ;; (DECLARE (INLINE ASSOC))
353 ;; (ASSOC ITEM ALIST :TEST #'EQ))
354 ;; which is pretty, but which would have required adding awkward
355 ;; build order constraints on SBCL (or figuring out some way to make
356 ;; inline definitions installable at build-the-cross-compiler time,
357 ;; which was too ambitious for now). Rather than mess with that, we
358 ;; just define ASSQ explicitly in terms of more primitive
361 ;; though it may look more natural to write this as
362 ;; (AND PAIR (EQ (CAR PAIR) ITEM))
363 ;; the temptation to do so should be resisted, as pointed out by PFD
364 ;; sbcl-devel 2003-08-16, as NIL elements are rare in association
365 ;; lists. -- CSR, 2003-08-16
366 (when (and (eq (car pair) item) (not (null pair)))
369 ;;; like (DELETE .. :TEST #'EQ):
370 ;;; Delete all LIST entries EQ to ITEM (destructively modifying
371 ;;; LIST), and return the modified LIST.
372 (defun delq (item list)
374 (do ((x list (cdr x))
377 (cond ((eq item (car x))
380 (rplacd splice (cdr x))))
381 (t (setq splice x)))))) ; Move splice along to include element.
384 ;;; like (POSITION .. :TEST #'EQ):
385 ;;; Return the position of the first element EQ to ITEM.
386 (defun posq (item list)
387 (do ((i list (cdr i))
390 (when (eq (car i) item)
393 (declaim (inline neq))
397 ;;; not really an old-fashioned function, but what the calling
398 ;;; convention should've been: like NTH, but with the same argument
399 ;;; order as in all the other indexed dereferencing functions, with
400 ;;; the collection first and the index second
401 (declaim (inline nth-but-with-sane-arg-order))
402 (declaim (ftype (function (list index) t) nth-but-with-sane-arg-order))
403 (defun nth-but-with-sane-arg-order (list index)
406 (defun adjust-list (list length initial-element)
407 (let ((old-length (length list)))
408 (cond ((< old-length length)
409 (append list (make-list (- length old-length)
410 :initial-element initial-element)))
411 ((> old-length length)
412 (subseq list 0 length))
415 ;;;; miscellaneous iteration extensions
417 ;;; like Scheme's named LET
419 ;;; (CMU CL called this ITERATE, and commented it as "the ultimate
420 ;;; iteration macro...". I (WHN) found the old name insufficiently
421 ;;; specific to remind me what the macro means, so I renamed it.)
422 (defmacro named-let (name binds &body body)
424 (unless (proper-list-of-length-p x 2)
425 (error "malformed NAMED-LET variable spec: ~S" x)))
426 `(labels ((,name ,(mapcar #'first binds) ,@body))
427 (,name ,@(mapcar #'second binds))))
429 (defun filter-dolist-declarations (decls)
430 (mapcar (lambda (decl)
431 `(declare ,@(remove-if
434 (or (eq (car clause) 'type)
435 (eq (car clause) 'ignore))))
438 ;;; just like DOLIST, but with one-dimensional arrays
439 (defmacro dovector ((elt vector &optional result) &body body)
440 (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
441 (with-unique-names (index length vec)
442 `(let ((,vec ,vector))
443 (declare (type vector ,vec))
444 (do ((,index 0 (1+ ,index))
445 (,length (length ,vec)))
446 ((>= ,index ,length) (let ((,elt nil))
447 ,@(filter-dolist-declarations decls)
450 (let ((,elt (aref ,vec ,index)))
455 ;;; Iterate over the entries in a HASH-TABLE, first obtaining the lock
456 ;;; if the table is a synchronized table.
457 (defmacro dohash (((key-var value-var) table &key result locked) &body body)
458 (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
459 (with-unique-names (gen n-more n-table)
460 (let ((iter-form `(with-hash-table-iterator (,gen ,n-table)
462 (multiple-value-bind (,n-more ,key-var ,value-var) (,gen)
464 (unless ,n-more (return ,result))
466 `(let ((,n-table ,table))
468 `(with-locked-system-table (,n-table)
472 ;;; Executes BODY for all entries of PLIST with KEY and VALUE bound to
473 ;;; the respective keys and values.
474 (defmacro doplist ((key val) plist &body body)
475 (with-unique-names (tail)
476 `(let ((,tail ,plist) ,key ,val)
477 (loop (when (null ,tail) (return nil))
478 (setq ,key (pop ,tail))
480 (error "malformed plist, odd number of elements"))
481 (setq ,val (pop ,tail))
485 ;;;; hash cache utility
487 (eval-when (:compile-toplevel :load-toplevel :execute)
488 (defvar *profile-hash-cache* nil))
490 ;;; a flag for whether it's too early in cold init to use caches so
491 ;;; that we have a better chance of recovering so that we have a
492 ;;; better chance of getting the system running so that we have a
493 ;;; better chance of diagnosing the problem which caused us to use the
496 (defvar *hash-caches-initialized-p*)
498 ;;; Define a hash cache that associates some number of argument values
499 ;;; with a result value. The TEST-FUNCTION paired with each ARG-NAME
500 ;;; is used to compare the value for that arg in a cache entry with a
501 ;;; supplied arg. The TEST-FUNCTION must not error when passed NIL as
502 ;;; its first arg, but need not return any particular value.
503 ;;; TEST-FUNCTION may be any thing that can be placed in CAR position.
505 ;;; This code used to store all the arguments / return values directly
506 ;;; in the cache vector. This was both interrupt- and thread-unsafe, since
507 ;;; it was possible that *-CACHE-ENTER would scribble over a region of the
508 ;;; cache vector which *-CACHE-LOOKUP had only partially processed. Instead
509 ;;; we now store the contents of each cache bucket as a separate array, which
510 ;;; is stored in the appropriate cell in the cache vector. A new bucket array
511 ;;; is created every time *-CACHE-ENTER is called, and the old ones are never
512 ;;; modified. This means that *-CACHE-LOOKUP will always work with a set
513 ;;; of consistent data. The overhead caused by consing new buckets seems to
514 ;;; be insignificant on the grand scale of things. -- JES, 2006-11-02
516 ;;; NAME is used to define these functions:
517 ;;; <name>-CACHE-LOOKUP Arg*
518 ;;; See whether there is an entry for the specified ARGs in the
519 ;;; cache. If not present, the :DEFAULT keyword (default NIL)
520 ;;; determines the result(s).
521 ;;; <name>-CACHE-ENTER Arg* Value*
522 ;;; Encache the association of the specified args with VALUE.
523 ;;; <name>-CACHE-CLEAR
524 ;;; Reinitialize the cache, invalidating all entries and allowing
525 ;;; the arguments and result values to be GC'd.
527 ;;; These other keywords are defined:
529 ;;; The size of the cache as a power of 2.
530 ;;; :HASH-FUNCTION function
531 ;;; Some thing that can be placed in CAR position which will compute
532 ;;; a value between 0 and (1- (expt 2 <hash-bits>)).
534 ;;; the number of return values cached for each function call
535 ;;; :INIT-WRAPPER <name>
536 ;;; The code for initializing the cache is wrapped in a form with
537 ;;; the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS
538 ;;; in type system definitions so that caches will be created
539 ;;; before top level forms run.)
540 (defvar *cache-vector-symbols* nil)
542 (defun drop-all-hash-caches ()
543 (dolist (name *cache-vector-symbols*)
546 (defmacro define-hash-cache (name args &key hash-function hash-bits default
547 (init-wrapper 'progn)
549 (let* ((var-name (symbolicate "**" name "-CACHE-VECTOR**"))
550 (probes-name (when *profile-hash-cache*
551 (symbolicate "**" name "-CACHE-PROBES**")))
552 (misses-name (when *profile-hash-cache*
553 (symbolicate "**" name "-CACHE-MISSES**")))
554 (nargs (length args))
555 (size (ash 1 hash-bits))
556 (default-values (if (and (consp default) (eq (car default) 'values))
559 (args-and-values (sb!xc:gensym "ARGS-AND-VALUES"))
560 (args-and-values-size (+ nargs values))
561 (n-index (sb!xc:gensym "INDEX"))
562 (n-cache (sb!xc:gensym "CACHE")))
563 (declare (ignorable probes-name misses-name))
564 (unless (= (length default-values) values)
565 (error "The number of default values ~S differs from :VALUES ~W."
577 (let ((name (sb!xc:gensym "VALUE")))
579 (values-refs `(svref ,args-and-values (+ ,nargs ,i)))
580 (sets `(setf (svref ,args-and-values (+ ,nargs ,i)) ,name))))
583 (unless (= (length arg) 2)
584 (error "bad argument spec: ~S" arg))
585 (let ((arg-name (first arg))
588 (tests `(,test (svref ,args-and-values ,n) ,arg-name))
589 (sets `(setf (svref ,args-and-values ,n) ,arg-name)))
592 (when *profile-hash-cache*
593 (inits `(setq ,probes-name 0))
594 (inits `(setq ,misses-name 0))
595 (forms `(declaim (fixnum ,probes-name ,misses-name))))
597 (let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
600 `(defun ,fun-name ,(arg-vars)
601 ,@(when *profile-hash-cache*
602 `((incf ,probes-name)))
604 ,@(when *profile-hash-cache*
605 `((incf ,misses-name)))
606 (return-from ,fun-name ,default)))
607 (let* ((,n-index (,hash-function ,@(arg-vars)))
608 (,n-cache (or ,var-name (miss)))
609 (,args-and-values (svref ,n-cache ,n-index)))
610 (cond ((and (not (eql 0 ,args-and-values))
612 (values ,@(values-refs)))
616 (let ((fun-name (symbolicate name "-CACHE-ENTER")))
619 `(defun ,fun-name (,@(arg-vars) ,@(values-names))
620 (let ((,n-index (,hash-function ,@(arg-vars)))
621 (,n-cache (or ,var-name
622 (setq ,var-name (make-array ,size :initial-element 0))))
623 (,args-and-values (make-array ,args-and-values-size)))
625 (setf (svref ,n-cache ,n-index) ,args-and-values))
628 (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
631 (setq ,var-name nil))))
633 ;; Needed for cold init!
634 (inits `(setq ,var-name nil))
635 #!+sb-show (inits `(setq *hash-caches-initialized-p* t))
638 (pushnew ',var-name *cache-vector-symbols*)
639 (defglobal ,var-name nil)
640 ,@(when *profile-hash-cache*
641 `((defglobal ,probes-name 0)
642 (defglobal ,misses-name 0)))
643 (declaim (type (or null (simple-vector ,size)) ,var-name))
644 #!-sb-fluid (declaim (inline ,@(inlines)))
645 (,init-wrapper ,@(inits))
649 ;;; some syntactic sugar for defining a function whose values are
650 ;;; cached by DEFINE-HASH-CACHE
651 (defmacro defun-cached ((name &rest options &key (values 1) default
653 args &body body-decls-doc)
654 (let ((default-values (if (and (consp default) (eq (car default) 'values))
657 (arg-names (mapcar #'car args))
658 (values-names (make-gensym-list values)))
659 (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
661 (define-hash-cache ,name ,args ,@options)
662 (defun ,name ,arg-names
666 ((not (boundp '*hash-caches-initialized-p*))
667 ;; This shouldn't happen, but it did happen to me
668 ;; when revising the type system, and it's a lot
669 ;; easier to figure out what what's going on with
670 ;; that kind of problem if the system can be kept
671 ;; alive until cold boot is complete. The recovery
672 ;; mechanism should definitely be conditional on some
673 ;; debugging feature (e.g. SB-SHOW) because it's big,
674 ;; duplicating all the BODY code. -- WHN
675 (/show0 ,name " too early in cold init, uncached")
676 (/show0 ,(first arg-names) "=..")
677 (/hexstr ,(first arg-names))
680 (multiple-value-bind ,values-names
681 (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
682 (if (and ,@(mapcar (lambda (val def)
684 values-names default-values))
685 (multiple-value-bind ,values-names
687 (,(symbolicate name "-CACHE-ENTER") ,@arg-names
689 (values ,@values-names))
690 (values ,@values-names))))))))))
692 (defmacro define-cached-synonym
693 (name &optional (original (symbolicate "%" name)))
694 (let ((cached-name (symbolicate "%%" name "-CACHED")))
696 (defun-cached (,cached-name :hash-bits 8
697 :hash-function (lambda (x)
698 (logand (sxhash x) #xff)))
700 (apply #',original args))
701 (defun ,name (&rest args)
702 (,cached-name args)))))
704 ;;; FIXME: maybe not the best place
706 ;;; FIXME: think of a better name -- not only does this not have the
707 ;;; CAR recursion of EQUAL, it also doesn't have the special treatment
708 ;;; of pathnames, bit-vectors and strings.
710 ;;; KLUDGE: This means that we will no longer cache specifiers of the
711 ;;; form '(INTEGER (0) 4). This is probably not a disaster.
713 ;;; A helper function for the type system, which is the main user of
714 ;;; these caches: we must be more conservative than EQUAL for some of
715 ;;; our equality tests, because MEMBER and friends refer to EQLity.
717 (defun equal-but-no-car-recursion (x y)
719 (cond ((eql x y) (return t))
722 (eql (pop x) (pop y))))
728 ;;; Note: Almost always you want to use FIND-UNDELETED-PACKAGE-OR-LOSE
729 ;;; instead of this function. (The distinction only actually matters when
730 ;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case
731 ;;; you generally do want to signal an error instead of proceeding.)
732 (defun %find-package-or-lose (package-designator)
733 (or (find-package package-designator)
734 (error 'sb!kernel:simple-package-error
735 :package package-designator
736 :format-control "The name ~S does not designate any package."
737 :format-arguments (list package-designator))))
739 ;;; ANSI specifies (in the section for FIND-PACKAGE) that the
740 ;;; consequences of most operations on deleted packages are
741 ;;; unspecified. We try to signal errors in such cases.
742 (defun find-undeleted-package-or-lose (package-designator)
743 (let ((maybe-result (%find-package-or-lose package-designator)))
744 (if (package-name maybe-result) ; if not deleted
746 (error 'sb!kernel:simple-package-error
747 :package maybe-result
748 :format-control "The package ~S has been deleted."
749 :format-arguments (list maybe-result)))))
751 ;;;; various operations on names
753 ;;; Is NAME a legal function name?
754 (declaim (inline legal-fun-name-p))
755 (defun legal-fun-name-p (name)
756 (values (valid-function-name-p name)))
758 (deftype function-name () '(satisfies legal-fun-name-p))
760 ;;; Signal an error unless NAME is a legal function name.
761 (defun legal-fun-name-or-type-error (name)
762 (unless (legal-fun-name-p name)
763 (error 'simple-type-error
765 :expected-type 'function-name
766 :format-control "invalid function name: ~S"
767 :format-arguments (list name))))
769 ;;; Given a function name, return the symbol embedded in it.
771 ;;; The ordinary use for this operator (and the motivation for the
772 ;;; name of this operator) is to convert from a function name to the
773 ;;; name of the BLOCK which encloses its body.
775 ;;; Occasionally the operator is useful elsewhere, where the operator
776 ;;; name is less mnemonic. (Maybe it should be changed?)
777 (declaim (ftype (function ((or symbol cons)) symbol) fun-name-block-name))
778 (defun fun-name-block-name (fun-name)
779 (cond ((symbolp fun-name)
782 (multiple-value-bind (legalp block-name)
783 (valid-function-name-p fun-name)
786 (error "not legal as a function name: ~S" fun-name))))
788 (error "not legal as a function name: ~S" fun-name))))
790 (defun looks-like-name-of-special-var-p (x)
792 (let ((name (symbol-name x)))
793 (and (> (length name) 2) ; to exclude '* and '**
794 (char= #\* (aref name 0))
795 (char= #\* (aref name (1- (length name))))))))
797 ;;; If COLD-FSET occurs not at top level, just treat it as an ordinary
798 ;;; assignment instead of doing cold static linking. That way things like
799 ;;; (FLET ((FROB (X) ..))
800 ;;; (DEFUN FOO (X Y) (FROB X) ..)
801 ;;; (DEFUN BAR (Z) (AND (FROB X) ..)))
802 ;;; can still "work" for cold init: they don't do magical static
803 ;;; linking the way that true toplevel DEFUNs do, but at least they do
804 ;;; the linking eventually, so as long as #'FOO and #'BAR aren't
805 ;;; needed until "cold toplevel forms" have executed, it's OK.
806 (defmacro cold-fset (name lambda)
808 "~@<COLD-FSET ~S not cross-compiled at top level: demoting to ~
809 (SETF FDEFINITION)~:@>"
811 ;; We convert the LAMBDA expression to the corresponding NAMED-LAMBDA
812 ;; expression so that the compiler can use NAME in debug names etc.
813 (destructuring-bind (lambda-symbol &rest lambda-rest) lambda
814 (assert (eql lambda-symbol 'lambda)) ; else dunno how to do conversion
815 `(setf (fdefinition ',name)
816 (named-lambda ,name ,@lambda-rest))))
820 ;;;; "The macro ONCE-ONLY has been around for a long time on various
821 ;;;; systems [..] if you can understand how to write and when to use
822 ;;;; ONCE-ONLY, then you truly understand macro." -- Peter Norvig,
823 ;;;; _Paradigms of Artificial Intelligence Programming: Case Studies
824 ;;;; in Common Lisp_, p. 853
826 ;;; ONCE-ONLY is a utility useful in writing source transforms and
827 ;;; macros. It provides a concise way to wrap a LET around some code
828 ;;; to ensure that some forms are only evaluated once.
830 ;;; Create a LET* which evaluates each value expression, binding a
831 ;;; temporary variable to the result, and wrapping the LET* around the
832 ;;; result of the evaluation of BODY. Within the body, each VAR is
833 ;;; bound to the corresponding temporary variable.
834 (defmacro once-only (specs &body body)
835 (named-let frob ((specs specs)
839 (let ((spec (first specs)))
840 ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
841 (unless (proper-list-of-length-p spec 2)
842 (error "malformed ONCE-ONLY binding spec: ~S" spec))
843 (let* ((name (first spec))
844 (exp-temp (gensym "ONCE-ONLY")))
845 `(let ((,exp-temp ,(second spec))
846 (,name (sb!xc:gensym ,(symbol-name name))))
847 `(let ((,,name ,,exp-temp))
848 ,,(frob (rest specs) body))))))))
850 ;;;; various error-checking utilities
852 ;;; This function can be used as the default value for keyword
853 ;;; arguments that must be always be supplied. Since it is known by
854 ;;; the compiler to never return, it will avoid any compile-time type
855 ;;; warnings that would result from a default value inconsistent with
856 ;;; the declared type. When this function is called, it signals an
857 ;;; error indicating that a required &KEY argument was not supplied.
858 ;;; This function is also useful for DEFSTRUCT slot defaults
859 ;;; corresponding to required arguments.
860 (declaim (ftype (function () nil) missing-arg))
861 (defun missing-arg ()
863 (/show0 "entering MISSING-ARG")
864 (error "A required &KEY or &OPTIONAL argument was not supplied."))
866 ;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
868 ;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT.
869 ;;; The CL:ASSERT restarts and whatnot expand into a significant
870 ;;; amount of code when you multiply them by 400, so replacing them
871 ;;; with this should reduce the size of the system by enough to be
872 ;;; worthwhile. ENFORCE-TYPE is much less common, but might still be
873 ;;; worthwhile, and since I don't really like CERROR stuff deep in the
874 ;;; guts of complex systems anyway, I replaced it too.)
875 (defmacro aver (expr)
877 (%failed-aver ',expr)))
879 (defun %failed-aver (expr)
880 ;; hackish way to tell we're in a cold sbcl and output the
881 ;; message before signalling error, as it may be this is too
882 ;; early in the cold init.
883 (when (find-package "SB!C")
885 (write-line "failed AVER:")
888 (bug "~@<failed AVER: ~2I~_~A~:>" expr))
890 (defun bug (format-control &rest format-arguments)
892 :format-control format-control
893 :format-arguments format-arguments))
895 (defmacro enforce-type (value type)
896 (once-only ((value value))
897 `(unless (typep ,value ',type)
898 (%failed-enforce-type ,value ',type))))
900 (defun %failed-enforce-type (value type)
901 ;; maybe should be TYPE-BUG, subclass of BUG? If it is changed,
902 ;; check uses of it in user-facing code (e.g. WARN)
903 (error 'simple-type-error
906 :format-control "~@<~S ~_is not a ~_~S~:>"
907 :format-arguments (list value type)))
909 ;;; Return a function like FUN, but expecting its (two) arguments in
910 ;;; the opposite order that FUN does.
911 (declaim (inline swapped-args-fun))
912 (defun swapped-args-fun (fun)
913 (declare (type function fun))
917 ;;; Return the numeric value of a type bound, i.e. an interval bound
918 ;;; more or less in the format of bounds in ANSI's type specifiers,
919 ;;; where a bare numeric value is a closed bound and a list of a
920 ;;; single numeric value is an open bound.
922 ;;; The "more or less" bit is that the no-bound-at-all case is
923 ;;; represented by NIL (not by * as in ANSI type specifiers); and in
924 ;;; this case we return NIL.
925 (defun type-bound-number (x)
927 (destructuring-bind (result) x result)
930 ;;; some commonly-occuring CONSTANTLY forms
931 (macrolet ((def-constantly-fun (name constant-expr)
932 `(setf (symbol-function ',name)
933 (constantly ,constant-expr))))
934 (def-constantly-fun constantly-t t)
935 (def-constantly-fun constantly-nil nil)
936 (def-constantly-fun constantly-0 0))
938 ;;; If X is a symbol, see whether it is present in *FEATURES*. Also
939 ;;; handle arbitrary combinations of atoms using NOT, AND, OR.
947 (error "too many subexpressions in feature expression: ~S" x))
949 (error "too few subexpressions in feature expression: ~S" x))
950 (t (not (featurep (cadr x))))))
951 ((:and and) (every #'featurep (cdr x)))
952 ((:or or) (some #'featurep (cdr x)))
954 (error "unknown operator in feature expression: ~S." x))))
955 (symbol (not (null (memq x *features*))))
957 (error "invalid feature expression: ~S" x))))
960 ;;;; utilities for two-VALUES predicates
962 (defmacro not/type (x)
963 (let ((val (gensym "VAL"))
964 (win (gensym "WIN")))
965 `(multiple-value-bind (,val ,win)
968 (values (not ,val) t)
971 (defmacro and/type (x y)
972 `(multiple-value-bind (val1 win1) ,x
973 (if (and (not val1) win1)
975 (multiple-value-bind (val2 win2) ,y
978 (values nil (and win2 (not val2))))))))
980 ;;; sort of like ANY and EVERY, except:
981 ;;; * We handle two-VALUES predicate functions, as SUBTYPEP does.
982 ;;; (And if the result is uncertain, then we return (VALUES NIL NIL),
983 ;;; as SUBTYPEP does.)
984 ;;; * THING is just an atom, and we apply OP (an arity-2 function)
985 ;;; successively to THING and each element of LIST.
986 (defun any/type (op thing list)
987 (declare (type function op))
989 (dolist (i list (values nil certain?))
990 (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
992 (when sub-value (return (values t t)))
993 (setf certain? nil))))))
994 (defun every/type (op thing list)
995 (declare (type function op))
997 (dolist (i list (if certain? (values t t) (values nil nil)))
998 (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
1000 (unless sub-value (return (values nil t)))
1001 (setf certain? nil))))))
1005 ;;; These functions are called by the expansion of the DEFPRINTER
1006 ;;; macro to do the actual printing.
1007 (declaim (ftype (function (symbol t stream) (values))
1008 defprinter-prin1 defprinter-princ))
1009 (defun defprinter-prin1 (name value stream)
1010 (defprinter-prinx #'prin1 name value stream))
1011 (defun defprinter-princ (name value stream)
1012 (defprinter-prinx #'princ name value stream))
1013 (defun defprinter-prinx (prinx name value stream)
1014 (declare (type function prinx))
1015 (when *print-pretty*
1016 (pprint-newline :linear stream))
1017 (format stream ":~A " name)
1018 (funcall prinx value stream)
1020 (defun defprinter-print-space (stream)
1021 (write-char #\space stream))
1023 ;;; Define some kind of reasonable PRINT-OBJECT method for a
1024 ;;; STRUCTURE-OBJECT class.
1026 ;;; NAME is the name of the structure class, and CONC-NAME is the same
1027 ;;; as in DEFSTRUCT.
1029 ;;; The SLOT-DESCS describe how each slot should be printed. Each
1030 ;;; SLOT-DESC can be a slot name, indicating that the slot should
1031 ;;; simply be printed. A SLOT-DESC may also be a list of a slot name
1032 ;;; and other stuff. The other stuff is composed of keywords followed
1033 ;;; by expressions. The expressions are evaluated with the variable
1034 ;;; which is the slot name bound to the value of the slot. These
1035 ;;; keywords are defined:
1037 ;;; :PRIN1 Print the value of the expression instead of the slot value.
1038 ;;; :PRINC Like :PRIN1, only PRINC the value
1039 ;;; :TEST Only print something if the test is true.
1041 ;;; If no printing thing is specified then the slot value is printed
1044 ;;; The structure being printed is bound to STRUCTURE and the stream
1045 ;;; is bound to STREAM.
1046 (defmacro defprinter ((name
1048 (conc-name (concatenate 'simple-string
1055 (reversed-prints nil)
1056 (stream (sb!xc:gensym "STREAM")))
1057 (flet ((sref (slot-name)
1058 `(,(symbolicate conc-name slot-name) structure)))
1059 (dolist (slot-desc slot-descs)
1061 (setf maybe-print-space nil
1063 (setf maybe-print-space `(defprinter-print-space ,stream)))
1064 (cond ((atom slot-desc)
1065 (push maybe-print-space reversed-prints)
1066 (push `(defprinter-prin1 ',slot-desc ,(sref slot-desc) ,stream)
1069 (let ((sname (first slot-desc))
1072 (do ((option (rest slot-desc) (cddr option)))
1074 (push `(let ((,sname ,(sref sname)))
1079 ',sname ,sname ,stream)))))
1081 (case (first option)
1083 (stuff `(defprinter-prin1
1084 ',sname ,(second option) ,stream)))
1086 (stuff `(defprinter-princ
1087 ',sname ,(second option) ,stream)))
1088 (:test (setq test (second option)))
1090 (error "bad option: ~S" (first option)))))))))))
1091 `(def!method print-object ((structure ,name) ,stream)
1092 (pprint-logical-block (,stream nil)
1093 (print-unreadable-object (structure
1096 :identity ,identity)
1097 ,@(nreverse reversed-prints))))))
1101 ;;; Given a pathname, return a corresponding physical pathname.
1102 (defun physicalize-pathname (possibly-logical-pathname)
1103 (if (typep possibly-logical-pathname 'logical-pathname)
1104 (translate-logical-pathname possibly-logical-pathname)
1105 possibly-logical-pathname))
1107 ;;;; Deprecating stuff
1109 (defun normalize-deprecation-replacements (replacements)
1110 (if (or (not (listp replacements))
1111 (eq 'setf (car replacements)))
1115 (defun deprecation-error (since name replacements)
1116 (error 'deprecation-error
1118 :replacements (normalize-deprecation-replacements replacements)
1121 (defun deprecation-warning (state since name replacements
1122 &key (runtime-error (neq :early state)))
1124 (:early 'early-deprecation-warning)
1125 (:late 'late-deprecation-warning)
1126 (:final 'final-deprecation-warning))
1128 :replacements (normalize-deprecation-replacements replacements)
1130 :runtime-error runtime-error))
1132 (defun deprecated-function (since name replacements)
1133 (lambda (&rest deprecated-function-args)
1134 (declare (ignore deprecated-function-args))
1135 (deprecation-error since name replacements)))
1137 (defun deprecation-compiler-macro (state since name replacements)
1139 (declare (ignore env))
1140 (deprecation-warning state since name replacements)
1145 ;;; :EARLY, for a compile-time style-warning.
1146 ;;; :LATE, for a compile-time full warning.
1147 ;;; :FINAL, for a compile-time full warning and runtime error.
1149 ;;; Suggested duration of each stage is one year, but some things can move faster,
1150 ;;; and some widely used legacy APIs might need to move slower. Internals we don't
1151 ;;; usually add deprecation notes for, but sometimes an internal API actually has
1152 ;;; several external users, in which case we try to be nice about it.
1154 ;;; When you deprecate something, note it here till it is fully gone: makes it
1155 ;;; easier to keep things progressing orderly. Also add the relevant section
1156 ;;; (or update it when deprecation proceeds) in the manual, in
1157 ;;; deprecated.texinfo.
1160 ;;; - SB-THREAD::GET-MUTEX, since 1.0.37.33 (04/2010) -> Late: 01/2013
1161 ;;; ^- initially deprecated without compile-time warning, hence the schedule
1162 ;;; - SB-THREAD::SPINLOCK (type), since 1.0.53.11 (08/2011) -> Late: 08/2012
1163 ;;; - SB-THREAD::MAKE-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
1164 ;;; - SB-THREAD::WITH-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
1165 ;;; - SB-THREAD::WITH-RECURSIVE-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
1166 ;;; - SB-THREAD::GET-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
1167 ;;; - SB-THREAD::RELEASE-SPINLOCK, since 1.0.53.11 (08/2011) -> Late: 08/2012
1168 ;;; - SB-THREAD::SPINLOCK-VALUE, since 1.0.53.11 (08/2011) -> Late: 08/2012
1169 ;;; - SB-THREAD::SPINLOCK-NAME, since 1.0.53.11 (08/2011) -> Late: 08/2012
1170 ;;; - SETF SB-THREAD::SPINLOCK-NAME, since 1.0.53.11 (08/2011) -> Late: 08/2012
1171 ;;; - SB-C::MERGE-TAIL-CALLS (policy), since 1.0.53.74 (11/2011) -> Late: 11/2012
1172 ;;; - SB-EXT:QUIT, since 1.0.56.55 (05/2012) -> Late: 05/2013
1173 ;;; - SB-UNIX:UNIX-EXIT, since 1.0.56.55 (05/2012) -> Late: 05/2013
1174 ;;; - SB-DEBUG:*SHOW-ENTRY-POINT-DETAILS*, since 1.1.4.9 (02/2013) -> Late: 02/2014
1177 ;;; - SB-SYS:OUTPUT-RAW-BYTES, since 1.0.8.16 (06/2007) -> Final: anytime
1178 ;;; Note: make sure CLX doesn't use it anymore!
1179 ;;; - SB-C::STACK-ALLOCATE-DYNAMIC-EXTENT (policy), since 1.0.19.7 -> Final: anytime
1180 ;;; - SB-C::STACK-ALLOCATE-VECTOR (policy), since 1.0.19.7 -> Final: anytime
1181 ;;; - SB-C::STACK-ALLOCATE-VALUE-CELLS (policy), since 1.0.19.7 -> Final: anytime
1182 ;;; - SB-INTROSPECT:FUNCTION-ARGLIST, since 1.0.24.5 (01/2009) -> Final: anytime
1183 ;;; - SB-THREAD:JOIN-THREAD-ERROR-THREAD, since 1.0.29.17 (06/2009) -> Final: 09/2012
1184 ;;; - SB-THREAD:INTERRUPT-THREAD-ERROR-THREAD since 1.0.29.17 (06/2009) -> Final: 06/2012
1186 (defmacro define-deprecated-function (state since name replacements lambda-list &body body)
1187 (let* ((replacements (normalize-deprecation-replacements replacements))
1189 (let ((*package* (find-package :keyword))
1190 (*print-pretty* nil))
1192 "~S has been deprecated as of SBCL ~A.~
1193 ~#[~;~2%Use ~S instead.~;~2%~
1194 Use ~S or ~S instead.~:;~2%~
1195 Use~@{~#[~; or~] ~S~^,~} instead.~]"
1196 name since replacements))))
1201 (defun ,name ,lambda-list
1206 (declaim (ftype (function * nil) ,name))
1207 (setf (fdefinition ',name)
1208 (deprecated-function ',name ',replacements ,since))
1209 (setf (documentation ',name 'function) ,doc))))
1210 (setf (compiler-macro-function ',name)
1211 (deprecation-compiler-macro ,state ,since ',name ',replacements)))))
1213 (defun check-deprecated-variable (name)
1214 (let ((info (info :variable :deprecated name)))
1216 (deprecation-warning (car info) (cdr info) name nil))))
1218 (defmacro define-deprecated-variable (state since name &key (value nil valuep) replacement)
1220 (setf (info :variable :deprecated ',name) (cons ,state ,since))
1221 ,@(when (member state '(:early :late))
1222 `((defvar ,name ,@(when valuep (list value))
1223 ,(let ((*package* (find-package :keyword)))
1225 "~@<~S has been deprecated as of SBCL ~A~@[, use ~S instead~].~:>"
1226 name since replacement)))))))
1228 ;;; Anaphoric macros
1229 (defmacro awhen (test &body body)
1233 (defmacro acond (&rest clauses)
1236 (destructuring-bind ((test &body body) &rest rest) clauses
1237 (once-only ((test test))
1239 (let ((it ,test)) (declare (ignorable it)),@body)
1242 ;;; (binding* ({(names initial-value [flag])}*) body)
1243 ;;; FLAG may be NIL or :EXIT-IF-NULL
1245 ;;; This form unites LET*, MULTIPLE-VALUE-BIND and AWHEN.
1246 (defmacro binding* ((&rest bindings) &body body)
1247 (let ((bindings (reverse bindings)))
1248 (loop with form = `(progn ,@body)
1249 for binding in bindings
1250 do (destructuring-bind (names initial-value &optional flag)
1252 (multiple-value-bind (names declarations)
1255 (let ((name (gensym)))
1256 (values (list name) `((declare (ignorable ,name))))))
1258 (values (list names) nil))
1260 (collect ((new-names) (ignorable))
1261 (dolist (name names)
1263 (setq name (gensym))
1268 `((declare (ignorable ,@(ignorable)))))))))
1269 (setq form `(multiple-value-bind ,names
1275 `(when ,(first names) ,form)))))))
1276 finally (return form))))
1278 ;;; Delayed evaluation
1279 (defmacro delay (form)
1280 `(cons nil (lambda () ,form)))
1282 (defun force (promise)
1283 (cond ((not (consp promise)) promise)
1284 ((car promise) (cdr promise))
1285 (t (setf (car promise) t
1286 (cdr promise) (funcall (cdr promise))))))
1288 (defun promise-ready-p (promise)
1289 (or (not (consp promise))
1293 (defmacro with-rebound-io-syntax (&body body)
1294 `(%with-rebound-io-syntax (lambda () ,@body)))
1296 (defun %with-rebound-io-syntax (function)
1297 (declare (type function function))
1298 (let ((*package* *package*)
1299 (*print-array* *print-array*)
1300 (*print-base* *print-base*)
1301 (*print-case* *print-case*)
1302 (*print-circle* *print-circle*)
1303 (*print-escape* *print-escape*)
1304 (*print-gensym* *print-gensym*)
1305 (*print-length* *print-length*)
1306 (*print-level* *print-level*)
1307 (*print-lines* *print-lines*)
1308 (*print-miser-width* *print-miser-width*)
1309 (*print-pretty* *print-pretty*)
1310 (*print-radix* *print-radix*)
1311 (*print-readably* *print-readably*)
1312 (*print-right-margin* *print-right-margin*)
1313 (*read-base* *read-base*)
1314 (*read-default-float-format* *read-default-float-format*)
1315 (*read-eval* *read-eval*)
1316 (*read-suppress* *read-suppress*)
1317 (*readtable* *readtable*))
1318 (funcall function)))
1320 ;;; Bind a few "potentially dangerous" printer control variables to
1321 ;;; safe values, respecting current values if possible.
1322 (defmacro with-sane-io-syntax (&body forms)
1323 `(call-with-sane-io-syntax (lambda () ,@forms)))
1325 (defun call-with-sane-io-syntax (function)
1326 (declare (type function function))
1327 (macrolet ((true (sym)
1328 `(and (boundp ',sym) ,sym)))
1329 (let ((*print-readably* nil)
1330 (*print-level* (or (true *print-level*) 6))
1331 (*print-length* (or (true *print-length*) 12)))
1332 (funcall function))))
1334 ;;; Returns a list of members of LIST. Useful for dealing with circular lists.
1335 ;;; For a dotted list returns a secondary value of T -- in which case the
1336 ;;; primary return value does not include the dotted tail.
1337 ;;; If the maximum length is reached, return a secondary value of :MAYBE.
1338 (defun list-members (list &key max-length)
1340 (do ((tail (cdr list) (cdr tail))
1341 (members (list (car list)) (cons (car tail) members))
1342 (count 0 (1+ count)))
1343 ((or (not (consp tail)) (eq tail list)
1344 (and max-length (>= count max-length)))
1345 (values members (or (not (listp tail))
1346 (and (>= count max-length) :maybe)))))))
1348 ;;; Default evaluator mode (interpeter / compiler)
1350 (declaim (type (member :compile #!+sb-eval :interpret) *evaluator-mode*))
1351 (defparameter *evaluator-mode* :compile
1353 "Toggle between different evaluator implementations. If set to :COMPILE,
1354 an implementation of EVAL that calls the compiler will be used. If set
1355 to :INTERPRET, an interpreter will be used.")
1357 ;;; Helper for making the DX closure allocation in macros expanding
1358 ;;; to CALL-WITH-FOO less ugly.
1359 (defmacro dx-flet (functions &body forms)
1361 (declare (#+sb-xc-host dynamic-extent #-sb-xc-host truly-dynamic-extent
1362 ,@(mapcar (lambda (func) `(function ,(car func))) functions)))
1365 ;;; Another similar one.
1366 (defmacro dx-let (bindings &body forms)
1368 (declare (#+sb-xc-host dynamic-extent #-sb-xc-host truly-dynamic-extent
1369 ,@(mapcar (lambda (bind) (if (consp bind) (car bind) bind))
1373 (in-package "SB!KERNEL")
1375 (defun fp-zero-p (x)
1377 (single-float (zerop x))
1378 (double-float (zerop x))
1380 (long-float (zerop x))
1383 (defun neg-fp-zero (x)
1387 (make-unportable-float :single-float-negative-zero)
1391 (make-unportable-float :double-float-negative-zero)
1396 (make-unportable-float :long-float-negative-zero)
1399 ;;; Signalling an error when trying to print an error condition is
1400 ;;; generally a PITA, so whatever the failure encountered when
1401 ;;; wondering about FILE-POSITION within a condition printer, 'tis
1402 ;;; better silently to give up than to try to complain.
1403 (defun file-position-or-nil-for-error (stream &optional (pos nil posp))
1404 ;; Arguably FILE-POSITION shouldn't be signalling errors at all; but
1405 ;; "NIL if this cannot be determined" in the ANSI spec doesn't seem
1406 ;; absolutely unambiguously to prohibit errors when, e.g., STREAM
1407 ;; has been closed so that FILE-POSITION is a nonsense question. So
1408 ;; my (WHN) impression is that the conservative approach is to
1409 ;; IGNORE-ERRORS. (I encountered this failure from within a homebrew
1410 ;; defsystemish operation where the ERROR-STREAM had been CL:CLOSEd,
1411 ;; I think by nonlocally exiting through a WITH-OPEN-FILE, by the
1412 ;; time an error was reported.)
1414 (ignore-errors (file-position stream pos))
1415 (ignore-errors (file-position stream))))
1417 (defun stream-error-position-info (stream &optional position)
1418 (unless (interactive-stream-p stream)
1419 (let ((now (file-position-or-nil-for-error stream))
1421 (when (and (not pos) now (plusp now))
1422 ;; FILE-POSITION is the next character -- error is at the previous one.
1423 (setf pos (1- now)))
1426 (< pos sb!xc:array-dimension-limit)
1427 (file-position stream :start))
1429 (make-string pos :element-type (stream-element-type stream))))
1430 (when (= pos (read-sequence string stream))
1431 ;; Lines count from 1, columns from 0. It's stupid and traditional.
1432 (setq lineno (1+ (count #\Newline string))
1433 colno (- pos (or (position #\Newline string :from-end t) 0)))))
1434 (file-position-or-nil-for-error stream now))
1435 (remove-if-not #'second
1436 (list (list :line lineno)
1437 (list :column colno)
1438 (list :file-position pos)))))))
1440 (declaim (inline schwartzian-stable-sort-list))
1441 (defun schwartzian-stable-sort-list (list comparator &key key)
1443 (stable-sort (copy-list list) comparator)
1444 (let* ((key (if (functionp key)
1446 (symbol-function key)))
1447 (wrapped (mapcar (lambda (x)
1448 (cons x (funcall key x)))
1450 (sorted (stable-sort wrapped comparator :key #'cdr)))
1451 (map-into sorted #'car sorted))))