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.
21 ;;; a type used for indexing into arrays, and for related quantities
22 ;;; like lengths of lists
24 ;;; It's intentionally limited to one less than the
25 ;;; ARRAY-DIMENSION-LIMIT for efficiency reasons, because in SBCL
26 ;;; ARRAY-DIMENSION-LIMIT is MOST-POSITIVE-FIXNUM, and staying below
27 ;;; that lets the system know it can increment a value of this type
28 ;;; without having to worry about using a bignum to represent the
31 ;;; (It should be safe to use ARRAY-DIMENSION-LIMIT as an exclusive
32 ;;; bound because ANSI specifies it as an exclusive bound.)
33 (def!type index () `(integer 0 (,sb!xc:array-dimension-limit)))
35 ;;; the default value used for initializing character data. The ANSI
36 ;;; spec says this is arbitrary. CMU CL used #\NULL, which we avoid
37 ;;; because it's not in the ANSI table of portable characters.
38 (defconstant default-init-char #\space)
40 ;;; CHAR-CODE values for ASCII characters which we care about but
41 ;;; which aren't defined in section "2.1.3 Standard Characters" of the
42 ;;; ANSI specification for Lisp
44 ;;; KLUDGE: These are typically used in the idiom (CODE-CHAR
45 ;;; FOO-CHAR-CODE). I suspect that the current implementation is
46 ;;; expanding this idiom into a full call to CODE-CHAR, which is an
47 ;;; annoying overhead. I should check whether this is happening, and
48 ;;; if so, perhaps implement a DEFTRANSFORM or something to stop it.
49 ;;; (or just find a nicer way of expressing characters portably?) --
51 (defconstant bell-char-code 7)
52 (defconstant tab-char-code 9)
53 (defconstant form-feed-char-code 12)
54 (defconstant return-char-code 13)
55 (defconstant escape-char-code 27)
56 (defconstant rubout-char-code 127)
58 ;;; Concatenate together the names of some strings and symbols,
59 ;;; producing a symbol in the current package.
60 (eval-when (:compile-toplevel :load-toplevel :execute)
61 (declaim (ftype (function (&rest (or string symbol)) symbol) symbolicate))
62 (defun symbolicate (&rest things)
63 (values (intern (apply #'concatenate
65 (mapcar #'string things))))))
67 ;;; like SYMBOLICATE, but producing keywords
68 (defun keywordicate (&rest things)
69 (let ((*package* *keyword-package*))
70 (apply #'symbolicate things)))
72 ;;;; miscellaneous iteration extensions
74 (defmacro dovector ((elt vector &optional result) &rest forms)
76 "just like DOLIST, but with one-dimensional arrays"
77 (let ((index (gensym))
80 `(let ((,vec ,vector))
81 (declare (type vector ,vec))
82 (do ((,index 0 (1+ ,index))
83 (,length (length ,vec)))
84 ((>= ,index ,length) ,result)
85 (let ((,elt (aref ,vec ,index)))
88 (defmacro dohash ((key-var value-var table &optional result) &body body)
90 "DOHASH (Key-Var Value-Var Table [Result]) Declaration* Form*
91 Iterate over the entries in a hash-table."
92 (multiple-value-bind (forms decls) (parse-body body nil)
95 `(with-hash-table-iterator (,gen ,table)
97 (multiple-value-bind (,n-more ,key-var ,value-var) (,gen)
99 (unless ,n-more (return ,result))
102 ;;;; hash cache utility
104 (eval-when (:compile-toplevel :load-toplevel :execute)
105 (defvar *profile-hash-cache* nil))
107 ;;; :INIT-WRAPPER is set to COLD-INIT-FORMS in type system definitions
108 ;;; so that caches will be created before top-level forms run.
109 (defmacro define-hash-cache (name args &key hash-function hash-bits default
110 (init-wrapper 'progn)
113 "DEFINE-HASH-CACHE Name ({(Arg-Name Test-Function)}*) {Key Value}*
114 Define a hash cache that associates some number of argument values to a
115 result value. The Test-Function paired with each Arg-Name is used to compare
116 the value for that arg in a cache entry with a supplied arg. The
117 Test-Function must not error when passed NIL as its first arg, but need not
118 return any particular value. Test-Function may be any thing that can be
119 placed in CAR position.
121 Name is used to define these functions:
123 <name>-CACHE-LOOKUP Arg*
124 See whether there is an entry for the specified Args in the cache. If
125 not present, the :DEFAULT keyword (default NIL) determines the result(s).
127 <name>-CACHE-ENTER Arg* Value*
128 Encache the association of the specified args with Value.
131 Reinitialize the cache, invalidating all entries and allowing the
132 arguments and result values to be GC'd.
134 These other keywords are defined:
137 The size of the cache as a power of 2.
139 :HASH-FUNCTION function
140 Some thing that can be placed in CAR position which will compute a value
141 between 0 and (1- (expt 2 <hash-bits>)).
144 The number of values cached.
147 The code for initializing the cache is wrapped in a form with the
148 specified name. Default PROGN."
150 (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
151 (nargs (length args))
152 (entry-size (+ nargs values))
153 (size (ash 1 hash-bits))
154 (total-size (* entry-size size))
155 (default-values (if (and (consp default) (eq (car default) 'values))
161 (unless (= (length default-values) values)
162 (error "The number of default values ~S differs from :VALUES ~D."
174 (values-indices `(+ ,n-index ,(+ nargs i)))
175 (values-names (gensym)))
178 (unless (= (length arg) 2)
179 (error "bad arg spec: ~S" arg))
180 (let ((arg-name (first arg))
183 (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
184 (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name)))
187 (when *profile-hash-cache*
188 (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*"))
189 (n-miss (symbolicate "*" name "-CACHE-MISSES*")))
190 (inits `(setq ,n-probe 0))
191 (inits `(setq ,n-miss 0))
192 (forms `(defvar ,n-probe))
193 (forms `(defvar ,n-miss))
194 (forms `(declaim (fixnum ,n-miss ,n-probe)))))
196 (let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
199 `(defun ,fun-name ,(arg-vars)
200 ,@(when *profile-hash-cache*
201 `((incf ,(symbolicate "*" name "-CACHE-PROBES*"))))
202 (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
203 (,n-cache ,var-name))
204 (declare (type fixnum ,n-index))
205 (cond ((and ,@(tests))
206 (values ,@(mapcar (lambda (x) `(svref ,n-cache ,x))
209 ,@(when *profile-hash-cache*
210 `((incf ,(symbolicate "*" name "-CACHE-MISSES*"))))
213 (let ((fun-name (symbolicate name "-CACHE-ENTER")))
216 `(defun ,fun-name (,@(arg-vars) ,@(values-names))
217 (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
218 (,n-cache ,var-name))
219 (declare (type fixnum ,n-index))
221 ,@(mapcar #'(lambda (i val)
222 `(setf (svref ,n-cache ,i) ,val))
227 (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
230 (/show0 ,(concatenate 'string "entering " (string fun-name)))
231 (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
232 (,n-cache ,var-name))
234 (declare (type fixnum ,n-index))
235 ,@(collect ((arg-sets))
237 (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
239 ,@(mapcar #'(lambda (i val)
240 `(setf (svref ,n-cache ,i) ,val))
243 (/show0 ,(concatenate 'string "leaving " (string fun-name)))
245 (forms `(,fun-name)))
247 (inits `(unless (boundp ',var-name)
248 (setq ,var-name (make-array ,total-size))))
252 (declaim (type (simple-vector ,total-size) ,var-name))
253 #!-sb-fluid (declaim (inline ,@(inlines)))
254 (,init-wrapper ,@(inits))
258 (defmacro defun-cached ((name &rest options &key (values 1) default
260 args &body body-decls-doc)
262 "DEFUN-CACHED (Name {Key Value}*) ({(Arg-Name Test-Function)}*) Form*
263 Some syntactic sugar for defining a function whose values are cached by
265 (let ((default-values (if (and (consp default) (eq (car default) 'values))
268 (arg-names (mapcar #'car args)))
269 (collect ((values-names))
271 (values-names (gensym)))
272 (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
274 (define-hash-cache ,name ,args ,@options)
275 (defun ,name ,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 ;;; FIXME: What is this used for that SYMBOLICATE couldn't be used for instead?
318 ;;; If nothing, replace it.
319 (eval-when (:compile-toplevel :load-toplevel :execute)
320 (defun concat-pnames (name1 name2)
321 (declare (symbol name1 name2))
323 (intern (concatenate 'simple-string
325 (symbol-name name2)))
328 ;;; Is NAME a legal function name?
329 (defun legal-function-name-p (name)
332 (eq (car name) 'setf)
334 (symbolp (cadr name))
335 (null (cddr name)))))
337 ;;; Given a function name, return the name for the BLOCK which encloses its
338 ;;; body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
339 (declaim (ftype (function ((or symbol cons)) symbol) function-name-block-name))
340 (defun function-name-block-name (function-name)
341 (cond ((symbolp function-name)
343 ((and (consp function-name)
344 (= (length function-name) 2)
345 (eq (first function-name) 'setf))
346 (second function-name))
348 (error "not legal as a function name: ~S" function-name))))
350 ;;; Is X a (possibly-improper) list of at least N elements?
351 (declaim (ftype (function (t index)) list-of-length-at-least-p))
352 (defun list-of-length-at-least-p (x n)
353 (or (zerop n) ; since anything can be considered an improper list of length 0
355 (list-of-length-at-least-p (cdr x) (1- n)))))
357 ;;; Return a list of N gensyms. (This is a common suboperation in
358 ;;; macros and other code-manipulating code.)
359 (declaim (ftype (function (index) list) make-gensym-list))
360 (defun make-gensym-list (n)
361 (loop repeat n collect (gensym)))
364 ;;; REMOVEME when done testing byte cross-compiler
365 (defun byte-compiled-foo (x y)
366 (declare (optimize (speed 0) (debug 1)))