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(defglobal *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 sequences, and for related 34;;; quantities like lengths of lists and other sequences. 35;;; 36;;; A more correct value for the exclusive upper bound for indexing 37;;; would be (1- ARRAY-DIMENSION-LIMIT) since ARRAY-DIMENSION-LIMIT is 38;;; the exclusive maximum *size* of one array dimension (As specified 39;;; in CLHS entries for MAKE-ARRAY and "valid array dimensions"). The 40;;; current value is maintained to avoid breaking existing code that 41;;; also uses that type for upper bounds on indices (e.g. sequence 42;;; length). 43;;; 44;;; In SBCL, ARRAY-DIMENSION-LIMIT is arranged to be a little smaller 45;;; than MOST-POSITIVE-FIXNUM, for implementation (see comment above 46;;; ARRAY-DIMENSION-LIMIT) and efficiency reasons: staying below 47;;; MOST-POSITIVE-FIXNUM lets the system know it can increment a value 48;;; of type INDEX without having to worry about using a bignum to 49;;; represent the result. 50(def!type index () `(integer 0 (,sb!xc:array-dimension-limit))) 51 52;;; like INDEX, but only up to half the maximum. Used by hash-table 53;;; code that does plenty to (aref v (* 2 i)) and (aref v (1+ (* 2 i))). 54(def!type index/2 () `(integer 0 (,(floor sb!xc:array-dimension-limit 2)))) 55 56;;; like INDEX, but augmented with -1 (useful when using the index 57;;; to count downwards to 0, e.g. LOOP FOR I FROM N DOWNTO 0, with 58;;; an implementation which terminates the loop by testing for the 59;;; index leaving the loop range) 60(def!type index-or-minus-1 () `(integer -1 (,sb!xc:array-dimension-limit))) 61 62;;; A couple of VM-related types that are currently used only on the 63;;; alpha platform. -- CSR, 2002-06-24 64(def!type unsigned-byte-with-a-bite-out (s bite) 65 (cond ((eq s '*) 'integer) 66 ((and (integerp s) (> s 0)) 67 (let ((bound (ash 1 s))) 68 `(integer 0 ,(- bound bite 1)))) 69 (t 70 (error "Bad size specified for UNSIGNED-BYTE type specifier: ~ 71 ~/sb!impl:print-type-specifier/." 72 s)))) 73 74;;; Motivated by the mips port. -- CSR, 2002-08-22 75(def!type signed-byte-with-a-bite-out (s bite) 76 (cond ((eq s '*) 'integer) 77 ((and (integerp s) (> s 1)) 78 (let ((bound (ash 1 (1- s)))) 79 `(integer ,(- bound) ,(- bound bite 1)))) 80 (t 81 (error "Bad size specified for SIGNED-BYTE type specifier: ~ 82 ~/sb!impl:print-type-specifier/." 83 s)))) 84 85(def!type load/store-index (scale lowtag min-offset 86 &optional (max-offset min-offset)) 87 `(integer ,(- (truncate (+ (ash 1 16) 88 (* min-offset sb!vm:n-word-bytes) 89 (- lowtag)) 90 scale)) 91 ,(truncate (- (+ (1- (ash 1 16)) lowtag) 92 (* max-offset sb!vm:n-word-bytes)) 93 scale))) 94 95#!+(or x86 x86-64) 96(defun displacement-bounds (lowtag element-size data-offset) 97 (let* ((adjustment (- (* data-offset sb!vm:n-word-bytes) lowtag)) 98 (bytes-per-element (ceiling element-size sb!vm:n-byte-bits)) 99 (min (truncate (+ sb!vm::minimum-immediate-offset adjustment) 100 bytes-per-element)) 101 (max (truncate (+ sb!vm::maximum-immediate-offset adjustment) 102 bytes-per-element))) 103 (values min max))) 104 105#!+(or x86 x86-64) 106(def!type constant-displacement (lowtag element-size data-offset) 107 (flet ((integerify (x) 108 (etypecase x 109 (integer x) 110 (symbol (symbol-value x))))) 111 (let ((lowtag (integerify lowtag)) 112 (element-size (integerify element-size)) 113 (data-offset (integerify data-offset))) 114 (multiple-value-bind (min max) (displacement-bounds lowtag 115 element-size 116 data-offset) 117 `(integer ,min ,max))))) 118 119;;; the default value used for initializing character data. The ANSI 120;;; spec says this is arbitrary, so we use the value that falls 121;;; through when we just let the low-level consing code initialize 122;;; all newly-allocated memory to zero. 123;;; 124;;; KLUDGE: It might be nice to use something which is a 125;;; STANDARD-CHAR, both to reduce user surprise a little and, probably 126;;; more significantly, to help SBCL's cross-compiler (which knows how 127;;; to dump STANDARD-CHARs). Unfortunately, the old CMU CL code is 128;;; shot through with implicit assumptions that it's #\NULL, and code 129;;; in several places (notably both DEFUN MAKE-ARRAY and DEFTRANSFORM 130;;; MAKE-ARRAY) would have to be rewritten. -- WHN 2001-10-04 131(eval-when (:compile-toplevel :load-toplevel :execute) 132 ;; an expression we can use to construct a DEFAULT-INIT-CHAR value 133 ;; at load time (so that we don't need to teach the cross-compiler 134 ;; how to represent and dump non-STANDARD-CHARs like #\NULL) 135 (defparameter *default-init-char-form* '(code-char 0))) 136 137;;; CHAR-CODE values for ASCII characters which we care about but 138;;; which aren't defined in section "2.1.3 Standard Characters" of the 139;;; ANSI specification for Lisp 140;;; 141;;; KLUDGE: These are typically used in the idiom (CODE-CHAR 142;;; FOO-CHAR-CODE). I suspect that the current implementation is 143;;; expanding this idiom into a full call to CODE-CHAR, which is an 144;;; annoying overhead. I should check whether this is happening, and 145;;; if so, perhaps implement a DEFTRANSFORM or something to stop it. 146;;; (or just find a nicer way of expressing characters portably?) -- 147;;; WHN 19990713 148(defconstant bell-char-code 7) 149(defconstant backspace-char-code 8) 150(defconstant tab-char-code 9) 151(defconstant line-feed-char-code 10) 152(defconstant form-feed-char-code 12) 153(defconstant return-char-code 13) 154(defconstant escape-char-code 27) 155(defconstant rubout-char-code 127) 156 157;;;; type-ish predicates 158 159;;; X may contain cycles -- a conservative approximation. This 160;;; occupies a somewhat uncomfortable niche between being fast for 161;;; common cases (we don't want to allocate a hash-table), and not 162;;; falling down to exponential behaviour for large trees (so we set 163;;; an arbitrady depth limit beyond which we punt). 164(defun maybe-cyclic-p (x &optional (depth-limit 12)) 165 (and (listp x) 166 (labels ((safe-cddr (cons) 167 (let ((cdr (cdr cons))) 168 (when (consp cdr) 169 (cdr cdr)))) 170 (check-cycle (object seen depth) 171 (when (and (consp object) 172 (or (> depth depth-limit) 173 (member object seen) 174 (circularp object seen depth))) 175 (return-from maybe-cyclic-p t))) 176 (circularp (list seen depth) 177 ;; Almost regular circular list detection, with a twist: 178 ;; we also check each element of the list for upward 179 ;; references using CHECK-CYCLE. 180 (do ((fast (cons (car list) (cdr list)) (safe-cddr fast)) 181 (slow list (cdr slow))) 182 ((not (consp fast)) 183 ;; Not CDR-circular, need to check remaining CARs yet 184 (do ((tail slow (and (cdr tail)))) 185 ((not (consp tail)) 186 nil) 187 (check-cycle (car tail) (cons tail seen) (1+ depth)))) 188 (check-cycle (car slow) (cons slow seen) (1+ depth)) 189 (when (eq fast slow) 190 (return t))))) 191 (circularp x (list x) 0)))) 192 193;;; Is X a (possibly-improper) list of at least N elements? 194(declaim (ftype (function (t index)) list-of-length-at-least-p)) 195(defun list-of-length-at-least-p (x n) 196 (or (zerop n) ; since anything can be considered an improper list of length 0 197 (and (consp x) 198 (list-of-length-at-least-p (cdr x) (1- n))))) 199 200(declaim (inline ensure-list)) 201(defun ensure-list (thing) 202 (if (listp thing) thing (list thing))) 203 204;;; Is X is a positive prime integer? 205(defun positive-primep (x) 206 ;; This happens to be called only from one place in sbcl-0.7.0, and 207 ;; only for fixnums, we can limit it to fixnums for efficiency. (And 208 ;; if we didn't limit it to fixnums, we should use a cleverer 209 ;; algorithm, since this one scales pretty badly for huge X.) 210 (declare (fixnum x)) 211 (if (<= x 5) 212 (and (>= x 2) (/= x 4)) 213 (and (not (evenp x)) 214 (not (zerop (rem x 3))) 215 (do ((q 6) 216 (r 1) 217 (inc 2 (logxor inc 6)) ;; 2,4,2,4... 218 (d 5 (+ d inc))) 219 ((or (= r 0) (> d q)) (/= r 0)) 220 (declare (fixnum inc)) 221 (multiple-value-setq (q r) (truncate x d)))))) 222 223;;; Could this object contain other objects? (This is important to 224;;; the implementation of things like *PRINT-CIRCLE* and the dumper.) 225(defun compound-object-p (x) 226 (or (consp x) 227 (%instancep x) 228 (typep x '(array t *)))) 229 230;;;; the COLLECT macro 231;;;; 232;;;; comment from CMU CL: "the ultimate collection macro..." 233 234;;; helper function for COLLECT, which becomes the expander of the 235;;; MACROLET definitions created by COLLECT if collecting a list. 236;;; N-TAIL is the pointer to the current tail of the list, or NIL 237;;; if the list is empty. 238(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) 239 (defun collect-list-expander (n-value n-tail forms) 240 (let ((n-res (gensym))) 241 `(progn 242 ,@(mapcar (lambda (form) 243 `(let ((,n-res (cons ,form nil))) 244 (cond (,n-tail 245 (setf (cdr ,n-tail) ,n-res) 246 (setq ,n-tail ,n-res)) 247 (t 248 (setq ,n-tail ,n-res ,n-value ,n-res))))) 249 forms) 250 ,n-value)))) 251 252;;; Collect some values somehow. Each of the collections specifies a 253;;; bunch of things which collected during the evaluation of the body 254;;; of the form. The name of the collection is used to define a local 255;;; macro, a la MACROLET. Within the body, this macro will evaluate 256;;; each of its arguments and collect the result, returning the 257;;; current value after the collection is done. The body is evaluated 258;;; as a PROGN; to get the final values when you are done, just call 259;;; the collection macro with no arguments. 260;;; 261;;; INITIAL-VALUE is the value that the collection starts out with, 262;;; which defaults to NIL. FUNCTION is the function which does the 263;;; collection. It is a function which will accept two arguments: the 264;;; value to be collected and the current collection. The result of 265;;; the function is made the new value for the collection. As a 266;;; totally magical special-case, FUNCTION may be COLLECT, which tells 267;;; us to build a list in forward order; this is the default. If an 268;;; INITIAL-VALUE is supplied for COLLECT, the stuff will be RPLACD'd 269;;; onto the end. Note that FUNCTION may be anything that can appear 270;;; in the functional position, including macros and lambdas. 271(defmacro collect (collections &body body) 272 (let ((macros ()) 273 (binds ()) 274 (ignores ())) 275 (dolist (spec collections) 276 (destructuring-bind (name &optional default collector 277 &aux (n-value (copy-symbol name))) spec 278 (push `(,n-value ,default) binds) 279 (let ((macro-body 280 (if (or (null collector) (eq collector 'collect)) 281 (let ((n-tail (gensymify* name "-TAIL"))) 282 (push n-tail ignores) 283 (push `(,n-tail ,(if default `(last ,n-value))) binds) 284 `(collect-list-expander ',n-value ',n-tail args)) 285 ``(progn 286 ,@(mapcar (lambda (x) 287 `(setq ,',n-value (,',collector ,x ,',n-value))) 288 args) 289 ,',n-value)))) 290 (push `(,name (&rest args) ,macro-body) macros)))) 291 `(macrolet ,macros 292 (let* ,(nreverse binds) 293 ;; Even if the user reads each collection result, 294 ;; reader conditionals might statically eliminate all writes. 295 ;; Since we don't know, all the -n-tail variable are ignorable. 296 ,@(if ignores `((declare (ignorable ,@ignores)))) 297 ,@body)))) 298 299;;;; some old-fashioned functions. (They're not just for old-fashioned 300;;;; code, they're also used as optimized forms of the corresponding 301;;;; general functions when the compiler can prove that they're 302;;;; equivalent.) 303 304;;; like (MEMBER ITEM LIST :TEST #'EQ) 305(defun memq (item list) 306 #!+sb-doc 307 "Return tail of LIST beginning with first element EQ to ITEM." 308 ;; KLUDGE: These could be and probably should be defined as 309 ;; (MEMBER ITEM LIST :TEST #'EQ)), 310 ;; but when I try to cross-compile that, I get an error from 311 ;; LTN-ANALYZE-KNOWN-CALL, "Recursive known function definition". The 312 ;; comments for that error say it "is probably a botched interpreter stub". 313 ;; Rather than try to figure that out, I just rewrote this function from 314 ;; scratch. -- WHN 19990512 315 (do ((i list (cdr i))) 316 ((null i)) 317 (when (eq (car i) item) 318 (return i)))) 319 320;;; like (ASSOC ITEM ALIST :TEST #'EQ): 321;;; Return the first pair of ALIST where ITEM is EQ to the key of 322;;; the pair. 323(defun assq (item alist) 324 ;; KLUDGE: CMU CL defined this with 325 ;; (DECLARE (INLINE ASSOC)) 326 ;; (ASSOC ITEM ALIST :TEST #'EQ)) 327 ;; which is pretty, but which would have required adding awkward 328 ;; build order constraints on SBCL (or figuring out some way to make 329 ;; inline definitions installable at build-the-cross-compiler time, 330 ;; which was too ambitious for now). Rather than mess with that, we 331 ;; just define ASSQ explicitly in terms of more primitive 332 ;; operations: 333 (dolist (pair alist) 334 ;; though it may look more natural to write this as 335 ;; (AND PAIR (EQ (CAR PAIR) ITEM)) 336 ;; the temptation to do so should be resisted, as pointed out by PFD 337 ;; sbcl-devel 2003-08-16, as NIL elements are rare in association 338 ;; lists. -- CSR, 2003-08-16 339 (when (and (eq (car pair) item) (not (null pair))) 340 (return pair)))) 341 342;;; like (DELETE .. :TEST #'EQ): 343;;; Delete all LIST entries EQ to ITEM (destructively modifying 344;;; LIST), and return the modified LIST. 345(defun delq (item list) 346 (let ((list list)) 347 (do ((x list (cdr x)) 348 (splice '())) 349 ((endp x) list) 350 (cond ((eq item (car x)) 351 (if (null splice) 352 (setq list (cdr x)) 353 (rplacd splice (cdr x)))) 354 (t (setq splice x)))))) ; Move splice along to include element. 355 356 357;;; like (POSITION .. :TEST #'EQ): 358;;; Return the position of the first element EQ to ITEM. 359(defun posq (item list) 360 (do ((i list (cdr i)) 361 (j 0 (1+ j))) 362 ((null i)) 363 (when (eq (car i) item) 364 (return j)))) 365 366(declaim (inline neq)) 367(defun neq (x y) 368 (not (eq x y))) 369 370(defun adjust-list (list length initial-element) 371 (let ((old-length (length list))) 372 (cond ((< old-length length) 373 (append list (make-list (- length old-length) 374 :initial-element initial-element))) 375 ((> old-length length) 376 (subseq list 0 length)) 377 (t list)))) 378 379;;;; miscellaneous iteration extensions 380 381;;; like Scheme's named LET 382;;; 383;;; (CMU CL called this ITERATE, and commented it as "the ultimate 384;;; iteration macro...". I (WHN) found the old name insufficiently 385;;; specific to remind me what the macro means, so I renamed it.) 386(defmacro named-let (name binds &body body) 387 (dolist (x binds) 388 (unless (proper-list-of-length-p x 2) 389 (error "malformed NAMED-LET variable spec: ~S" x))) 390 `(labels ((,name ,(mapcar #'first binds) ,@body)) 391 (,name ,@(mapcar #'second binds)))) 392 393(defun filter-dolist-declarations (decls) 394 (mapcar (lambda (decl) 395 `(declare ,@(remove-if 396 (lambda (clause) 397 (and (consp clause) 398 (or (eq (car clause) 'type) 399 (eq (car clause) 'ignore)))) 400 (cdr decl)))) 401 decls)) 402;;; just like DOLIST, but with one-dimensional arrays 403(defmacro dovector ((elt vector &optional result) &body body) 404 (multiple-value-bind (forms decls) (parse-body body nil) 405 (with-unique-names (index length vec) 406 `(let ((,vec ,vector)) 407 (declare (type vector ,vec)) 408 (do ((,index 0 (1+ ,index)) 409 (,length (length ,vec))) 410 ((>= ,index ,length) (let ((,elt nil)) 411 ,@(filter-dolist-declarations decls) 412 ,elt 413 ,result)) 414 (let ((,elt (aref ,vec ,index))) 415 ,@decls 416 (tagbody 417 ,@forms))))))) 418 419;;; Iterate over the entries in a HASH-TABLE, first obtaining the lock 420;;; if the table is a synchronized table. 421;;; An implicit block named NIL exists around the iteration, as is the custom. 422(defmacro dohash (((key-var value-var) table &key result locked) &body body) 423 (let* ((n-table (make-symbol "HT")) 424 (iter-form `(block nil 425 (maphash (lambda (,key-var ,value-var) ,@body) ,n-table) 426 ,result))) 427 `(let ((,n-table ,table)) 428 ,(if locked 429 `(with-locked-system-table (,n-table) ,iter-form) 430 iter-form)))) 431 432;;; Executes BODY for all entries of PLIST with KEY and VALUE bound to 433;;; the respective keys and values. 434(defmacro doplist ((key val) plist &body body) 435 (with-unique-names (tail) 436 `(let ((,tail ,plist) ,key ,val) 437 (loop (when (null ,tail) (return nil)) 438 (setq ,key (pop ,tail)) 439 (when (null ,tail) 440 (error "malformed plist, odd number of elements")) 441 (setq ,val (pop ,tail)) 442 (progn ,@body))))) 443 444;;; (binding* ({(names initial-value [flag])}*) body) 445;;; FLAG may be NIL or :EXIT-IF-NULL 446;;; 447;;; This form unites LET*, MULTIPLE-VALUE-BIND and AWHEN. 448;;; Any name in a list of names may be NIL to ignore the respective value. 449;;; If NAMES itself is nil, the initial-value form is evaluated only for effect. 450;;; 451;;; Clauses with no flag and one binding are equivalent to LET. 452;;; 453;;; Caution: don't use declarations of the form (<non-builtin-type-id> <var>) 454;;; before the INFO database is set up in building the cross-compiler, 455;;; or you will probably lose. 456;;; Of course, since some other host Lisps don't seem to think that's 457;;; acceptable syntax anyway, you're pretty much prevented from writing it. 458;;; 459(defmacro binding* ((&rest clauses) &body body) 460 (unless clauses ; wrap in LET to preserve non-toplevelness 461 (return-from binding* `(let () ,@body))) 462 (multiple-value-bind (body decls) (parse-body body nil) 463 ;; Generate an abstract representation that combines LET* clauses. 464 (let (repr) 465 (dolist (clause clauses) 466 (destructuring-bind (symbols value-form &optional flag) clause 467 (declare (type (member :exit-if-null nil) flag)) 468 (let* ((ignore nil) 469 (symbols 470 (cond ((not (listp symbols)) (list symbols)) 471 ((not symbols) (setq ignore (list (gensym)))) 472 (t (mapcar 473 (lambda (x) (or x (car (push (gensym) ignore)))) 474 symbols)))) 475 (flags (logior (if (cdr symbols) 1 0) (if flag 2 0))) 476 (last (car repr))) 477 ;; EVENP => this clause does not entail multiple-value-bind 478 (cond ((and (evenp flags) (eql (car last) 0)) 479 (setf (first last) flags) 480 (push (car symbols) (second last)) 481 (push value-form (third last)) 482 (setf (fourth last) (nconc ignore (fourth last)))) 483 (t 484 (push (list flags symbols (list value-form) ignore) 485 repr)))))) 486 ;; Starting with the innermost binding clause, snarf out the 487 ;; applicable declarations. (Clauses are currently reversed) 488 (dolist (abstract-clause repr) 489 (when decls 490 (multiple-value-bind (binding-decls remaining-decls) 491 (extract-var-decls decls (second abstract-clause)) 492 (setf (cddddr abstract-clause) binding-decls) 493 (setf decls remaining-decls)))) 494 ;; Generate sexprs from inside out. 495 (loop with listp = t ; BODY is already a list 496 for (flags symbols values ignore . binding-decls) in repr 497 ;; Maybe test the last bound symbol in the clause for LET* 498 ;; or 1st symbol for mv-bind. Either way, the first of SYMBOLS. 499 for inner = (if (logtest flags 2) ; :EXIT-IF-NULL was specified. 500 (prog1 `(when ,(car symbols) 501 ,@(if listp body (list body))) 502 (setq listp nil)) 503 body) 504 do (setq body 505 `(,.(if (evenp flags) 506 `(let* ,(nreverse (mapcar #'list symbols values))) 507 `(multiple-value-bind ,symbols ,(car values))) 508 ,@(when binding-decls (list binding-decls)) 509 ,@(when ignore `((declare (ignorable ,@ignore)))) 510 ,@decls ; anything leftover 511 ,@(if listp inner (list inner))) 512 listp nil 513 decls nil)) 514 body))) 515 516;;;; macro writing utilities 517 518(defmacro with-current-source-form ((&rest forms) &body body) 519 #!+sb-doc 520 "In a macroexpander, indicate that FORMS are being processed by BODY. 521 522FORMS are usually sub-forms of the whole form passed to the expander. 523 524If more than one form is supplied, FORMS should be ordered by 525specificity, with the most specific form first. This allows the 526compiler to try and obtain a source path using subsequent elements of 527FORMS if it fails for the first one. 528 529Indicating the processing of sub-forms lets the compiler report 530precise source locations in case conditions are signaled during the 531execution of BODY. 532 533NOTE: This interface is experimental and subject to change." 534 #-sb-xc-host `(sb!c::call-with-current-source-form 535 (lambda () ,@body) ,@forms) 536 #+sb-xc-host `(progn (list ,@forms) ,@body)) 537 538;;;; hash cache utility 539 540(eval-when (:compile-toplevel :load-toplevel :execute) 541 (defvar *profile-hash-cache* nil)) 542 543;;; Define a hash cache that associates some number of argument values 544;;; with a result value. The TEST-FUNCTION paired with each ARG-NAME 545;;; is used to compare the value for that arg in a cache entry with a 546;;; supplied arg. The TEST-FUNCTION must not error when passed NIL as 547;;; its first arg, but need not return any particular value. 548;;; TEST-FUNCTION may be any thing that can be placed in CAR position. 549;;; 550;;; This code used to store all the arguments / return values directly 551;;; in the cache vector. This was both interrupt- and thread-unsafe, since 552;;; it was possible that *-CACHE-ENTER would scribble over a region of the 553;;; cache vector which *-CACHE-LOOKUP had only partially processed. Instead 554;;; we now store the contents of each cache bucket as a separate array, which 555;;; is stored in the appropriate cell in the cache vector. A new bucket array 556;;; is created every time *-CACHE-ENTER is called, and the old ones are never 557;;; modified. This means that *-CACHE-LOOKUP will always work with a set 558;;; of consistent data. The overhead caused by consing new buckets seems to 559;;; be insignificant on the grand scale of things. -- JES, 2006-11-02 560;;; 561;;; NAME is used to define these functions: 562;;; <name>-CACHE-LOOKUP Arg* 563;;; See whether there is an entry for the specified ARGs in the 564;;; cache. If not present, the :DEFAULT keyword (default NIL) 565;;; determines the result(s). 566;;; <name>-CACHE-ENTER Arg* Value* 567;;; Encache the association of the specified args with VALUE. 568;;; <name>-CACHE-CLEAR 569;;; Reinitialize the cache, invalidating all entries and allowing 570;;; the arguments and result values to be GC'd. 571;;; 572;;; These other keywords are defined: 573;;; :HASH-BITS <n> 574;;; The size of the cache as a power of 2. 575;;; :HASH-FUNCTION function 576;;; Some thing that can be placed in CAR position which will compute 577;;; a fixnum with at least (* 2 <hash-bits>) of information in it. 578;;; :VALUES <n> 579;;; the number of return values cached for each function call 580(defvar *cache-vector-symbols* nil) 581 582(defun drop-all-hash-caches () 583 (dolist (name *cache-vector-symbols*) 584 (set name nil))) 585 586;; Make a new hash-cache and optionally create the statistics vector. 587(defun alloc-hash-cache (size symbol) 588 (let (cache) 589 ;; It took me a while to figure out why infinite recursion could occur 590 ;; in VALUES-SPECIFIER-TYPE. It's because SET calls VALUES-SPECIFIER-TYPE. 591 (macrolet ((set! (symbol value) 592 `(#+sb-xc-host set 593 #-sb-xc-host sb!kernel:%set-symbol-global-value 594 ,symbol ,value)) 595 (reset-stats () 596 ;; If statistics gathering is not not compiled-in, 597 ;; no sense in setting a symbol that is never used. 598 ;; While this uses SYMBOLICATE at runtime, 599 ;; it is inconsequential to performance. 600 (if *profile-hash-cache* 601 `(let ((statistics 602 (let ((*package* (symbol-package symbol))) 603 (symbolicate symbol "STATISTICS")))) 604 (unless (boundp statistics) 605 (set! statistics 606 (make-array 3 :element-type 'fixnum 607 :initial-contents '(1 0 0)))))))) 608 ;; It would be bad if another thread sees MAKE-ARRAY's result in the 609 ;; global variable before the vector's header+length have been set. 610 ;; Without a barrier, this would be theoretically possible if the 611 ;; architecture allows out-of-order memory writes. 612 (sb!thread:barrier (:write) 613 (reset-stats) 614 (setq cache (make-array size :initial-element 0))) 615 (set! symbol cache)))) 616 617;; At present we make a new vector every time a line is re-written, 618;; to make it thread-safe and interrupt-safe. A multi-word compare-and-swap 619;; is tricky to code and stronger than we need. It is possible instead 620;; to provide multi-word reads that can detect failure of atomicity, 621;; and on x86 it's possible to have atomic double-wide read/write, 622;; so a 1-arg/1-result cache line needn't cons at all except once 623;; (and maybe not even that if we make the cache into pairs of cells). 624;; But this way is easier to understand, for now anyway. 625(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) 626 (defun hash-cache-line-allocator (n) 627 (aref #.(coerce (loop for i from 2 to 6 628 collect (symbolicate "ALLOC-HASH-CACHE-LINE/" 629 (char "23456" (- i 2)))) 630 'vector) 631 (- n 2)))) 632(macrolet ((def (n) 633 (let* ((ftype `(sfunction ,(make-list n :initial-element t) t)) 634 (fn (hash-cache-line-allocator n)) 635 (args (make-gensym-list n))) 636 `(progn 637 (declaim (ftype ,ftype ,fn)) 638 (defun ,fn ,args 639 (declare (optimize (safety 0))) 640 ,(if (<= n 3) 641 `(list* ,@args) 642 `(vector ,@args))))))) 643 (def 2) 644 (def 3) 645 (def 4) 646 (def 5) 647 (def 6)) 648 649(defmacro !define-hash-cache (name args aux-vars 650 &key hash-function hash-bits memoizer 651 flush-function (values 1)) 652 (declare (ignore memoizer)) 653 (dolist (arg args) 654 (unless (<= 2 (length arg) 3) 655 (error "bad argument spec: ~S" arg))) 656 (assert (typep hash-bits '(integer 5 14))) ; reasonable bounds 657 (let* ((fun-name (symbolicate "!" name "-MEMO-WRAPPER")) 658 (var-name (symbolicate "**" name "-CACHE-VECTOR**")) 659 (statistics-name 660 (when *profile-hash-cache* 661 (symbolicate var-name "STATISTICS"))) 662 (nargs (length args)) 663 (size (ash 1 hash-bits)) 664 (hashval (make-symbol "HASH")) 665 (cache (make-symbol "CACHE")) 666 (entry (make-symbol "LINE")) 667 (thunk (make-symbol "THUNK")) 668 (arg-vars (mapcar #'first args)) 669 (nvalues (if (listp values) (length values) values)) 670 (result-temps 671 (if (listp values) 672 values ; use the names provided by the user 673 (loop for i from 1 to nvalues ; else invent some names 674 collect (make-symbol (format nil "R~D" i))))) 675 (temps (append (mapcar (lambda (x) (make-symbol (string x))) 676 arg-vars) 677 result-temps)) 678 ;; Mnemonic: (FIND x SEQ :test #'f) calls f with x as the LHS 679 (tests (mapcar (lambda (spec temp) ; -> (EQx ARG #:ARG) 680 `(,(cadr spec) ,(car spec) ,temp)) 681 args temps)) 682 (cache-type `(simple-vector ,size)) 683 (line-type (let ((n (+ nargs nvalues))) 684 (if (<= n 3) 'cons `(simple-vector ,n)))) 685 (bind-hashval 686 `((,hashval (the (signed-byte #.sb!vm:n-fixnum-bits) 687 (funcall ,hash-function ,@arg-vars))) 688 (,cache ,var-name))) 689 (probe-it 690 (lambda (ignore action) 691 `(when ,cache 692 (let ((,hashval ,hashval) ; gets clobbered in probe loop 693 (,cache (truly-the ,cache-type ,cache))) 694 ;; FIXME: redundant? 695 (declare (type (signed-byte #.sb!vm:n-fixnum-bits) ,hashval)) 696 (loop repeat 2 697 do (let ((,entry 698 (svref ,cache 699 (ldb (byte ,hash-bits 0) ,hashval)))) 700 (unless (eql ,entry 0) 701 ;; This barrier is a no-op on all multi-threaded SBCL 702 ;; architectures. No CPU except Alpha will move a 703 ;; load prior to a load on which it depends. 704 (sb!thread:barrier (:data-dependency)) 705 (locally (declare (type ,line-type ,entry)) 706 (let* ,(case (length temps) 707 (2 `((,(first temps) (car ,entry)) 708 (,(second temps) (cdr ,entry)))) 709 (3 (let ((arg-temp (sb!xc:gensym "ARGS"))) 710 `((,arg-temp (cdr ,entry)) 711 (,(first temps) (car ,entry)) 712 (,(second temps) 713 (car (truly-the cons ,arg-temp))) 714 (,(third temps) (cdr ,arg-temp))))) 715 (t (loop for i from 0 for x in temps 716 collect `(,x (svref ,entry ,i))))) 717 ,@ignore 718 (when (and ,@tests) ,action)))) 719 (setq ,hashval (ash ,hashval ,(- hash-bits))))))))) 720 (fun 721 `(defun ,fun-name (,thunk ,@arg-vars ,@aux-vars) 722 ,@(when *profile-hash-cache* ; count seeks 723 `((when (boundp ',statistics-name) 724 (incf (aref ,statistics-name 0))))) 725 (let ,bind-hashval 726 ,(funcall probe-it nil 727 `(return-from ,fun-name (values ,@result-temps))) 728 (multiple-value-bind ,result-temps (funcall ,thunk) 729 (let ((,entry 730 (,(hash-cache-line-allocator (+ nargs nvalues)) 731 ,@(mapcar (lambda (spec) (or (caddr spec) (car spec))) 732 args) 733 ,@result-temps)) 734 (,cache 735 (truly-the ,cache-type 736 (or ,cache (alloc-hash-cache ,size ',var-name)))) 737 (idx1 (ldb (byte ,hash-bits 0) ,hashval)) 738 (idx2 (ldb (byte ,hash-bits ,hash-bits) ,hashval))) 739 ,@(when *profile-hash-cache* 740 `((incf (aref ,statistics-name 1)))) ; count misses 741 ;; Why a barrier: the pointer to 'entry' (a cons or vector) 742 ;; MUST NOT be observed by another thread before its cells 743 ;; are filled. Equally bad, the 'output' cells in the line 744 ;; could be 0 while the 'input' cells matched something. 745 (sb!thread:barrier (:write)) 746 (cond ((eql (svref ,cache idx1) 0) 747 (setf (svref ,cache idx1) ,entry)) 748 ((eql (svref ,cache idx2) 0) 749 (setf (svref ,cache idx2) ,entry)) 750 (t 751 ,@(when *profile-hash-cache* ; count evictions 752 `((incf (aref ,statistics-name 2)))) 753 (setf (svref ,cache idx1) ,entry)))) 754 (values ,@result-temps)))))) 755 `(progn 756 (pushnew ',var-name *cache-vector-symbols*) 757 (defglobal ,var-name nil) 758 ,@(when *profile-hash-cache* 759 `((declaim (type (simple-array fixnum (3)) ,statistics-name)) 760 (defvar ,statistics-name))) 761 (declaim (type (or null ,cache-type) ,var-name)) 762 (defun ,(symbolicate name "-CACHE-CLEAR") () (setq ,var-name nil)) 763 ,@(when flush-function 764 `((defun ,flush-function ,arg-vars 765 (let ,bind-hashval 766 ,(funcall probe-it 767 `((declare (ignore ,@result-temps))) 768 `(return (setf (svref ,cache 769 (ldb (byte ,hash-bits 0) ,hashval)) 770 0))))))) 771 (declaim (inline ,fun-name)) 772 ,fun))) 773 774;;; some syntactic sugar for defining a function whose values are 775;;; cached by !DEFINE-HASH-CACHE 776;;; These keywords are mostly defined at !DEFINE-HASH-CACHE. 777;;; Additional options: 778;;; :MEMOIZER <name> 779;;; If provided, it is the name of a local macro that must be called 780;;; within the body forms to perform cache lookup/insertion. 781;;; If not provided, then the function's behavior is to automatically 782;;; attempt cache lookup, and on miss, execute the body code and 783;;; insert into the cache. 784;;; Manual control over memoization is useful if there are cases for 785;;; which it is undesirable to pollute the cache. 786 787;;; FIXME: this macro holds onto the DEFINE-HASH-CACHE macro, 788;;; but should not. 789;;; 790;;; Possible FIXME: if the function has a type proclamation, it forces 791;;; a type-check every time the cache finds something. Instead, values should 792;;; be checked once only when inserted into the cache, and not when read out. 793;;; 794;;; N.B.: it is not obvious that the intended use of an explicit MEMOIZE macro 795;;; is to call it exactly once or not at all. If you call it more than once, 796;;; then you inline all of its logic every time. Probably the code generated 797;;; by DEFINE-HASH-CACHE should be an FLET inside the body of DEFUN-CACHED, 798;;; but the division of labor is somewhat inverted at present. 799;;; Since we don't have caches that aren't in direct support of DEFUN-CACHED 800;;; - did we ever? - this should be possible to change. 801;;; 802(defmacro defun-cached ((name &rest options &key 803 (memoizer (make-symbol "MEMOIZE") 804 memoizer-supplied-p) 805 &allow-other-keys) 806 args &body body-decls-doc) 807 (binding* (((forms decls doc) (parse-body body-decls-doc t)) 808 ((inputs aux-vars) 809 (let ((aux (member '&aux args))) 810 (if aux 811 (values (ldiff args aux) aux) 812 (values args nil)))) 813 (arg-names (mapcar #'car inputs))) 814 `(progn 815 (!define-hash-cache ,name ,inputs ,aux-vars ,@options) 816 (defun ,name ,arg-names 817 ,@decls 818 ,@(if doc (list doc)) 819 (macrolet ((,memoizer (&body body) 820 ;; We don't need (DX-FLET ((,thunk () ,@body)) ...) 821 ;; This lambda is a single-use local call within 822 ;; the inline memoizing wrapper. 823 `(,',(symbolicate "!" name "-MEMO-WRAPPER") 824 (lambda () ,@body) ,@',arg-names))) 825 ,@(if memoizer-supplied-p 826 forms 827 `((,memoizer ,@forms)))))))) 828 829;;; FIXME: maybe not the best place 830;;; 831;;; FIXME: think of a better name -- not only does this not have the 832;;; CAR recursion of EQUAL, it also doesn't have the special treatment 833;;; of pathnames, bit-vectors and strings. 834;;; 835;;; KLUDGE: This means that we will no longer cache specifiers of the 836;;; form '(INTEGER (0) 4). This is probably not a disaster. 837;;; 838;;; A helper function for the type system, which is the main user of 839;;; these caches: we must be more conservative than EQUAL for some of 840;;; our equality tests, because MEMBER and friends refer to EQLity. 841;;; So: 842(defun equal-but-no-car-recursion (x y) 843 (do () (()) 844 (cond ((eql x y) (return t)) 845 ((and (consp x) 846 (consp y) 847 (eql (pop x) (pop y)))) 848 (t 849 (return))))) 850 851;;;; package idioms 852 853;;; Note: Almost always you want to use FIND-UNDELETED-PACKAGE-OR-LOSE 854;;; instead of this function. (The distinction only actually matters when 855;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case 856;;; you generally do want to signal an error instead of proceeding.) 857(defun %find-package-or-lose (package-designator) 858 #-sb-xc-host(declare (optimize allow-non-returning-tail-call)) 859 (or (find-package package-designator) 860 (error 'simple-package-error 861 :package package-designator 862 :format-control "The name ~S does not designate any package." 863 :format-arguments (list package-designator)))) 864 865;;; ANSI specifies (in the section for FIND-PACKAGE) that the 866;;; consequences of most operations on deleted packages are 867;;; unspecified. We try to signal errors in such cases. 868(defun find-undeleted-package-or-lose (package-designator) 869 #-sb-xc-host(declare (optimize allow-non-returning-tail-call)) 870 (let ((maybe-result (%find-package-or-lose package-designator))) 871 (if (package-%name maybe-result) ; if not deleted 872 maybe-result 873 (error 'simple-package-error 874 :package maybe-result 875 :format-control "The package ~S has been deleted." 876 :format-arguments (list maybe-result))))) 877 878;;;; various operations on names 879 880;;; Is NAME a legal function name? 881(declaim (inline legal-fun-name-p)) 882(defun legal-fun-name-p (name) 883 (values (valid-function-name-p name))) 884 885(deftype function-name () '(satisfies legal-fun-name-p)) 886 887;;; Signal an error unless NAME is a legal function name. 888(defun legal-fun-name-or-type-error (name) 889 #-sb-xc-host(declare (optimize allow-non-returning-tail-call)) 890 (unless (legal-fun-name-p name) 891 (error 'simple-type-error 892 :datum name 893 :expected-type 'function-name 894 :format-control "invalid function name: ~S" 895 :format-arguments (list name)))) 896 897;;; Given a function name, return the symbol embedded in it. 898;;; 899;;; The ordinary use for this operator (and the motivation for the 900;;; name of this operator) is to convert from a function name to the 901;;; name of the BLOCK which encloses its body. 902;;; 903;;; Occasionally the operator is useful elsewhere, where the operator 904;;; name is less mnemonic. (Maybe it should be changed?) 905(declaim (ftype (function ((or symbol cons)) symbol) fun-name-block-name)) 906(defun fun-name-block-name (fun-name) 907 (if (symbolp fun-name) 908 fun-name 909 (multiple-value-bind (legalp block-name) 910 (valid-function-name-p fun-name) 911 (if legalp 912 block-name 913 (error "not legal as a function name: ~S" fun-name))))) 914 915(defun looks-like-name-of-special-var-p (x) 916 (and (symbolp x) 917 (symbol-package x) 918 (let ((name (symbol-name x))) 919 (and (> (length name) 2) ; to exclude '* and '** 920 (char= #\* (aref name 0)) 921 (char= #\* (aref name (1- (length name)))))))) 922 923;;;; ONCE-ONLY 924;;;; 925;;;; "The macro ONCE-ONLY has been around for a long time on various 926;;;; systems [..] if you can understand how to write and when to use 927;;;; ONCE-ONLY, then you truly understand macro." -- Peter Norvig, 928;;;; _Paradigms of Artificial Intelligence Programming: Case Studies 929;;;; in Common Lisp_, p. 853 930 931;;; ONCE-ONLY is a utility useful in writing source transforms and 932;;; macros. It provides a concise way to wrap a LET around some code 933;;; to ensure that some forms are only evaluated once. 934;;; 935;;; Create a LET* which evaluates each value expression, binding a 936;;; temporary variable to the result, and wrapping the LET* around the 937;;; result of the evaluation of BODY. Within the body, each VAR is 938;;; bound to the corresponding temporary variable. 939(defmacro once-only (specs &body body) 940 (named-let frob ((specs specs) 941 (body body)) 942 (if (null specs) 943 `(progn ,@body) 944 (let ((spec (first specs))) 945 ;; FIXME: should just be DESTRUCTURING-BIND of SPEC 946 (unless (proper-list-of-length-p spec 2) 947 (error "malformed ONCE-ONLY binding spec: ~S" spec)) 948 (let* ((name (first spec)) 949 (exp-temp (gensym "ONCE-ONLY"))) 950 `(let ((,exp-temp ,(second spec)) 951 (,name (sb!xc:gensym ,(symbol-name name)))) 952 `(let ((,,name ,,exp-temp)) 953 ,,(frob (rest specs) body)))))))) 954 955;;;; various error-checking utilities 956 957;;; This function can be used as the default value for keyword 958;;; arguments that must be always be supplied. Since it is known by 959;;; the compiler to never return, it will avoid any compile-time type 960;;; warnings that would result from a default value inconsistent with 961;;; the declared type. When this function is called, it signals an 962;;; error indicating that a required &KEY argument was not supplied. 963;;; This function is also useful for DEFSTRUCT slot defaults 964;;; corresponding to required arguments. 965(declaim (ftype (function () #+(and sb-xc-host ccl) * 966 #-(and sb-xc-host ccl) nil) missing-arg)) 967(defun missing-arg () 968 #!+sb-doc 969 (/show0 "entering MISSING-ARG") 970 (error "A required &KEY or &OPTIONAL argument was not supplied.")) 971 972;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight 973;;; 974;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT. 975;;; The CL:ASSERT restarts and whatnot expand into a significant 976;;; amount of code when you multiply them by 400, so replacing them 977;;; with this should reduce the size of the system by enough to be 978;;; worthwhile.) 979(defmacro aver (expr) 980 `(unless ,expr 981 (%failed-aver ',expr))) 982 983(defun %failed-aver (expr) 984 (bug "~@<failed AVER: ~2I~_~S~:>" expr)) 985 986(defun bug (format-control &rest format-arguments) 987 (error 'bug 988 :format-control format-control 989 :format-arguments format-arguments)) 990 991;;; Return a function like FUN, but expecting its (two) arguments in 992;;; the opposite order that FUN does. 993(declaim (inline swapped-args-fun)) 994(defun swapped-args-fun (fun) 995 (declare (type function fun)) 996 (lambda (x y) 997 (funcall fun y x))) 998 999;;; Return the numeric value of a type bound, i.e. an interval bound 1000;;; more or less in the format of bounds in ANSI's type specifiers, 1001;;; where a bare numeric value is a closed bound and a list of a 1002;;; single numeric value is an open bound. 1003;;; 1004;;; The "more or less" bit is that the no-bound-at-all case is 1005;;; represented by NIL (not by * as in ANSI type specifiers); and in 1006;;; this case we return NIL. 1007(defun type-bound-number (x) 1008 (if (consp x) 1009 (destructuring-bind (result) x result) 1010 x)) 1011 1012;;; some commonly-occurring CONSTANTLY forms 1013(macrolet ((def-constantly-fun (name constant-expr) 1014 `(progn 1015 (declaim (ftype (sfunction * (eql ,constant-expr)) ,name)) 1016 (setf (symbol-function ',name) 1017 (constantly ,constant-expr))))) 1018 (def-constantly-fun constantly-t t) 1019 (def-constantly-fun constantly-nil nil) 1020 (def-constantly-fun constantly-0 0)) 1021 1022;;; If X is a symbol, see whether it is present in *FEATURES*. Also 1023;;; handle arbitrary combinations of atoms using NOT, AND, OR. 1024(defun featurep (x) 1025 (typecase x 1026 (cons 1027 (case (car x) 1028 ((:not not) 1029 (cond 1030 ((cddr x) 1031 (error "too many subexpressions in feature expression: ~S" x)) 1032 ((null (cdr x)) 1033 (error "too few subexpressions in feature expression: ~S" x)) 1034 (t (not (featurep (cadr x)))))) 1035 ((:and and) (every #'featurep (cdr x))) 1036 ((:or or) (some #'featurep (cdr x))) 1037 (t 1038 (error "unknown operator in feature expression: ~S." x)))) 1039 (symbol (not (null (memq x *features*)))) 1040 (t 1041 (error "invalid feature expression: ~S" x)))) 1042 1043 1044;;;; utilities for two-VALUES predicates 1045 1046(defmacro not/type (x) 1047 (let ((val (gensym "VAL")) 1048 (win (gensym "WIN"))) 1049 `(multiple-value-bind (,val ,win) 1050 ,x 1051 (if ,win 1052 (values (not ,val) t) 1053 (values nil nil))))) 1054 1055(defmacro and/type (x y) 1056 `(multiple-value-bind (val1 win1) ,x 1057 (if (and (not val1) win1) 1058 (values nil t) 1059 (multiple-value-bind (val2 win2) ,y 1060 (if (and val1 val2) 1061 (values t t) 1062 (values nil (and win2 (not val2)))))))) 1063 1064;;; sort of like ANY and EVERY, except: 1065;;; * We handle two-VALUES predicate functions, as SUBTYPEP does. 1066;;; (And if the result is uncertain, then we return (VALUES NIL NIL), 1067;;; as SUBTYPEP does.) 1068;;; * THING is just an atom, and we apply OP (an arity-2 function) 1069;;; successively to THING and each element of LIST. 1070(defun any/type (op thing list) 1071 (declare (type function op)) 1072 (let ((certain? t)) 1073 (dolist (i list (values nil certain?)) 1074 (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) 1075 (if sub-certain? 1076 (when sub-value (return (values t t))) 1077 (setf certain? nil)))))) 1078(defun every/type (op thing list) 1079 (declare (type function op)) 1080 (let ((certain? t)) 1081 (dolist (i list (if certain? (values t t) (values nil nil))) 1082 (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) 1083 (if sub-certain? 1084 (unless sub-value (return (values nil t))) 1085 (setf certain? nil)))))) 1086 1087;;;; DEFPRINTER 1088 1089;;; These functions are called by the expansion of the DEFPRINTER 1090;;; macro to do the actual printing. 1091(declaim (ftype (function (symbol t stream) (values)) 1092 defprinter-prin1 defprinter-princ)) 1093(defun defprinter-prin1 (name value stream) 1094 (defprinter-prinx #'prin1 name value stream)) 1095(defun defprinter-princ (name value stream) 1096 (defprinter-prinx #'princ name value stream)) 1097(defun defprinter-prinx (prinx name value stream) 1098 (declare (type function prinx)) 1099 (when *print-pretty* 1100 (pprint-newline :linear stream)) 1101 (format stream ":~A " name) 1102 (funcall prinx value stream) 1103 (values)) 1104(defun defprinter-print-space (stream) 1105 (write-char #\space stream)) 1106 1107;;; Define some kind of reasonable PRINT-OBJECT method for a 1108;;; STRUCTURE-OBJECT class. 1109;;; 1110;;; NAME is the name of the structure class, and CONC-NAME is the same 1111;;; as in DEFSTRUCT. 1112;;; 1113;;; The SLOT-DESCS describe how each slot should be printed. Each 1114;;; SLOT-DESC can be a slot name, indicating that the slot should 1115;;; simply be printed. A SLOT-DESC may also be a list of a slot name 1116;;; and other stuff. The other stuff is composed of keywords followed 1117;;; by expressions. The expressions are evaluated with the variable 1118;;; which is the slot name bound to the value of the slot. These 1119;;; keywords are defined: 1120;;; 1121;;; :PRIN1 Print the value of the expression instead of the slot value. 1122;;; :PRINC Like :PRIN1, only PRINC the value 1123;;; :TEST Only print something if the test is true. 1124;;; 1125;;; If no printing thing is specified then the slot value is printed 1126;;; as if by PRIN1. 1127;;; 1128;;; The structure being printed is bound to STRUCTURE and the stream 1129;;; is bound to STREAM. 1130(defmacro defprinter ((name 1131 &key 1132 (conc-name (concatenate 'simple-string 1133 (symbol-name name) 1134 "-")) 1135 identity) 1136 &rest slot-descs) 1137 (let ((first? t) 1138 maybe-print-space 1139 (reversed-prints nil) 1140 (stream (sb!xc:gensym "STREAM"))) 1141 (flet ((sref (slot-name) 1142 `(,(symbolicate conc-name slot-name) structure))) 1143 (dolist (slot-desc slot-descs) 1144 (if first? 1145 (setf maybe-print-space nil 1146 first? nil) 1147 (setf maybe-print-space `(defprinter-print-space ,stream))) 1148 (cond ((atom slot-desc) 1149 (push maybe-print-space reversed-prints) 1150 (push `(defprinter-prin1 ',slot-desc ,(sref slot-desc) ,stream) 1151 reversed-prints)) 1152 (t 1153 (let ((sname (first slot-desc)) 1154 (test t)) 1155 (collect ((stuff)) 1156 (do ((option (rest slot-desc) (cddr option))) 1157 ((null option) 1158 (push `(let ((,sname ,(sref sname))) 1159 (when ,test 1160 ,maybe-print-space 1161 ,@(or (stuff) 1162 `((defprinter-prin1 1163 ',sname ,sname ,stream))))) 1164 reversed-prints)) 1165 (case (first option) 1166 (:prin1 1167 (stuff `(defprinter-prin1 1168 ',sname ,(second option) ,stream))) 1169 (:princ 1170 (stuff `(defprinter-princ 1171 ',sname ,(second option) ,stream))) 1172 (:test (setq test (second option))) 1173 (t 1174 (error "bad option: ~S" (first option))))))))))) 1175 `(defmethod print-object ((structure ,name) ,stream) 1176 (pprint-logical-block (,stream nil) 1177 (print-unreadable-object (structure 1178 ,stream 1179 :type t 1180 :identity ,identity) 1181 ,@(nreverse reversed-prints)))))) 1182 1183(defun print-symbol-with-prefix (stream symbol &optional colon at) 1184 #!+sb-doc 1185 "For use with ~/: Write SYMBOL to STREAM as if it is not accessible from 1186 the current package." 1187 (declare (ignore colon at)) 1188 ;; Only keywords should be accessible from the keyword package, and 1189 ;; keywords are always printed with colons, so this guarantees that the 1190 ;; symbol will not be printed without a prefix. 1191 (let ((*package* *keyword-package*)) 1192 (write symbol :stream stream :escape t))) 1193 1194(declaim (special sb!pretty:*pprint-quote-with-syntactic-sugar*)) 1195(defun print-type-specifier (stream type-specifier &optional colon at) 1196 (declare (ignore colon at)) 1197 ;; Binding *PPRINT-QUOTE-WITH-SYNTACTIC-SUGAR* prevents certain 1198 ;; [f]types from being printed unhelpfully: 1199 ;; 1200 ;; (function ()) => #'NIL 1201 ;; (function *) => #'* 1202 ;; (function (function a)) => #'#'A 1203 ;; 1204 ;; Binding *PACKAGE* to the COMMON-LISP package causes specifiers 1205 ;; like CL:FUNCTION, CL:INTEGER, etc. to be printed without package 1206 ;; prefix but forces printing with package prefix for other 1207 ;; specifiers. 1208 (let ((sb!pretty:*pprint-quote-with-syntactic-sugar* nil) 1209 (*package* *cl-package*)) 1210 (prin1 type-specifier stream))) 1211 1212(defun print-type (stream type &optional colon at) 1213 (print-type-specifier stream (type-specifier type) colon at)) 1214 1215 1216;;;; etc. 1217 1218;;; Given a pathname, return a corresponding physical pathname. 1219(defun physicalize-pathname (possibly-logical-pathname) 1220 (if (typep possibly-logical-pathname 'logical-pathname) 1221 (translate-logical-pathname possibly-logical-pathname) 1222 possibly-logical-pathname)) 1223 1224;;;; Deprecating stuff 1225 1226(deftype deprecation-state () 1227 '(member :early :late :final)) 1228 1229(deftype deprecation-software-and-version () 1230 '(or string (cons string (cons string null)))) 1231 1232(defun normalize-deprecation-since (since) 1233 (unless (typep since 'deprecation-software-and-version) 1234 (error 'simple-type-error 1235 :datum since 1236 :expected-type 'deprecation-software-and-version 1237 :format-control "~@<The value ~S does not designate a ~ 1238 version or a software name and a version.~@:>" 1239 :format-arguments (list since))) 1240 (if (typep since 'string) 1241 (values nil since) 1242 (values-list since))) 1243 1244(defun normalize-deprecation-replacements (replacements) 1245 (if (or (not (listp replacements)) 1246 (eq 'setf (car replacements))) 1247 (list replacements) 1248 replacements)) 1249 1250(defstruct (deprecation-info 1251 (:constructor make-deprecation-info 1252 (state software version &optional replacement-spec 1253 &aux 1254 (replacements (normalize-deprecation-replacements 1255 replacement-spec)))) 1256 (:copier nil)) 1257 (state (missing-arg) :type deprecation-state :read-only t) 1258 (software (missing-arg) :type (or null string) :read-only t) 1259 (version (missing-arg) :type string :read-only t) 1260 (replacements '() :type list :read-only t)) 1261 1262;; Return the state of deprecation of the thing identified by 1263;; NAMESPACE and NAME, or NIL. 1264(defun deprecated-thing-p (namespace name) 1265 (multiple-value-bind (info infop) 1266 (ecase namespace 1267 (variable (info :variable :deprecated name)) 1268 (function (info :function :deprecated name)) 1269 (type (info :type :deprecated name))) 1270 (when infop 1271 (values (deprecation-info-state info) 1272 (list (deprecation-info-software info) 1273 (deprecation-info-version info)) 1274 (deprecation-info-replacements info))))) 1275 1276(defun deprecation-error (software version namespace name replacements) 1277 #-sb-xc-host(declare (optimize allow-non-returning-tail-call)) 1278 (error 'deprecation-error 1279 :namespace namespace 1280 :name name 1281 :software software 1282 :version version 1283 :replacements (normalize-deprecation-replacements replacements))) 1284 1285(defun deprecation-warn (state software version namespace name replacements 1286 &key (runtime-error (neq :early state))) 1287 (warn (ecase state 1288 (:early 'early-deprecation-warning) 1289 (:late 'late-deprecation-warning) 1290 (:final 'final-deprecation-warning)) 1291 :namespace namespace 1292 :name name 1293 :software software 1294 :version version 1295 :replacements (normalize-deprecation-replacements replacements) 1296 :runtime-error runtime-error)) 1297 1298(defun check-deprecated-thing (namespace name) 1299 (multiple-value-bind (state since replacements) 1300 (deprecated-thing-p namespace name) 1301 (when state 1302 (deprecation-warn 1303 state (first since) (second since) namespace name replacements) 1304 (values state since replacements)))) 1305 1306;;; For-effect-only variant of CHECK-DEPRECATED-THING for 1307;;; type-specifiers that descends into compound type-specifiers. 1308(defun %check-deprecated-type (type-specifier) 1309 (let ((seen '())) 1310 ;; KLUDGE: we have to use SPECIFIER-TYPE to sanely traverse 1311 ;; TYPE-SPECIFIER and detect references to deprecated types. But 1312 ;; then we may have to drop its cache to get the 1313 ;; PARSE-DEPRECATED-TYPE condition when TYPE-SPECIFIER is parsed 1314 ;; again later. 1315 ;; 1316 ;; Proper fix would be a 1317 ;; 1318 ;; walk-type function type-specifier 1319 ;; 1320 ;; mechanism that could drive VALUES-SPECIFIER-TYPE but also 1321 ;; things like this function. 1322 (block nil 1323 (handler-bind 1324 ((sb!kernel::parse-deprecated-type 1325 (lambda (condition) 1326 (let ((type-specifier (sb!kernel::parse-deprecated-type-specifier 1327 condition))) 1328 (aver (symbolp type-specifier)) 1329 (unless (memq type-specifier seen) 1330 (push type-specifier seen) 1331 (check-deprecated-thing 'type type-specifier))))) 1332 ((or error sb!kernel:parse-unknown-type) 1333 (lambda (condition) 1334 (declare (ignore condition)) 1335 (return)))) 1336 (specifier-type type-specifier))))) 1337 1338(defun check-deprecated-type (type-specifier) 1339 (typecase type-specifier 1340 ((or symbol cons) 1341 (%check-deprecated-type type-specifier)) 1342 (class 1343 (let ((name (class-name type-specifier))) 1344 (when (and name (symbolp name) 1345 (eq type-specifier (find-class name nil))) 1346 (%check-deprecated-type name)))))) 1347 1348;; This is the moral equivalent of a warning from /usr/bin/ld that 1349;; "gets() is dangerous." You're informed by both the compiler and linker. 1350(defun loader-deprecation-warn (stuff whence) 1351 ;; Stuff is a list: ((<state> name . category) ...) 1352 ;; For now we only deal with category = :FUNCTION so we ignore it. 1353 (let ((warning-class 1354 ;; We're only going to warn once (per toplevel form), 1355 ;; so pick the most stern warning applicable. 1356 (if (every (lambda (x) (eq (car x) :early)) stuff) 1357 'simple-style-warning 'simple-warning))) 1358 (warn warning-class 1359 :format-control "Reference to deprecated function~P ~S~@[ from ~S~]" 1360 :format-arguments 1361 (list (length stuff) (mapcar #'second stuff) whence)))) 1362 1363;;; STATE is one of 1364;;; 1365;;; :EARLY, for a compile-time style-warning. 1366;;; :LATE, for a compile-time full warning. 1367;;; :FINAL, for a compile-time full warning and runtime error. 1368;;; 1369;;; Suggested duration of each stage is one year, but some things can move faster, 1370;;; and some widely used legacy APIs might need to move slower. Internals we don't 1371;;; usually add deprecation notes for, but sometimes an internal API actually has 1372;;; several external users, in which case we try to be nice about it. 1373;;; 1374;;; When you deprecate something, note it here till it is fully gone: makes it 1375;;; easier to keep things progressing orderly. Also add the relevant section 1376;;; (or update it when deprecation proceeds) in the manual, in 1377;;; deprecated.texinfo. 1378;;; 1379;;; EARLY: 1380;;; - SOCKINT::WIN32-BIND since 1.2.10 (03/2015) -> Late: 08/2015 1381;;; - SOCKINT::WIN32-GETSOCKNAME since 1.2.10 (03/2015) -> Late: 08/2015 1382;;; - SOCKINT::WIN32-LISTEN since 1.2.10 (03/2015) -> Late: 08/2015 1383;;; - SOCKINT::WIN32-RECV since 1.2.10 (03/2015) -> Late: 08/2015 1384;;; - SOCKINT::WIN32-RECVFROM since 1.2.10 (03/2015) -> Late: 08/2015 1385;;; - SOCKINT::WIN32-SEND since 1.2.10 (03/2015) -> Late: 08/2015 1386;;; - SOCKINT::WIN32-SENDTO since 1.2.10 (03/2015) -> Late: 08/2015 1387;;; - SOCKINT::WIN32-CLOSE since 1.2.10 (03/2015) -> Late: 08/2015 1388;;; - SOCKINT::WIN32-CONNECT since 1.2.10 (03/2015) -> Late: 08/2015 1389;;; - SOCKINT::WIN32-GETPEERNAME since 1.2.10 (03/2015) -> Late: 08/2015 1390;;; - SOCKINT::WIN32-IOCTL since 1.2.10 (03/2015) -> Late: 08/2015 1391;;; - SOCKINT::WIN32-SETSOCKOPT since 1.2.10 (03/2015) -> Late: 08/2015 1392;;; - SOCKINT::WIN32-GETSOCKOPT since 1.2.10 (03/2015) -> Late: 08/2015 1393;;; 1394;;; - SB-C::MERGE-TAIL-CALLS (policy) since 1.0.53.74 (11/2011) -> Late: 11/2012 1395;;; 1396;;; LATE: 1397;;; - SB-C::STACK-ALLOCATE-DYNAMIC-EXTENT (policy) since 1.0.19.7 -> Final: anytime 1398;;; - SB-C::STACK-ALLOCATE-VECTOR (policy) since 1.0.19.7 -> Final: anytime 1399;;; - SB-C::STACK-ALLOCATE-VALUE-CELLS (policy) since 1.0.19.7 -> Final: anytime 1400 1401(defun print-deprecation-replacements (stream replacements &optional colonp atp) 1402 (declare (ignore colonp atp)) 1403 ;; I don't think this is callable during cross-compilation, is it? 1404 (apply #'format stream 1405 "~#[~;~ 1406 Use ~/sb-impl:print-symbol-with-prefix/ instead.~;~ 1407 Use ~/sb-impl:print-symbol-with-prefix/ or ~ 1408 ~/sb-impl:print-symbol-with-prefix/ instead.~:;~ 1409 Use~@{~#[~; or~] ~ 1410 ~/sb-impl:print-symbol-with-prefix/~^,~} instead.~ 1411 ~]" 1412 replacements)) 1413 1414(defun print-deprecation-message (namespace name software version 1415 &optional replacements stream) 1416 (format stream 1417 "The ~(~A~) ~/sb!impl:print-symbol-with-prefix/ has been ~ 1418 deprecated as of ~@[~A ~]version ~A.~ 1419 ~@[~2%~/sb!impl::print-deprecation-replacements/~]" 1420 namespace name software version replacements)) 1421 1422(defun setup-function-in-final-deprecation 1423 (software version name replacement-spec) 1424 #+sb-xc-host (declare (ignore software version name replacement-spec)) 1425 #-sb-xc-host 1426 (setf (fdefinition name) 1427 (sb!impl::set-closure-name 1428 (lambda (&rest args) 1429 (declare (ignore args)) 1430 (deprecation-error software version 'function name replacement-spec)) 1431 name))) 1432 1433(defun setup-variable-in-final-deprecation 1434 (software version name replacement-spec) 1435 (sb!c::%define-symbol-macro 1436 name 1437 `(deprecation-error 1438 ,software ,version 'variable ',name 1439 (list ,@(mapcar 1440 (lambda (replacement) 1441 `',replacement) 1442 (normalize-deprecation-replacements replacement-spec)))) 1443 nil)) 1444 1445(defun setup-type-in-final-deprecation 1446 (software version name replacement-spec) 1447 (declare (ignore software version replacement-spec)) 1448 (%compiler-deftype name (constant-type-expander name t) nil)) 1449 1450(defmacro define-deprecated-function (state version name replacements lambda-list 1451 &body body) 1452 (declare (type deprecation-state state) 1453 (type string version) 1454 (type function-name name) 1455 (type (or function-name list) replacements) 1456 (type list lambda-list) 1457 #+sb-xc-host (ignore version replacements)) 1458 `(progn 1459 #-sb-xc-host 1460 (declaim (deprecated 1461 ,state ("SBCL" ,version) 1462 (function ,name ,@(when replacements 1463 `(:replacement ,replacements))))) 1464 ,(ecase state 1465 ((:early :late) 1466 `(defun ,name ,lambda-list 1467 ,@body)) 1468 ((:final) 1469 `',name)))) 1470 1471(defmacro define-deprecated-variable (state version name 1472 &key (value nil valuep) replacement) 1473 (declare (type deprecation-state state) 1474 (type string version) 1475 (type symbol name) 1476 #+sb-xc-host (ignore version replacement)) 1477 `(progn 1478 #-sb-xc-host 1479 (declaim (deprecated 1480 ,state ("SBCL" ,version) 1481 (variable ,name ,@(when replacement 1482 `(:replacement ,replacement))))) 1483 ,(ecase state 1484 ((:early :late) 1485 `(defvar ,name ,@(when valuep (list value)))) 1486 ((:final) 1487 `',name)))) 1488 1489;; Given DECLS as returned by from parse-body, and SYMBOLS to be bound 1490;; (with LET, MULTIPLE-VALUE-BIND, etc) return two sets of declarations: 1491;; those which pertain to the variables and those which don't. 1492;; The first returned value is NIL or a single expression headed by DECLARE. 1493;; The second is a list of expressions resembling the input DECLS. 1494(defun extract-var-decls (decls symbols) 1495 (unless symbols ; Don't bother filtering DECLS, just return them. 1496 (return-from extract-var-decls (values nil decls))) 1497 (labels ((applies-to-variables (decl) 1498 ;; If DECL is a variable-affecting declaration, then return 1499 ;; the subset of SYMBOLS to which DECL applies. 1500 (let ((id (car decl))) 1501 (remove-if (lambda (x) (not (memq x symbols))) 1502 (cond ((eq id 'type) 1503 (cddr decl)) 1504 ((or (listp id) ; must be a type-specifier 1505 (memq id '(special ignorable ignore 1506 dynamic-extent 1507 truly-dynamic-extent)) 1508 (info :type :kind id)) 1509 (cdr decl)))))) 1510 (partition (spec) 1511 ;; If SPEC is a declaration affecting some variables in SYMBOLS 1512 ;; and some not, split it into two mutually exclusive declarations. 1513 (acond ((applies-to-variables spec) 1514 (multiple-value-bind (decl-head all-symbols) 1515 (if (eq (car spec) 'type) 1516 (values `(type ,(cadr spec)) (cddr spec)) 1517 (values `(,(car spec)) (cdr spec))) 1518 (let ((more (set-difference all-symbols it))) 1519 (values `(,@decl-head ,@it) 1520 (and more `(,@decl-head ,@more)))))) 1521 (t 1522 (values nil spec))))) 1523 ;; This loop is less inefficient than theoretically possible, 1524 ;; reconstructing the tree even if no need, 1525 ;; but it's just a macroexpander, so... fine. 1526 (collect ((binding-decls)) 1527 (let ((filtered 1528 (mapcar (lambda (decl-expr) ; a list headed by DECLARE 1529 (mapcan (lambda (spec) 1530 (multiple-value-bind (binding other) 1531 (partition spec) 1532 (when binding 1533 (binding-decls binding)) 1534 (if other (list other)))) 1535 (cdr decl-expr))) 1536 decls))) 1537 (values (awhen (binding-decls) `(declare ,@it)) 1538 (mapcan (lambda (x) (if x (list `(declare ,@x)))) filtered)))))) 1539 1540;;; Delayed evaluation 1541(defmacro delay (form) 1542 `(cons nil (lambda () ,form))) 1543 1544(defun force (promise) 1545 (cond ((not (consp promise)) promise) 1546 ((car promise) (cdr promise)) 1547 (t (setf (car promise) t 1548 (cdr promise) (funcall (cdr promise)))))) 1549 1550(defun promise-ready-p (promise) 1551 (or (not (consp promise)) 1552 (car promise))) 1553 1554;;; toplevel helper 1555(defmacro with-rebound-io-syntax (&body body) 1556 `(%with-rebound-io-syntax (lambda () ,@body))) 1557 1558(defun %with-rebound-io-syntax (function) 1559 (declare (type function function)) 1560 (let ((*package* *package*) 1561 (*print-array* *print-array*) 1562 (*print-base* *print-base*) 1563 (*print-case* *print-case*) 1564 (*print-circle* *print-circle*) 1565 (*print-escape* *print-escape*) 1566 (*print-gensym* *print-gensym*) 1567 (*print-length* *print-length*) 1568 (*print-level* *print-level*) 1569 (*print-lines* *print-lines*) 1570 (*print-miser-width* *print-miser-width*) 1571 (*print-pretty* *print-pretty*) 1572 (*print-radix* *print-radix*) 1573 (*print-readably* *print-readably*) 1574 (*print-right-margin* *print-right-margin*) 1575 (*read-base* *read-base*) 1576 (*read-default-float-format* *read-default-float-format*) 1577 (*read-eval* *read-eval*) 1578 (*read-suppress* *read-suppress*) 1579 (*readtable* *readtable*)) 1580 (funcall function))) 1581 1582;;; Bind a few "potentially dangerous" printer control variables to 1583;;; safe values, respecting current values if possible. 1584(defmacro with-sane-io-syntax (&body forms) 1585 `(call-with-sane-io-syntax (lambda () ,@forms))) 1586 1587(defun call-with-sane-io-syntax (function) 1588 (declare (type function function)) 1589 (macrolet ((true (sym) 1590 `(and (boundp ',sym) ,sym))) 1591 (let ((*print-readably* nil) 1592 (*print-level* (or (true *print-level*) 6)) 1593 (*print-length* (or (true *print-length*) 12))) 1594 (funcall function)))) 1595 1596;;; Returns a list of members of LIST. Useful for dealing with circular lists. 1597;;; For a dotted list returns a secondary value of T -- in which case the 1598;;; primary return value does not include the dotted tail. 1599;;; If the maximum length is reached, return a secondary value of :MAYBE. 1600(defun list-members (list &key max-length) 1601 (when list 1602 (do ((tail (cdr list) (cdr tail)) 1603 (members (list (car list)) (cons (car tail) members)) 1604 (count 0 (1+ count))) 1605 ((or (not (consp tail)) (eq tail list) 1606 (and max-length (>= count max-length))) 1607 (values members (or (not (listp tail)) 1608 (and (>= count max-length) :maybe))))))) 1609 1610;;; Default evaluator mode (interpeter / compiler) 1611 1612(declaim (type (member :compile #!+(or sb-eval sb-fasteval) :interpret) 1613 *evaluator-mode*)) 1614(!defparameter *evaluator-mode* :compile 1615 #!+sb-doc 1616 "Toggle between different evaluator implementations. If set to :COMPILE, 1617an implementation of EVAL that calls the compiler will be used. If set 1618to :INTERPRET, an interpreter will be used.") 1619 1620;; This is not my preferred name for this function, but chosen for harmony 1621;; with everything else that refers to these as 'hash-caches'. 1622;; Hashing is just one particular way of memoizing, and it would have been 1623;; slightly more abstract and yet at the same time more concrete to say 1624;; "memoized-function-caches". "hash-caches" is pretty nonspecific. 1625#.(if *profile-hash-cache* 1626'(defun show-hash-cache-statistics () 1627 (flet ((cache-stats (symbol) 1628 (let* ((name (string symbol)) 1629 (statistics (let ((*package* (symbol-package symbol))) 1630 (symbolicate symbol "STATISTICS"))) 1631 (prefix 1632 (subseq name 0 (- (length name) (length "VECTOR**"))))) 1633 (values (if (boundp statistics) 1634 (symbol-value statistics) 1635 (make-array 3 :element-type 'fixnum)) 1636 (subseq prefix 2 (1- (length prefix))))))) 1637 (format t "~%Type function memoization:~% Seek Hit (%)~: 1638 Evict (%) Size full~%") 1639 ;; Sort by descending seek count to rank by likely relative importance 1640 (dolist (symbol (sort (copy-list *cache-vector-symbols*) #'> 1641 :key (lambda (x) (aref (cache-stats x) 0)))) 1642 (binding* (((stats short-name) (cache-stats symbol)) 1643 (seek (aref stats 0)) 1644 (miss (aref stats 1)) 1645 (hit (- seek miss)) 1646 (evict (aref stats 2)) 1647 (cache (symbol-value symbol))) 1648 (format t "~9d ~9d (~5,1f%) ~8d (~5,1f%) ~4d ~6,1f% ~A~%" 1649 seek hit 1650 (if (plusp seek) (* 100 (/ hit seek))) 1651 evict 1652 (if (plusp seek) (* 100 (/ evict seek))) 1653 (length cache) 1654 (if (plusp (length cache)) 1655 (* 100 (/ (count-if-not #'fixnump cache) 1656 (length cache)))) 1657 short-name)))))) 1658 1659(in-package "SB!KERNEL") 1660 1661(defun fp-zero-p (x) 1662 (typecase x 1663 (single-float (zerop x)) 1664 (double-float (zerop x)) 1665 #!+long-float 1666 (long-float (zerop x)) 1667 (t nil))) 1668 1669(defun neg-fp-zero (x) 1670 (etypecase x 1671 (single-float 1672 (if (eql x 0.0f0) 1673 (make-unportable-float :single-float-negative-zero) 1674 0.0f0)) 1675 (double-float 1676 (if (eql x 0.0d0) 1677 (make-unportable-float :double-float-negative-zero) 1678 0.0d0)) 1679 #!+long-float 1680 (long-float 1681 (if (eql x 0.0l0) 1682 (make-unportable-float :long-float-negative-zero) 1683 0.0l0)))) 1684 1685(declaim (inline schwartzian-stable-sort-list)) 1686(defun schwartzian-stable-sort-list (list comparator &key key) 1687 (if (null key) 1688 (stable-sort (copy-list list) comparator) 1689 (let* ((key (if (functionp key) 1690 key 1691 (symbol-function key))) 1692 (wrapped (mapcar (lambda (x) 1693 (cons x (funcall key x))) 1694 list)) 1695 (sorted (stable-sort wrapped comparator :key #'cdr))) 1696 (map-into sorted #'car sorted)))) 1697 1698;;; Just like WITH-OUTPUT-TO-STRING but doesn't close the stream, 1699;;; producing more compact code. 1700(defmacro with-simple-output-to-string 1701 ((var &optional string) 1702 &body body) 1703 (multiple-value-bind (forms decls) (parse-body body nil) 1704 (if string 1705 `(let ((,var (sb!impl::make-fill-pointer-output-stream ,string))) 1706 ,@decls 1707 ,@forms) 1708 `(let ((,var (make-string-output-stream))) 1709 ,@decls 1710 ,@forms 1711 (truly-the (simple-array character (*)) 1712 (get-output-stream-string ,var)))))) 1713 1714(defun possibly-base-stringize (s) 1715 (cond #!+(and sb-unicode (host-feature sb-xc)) 1716 ((and (typep s '(array character (*))) (every #'base-char-p s)) 1717 (coerce s 'base-string)) 1718 (t 1719 s))) 1720 1721(defun self-evaluating-p (x) 1722 (typecase x 1723 (null t) 1724 (symbol (or (eq x t) (eq (symbol-package x) *keyword-package*))) 1725 (cons nil) 1726 (t t))) 1727