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