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