src/code/early-extensions.lisp

   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
   8 ;;;; this file.
   9
  10 ;;;; This software is part of the SBCL system. See the README file for
  11 ;;;; more information.
  12 ;;;;
  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.
  18
  19 (in-package "SB!EXT")
  20
  21 ;;; a type used for indexing into arrays, and for related quantities
  22 ;;; like lengths of lists
  23 ;;;
  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
  29 ;;; result.
  30 ;;;
  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)))
  34
  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)
  39
  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
  43 ;;;
  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?) --
  50 ;;; WHN 19990713
  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)
  57 \f
  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
  64                            'string
  65                            (mapcar #'string things))))))
  66
  67 ;;; like SYMBOLICATE, but producing keywords
  68 (defun keywordicate (&rest things)
  69   (let ((*package* *keyword-package*))
  70     (apply #'symbolicate things)))
  71 \f
  72 ;;;; miscellaneous iteration extensions
  73
  74 (defmacro dovector ((elt vector &optional result) &rest forms)
  75   #!+sb-doc
  76   "just like DOLIST, but with one-dimensional arrays"
  77   (let ((index (gensym))
  78         (length (gensym))
  79         (vec (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)))
  86            ,@forms)))))
  87
  88 (defmacro dohash ((key-var value-var table &optional result) &body body)
  89   #!+sb-doc
  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)
  93     (let ((gen (gensym))
  94           (n-more (gensym)))
  95       `(with-hash-table-iterator (,gen ,table)
  96          (loop
  97           (multiple-value-bind (,n-more ,key-var ,value-var) (,gen)
  98             ,@decls
  99             (unless ,n-more (return ,result))
 100             ,@forms))))))
 101 \f
 102 ;;;; hash cache utility
 103
 104 (eval-when (:compile-toplevel :load-toplevel :execute)
 105   (defvar *profile-hash-cache* nil))
 106
 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)
 111                                   (values 1))
 112   #!+sb-doc
 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.
 120
 121   Name is used to define these functions:
 122
 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).
 126
 127   <name>-CACHE-ENTER Arg* Value*
 128       Encache the association of the specified args with Value.
 129
 130   <name>-CACHE-CLEAR
 131       Reinitialize the cache, invalidating all entries and allowing the
 132       arguments and result values to be GC'd.
 133
 134   These other keywords are defined:
 135
 136   :HASH-BITS <n>
 137       The size of the cache as a power of 2.
 138
 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>)).
 142
 143   :VALUES <n>
 144       The number of values cached.
 145
 146   :INIT-WRAPPER <name>
 147       The code for initializing the cache is wrapped in a form with the
 148       specified name. Default PROGN."
 149
 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))
 156                              (cdr default)
 157                              (list default)))
 158          (n-index (gensym))
 159          (n-cache (gensym)))
 160
 161     (unless (= (length default-values) values)
 162       (error "The number of default values ~S differs from :VALUES ~D."
 163              default values))
 164
 165     (collect ((inlines)
 166               (forms)
 167               (inits)
 168               (tests)
 169               (sets)
 170               (arg-vars)
 171               (values-indices)
 172               (values-names))
 173       (dotimes (i values)
 174         (values-indices `(+ ,n-index ,(+ nargs i)))
 175         (values-names (gensym)))
 176       (let ((n 0))
 177         (dolist (arg args)
 178           (unless (= (length arg) 2)
 179             (error "bad arg spec: ~S" arg))
 180           (let ((arg-name (first arg))
 181                 (test (second arg)))
 182             (arg-vars arg-name)
 183             (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
 184             (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name)))
 185           (incf n)))
 186
 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)))))
 195
 196       (let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
 197         (inlines fun-name)
 198         (forms
 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))
 207                                        (values-indices))))
 208                     (t
 209                      ,@(when *profile-hash-cache*
 210                          `((incf ,(symbolicate  "*" name "-CACHE-MISSES*"))))
 211                      ,default))))))
 212
 213       (let ((fun-name (symbolicate name "-CACHE-ENTER")))
 214         (inlines fun-name)
 215         (forms
 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))
 220               ,@(sets)
 221               ,@(mapcar #'(lambda (i val)
 222                             `(setf (svref ,n-cache ,i) ,val))
 223                         (values-indices)
 224                         (values-names))
 225               (values)))))
 226
 227       (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
 228         (forms
 229          `(defun ,fun-name ()
 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))
 233                 ((minusp ,n-index))
 234               (declare (type fixnum ,n-index))
 235               ,@(collect ((arg-sets))
 236                   (dotimes (i nargs)
 237                     (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
 238                   (arg-sets))
 239               ,@(mapcar #'(lambda (i val)
 240                             `(setf (svref ,n-cache ,i) ,val))
 241                         (values-indices)
 242                         default-values))
 243             (/show0 ,(concatenate 'string "leaving " (string fun-name)))
 244             (values)))
 245         (forms `(,fun-name)))
 246
 247       (inits `(unless (boundp ',var-name)
 248                 (setq ,var-name (make-array ,total-size))))
 249
 250       `(progn
 251          (defvar ,var-name)
 252          (declaim (type (simple-vector ,total-size) ,var-name))
 253          #!-sb-fluid (declaim (inline ,@(inlines)))
 254          (,init-wrapper ,@(inits))
 255          ,@(forms)
 256          ',name))))
 257
 258 (defmacro defun-cached ((name &rest options &key (values 1) default
 259                               &allow-other-keys)
 260                         args &body body-decls-doc)
 261   #!+sb-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
 264   DEFINE-HASH-CACHE."
 265   (let ((default-values (if (and (consp default) (eq (car default) 'values))
 266                             (cdr default)
 267                             (list default)))
 268         (arg-names (mapcar #'car args)))
 269     (collect ((values-names))
 270       (dotimes (i values)
 271         (values-names (gensym)))
 272       (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
 273         `(progn
 274            (define-hash-cache ,name ,args ,@options)
 275            (defun ,name ,arg-names
 276              ,@decls
 277              ,doc
 278              (multiple-value-bind ,(values-names)
 279                  (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
 280                (if (and ,@(mapcar #'(lambda (val def)
 281                                       `(eq ,val ,def))
 282                                   (values-names) default-values))
 283                    (multiple-value-bind ,(values-names)
 284                                         (progn ,@body)
 285                      (,(symbolicate name "-CACHE-ENTER") ,@arg-names
 286                       ,@(values-names))
 287                      (values ,@(values-names)))
 288                    (values ,@(values-names))))))))))
 289 \f
 290 ;;;; package idioms
 291
 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))))
 302
 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
 309         maybe-result
 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)))))
 314 \f
 315 ;;;; miscellany
 316
 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))
 322     (if name1
 323         (intern (concatenate 'simple-string
 324                              (symbol-name name1)
 325                              (symbol-name name2)))
 326         name2)))
 327
 328 ;;; Is NAME a legal function name?
 329 (defun legal-function-name-p (name)
 330   (or (symbolp name)
 331       (and (consp name)
 332            (eq (car name) 'setf)
 333            (consp (cdr name))
 334            (symbolp (cadr name))
 335            (null (cddr name)))))
 336
 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)
 342          function-name)
 343         ((and (consp function-name)
 344               (= (length function-name) 2)
 345               (eq (first function-name) 'setf))
 346          (second function-name))
 347         (t
 348          (error "not legal as a function name: ~S" function-name))))
 349
 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
 354       (and (consp x)
 355            (list-of-length-at-least-p (cdr x) (1- n)))))
 356
 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)))
 362 \f
 363 #|
 364 ;;; REMOVEME when done testing byte cross-compiler
 365 (defun byte-compiled-foo (x y)
 366   (declare (optimize (speed 0) (debug 1)))
 367   (if x
 368       x
 369       (cons y y)))
 370 |#