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 ;;; a type used for indexing into arrays, and for related quantities
  25 ;;; like lengths of lists
  26 ;;;
  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
  32 ;;; result.
  33 ;;;
  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)))
  37
  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)
  42
  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
  46 ;;;
  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?) --
  53 ;;; WHN 19990713
  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)
  60 \f
  61 ;;; Concatenate together the names of some strings and symbols,
  62 ;;; producing a symbol in the current package.
  63 (eval-when (:compile-toplevel :load-toplevel :execute)
  64   (declaim (ftype (function (&rest (or string symbol)) symbol) symbolicate))
  65   (defun symbolicate (&rest things)
  66     (values (intern (apply #'concatenate
  67                            'string
  68                            (mapcar #'string things))))))
  69
  70 ;;; like SYMBOLICATE, but producing keywords
  71 (defun keywordicate (&rest things)
  72   (let ((*package* *keyword-package*))
  73     (apply #'symbolicate things)))
  74 \f
  75 ;;;; miscellaneous iteration extensions
  76
  77 (defmacro dovector ((elt vector &optional result) &rest forms)
  78   #!+sb-doc
  79   "just like DOLIST, but with one-dimensional arrays"
  80   (let ((index (gensym))
  81         (length (gensym))
  82         (vec (gensym)))
  83     `(let ((,vec ,vector))
  84        (declare (type vector ,vec))
  85        (do ((,index 0 (1+ ,index))
  86             (,length (length ,vec)))
  87            ((>= ,index ,length) ,result)
  88          (let ((,elt (aref ,vec ,index)))
  89            ,@forms)))))
  90
  91 (defmacro dohash ((key-var value-var table &optional result) &body body)
  92   #!+sb-doc
  93   "DOHASH (Key-Var Value-Var Table [Result]) Declaration* Form*
  94    Iterate over the entries in a hash-table."
  95   (multiple-value-bind (forms decls) (parse-body body nil)
  96     (let ((gen (gensym))
  97           (n-more (gensym)))
  98       `(with-hash-table-iterator (,gen ,table)
  99          (loop
 100           (multiple-value-bind (,n-more ,key-var ,value-var) (,gen)
 101             ,@decls
 102             (unless ,n-more (return ,result))
 103             ,@forms))))))
 104 \f
 105 ;;;; hash cache utility
 106
 107 (eval-when (:compile-toplevel :load-toplevel :execute)
 108   (defvar *profile-hash-cache* nil))
 109
 110 ;;; :INIT-WRAPPER is set to COLD-INIT-FORMS in type system definitions
 111 ;;; so that caches will be created before top-level forms run.
 112 (defmacro define-hash-cache (name args &key hash-function hash-bits default
 113                                   (init-wrapper 'progn)
 114                                   (values 1))
 115   #!+sb-doc
 116   "DEFINE-HASH-CACHE Name ({(Arg-Name Test-Function)}*) {Key Value}*
 117   Define a hash cache that associates some number of argument values to a
 118   result value. The Test-Function paired with each Arg-Name is used to compare
 119   the value for that arg in a cache entry with a supplied arg. The
 120   Test-Function must not error when passed NIL as its first arg, but need not
 121   return any particular value. Test-Function may be any thing that can be
 122   placed in CAR position.
 123
 124   Name is used to define these functions:
 125
 126   <name>-CACHE-LOOKUP Arg*
 127       See whether there is an entry for the specified Args in the cache. If
 128       not present, the :DEFAULT keyword (default NIL) determines the result(s).
 129
 130   <name>-CACHE-ENTER Arg* Value*
 131       Encache the association of the specified args with Value.
 132
 133   <name>-CACHE-CLEAR
 134       Reinitialize the cache, invalidating all entries and allowing the
 135       arguments and result values to be GC'd.
 136
 137   These other keywords are defined:
 138
 139   :HASH-BITS <n>
 140       The size of the cache as a power of 2.
 141
 142   :HASH-FUNCTION function
 143       Some thing that can be placed in CAR position which will compute a value
 144       between 0 and (1- (expt 2 <hash-bits>)).
 145
 146   :VALUES <n>
 147       The number of values cached.
 148
 149   :INIT-WRAPPER <name>
 150       The code for initializing the cache is wrapped in a form with the
 151       specified name. Default PROGN."
 152
 153   (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
 154          (nargs (length args))
 155          (entry-size (+ nargs values))
 156          (size (ash 1 hash-bits))
 157          (total-size (* entry-size size))
 158          (default-values (if (and (consp default) (eq (car default) 'values))
 159                              (cdr default)
 160                              (list default)))
 161          (n-index (gensym))
 162          (n-cache (gensym)))
 163
 164     (unless (= (length default-values) values)
 165       (error "The number of default values ~S differs from :VALUES ~D."
 166              default values))
 167
 168     (collect ((inlines)
 169               (forms)
 170               (inits)
 171               (tests)
 172               (sets)
 173               (arg-vars)
 174               (values-indices)
 175               (values-names))
 176       (dotimes (i values)
 177         (values-indices `(+ ,n-index ,(+ nargs i)))
 178         (values-names (gensym)))
 179       (let ((n 0))
 180         (dolist (arg args)
 181           (unless (= (length arg) 2)
 182             (error "bad arg spec: ~S" arg))
 183           (let ((arg-name (first arg))
 184                 (test (second arg)))
 185             (arg-vars arg-name)
 186             (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
 187             (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name)))
 188           (incf n)))
 189
 190       (when *profile-hash-cache*
 191         (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*"))
 192               (n-miss (symbolicate "*" name "-CACHE-MISSES*")))
 193           (inits `(setq ,n-probe 0))
 194           (inits `(setq ,n-miss 0))
 195           (forms `(defvar ,n-probe))
 196           (forms `(defvar ,n-miss))
 197           (forms `(declaim (fixnum ,n-miss ,n-probe)))))
 198
 199       (let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
 200         (inlines fun-name)
 201         (forms
 202          `(defun ,fun-name ,(arg-vars)
 203             ,@(when *profile-hash-cache*
 204                 `((incf ,(symbolicate  "*" name "-CACHE-PROBES*"))))
 205             (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
 206                   (,n-cache ,var-name))
 207               (declare (type fixnum ,n-index))
 208               (cond ((and ,@(tests))
 209                      (values ,@(mapcar (lambda (x) `(svref ,n-cache ,x))
 210                                        (values-indices))))
 211                     (t
 212                      ,@(when *profile-hash-cache*
 213                          `((incf ,(symbolicate  "*" name "-CACHE-MISSES*"))))
 214                      ,default))))))
 215
 216       (let ((fun-name (symbolicate name "-CACHE-ENTER")))
 217         (inlines fun-name)
 218         (forms
 219          `(defun ,fun-name (,@(arg-vars) ,@(values-names))
 220             (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
 221                   (,n-cache ,var-name))
 222               (declare (type fixnum ,n-index))
 223               ,@(sets)
 224               ,@(mapcar #'(lambda (i val)
 225                             `(setf (svref ,n-cache ,i) ,val))
 226                         (values-indices)
 227                         (values-names))
 228               (values)))))
 229
 230       (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
 231         (forms
 232          `(defun ,fun-name ()
 233             (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
 234                  (,n-cache ,var-name))
 235                 ((minusp ,n-index))
 236               (declare (type fixnum ,n-index))
 237               ,@(collect ((arg-sets))
 238                   (dotimes (i nargs)
 239                     (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
 240                   (arg-sets))
 241               ,@(mapcar #'(lambda (i val)
 242                             `(setf (svref ,n-cache ,i) ,val))
 243                         (values-indices)
 244                         default-values))
 245             (values)))
 246         (forms `(,fun-name)))
 247
 248       (inits `(unless (boundp ',var-name)
 249                 (setq ,var-name (make-array ,total-size))))
 250
 251       `(progn
 252          (defvar ,var-name)
 253          (declaim (type (simple-vector ,total-size) ,var-name))
 254          #!-sb-fluid (declaim (inline ,@(inlines)))
 255          (,init-wrapper ,@(inits))
 256          ,@(forms)
 257          ',name))))
 258
 259 (defmacro defun-cached ((name &rest options &key (values 1) default
 260                               &allow-other-keys)
 261                         args &body body-decls-doc)
 262   #!+sb-doc
 263   "DEFUN-CACHED (Name {Key Value}*) ({(Arg-Name Test-Function)}*) Form*
 264   Some syntactic sugar for defining a function whose values are cached by
 265   DEFINE-HASH-CACHE."
 266   (let ((default-values (if (and (consp default) (eq (car default) 'values))
 267                             (cdr default)
 268                             (list default)))
 269         (arg-names (mapcar #'car args)))
 270     (collect ((values-names))
 271       (dotimes (i values)
 272         (values-names (gensym)))
 273       (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
 274         `(progn
 275            (define-hash-cache ,name ,args ,@options)
 276            (defun ,name ,arg-names
 277              ,@decls
 278              ,doc
 279              (multiple-value-bind ,(values-names)
 280                  (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
 281                (if (and ,@(mapcar #'(lambda (val def)
 282                                       `(eq ,val ,def))
 283                                   (values-names) default-values))
 284                    (multiple-value-bind ,(values-names)
 285                                         (progn ,@body)
 286                      (,(symbolicate name "-CACHE-ENTER") ,@arg-names
 287                       ,@(values-names))
 288                      (values ,@(values-names)))
 289                    (values ,@(values-names))))))))))
 290 \f
 291 ;;;; package idioms
 292
 293 ;;; Note: Almost always you want to use FIND-UNDELETED-PACKAGE-OR-LOSE
 294 ;;; instead of this function. (The distinction only actually matters when
 295 ;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case
 296 ;;; you generally do want to signal an error instead of proceeding.)
 297 (defun %find-package-or-lose (package-designator)
 298   (or (find-package package-designator)
 299       (error 'sb!kernel:simple-package-error
 300              :package package-designator
 301              :format-control "The name ~S does not designate any package."
 302              :format-arguments (list package-designator))))
 303
 304 ;;; ANSI specifies (in the section for FIND-PACKAGE) that the
 305 ;;; consequences of most operations on deleted packages are
 306 ;;; unspecified. We try to signal errors in such cases.
 307 (defun find-undeleted-package-or-lose (package-designator)
 308   (let ((maybe-result (%find-package-or-lose package-designator)))
 309     (if (package-name maybe-result)     ; if not deleted
 310         maybe-result
 311         (error 'sb!kernel:simple-package-error
 312                :package maybe-result
 313                :format-control "The package ~S has been deleted."
 314                :format-arguments (list maybe-result)))))
 315 \f
 316 ;;;; miscellany
 317
 318 ;;; FIXME: What is this used for that SYMBOLICATE couldn't be used for instead?
 319 ;;; If nothing, replace it.
 320 (eval-when (:compile-toplevel :load-toplevel :execute)
 321   (defun concat-pnames (name1 name2)
 322     (declare (symbol name1 name2))
 323     (if name1
 324         (intern (concatenate 'simple-string
 325                              (symbol-name name1)
 326                              (symbol-name name2)))
 327         name2)))
 328
 329 ;;; Is NAME a legal function name?
 330 (defun legal-function-name-p (name)
 331   (or (symbolp name)
 332       (and (consp name)
 333            (eq (car name) 'setf)
 334            (consp (cdr name))
 335            (symbolp (cadr name))
 336            (null (cddr name)))))
 337
 338 ;;; Given a function name, return the name for the BLOCK which encloses its
 339 ;;; body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
 340 (declaim (ftype (function ((or symbol cons)) symbol) function-name-block-name))
 341 (defun function-name-block-name (function-name)
 342   (cond ((symbolp function-name)
 343          function-name)
 344         ((and (consp function-name)
 345               (= (length function-name) 2)
 346               (eq (first function-name) 'setf))
 347          (second function-name))
 348         (t
 349          (error "not legal as a function name: ~S" function-name))))
 350
 351 ;;; Is X a (possibly-improper) list of at least N elements?
 352 (declaim (ftype (function (t index)) list-of-length-at-least-p))
 353 (defun list-of-length-at-least-p (x n)
 354   (or (zerop n) ; since anything can be considered an improper list of length 0
 355       (and (consp x)
 356            (list-of-length-at-least-p (cdr x) (1- n)))))
 357
 358 ;;; Return a list of N gensyms. (This is a common suboperation in
 359 ;;; macros and other code-manipulating code.)
 360 (declaim (ftype (function (index) list) make-gensym-list))
 361 (defun make-gensym-list (n)
 362   (loop repeat n collect (gensym)))
 363 \f
 364 #|
 365 ;;; REMOVEME when done testing byte cross-compiler
 366 (defun byte-compiled-foo (x y)
 367   (declare (optimize (speed 0) (debug 1)))
 368   (if x
 369       x
 370       (cons y y)))
 371 |#