src/code/macros.lisp

   1 ;;;; lots of basic macros for the target SBCL
   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 \f
  14 ;;;; ASSERT and CHECK-TYPE
  15
  16 ;;; ASSERT is written this way, to call ASSERT-ERROR, because of how
  17 ;;; closures are compiled. RESTART-CASE has forms with closures that
  18 ;;; the compiler causes to be generated at the top of any function
  19 ;;; using RESTART-CASE, regardless of whether they are needed. Thus if
  20 ;;; we just wrapped a RESTART-CASE around the call to ERROR, we'd have
  21 ;;; to do a significant amount of work at runtime allocating and
  22 ;;; deallocating the closures regardless of whether they were ever
  23 ;;; needed.
  24 ;;;
  25 ;;; ASSERT-ERROR isn't defined until a later file because it uses the
  26 ;;; macro RESTART-CASE, which isn't defined until a later file.
  27 (defmacro-mundanely assert (test-form &optional places datum &rest arguments)
  28   #!+sb-doc
  29   "Signals an error if the value of test-form is nil. Continuing from this
  30    error using the CONTINUE restart will allow the user to alter the value of
  31    some locations known to SETF, starting over with test-form. Returns NIL."
  32   `(do () (,test-form)
  33      (assert-error ',test-form ',places ,datum ,@arguments)
  34      ,@(mapcar #'(lambda (place)
  35                    `(setf ,place (assert-prompt ',place ,place)))
  36                places)))
  37
  38 (defun assert-prompt (name value)
  39   (cond ((y-or-n-p "The old value of ~S is ~S.~
  40                   ~%Do you want to supply a new value? "
  41                    name value)
  42          (format *query-io* "~&Type a form to be evaluated:~%")
  43          (flet ((read-it () (eval (read *query-io*))))
  44            (if (symbolp name) ;help user debug lexical variables
  45                (progv (list name) (list value) (read-it))
  46                (read-it))))
  47         (t value)))
  48
  49 ;;; CHECK-TYPE is written this way, to call CHECK-TYPE-ERROR, because
  50 ;;; of how closures are compiled. RESTART-CASE has forms with closures
  51 ;;; that the compiler causes to be generated at the top of any
  52 ;;; function using RESTART-CASE, regardless of whether they are
  53 ;;; needed. Because it would be nice if CHECK-TYPE were cheap to use,
  54 ;;; and some things (e.g., READ-CHAR) can't afford this excessive
  55 ;;; consing, we bend backwards a little.
  56 ;;;
  57 ;;; FIXME: In reality, this restart cruft is needed hardly anywhere in
  58 ;;; the system. Write NEED and NEED-TYPE to replace ASSERT and
  59 ;;; CHECK-TYPE inside the system. (CL:CHECK-TYPE must still be
  60 ;;; defined, since it's specified by ANSI and it is sometimes nice for
  61 ;;; whipping up little things. But as far as I can tell it's not
  62 ;;; usually very helpful deep inside the guts of a complex system like
  63 ;;; SBCL.)
  64 ;;;
  65 ;;; CHECK-TYPE-ERROR isn't defined until a later file because it uses
  66 ;;; the macro RESTART-CASE, which isn't defined until a later file.
  67 (defmacro-mundanely check-type (place type &optional type-string)
  68   #!+sb-doc
  69   "Signal a restartable error of type TYPE-ERROR if the value of PLACE is
  70   not of the specified type. If an error is signalled and the restart is
  71   used to return, this can only return if the STORE-VALUE restart is
  72   invoked. In that case it will store into PLACE and start over."
  73   (let ((place-value (gensym)))
  74     `(do ((,place-value ,place ,place))
  75          ((typep ,place-value ',type))
  76        (setf ,place
  77              (check-type-error ',place ,place-value ',type ,type-string)))))
  78 \f
  79 ;;;; DEFCONSTANT
  80
  81 (defmacro-mundanely defconstant (name value &optional documentation)
  82   #!+sb-doc
  83   "For defining global constants. DEFCONSTANT says that the value is
  84   constant and may be compiled into code. If the variable already has
  85   a value, and this is not EQL to the init, the code is not portable
  86   (undefined behavior). The third argument is an optional documentation
  87   string for the variable."
  88   `(eval-when (:compile-toplevel :load-toplevel :execute)
  89      (sb!c::%defconstant ',name ,value ',documentation)))
  90
  91 ;;; the guts of DEFCONSTANT
  92 (defun sb!c::%defconstant (name value doc)
  93   (unless (symbolp name)
  94     (error "The constant name is not a symbol: ~S" name))
  95   (about-to-modify name)
  96   (when (looks-like-name-of-special-var-p name)
  97     (style-warn "defining ~S as a constant, even though the name follows~@
  98 the usual naming convention (names like *FOO*) for special variables"
  99                 name))
 100   (let ((kind (info :variable :kind name)))
 101     (case kind
 102       (:constant
 103        ;; Note: This behavior (discouraging any non-EQL modification)
 104        ;; is unpopular, but it is specified by ANSI (i.e. ANSI says a
 105        ;; non-EQL change has undefined consequences). If people really
 106        ;; want bindings which are constant in some sense other than
 107        ;; EQL, I suggest either just using DEFVAR (which is usually
 108        ;; appropriate, despite the un-mnemonic name), or defining
 109        ;; something like SB-INT:DEFCONSTANT-EQX (which is occasionally
 110        ;; more appropriate). -- WHN 2000-11-03
 111        (unless (eql value
 112                     (info :variable :constant-value name))
 113          (cerror "Go ahead and change the value."
 114                  "The constant ~S is being redefined."
 115                  name)))
 116       (:global
 117        ;; (This is OK -- undefined variables are of this kind. So we
 118        ;; don't warn or error or anything, just fall through.)
 119        )
 120       (t (warn "redefining ~(~A~) ~S to be a constant" kind name))))
 121   (when doc
 122     (setf (fdocumentation name 'variable) doc))
 123
 124   ;; We want to set the cross-compilation host's symbol value, not just
 125   ;; the cross-compiler's (INFO :VARIABLE :CONSTANT-VALUE NAME), so
 126   ;; that code like
 127   ;;   (defconstant max-entries 61)
 128   ;;   (deftype entry-index () `(mod ,max-entries))
 129   ;; will be cross-compiled correctly.
 130   #-sb-xc-host (setf (symbol-value name) value)
 131   #+sb-xc-host (progn
 132                  (/show (symbol-package name))
 133                  ;; Redefining our cross-compilation host's CL symbols
 134                  ;; would be poor form.
 135                  ;;
 136                  ;; FIXME: Having to check this and then not treat it
 137                  ;; as a fatal error seems like a symptom of things
 138                  ;; being pretty broken. It's also a problem in and of
 139                  ;; itself, since it makes it too easy for cases of
 140                  ;; using the cross-compilation host Lisp's CL
 141                  ;; constant values in the target Lisp to slip by. I
 142                  ;; got backed into this because the cross-compiler
 143                  ;; translates DEFCONSTANT SB!XC:FOO into DEFCONSTANT
 144                  ;; CL:FOO. It would be good to unscrew the
 145                  ;; cross-compilation package hacks so that that
 146                  ;; translation doesn't happen. Perhaps:
 147                  ;;   * Replace SB-XC with SB-CL. SB-CL exports all the
 148                  ;;     symbols which ANSI requires to be exported from CL.
 149                  ;;   * Make a nickname SB!CL which behaves like SB!XC.
 150                  ;;   * Go through the loaded-on-the-host code making
 151                  ;;     every target definition be in SB-CL. E.g.
 152                  ;;     DEFMACRO-MUNDANELY DEFCONSTANT becomes
 153                  ;;     DEFMACRO-MUNDANELY SB!CL:DEFCONSTANT.
 154                  ;;   * Make IN-TARGET-COMPILATION-MODE do
 155                  ;;     UNUSE-PACKAGE CL and USE-PACKAGE SB-CL in each
 156                  ;;     of the target packages (then undo it on exit).
 157                  ;;   * Make the cross-compiler's implementation of
 158                  ;;     EVAL-WHEN (:COMPILE-TOPLEVEL) do UNCROSS.
 159                  ;;     (This may not require any change.)
 160                  ;;   * Hack GENESIS as necessary so that it outputs
 161                  ;;     SB-CL stuff as COMMON-LISP stuff.
 162                  ;;   * Now the code here can assert that the symbol
 163                  ;;     being defined isn't in the cross-compilation
 164                  ;;     host's CL package.
 165                  (unless (eql (find-symbol (symbol-name name) :cl) name)
 166                    ;; KLUDGE: In the cross-compiler, we use the
 167                    ;; cross-compilation host's DEFCONSTANT macro
 168                    ;; instead of just (SETF SYMBOL-VALUE), in order to
 169                    ;; get whatever blessing the cross-compilation host
 170                    ;; may expect for a global (SETF SYMBOL-VALUE).
 171                    ;; (CMU CL, at least around 2.4.19, generated full
 172                    ;; WARNINGs for code -- e.g. DEFTYPE expanders --
 173                    ;; which referred to symbols which had been set by
 174                    ;; (SETF SYMBOL-VALUE). I doubt such warnings are
 175                    ;; ANSI-compliant, but I'm not sure, so I've
 176                    ;; written this in a way that CMU CL will tolerate
 177                    ;; and which ought to work elsewhere too.) -- WHN
 178                    ;; 2001-03-24
 179                    (eval `(defconstant ,name ',value))))
 180
 181   (setf (info :variable :kind name) :constant)
 182   (setf (info :variable :constant-value name) value)
 183   name)
 184 \f
 185 ;;;; DEFINE-COMPILER-MACRO
 186
 187 ;;; FIXME: The logic here for handling compiler macros named (SETF
 188 ;;; FOO) was added after the fork from SBCL, is not well tested, and
 189 ;;; may conflict with subtleties of the ANSI standard. E.g. section
 190 ;;; "3.2.2.1 Compiler Macros" says that creating a lexical binding for
 191 ;;; a function name shadows a compiler macro, and it's not clear that
 192 ;;; that works with this version. It should be tested.
 193 (defmacro-mundanely define-compiler-macro (name lambda-list &body body)
 194   #!+sb-doc
 195   "Define a compiler-macro for NAME."
 196   (let ((whole (gensym "WHOLE-"))
 197         (environment (gensym "ENV-")))
 198     (multiple-value-bind (body local-decs doc)
 199         (parse-defmacro lambda-list whole body name 'define-compiler-macro
 200                         :environment environment)
 201       (let ((def `(lambda (,whole ,environment)
 202                     ,@local-decs
 203                     (block ,(function-name-block-name name)
 204                       ,body))))
 205         `(sb!c::%define-compiler-macro ',name #',def ',lambda-list ,doc)))))
 206 (defun sb!c::%define-compiler-macro (name definition lambda-list doc)
 207   #!+sb-interpreter (setf (sb!eval:interpreted-function-name definition)
 208                           (format nil "DEFINE-COMPILER-MACRO ~S" name))
 209   #!+sb-interpreter (setf (sb!eval:interpreted-function-arglist definition)
 210                           lambda-list)
 211   (sb!c::%%define-compiler-macro name definition doc))
 212 (defun sb!c::%%define-compiler-macro (name definition doc)
 213   (setf (sb!xc:compiler-macro-function name) definition)
 214   ;; FIXME: Add support for (SETF FDOCUMENTATION) when object is a list
 215   ;; and type is COMPILER-MACRO. (Until then, we have to discard any
 216   ;; compiler macro documentation for (SETF FOO).)
 217   (unless (listp name)
 218     (setf (fdocumentation name 'compiler-macro) doc))
 219   name)
 220 \f
 221 ;;;; CASE, TYPECASE, and friends
 222
 223 (eval-when (:compile-toplevel :load-toplevel :execute)
 224
 225 ;;; CASE-BODY returns code for all the standard "case" macros. NAME is
 226 ;;; the macro name, and KEYFORM is the thing to case on. MULTI-P
 227 ;;; indicates whether a branch may fire off a list of keys; otherwise,
 228 ;;; a key that is a list is interpreted in some way as a single key.
 229 ;;; When MULTI-P, TEST is applied to the value of KEYFORM and each key
 230 ;;; for a given branch; otherwise, TEST is applied to the value of
 231 ;;; KEYFORM and the entire first element, instead of each part, of the
 232 ;;; case branch. When ERRORP, no T or OTHERWISE branch is permitted,
 233 ;;; and an ERROR form is generated. When PROCEEDP, it is an error to
 234 ;;; omit ERRORP, and the ERROR form generated is executed within a
 235 ;;; RESTART-CASE allowing KEYFORM to be set and retested.
 236 (defun case-body (name keyform cases multi-p test errorp proceedp needcasesp)
 237   (unless (or cases (not needcasesp))
 238     (warn "no clauses in ~S" name))
 239   (let ((keyform-value (gensym))
 240         (clauses ())
 241         (keys ()))
 242     (dolist (case cases)
 243       (unless (list-of-length-at-least-p case 1)
 244         (error "~S -- bad clause in ~S" case name))
 245       (destructuring-bind (keyoid &rest forms) case
 246         (cond ((memq keyoid '(t otherwise))
 247                (if errorp
 248                    (error 'simple-program-error
 249                           :format-control
 250                           "No default clause is allowed in ~S: ~S"
 251                           :format-arguments (list name case))
 252                    (push `(t nil ,@forms) clauses)))
 253               ((and multi-p (listp keyoid))
 254                (setf keys (append keyoid keys))
 255                (push `((or ,@(mapcar (lambda (key)
 256                                        `(,test ,keyform-value ',key))
 257                                      keyoid))
 258                        nil
 259                        ,@forms)
 260                      clauses))
 261               (t
 262                (push keyoid keys)
 263                (push `((,test ,keyform-value ',keyoid)
 264                        nil
 265                        ,@forms)
 266                      clauses)))))
 267     (case-body-aux name keyform keyform-value clauses keys errorp proceedp
 268                    `(,(if multi-p 'member 'or) ,@keys))))
 269
 270 ;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled
 271 ;;; all the cases. Note: it is not necessary that the resulting code
 272 ;;; signal case-failure conditions, but that's what KMP's prototype
 273 ;;; code did. We call CASE-BODY-ERROR, because of how closures are
 274 ;;; compiled. RESTART-CASE has forms with closures that the compiler
 275 ;;; causes to be generated at the top of any function using the case
 276 ;;; macros, regardless of whether they are needed.
 277 ;;;
 278 ;;; The CASE-BODY-ERROR function is defined later, when the
 279 ;;; RESTART-CASE macro has been defined.
 280 (defun case-body-aux (name keyform keyform-value clauses keys
 281                       errorp proceedp expected-type)
 282   (if proceedp
 283       (let ((block (gensym))
 284             (again (gensym)))
 285         `(let ((,keyform-value ,keyform))
 286            (block ,block
 287              (tagbody
 288               ,again
 289               (return-from
 290                ,block
 291                (cond ,@(nreverse clauses)
 292                      (t
 293                       (setf ,keyform-value
 294                             (setf ,keyform
 295                                   (case-body-error
 296                                    ',name ',keyform ,keyform-value
 297                                    ',expected-type ',keys)))
 298                       (go ,again))))))))
 299       `(let ((,keyform-value ,keyform))
 300          (declare (ignorable ,keyform-value)) ; e.g. (CASE KEY (T))
 301          (cond
 302           ,@(nreverse clauses)
 303           ,@(if errorp
 304                 `((t (error 'case-failure
 305                             :name ',name
 306                             :datum ,keyform-value
 307                             :expected-type ',expected-type
 308                             :possibilities ',keys))))))))
 309 ) ; EVAL-WHEN
 310
 311 (defmacro-mundanely case (keyform &body cases)
 312   #!+sb-doc
 313   "CASE Keyform {({(Key*) | Key} Form*)}*
 314   Evaluates the Forms in the first clause with a Key EQL to the value of
 315   Keyform. If a singleton key is T then the clause is a default clause."
 316   (case-body 'case keyform cases t 'eql nil nil nil))
 317
 318 (defmacro-mundanely ccase (keyform &body cases)
 319   #!+sb-doc
 320   "CCASE Keyform {({(Key*) | Key} Form*)}*
 321   Evaluates the Forms in the first clause with a Key EQL to the value of
 322   Keyform. If none of the keys matches then a correctable error is
 323   signalled."
 324   (case-body 'ccase keyform cases t 'eql t t t))
 325
 326 (defmacro-mundanely ecase (keyform &body cases)
 327   #!+sb-doc
 328   "ECASE Keyform {({(Key*) | Key} Form*)}*
 329   Evaluates the Forms in the first clause with a Key EQL to the value of
 330   Keyform. If none of the keys matches then an error is signalled."
 331   (case-body 'ecase keyform cases t 'eql t nil t))
 332
 333 (defmacro-mundanely typecase (keyform &body cases)
 334   #!+sb-doc
 335   "TYPECASE Keyform {(Type Form*)}*
 336   Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
 337   is true."
 338   (case-body 'typecase keyform cases nil 'typep nil nil nil))
 339
 340 (defmacro-mundanely ctypecase (keyform &body cases)
 341   #!+sb-doc
 342   "CTYPECASE Keyform {(Type Form*)}*
 343   Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
 344   is true. If no form is satisfied then a correctable error is signalled."
 345   (case-body 'ctypecase keyform cases nil 'typep t t t))
 346
 347 (defmacro-mundanely etypecase (keyform &body cases)
 348   #!+sb-doc
 349   "ETYPECASE Keyform {(Type Form*)}*
 350   Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
 351   is true. If no form is satisfied then an error is signalled."
 352   (case-body 'etypecase keyform cases nil 'typep t nil t))
 353 \f
 354 ;;;; WITH-FOO i/o-related macros
 355
 356 (defmacro-mundanely with-open-stream ((var stream) &body forms-decls)
 357   (multiple-value-bind (forms decls) (parse-body forms-decls nil)
 358     (let ((abortp (gensym)))
 359       `(let ((,var ,stream)
 360              (,abortp t))
 361          ,@decls
 362          (unwind-protect
 363              (multiple-value-prog1
 364               (progn ,@forms)
 365               (setq ,abortp nil))
 366            (when ,var
 367              (close ,var :abort ,abortp)))))))
 368
 369 (defmacro-mundanely with-open-file ((stream filespec &rest options)
 370                                     &body body)
 371   `(with-open-stream (,stream (open ,filespec ,@options))
 372      ,@body))
 373
 374 (defmacro-mundanely with-input-from-string ((var string &key index start end)
 375                                             &body forms-decls)
 376   (multiple-value-bind (forms decls) (parse-body forms-decls nil)
 377     ;; The ONCE-ONLY inhibits compiler note for unreachable code when
 378     ;; END is true.
 379     (once-only ((string string))
 380       `(let ((,var
 381               ,(cond ((null end)
 382                       `(make-string-input-stream ,string ,(or start 0)))
 383                      ((symbolp end)
 384                       `(if ,end
 385                            (make-string-input-stream ,string
 386                                                      ,(or start 0)
 387                                                      ,end)
 388                            (make-string-input-stream ,string
 389                                                      ,(or start 0))))
 390                      (t
 391                       `(make-string-input-stream ,string
 392                                                  ,(or start 0)
 393                                                  ,end)))))
 394          ,@decls
 395          (unwind-protect
 396              (progn ,@forms)
 397            (close ,var)
 398            ,@(when index
 399                `((setf ,index (string-input-stream-current ,var)))))))))
 400
 401 (defmacro-mundanely with-output-to-string ((var &optional string)
 402                                            &body forms-decls)
 403   (multiple-value-bind (forms decls) (parse-body forms-decls nil)
 404     (if string
 405       `(let ((,var (make-fill-pointer-output-stream ,string)))
 406          ,@decls
 407          (unwind-protect
 408              (progn ,@forms)
 409            (close ,var)))
 410       `(let ((,var (make-string-output-stream)))
 411          ,@decls
 412          (unwind-protect
 413              (progn ,@forms)
 414            (close ,var))
 415          (get-output-stream-string ,var)))))
 416 \f
 417 ;;;; miscellaneous macros
 418
 419 (defmacro-mundanely nth-value (n form)
 420   #!+sb-doc
 421   "Evaluates FORM and returns the Nth value (zero based). This involves no
 422   consing when N is a trivial constant integer."
 423   (if (integerp n)
 424       (let ((dummy-list nil)
 425             (keeper (gensym "KEEPER-")))
 426         ;; We build DUMMY-LIST, a list of variables to bind to useless
 427         ;; values, then we explicitly IGNORE those bindings and return
 428         ;; KEEPER, the only thing we're really interested in right now.
 429         (dotimes (i n)
 430           (push (gensym "IGNORE-") dummy-list))
 431         `(multiple-value-bind (,@dummy-list ,keeper) ,form
 432            (declare (ignore ,@dummy-list))
 433            ,keeper))
 434       (once-only ((n n))
 435         `(case (the fixnum ,n)
 436            (0 (nth-value 0 ,form))
 437            (1 (nth-value 1 ,form))
 438            (2 (nth-value 2 ,form))
 439            (t (nth (the fixnum ,n) (multiple-value-list ,form)))))))
 440
 441 (defmacro-mundanely declaim (&rest specs)
 442   #!+sb-doc
 443   "DECLAIM Declaration*
 444   Do a declaration or declarations for the global environment."
 445   #-sb-xc-host
 446   `(eval-when (:compile-toplevel :load-toplevel :execute)
 447      ,@(mapcar #'(lambda (x)
 448                    `(sb!xc:proclaim ',x))
 449                specs))
 450   ;; KLUDGE: The definition above doesn't work in the cross-compiler,
 451   ;; because UNCROSS translates SB!XC:PROCLAIM into CL:PROCLAIM before
 452   ;; the form gets executed. Instead, we have to explicitly do the
 453   ;; proclamation at macroexpansion time. -- WHN ca. 19990810
 454   ;;
 455   ;; FIXME: Maybe we don't need this special treatment any more now
 456   ;; that we're using DEFMACRO-MUNDANELY instead of DEFMACRO?
 457   #+sb-xc-host (progn
 458                  (mapcar #'sb!xc:proclaim specs)
 459                  `(progn
 460                     ,@(mapcar #'(lambda (x)
 461                                   `(sb!xc:proclaim ',x))
 462                               specs))))
 463
 464 (defmacro-mundanely print-unreadable-object ((object stream
 465                                               &key type identity)
 466                                              &body body)
 467   `(%print-unreadable-object ,object ,stream ,type ,identity
 468                              ,(if body
 469                                   `#'(lambda () ,@body)
 470                                   nil)))