1 ;;;; This file contains definitions and declarations for the
2 ;;;; EXTENSIONS package which must be available at early cross-compile
3 ;;;; time, and perhaps also some things which might as well be built
4 ;;;; at cross-compile time even if they're not strictly needed, since
5 ;;;; that's harmless. Things which can't be built at cross-compile
6 ;;;; time (e.g. because they need machinery which only exists inside
7 ;;;; CMU CL's implementation of the LISP package) do not belong in
10 ;;;; This software is part of the SBCL system. See the README file for
11 ;;;; more information.
13 ;;;; This software is derived from the CMU CL system, which was
14 ;;;; written at Carnegie Mellon University and released into the
15 ;;;; public domain. The software is in the public domain and is
16 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
17 ;;;; files for more information.
19 (in-package "SB!IMPL")
21 ;;; something not EQ to anything we might legitimately READ
22 (defparameter *eof-object* (make-symbol "EOF-OBJECT"))
24 ;;; a type used for indexing into arrays, and for related quantities
25 ;;; like lengths of lists
27 ;;; It's intentionally limited to one less than the
28 ;;; ARRAY-DIMENSION-LIMIT for efficiency reasons, because in SBCL
29 ;;; ARRAY-DIMENSION-LIMIT is MOST-POSITIVE-FIXNUM, and staying below
30 ;;; that lets the system know it can increment a value of this type
31 ;;; without having to worry about using a bignum to represent the
34 ;;; (It should be safe to use ARRAY-DIMENSION-LIMIT as an exclusive
35 ;;; bound because ANSI specifies it as an exclusive bound.)
36 (def!type index () `(integer 0 (,sb!xc:array-dimension-limit)))
38 ;;; the default value used for initializing character data. The ANSI
39 ;;; spec says this is arbitrary. CMU CL used #\NULL, which we avoid
40 ;;; because it's not in the ANSI table of portable characters.
41 (defconstant default-init-char #\space)
43 ;;; CHAR-CODE values for ASCII characters which we care about but
44 ;;; which aren't defined in section "2.1.3 Standard Characters" of the
45 ;;; ANSI specification for Lisp
47 ;;; KLUDGE: These are typically used in the idiom (CODE-CHAR
48 ;;; FOO-CHAR-CODE). I suspect that the current implementation is
49 ;;; expanding this idiom into a full call to CODE-CHAR, which is an
50 ;;; annoying overhead. I should check whether this is happening, and
51 ;;; if so, perhaps implement a DEFTRANSFORM or something to stop it.
52 ;;; (or just find a nicer way of expressing characters portably?) --
54 (defconstant bell-char-code 7)
55 (defconstant tab-char-code 9)
56 (defconstant form-feed-char-code 12)
57 (defconstant return-char-code 13)
58 (defconstant escape-char-code 27)
59 (defconstant rubout-char-code 127)
61 ;;;; miscellaneous iteration extensions
63 (defmacro dovector ((elt vector &optional result) &rest forms)
65 "just like DOLIST, but with one-dimensional arrays"
66 (let ((index (gensym))
69 `(let ((,vec ,vector))
70 (declare (type vector ,vec))
71 (do ((,index 0 (1+ ,index))
72 (,length (length ,vec)))
73 ((>= ,index ,length) ,result)
74 (let ((,elt (aref ,vec ,index)))
77 (defmacro dohash ((key-var value-var table &optional result) &body body)
79 "DOHASH (Key-Var Value-Var Table [Result]) Declaration* Form*
80 Iterate over the entries in a hash-table."
81 (multiple-value-bind (forms decls) (parse-body body nil)
84 `(with-hash-table-iterator (,gen ,table)
86 (multiple-value-bind (,n-more ,key-var ,value-var) (,gen)
88 (unless ,n-more (return ,result))
91 ;;;; hash cache utility
93 (eval-when (:compile-toplevel :load-toplevel :execute)
94 (defvar *profile-hash-cache* nil))
96 ;;; a flag for whether it's too early in cold init to use caches so
97 ;;; that we have a better chance of recovering so that we have a
98 ;;; better chance of getting the system running so that we have a
99 ;;; better chance of diagnosing the problem which caused us to use the
102 (defvar *hash-caches-initialized-p*)
104 ;;; Define a hash cache that associates some number of argument values
105 ;;; with a result value. The TEST-FUNCTION paired with each ARG-NAME
106 ;;; is used to compare the value for that arg in a cache entry with a
107 ;;; supplied arg. The TEST-FUNCTION must not error when passed NIL as
108 ;;; its first arg, but need not return any particular value.
109 ;;; TEST-FUNCTION may be any thing that can be placed in CAR position.
111 ;;; NAME is used to define these functions:
112 ;;; <name>-CACHE-LOOKUP Arg*
113 ;;; See whether there is an entry for the specified ARGs in the
114 ;;; cache. If not present, the :DEFAULT keyword (default NIL)
115 ;;; determines the result(s).
116 ;;; <name>-CACHE-ENTER Arg* Value*
117 ;;; Encache the association of the specified args with VALUE.
118 ;;; <name>-CACHE-CLEAR
119 ;;; Reinitialize the cache, invalidating all entries and allowing
120 ;;; the arguments and result values to be GC'd.
122 ;;; These other keywords are defined:
124 ;;; The size of the cache as a power of 2.
125 ;;; :HASH-FUNCTION function
126 ;;; Some thing that can be placed in CAR position which will compute
127 ;;; a value between 0 and (1- (expt 2 <hash-bits>)).
129 ;;; the number of return values cached for each function call
130 ;;; :INIT-WRAPPER <name>
131 ;;; The code for initializing the cache is wrapped in a form with
132 ;;; the specified name. (:INIT-WRAPPER is set to COLD-INIT-FORMS
133 ;;; in type system definitions so that caches will be created
134 ;;; before top-level forms run.)
135 (defmacro define-hash-cache (name args &key hash-function hash-bits default
136 (init-wrapper 'progn)
138 (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
139 (nargs (length args))
140 (entry-size (+ nargs values))
141 (size (ash 1 hash-bits))
142 (total-size (* entry-size size))
143 (default-values (if (and (consp default) (eq (car default) 'values))
149 (unless (= (length default-values) values)
150 (error "The number of default values ~S differs from :VALUES ~D."
162 (values-indices `(+ ,n-index ,(+ nargs i)))
163 (values-names (gensym)))
166 (unless (= (length arg) 2)
167 (error "bad argument spec: ~S" arg))
168 (let ((arg-name (first arg))
171 (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
172 (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name)))
175 (when *profile-hash-cache*
176 (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*"))
177 (n-miss (symbolicate "*" name "-CACHE-MISSES*")))
178 (inits `(setq ,n-probe 0))
179 (inits `(setq ,n-miss 0))
180 (forms `(defvar ,n-probe))
181 (forms `(defvar ,n-miss))
182 (forms `(declaim (fixnum ,n-miss ,n-probe)))))
184 (let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
187 `(defun ,fun-name ,(arg-vars)
188 ,@(when *profile-hash-cache*
189 `((incf ,(symbolicate "*" name "-CACHE-PROBES*"))))
190 (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
191 (,n-cache ,var-name))
192 (declare (type fixnum ,n-index))
193 (cond ((and ,@(tests))
194 (values ,@(mapcar (lambda (x) `(svref ,n-cache ,x))
197 ,@(when *profile-hash-cache*
198 `((incf ,(symbolicate "*" name "-CACHE-MISSES*"))))
201 (let ((fun-name (symbolicate name "-CACHE-ENTER")))
204 `(defun ,fun-name (,@(arg-vars) ,@(values-names))
205 (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
206 (,n-cache ,var-name))
207 (declare (type fixnum ,n-index))
209 ,@(mapcar #'(lambda (i val)
210 `(setf (svref ,n-cache ,i) ,val))
215 (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
218 (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
219 (,n-cache ,var-name))
221 (declare (type fixnum ,n-index))
222 ,@(collect ((arg-sets))
224 (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
226 ,@(mapcar #'(lambda (i val)
227 `(setf (svref ,n-cache ,i) ,val))
231 (forms `(,fun-name)))
233 (inits `(unless (boundp ',var-name)
234 (setq ,var-name (make-array ,total-size))))
235 #!+sb-show (inits `(setq *hash-caches-initialized-p* t))
239 (declaim (type (simple-vector ,total-size) ,var-name))
240 #!-sb-fluid (declaim (inline ,@(inlines)))
241 (,init-wrapper ,@(inits))
245 ;;; some syntactic sugar for defining a function whose values are
246 ;;; cached by DEFINE-HASH-CACHE
247 (defmacro defun-cached ((name &rest options &key (values 1) default
249 args &body body-decls-doc)
250 (let ((default-values (if (and (consp default) (eq (car default) 'values))
253 (arg-names (mapcar #'car args)))
254 (collect ((values-names))
256 (values-names (gensym)))
257 (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
259 (define-hash-cache ,name ,args ,@options)
260 (defun ,name ,arg-names
264 ((not (boundp '*hash-caches-initialized-p*))
265 ;; This shouldn't happen, but it did happen to me
266 ;; when revising the type system, and it's a lot
267 ;; easier to figure out what what's going on with
268 ;; that kind of problem if the system can be kept
269 ;; alive until cold boot is complete. The recovery
270 ;; mechanism should definitely be conditional on
271 ;; some debugging feature (e.g. SB-SHOW) because
272 ;; it's big, duplicating all the BODY code. -- WHN
273 (/show0 ,name " too early in cold init, uncached")
274 (/show0 ,(first arg-names) "=..")
275 (/hexstr ,(first arg-names))
278 (multiple-value-bind ,(values-names)
279 (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
280 (if (and ,@(mapcar (lambda (val def)
282 (values-names) default-values))
283 (multiple-value-bind ,(values-names)
285 (,(symbolicate name "-CACHE-ENTER") ,@arg-names
287 (values ,@(values-names)))
288 (values ,@(values-names))))))))))))
292 ;;; Note: Almost always you want to use FIND-UNDELETED-PACKAGE-OR-LOSE
293 ;;; instead of this function. (The distinction only actually matters when
294 ;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case
295 ;;; you generally do want to signal an error instead of proceeding.)
296 (defun %find-package-or-lose (package-designator)
297 (or (find-package package-designator)
298 (error 'sb!kernel:simple-package-error
299 :package package-designator
300 :format-control "The name ~S does not designate any package."
301 :format-arguments (list package-designator))))
303 ;;; ANSI specifies (in the section for FIND-PACKAGE) that the
304 ;;; consequences of most operations on deleted packages are
305 ;;; unspecified. We try to signal errors in such cases.
306 (defun find-undeleted-package-or-lose (package-designator)
307 (let ((maybe-result (%find-package-or-lose package-designator)))
308 (if (package-name maybe-result) ; if not deleted
310 (error 'sb!kernel:simple-package-error
311 :package maybe-result
312 :format-control "The package ~S has been deleted."
313 :format-arguments (list maybe-result)))))
317 ;;; Is NAME a legal function name?
318 (defun legal-function-name-p (name)
321 (eq (car name) 'setf)
323 (symbolp (cadr name))
324 (null (cddr name)))))
326 ;;; Given a function name, return the name for the BLOCK which
327 ;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
328 (declaim (ftype (function ((or symbol cons)) symbol) function-name-block-name))
329 (defun function-name-block-name (function-name)
330 (cond ((symbolp function-name)
332 ((and (consp function-name)
333 (= (length function-name) 2)
334 (eq (first function-name) 'setf))
335 (second function-name))
337 (error "not legal as a function name: ~S" function-name))))
339 ;;; Is X a (possibly-improper) list of at least N elements?
340 (declaim (ftype (function (t index)) list-of-length-at-least-p))
341 (defun list-of-length-at-least-p (x n)
342 (or (zerop n) ; since anything can be considered an improper list of length 0
344 (list-of-length-at-least-p (cdr x) (1- n)))))
346 ;;; Return a list of N gensyms. (This is a common suboperation in
347 ;;; macros and other code-manipulating code.)
348 (declaim (ftype (function (index) list) make-gensym-list))
349 (defun make-gensym-list (n)
350 (loop repeat n collect (gensym)))
352 ;;; ANSI guarantees that some symbols are self-evaluating. This
353 ;;; function is to be called just before a change which would affect
354 ;;; that. (We don't absolutely have to call this function before such
355 ;;; changes, since such changes are given as undefined behavior. In
356 ;;; particular, we don't if the runtime cost would be annoying. But
357 ;;; otherwise it's nice to do so.)
358 (defun about-to-modify (symbol)
359 (declare (type symbol symbol))
361 (error "Veritas aeterna. (can't change T)"))
363 (error "Nihil ex nihil. (can't change NIL)"))
365 (error "Keyword values can't be changed."))
366 ;; (Just because a value is CONSTANTP is not a good enough
367 ;; reason to complain here, because we want DEFCONSTANT to
368 ;; be able to use this function, and it's legal to DEFCONSTANT
369 ;; a constant as long as the new value is EQL to the old
373 ;;; Return a function like FUN, but expecting its (two) arguments in
374 ;;; the opposite order that FUN does.
375 (declaim (inline swapped-args-fun))
376 (defun swapped-args-fun (fun)
377 (declare (type function fun))
381 ;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
383 ;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT.
384 ;;; The CL:ASSERT restarts and whatnot expand into a significant
385 ;;; amount of code when you multiply them by 400, so replacing them
386 ;;; with this should reduce the size of the system by enough to be
387 ;;; worthwhile. ENFORCE-TYPE is much less common, but might still be
388 ;;; worthwhile, and since I don't really like CERROR stuff deep in the
389 ;;; guts of complex systems anyway, I replaced it too.)
390 (defmacro aver (expr)
392 (%failed-aver ,(let ((*package* (find-package :keyword)))
393 (format nil "~S" expr)))))
394 (defun %failed-aver (expr-as-string)
395 (error "~@<internal error, failed AVER: ~2I~_~S~:>" expr-as-string))
396 (defmacro enforce-type (value type)
397 (once-only ((value value))
398 `(unless (typep ,value ',type)
399 (%failed-aver-type ,value ',type))))
400 (defun %failed-enforce-type (value type)
401 (error 'simple-type-error
404 :format-string "~@<~S ~_is not a ~_~S~:>"
405 :format-arguments (list value type)))
407 ;;; Return the numeric value of a type bound, i.e. an interval bound
408 ;;; more or less in the format of bounds in ANSI's type specifiers,
409 ;;; where a bare numeric value is a closed bound and a list of a
410 ;;; single numeric value is an open bound.
412 ;;; The "more or less" bit is that the no-bound-at-all case is
413 ;;; represented by NIL (not by * as in ANSI type specifiers); and in
414 ;;; this case we return NIL.
415 (defun type-bound-number (x)
417 (destructuring-bind (result) x result)
420 ;;; some commonly-occuring CONSTANTLY forms
421 (macrolet ((def-constantly-fun (name constant-expr)
422 `(setf (symbol-function ',name)
423 (constantly ,constant-expr))))
424 (def-constantly-fun constantly-t t)
425 (def-constantly-fun constantly-nil nil)
426 (def-constantly-fun constantly-0 0))
428 ;;;; utilities for two-VALUES predicates
430 ;;; sort of like ANY and EVERY, except:
431 ;;; * We handle two-VALUES predicate functions, as SUBTYPEP does.
432 ;;; (And if the result is uncertain, then we return (VALUES NIL NIL),
433 ;;; as SUBTYPEP does.)
434 ;;; * THING is just an atom, and we apply OP (an arity-2 function)
435 ;;; successively to THING and each element of LIST.
436 (defun any/type (op thing list)
437 (declare (type function op))
439 (dolist (i list (values nil certain?))
440 (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
442 (when sub-value (return (values t t)))
443 (setf certain? nil))))))
444 (defun every/type (op thing list)
445 (declare (type function op))
447 (dolist (i list (if certain? (values t t) (values nil nil)))
448 (multiple-value-bind (sub-value sub-certain?) (funcall op thing i)
450 (unless sub-value (return (values nil t)))
451 (setf certain? nil))))))
455 ;;; These functions are called by the expansion of the DEFPRINTER
456 ;;; macro to do the actual printing.
457 (declaim (ftype (function (symbol t stream) (values))
458 defprinter-prin1 defprinter-princ))
459 (defun defprinter-prin1 (name value stream)
460 (defprinter-prinx #'prin1 name value stream))
461 (defun defprinter-princ (name value stream)
462 (defprinter-prinx #'princ name value stream))
463 (defun defprinter-prinx (prinx name value stream)
464 (declare (type function prinx))
466 (pprint-newline :linear stream))
467 (format stream ":~A " name)
468 (funcall prinx value stream)
470 (defun defprinter-print-space (stream)
471 (write-char #\space stream))
473 ;;; Define some kind of reasonable PRINT-OBJECT method for a
474 ;;; STRUCTURE-OBJECT class.
476 ;;; NAME is the name of the structure class, and CONC-NAME is the same
479 ;;; The SLOT-DESCS describe how each slot should be printed. Each
480 ;;; SLOT-DESC can be a slot name, indicating that the slot should
481 ;;; simply be printed. A SLOT-DESC may also be a list of a slot name
482 ;;; and other stuff. The other stuff is composed of keywords followed
483 ;;; by expressions. The expressions are evaluated with the variable
484 ;;; which is the slot name bound to the value of the slot. These
485 ;;; keywords are defined:
487 ;;; :PRIN1 Print the value of the expression instead of the slot value.
488 ;;; :PRINC Like :PRIN1, only PRINC the value
489 ;;; :TEST Only print something if the test is true.
491 ;;; If no printing thing is specified then the slot value is printed
494 ;;; The structure being printed is bound to STRUCTURE and the stream
495 ;;; is bound to STREAM.
496 (defmacro defprinter ((name &key (conc-name (concatenate 'simple-string
502 (reversed-prints nil)
503 (stream (gensym "STREAM")))
504 (flet ((sref (slot-name)
505 `(,(symbolicate conc-name slot-name) structure)))
506 (dolist (slot-desc slot-descs)
508 (setf maybe-print-space nil
510 (setf maybe-print-space `(defprinter-print-space ,stream)))
511 (cond ((atom slot-desc)
512 (push maybe-print-space reversed-prints)
513 (push `(defprinter-prin1 ',slot-desc ,(sref slot-desc) ,stream)
516 (let ((sname (first slot-desc))
519 (do ((option (rest slot-desc) (cddr option)))
521 (push `(let ((,sname ,(sref sname)))
526 ',sname ,sname ,stream)))))
530 (stuff `(defprinter-prin1
531 ',sname ,(second option) ,stream)))
533 (stuff `(defprinter-princ
534 ',sname ,(second option) ,stream)))
535 (:test (setq test (second option)))
537 (error "bad option: ~S" (first option)))))))))))
538 `(def!method print-object ((structure ,name) ,stream)
539 ;; FIXME: should probably be byte-compiled
540 (pprint-logical-block (,stream nil)
541 (print-unreadable-object (structure ,stream :type t)
542 ,@(nreverse reversed-prints))))))
545 ;;; REMOVEME when done testing byte cross-compiler
546 (defun byte-compiled-foo (x y)
547 (declare (optimize (speed 0) (debug 1)))