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 (file-comment
  22   "$Header$")
  23
  24 ;;; the default value used for initializing character data. The ANSI
  25 ;;; spec says this is arbitrary. CMU CL used #\NULL, which we avoid
  26 ;;; because it's not in the ANSI table of portable characters.
  27 (defconstant default-init-char #\space)
  28
  29 ;;; CHAR-CODE values for ASCII characters which we care about but
  30 ;;; which aren't defined in section "2.1.3 Standard Characters" of the
  31 ;;; ANSI specification for Lisp
  32 ;;;
  33 ;;; KLUDGE: These are typically used in the idiom (CODE-CHAR
  34 ;;; FOO-CHAR-CODE). I suspect that the current implementation is
  35 ;;; expanding this idiom into a full call to CODE-CHAR, which is an
  36 ;;; annoying overhead. I should check whether this is happening, and
  37 ;;; if so, perhaps implement a DEFTRANSFORM or something to stop it.
  38 ;;; (or just find a nicer way of expressing characters portably?) --
  39 ;;; WHN 19990713
  40 (defconstant bell-char-code 7)
  41 (defconstant tab-char-code 9)
  42 (defconstant form-feed-char-code 12)
  43 (defconstant return-char-code 13)
  44 (defconstant escape-char-code 27)
  45 (defconstant rubout-char-code 127)
  46 \f
  47 ;;; Concatenate together the names of some strings and symbols,
  48 ;;; producing a symbol in the current package.
  49 (eval-when (:compile-toplevel :load-toplevel :execute)
  50   (declaim (ftype (function (&rest (or string symbol)) symbol) symbolicate))
  51   (defun symbolicate (&rest things)
  52     (values (intern (apply #'concatenate
  53                            'string
  54                            (mapcar #'string things))))))
  55
  56 ;;; like SYMBOLICATE, but producing keywords
  57 (defun keywordicate (&rest things)
  58   (let ((*package* *keyword-package*))
  59     (apply #'symbolicate things)))
  60 \f
  61 ;;;; miscellaneous iteration extensions
  62
  63 (defmacro dovector ((elt vector &optional result) &rest forms)
  64   #!+sb-doc
  65   "just like DOLIST, but with one-dimensional arrays"
  66   (let ((index (gensym))
  67         (length (gensym))
  68         (vec (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)))
  75            ,@forms)))))
  76
  77 (defmacro dohash ((key-var value-var table &optional result) &body body)
  78   #!+sb-doc
  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)
  82     (let ((gen (gensym))
  83           (n-more (gensym)))
  84       `(with-hash-table-iterator (,gen ,table)
  85          (loop
  86           (multiple-value-bind (,n-more ,key-var ,value-var) (,gen)
  87             ,@decls
  88             (unless ,n-more (return ,result))
  89             ,@forms))))))
  90 \f
  91 ;;;; hash cache utility
  92
  93 (eval-when (:compile-toplevel :load-toplevel :execute)
  94   (defvar *profile-hash-cache* nil))
  95
  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
  99                                   (init-wrapper 'progn)
 100                                   (values 1))
 101   #!+sb-doc
 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.
 109
 110   Name is used to define these functions:
 111
 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).
 115
 116   <name>-CACHE-ENTER Arg* Value*
 117       Encache the association of the specified args with Value.
 118
 119   <name>-CACHE-CLEAR
 120       Reinitialize the cache, invalidating all entries and allowing the
 121       arguments and result values to be GC'd.
 122
 123   These other keywords are defined:
 124
 125   :HASH-BITS <n>
 126       The size of the cache as a power of 2.
 127
 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>)).
 131
 132   :VALUES <n>
 133       The number of values cached.
 134
 135   :INIT-WRAPPER <name>
 136       The code for initializing the cache is wrapped in a form with the
 137       specified name. Default PROGN."
 138
 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))
 145                              (cdr default)
 146                              (list default)))
 147          (n-index (gensym))
 148          (n-cache (gensym)))
 149
 150     (unless (= (length default-values) values)
 151       (error "The number of default values ~S differs from :VALUES ~D."
 152              default values))
 153
 154     (collect ((inlines)
 155               (forms)
 156               (inits)
 157               (tests)
 158               (sets)
 159               (arg-vars)
 160               (values-indices)
 161               (values-names))
 162       (dotimes (i values)
 163         (values-indices `(+ ,n-index ,(+ nargs i)))
 164         (values-names (gensym)))
 165       (let ((n 0))
 166         (dolist (arg args)
 167           (unless (= (length arg) 2)
 168             (error "bad arg spec: ~S" arg))
 169           (let ((arg-name (first arg))
 170                 (test (second arg)))
 171             (arg-vars arg-name)
 172             (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
 173             (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name)))
 174           (incf n)))
 175
 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)))))
 184
 185       (let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
 186         (inlines fun-name)
 187         (forms
 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))
 196                                        (values-indices))))
 197                     (t
 198                      ,@(when *profile-hash-cache*
 199                          `((incf ,(symbolicate  "*" name "-CACHE-MISSES*"))))
 200                      ,default))))))
 201
 202       (let ((fun-name (symbolicate name "-CACHE-ENTER")))
 203         (inlines fun-name)
 204         (forms
 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))
 209               ,@(sets)
 210               ,@(mapcar #'(lambda (i val)
 211                             `(setf (svref ,n-cache ,i) ,val))
 212                         (values-indices)
 213                         (values-names))
 214               (values)))))
 215
 216       (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
 217         (forms
 218          `(defun ,fun-name ()
 219             (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
 220                  (,n-cache ,var-name))
 221                 ((minusp ,n-index))
 222               (declare (type fixnum ,n-index))
 223               ,@(collect ((arg-sets))
 224                   (dotimes (i nargs)
 225                     (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
 226                   (arg-sets))
 227               ,@(mapcar #'(lambda (i val)
 228                             `(setf (svref ,n-cache ,i) ,val))
 229                         (values-indices)
 230                         default-values))
 231             (values)))
 232         (forms `(,fun-name)))
 233
 234       (inits `(unless (boundp ',var-name)
 235                 (setq ,var-name (make-array ,total-size))))
 236
 237       `(progn
 238          (defvar ,var-name)
 239          (declaim (type (simple-vector ,total-size) ,var-name))
 240          #!-sb-fluid (declaim (inline ,@(inlines)))
 241          (,init-wrapper ,@(inits))
 242          ,@(forms)
 243          ',name))))
 244
 245 (defmacro defun-cached ((name &rest options &key (values 1) default
 246                               &allow-other-keys)
 247                         args &body body-decls-doc)
 248   #!+sb-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
 251   DEFINE-HASH-CACHE."
 252   (let ((default-values (if (and (consp default) (eq (car default) 'values))
 253                             (cdr default)
 254                             (list default)))
 255         (arg-names (mapcar #'car args)))
 256     (collect ((values-names))
 257       (dotimes (i values)
 258         (values-names (gensym)))
 259       (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
 260         `(progn
 261            (define-hash-cache ,name ,args ,@options)
 262            (defun ,name ,arg-names
 263              ,@decls
 264              ,doc
 265              (multiple-value-bind ,(values-names)
 266                  (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
 267                (if (and ,@(mapcar #'(lambda (val def)
 268                                       `(eq ,val ,def))
 269                                   (values-names) default-values))
 270                    (multiple-value-bind ,(values-names)
 271                                         (progn ,@body)
 272                      (,(symbolicate name "-CACHE-ENTER") ,@arg-names
 273                       ,@(values-names))
 274                      (values ,@(values-names)))
 275                    (values ,@(values-names))))))))))
 276 \f
 277 ;;;; package idioms
 278
 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))))
 289
 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
 296         maybe-result
 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)))))
 301 \f
 302 ;;;; miscellany
 303
 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))
 309     (if name1
 310         (intern (concatenate 'simple-string
 311                              (symbol-name name1)
 312                              (symbol-name name2)))
 313         name2)))
 314
 315 ;;; Is NAME a legal function name?
 316 (defun legal-function-name-p (name)
 317   (or (symbolp name)
 318       (and (consp name)
 319            (eq (car name) 'setf)
 320            (consp (cdr name))
 321            (symbolp (cadr name))
 322            (null (cddr name)))))
 323
 324 ;;; Given a function name, return the name for the BLOCK which encloses its
 325 ;;; 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)
 329          function-name)
 330         ((and (consp function-name)
 331               (= (length function-name) 2)
 332               (eq (first function-name) 'setf))
 333          (second function-name))
 334         (t
 335          (error "not legal as a function name: ~S" function-name))))
 336
 337 ;;; Is X a (possibly-improper) list of at least N elements?
 338 (defun list-of-length-at-least-p (x n)
 339   (declare (type (and unsigned-byte fixnum) n))
 340   (or (zerop n) ; since anything can be considered an improper list of length 0
 341       (and (consp x)
 342            (list-of-length-at-least-p (cdr x) (1- n)))))
 343 \f
 344 #|
 345 ;;; REMOVEME when done testing byte cross-compiler
 346 (defun byte-compiled-foo (x y)
 347   (declare (optimize (speed 0) (debug 1)))
 348   (if x
 349       x
 350       (cons y y)))
 351 |#