src/code/primordial-extensions.lisp

   1 ;;;; various user-level definitions which need to be done particularly
   2 ;;;; early
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!INT")
  14 \f
  15 ;;;; DO-related stuff which needs to be visible on the cross-compilation host
  16
  17 (eval-when (:compile-toplevel :load-toplevel :execute)
  18   (defun do-do-body (varlist endlist decls-and-code bind step name block)
  19     (let* ((r-inits nil) ; accumulator for reversed list
  20            (r-steps nil) ; accumulator for reversed list
  21            (label-1 (gensym))
  22            (label-2 (gensym)))
  23       ;; Check for illegal old-style DO.
  24       (when (or (not (listp varlist)) (atom endlist))
  25         (error "Ill-formed ~S -- possibly illegal old style DO?" name))
  26       ;; Parse VARLIST to get R-INITS and R-STEPS.
  27       (dolist (v varlist)
  28         (flet (;; (We avoid using CL:PUSH here so that CL:PUSH can be defined
  29                ;; in terms of CL:SETF, and CL:SETF can be defined in terms of
  30                ;; CL:DO, and CL:DO can be defined in terms of the current
  31                ;; function.)
  32                (push-on-r-inits (x)
  33                  (setq r-inits (cons x r-inits)))
  34                ;; common error-handling
  35                (illegal-varlist ()
  36                  (error "~S is an illegal form for a ~S varlist." v name)))
  37           (cond ((symbolp v) (push-on-r-inits v))
  38                 ((listp v)
  39                  (unless (symbolp (first v))
  40                    (error "~S step variable is not a symbol: ~S"
  41                           name
  42                           (first v)))
  43                  (let ((lv (length v)))
  44                    ;; (We avoid using CL:CASE here so that CL:CASE can be
  45                    ;; defined in terms of CL:SETF, and CL:SETF can be defined
  46                    ;; in terms of CL:DO, and CL:DO can be defined in terms of
  47                    ;; the current function.)
  48                    (cond ((= lv 1)
  49                           (push-on-r-inits (first v)))
  50                          ((= lv 2)
  51                           (push-on-r-inits v))
  52                          ((= lv 3)
  53                           (push-on-r-inits (list (first v) (second v)))
  54                           (setq r-steps (list* (third v) (first v) r-steps)))
  55                          (t (illegal-varlist)))))
  56                 (t (illegal-varlist)))))
  57       ;; Construct the new form.
  58       (multiple-value-bind (code decls) (parse-body decls-and-code nil)
  59         `(block ,block
  60            (,bind ,(nreverse r-inits)
  61                   ,@decls
  62                   (tagbody
  63                    (go ,label-2)
  64                    ,label-1
  65                    ,@code
  66                    (,step ,@(nreverse r-steps))
  67                    ,label-2
  68                    (unless ,(first endlist) (go ,label-1))
  69                    (return-from ,block (progn ,@(rest endlist))))))))))
  70
  71 (defmacro do-anonymous (varlist endlist &rest body)
  72   #!+sb-doc
  73   "DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
  74   Like DO, but has no implicit NIL block. Each Var is initialized in parallel
  75   to the value of the specified Init form. On subsequent iterations, the Vars
  76   are assigned the value of the Step form (if any) in parallel. The Test is
  77   evaluated before each evaluation of the body Forms. When the Test is true,
  78   the Exit-Forms are evaluated as a PROGN, with the result being the value
  79   of the DO."
  80   (do-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym)))
  81 \f
  82 ;;;; miscellany
  83
  84 ;;; Concatenate together the names of some strings and symbols,
  85 ;;; producing a symbol in the current package.
  86 (defun symbolicate (&rest things)
  87   (values (intern (apply #'concatenate
  88                          'string
  89                          (mapcar #'string things)))))
  90
  91 ;;; like SYMBOLICATE, but producing keywords
  92 (defun keywordicate (&rest things)
  93   (let ((*package* *keyword-package*))
  94     (apply #'symbolicate things)))
  95
  96 ;;; Access *PACKAGE* in a way which lets us recover if someone has
  97 ;;; done something silly like (SETF *PACKAGE* :CL-USER). (Such an
  98 ;;; assignment is undefined behavior, so it's sort of reasonable for it
  99 ;;; to cause the system to go totally insane afterwards, but it's
 100 ;;; a fairly easy mistake to make, so let's try to recover gracefully
 101 ;;; instead.)
 102 (defun sane-package ()
 103   (let ((maybe-package *package*))
 104     (cond ((and (packagep maybe-package)
 105                 ;; For good measure, we also catch the problem of
 106                 ;; *PACKAGE* being bound to a deleted package.
 107                 ;; Technically, this is not undefined behavior in itself,
 108                 ;; but it will immediately lead to undefined to behavior,
 109                 ;; since almost any operation on a deleted package is
 110                 ;; undefined.
 111                 (package-name maybe-package))
 112            maybe-package)
 113           (t
 114            ;; We're in the undefined behavior zone. First, munge the
 115            ;; system back into a defined state.
 116            (let ((really-package (find-package :cl-user)))
 117              (setf *package* really-package)
 118              ;; Then complain.
 119              (error 'simple-type-error
 120                     :datum maybe-package
 121                     :expected-type 'package
 122                     :format-control
 123                     "~S can't be a ~S:~%  ~S has been reset to ~S"
 124                     :format-arguments (list '*package* (type-of maybe-package)
 125                                             '*package* really-package)))))))
 126
 127 ;;; Give names to elements of a numeric sequence.
 128 (defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1))
 129                    &rest identifiers)
 130   (let ((results nil)
 131         (index 0)
 132         (start (eval start))
 133         (step (eval step)))
 134     (dolist (id identifiers)
 135       (when id
 136         (multiple-value-bind (root docs)
 137             (if (consp id)
 138                 (values (car id) (cdr id))
 139                 (values id nil))
 140           ;; (This could be SYMBOLICATE, except that due to
 141           ;; bogobootstrapping issues SYMBOLICATE isn't defined yet.)
 142           (push `(defconstant ,(symbolicate prefix root suffix)
 143                    ,(+ start (* step index))
 144                    ,@docs)
 145                 results)))
 146       (incf index))
 147     `(progn
 148        ,@(nreverse results))))
 149
 150 ;;; generalization of DEFCONSTANT to values which are the same not
 151 ;;; under EQL but under e.g. EQUAL or EQUALP
 152 ;;;
 153 ;;; DEFCONSTANT-EQX is to be used instead of DEFCONSTANT for values
 154 ;;; which are appropriately compared using the function given by the
 155 ;;; EQX argument instead of EQL.
 156 ;;;
 157 ;;; Note: Be careful when using this macro, since it's easy to
 158 ;;; unintentionally pessimize your code. A good time to use this macro
 159 ;;; is when the values defined will be fed into optimization
 160 ;;; transforms and never actually appear in the generated code; this
 161 ;;; is especially common when defining BYTE expressions. Unintentional
 162 ;;; pessimization can result when the values defined by this macro are
 163 ;;; actually used in generated code: because of the way that the
 164 ;;; dump/load system works, you'll typically get one copy of consed
 165 ;;; structure for each object file which contains code referring to
 166 ;;; the value, plus perhaps one more copy bound to the SYMBOL-VALUE of
 167 ;;; the constant. If you don't want that to happen, you should
 168 ;;; probably use DEFPARAMETER instead.
 169 (defmacro defconstant-eqx (symbol expr eqx &optional doc)
 170   (let ((expr-tmp (gensym "EXPR-TMP-")))
 171     `(progn
 172        ;; When we're building the cross-compiler, and in most
 173        ;; situations even when we're running the cross-compiler,
 174        ;; all we need is a nice portable definition in terms of the
 175        ;; ANSI Common Lisp operations.
 176        (eval-when (:compile-toplevel :load-toplevel :execute)
 177          (let ((,expr-tmp ,expr))
 178            (cond ((boundp ',symbol)
 179                   (unless (and (constantp ',symbol)
 180                                (funcall ,eqx
 181                                         (symbol-value ',symbol)
 182                                         ,expr-tmp))
 183                     (error "already bound differently: ~S")))
 184                  (t
 185                   (defconstant ,symbol ,expr-tmp ,@(when doc `(,doc)))))))
 186        ;; The #+SB-XC :COMPILE-TOPLEVEL situation is special, since we
 187        ;; want to define the symbol not just in the cross-compilation
 188        ;; host Lisp (which was handled above) but also in the
 189        ;; cross-compiler (which we will handle now).
 190        ;;
 191        ;; KLUDGE: It would probably be possible to do this fairly
 192        ;; cleanly, in a way parallel to the code above, if we had
 193        ;; SB!XC:FOO versions of all the primitives CL:FOO used above
 194        ;; (e.g. SB!XC:BOUNDP, SB!XC:SYMBOL-VALUE, and
 195        ;; SB!XC:DEFCONSTANT), and took care to call them. But right
 196        ;; now we just hack around in the guts of the cross-compiler
 197        ;; instead. -- WHN 2000-11-03
 198        #+sb-xc
 199        (eval-when (:compile-toplevel)
 200          (let ((,expr-tmp ,symbol))
 201            (unless (and (eql (info :variable :kind ',symbol) :constant)
 202                         (funcall ,eqx
 203                                  (info :variable :constant-value ',symbol)
 204                                  ,expr-tmp))
 205              (sb!c::%defconstant ',symbol ,expr-tmp ,doc)))))))