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 ;;; :INIT-WRAPPER is set to COLD-INIT-FORMS in type system definitions
97 ;;; so that caches will be created before top-level forms run.
98 (defmacro define-hash-cache (name args &key hash-function hash-bits default
102 "DEFINE-HASH-CACHE Name ({(Arg-Name Test-Function)}*) {Key Value}*
103 Define a hash cache that associates some number of argument values to a
104 result value. The Test-Function paired with each Arg-Name is used to compare
105 the value for that arg in a cache entry with a supplied arg. The
106 Test-Function must not error when passed NIL as its first arg, but need not
107 return any particular value. Test-Function may be any thing that can be
108 placed in CAR position.
110 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 cache. If
114 not present, the :DEFAULT keyword (default NIL) determines the result(s).
116 <name>-CACHE-ENTER Arg* Value*
117 Encache the association of the specified args with Value.
120 Reinitialize the cache, invalidating all entries and allowing the
121 arguments and result values to be GC'd.
123 These other keywords are defined:
126 The size of the cache as a power of 2.
128 :HASH-FUNCTION function
129 Some thing that can be placed in CAR position which will compute a value
130 between 0 and (1- (expt 2 <hash-bits>)).
133 The number of values cached.
136 The code for initializing the cache is wrapped in a form with the
137 specified name. Default PROGN."
139 (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
140 (nargs (length args))
141 (entry-size (+ nargs values))
142 (size (ash 1 hash-bits))
143 (total-size (* entry-size size))
144 (default-values (if (and (consp default) (eq (car default) 'values))
150 (unless (= (length default-values) values)
151 (error "The number of default values ~S differs from :VALUES ~D."
163 (values-indices `(+ ,n-index ,(+ nargs i)))
164 (values-names (gensym)))
167 (unless (= (length arg) 2)
168 (error "bad argument spec: ~S" arg))
169 (let ((arg-name (first arg))
172 (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
173 (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name)))
176 (when *profile-hash-cache*
177 (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*"))
178 (n-miss (symbolicate "*" name "-CACHE-MISSES*")))
179 (inits `(setq ,n-probe 0))
180 (inits `(setq ,n-miss 0))
181 (forms `(defvar ,n-probe))
182 (forms `(defvar ,n-miss))
183 (forms `(declaim (fixnum ,n-miss ,n-probe)))))
185 (let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
188 `(defun ,fun-name ,(arg-vars)
189 ,@(when *profile-hash-cache*
190 `((incf ,(symbolicate "*" name "-CACHE-PROBES*"))))
191 (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
192 (,n-cache ,var-name))
193 (declare (type fixnum ,n-index))
194 (cond ((and ,@(tests))
195 (values ,@(mapcar (lambda (x) `(svref ,n-cache ,x))
198 ,@(when *profile-hash-cache*
199 `((incf ,(symbolicate "*" name "-CACHE-MISSES*"))))
202 (let ((fun-name (symbolicate name "-CACHE-ENTER")))
205 `(defun ,fun-name (,@(arg-vars) ,@(values-names))
206 (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
207 (,n-cache ,var-name))
208 (declare (type fixnum ,n-index))
210 ,@(mapcar #'(lambda (i val)
211 `(setf (svref ,n-cache ,i) ,val))
216 (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
219 (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
220 (,n-cache ,var-name))
222 (declare (type fixnum ,n-index))
223 ,@(collect ((arg-sets))
225 (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
227 ,@(mapcar #'(lambda (i val)
228 `(setf (svref ,n-cache ,i) ,val))
232 (forms `(,fun-name)))
234 (inits `(unless (boundp ',var-name)
235 (setq ,var-name (make-array ,total-size))))
239 (declaim (type (simple-vector ,total-size) ,var-name))
240 #!-sb-fluid (declaim (inline ,@(inlines)))
241 (,init-wrapper ,@(inits))
245 (defmacro defun-cached ((name &rest options &key (values 1) default
247 args &body body-decls-doc)
249 "DEFUN-CACHED (Name {Key Value}*) ({(Arg-Name Test-Function)}*) Form*
250 Some syntactic sugar for defining a function whose values are cached by
252 (let ((default-values (if (and (consp default) (eq (car default) 'values))
255 (arg-names (mapcar #'car args)))
256 (collect ((values-names))
258 (values-names (gensym)))
259 (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
261 (define-hash-cache ,name ,args ,@options)
262 (defun ,name ,arg-names
265 (multiple-value-bind ,(values-names)
266 (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
267 (if (and ,@(mapcar #'(lambda (val def)
269 (values-names) default-values))
270 (multiple-value-bind ,(values-names)
272 (,(symbolicate name "-CACHE-ENTER") ,@arg-names
274 (values ,@(values-names)))
275 (values ,@(values-names))))))))))
279 ;;; Note: Almost always you want to use FIND-UNDELETED-PACKAGE-OR-LOSE
280 ;;; instead of this function. (The distinction only actually matters when
281 ;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case
282 ;;; you generally do want to signal an error instead of proceeding.)
283 (defun %find-package-or-lose (package-designator)
284 (or (find-package package-designator)
285 (error 'sb!kernel:simple-package-error
286 :package package-designator
287 :format-control "The name ~S does not designate any package."
288 :format-arguments (list package-designator))))
290 ;;; ANSI specifies (in the section for FIND-PACKAGE) that the
291 ;;; consequences of most operations on deleted packages are
292 ;;; unspecified. We try to signal errors in such cases.
293 (defun find-undeleted-package-or-lose (package-designator)
294 (let ((maybe-result (%find-package-or-lose package-designator)))
295 (if (package-name maybe-result) ; if not deleted
297 (error 'sb!kernel:simple-package-error
298 :package maybe-result
299 :format-control "The package ~S has been deleted."
300 :format-arguments (list maybe-result)))))
304 ;;; FIXME: What is this used for that SYMBOLICATE couldn't be used for instead?
305 ;;; If nothing, replace it.
306 (eval-when (:compile-toplevel :load-toplevel :execute)
307 (defun concat-pnames (name1 name2)
308 (declare (symbol name1 name2))
310 (intern (concatenate 'simple-string
312 (symbol-name name2)))
315 ;;; Is NAME a legal function name?
316 (defun legal-function-name-p (name)
319 (eq (car name) 'setf)
321 (symbolp (cadr name))
322 (null (cddr name)))))
324 ;;; Given a function name, return the name for the BLOCK which
325 ;;; encloses its body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
326 (declaim (ftype (function ((or symbol cons)) symbol) function-name-block-name))
327 (defun function-name-block-name (function-name)
328 (cond ((symbolp function-name)
330 ((and (consp function-name)
331 (= (length function-name) 2)
332 (eq (first function-name) 'setf))
333 (second function-name))
335 (error "not legal as a function name: ~S" function-name))))
337 ;;; Is X a (possibly-improper) list of at least N elements?
338 (declaim (ftype (function (t index)) list-of-length-at-least-p))
339 (defun list-of-length-at-least-p (x n)
340 (or (zerop n) ; since anything can be considered an improper list of length 0
342 (list-of-length-at-least-p (cdr x) (1- n)))))
344 ;;; Return a list of N gensyms. (This is a common suboperation in
345 ;;; macros and other code-manipulating code.)
346 (declaim (ftype (function (index) list) make-gensym-list))
347 (defun make-gensym-list (n)
348 (loop repeat n collect (gensym)))
350 ;;; ANSI guarantees that some symbols are self-evaluating. This
351 ;;; function is to be called just before a change which would affect
352 ;;; that. (We don't absolutely have to call this function before such
353 ;;; changes, since such changes are given as undefined behavior. In
354 ;;; particular, we don't if the runtime cost would be annoying. But
355 ;;; otherwise it's nice to do so.)
356 (defun about-to-modify (symbol)
357 (declare (type symbol symbol))
359 (error "Veritas aeterna. (can't change T)"))
361 (error "Nihil ex nihil. (can't change NIL)"))
363 (error "Keyword values can't be changed."))
364 ;; (Just because a value is CONSTANTP is not a good enough
365 ;; reason to complain here, because we want DEFCONSTANT to
366 ;; be able to use this function, and it's legal to DEFCONSTANT
367 ;; a constant as long as the new value is EQL to the old
373 ;;; These functions are called by the expansion of the DEFPRINTER
374 ;;; macro to do the actual printing.
375 (declaim (ftype (function (symbol t stream &optional t) (values))
376 defprinter-prin1 defprinter-princ))
377 (defun defprinter-prin1 (name value stream &optional indent)
378 (declare (ignore indent))
379 (defprinter-prinx #'prin1 name value stream))
380 (defun defprinter-princ (name value stream &optional indent)
381 (declare (ignore indent))
382 (defprinter-prinx #'princ name value stream))
383 (defun defprinter-prinx (prinx name value stream)
384 (declare (type function prinx))
386 (pprint-newline :linear stream))
387 (format stream ":~A " name)
388 (funcall prinx value stream)
390 (defun defprinter-print-space (stream)
391 (write-char #\space stream))
393 ;;; Define some kind of reasonable PRINT-OBJECT method for a
394 ;;; STRUCTURE-OBJECT class.
396 ;;; NAME is the name of the structure class, and CONC-NAME is the same
399 ;;; The SLOT-DESCS describe how each slot should be printed. Each
400 ;;; SLOT-DESC can be a slot name, indicating that the slot should
401 ;;; simply be printed. A SLOT-DESC may also be a list of a slot name
402 ;;; and other stuff. The other stuff is composed of keywords followed
403 ;;; by expressions. The expressions are evaluated with the variable
404 ;;; which is the slot name bound to the value of the slot. These
405 ;;; keywords are defined:
407 ;;; :PRIN1 Print the value of the expression instead of the slot value.
408 ;;; :PRINC Like :PRIN1, only princ the value
409 ;;; :TEST Only print something if the test is true.
411 ;;; If no printing thing is specified then the slot value is printed
414 ;;; The structure being printed is bound to STRUCTURE and the stream
415 ;;; is bound to STREAM.
416 (defmacro defprinter ((name &key (conc-name (concatenate 'simple-string
422 (reversed-prints nil)
423 (stream (gensym "STREAM")))
424 (flet ((sref (slot-name)
425 `(,(symbolicate conc-name slot-name) structure)))
426 (dolist (slot-desc slot-descs)
428 (setf maybe-print-space nil
430 (setf maybe-print-space `(defprinter-print-space ,stream)))
431 (cond ((atom slot-desc)
432 (push maybe-print-space reversed-prints)
433 (push `(defprinter-prin1 ',slot-desc ,(sref slot-desc) ,stream)
436 (let ((sname (first slot-desc))
439 (do ((option (rest slot-desc) (cddr option)))
441 (push `(let ((,sname ,(sref sname)))
446 ',sname ,sname ,stream)))))
450 (stuff `(defprinter-prin1
451 ',sname ,(second option) ,stream)))
453 (stuff `(defprinter-princ
454 ',sname ,(second option) ,stream)))
455 (:test (setq test (second option)))
457 (error "bad option: ~S" (first option)))))))))))
458 `(def!method print-object ((structure ,name) ,stream)
459 ;; FIXME: should probably be byte-compiled
460 (pprint-logical-block (,stream nil)
461 (print-unreadable-object (structure ,stream :type t)
463 (pprint-indent :block 2 ,stream))
464 ,@(nreverse reversed-prints))))))
467 ;;; REMOVEME when done testing byte cross-compiler
468 (defun byte-compiled-foo (x y)
469 (declare (optimize (speed 0) (debug 1)))