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!EXT")
  13
  14 (file-comment
  15   "$Header$")
  16
  17 ;;; Lots of code wants to get to the KEYWORD package or the COMMON-LISP package
  18 ;;; without a lot of fuss, so we cache them in variables. TO DO: How much
  19 ;;; does this actually buy us? It sounds sensible, but I don't know for sure
  20 ;;; that it saves space or time.. -- WHN 19990521
  21 (declaim (type package *cl-package* *keyword-package*))
  22 (defvar *cl-package*        (find-package "COMMON-LISP"))
  23 (defvar *keyword-package*   (find-package "KEYWORD"))
  24 \f
  25 ;;;; the COLLECT macro
  26
  27 ;;; helper functions for COLLECT, which become the expanders of the MACROLET
  28 ;;; definitions created by COLLECT
  29 ;;;
  30 ;;; COLLECT-NORMAL-EXPANDER handles normal collection macros.
  31 ;;;
  32 ;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
  33 ;;; is the pointer to the current tail of the list, or NIL if the list
  34 ;;; is empty.
  35 (defun collect-normal-expander (n-value fun forms)
  36   `(progn
  37     ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
  38     ,n-value))
  39 (defun collect-list-expander (n-value n-tail forms)
  40   (let ((n-res (gensym)))
  41     `(progn
  42       ,@(mapcar #'(lambda (form)
  43                     `(let ((,n-res (cons ,form nil)))
  44                        (cond (,n-tail
  45                               (setf (cdr ,n-tail) ,n-res)
  46                               (setq ,n-tail ,n-res))
  47                              (t
  48                               (setq ,n-tail ,n-res  ,n-value ,n-res)))))
  49                 forms)
  50       ,n-value)))
  51
  52 ;;; the ultimate collection macro...
  53 (defmacro collect (collections &body body)
  54   #!+sb-doc
  55   "Collect ({(Name [Initial-Value] [Function])}*) {Form}*
  56   Collect some values somehow. Each of the collections specifies a bunch of
  57   things which collected during the evaluation of the body of the form. The
  58   name of the collection is used to define a local macro, a la MACROLET.
  59   Within the body, this macro will evaluate each of its arguments and collect
  60   the result, returning the current value after the collection is done. The
  61   body is evaluated as a PROGN; to get the final values when you are done, just
  62   call the collection macro with no arguments.
  63
  64   INITIAL-VALUE is the value that the collection starts out with, which
  65   defaults to NIL. FUNCTION is the function which does the collection. It is
  66   a function which will accept two arguments: the value to be collected and the
  67   current collection. The result of the function is made the new value for the
  68   collection. As a totally magical special-case, FUNCTION may be COLLECT,
  69   which tells us to build a list in forward order; this is the default. If an
  70   INITIAL-VALUE is supplied for Collect, the stuff will be RPLACD'd onto the
  71   end. Note that FUNCTION may be anything that can appear in the functional
  72   position, including macros and lambdas."
  73
  74   (let ((macros ())
  75         (binds ()))
  76     (dolist (spec collections)
  77       (unless (proper-list-of-length-p spec 1 3)
  78         (error "Malformed collection specifier: ~S." spec))
  79       (let* ((name (first spec))
  80              (default (second spec))
  81              (kind (or (third spec) 'collect))
  82              (n-value (gensym (concatenate 'string
  83                                            (symbol-name name)
  84                                            "-N-VALUE-"))))
  85         (push `(,n-value ,default) binds)
  86         (if (eq kind 'collect)
  87           (let ((n-tail (gensym (concatenate 'string
  88                                              (symbol-name name)
  89                                              "-N-TAIL-"))))
  90             (if default
  91               (push `(,n-tail (last ,n-value)) binds)
  92               (push n-tail binds))
  93             (push `(,name (&rest args)
  94                      (collect-list-expander ',n-value ',n-tail args))
  95                   macros))
  96           (push `(,name (&rest args)
  97                    (collect-normal-expander ',n-value ',kind args))
  98                 macros))))
  99     `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
 100 \f
 101 (declaim (ftype (function () nil) required-argument))
 102 (defun required-argument ()
 103   #!+sb-doc
 104   "This function can be used as the default value for keyword arguments that
 105   must be always be supplied. Since it is known by the compiler to never
 106   return, it will avoid any compile-time type warnings that would result from a
 107   default value inconsistent with the declared type. When this function is
 108   called, it signals an error indicating that a required keyword argument was
 109   not supplied. This function is also useful for DEFSTRUCT slot defaults
 110   corresponding to required arguments."
 111   (/show0 "entering REQUIRED-ARGUMENT")
 112   (error "A required keyword argument was not supplied."))
 113 \f
 114 ;;; "the ultimate iteration macro"
 115 ;;;
 116 ;;; note for Schemers: This seems to be identical to Scheme's "named LET".
 117 (defmacro iterate (name binds &body body)
 118   #!+sb-doc
 119   "Iterate Name ({(Var Initial-Value)}*) Declaration* Form*
 120   This is syntactic sugar for Labels. It creates a local function Name with
 121   the specified Vars as its arguments and the Declarations and Forms as its
 122   body. This function is then called with the Initial-Values, and the result
 123   of the call is returned from the macro."
 124   (dolist (x binds)
 125     (unless (proper-list-of-length-p x 2)
 126       (error "Malformed ITERATE variable spec: ~S." x)))
 127   `(labels ((,name ,(mapcar #'first binds) ,@body))
 128      (,name ,@(mapcar #'second binds))))
 129 \f
 130 ;;; Once-Only is a utility useful in writing source transforms and macros.
 131 ;;; It provides an easy way to wrap a LET around some code to ensure that some
 132 ;;; forms are only evaluated once.
 133 (defmacro once-only (specs &body body)
 134   #!+sb-doc
 135   "Once-Only ({(Var Value-Expression)}*) Form*
 136   Create a Let* which evaluates each Value-Expression, binding a temporary
 137   variable to the result, and wrapping the Let* around the result of the
 138   evaluation of Body. Within the body, each Var is bound to the corresponding
 139   temporary variable."
 140   (iterate frob
 141            ((specs specs)
 142             (body body))
 143     (if (null specs)
 144         `(progn ,@body)
 145         (let ((spec (first specs)))
 146           ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
 147           (unless (proper-list-of-length-p spec 2)
 148             (error "malformed ONCE-ONLY binding spec: ~S" spec))
 149           (let* ((name (first spec))
 150                  (exp-temp (gensym (symbol-name name))))
 151             `(let ((,exp-temp ,(second spec))
 152                    (,name (gensym "OO-")))
 153                `(let ((,,name ,,exp-temp))
 154                   ,,(frob (rest specs) body))))))))
 155 \f
 156 ;;;; some old-fashioned functions. (They're not just for old-fashioned
 157 ;;;; code, they're also used as optimized forms of the corresponding
 158 ;;;; general functions when the compiler can prove that they're
 159 ;;;; equivalent.)
 160
 161 ;;; like (MEMBER ITEM LIST :TEST #'EQ)
 162 (defun memq (item list)
 163   #!+sb-doc
 164   "Returns tail of LIST beginning with first element EQ to ITEM."
 165   ;; KLUDGE: These could be and probably should be defined as
 166   ;;   (MEMBER ITEM LIST :TEST #'EQ)),
 167   ;; but when I try to cross-compile that, I get an error from
 168   ;; LTN-ANALYZE-KNOWN-CALL, "Recursive known function definition". The
 169   ;; comments for that error say it "is probably a botched interpreter stub".
 170   ;; Rather than try to figure that out, I just rewrote this function from
 171   ;; scratch. -- WHN 19990512
 172   (do ((i list (cdr i)))
 173       ((null i))
 174     (when (eq (car i) item)
 175       (return i))))
 176
 177 ;;; like (ASSOC ITEM ALIST :TEST #'EQ)
 178 (defun assq (item alist)
 179   #!+sb-doc
 180   "Return the first pair of ALIST where ITEM is EQ to the key of the pair."
 181   ;; KLUDGE: CMU CL defined this with
 182   ;;   (DECLARE (INLINE ASSOC))
 183   ;;   (ASSOC ITEM ALIST :TEST #'EQ))
 184   ;; which is pretty, but which would have required adding awkward
 185   ;; build order constraints on SBCL (or figuring out some way to make
 186   ;; inline definitions installable at build-the-cross-compiler time,
 187   ;; which was too ambitious for now). Rather than mess with that,
 188   ;; we just define ASSQ explicitly in terms of more primitive operations:
 189   (dolist (pair alist)
 190     (when (eq (car pair) item)
 191       (return pair))))
 192
 193 (defun delq (item list)
 194   #!+sb-doc
 195   "Delete all LIST entries EQ to ITEM (destructively modifying LIST), and
 196   return the modified LIST."
 197   (let ((list list))
 198     (do ((x list (cdr x))
 199          (splice '()))
 200         ((endp x) list)
 201       (cond ((eq item (car x))
 202              (if (null splice)
 203                (setq list (cdr x))
 204                (rplacd splice (cdr x))))
 205             (t (setq splice x)))))) ; Move splice along to include element.