src/code/boot-extensions.lisp

   1 ;;;; extensions which are needed in order to (cross-)compile target-only code
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!IMPL")
  13
  14 ;;; Lots of code wants to get to the KEYWORD package or the
  15 ;;; COMMON-LISP package without a lot of fuss, so we cache them in
  16 ;;; variables. TO DO: How much does this actually buy us? It sounds
  17 ;;; sensible, but I don't know for sure that it saves space or time..
  18 ;;; -- WHN 19990521
  19 ;;;
  20 ;;; (The initialization forms here only matter on the cross-compilation
  21 ;;; host; In the target SBCL, these variables are set in cold init.)
  22 (declaim (type package *cl-package* *keyword-package*))
  23 (defvar *cl-package*      (find-package "COMMON-LISP"))
  24 (defvar *keyword-package* (find-package "KEYWORD"))
  25
  26 ;;; a helper function for various macros which expect clauses of a
  27 ;;; given length, etc.
  28 ;;;
  29 ;;; FIXME: This implementation will hang on circular list structure.
  30 ;;; Since this is an error-checking utility, i.e. its job is to deal
  31 ;;; with screwed-up input, it'd be good style to fix it so that it can
  32 ;;; deal with circular list structure.
  33 (eval-when (:compile-toplevel :load-toplevel :execute)
  34   ;; Return true if X is a proper list whose length is between MIN and
  35   ;; MAX (inclusive).
  36   (defun proper-list-of-length-p (x min &optional (max min))
  37     (cond ((minusp max)
  38            nil)
  39           ((null x)
  40            (zerop min))
  41           ((consp x)
  42            (and (plusp max)
  43                 (proper-list-of-length-p (cdr x)
  44                                          (if (plusp (1- min))
  45                                            (1- min)
  46                                            0)
  47                                          (1- max))))
  48           (t nil))))
  49 \f
  50 ;;;; the COLLECT macro
  51
  52 ;;; helper functions for COLLECT, which become the expanders of the
  53 ;;; MACROLET definitions created by COLLECT
  54 ;;;
  55 ;;; COLLECT-NORMAL-EXPANDER handles normal collection macros.
  56 ;;;
  57 ;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
  58 ;;; is the pointer to the current tail of the list, or NIL if the list
  59 ;;; is empty.
  60 (defun collect-normal-expander (n-value fun forms)
  61   `(progn
  62     ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
  63     ,n-value))
  64 (defun collect-list-expander (n-value n-tail forms)
  65   (let ((n-res (gensym)))
  66     `(progn
  67       ,@(mapcar #'(lambda (form)
  68                     `(let ((,n-res (cons ,form nil)))
  69                        (cond (,n-tail
  70                               (setf (cdr ,n-tail) ,n-res)
  71                               (setq ,n-tail ,n-res))
  72                              (t
  73                               (setq ,n-tail ,n-res  ,n-value ,n-res)))))
  74                 forms)
  75       ,n-value)))
  76
  77 ;;; the ultimate collection macro...
  78 (defmacro collect (collections &body body)
  79   #!+sb-doc
  80   "Collect ({(Name [Initial-Value] [Function])}*) {Form}*
  81   Collect some values somehow. Each of the collections specifies a bunch of
  82   things which collected during the evaluation of the body of the form. The
  83   name of the collection is used to define a local macro, a la MACROLET.
  84   Within the body, this macro will evaluate each of its arguments and collect
  85   the result, returning the current value after the collection is done. The
  86   body is evaluated as a PROGN; to get the final values when you are done, just
  87   call the collection macro with no arguments.
  88
  89   INITIAL-VALUE is the value that the collection starts out with, which
  90   defaults to NIL. FUNCTION is the function which does the collection. It is
  91   a function which will accept two arguments: the value to be collected and the
  92   current collection. The result of the function is made the new value for the
  93   collection. As a totally magical special-case, FUNCTION may be COLLECT,
  94   which tells us to build a list in forward order; this is the default. If an
  95   INITIAL-VALUE is supplied for Collect, the stuff will be RPLACD'd onto the
  96   end. Note that FUNCTION may be anything that can appear in the functional
  97   position, including macros and lambdas."
  98
  99   (let ((macros ())
 100         (binds ()))
 101     (dolist (spec collections)
 102       (unless (proper-list-of-length-p spec 1 3)
 103         (error "Malformed collection specifier: ~S." spec))
 104       (let* ((name (first spec))
 105              (default (second spec))
 106              (kind (or (third spec) 'collect))
 107              (n-value (gensym (concatenate 'string
 108                                            (symbol-name name)
 109                                            "-N-VALUE-"))))
 110         (push `(,n-value ,default) binds)
 111         (if (eq kind 'collect)
 112           (let ((n-tail (gensym (concatenate 'string
 113                                              (symbol-name name)
 114                                              "-N-TAIL-"))))
 115             (if default
 116               (push `(,n-tail (last ,n-value)) binds)
 117               (push n-tail binds))
 118             (push `(,name (&rest args)
 119                      (collect-list-expander ',n-value ',n-tail args))
 120                   macros))
 121           (push `(,name (&rest args)
 122                    (collect-normal-expander ',n-value ',kind args))
 123                 macros))))
 124     `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
 125 \f
 126 ;;; This function can be used as the default value for keyword
 127 ;;; arguments that must be always be supplied. Since it is known by
 128 ;;; the compiler to never return, it will avoid any compile-time type
 129 ;;; warnings that would result from a default value inconsistent with
 130 ;;; the declared type. When this function is called, it signals an
 131 ;;; error indicating that a required keyword argument was not
 132 ;;; supplied. This function is also useful for DEFSTRUCT slot defaults
 133 ;;; corresponding to required arguments.
 134 (declaim (ftype (function () nil) required-argument))
 135 (defun required-argument ()
 136   #!+sb-doc
 137   (/show0 "entering REQUIRED-ARGUMENT")
 138   (error "A required keyword argument was not supplied."))
 139 \f
 140 ;;; "the ultimate iteration macro"
 141 ;;;
 142 ;;; note for Schemers: This seems to be identical to Scheme's "named LET".
 143 (defmacro named-let (name binds &body body)
 144   #!+sb-doc
 145   (dolist (x binds)
 146     (unless (proper-list-of-length-p x 2)
 147       (error "Malformed ITERATE variable spec: ~S." x)))
 148   `(labels ((,name ,(mapcar #'first binds) ,@body))
 149      (,name ,@(mapcar #'second binds))))
 150
 151 ;;; ONCE-ONLY is a utility useful in writing source transforms and
 152 ;;; macros. It provides a concise way to wrap a LET around some code
 153 ;;; to ensure that some forms are only evaluated once.
 154 ;;;
 155 ;;; Create a LET* which evaluates each value expression, binding a
 156 ;;; temporary variable to the result, and wrapping the LET* around the
 157 ;;; result of the evaluation of BODY. Within the body, each VAR is
 158 ;;; bound to the corresponding temporary variable.
 159 (defmacro once-only (specs &body body)
 160   (named-let frob ((specs specs)
 161                    (body body))
 162     (if (null specs)
 163         `(progn ,@body)
 164         (let ((spec (first specs)))
 165           ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
 166           (unless (proper-list-of-length-p spec 2)
 167             (error "malformed ONCE-ONLY binding spec: ~S" spec))
 168           (let* ((name (first spec))
 169                  (exp-temp (gensym (symbol-name name))))
 170             `(let ((,exp-temp ,(second spec))
 171                    (,name (gensym "ONCE-ONLY-")))
 172                `(let ((,,name ,,exp-temp))
 173                   ,,(frob (rest specs) body))))))))
 174 \f
 175 ;;;; some old-fashioned functions. (They're not just for old-fashioned
 176 ;;;; code, they're also used as optimized forms of the corresponding
 177 ;;;; general functions when the compiler can prove that they're
 178 ;;;; equivalent.)
 179
 180 ;;; like (MEMBER ITEM LIST :TEST #'EQ)
 181 (defun memq (item list)
 182   #!+sb-doc
 183   "Returns tail of LIST beginning with first element EQ to ITEM."
 184   ;; KLUDGE: These could be and probably should be defined as
 185   ;;   (MEMBER ITEM LIST :TEST #'EQ)),
 186   ;; but when I try to cross-compile that, I get an error from
 187   ;; LTN-ANALYZE-KNOWN-CALL, "Recursive known function definition". The
 188   ;; comments for that error say it "is probably a botched interpreter stub".
 189   ;; Rather than try to figure that out, I just rewrote this function from
 190   ;; scratch. -- WHN 19990512
 191   (do ((i list (cdr i)))
 192       ((null i))
 193     (when (eq (car i) item)
 194       (return i))))
 195
 196 ;;; like (ASSOC ITEM ALIST :TEST #'EQ)
 197 (defun assq (item alist)
 198   #!+sb-doc
 199   "Return the first pair of ALIST where ITEM is EQ to the key of the pair."
 200   ;; KLUDGE: CMU CL defined this with
 201   ;;   (DECLARE (INLINE ASSOC))
 202   ;;   (ASSOC ITEM ALIST :TEST #'EQ))
 203   ;; which is pretty, but which would have required adding awkward
 204   ;; build order constraints on SBCL (or figuring out some way to make
 205   ;; inline definitions installable at build-the-cross-compiler time,
 206   ;; which was too ambitious for now). Rather than mess with that, we
 207   ;; just define ASSQ explicitly in terms of more primitive
 208   ;; operations:
 209   (dolist (pair alist)
 210     (when (eq (car pair) item)
 211       (return pair))))
 212
 213 (defun delq (item list)
 214   #!+sb-doc
 215   "Delete all LIST entries EQ to ITEM (destructively modifying LIST), and
 216   return the modified LIST."
 217   (let ((list list))
 218     (do ((x list (cdr x))
 219          (splice '()))
 220         ((endp x) list)
 221       (cond ((eq item (car x))
 222              (if (null splice)
 223                (setq list (cdr x))
 224                (rplacd splice (cdr x))))
 225             (t (setq splice x)))))) ; Move splice along to include element.
 226
 227
 228 ;; (defmacro posq (item list) `(position ,item ,list :test #'eq))
 229 (defun posq (item list)
 230   #!+sb-doc
 231   "Returns the position of the first element EQ to ITEM."
 232   (do ((i list (cdr i))
 233        (j 0 (1+ j)))
 234       ((null i))
 235     (when (eq (car i) item)
 236       (return j))))
 237
 238 ;; (defmacro neq (x y) `(not (eq ,x ,y)))
 239 (defun neq (x y) (not (eq x y)))