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 arrays, and for related quantities
34 ;;; like lengths of lists
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
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
)))
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))))
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
)))
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))))
65 (error "Bad size specified for UNSIGNED-BYTE type specifier: ~S." s
))))
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))))
74 (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s
))))
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
)
82 ,(truncate (- (+ (1- (ash 1 16)) lowtag
)
83 (* max-offset sb
!vm
:n-word-bytes
))
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
)
92 (max (truncate (+ sb
!vm
::maximum-immediate-offset adjustment
)
97 (def!type constant-displacement
(lowtag element-size data-offset
)
98 (flet ((integerify (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
108 `(integer ,min
,max
)))))
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
'*) '*)
117 (not (eq (car result
) 'values
)))
118 `(values ,result
&optional
))
119 ((intersection (cdr result
) sb
!xc
:lambda-list-keywords
)
121 (t `(values ,@(cdr result
) &optional
)))))
122 `(function ,args
,result
)))
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
))
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.
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)))
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
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?) --
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)
170 ;;;; type-ish predicates
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))
179 (labels ((safe-cddr (cons)
180 (let ((cdr (cdr cons
)))
183 (check-cycle (object seen depth
)
184 (when (and (consp object
)
185 (or (> depth depth-limit
)
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
)))
196 ;; Not CDR-circular, need to check remaining CARs yet
197 (do ((tail slow
(and (cdr tail
))))
200 (check-cycle (car tail
) (cons tail seen
) (1+ depth
))))
201 (check-cycle (car slow
) (cons slow seen
) (1+ depth
))
204 (circularp x
(list x
) 0))))
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
211 (list-of-length-at-least-p (cdr x
) (1- n
)))))
213 (declaim (inline singleton-p
))
214 (defun singleton-p (list)
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.)
226 (and (>= x
2) (/= x
4))
228 (not (zerop (rem x
3)))
231 (inc 2 (logxor inc
6)) ;; 2,4,2,4...
233 ((or (= r
0) (> d q
)) (/= r
0))
234 (declare (fixnum inc
))
235 (multiple-value-setq (q r
) (truncate x d
))))))
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)
242 (typep x
'(array t
*))))
244 ;;;; the COLLECT macro
246 ;;;; comment from CMU CL: "the ultimate collection macro..."
248 ;;; helper functions for COLLECT, which become the expanders of the
249 ;;; MACROLET definitions created by COLLECT
251 ;;; COLLECT-NORMAL-EXPANDER handles normal collection macros.
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
256 (eval-when (#-sb-xc
:compile-toplevel
:load-toplevel
:execute
)
257 (defun collect-normal-expander (n-value fun forms
)
259 ,@(mapcar (lambda (form) `(setq ,n-value
(,fun
,form
,n-value
))) forms
)
261 (defun collect-list-expander (n-value n-tail forms
)
262 (let ((n-res (gensym)))
264 ,@(mapcar (lambda (form)
265 `(let ((,n-res
(cons ,form nil
)))
267 (setf (cdr ,n-tail
) ,n-res
)
268 (setq ,n-tail
,n-res
))
270 (setq ,n-tail
,n-res
,n-value
,n-res
)))))
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.
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
)
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
305 (push `(,n-value
,default
) binds
)
306 (if (eq kind
'collect
)
307 (let ((n-tail (gensym (concatenate 'string
311 (push `(,n-tail
(last ,n-value
)) binds
)
313 (push `(,name
(&rest args
)
314 (collect-list-expander ',n-value
',n-tail args
))
316 (push `(,name
(&rest args
)
317 (collect-normal-expander ',n-value
',kind args
))
319 `(macrolet ,macros
(let* ,(nreverse binds
) ,@body
))))
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
326 ;;; like (MEMBER ITEM LIST :TEST #'EQ)
327 (defun memq (item list
)
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
)))
339 (when (eq (car i
) item
)
342 ;;; like (ASSOC ITEM ALIST :TEST #'EQ):
343 ;;; Return the first pair of ALIST where ITEM is EQ to the key of
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
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
)))
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
)
369 (do ((x list
(cdr x
))
372 (cond ((eq item
(car x
))
375 (rplacd splice
(cdr x
))))
376 (t (setq splice x
)))))) ; Move splice along to include element.
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
))
385 (when (eq (car i
) item
)
388 (declaim (inline neq
))
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
)
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
))
410 ;;;; miscellaneous iteration extensions
412 ;;; like Scheme's named LET
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
)
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
))))
424 (defun filter-dolist-declarations (decls)
425 (mapcar (lambda (decl)
426 `(declare ,@(remove-if
429 (or (eq (car clause
) 'type
)
430 (eq (car clause
) 'ignore
))))
434 ;;; just like DOLIST, but with one-dimensional arrays
435 (defmacro dovector
((elt vector
&optional result
) &body body
)
436 (multiple-value-bind (forms decls
) (parse-body body
:doc-string-allowed nil
)
437 (with-unique-names (index length vec
)
438 `(let ((,vec
,vector
))
439 (declare (type vector
,vec
))
440 (do ((,index
0 (1+ ,index
))
441 (,length
(length ,vec
)))
442 ((>= ,index
,length
) (let ((,elt nil
))
443 ,@(filter-dolist-declarations decls
)
446 (let ((,elt
(aref ,vec
,index
)))
451 ;;; Iterate over the entries in a HASH-TABLE, first obtaining the lock
452 ;;; if the table is a synchronized table.
453 (defmacro dohash
(((key-var value-var
) table
&key result locked
) &body body
)
454 (multiple-value-bind (forms decls
) (parse-body body
:doc-string-allowed nil
)
455 (with-unique-names (gen n-more n-table
)
456 (let ((iter-form `(with-hash-table-iterator (,gen
,n-table
)
458 (multiple-value-bind (,n-more
,key-var
,value-var
) (,gen
)
460 (unless ,n-more
(return ,result
))
462 `(let ((,n-table
,table
))
464 `(with-locked-hash-table (,n-table
)
468 ;;;; hash cache utility
470 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
471 (defvar *profile-hash-cache
* nil
))
473 ;;; a flag for whether it's too early in cold init to use caches so
474 ;;; that we have a better chance of recovering so that we have a
475 ;;; better chance of getting the system running so that we have a
476 ;;; better chance of diagnosing the problem which caused us to use the
479 (defvar *hash-caches-initialized-p
*)
481 ;;; Define a hash cache that associates some number of argument values
482 ;;; with a result value. The TEST-FUNCTION paired with each ARG-NAME
483 ;;; is used to compare the value for that arg in a cache entry with a
484 ;;; supplied arg. The TEST-FUNCTION must not error when passed NIL as
485 ;;; its first arg, but need not return any particular value.
486 ;;; TEST-FUNCTION may be any thing that can be placed in CAR position.
488 ;;; This code used to store all the arguments / return values directly
489 ;;; in the cache vector. This was both interrupt- and thread-unsafe, since
490 ;;; it was possible that *-CACHE-ENTER would scribble over a region of the
491 ;;; cache vector which *-CACHE-LOOKUP had only partially processed. Instead
492 ;;; we now store the contents of each cache bucket as a separate array, which
493 ;;; is stored in the appropriate cell in the cache vector. A new bucket array
494 ;;; is created every time *-CACHE-ENTER is called, and the old ones are never
495 ;;; modified. This means that *-CACHE-LOOKUP will always work with a set
496 ;;; of consistent data. The overhead caused by consing new buckets seems to
497 ;;; be insignificant on the grand scale of things. -- JES, 2006-11-02
499 ;;; NAME is used to define these functions:
500 ;;; <name>-CACHE-LOOKUP Arg*
501 ;;; See whether there is an entry for the specified ARGs in the
502 ;;; cache. If not present, the :DEFAULT keyword (default NIL)
503 ;;; determines the result(s).
504 ;;; <name>-CACHE-ENTER Arg* Value*
505 ;;; Encache the association of the specified args with VALUE.
506 ;;; <name>-CACHE-CLEAR
507 ;;; Reinitialize the cache, invalidating all entries and allowing
508 ;;; the arguments and result values to be GC'd.
510 ;;; These other keywords are defined:
512 ;;; The size of the cache as a power of 2.
513 ;;; :HASH-FUNCTION function
514 ;;; Some thing that can be placed in CAR position which will compute
515 ;;; a value between 0 and (1- (expt 2 <hash-bits>)).
517 ;;; the number of return values cached for each function call
518 ;;; :INIT-WRAPPER <name>
519 ;;; The code for initializing the cache is wrapped in a form with
520 ;;; the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS
521 ;;; in type system definitions so that caches will be created
522 ;;; before top level forms run.)
523 (defmacro define-hash-cache
(name args
&key hash-function hash-bits default
524 (init-wrapper 'progn
)
526 (let* ((var-name (symbolicate "*" name
"-CACHE-VECTOR*"))
527 (probes-name (when *profile-hash-cache
*
528 (symbolicate "*" name
"-CACHE-PROBES*")))
529 (misses-name (when *profile-hash-cache
*
530 (symbolicate "*" name
"-CACHE-MISSES*")))
531 (nargs (length args
))
532 (size (ash 1 hash-bits
))
533 (default-values (if (and (consp default
) (eq (car default
) 'values
))
536 (args-and-values (sb!xc
:gensym
"ARGS-AND-VALUES"))
537 (args-and-values-size (+ nargs values
))
538 (n-index (sb!xc
:gensym
"INDEX"))
539 (n-cache (sb!xc
:gensym
"CACHE")))
540 (declare (ignorable probes-name misses-name
))
541 (unless (= (length default-values
) values
)
542 (error "The number of default values ~S differs from :VALUES ~W."
554 (let ((name (sb!xc
:gensym
"VALUE")))
556 (values-refs `(svref ,args-and-values
(+ ,nargs
,i
)))
557 (sets `(setf (svref ,args-and-values
(+ ,nargs
,i
)) ,name
))))
560 (unless (= (length arg
) 2)
561 (error "bad argument spec: ~S" arg
))
562 (let ((arg-name (first arg
))
565 (tests `(,test
(svref ,args-and-values
,n
) ,arg-name
))
566 (sets `(setf (svref ,args-and-values
,n
) ,arg-name
)))
569 (when *profile-hash-cache
*
570 (inits `(setq ,probes-name
0))
571 (inits `(setq ,misses-name
0))
572 (forms `(declaim (fixnum ,probes-name
,misses-name
))))
574 (let ((fun-name (symbolicate name
"-CACHE-LOOKUP")))
577 `(defun ,fun-name
,(arg-vars)
578 ,@(when *profile-hash-cache
*
579 `((incf ,probes-name
)))
580 (let* ((,n-index
(,hash-function
,@(arg-vars)))
582 (,args-and-values
(svref ,n-cache
,n-index
)))
583 (cond ((and ,args-and-values
585 (values ,@(values-refs)))
587 ,@(when *profile-hash-cache
*
588 `((incf ,misses-name
)))
591 (let ((fun-name (symbolicate name
"-CACHE-ENTER")))
594 `(defun ,fun-name
(,@(arg-vars) ,@(values-names))
595 (let ((,n-index
(,hash-function
,@(arg-vars)))
597 (,args-and-values
(make-array ,args-and-values-size
)))
599 (setf (svref ,n-cache
,n-index
) ,args-and-values
))
602 (let ((fun-name (symbolicate name
"-CACHE-CLEAR")))
605 (fill ,var-name nil
)))
606 (forms `(,fun-name
)))
608 (inits `(unless (boundp ',var-name
)
609 (setq ,var-name
(make-array ,size
:initial-element nil
))))
610 #!+sb-show
(inits `(setq *hash-caches-initialized-p
* t
))
614 ,@(when *profile-hash-cache
*
615 `((defvar ,probes-name
)
616 (defvar ,misses-name
)))
617 (declaim (type (simple-vector ,size
) ,var-name
))
618 #!-sb-fluid
(declaim (inline ,@(inlines)))
619 (,init-wrapper
,@(inits))
623 ;;; some syntactic sugar for defining a function whose values are
624 ;;; cached by DEFINE-HASH-CACHE
625 (defmacro defun-cached
((name &rest options
&key
(values 1) default
627 args
&body body-decls-doc
)
628 (let ((default-values (if (and (consp default
) (eq (car default
) 'values
))
631 (arg-names (mapcar #'car args
))
632 (values-names (make-gensym-list values
)))
633 (multiple-value-bind (body decls doc
) (parse-body body-decls-doc
)
635 (define-hash-cache ,name
,args
,@options
)
636 (defun ,name
,arg-names
640 ((not (boundp '*hash-caches-initialized-p
*))
641 ;; This shouldn't happen, but it did happen to me
642 ;; when revising the type system, and it's a lot
643 ;; easier to figure out what what's going on with
644 ;; that kind of problem if the system can be kept
645 ;; alive until cold boot is complete. The recovery
646 ;; mechanism should definitely be conditional on some
647 ;; debugging feature (e.g. SB-SHOW) because it's big,
648 ;; duplicating all the BODY code. -- WHN
649 (/show0
,name
" too early in cold init, uncached")
650 (/show0
,(first arg-names
) "=..")
651 (/hexstr
,(first arg-names
))
654 (multiple-value-bind ,values-names
655 (,(symbolicate name
"-CACHE-LOOKUP") ,@arg-names
)
656 (if (and ,@(mapcar (lambda (val def
)
658 values-names default-values
))
659 (multiple-value-bind ,values-names
661 (,(symbolicate name
"-CACHE-ENTER") ,@arg-names
663 (values ,@values-names
))
664 (values ,@values-names
))))))))))
666 (defmacro define-cached-synonym
667 (name &optional
(original (symbolicate "%" name
)))
668 (let ((cached-name (symbolicate "%%" name
"-CACHED")))
670 (defun-cached (,cached-name
:hash-bits
8
671 :hash-function
(lambda (x)
672 (logand (sxhash x
) #xff
)))
674 (apply #',original args
))
675 (defun ,name
(&rest args
)
676 (,cached-name args
)))))
678 ;;; FIXME: maybe not the best place
680 ;;; FIXME: think of a better name -- not only does this not have the
681 ;;; CAR recursion of EQUAL, it also doesn't have the special treatment
682 ;;; of pathnames, bit-vectors and strings.
684 ;;; KLUDGE: This means that we will no longer cache specifiers of the
685 ;;; form '(INTEGER (0) 4). This is probably not a disaster.
687 ;;; A helper function for the type system, which is the main user of
688 ;;; these caches: we must be more conservative than EQUAL for some of
689 ;;; our equality tests, because MEMBER and friends refer to EQLity.
691 (defun equal-but-no-car-recursion (x y
)
696 (eql (car x
) (car y
))
697 (equal-but-no-car-recursion (cdr x
) (cdr y
))))
702 ;;; Note: Almost always you want to use FIND-UNDELETED-PACKAGE-OR-LOSE
703 ;;; instead of this function. (The distinction only actually matters when
704 ;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case
705 ;;; you generally do want to signal an error instead of proceeding.)
706 (defun %find-package-or-lose
(package-designator)
707 (or (find-package package-designator
)
708 (error 'sb
!kernel
:simple-package-error
709 :package package-designator
710 :format-control
"The name ~S does not designate any package."
711 :format-arguments
(list package-designator
))))
713 ;;; ANSI specifies (in the section for FIND-PACKAGE) that the
714 ;;; consequences of most operations on deleted packages are
715 ;;; unspecified. We try to signal errors in such cases.
716 (defun find-undeleted-package-or-lose (package-designator)
717 (let ((maybe-result (%find-package-or-lose package-designator
)))
718 (if (package-name maybe-result
) ; if not deleted
720 (error 'sb
!kernel
:simple-package-error
721 :package maybe-result
722 :format-control
"The package ~S has been deleted."
723 :format-arguments
(list maybe-result
)))))
725 ;;;; various operations on names
727 ;;; Is NAME a legal function name?
728 (declaim (inline legal-fun-name-p
))
729 (defun legal-fun-name-p (name)
730 (values (valid-function-name-p name
)))
732 (deftype function-name
() '(satisfies legal-fun-name-p
))
734 ;;; Signal an error unless NAME is a legal function name.
735 (defun legal-fun-name-or-type-error (name)
736 (unless (legal-fun-name-p name
)
737 (error 'simple-type-error
739 :expected-type
'function-name
740 :format-control
"invalid function name: ~S"
741 :format-arguments
(list name
))))
743 ;;; Given a function name, return the symbol embedded in it.
745 ;;; The ordinary use for this operator (and the motivation for the
746 ;;; name of this operator) is to convert from a function name to the
747 ;;; name of the BLOCK which encloses its body.
749 ;;; Occasionally the operator is useful elsewhere, where the operator
750 ;;; name is less mnemonic. (Maybe it should be changed?)
751 (declaim (ftype (function ((or symbol cons
)) symbol
) fun-name-block-name
))
752 (defun fun-name-block-name (fun-name)
753 (cond ((symbolp fun-name
)
756 (multiple-value-bind (legalp block-name
)
757 (valid-function-name-p fun-name
)
760 (error "not legal as a function name: ~S" fun-name
))))
762 (error "not legal as a function name: ~S" fun-name
))))
764 (defun looks-like-name-of-special-var-p (x)
766 (let ((name (symbol-name x
)))
767 (and (> (length name
) 2) ; to exclude '* and '**
768 (char= #\
* (aref name
0))
769 (char= #\
* (aref name
(1- (length name
))))))))
771 ;;; This function is to be called just before a change which would affect the
772 ;;; symbol value. We don't absolutely have to call this function before such
773 ;;; changes, since such changes to constants are given as undefined behavior,
774 ;;; it's nice to do so. To circumvent this you need code like this:
777 ;;; (defun set-foo (x) (setq foo x))
778 ;;; (defconstant foo 42)
780 ;;; foo => 13, (constantp 'foo) => t
782 ;;; ...in which case you frankly deserve to lose.
783 (defun about-to-modify-symbol-value (symbol action
&optional
(new-value nil valuep
) bind
)
784 (declare (symbol symbol
))
785 (flet ((describe-action ()
787 (set "set SYMBOL-VALUE of ~S")
789 (compare-and-swap "compare-and-swap SYMBOL-VALUE of ~S")
790 (defconstant "define ~S as a constant")
791 (makunbound "make ~S unbound"))))
792 (let ((kind (info :variable
:kind symbol
)))
793 (multiple-value-bind (what continue
)
794 (cond ((eq :constant kind
)
796 (values "Veritas aeterna. (can't ~@?)" nil
))
798 (values "Nihil ex nihil. (can't ~@?)" nil
))
800 (values "Can't ~@?." nil
))
802 (values "Constant modification: attempt to ~@?." t
))))
803 ((and bind
(eq :global kind
))
804 (values "Can't ~@? (global variable)." nil
)))
807 (cerror "Modify the constant." what
(describe-action) symbol
)
808 (error what
(describe-action) symbol
)))
810 ;; :VARIABLE :TYPE is in the db only if it is declared, so no need to
812 (let ((type (info :variable
:type symbol
)))
813 (unless (sb!kernel
::%%typep new-value type nil
)
814 (let ((spec (type-specifier type
)))
815 (error 'simple-type-error
816 :format-control
"~@<Cannot ~@? to ~S, not of type ~S.~:@>"
817 :format-arguments
(list (describe-action) symbol new-value spec
)
819 :expected-type spec
))))))))
822 ;;; If COLD-FSET occurs not at top level, just treat it as an ordinary
823 ;;; assignment instead of doing cold static linking. That way things like
824 ;;; (FLET ((FROB (X) ..))
825 ;;; (DEFUN FOO (X Y) (FROB X) ..)
826 ;;; (DEFUN BAR (Z) (AND (FROB X) ..)))
827 ;;; can still "work" for cold init: they don't do magical static
828 ;;; linking the way that true toplevel DEFUNs do, but at least they do
829 ;;; the linking eventually, so as long as #'FOO and #'BAR aren't
830 ;;; needed until "cold toplevel forms" have executed, it's OK.
831 (defmacro cold-fset
(name lambda
)
833 "~@<COLD-FSET ~S not cross-compiled at top level: demoting to ~
834 (SETF FDEFINITION)~:@>"
836 ;; We convert the LAMBDA expression to the corresponding NAMED-LAMBDA
837 ;; expression so that the compiler can use NAME in debug names etc.
838 (destructuring-bind (lambda-symbol &rest lambda-rest
) lambda
839 (assert (eql lambda-symbol
'lambda
)) ; else dunno how to do conversion
840 `(setf (fdefinition ',name
)
841 (named-lambda ,name
,@lambda-rest
))))
845 ;;;; "The macro ONCE-ONLY has been around for a long time on various
846 ;;;; systems [..] if you can understand how to write and when to use
847 ;;;; ONCE-ONLY, then you truly understand macro." -- Peter Norvig,
848 ;;;; _Paradigms of Artificial Intelligence Programming: Case Studies
849 ;;;; in Common Lisp_, p. 853
851 ;;; ONCE-ONLY is a utility useful in writing source transforms and
852 ;;; macros. It provides a concise way to wrap a LET around some code
853 ;;; to ensure that some forms are only evaluated once.
855 ;;; Create a LET* which evaluates each value expression, binding a
856 ;;; temporary variable to the result, and wrapping the LET* around the
857 ;;; result of the evaluation of BODY. Within the body, each VAR is
858 ;;; bound to the corresponding temporary variable.
859 (defmacro once-only
(specs &body body
)
860 (named-let frob
((specs specs
)
864 (let ((spec (first specs
)))
865 ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
866 (unless (proper-list-of-length-p spec
2)
867 (error "malformed ONCE-ONLY binding spec: ~S" spec
))
868 (let* ((name (first spec
))
869 (exp-temp (gensym "ONCE-ONLY")))
870 `(let ((,exp-temp
,(second spec
))
871 (,name
(gensym ,(symbol-name name
))))
872 `(let ((,,name
,,exp-temp
))
873 ,,(frob (rest specs
) body
))))))))
875 ;;;; various error-checking utilities
877 ;;; This function can be used as the default value for keyword
878 ;;; arguments that must be always be supplied. Since it is known by
879 ;;; the compiler to never return, it will avoid any compile-time type
880 ;;; warnings that would result from a default value inconsistent with
881 ;;; the declared type. When this function is called, it signals an
882 ;;; error indicating that a required &KEY argument was not supplied.
883 ;;; This function is also useful for DEFSTRUCT slot defaults
884 ;;; corresponding to required arguments.
885 (declaim (ftype (function () nil
) missing-arg
))
886 (defun missing-arg ()
888 (/show0
"entering MISSING-ARG")
889 (error "A required &KEY or &OPTIONAL argument was not supplied."))
891 ;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
893 ;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT.
894 ;;; The CL:ASSERT restarts and whatnot expand into a significant
895 ;;; amount of code when you multiply them by 400, so replacing them
896 ;;; with this should reduce the size of the system by enough to be
897 ;;; worthwhile. ENFORCE-TYPE is much less common, but might still be
898 ;;; worthwhile, and since I don't really like CERROR stuff deep in the
899 ;;; guts of complex systems anyway, I replaced it too.)
900 (defmacro aver
(expr)
902 (%failed-aver
',expr
)))
904 (defun %failed-aver
(expr)
905 ;; hackish way to tell we're in a cold sbcl and output the
906 ;; message before signalling error, as it may be this is too
907 ;; early in the cold init.
908 (when (find-package "SB!C")
910 (write-line "failed AVER:")
913 (bug "~@<failed AVER: ~2I~_~A~:>" expr
))
915 (defun bug (format-control &rest format-arguments
)
917 :format-control format-control
918 :format-arguments format-arguments
))
920 (defmacro enforce-type
(value type
)
921 (once-only ((value value
))
922 `(unless (typep ,value
',type
)
923 (%failed-enforce-type
,value
',type
))))
925 (defun %failed-enforce-type
(value type
)
926 ;; maybe should be TYPE-BUG, subclass of BUG? If it is changed,
927 ;; check uses of it in user-facing code (e.g. WARN)
928 (error 'simple-type-error
931 :format-control
"~@<~S ~_is not a ~_~S~:>"
932 :format-arguments
(list value type
)))
934 ;;; Return a function like FUN, but expecting its (two) arguments in
935 ;;; the opposite order that FUN does.
936 (declaim (inline swapped-args-fun
))
937 (defun swapped-args-fun (fun)
938 (declare (type function fun
))
942 ;;; Return the numeric value of a type bound, i.e. an interval bound
943 ;;; more or less in the format of bounds in ANSI's type specifiers,
944 ;;; where a bare numeric value is a closed bound and a list of a
945 ;;; single numeric value is an open bound.
947 ;;; The "more or less" bit is that the no-bound-at-all case is
948 ;;; represented by NIL (not by * as in ANSI type specifiers); and in
949 ;;; this case we return NIL.
950 (defun type-bound-number (x)
952 (destructuring-bind (result) x result
)
955 ;;; some commonly-occuring CONSTANTLY forms
956 (macrolet ((def-constantly-fun (name constant-expr
)
957 `(setf (symbol-function ',name
)
958 (constantly ,constant-expr
))))
959 (def-constantly-fun constantly-t t
)
960 (def-constantly-fun constantly-nil nil
)
961 (def-constantly-fun constantly-0
0))
963 ;;; If X is a symbol, see whether it is present in *FEATURES*. Also
964 ;;; handle arbitrary combinations of atoms using NOT, AND, OR.
972 (error "too many subexpressions in feature expression: ~S" x
))
974 (error "too few subexpressions in feature expression: ~S" x
))
975 (t (not (featurep (cadr x
))))))
976 ((:and and
) (every #'featurep
(cdr x
)))
977 ((:or or
) (some #'featurep
(cdr x
)))
979 (error "unknown operator in feature expression: ~S." x
))))
980 (symbol (not (null (memq x
*features
*))))))
982 ;;;; utilities for two-VALUES predicates
984 (defmacro not
/type
(x)
985 (let ((val (gensym "VAL"))
986 (win (gensym "WIN")))
987 `(multiple-value-bind (,val
,win
)
990 (values (not ,val
) t
)
993 (defmacro and
/type
(x y
)
994 `(multiple-value-bind (val1 win1
) ,x
995 (if (and (not val1
) win1
)
997 (multiple-value-bind (val2 win2
) ,y
1000 (values nil
(and win2
(not val2
))))))))
1002 ;;; sort of like ANY and EVERY, except:
1003 ;;; * We handle two-VALUES predicate functions, as SUBTYPEP does.
1004 ;;; (And if the result is uncertain, then we return (VALUES NIL NIL),
1005 ;;; as SUBTYPEP does.)
1006 ;;; * THING is just an atom, and we apply OP (an arity-2 function)
1007 ;;; successively to THING and each element of LIST.
1008 (defun any/type
(op thing list
)
1009 (declare (type function op
))
1011 (dolist (i list
(values nil certain?
))
1012 (multiple-value-bind (sub-value sub-certain?
) (funcall op thing i
)
1014 (when sub-value
(return (values t t
)))
1015 (setf certain? nil
))))))
1016 (defun every/type
(op thing list
)
1017 (declare (type function op
))
1019 (dolist (i list
(if certain?
(values t t
) (values nil nil
)))
1020 (multiple-value-bind (sub-value sub-certain?
) (funcall op thing i
)
1022 (unless sub-value
(return (values nil t
)))
1023 (setf certain? nil
))))))
1027 ;;; These functions are called by the expansion of the DEFPRINTER
1028 ;;; macro to do the actual printing.
1029 (declaim (ftype (function (symbol t stream
) (values))
1030 defprinter-prin1 defprinter-princ
))
1031 (defun defprinter-prin1 (name value stream
)
1032 (defprinter-prinx #'prin1 name value stream
))
1033 (defun defprinter-princ (name value stream
)
1034 (defprinter-prinx #'princ name value stream
))
1035 (defun defprinter-prinx (prinx name value stream
)
1036 (declare (type function prinx
))
1037 (when *print-pretty
*
1038 (pprint-newline :linear stream
))
1039 (format stream
":~A " name
)
1040 (funcall prinx value stream
)
1042 (defun defprinter-print-space (stream)
1043 (write-char #\space stream
))
1045 ;;; Define some kind of reasonable PRINT-OBJECT method for a
1046 ;;; STRUCTURE-OBJECT class.
1048 ;;; NAME is the name of the structure class, and CONC-NAME is the same
1049 ;;; as in DEFSTRUCT.
1051 ;;; The SLOT-DESCS describe how each slot should be printed. Each
1052 ;;; SLOT-DESC can be a slot name, indicating that the slot should
1053 ;;; simply be printed. A SLOT-DESC may also be a list of a slot name
1054 ;;; and other stuff. The other stuff is composed of keywords followed
1055 ;;; by expressions. The expressions are evaluated with the variable
1056 ;;; which is the slot name bound to the value of the slot. These
1057 ;;; keywords are defined:
1059 ;;; :PRIN1 Print the value of the expression instead of the slot value.
1060 ;;; :PRINC Like :PRIN1, only PRINC the value
1061 ;;; :TEST Only print something if the test is true.
1063 ;;; If no printing thing is specified then the slot value is printed
1066 ;;; The structure being printed is bound to STRUCTURE and the stream
1067 ;;; is bound to STREAM.
1068 (defmacro defprinter
((name
1070 (conc-name (concatenate 'simple-string
1077 (reversed-prints nil
)
1078 (stream (sb!xc
:gensym
"STREAM")))
1079 (flet ((sref (slot-name)
1080 `(,(symbolicate conc-name slot-name
) structure
)))
1081 (dolist (slot-desc slot-descs
)
1083 (setf maybe-print-space nil
1085 (setf maybe-print-space
`(defprinter-print-space ,stream
)))
1086 (cond ((atom slot-desc
)
1087 (push maybe-print-space reversed-prints
)
1088 (push `(defprinter-prin1 ',slot-desc
,(sref slot-desc
) ,stream
)
1091 (let ((sname (first slot-desc
))
1094 (do ((option (rest slot-desc
) (cddr option
)))
1096 (push `(let ((,sname
,(sref sname
)))
1101 ',sname
,sname
,stream
)))))
1103 (case (first option
)
1105 (stuff `(defprinter-prin1
1106 ',sname
,(second option
) ,stream
)))
1108 (stuff `(defprinter-princ
1109 ',sname
,(second option
) ,stream
)))
1110 (:test
(setq test
(second option
)))
1112 (error "bad option: ~S" (first option
)))))))))))
1113 `(def!method print-object
((structure ,name
) ,stream
)
1114 (pprint-logical-block (,stream nil
)
1115 (print-unreadable-object (structure
1118 :identity
,identity
)
1119 ,@(nreverse reversed-prints
))))))
1123 ;;; Given a pathname, return a corresponding physical pathname.
1124 (defun physicalize-pathname (possibly-logical-pathname)
1125 (if (typep possibly-logical-pathname
'logical-pathname
)
1126 (translate-logical-pathname possibly-logical-pathname
)
1127 possibly-logical-pathname
))
1129 (defun deprecation-warning (bad-name &optional good-name
)
1130 (warn "using deprecated ~S~@[, should use ~S instead~]"
1134 ;;; Anaphoric macros
1135 (defmacro awhen
(test &body body
)
1139 (defmacro acond
(&rest clauses
)
1142 (destructuring-bind ((test &body body
) &rest rest
) clauses
1143 (once-only ((test test
))
1145 (let ((it ,test
)) (declare (ignorable it
)),@body
)
1148 ;;; (binding* ({(names initial-value [flag])}*) body)
1149 ;;; FLAG may be NIL or :EXIT-IF-NULL
1151 ;;; This form unites LET*, MULTIPLE-VALUE-BIND and AWHEN.
1152 (defmacro binding
* ((&rest bindings
) &body body
)
1153 (let ((bindings (reverse bindings
)))
1154 (loop with form
= `(progn ,@body
)
1155 for binding in bindings
1156 do
(destructuring-bind (names initial-value
&optional flag
)
1158 (multiple-value-bind (names declarations
)
1161 (let ((name (gensym)))
1162 (values (list name
) `((declare (ignorable ,name
))))))
1164 (values (list names
) nil
))
1166 (collect ((new-names) (ignorable))
1167 (dolist (name names
)
1169 (setq name
(gensym))
1174 `((declare (ignorable ,@(ignorable)))))))))
1175 (setq form
`(multiple-value-bind ,names
1181 `(when ,(first names
) ,form
)))))))
1182 finally
(return form
))))
1184 ;;; Delayed evaluation
1185 (defmacro delay
(form)
1186 `(cons nil
(lambda () ,form
)))
1188 (defun force (promise)
1189 (cond ((not (consp promise
)) promise
)
1190 ((car promise
) (cdr promise
))
1191 (t (setf (car promise
) t
1192 (cdr promise
) (funcall (cdr promise
))))))
1194 (defun promise-ready-p (promise)
1195 (or (not (consp promise
))
1199 (defmacro with-rebound-io-syntax
(&body body
)
1200 `(%with-rebound-io-syntax
(lambda () ,@body
)))
1202 (defun %with-rebound-io-syntax
(function)
1203 (declare (type function function
))
1204 (let ((*package
* *package
*)
1205 (*print-array
* *print-array
*)
1206 (*print-base
* *print-base
*)
1207 (*print-case
* *print-case
*)
1208 (*print-circle
* *print-circle
*)
1209 (*print-escape
* *print-escape
*)
1210 (*print-gensym
* *print-gensym
*)
1211 (*print-length
* *print-length
*)
1212 (*print-level
* *print-level
*)
1213 (*print-lines
* *print-lines
*)
1214 (*print-miser-width
* *print-miser-width
*)
1215 (*print-pretty
* *print-pretty
*)
1216 (*print-radix
* *print-radix
*)
1217 (*print-readably
* *print-readably
*)
1218 (*print-right-margin
* *print-right-margin
*)
1219 (*read-base
* *read-base
*)
1220 (*read-default-float-format
* *read-default-float-format
*)
1221 (*read-eval
* *read-eval
*)
1222 (*read-suppress
* *read-suppress
*)
1223 (*readtable
* *readtable
*))
1224 (funcall function
)))
1226 ;;; Bind a few "potentially dangerous" printer control variables to
1227 ;;; safe values, respecting current values if possible.
1228 (defmacro with-sane-io-syntax
(&body forms
)
1229 `(call-with-sane-io-syntax (lambda () ,@forms
)))
1231 (defun call-with-sane-io-syntax (function)
1232 (declare (type function function
))
1233 (macrolet ((true (sym)
1234 `(and (boundp ',sym
) ,sym
)))
1235 (let ((*print-readably
* nil
)
1236 (*print-level
* (or (true *print-level
*) 6))
1237 (*print-length
* (or (true *print-length
*) 12)))
1238 (funcall function
))))
1240 ;;; Returns a list of members of LIST. Useful for dealing with circular lists.
1241 ;;; For a dotted list returns a secondary value of T -- in which case the
1242 ;;; primary return value does not include the dotted tail.
1243 (defun list-members (list)
1245 (do ((tail (cdr list
) (cdr tail
))
1246 (members (list (car list
)) (cons (car tail
) members
)))
1247 ((or (not (consp tail
)) (eq tail list
))
1248 (values members
(not (listp tail
)))))))
1250 ;;; Default evaluator mode (interpeter / compiler)
1252 (declaim (type (member :compile
#!+sb-eval
:interpret
) *evaluator-mode
*))
1253 (defparameter *evaluator-mode
* :compile
1255 "Toggle between different evaluator implementations. If set to :COMPILE,
1256 an implementation of EVAL that calls the compiler will be used. If set
1257 to :INTERPRET, an interpreter will be used.")
1259 ;;; Helper for making the DX closure allocation in macros expanding
1260 ;;; to CALL-WITH-FOO less ugly.
1261 (defmacro dx-flet
(functions &body forms
)
1263 (declare (#+sb-xc-host dynamic-extent
#-sb-xc-host truly-dynamic-extent
1264 ,@(mapcar (lambda (func) `(function ,(car func
))) functions
)))
1267 ;;; Another similar one.
1268 (defmacro dx-let
(bindings &body forms
)
1270 (declare (#+sb-xc-host dynamic-extent
#-sb-xc-host truly-dynamic-extent
1271 ,@(mapcar (lambda (bind) (if (consp bind
) (car bind
) bind
))
1275 (in-package "SB!KERNEL")
1277 (defun fp-zero-p (x)
1279 (single-float (zerop x
))
1280 (double-float (zerop x
))
1282 (long-float (zerop x
))
1285 (defun neg-fp-zero (x)
1289 (make-unportable-float :single-float-negative-zero
)
1293 (make-unportable-float :double-float-negative-zero
)
1298 (make-unportable-float :long-float-negative-zero
)