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                             &environment env)
  29   #!+sb-doc
  30   "Signals an error if the value of TEST-FORM is NIL. Returns NIL.
  31
  32    Optional DATUM and ARGUMENTS can be used to change the signaled
  33    error condition and are interpreted as in (APPLY #'ERROR DATUM
  34    ARGUMENTS).
  35
  36    Continuing from the signaled error using the CONTINUE restart will
  37    allow the user to alter the values of the SETFable locations
  38    specified in PLACES and then start over with TEST-FORM.
  39
  40    If TEST-FORM is of the form
  41
  42      (FUNCTION ARG*)
  43
  44    where FUNCTION is a function (but not a special operator like
  45    CL:OR, CL:AND, etc.) the results of evaluating the ARGs will be
  46    included in the error report if the assertion fails."
  47   (collect ((bindings) (infos))
  48     (let ((new-test
  49             (flet ((process-place (place)
  50                      (if (sb!xc:constantp place env)
  51                          place
  52                          (with-unique-names (temp)
  53                            (bindings `(,temp ,place))
  54                            (infos `(list ',place ,temp))
  55                            temp))))
  56               (cond
  57                 ;; TEST-FORM looks like a function call. We do not
  58                 ;; attempt this if TEST-FORM is the application of a
  59                 ;; special operator because of argument evaluation
  60                 ;; order issues.
  61                 ((and (typep test-form '(cons symbol list))
  62                       (eq (info :function :kind (first test-form)) :function))
  63                  (let ((name (first test-form))
  64                        (args (mapcar #'process-place (rest test-form))))
  65                    `(,name ,@args)))
  66                 ;; For all other cases, just evaluate TEST-FORM and do
  67                 ;; not report any details if the assertion fails.
  68                 (t
  69                  test-form)))))
  70       ;; If TEST-FORM, potentially using values from BINDINGS, does not
  71       ;; hold, enter a loop which reports the assertion error,
  72       ;; potentially changes PLACES, and retries TEST-FORM.
  73       `(tagbody
  74         :try
  75           (let ,(bindings)
  76             (when ,new-test
  77               (go :done))
  78             (assert-error ',test-form (list ,@(infos))
  79                           ',places ,datum ,@arguments))
  80           ,@(mapcar (lambda (place)
  81                       `(setf ,place (assert-prompt ',place ,place)))
  82                     places)
  83           (go :try)
  84         :done))))
  85
  86 (defun assert-prompt (name value)
  87   (cond ((y-or-n-p "The old value of ~S is ~S.~
  88                     ~%Do you want to supply a new value? "
  89                    name value)
  90          (format *query-io* "~&Type a form to be evaluated:~%")
  91          (flet ((read-it () (eval (read *query-io*))))
  92            (if (symbolp name) ;help user debug lexical variables
  93                (progv (list name) (list value) (read-it))
  94                (read-it))))
  95         (t value)))
  96
  97 ;;; CHECK-TYPE is written this way, to call CHECK-TYPE-ERROR, because
  98 ;;; of how closures are compiled. RESTART-CASE has forms with closures
  99 ;;; that the compiler causes to be generated at the top of any
 100 ;;; function using RESTART-CASE, regardless of whether they are
 101 ;;; needed. Because it would be nice if CHECK-TYPE were cheap to use,
 102 ;;; and some things (e.g., READ-CHAR) can't afford this excessive
 103 ;;; consing, we bend backwards a little.
 104 ;;;
 105 ;;; CHECK-TYPE-ERROR isn't defined until a later file because it uses
 106 ;;; the macro RESTART-CASE, which isn't defined until a later file.
 107 (defmacro-mundanely check-type (place type &optional type-string
 108                                 &environment env)
 109   #!+sb-doc
 110   "Signal a restartable error of type TYPE-ERROR if the value of PLACE
 111 is not of the specified type. If an error is signalled and the restart
 112 is used to return, this can only return if the STORE-VALUE restart is
 113 invoked. In that case it will store into PLACE and start over."
 114   ;; Detect a common user-error.
 115   (when (and (consp type) (eq 'quote (car type)))
 116     (error 'simple-reference-error
 117            :format-control "Quoted type specifier in ~S: ~S"
 118            :format-arguments (list 'check-type type)
 119            :references (list '(:ansi-cl :macro check-type))))
 120   ;; KLUDGE: We use a simpler form of expansion if PLACE is just a
 121   ;; variable to work around Python's blind spot in type derivation.
 122   ;; For more complex places getting the type derived should not
 123   ;; matter so much anyhow.
 124   (let ((expanded (%macroexpand place env)))
 125     (if (symbolp expanded)
 126         `(do ()
 127              ((typep ,place ',type))
 128           (setf ,place (check-type-error ',place ,place ',type ,type-string)))
 129         (let ((value (gensym)))
 130           `(do ((,value ,place ,place))
 131                ((typep ,value ',type))
 132             (setf ,place
 133                   (check-type-error ',place ,value ',type ,type-string)))))))
 134 \f
 135 ;;;; DEFINE-SYMBOL-MACRO
 136
 137 (defmacro-mundanely define-symbol-macro (name expansion)
 138   `(eval-when (:compile-toplevel :load-toplevel :execute)
 139     (sb!c::%define-symbol-macro ',name ',expansion (sb!c:source-location))))
 140
 141 (defun sb!c::%define-symbol-macro (name expansion source-location)
 142   (unless (symbolp name)
 143     (error 'simple-type-error :datum name :expected-type 'symbol
 144            :format-control "Symbol macro name is not a symbol: ~S."
 145            :format-arguments (list name)))
 146   (with-single-package-locked-error
 147       (:symbol name "defining ~A as a symbol-macro"))
 148   (sb!c:with-source-location (source-location)
 149     (setf (info :source-location :symbol-macro name) source-location))
 150   (let ((kind (info :variable :kind name)))
 151     (ecase kind
 152      ((:macro :unknown)
 153       (setf (info :variable :kind name) :macro)
 154       (setf (info :variable :macro-expansion name) expansion))
 155      ((:special :global)
 156       (error 'simple-program-error
 157              :format-control "Symbol macro name already declared ~A: ~S."
 158              :format-arguments (list kind name)))
 159      (:constant
 160       (error 'simple-program-error
 161              :format-control "Symbol macro name already defined as a constant: ~S."
 162              :format-arguments (list name)))))
 163   name)
 164 \f
 165 ;;;; DEFINE-COMPILER-MACRO
 166
 167 (defmacro-mundanely define-compiler-macro (name lambda-list &body body)
 168   #!+sb-doc
 169   "Define a compiler-macro for NAME."
 170   (legal-fun-name-or-type-error name)
 171   (when (and (symbolp name) (special-operator-p name))
 172     (error 'simple-program-error
 173            :format-control "cannot define a compiler-macro for a special operator: ~S"
 174            :format-arguments (list name)))
 175   (with-unique-names (whole environment)
 176     (multiple-value-bind (body local-decs doc)
 177         (parse-defmacro lambda-list whole body name 'define-compiler-macro
 178                         :environment environment)
 179       (let ((def `(lambda (,whole ,environment)
 180                     ,@local-decs
 181                     ,body))
 182             (debug-name (sb!c::debug-name 'compiler-macro-function name)))
 183         `(eval-when (:compile-toplevel :load-toplevel :execute)
 184            (sb!c::%define-compiler-macro ',name
 185                                          #',def
 186                                          ',lambda-list
 187                                          ,doc
 188                                          ',debug-name))))))
 189
 190 ;;; FIXME: This will look remarkably similar to those who have already
 191 ;;; seen the code for %DEFMACRO in src/code/defmacro.lisp.  Various
 192 ;;; bits of logic should be shared (notably arglist setting).
 193 (macrolet
 194     ((def (times set-p)
 195          `(eval-when (,@times)
 196            (defun sb!c::%define-compiler-macro
 197                (name definition lambda-list doc debug-name)
 198              ,@(unless set-p
 199                  '((declare (ignore lambda-list debug-name))))
 200              ;; FIXME: warn about incompatible lambda list with
 201              ;; respect to parent function?
 202              (setf (sb!xc:compiler-macro-function name) definition)
 203              ,(when set-p
 204                     `(setf (%fun-doc definition) doc
 205                            (%fun-lambda-list definition) lambda-list
 206                            (%fun-name definition) debug-name))
 207              name))))
 208   (progn
 209     (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil)
 210     #-sb-xc (def (:compile-toplevel) nil)))
 211 \f
 212 ;;;; CASE, TYPECASE, and friends
 213
 214 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 215
 216 ;;; Make this a full warning during SBCL build.
 217 (define-condition duplicate-case-key-warning (#-sb-xc-host style-warning #+sb-xc-host warning)
 218   ((key :initarg :key
 219         :reader case-warning-key)
 220    (case-kind :initarg :case-kind
 221               :reader case-warning-case-kind)
 222    (occurrences :initarg :occurrences
 223                 :type list
 224                 :reader duplicate-case-key-warning-occurrences))
 225   (:report
 226     (lambda (condition stream)
 227       (format stream
 228         "Duplicate key ~S in ~S form, ~
 229          occurring in~{~#[~; and~]~{ the ~:R clause:~%~<  ~S~:>~}~^,~}."
 230         (case-warning-key condition)
 231         (case-warning-case-kind condition)
 232         (duplicate-case-key-warning-occurrences condition)))))
 233
 234 ;;; CASE-BODY returns code for all the standard "case" macros. NAME is
 235 ;;; the macro name, and KEYFORM is the thing to case on. MULTI-P
 236 ;;; indicates whether a branch may fire off a list of keys; otherwise,
 237 ;;; a key that is a list is interpreted in some way as a single key.
 238 ;;; When MULTI-P, TEST is applied to the value of KEYFORM and each key
 239 ;;; for a given branch; otherwise, TEST is applied to the value of
 240 ;;; KEYFORM and the entire first element, instead of each part, of the
 241 ;;; case branch. When ERRORP, no OTHERWISE-CLAUSEs are recognized,
 242 ;;; and an ERROR form is generated where control falls off the end
 243 ;;; of the ordinary clauses. When PROCEEDP, it is an error to
 244 ;;; omit ERRORP, and the ERROR form generated is executed within a
 245 ;;; RESTART-CASE allowing KEYFORM to be set and retested.
 246 (defun case-body (name keyform cases multi-p test errorp proceedp needcasesp)
 247   (unless (or cases (not needcasesp))
 248     (warn "no clauses in ~S" name))
 249   (let ((keyform-value (gensym))
 250         (clauses ())
 251         (keys ())
 252         (keys-seen (make-hash-table :test #'eql)))
 253     (do* ((cases cases (cdr cases))
 254           (case (car cases) (car cases))
 255           (case-position 1 (1+ case-position)))
 256          ((null cases) nil)
 257       (flet ((check-clause (case-keys)
 258                (loop for k in case-keys
 259                      for existing = (gethash k keys-seen)
 260                      do (when existing
 261                           (let ((sb!c::*current-path*
 262                                  (when (boundp 'sb!c::*source-paths*)
 263                                    (or (sb!c::get-source-path case)
 264                                        sb!c::*current-path*))))
 265                             (warn 'duplicate-case-key-warning
 266                                   :key k
 267                                   :case-kind name
 268                                   :occurrences `(,existing (,case-position (,case)))))))
 269                (let ((record (list case-position (list case))))
 270                  (dolist (k case-keys)
 271                    (setf (gethash k keys-seen) record)))))
 272         (unless (list-of-length-at-least-p case 1)
 273           (error "~S -- bad clause in ~S" case name))
 274         (destructuring-bind (keyoid &rest forms) case
 275           (cond (;; an OTHERWISE-CLAUSE
 276                  ;;
 277                  ;; By the way... The old code here tried gave
 278                  ;; STYLE-WARNINGs for normal-clauses which looked as
 279                  ;; though they might've been intended to be
 280                  ;; otherwise-clauses. As Tony Martinez reported on
 281                  ;; sbcl-devel 2004-11-09 there are sometimes good
 282                  ;; reasons to write clauses like that; and as I noticed
 283                  ;; when trying to understand the old code so I could
 284                  ;; understand his patch, trying to guess which clauses
 285                  ;; don't have good reasons is fundamentally kind of a
 286                  ;; mess. SBCL does issue style warnings rather
 287                  ;; enthusiastically, and I have often justified that by
 288                  ;; arguing that we're doing that to detect issues which
 289                  ;; are tedious for programmers to detect for by
 290                  ;; proofreading (like small typoes in long symbol
 291                  ;; names, or duplicate function definitions in large
 292                  ;; files). This doesn't seem to be an issue like that,
 293                  ;; and I can't think of a comparably good justification
 294                  ;; for giving STYLE-WARNINGs for legal code here, so
 295                  ;; now we just hope the programmer knows what he's
 296                  ;; doing. -- WHN 2004-11-20
 297                  (and (not errorp) ; possible only in CASE or TYPECASE,
 298                                    ; not in [EC]CASE or [EC]TYPECASE
 299                       (memq keyoid '(t otherwise))
 300                       (null (cdr cases)))
 301                  (push `(t nil ,@forms) clauses))
 302                 ((and multi-p (listp keyoid))
 303                  (setf keys (append keyoid keys))
 304                  (check-clause keyoid)
 305                  (push `((or ,@(mapcar (lambda (key)
 306                                          `(,test ,keyform-value ',key))
 307                                        keyoid))
 308                          nil
 309                          ,@forms)
 310                        clauses))
 311                 (t
 312                  (when (and (eq name 'case)
 313                             (cdr cases)
 314                             (memq keyoid '(t otherwise)))
 315                    (error 'simple-reference-error
 316                           :format-control
 317                           "~@<~IBad ~S clause:~:@_  ~S~:@_~S allowed as the key ~
 318                            designator only in the final otherwise-clause, not in a ~
 319                            normal-clause. Use (~S) instead, or move the clause the ~
 320                            correct position.~:@>"
 321                           :format-arguments (list 'case case keyoid keyoid)
 322                           :references `((:ansi-cl :macro case))))
 323                  (push keyoid keys)
 324                  (check-clause (list keyoid))
 325                  (push `((,test ,keyform-value ',keyoid)
 326                          nil
 327                          ,@forms)
 328                        clauses))))))
 329     (case-body-aux name keyform keyform-value clauses keys errorp proceedp
 330                    `(,(if multi-p 'member 'or) ,@keys))))
 331
 332 ;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled
 333 ;;; all the cases. Note: it is not necessary that the resulting code
 334 ;;; signal case-failure conditions, but that's what KMP's prototype
 335 ;;; code did. We call CASE-BODY-ERROR, because of how closures are
 336 ;;; compiled. RESTART-CASE has forms with closures that the compiler
 337 ;;; causes to be generated at the top of any function using the case
 338 ;;; macros, regardless of whether they are needed.
 339 ;;;
 340 ;;; The CASE-BODY-ERROR function is defined later, when the
 341 ;;; RESTART-CASE macro has been defined.
 342 (defun case-body-aux (name keyform keyform-value clauses keys
 343                       errorp proceedp expected-type)
 344   (if proceedp
 345       (let ((block (gensym))
 346             (again (gensym)))
 347         `(let ((,keyform-value ,keyform))
 348            (block ,block
 349              (tagbody
 350               ,again
 351               (return-from
 352                ,block
 353                (cond ,@(nreverse clauses)
 354                      (t
 355                       (setf ,keyform-value
 356                             (setf ,keyform
 357                                   (case-body-error
 358                                    ',name ',keyform ,keyform-value
 359                                    ',expected-type ',keys)))
 360                       (go ,again))))))))
 361       `(let ((,keyform-value ,keyform))
 362          (declare (ignorable ,keyform-value)) ; e.g. (CASE KEY (T))
 363          (cond
 364           ,@(nreverse clauses)
 365           ,@(if errorp
 366                 `((t (case-failure ',name ,keyform-value ',keys))))))))
 367 ) ; EVAL-WHEN
 368
 369 (defmacro-mundanely case (keyform &body cases)
 370   #!+sb-doc
 371   "CASE Keyform {({(Key*) | Key} Form*)}*
 372   Evaluates the Forms in the first clause with a Key EQL to the value of
 373   Keyform. If a singleton key is T then the clause is a default clause."
 374   (case-body 'case keyform cases t 'eql nil nil nil))
 375
 376 (defmacro-mundanely ccase (keyform &body cases)
 377   #!+sb-doc
 378   "CCASE Keyform {({(Key*) | Key} Form*)}*
 379   Evaluates the Forms in the first clause with a Key EQL to the value of
 380   Keyform. If none of the keys matches then a correctable error is
 381   signalled."
 382   (case-body 'ccase keyform cases t 'eql t t t))
 383
 384 (defmacro-mundanely ecase (keyform &body cases)
 385   #!+sb-doc
 386   "ECASE Keyform {({(Key*) | Key} Form*)}*
 387   Evaluates the Forms in the first clause with a Key EQL to the value of
 388   Keyform. If none of the keys matches then an error is signalled."
 389   (case-body 'ecase keyform cases t 'eql t nil t))
 390
 391 (defmacro-mundanely typecase (keyform &body cases)
 392   #!+sb-doc
 393   "TYPECASE Keyform {(Type Form*)}*
 394   Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
 395   is true."
 396   (case-body 'typecase keyform cases nil 'typep nil nil nil))
 397
 398 (defmacro-mundanely ctypecase (keyform &body cases)
 399   #!+sb-doc
 400   "CTYPECASE Keyform {(Type Form*)}*
 401   Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
 402   is true. If no form is satisfied then a correctable error is signalled."
 403   (case-body 'ctypecase keyform cases nil 'typep t t t))
 404
 405 (defmacro-mundanely etypecase (keyform &body cases)
 406   #!+sb-doc
 407   "ETYPECASE Keyform {(Type Form*)}*
 408   Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
 409   is true. If no form is satisfied then an error is signalled."
 410   (case-body 'etypecase keyform cases nil 'typep t nil t))
 411 \f
 412 ;;;; WITH-FOO i/o-related macros
 413
 414 (defmacro-mundanely with-open-stream ((var stream) &body forms-decls)
 415   (multiple-value-bind (forms decls)
 416       (parse-body forms-decls :doc-string-allowed nil)
 417     (let ((abortp (gensym)))
 418       `(let ((,var ,stream)
 419              (,abortp t))
 420          ,@decls
 421          (unwind-protect
 422              (multiple-value-prog1
 423               (progn ,@forms)
 424               (setq ,abortp nil))
 425            (when ,var
 426              (close ,var :abort ,abortp)))))))
 427
 428 (defmacro-mundanely with-open-file ((stream filespec &rest options)
 429                                     &body body)
 430   `(with-open-stream (,stream (open ,filespec ,@options))
 431      ,@body))
 432
 433 (defmacro-mundanely with-input-from-string ((var string &key index start end)
 434                                             &body forms-decls)
 435   (multiple-value-bind (forms decls)
 436       (parse-body forms-decls :doc-string-allowed nil)
 437     ;; The ONCE-ONLY inhibits compiler note for unreachable code when
 438     ;; END is true.
 439     (once-only ((string string))
 440       `(let ((,var
 441               ,(cond ((null end)
 442                       `(make-string-input-stream ,string ,(or start 0)))
 443                      ((symbolp end)
 444                       `(if ,end
 445                            (make-string-input-stream ,string
 446                                                      ,(or start 0)
 447                                                      ,end)
 448                            (make-string-input-stream ,string
 449                                                      ,(or start 0))))
 450                      (t
 451                       `(make-string-input-stream ,string
 452                                                  ,(or start 0)
 453                                                  ,end)))))
 454          ,@decls
 455          (multiple-value-prog1
 456              (unwind-protect
 457                   (progn ,@forms)
 458                (close ,var))
 459            ,@(when index
 460                `((setf ,index (string-input-stream-current ,var)))))))))
 461
 462 (defmacro-mundanely with-output-to-string
 463     ((var &optional string &key (element-type ''character))
 464      &body forms-decls)
 465   (multiple-value-bind (forms decls)
 466       (parse-body forms-decls :doc-string-allowed nil)
 467     (if string
 468         (let ((element-type-var (gensym)))
 469           `(let ((,var (make-fill-pointer-output-stream ,string))
 470                  ;; ELEMENT-TYPE isn't currently used for anything
 471                  ;; (see FILL-POINTER-OUTPUT-STREAM FIXME in stream.lisp),
 472                  ;; but it still has to be evaluated for side-effects.
 473                  (,element-type-var ,element-type))
 474             (declare (ignore ,element-type-var))
 475             ,@decls
 476             (unwind-protect
 477                  (progn ,@forms)
 478               (close ,var))))
 479       `(let ((,var (make-string-output-stream :element-type ,element-type)))
 480          ,@decls
 481          (unwind-protect
 482              (progn ,@forms)
 483            (close ,var))
 484          (get-output-stream-string ,var)))))
 485 \f
 486 ;;;; miscellaneous macros
 487
 488 (defmacro-mundanely nth-value (n form)
 489   #!+sb-doc
 490   "Evaluate FORM and return the Nth value (zero based). This involves no
 491   consing when N is a trivial constant integer."
 492   ;; FIXME: The above is true, if slightly misleading.  The
 493   ;; MULTIPLE-VALUE-BIND idiom [ as opposed to MULTIPLE-VALUE-CALL
 494   ;; (LAMBDA (&REST VALUES) (NTH N VALUES)) ] does indeed not cons at
 495   ;; runtime.  However, for large N (say N = 200), COMPILE on such a
 496   ;; form will take longer than can be described as adequate, as the
 497   ;; optional dispatch mechanism for the M-V-B gets increasingly
 498   ;; hairy.
 499   (if (integerp n)
 500       (let ((dummy-list (make-gensym-list n))
 501             (keeper (sb!xc:gensym "KEEPER")))
 502         `(multiple-value-bind (,@dummy-list ,keeper) ,form
 503            (declare (ignore ,@dummy-list))
 504            ,keeper))
 505       (once-only ((n n))
 506         `(case (the fixnum ,n)
 507            (0 (nth-value 0 ,form))
 508            (1 (nth-value 1 ,form))
 509            (2 (nth-value 2 ,form))
 510            (t (nth (the fixnum ,n) (multiple-value-list ,form)))))))
 511
 512 (defmacro-mundanely declaim (&rest specs)
 513   #!+sb-doc
 514   "DECLAIM Declaration*
 515   Do a declaration or declarations for the global environment."
 516   `(eval-when (:compile-toplevel :load-toplevel :execute)
 517      ,@(mapcar (lambda (spec) `(sb!xc:proclaim ',spec))
 518                specs)))
 519
 520 (defmacro-mundanely print-unreadable-object ((object stream &key type identity)
 521                                              &body body)
 522   "Output OBJECT to STREAM with \"#<\" prefix, \">\" suffix, optionally
 523   with object-type prefix and object-identity suffix, and executing the
 524   code in BODY to provide possible further output."
 525   `(%print-unreadable-object ,object ,stream ,type ,identity
 526                              ,(if body
 527                                   `(lambda () ,@body)
 528                                   nil)))
 529
 530 (defmacro-mundanely ignore-errors (&rest forms)
 531   #!+sb-doc
 532   "Execute FORMS handling ERROR conditions, returning the result of the last
 533   form, or (VALUES NIL the-ERROR-that-was-caught) if an ERROR was handled."
 534   `(handler-case (progn ,@forms)
 535      (error (condition) (values nil condition))))