src/code/defboot.lisp

   1 ;;;; bootstrapping fundamental machinery (e.g. DEFUN, DEFCONSTANT,
   2 ;;;; DEFVAR) from special forms and primitive functions
   3 ;;;;
   4 ;;;; KLUDGE: The bootstrapping aspect of this is now obsolete. It was
   5 ;;;; originally intended that this file file would be loaded into a
   6 ;;;; Lisp image which had Common Lisp primitives defined, and DEFMACRO
   7 ;;;; defined, and little else. Since then that approach has been
   8 ;;;; dropped and this file has been modified somewhat to make it work
   9 ;;;; more cleanly when used to predefine macros at
  10 ;;;; build-the-cross-compiler time.
  11
  12 ;;;; This software is part of the SBCL system. See the README file for
  13 ;;;; more information.
  14 ;;;;
  15 ;;;; This software is derived from the CMU CL system, which was
  16 ;;;; written at Carnegie Mellon University and released into the
  17 ;;;; public domain. The software is in the public domain and is
  18 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  19 ;;;; files for more information.
  20
  21 (in-package "SB!IMPL")
  22
  23 \f
  24 ;;;; IN-PACKAGE
  25
  26 (defmacro-mundanely in-package (string-designator)
  27   (let ((string (string string-designator)))
  28     `(eval-when (:compile-toplevel :load-toplevel :execute)
  29        (setq *package* (find-undeleted-package-or-lose ,string)))))
  30 \f
  31 ;;;; MULTIPLE-VALUE-FOO
  32
  33 (defun list-of-symbols-p (x)
  34   (and (listp x)
  35        (every #'symbolp x)))
  36
  37 (defmacro-mundanely multiple-value-bind (vars value-form &body body)
  38   (if (list-of-symbols-p vars)
  39     ;; It's unclear why it would be important to special-case the LENGTH=1 case
  40     ;; at this level, but the CMU CL code did it, so.. -- WHN 19990411
  41     (if (= (length vars) 1)
  42       `(let ((,(car vars) ,value-form))
  43          ,@body)
  44       (let ((ignore (gensym)))
  45         `(multiple-value-call #'(lambda (&optional ,@(mapcar #'list vars)
  46                                          &rest ,ignore)
  47                                   (declare (ignore ,ignore))
  48                                   ,@body)
  49                               ,value-form)))
  50     (error "Vars is not a list of symbols: ~S" vars)))
  51
  52 (defmacro-mundanely multiple-value-setq (vars value-form)
  53   (unless (list-of-symbols-p vars)
  54     (error "Vars is not a list of symbols: ~S" vars))
  55   ;; MULTIPLE-VALUE-SETQ is required to always return just the primary
  56   ;; value of the value-from, even if there are no vars. (SETF VALUES)
  57   ;; in turn is required to return as many values as there are
  58   ;; value-places, hence this:
  59   (if vars
  60       `(values (setf (values ,@vars) ,value-form))
  61       `(values ,value-form)))
  62
  63 (defmacro-mundanely multiple-value-list (value-form)
  64   `(multiple-value-call #'list ,value-form))
  65 \f
  66 ;;;; various conditional constructs
  67
  68 ;;; COND defined in terms of IF
  69 (defmacro-mundanely cond (&rest clauses)
  70   (if (endp clauses)
  71       nil
  72       (let ((clause (first clauses)))
  73         (if (atom clause)
  74             (error "COND clause is not a list: ~S" clause)
  75             (let ((test (first clause))
  76                   (forms (rest clause)))
  77               (if (endp forms)
  78                   (let ((n-result (gensym)))
  79                     `(let ((,n-result ,test))
  80                        (if ,n-result
  81                            ,n-result
  82                            (cond ,@(rest clauses)))))
  83                   `(if ,test
  84                        (progn ,@forms)
  85                        (cond ,@(rest clauses)))))))))
  86
  87 (defmacro-mundanely when (test &body forms)
  88   #!+sb-doc
  89   "If the first argument is true, the rest of the forms are
  90 evaluated as a PROGN."
  91   `(if ,test (progn ,@forms) nil))
  92
  93 (defmacro-mundanely unless (test &body forms)
  94   #!+sb-doc
  95   "If the first argument is not true, the rest of the forms are
  96 evaluated as a PROGN."
  97   `(if ,test nil (progn ,@forms)))
  98
  99 (defmacro-mundanely and (&rest forms)
 100   (cond ((endp forms) t)
 101         ((endp (rest forms)) (first forms))
 102         (t
 103          `(if ,(first forms)
 104               (and ,@(rest forms))
 105               nil))))
 106
 107 (defmacro-mundanely or (&rest forms)
 108   (cond ((endp forms) nil)
 109         ((endp (rest forms)) (first forms))
 110         (t
 111          (let ((n-result (gensym)))
 112            `(let ((,n-result ,(first forms)))
 113               (if ,n-result
 114                   ,n-result
 115                   (or ,@(rest forms))))))))
 116 \f
 117 ;;;; various sequencing constructs
 118
 119 (flet ((prog-expansion-from-let (varlist body-decls let)
 120          (multiple-value-bind (body decls)
 121              (parse-body body-decls :doc-string-allowed nil)
 122            `(block nil
 123               (,let ,varlist
 124                 ,@decls
 125                 (tagbody ,@body))))))
 126   (defmacro-mundanely prog (varlist &body body-decls)
 127     (prog-expansion-from-let varlist body-decls 'let))
 128   (defmacro-mundanely prog* (varlist &body body-decls)
 129     (prog-expansion-from-let varlist body-decls 'let*)))
 130
 131 (defmacro-mundanely prog1 (result &body body)
 132   (let ((n-result (gensym)))
 133     `(let ((,n-result ,result))
 134        ,@body
 135        ,n-result)))
 136
 137 (defmacro-mundanely prog2 (form1 result &body body)
 138   `(prog1 (progn ,form1 ,result) ,@body))
 139 \f
 140 ;;;; DEFUN
 141
 142 ;;; Should we save the inline expansion of the function named NAME?
 143 (defun inline-fun-name-p (name)
 144   (or
 145    ;; the normal reason for saving the inline expansion
 146    (info :function :inlinep name)
 147    ;; another reason for saving the inline expansion: If the
 148    ;; ANSI-recommended idiom
 149    ;;   (DECLAIM (INLINE FOO))
 150    ;;   (DEFUN FOO ..)
 151    ;;   (DECLAIM (NOTINLINE FOO))
 152    ;; has been used, and then we later do another
 153    ;;   (DEFUN FOO ..)
 154    ;; without a preceding
 155    ;;   (DECLAIM (INLINE FOO))
 156    ;; what should we do with the old inline expansion when we see the
 157    ;; new DEFUN? Overwriting it with the new definition seems like
 158    ;; the only unsurprising choice.
 159    (info :function :inline-expansion-designator name)))
 160
 161 (defmacro-mundanely defun (&environment env name args &body body)
 162   "Define a function at top level."
 163   #+sb-xc-host
 164   (unless (symbol-package (fun-name-block-name name))
 165     (warn "DEFUN of uninterned function name ~S (tricky for GENESIS)" name))
 166   (multiple-value-bind (forms decls doc) (parse-body body)
 167     (let* (;; stuff shared between LAMBDA and INLINE-LAMBDA and NAMED-LAMBDA
 168            (lambda-guts `(,args
 169                           ,@decls
 170                           (block ,(fun-name-block-name name)
 171                             ,@forms)))
 172            (lambda `(lambda ,@lambda-guts))
 173            #-sb-xc-host
 174            (named-lambda `(named-lambda ,name ,@lambda-guts))
 175            (inline-lambda
 176             (when (inline-fun-name-p name)
 177               ;; we want to attempt to inline, so complain if we can't
 178               (or (sb!c:maybe-inline-syntactic-closure lambda env)
 179                   (progn
 180                     (#+sb-xc-host warn
 181                      #-sb-xc-host sb!c:maybe-compiler-notify
 182                      "lexical environment too hairy, can't inline DEFUN ~S"
 183                      name)
 184                     nil)))))
 185       `(progn
 186          ;; In cross-compilation of toplevel DEFUNs, we arrange for
 187          ;; the LAMBDA to be statically linked by GENESIS.
 188          ;;
 189          ;; It may seem strangely inconsistent not to use NAMED-LAMBDA
 190          ;; here instead of LAMBDA. The reason is historical:
 191          ;; COLD-FSET was written before NAMED-LAMBDA, and has special
 192          ;; logic of its own to notify the compiler about NAME.
 193          #+sb-xc-host
 194          (cold-fset ,name ,lambda)
 195
 196          (eval-when (:compile-toplevel)
 197            (sb!c:%compiler-defun ',name ',inline-lambda t))
 198          (eval-when (:load-toplevel :execute)
 199            (%defun ',name
 200                    ;; In normal compilation (not for cold load) this is
 201                    ;; where the compiled LAMBDA first appears. In
 202                    ;; cross-compilation, we manipulate the
 203                    ;; previously-statically-linked LAMBDA here.
 204                    #-sb-xc-host ,named-lambda
 205                    #+sb-xc-host (fdefinition ',name)
 206                    ,doc
 207                    ',inline-lambda
 208                    (sb!c:source-location)))))))
 209
 210 #-sb-xc-host
 211 (defun %defun (name def doc inline-lambda source-location)
 212   (declare (ignore source-location))
 213   (declare (type function def))
 214   (declare (type (or null simple-string) doc))
 215   (aver (legal-fun-name-p name)) ; should've been checked by DEFMACRO DEFUN
 216   (sb!c:%compiler-defun name inline-lambda nil)
 217   (when (fboundp name)
 218     (/show0 "redefining NAME in %DEFUN")
 219     (style-warn "redefining ~S in DEFUN" name))
 220   (setf (sb!xc:fdefinition name) def)
 221
 222   (sb!c::note-name-defined name :function)
 223
 224   ;; FIXME: I want to do this here (and fix bug 137), but until the
 225   ;; breathtaking CMU CL function name architecture is converted into
 226   ;; something sane, (1) doing so doesn't really fix the bug, and
 227   ;; (2) doing probably isn't even really safe.
 228   #+nil (setf (%fun-name def) name)
 229
 230   (when doc
 231     (setf (fdocumentation name 'function) doc)
 232     #!+sb-eval
 233     (when (typep def 'sb!eval:interpreted-function)
 234       (setf (sb!eval:interpreted-function-documentation def)
 235             doc)))
 236   name)
 237 \f
 238 ;;;; DEFVAR and DEFPARAMETER
 239
 240 (defmacro-mundanely defvar (var &optional (val nil valp) (doc nil docp))
 241   #!+sb-doc
 242   "Define a global variable at top level. Declare the variable
 243   SPECIAL and, optionally, initialize it. If the variable already has a
 244   value, the old value is not clobbered. The third argument is an optional
 245   documentation string for the variable."
 246   `(progn
 247      (eval-when (:compile-toplevel)
 248        (%compiler-defvar ',var))
 249      (eval-when (:load-toplevel :execute)
 250        (%defvar ',var (unless (boundp ',var) ,val)
 251                 ',valp ,doc ',docp
 252                 (sb!c:source-location)))))
 253
 254 (defmacro-mundanely defparameter (var val &optional (doc nil docp))
 255   #!+sb-doc
 256   "Define a parameter that is not normally changed by the program,
 257   but that may be changed without causing an error. Declare the
 258   variable special and sets its value to VAL, overwriting any
 259   previous value. The third argument is an optional documentation
 260   string for the parameter."
 261   `(progn
 262      (eval-when (:compile-toplevel)
 263        (%compiler-defvar ',var))
 264      (eval-when (:load-toplevel :execute)
 265        (%defparameter ',var ,val ,doc ',docp (sb!c:source-location)))))
 266
 267 (defun %compiler-defvar (var)
 268   (sb!xc:proclaim `(special ,var)))
 269
 270 #-sb-xc-host
 271 (defun %defvar (var val valp doc docp source-location)
 272   (%compiler-defvar var)
 273   (when valp
 274     (unless (boundp var)
 275       (set var val)))
 276   (when docp
 277     (setf (fdocumentation var 'variable) doc))
 278   (sb!c:with-source-location (source-location)
 279     (setf (info :source-location :variable var) source-location))
 280   var)
 281
 282 #-sb-xc-host
 283 (defun %defparameter (var val doc docp source-location)
 284   (%compiler-defvar var)
 285   (set var val)
 286   (when docp
 287     (setf (fdocumentation var 'variable) doc))
 288   (sb!c:with-source-location (source-location)
 289     (setf (info :source-location :variable var) source-location))
 290   var)
 291 \f
 292 ;;;; iteration constructs
 293
 294 ;;; (These macros are defined in terms of a function FROB-DO-BODY which
 295 ;;; is also used by SB!INT:DO-ANONYMOUS. Since these macros should not
 296 ;;; be loaded on the cross-compilation host, but SB!INT:DO-ANONYMOUS
 297 ;;; and FROB-DO-BODY should be, these macros can't conveniently be in
 298 ;;; the same file as FROB-DO-BODY.)
 299 (defmacro-mundanely do (varlist endlist &body body)
 300   #!+sb-doc
 301   "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
 302   Iteration construct. Each Var is initialized in parallel to the value of the
 303   specified Init form. On subsequent iterations, the Vars are assigned the
 304   value of the Step form (if any) in parallel. The Test is evaluated before
 305   each evaluation of the body Forms. When the Test is true, the Exit-Forms
 306   are evaluated as a PROGN, with the result being the value of the DO. A block
 307   named NIL is established around the entire expansion, allowing RETURN to be
 308   used as an alternate exit mechanism."
 309   (frob-do-body varlist endlist body 'let 'psetq 'do nil))
 310 (defmacro-mundanely do* (varlist endlist &body body)
 311   #!+sb-doc
 312   "DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
 313   Iteration construct. Each Var is initialized sequentially (like LET*) to the
 314   value of the specified Init form. On subsequent iterations, the Vars are
 315   sequentially assigned the value of the Step form (if any). The Test is
 316   evaluated before each evaluation of the body Forms. When the Test is true,
 317   the Exit-Forms are evaluated as a PROGN, with the result being the value
 318   of the DO. A block named NIL is established around the entire expansion,
 319   allowing RETURN to be used as an laternate exit mechanism."
 320   (frob-do-body varlist endlist body 'let* 'setq 'do* nil))
 321
 322 ;;; DOTIMES and DOLIST could be defined more concisely using
 323 ;;; destructuring macro lambda lists or DESTRUCTURING-BIND, but then
 324 ;;; it'd be tricky to use them before those things were defined.
 325 ;;; They're used enough times before destructuring mechanisms are
 326 ;;; defined that it looks as though it's worth just implementing them
 327 ;;; ASAP, at the cost of being unable to use the standard
 328 ;;; destructuring mechanisms.
 329 (defmacro-mundanely dotimes ((var count &optional (result nil)) &body body)
 330   (cond ((numberp count)
 331         `(do ((,var 0 (1+ ,var)))
 332              ((>= ,var ,count) ,result)
 333            (declare (type unsigned-byte ,var))
 334            ,@body))
 335         (t
 336          (let ((c (gensym "COUNT")))
 337            `(do ((,var 0 (1+ ,var))
 338                  (,c ,count))
 339                 ((>= ,var ,c) ,result)
 340               (declare (type unsigned-byte ,var)
 341                        (type integer ,c))
 342               ,@body)))))
 343
 344 (defmacro-mundanely dolist ((var list &optional (result nil)) &body body)
 345   ;; We repeatedly bind the var instead of setting it so that we never
 346   ;; have to give the var an arbitrary value such as NIL (which might
 347   ;; conflict with a declaration). If there is a result form, we
 348   ;; introduce a gratuitous binding of the variable to NIL without the
 349   ;; declarations, then evaluate the result form in that
 350   ;; environment. We spuriously reference the gratuitous variable,
 351   ;; since we don't want to use IGNORABLE on what might be a special
 352   ;; var.
 353   (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
 354     (let ((n-list (gensym "N-LIST"))
 355           (start (gensym "START")))
 356       `(block nil
 357          (let ((,n-list ,list))
 358            (tagbody
 359               ,start
 360               (unless (endp ,n-list)
 361                 (let ((,var (car ,n-list)))
 362                   ,@decls
 363                   (setq ,n-list (cdr ,n-list))
 364                   (tagbody ,@forms))
 365                 (go ,start))))
 366          ,(if result
 367               `(let ((,var nil))
 368                  ;; Filter out TYPE declarations (VAR gets bound to NIL,
 369                  ;; and might have a conflicting type declaration) and
 370                  ;; IGNORE (VAR might be ignored in the loop body, but
 371                  ;; it's used in the result form).
 372                  ,@(filter-dolist-declarations decls)
 373                  ,var
 374                  ,result)
 375                nil)))))
 376 \f
 377 ;;;; conditions, handlers, restarts
 378
 379 ;;; KLUDGE: we PROCLAIM these special here so that we can use restart
 380 ;;; macros in the compiler before the DEFVARs are compiled.
 381 (sb!xc:proclaim
 382  '(special *handler-clusters* *restart-clusters* *condition-restarts*))
 383
 384 (defmacro-mundanely with-condition-restarts
 385     (condition-form restarts-form &body body)
 386   #!+sb-doc
 387   "Evaluates the BODY in a dynamic environment where the restarts in the list
 388    RESTARTS-FORM are associated with the condition returned by CONDITION-FORM.
 389    This allows FIND-RESTART, etc., to recognize restarts that are not related
 390    to the error currently being debugged. See also RESTART-CASE."
 391   (let ((n-cond (gensym)))
 392     `(let ((*condition-restarts*
 393             (cons (let ((,n-cond ,condition-form))
 394                     (cons ,n-cond
 395                           (append ,restarts-form
 396                                   (cdr (assoc ,n-cond *condition-restarts*)))))
 397                   *condition-restarts*)))
 398        ,@body)))
 399
 400 (defmacro-mundanely restart-bind (bindings &body forms)
 401   #!+sb-doc
 402   "Executes forms in a dynamic context where the given restart bindings are
 403    in effect. Users probably want to use RESTART-CASE. When clauses contain
 404    the same restart name, FIND-RESTART will find the first such clause."
 405   `(let ((*restart-clusters*
 406           (cons (list
 407                  ,@(mapcar (lambda (binding)
 408                              (unless (or (car binding)
 409                                          (member :report-function
 410                                                  binding
 411                                                  :test #'eq))
 412                                (warn "Unnamed restart does not have a ~
 413                                       report function: ~S"
 414                                      binding))
 415                              `(make-restart :name ',(car binding)
 416                                             :function ,(cadr binding)
 417                                             ,@(cddr binding)))
 418                            bindings))
 419                 *restart-clusters*)))
 420      ,@forms))
 421
 422 ;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if
 423 ;;; appropriate. Gross, but it's what the book seems to say...
 424 (defun munge-restart-case-expression (expression env)
 425   (let ((exp (sb!xc:macroexpand expression env)))
 426     (if (consp exp)
 427         (let* ((name (car exp))
 428                (args (if (eq name 'cerror) (cddr exp) (cdr exp))))
 429           (if (member name '(signal error cerror warn))
 430               (once-only ((n-cond `(coerce-to-condition
 431                                     ,(first args)
 432                                     (list ,@(rest args))
 433                                     ',(case name
 434                                         (warn 'simple-warning)
 435                                         (signal 'simple-condition)
 436                                         (t 'simple-error))
 437                                     ',name)))
 438                 `(with-condition-restarts
 439                      ,n-cond
 440                      (car *restart-clusters*)
 441                    ,(if (eq name 'cerror)
 442                         `(cerror ,(second exp) ,n-cond)
 443                         `(,name ,n-cond))))
 444               expression))
 445         expression)))
 446
 447 ;;; FIXME: I did a fair amount of rearrangement of this code in order to
 448 ;;; get WITH-KEYWORD-PAIRS to work cleanly. This code should be tested..
 449 (defmacro-mundanely restart-case (expression &body clauses &environment env)
 450   #!+sb-doc
 451   "(RESTART-CASE form
 452    {(case-name arg-list {keyword value}* body)}*)
 453    The form is evaluated in a dynamic context where the clauses have special
 454    meanings as points to which control may be transferred (see INVOKE-RESTART).
 455    When clauses contain the same case-name, FIND-RESTART will find the first
 456    such clause. If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or
 457    macroexpands into such) then the signalled condition will be associated with
 458    the new restarts."
 459   (flet ((transform-keywords (&key report interactive test)
 460            (let ((result '()))
 461              (when report
 462                (setq result (list* (if (stringp report)
 463                                        `#'(lambda (stream)
 464                                             (write-string ,report stream))
 465                                        `#',report)
 466                                    :report-function
 467                                    result)))
 468              (when interactive
 469                (setq result (list* `#',interactive
 470                                    :interactive-function
 471                                    result)))
 472              (when test
 473                (setq result (list* `#',test :test-function result)))
 474              (nreverse result)))
 475          (parse-keyword-pairs (list keys)
 476            (do ((l list (cddr l))
 477                 (k '() (list* (cadr l) (car l) k)))
 478                ((or (null l) (not (member (car l) keys)))
 479                 (values (nreverse k) l)))))
 480     (let ((block-tag (gensym))
 481           (temp-var (gensym))
 482           (data
 483            (macrolet (;; KLUDGE: This started as an old DEFMACRO
 484                       ;; WITH-KEYWORD-PAIRS general utility, which was used
 485                       ;; only in this one place in the code. It was translated
 486                       ;; literally into this MACROLET in order to avoid some
 487                       ;; cross-compilation bootstrap problems. It would almost
 488                       ;; certainly be clearer, and it would certainly be more
 489                       ;; concise, to do a more idiomatic translation, merging
 490                       ;; this with the TRANSFORM-KEYWORDS logic above.
 491                       ;;   -- WHN 19990925
 492                       (with-keyword-pairs ((names expression) &body forms)
 493                         (let ((temp (member '&rest names)))
 494                           (unless (= (length temp) 2)
 495                             (error "&REST keyword is ~:[missing~;misplaced~]."
 496                                    temp))
 497                           (let* ((key-vars (ldiff names temp))
 498                                  (keywords (mapcar #'keywordicate key-vars))
 499                                  (key-var (gensym))
 500                                  (rest-var (cadr temp)))
 501                             `(multiple-value-bind (,key-var ,rest-var)
 502                                  (parse-keyword-pairs ,expression ',keywords)
 503                                (let ,(mapcar (lambda (var keyword)
 504                                                `(,var (getf ,key-var
 505                                                             ,keyword)))
 506                                              key-vars keywords)
 507                                  ,@forms))))))
 508              (mapcar (lambda (clause)
 509                        (with-keyword-pairs ((report interactive test
 510                                                     &rest forms)
 511                                             (cddr clause))
 512                          (list (car clause) ;name=0
 513                                (gensym) ;tag=1
 514                                (transform-keywords :report report ;keywords=2
 515                                                    :interactive interactive
 516                                                    :test test)
 517                                (cadr clause) ;bvl=3
 518                                forms))) ;body=4
 519                    clauses))))
 520       `(block ,block-tag
 521          (let ((,temp-var nil))
 522            (tagbody
 523             (restart-bind
 524                 ,(mapcar (lambda (datum)
 525                            (let ((name (nth 0 datum))
 526                                  (tag  (nth 1 datum))
 527                                  (keys (nth 2 datum)))
 528                              `(,name #'(lambda (&rest temp)
 529                                          (setq ,temp-var temp)
 530                                          (go ,tag))
 531                                      ,@keys)))
 532                          data)
 533               (return-from ,block-tag
 534                            ,(munge-restart-case-expression expression env)))
 535             ,@(mapcan (lambda (datum)
 536                         (let ((tag  (nth 1 datum))
 537                               (bvl  (nth 3 datum))
 538                               (body (nth 4 datum)))
 539                           (list tag
 540                                 `(return-from ,block-tag
 541                                    (apply (lambda ,bvl ,@body)
 542                                           ,temp-var)))))
 543                       data)))))))
 544
 545 (defmacro-mundanely with-simple-restart ((restart-name format-string
 546                                                        &rest format-arguments)
 547                                          &body forms)
 548   #!+sb-doc
 549   "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments)
 550    body)
 551    If restart-name is not invoked, then all values returned by forms are
 552    returned. If control is transferred to this restart, it immediately
 553    returns the values NIL and T."
 554   `(restart-case
 555        ;; If there's just one body form, then don't use PROGN. This allows
 556        ;; RESTART-CASE to "see" calls to ERROR, etc.
 557        ,(if (= (length forms) 1) (car forms) `(progn ,@forms))
 558      (,restart-name ()
 559         :report (lambda (stream)
 560                   (format stream ,format-string ,@format-arguments))
 561       (values nil t))))
 562
 563 (defmacro-mundanely handler-bind (bindings &body forms)
 564   #!+sb-doc
 565   "(HANDLER-BIND ( {(type handler)}* )  body)
 566    Executes body in a dynamic context where the given handler bindings are
 567    in effect. Each handler must take the condition being signalled as an
 568    argument. The bindings are searched first to last in the event of a
 569    signalled condition."
 570   (let ((member-if (member-if (lambda (x)
 571                                 (not (proper-list-of-length-p x 2)))
 572                               bindings)))
 573     (when member-if
 574       (error "ill-formed handler binding: ~S" (first member-if))))
 575   `(let ((*handler-clusters*
 576           (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x)))
 577                                 bindings))
 578                 *handler-clusters*)))
 579      (multiple-value-prog1
 580          (progn
 581            ,@forms)
 582        ;; Wait for any float exceptions.
 583        #!+x86 (float-wait))))
 584
 585 (defmacro-mundanely handler-case (form &rest cases)
 586   "(HANDLER-CASE form
 587    { (type ([var]) body) }* )
 588    Execute FORM in a context with handlers established for the condition
 589    types. A peculiar property allows type to be :NO-ERROR. If such a clause
 590    occurs, and form returns normally, all its values are passed to this clause
 591    as if by MULTIPLE-VALUE-CALL.  The :NO-ERROR clause accepts more than one
 592    var specification."
 593   ;; FIXME: Replacing CADR, CDDDR and friends with DESTRUCTURING-BIND
 594   ;; and names for the subexpressions would make it easier to
 595   ;; understand the code below.
 596   (let ((no-error-clause (assoc ':no-error cases)))
 597     (if no-error-clause
 598         (let ((normal-return (make-symbol "normal-return"))
 599               (error-return  (make-symbol "error-return")))
 600           `(block ,error-return
 601              (multiple-value-call (lambda ,@(cdr no-error-clause))
 602                (block ,normal-return
 603                  (return-from ,error-return
 604                    (handler-case (return-from ,normal-return ,form)
 605                      ,@(remove no-error-clause cases)))))))
 606         (let ((tag (gensym))
 607               (var (gensym))
 608               (annotated-cases (mapcar (lambda (case) (cons (gensym) case))
 609                                        cases)))
 610           `(block ,tag
 611              (let ((,var nil))
 612                (declare (ignorable ,var))
 613                (tagbody
 614                 (handler-bind
 615                     ,(mapcar (lambda (annotated-case)
 616                                (list (cadr annotated-case)
 617                                      `(lambda (temp)
 618                                         ,(if (caddr annotated-case)
 619                                              `(setq ,var temp)
 620                                              '(declare (ignore temp)))
 621                                         (go ,(car annotated-case)))))
 622                              annotated-cases)
 623                   (return-from ,tag
 624                     #!-x86 ,form
 625                     #!+x86 (multiple-value-prog1 ,form
 626                              ;; Need to catch FP errors here!
 627                              (float-wait))))
 628                 ,@(mapcan
 629                    (lambda (annotated-case)
 630                      (list (car annotated-case)
 631                            (let ((body (cdddr annotated-case)))
 632                              `(return-from
 633                                   ,tag
 634                                 ,(cond ((caddr annotated-case)
 635                                         `(let ((,(caaddr annotated-case)
 636                                                 ,var))
 637                                            ,@body))
 638                                        (t
 639                                         `(locally ,@body)))))))
 640                    annotated-cases))))))))
 641 \f
 642 ;;;; miscellaneous
 643
 644 (defmacro-mundanely return (&optional (value nil))
 645   `(return-from nil ,value))
 646
 647 (defmacro-mundanely psetq (&rest pairs)
 648   #!+sb-doc
 649   "PSETQ {var value}*
 650    Set the variables to the values, like SETQ, except that assignments
 651    happen in parallel, i.e. no assignments take place until all the
 652    forms have been evaluated."
 653   ;; Given the possibility of symbol-macros, we delegate to PSETF
 654   ;; which knows how to deal with them, after checking that syntax is
 655   ;; compatible with PSETQ.
 656   (do ((pair pairs (cddr pair)))
 657       ((endp pair) `(psetf ,@pairs))
 658     (unless (symbolp (car pair))
 659       (error 'simple-program-error
 660              :format-control "variable ~S in PSETQ is not a SYMBOL"
 661              :format-arguments (list (car pair))))))
 662
 663 (defmacro-mundanely lambda (&whole whole args &body body)
 664   (declare (ignore args body))
 665   `#',whole)
 666
 667 (defmacro-mundanely named-lambda (&whole whole name args &body body)
 668   (declare (ignore name args body))
 669   `#',whole)
 670
 671 (defmacro-mundanely lambda-with-lexenv (&whole whole
 672                                         declarations macros symbol-macros
 673                                         &body body)
 674   (declare (ignore declarations macros symbol-macros body))
 675   `#',whole)
 676
 677 ;;; this eliminates a whole bundle of unknown function STYLE-WARNINGs
 678 ;;; when cross-compiling.  It's not critical for behaviour, but is
 679 ;;; aesthetically pleasing, except inasmuch as there's this list of
 680 ;;; magic functions here.  -- CSR, 2003-04-01
 681 #+sb-xc-host
 682 (sb!xc:proclaim '(ftype (function * *)
 683                         ;; functions appearing in fundamental defining
 684                         ;; macro expansions:
 685                         %compiler-deftype
 686                         %compiler-defvar
 687                         %defun
 688                         %defsetf
 689                         %defparameter
 690                         %defvar
 691                         sb!c:%compiler-defun
 692                         sb!c::%define-symbol-macro
 693                         sb!c::%defconstant
 694                         sb!c::%define-compiler-macro
 695                         sb!c::%defmacro
 696                         sb!kernel::%compiler-defstruct
 697                         sb!kernel::%compiler-define-condition
 698                         sb!kernel::%defstruct
 699                         sb!kernel::%define-condition
 700                         ;; miscellaneous functions commonly appearing
 701                         ;; as a result of macro expansions or compiler
 702                         ;; transformations:
 703                         sb!int:find-undeleted-package-or-lose ; IN-PACKAGE
 704                         sb!kernel::arg-count-error ; PARSE-DEFMACRO
 705                         ))