home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / clisp / conditio.lsp < prev    next >
Text File  |  1977-12-31  |  67KB  |  1,725 lines
  1. ;;; Condition System for CLISP
  2. ;;; David Gadbois <gadbois@cs.utexas.edu> 30.11.1993
  3. ;;; Bruno Haible 24.11.1993, 2.12.1993
  4.  
  5. (in-package "LISP")
  6. ;;; exports:
  7. (export '(
  8. ;; types:
  9. restart condition serious-condition error program-error control-error
  10. arithmetic-error division-by-zero floating-point-overflow
  11. floating-point-underflow cell-error unbound-variable undefined-function
  12. type-error package-error print-not-readable stream-error end-of-file
  13. file-error storage-condition warning simple-condition simple-error
  14. simple-type-error simple-warning
  15. ;; macros:
  16. define-condition handler-bind ignore-errors handler-case
  17. with-condition-restarts restart-bind restart-case with-restarts
  18. with-simple-restart check-type assert etypecase ctypecase ecase ccase
  19. ;; functions:
  20. make-condition arithmetic-error-operation arithmetic-error-operands
  21. cell-error-name type-error-datum type-error-expected-type
  22. package-error-package print-not-readable-object stream-error-stream
  23. file-error-pathname simple-condition-format-string
  24. simple-condition-format-arguments
  25. signal restart-name compute-restarts find-restart invoke-restart
  26. invoke-restart-interactively invoke-debugger break error cerror warn
  27. ;; functions and restart names:
  28. abort continue muffle-warning store-value use-value
  29. ;; variables:
  30. *break-on-signals* *debugger-hook*
  31. ;; extensions:
  32. muffle-cerrors appease-cerrors exit-on-error
  33. ))
  34. (in-package "SYSTEM")
  35.  
  36.  
  37. ;;; Overview of Concepts
  38.  
  39. ; A condition is some information about an exceptional situation the program
  40. ; cannot or does not want handle locally.
  41. ; A handler is some code that tries to do recovery from exceptional situations
  42. ; that happen elsewhere, or that decides to transfer control.
  43. ; A restart is a point where control may be transferred to, together with a
  44. ; description what is about to happen in this case.
  45.  
  46.  
  47. ;;; The CONDITION type
  48.  
  49. ; The condition type system is integrated with CLOS.
  50. (clos:defclass condition () ())
  51.  
  52. ; 29.3.18. Printing Conditions when *print-escape* and *print-readably* are NIL.
  53. (clos:defgeneric print-condition (condition stream)
  54.   (:method ((condition condition) stream)
  55.     (format stream 
  56.         (formatter
  57.             #.
  58.             #L{
  59.             DEUTSCH "Ausnahmefall vom Typ ~S."
  60.             ENGLISH "Condition of type ~S."
  61.             FRANCAIS "Condition exceptionnelle de type ~S."
  62.             }
  63.         )
  64.         (type-of condition)
  65.   ) )
  66. )
  67. (clos:defmethod clos:print-object ((object condition) stream)
  68.   (if (or *print-escape* *print-readably*)
  69.     (clos:call-next-method)
  70.     (print-condition object stream)
  71. ) )
  72.  
  73. ;;; 29.4.5. Defining Conditions
  74.  
  75. ; DEFINE-CONDITION, CLtL2 p. 898
  76. (defmacro define-condition (name parent-types slot-specs &rest options)
  77.   (unless (symbolp name)
  78.     (error-of-type 'program-error
  79.                    #L{
  80.                    DEUTSCH "~S: Der Name einer Condition muß ein Symbol sein, nicht: ~S"
  81.                    ENGLISH "~S: the name of a condition must be a symbol, not ~S"
  82.                    FRANCAIS "~S : Le nom d'une condition exceptionnelle doit être un symbole et non ~S"
  83.                    }
  84.       'define-condition name
  85.   ) )
  86.   (unless (and (listp parent-types) (every #'symbolp parent-types))
  87.     (error-of-type 'program-error
  88.                    #L{
  89.                    DEUTSCH "~S: Die Liste der Obertypen muß eine Liste von Symbolen sein, nicht: ~S"
  90.                    ENGLISH "~S: the parent-type list must be a list of symbols, not ~S"
  91.                    FRANCAIS "~S : La liste des types doit être une liste de symboles et non ~S"
  92.                    }
  93.       'define-condition parent-types
  94.   ) )
  95.   (unless (listp slot-specs)
  96.     (error-of-type 'program-error
  97.                    #L{
  98.                    DEUTSCH "~S: Die Liste der Slot-Beschreibungen muß eine Liste sein, nicht: ~S"
  99.                    ENGLISH "~S: the slot description list must be a list, not ~S"
  100.                    FRANCAIS "~S : La liste des descriptions de «slots» doit être une listeet non ~S"
  101.                    }
  102.       'define-condition slot-specs
  103.   ) )
  104.   (let ((docstring-option nil)
  105.         (report-function nil))
  106.     (dolist (option options)
  107.       (if (listp option)
  108.         (if (and (keywordp (car option)) (eql (length option) 2))
  109.           (case (first option)
  110.             (:DOCUMENTATION (setq docstring-option option))
  111.             (:REPORT (setq report-function (rest option)))
  112.             (T (error-of-type 'program-error
  113.                               #L{
  114.                               DEUTSCH "~S ~S: Die Option ~S gibt es nicht."
  115.                               ENGLISH "~S ~S: unknown option ~S"
  116.                               FRANCAIS "~S ~S : Option ~S non reconnue."
  117.                               }
  118.                  'define-condition name (first option)
  119.           ) )  )
  120.           (error-of-type 'program-error
  121.                          #L{
  122.                          DEUTSCH "~S ~S: Falsche Syntax in ~S-Option: ~S"
  123.                          ENGLISH "~S ~S: invalid syntax in ~S option: ~S"
  124.                          FRANCAIS "~S ~S : Mauvaise syntaxe dans l'option ~S: ~S"
  125.                          }
  126.             'define-condition name option
  127.         ) )
  128.         (error-of-type 'program-error
  129.                        #L{
  130.                        DEUTSCH "~S ~S: Das ist keine ~S-Option: ~S"
  131.                        ENGLISH "~S ~S: not a ~S option: ~S"
  132.                        FRANCAIS "~S ~S : Ceci n'est pas une option ~S: ~S"
  133.                        }
  134.           'define-condition name option
  135.     ) ) )
  136.     (let ((defclass-form
  137.             `(CLOS:DEFCLASS ,name
  138.                ,(clos::add-default-superclass parent-types 'CONDITION)
  139.                ,slot-specs
  140.                ,@(if docstring-option `(,docstring-option))
  141.              )
  142.          ))
  143.       (if report-function
  144.         `(PROGN
  145.            ,defclass-form
  146.            (CLOS:DEFMETHOD PRINT-CONDITION ((CONDITION ,name) STREAM)
  147.              ,(if (stringp (first report-function))
  148.                 `(WRITE-STRING ,(first report-function) STREAM)
  149.                 `(FUNCALL (FUNCTION ,@report-function) CONDITION STREAM)
  150.               )
  151.          ) )
  152.         defclass-form
  153. ) ) ) )
  154.  
  155. ;;; 29.4.6. Creating Conditions
  156.  
  157. ; MAKE-CONDITION, CLtL2 p. 901
  158. (defun make-condition (type &rest slot-initializations)
  159.   (unless (subtypep type 'condition)
  160.     (error-of-type 'error
  161.                    #L{
  162.                    DEUTSCH "~S: Typ ~S ist kein Untertyp von ~S."
  163.                    ENGLISH "~S: type ~S is not a subtype of ~S"
  164.                    FRANCAIS "~S : Le type ~S n'est pas un sous-type de ~S."
  165.                    }
  166.       'make-condition type 'condition
  167.   ) )
  168.   (apply #'clos:make-instance type slot-initializations)
  169. )
  170.  
  171. ; canonicalize a condition argument, CLtL2 p. 888
  172. (defun coerce-to-condition (datum arguments
  173.                             caller-name
  174.                             default-type &rest more-initargs)
  175.   (typecase datum
  176.     (condition
  177.       (when arguments
  178.         (error-of-type 'type-error
  179.           :datum arguments :expected-type 'null
  180.           #L{
  181.           DEUTSCH "~S ~S: Überflüssige Argumente ~S"
  182.           ENGLISH "~S ~S: superfluous arguments ~S"
  183.           FRANCAIS "~S ~S : Les arguments ~S sont superflus."
  184.           }
  185.           caller-name datum arguments
  186.       ) )
  187.       datum
  188.     )
  189.     (symbol
  190.       (apply #'make-condition datum arguments)
  191.     )
  192.     ((or string function) ; only this case uses default-type and more-initargs
  193.       (apply #'make-condition default-type
  194.              #-dpANS :format-string #+dpANS :format-control datum
  195.              :format-arguments arguments
  196.              more-initargs
  197.     ) )
  198.     (t
  199.       (error-of-type 'type-error
  200.         :datum datum :expected-type '(or condition symbol string function)
  201.         #L{
  202.         DEUTSCH "~S: Condition-Argument muß ein String, ein Symbol oder eine Condition sein, nicht ~S"
  203.         ENGLISH "~S: the condition argument must be a string, a symbol or a condition, not ~S"
  204.         FRANCAIS "~S : L'argument de condition exceptionnelle doit être de type STRING, SYMBOL ou CONDITION et non ~S"
  205.         }
  206.         caller-name datum
  207. ) ) ) )
  208.  
  209. ;;; 29.5. Predefined Condition Types
  210.  
  211. ; Hierarchy:
  212. ;
  213. ;   condition
  214. ;   |
  215. ;   |-- simple-condition
  216. ;   |
  217. ;   |-- serious-condition
  218. ;   |   |
  219. ;   |   |-- error
  220. ;   |   |   |
  221. ;   |   |   |-- simple-error
  222. ;   |   |   |
  223. ;   |   |   |-- arithmetic-error
  224. ;   |   |   |   |
  225. ;   |   |   |   |-- division-by-zero
  226. ;   |   |   |   |
  227. ;   |   |   |   |-- floating-point-overflow
  228. ;   |   |   |   |
  229. ;   |   |   |   |-- floating-point-underflow
  230. ;   |   |   |
  231. ;   |   |   |-- cell-error
  232. ;   |   |   |   |
  233. ;   |   |   |   |-- unbound-variable
  234. ;   |   |   |   |
  235. ;   |   |   |   |-- undefined-function
  236. ;   |   |   |
  237. ;   |   |   |-- control-error
  238. ;   |   |   |
  239. ;   |   |   |-- file-error
  240. ;   |   |   |
  241. ;   |   |   |-- package-error
  242. ;   |   |   |
  243. ;   |   |   |-- print-not-readable
  244. ;   |   |   |
  245. ;   |   |   |-- program-error
  246. ;   |   |   |
  247. ;   |   |   |-- stream-error
  248. ;   |   |   |   |
  249. ;   |   |   |   |-- end-of-file
  250. ;   |   |   |
  251. ;   |   |   |-- type-error
  252. ;   |   |       |
  253. ;   |   |       |-- simple-type-error
  254. ;   |   |
  255. ;   |   |-- storage-condition
  256. ;   |
  257. ;   |-- warning
  258. ;       |
  259. ;       |-- simple-warning
  260. ;
  261.  
  262. ; conditions that require interactive intervention
  263. (define-condition serious-condition () ())
  264.  
  265.   ; serious conditions that occur deterministically
  266.   (define-condition error (serious-condition) ())
  267.  
  268.     ; statically detectable errors of a program
  269.     (define-condition program-error (error) ())
  270.     ; all the other errors must be detected by the runtime system
  271.  
  272.     ; not statically detectable errors in program control
  273.     (define-condition control-error (error) ())
  274.  
  275.     ; errors that occur while doing arithmetic operations
  276.     (define-condition arithmetic-error (error)
  277.       ((operation :initarg :operation :reader arithmetic-error-operation)
  278.        (operands  :initarg :operands  :reader arithmetic-error-operands)
  279.     ) )
  280.  
  281.       ; trying to evaluate a mathematical function at a singularity
  282.       (define-condition division-by-zero (arithmetic-error) ())
  283.  
  284.       ; trying to get too close to infinity in the floating point domain
  285.       (define-condition floating-point-overflow (arithmetic-error) ())
  286.  
  287.       ; trying to get too close to zero in the floating point domain
  288.       (define-condition floating-point-underflow (arithmetic-error) ())
  289.  
  290.       #+dpANS (define-condition floating-point-inexact (arithmetic-error) ())
  291.  
  292.       #+dpANS (define-condition floating-point-invalid-operation (arithmetic-error) ())
  293.  
  294.     ; trying to access a location which contains #<UNBOUND>
  295.     (define-condition cell-error (error)
  296.       ((name :initarg :name :reader cell-error-name))
  297.     )
  298.  
  299.       ; trying to get the value of an unbound variable
  300.       (define-condition unbound-variable (cell-error) ())
  301.  
  302.       ; trying to get the global function definition of an undefined function
  303.       (define-condition undefined-function (cell-error) ())
  304.  
  305.       #+dpANS (define-condition unbound-slot (cell-error)
  306.                 ((instance :initarg :instance :reader unbound-slot-instance))
  307.               )
  308.  
  309.     ; when some datum does not belong to the expected type
  310.     (define-condition type-error (error)
  311.       ((datum         :initarg :datum         :reader type-error-datum)
  312.        (expected-type :initarg :expected-type :reader type-error-expected-type)
  313.     ) )
  314.  
  315.     ; errors during operation on packages
  316.     (define-condition package-error (error)
  317.       ((package :initarg :package :reader package-error-package))
  318.     )
  319.  
  320.     ; attempted violation of *PRINT-READABLY*
  321.     (define-condition print-not-readable (error)
  322.       ((object :initarg :object :reader print-not-readable-object))
  323.     )
  324.  
  325.     #+dpANS (define-condition parse-error (error) ())
  326.  
  327.     ; errors while doing stream I/O
  328.     (define-condition stream-error (error)
  329.       ((stream :initarg :stream :reader stream-error-stream))
  330.     )
  331.  
  332.       ; unexpected end of stream
  333.       (define-condition end-of-file (stream-error) ())
  334.  
  335.       #+dpANS (define-condition reader-error (parse-error stream-error) ())
  336.  
  337.     ; errors with pathnames, OS level errors with streams
  338.     (define-condition file-error (error)
  339.       ((pathname :initarg :pathname :reader file-error-pathname))
  340.     )
  341.  
  342.   ; "Virtual memory exhausted"
  343.   (define-condition storage-condition (serious-condition) ())
  344.  
  345. ; conditions for which user notification is appropriate
  346. (define-condition warning () ())
  347.  
  348. #+dpANS (define-condition style-warning (warning) ())
  349.  
  350. ;; These shouldn't be separate types but we cannot adjoin slots without
  351. ;; defining subtypes.
  352.  
  353. ; conditions usually created by SIGNAL
  354. (define-condition simple-condition ()
  355.   (#-dpANS (format-string :initarg :format-string :initform nil
  356.                           :reader simple-condition-format-string
  357.            )
  358.    #+dpANS (format-control :initarg :format-control :initform nil
  359.                            :reader simple-condition-format-string
  360.                            :reader simple-condition-format-control
  361.            )
  362.    (format-arguments :initarg :format-arguments :initform nil
  363.                      :reader simple-condition-format-arguments
  364.   ))
  365.   #|
  366.   (:report
  367.     (lambda (condition stream)
  368.       (let ((fstring (simple-condition-format-string condition)))
  369.         (when fstring
  370.           (apply #'format stream fstring (simple-condition-format-arguments condition))
  371.   ) ) ) )
  372.   |#
  373. )
  374. ; We don't use the :report option here. Instead we define a print-condition
  375. ; method which will be executed regardless of the condition type's CPL.
  376. (clos:defmethod print-condition :around ((condition simple-condition) stream)
  377.   (let ((fstring (simple-condition-format-string condition)))
  378.     (if fstring
  379.       (apply #'format stream fstring (simple-condition-format-arguments condition))
  380.       (clos:call-next-method)
  381. ) ) )
  382.  
  383. ; conditions usually created by ERROR or CERROR
  384. (define-condition simple-error (simple-condition error) ())
  385.  
  386. ; conditions usually created by CHECK-TYPE
  387. (define-condition simple-type-error (simple-error type-error) ())
  388.  
  389. ; conditions usually created by WARN
  390. (define-condition simple-warning (simple-condition warning) ())
  391.  
  392. ; All conditions created by the C runtime code are of type simple-condition.
  393. ; Need the following types. Don't use them for discrimination.
  394. (define-condition simple-serious-condition (simple-condition serious-condition) ())
  395. (define-condition simple-program-error (simple-error program-error) ())
  396. (define-condition simple-control-error (simple-error control-error) ())
  397. (define-condition simple-arithmetic-error (simple-error arithmetic-error) ())
  398. (define-condition simple-division-by-zero (simple-error division-by-zero) ())
  399. (define-condition simple-floating-point-overflow (simple-error floating-point-overflow) ())
  400. (define-condition simple-floating-point-underflow (simple-error floating-point-underflow) ())
  401. (define-condition simple-cell-error (simple-error cell-error) ())
  402. (define-condition simple-unbound-variable (simple-error unbound-variable) ())
  403. (define-condition simple-undefined-function (simple-error undefined-function) ())
  404. (define-condition simple-package-error (simple-error package-error) ())
  405. (define-condition simple-print-not-readable (simple-error print-not-readable) ())
  406. (define-condition simple-stream-error (simple-error stream-error) ())
  407. (define-condition simple-end-of-file (simple-error end-of-file) ())
  408. (define-condition simple-file-error (simple-error file-error) ())
  409. (define-condition simple-storage-condition (simple-condition storage-condition) ())
  410.  
  411. ; Bootstrapping
  412. (%defclcs
  413.   ; The order of the types in this vector must be the same as in lispbibl.d.
  414.   '#((condition                . simple-condition)
  415.      (serious-condition        . simple-serious-condition)
  416.      (error                    . simple-error)
  417.      (program-error            . simple-program-error)
  418.      (control-error            . simple-control-error)
  419.      (arithmetic-error         . simple-arithmetic-error)
  420.      (division-by-zero         . simple-division-by-zero)
  421.      (floating-point-overflow  . simple-floating-point-overflow)
  422.      (floating-point-underflow . simple-floating-point-underflow)
  423.      (cell-error               . simple-cell-error)
  424.      (unbound-variable         . simple-unbound-variable)
  425.      (undefined-function       . simple-undefined-function)
  426.      (type-error               . simple-type-error)
  427.      (package-error            . simple-package-error)
  428.      (print-not-readable       . simple-print-not-readable)
  429.      (stream-error             . simple-stream-error)
  430.      (end-of-file              . simple-end-of-file)
  431.      (file-error               . simple-file-error)
  432.      (storage-condition        . simple-storage-condition)
  433.      (warning                  . simple-warning)
  434.     )
  435. )
  436.  
  437.  
  438. ;;; Handling and Signalling - Primitives
  439.  
  440. (defvar *break-on-signals* nil)
  441.  
  442. #|
  443. ; This would be a possible implementation. However, it forces too many
  444. ; variables into closures although in the most frequent case - no condition
  445. ; at all - they won't be needed. Furthermore, it conses too much.
  446.  
  447. ; List of active invocations of HANDLER-BIND.
  448. (defvar *handler-clusters* '())
  449.  
  450. ;; HANDLER-BIND, CLtL2 p. 898
  451. (defmacro handler-bind (clauses &body body)
  452.   `(LET ((*HANDLER-CLUSTERS*
  453.            (CONS
  454.              (LIST ,@(mapcar #'(lambda (clause)
  455.                                  (let ((type (first clause))
  456.                                        (function-form (second clause)))
  457.                                    `(CONS ',type ,function-form)
  458.                                ) )
  459.                              clauses
  460.                      )
  461.              )
  462.              *HANDLER-CLUSTERS*
  463.         )) )
  464.      (PROGN ,@body)
  465.    )
  466. )
  467.  
  468. ;; SIGNAL, CLtL2 p. 888
  469. (defun signal (datum &rest arguments)
  470.   (let ((condition
  471.           (coerce-to-condition datum arguments 'signal
  472.                                'simple-condition ; CLtL2 p. 918 specifies this
  473.        )) )
  474.     (when (typep condition *break-on-signals*)
  475.       ; Enter the debugger prior to signalling the condition
  476.       (restart-case (invoke-debugger condition)
  477.         (continue ())
  478.     ) )
  479.     ; CLtL2 p. 884: "A handler is executed in the dynamic context of the
  480.     ; signaler, except that the set of available condition handlers will
  481.     ; have been rebound to the value that was active at the time the condition
  482.     ; handler was made active."
  483.     (let ((*handler-clusters* *handler-clusters*))
  484.       (loop
  485.         (when (null *handler-clusters*) (return))
  486.         (dolist (handler (pop *handler-clusters*))
  487.           (when (typep condition (car handler))
  488.             (funcall (cdr handler) condition)
  489.             (return)
  490.     ) ) ) )
  491.     nil
  492. ) )
  493.  
  494. |#
  495.  
  496. ;; HANDLER-BIND, CLtL2 p. 898
  497. ; Since we can build handler frames only in compiled code
  498. ; there is SYS::%HANDLER-BIND which is synonymous to HANDLER-BIND except
  499. ; that SYS::%HANDLER-BIND only occurs in compiled code.
  500. (defmacro handler-bind (clauses &body body)
  501.   (let ((typespecs (mapcar #'first clauses))
  502.         (handlers (append (mapcar #'rest clauses) (list body))))
  503.     (let ((handler-vars
  504.             (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) handlers)
  505.          ))
  506.       `(LET ,(mapcar #'list
  507.                handler-vars
  508.                (mapcar #'(lambda (handler) `(FUNCTION (LAMBDA () (PROGN ,@handler))))
  509.                        handlers
  510.              ) )
  511.          (LOCALLY (DECLARE (COMPILE))
  512.            (SYS::%HANDLER-BIND
  513.              ,(mapcar #'(lambda (typespec handler-var)
  514.                           `(,typespec #'(LAMBDA (CONDITION) (FUNCALL (FUNCALL ,handler-var) CONDITION)))
  515.                         )
  516.                       typespecs handler-vars
  517.               )
  518.              (FUNCALL ,(car (last handler-vars)))
  519.        ) ) )
  520. ) ) )
  521.  
  522. ;; SIGNAL, CLtL2 p. 888
  523. ; is in error.d
  524.  
  525.  
  526. ;;; Handling and Signalling - Part 2
  527.  
  528. ;; IGNORE-ERRORS, CLtL2 p. 897
  529. (defmacro ignore-errors (&body body)
  530.   (let ((blockname (gensym)))
  531.     `(BLOCK ,blockname
  532.        (HANDLER-BIND
  533.          ((ERROR #'(LAMBDA (CONDITION) (RETURN-FROM ,blockname (VALUES NIL CONDITION)))))
  534.          ,@body
  535.      ) )
  536. ) )
  537.  
  538. ;; HANDLER-CASE, CLtL2 p. 895
  539. (defmacro handler-case (form &rest clauses)
  540.   ; split off the :NO-ERROR clause and
  541.   ; add a GO tag to the other clauses (type varlist . body)
  542.   (let ((no-error-clause nil) ; the last clause, if it is a :no-error clause
  543.         (extended-clauses '())) ; ((tag type varlist . body) ...)
  544.     (do ()
  545.         ((endp clauses))
  546.       (let ((clause (pop clauses)))
  547.         (block check-clause
  548.           (unless (and (consp clause) (consp (cdr clause)) (listp (second clause)))
  549.             (error-of-type 'program-error
  550.                            #L{
  551.                            DEUTSCH "~S: Illegale Syntax für Klausel: ~S"
  552.                            ENGLISH "~S: illegal syntax of clause ~S"
  553.                            FRANCAIS "~S : syntaxe inadmissible de la phrase ~S"
  554.                            }
  555.               'handler-case clause
  556.           ) )
  557.           (when (eq (first clause) ':no-error)
  558.             (if (null clauses) ; at the end of the clauses?
  559.               (progn (setq no-error-clause clause) (return-from check-clause))
  560.               (warn 
  561.                #L{
  562.                DEUTSCH "~S: ~S-Klausel an falscher Stelle: ~S"
  563.                ENGLISH "~S: misplaced ~S clause: ~S"
  564.                FRANCAIS "~S : phrase ~S mal placée: ~S"
  565.                }
  566.                'handler-case ':no-error clause
  567.           ) ) )
  568.           (let ((varlist (second clause))) ; known as a list
  569.             (unless (null (cdr varlist))
  570.               (error-of-type 'program-error
  571.                              #L{
  572.                              DEUTSCH "~S: Zu viele Variablen ~S in Klausel ~S"
  573.                              ENGLISH "~S: too many variables ~S in clause ~S"
  574.                              FRANCAIS "~S : trop de variables ~S dans la phrase ~S"
  575.                              }
  576.                              'handler-case varlist clause
  577.           ) ) )
  578.           (push (cons (gensym) clause) extended-clauses)
  579.     ) ) )
  580.     (setq extended-clauses (nreverse extended-clauses))
  581.     (let ((blockname (gensym))
  582.           (tempvar (gensym)))
  583.       `(BLOCK ,blockname
  584.          (LET (,tempvar) ; tempvar is IGNORABLE since it is a gensym
  585.            (TAGBODY
  586.              (RETURN-FROM ,blockname
  587.                ,(let ((main-form
  588.                         `(HANDLER-BIND
  589.                            ,(mapcar #'(lambda (xclause)
  590.                                         (let ((tag (first xclause))
  591.                                               (type (first (rest xclause)))
  592.                                               (varlist (second (rest xclause))))
  593.                                           `(,type
  594.                                             #'(LAMBDA (CONDITION)
  595.                                                 ,(if (null varlist)
  596.                                                    `(DECLARE (IGNORE CONDITION))
  597.                                                    `(SETQ ,tempvar CONDITION)
  598.                                                  )
  599.                                                 (GO ,tag)
  600.                                            )  )
  601.                                       ) )
  602.                                     extended-clauses
  603.                             )
  604.                            ,form
  605.                          )
  606.                      ))
  607.                   (if no-error-clause
  608.                     `(MULTIPLE-VALUE-CALL #'(LAMBDA ,@(rest no-error-clause))
  609.                        ,main-form
  610.                      )
  611.                     main-form
  612.                 ) )
  613.              )
  614.              ,@(mapcap #'(lambda (xclause)
  615.                            (let ((tag (first xclause))
  616.                                  (varlist (second (rest xclause)))
  617.                                  (body (cddr (rest xclause)))) ; may contain declarations
  618.                              `(,tag
  619.                                (RETURN-FROM ,blockname
  620.                                  (LET ,(if (null varlist) '() `((,@varlist ,tempvar)))
  621.                                    ,@body
  622.                               )) )
  623.                          ) )
  624.                        extended-clauses
  625.                )
  626.        ) ) )
  627. ) ) )
  628.  
  629.  
  630. ;;; Restarts
  631.  
  632. ;; This stuff is needed only once an exception has already occurred. No need
  633. ;; to optimize the hell out of it.
  634.  
  635. ; The default test function for restarts always returns T. See CLtL2 p. 905,909.
  636. (defun default-restart-test (condition)
  637.   (declare (ignore condition))
  638.   t
  639. )
  640.  
  641. ; The default interactive function for restarts returns the empty argument list.
  642. (defun default-restart-interactive ()
  643.   '()
  644. )
  645.  
  646. ;; The RESTART type, CLtL2 p. 916
  647. ;; Also defines RESTART-NAME, CLtL2 p. 911
  648. (defstruct (restart (:print-function print-restart))
  649.   name             ; its name, or NIL if it is not named
  650.   (test #'default-restart-test) ; function that tests whether this restart
  651.                                 ; applies to a given condition
  652.   (invoke-tag nil) ; tag used to invoke the restart, or nil
  653.   invoke-function  ; function used to invoke the restart, if invoke-tag is nil
  654.   (report nil)     ; function used to print a description of the restart
  655.   (interactive #'default-restart-interactive)
  656.                    ; function used to gather additional data from the user
  657.                    ; before invoking the restart
  658. )
  659. #| ; We could also define it as a CLOS class:
  660. (clos:defclass restart ()
  661.   (name            :initarg :name            :reader restart-name)
  662.   (test            :initarg :test            :reader restart-test
  663.                    :initform #'default-restart-test
  664.   )
  665.   (invoke-tag      :initarg :invoke-tag      :reader restart-invoke-tag
  666.                    :initform nil
  667.   )
  668.   (invoke-function :initarg :invoke-function :reader restart-invoke-function)
  669.   (report          :initarg :report          :reader restart-report
  670.                    :initform nil
  671.   )
  672.   (interactive     :initarg :interactive     :reader restart-interactive
  673.                    :initform #'default-restart-interactive
  674.   )
  675. )
  676. |#
  677.  
  678. ;; Printing restarts
  679. (defun print-restart (restart stream depth)
  680.   (declare (ignore depth))
  681.   (if (or *print-escape* *print-readably*)
  682.     (print-unreadable-object (restart stream :type t :identity t)
  683.       (write (restart-name restart) :stream stream)
  684.     )
  685.     (let ((report-function (restart-report restart)))
  686.       (if report-function
  687.         (funcall report-function stream)
  688.         (prin1 (restart-name restart) stream)
  689. ) ) ) )
  690. #| ; If RESTART were a CLOS class:
  691. (clos:defmethod clos:print-object ((restart restart) stream)
  692.   (if (or *print-escape* *print-readably*)
  693.     (clos:call-next-method)
  694.     (let ((report-function (restart-report restart)))
  695.       (if report-function
  696.         (funcall report-function stream)
  697.         (prin1 (restart-name restart) stream)
  698. ) ) ) )
  699. |#
  700.  
  701. ;; Expands to the equivalent of `(MAKE-RESTART :NAME name ...)
  702. ;; but makes intelligent use of the defaults to reduce code size.
  703. (defun make-restart-form (name test invoke-tag invoke-function report interactive)
  704.   `(MAKE-RESTART
  705.      :NAME ,name
  706.      ,@(if (not (equal test '(FUNCTION DEFAULT-RESTART-TEST)))
  707.          `(:TEST ,test)
  708.        )
  709.      ,@(if (not (equal invoke-tag 'NIL))
  710.          `(:INVOKE-TAG ,invoke-tag)
  711.        )
  712.      :INVOKE-FUNCTION ,invoke-function
  713.      ,@(if (not (equal report 'NIL))
  714.          `(:REPORT ,report)
  715.        )
  716.      ,@(if (not (equal interactive '(FUNCTION DEFAULT-RESTART-INTERACTIVE)))
  717.          `(:INTERACTIVE ,interactive)
  718.        )
  719.    )
  720. )
  721.  
  722. ;; The list of active restarts.
  723. (defvar *active-restarts* nil)
  724.  
  725. ;; A list of pairs of conditions and restarts associated with them. We have to
  726. ;; keep the associations separate because there can be a many-to-many mapping
  727. ;; between restarts and conditions, and this mapping has dynamic extent.
  728. (defvar *condition-restarts* nil)
  729.  
  730. ; Add an association between a condition and a couple of restarts.
  731. (defun add-condition-restarts (condition restarts)
  732.   (dolist (restart restarts)
  733.     (push (cons condition restart) *condition-restarts*)
  734. ) )
  735.  
  736. ;; WITH-CONDITION-RESTARTS, CLtL2 p. 910
  737. (defmacro with-condition-restarts (condition-form restarts-form &body body)
  738.   `(LET ((*CONDITION-RESTARTS* *CONDITION-RESTARTS*))
  739.      (ADD-CONDITION-RESTARTS ,condition-form ,restarts-form)
  740.      (LET () ,@body)
  741.    )
  742. )
  743.  
  744. ;;; 29.4.8. Finding and Manipulating Restarts
  745.  
  746. ; Tests whether a given restart is applicable to a given condition
  747. (defun applicable-restart-p (restart condition)
  748.   (and
  749.     #| ; We choose the dpANS behaviour because it makes the need for the
  750.        ; syntax-dependent implicit restart association in RESTART-CASE
  751.        ; nearly obsolete.
  752.     #-dpANS
  753.     ; A restart is applicable iff it is associated to that condition.
  754.     (dolist (asso *condition-restarts* nil)
  755.       (when (and (eq (car asso) condition) (eq (cdr asso) restart))
  756.         (return t)
  757.     ) )
  758.     #+dpANS
  759.     |#
  760.     ; A restart is applicable if it is associated to that condition
  761.     ; or if it is not associated to any condition.
  762.     (let ((not-at-all t))
  763.       (dolist (asso *condition-restarts* not-at-all)
  764.         (when (eq (cdr asso) restart)
  765.           (if (eq (car asso) condition)
  766.             (return t)
  767.             (setq not-at-all nil)
  768.     ) ) ) )
  769.     ; Call the restart's test function:
  770.     (funcall (restart-test restart) condition)
  771. ) )
  772.  
  773. ;; COMPUTE-RESTARTS, CLtL2 p. 910
  774. (defun compute-restarts (&optional condition)
  775.   (if condition
  776.     ; return only restarts that are applicable to that condition
  777.     (remove-if-not #'(lambda (restart) (applicable-restart-p restart condition))
  778.                    *active-restarts*
  779.     )
  780.     ; return all restarts
  781.     *active-restarts*
  782. ) )
  783.  
  784. ;; FIND-RESTART, CLtL2 p. 911
  785. ; returns a restart or nil
  786. (defun find-restart (restart-identifier &optional condition)
  787.   (cond ((null restart-identifier)
  788.          (error-of-type 'error
  789.                         #L{
  790.                         DEUTSCH "~S: ~S ist als Restart-Name hier nicht zulässig. Verwenden Sie ~S."
  791.                         ENGLISH "~S: ~S is not a valid restart name here. Use ~S instead."
  792.                         FRANCAIS "~S : ~S n'est pas valable comme nom de «restart» ici. Utilisez ~S."
  793.                         }
  794.                         'find-restart restart-identifier 'compute-restarts
  795.         ))
  796.         ((symbolp restart-identifier)
  797.          (dolist (restart *active-restarts*)
  798.            (when (and (eq (restart-name restart) restart-identifier)
  799.                       (or (null condition)
  800.                           (applicable-restart-p restart condition)
  801.                  )    )
  802.              (return restart)
  803.         )) )
  804.         ((typep restart-identifier 'restart)
  805.          (dolist (restart *active-restarts*)
  806.            (when (and (eq restart restart-identifier)
  807.                       (or (null condition)
  808.                           (applicable-restart-p restart condition)
  809.                  )    )
  810.              (return restart)
  811.         )) )
  812.         (t (error-of-type 'type-error
  813.              :datum restart-identifier :expected-type '(or symbol restart)
  814.              #L{
  815.              DEUTSCH "~S: Ungültiger Restart-Name: ~S"
  816.              ENGLISH "~S: invalid restart name ~S"
  817.              FRANCAIS "~S : Nom inadmissible pour un «restart»: ~S"
  818.              }
  819.              'find-restart restart-identifier
  820.         )  )
  821. ) )
  822.  
  823. (defun restart-not-found (restart-identifier)
  824.   (error-of-type 'control-error
  825.                  #L{
  826.                  DEUTSCH "~S: Ein Restart mit Namen ~S ist nicht sichtbar."
  827.                  ENGLISH "~S: No restart named ~S is visible."
  828.                  FRANCAIS "~S : Un «restart» de nom ~S n'est pas visible."
  829.                  }
  830.                  'invoke-restart restart-identifier
  831. ) )
  832.  
  833. (defun %invoke-restart (restart arguments)
  834.   (if (restart-invoke-tag restart)
  835.     (throw (restart-invoke-tag restart) arguments)
  836.     (apply (restart-invoke-function restart) arguments)
  837.     ; This may return normally, the restart need not transfer control.
  838.     ; (See CLtL2 p. 880.)
  839. ) )
  840.  
  841. ;; INVOKE-RESTART, CLtL2 p. 911
  842. (defun invoke-restart (restart-identifier &rest arguments)
  843.   (let ((restart (find-restart restart-identifier)))
  844.     (unless restart (restart-not-found restart-identifier))
  845.     (%invoke-restart restart arguments)
  846. ) )
  847.  
  848. (defun invoke-restart-condition (restart-identifier condition &rest arguments)
  849.   (let ((restart (find-restart restart-identifier condition)))
  850.     (unless restart (restart-not-found restart-identifier))
  851.     (%invoke-restart restart arguments)
  852. ) )
  853.  
  854. (defun invoke-restart-condition-if-exists (restart-identifier condition &rest arguments)
  855.   (let ((restart (find-restart restart-identifier condition)))
  856.     (when restart
  857.       (%invoke-restart restart arguments)
  858. ) ) )
  859.  
  860. ;; INVOKE-RESTART-INTERACTIVELY, CLtL2 p. 911
  861. (defun invoke-restart-interactively (restart-identifier)
  862.   (let ((restart (find-restart restart-identifier)))
  863.     (unless restart (restart-not-found restart-identifier))
  864.     (let ((arguments (funcall (restart-interactive restart))))
  865.       (%invoke-restart restart arguments)
  866. ) ) )
  867.  
  868. ;;; 29.4.7. Establishing Restarts
  869.  
  870. ;; This conses out the wazoo, but there seems to be no good way around it short
  871. ;; of special casing things a zillion ways.  The main problem is that someone
  872. ;; could write:
  873. ;;
  874. ;; (restart-bind ((nil *fun-1*
  875. ;;                     :interactive-function *fun-2*
  876. ;;                     :report-function *fun-3*
  877. ;;                     :test-function *fun-4*
  878. ;;                 )) ...)
  879. ;;
  880. ;; and it is supposed to work.
  881.  
  882. ;; RESTART-BIND, CLtL2 p. 909
  883. (defmacro restart-bind (restart-specs &body body)
  884.   (setq body `(PROGN ,@body))
  885.   (unless (listp restart-specs)
  886.     (error-of-type 'program-error
  887.                    #L{
  888.                    DEUTSCH "~S: Das ist keine Liste: ~S"
  889.                    ENGLISH "~S: not a list: ~S"
  890.                    FRANCAIS "~S : ceci n'est pas une liste: ~S"
  891.                    }
  892.                    'restart-bind restart-specs
  893.   ) )
  894.   (if restart-specs
  895.     `(LET ((*ACTIVE-RESTARTS*
  896.              (LIST*
  897.                ,@(mapcar #'(lambda (spec)
  898.                              (unless (and (listp spec) (consp (cdr spec)) (symbolp (first spec)))
  899.                                (error-of-type 'program-error
  900.                                               #L{
  901.                                               DEUTSCH "~S: Ungültige Restart-Spezifikation: ~S"
  902.                                               ENGLISH "~S: invalid restart specification ~S"
  903.                                               FRANCAIS "~S : spécification inadmissible d'un «restart»: ~S"
  904.                                               }
  905.                                               'restart-bind spec
  906.                              ) )
  907.                              (apply #'(lambda (name function
  908.                                                &key (test-function '(FUNCTION DEFAULT-RESTART-TEST))
  909.                                                     (interactive-function '(FUNCTION DEFAULT-RESTART-INTERACTIVE))
  910.                                                     (report-function 'NIL))
  911.                                         (when (and (null name) (eq report-function 'NIL))
  912.                                           ; CLtL2 p. 906: "It is an error if an unnamed restart is used
  913.                                           ; and no report information is provided."
  914.                                           (error-of-type 'program-error
  915.                                                          #L{
  916.                                                          DEUTSCH "~S: Bei unbenannten Restarts muß ~S angegeben werden: ~S"
  917.                                                          ENGLISH "~S: unnamed restarts require ~S to be specified: ~S"
  918.                                                          FRANCAIS "~S : Il faut spécifier ~S pour des «restarts» anonymes: ~S"
  919.                                                          }
  920.                                                          'restart-bind ':REPORT-FUNCTION spec
  921.                                         ) )
  922.                                         (make-restart-form `',name
  923.                                                            test-function
  924.                                                            'NIL
  925.                                                            function
  926.                                                            report-function
  927.                                                            interactive-function
  928.                                       ) )
  929.                                     spec
  930.                            ) )
  931.                          restart-specs
  932.                  )
  933.                *ACTIVE-RESTARTS*
  934.           )) )
  935.        ,body
  936.      )
  937.     body
  938. ) )
  939.  
  940. ;; RESTART-CASE, CLtL2 p. 903
  941. ;; WITH-RESTARTS
  942. ;; Syntax: (RESTART-CASE form {restart-clause}*)
  943. ;;         (WITH-RESTARTS ({restart-clause}*) {form}*)
  944. ;; restart-clause ::=   (restart-name arglist {keyword value}* {form}*)
  945. ;;                    | (restart-name {keyword value}* arglist {form}*)
  946.  
  947. ;; There are a number of special cases we could optimize for. If we
  948. ;; can determine that we will not have to cons any closures at
  949. ;; runtime, then we could statically allocate the list of restarts.
  950. ;;
  951. ;; Since we have to deal with the wacky way RESTART-CASE interacts with
  952. ;; WITH-CONDITION-RESTARTS, we do not go through RESTART-BIND.
  953.  
  954. (eval-when (compile load eval)
  955.   (defun expand-restart-case (caller restart-clauses form)
  956.     (unless (listp restart-clauses)
  957.       (error-of-type 'program-error
  958.                      #L{
  959.                      DEUTSCH "~S: Das ist keine Liste: ~S"
  960.                      ENGLISH "~S: not a list: ~S"
  961.                      FRANCAIS "~S : ceci n'est pas une liste: ~S"
  962.                      }
  963.                      caller restart-clauses
  964.     ) )
  965.     (let ((xclauses ; list of expanded clauses
  966.                     ; ((tag name test interactive report lambdalist . body) ...)
  967.             (mapcar
  968.               #'(lambda (restart-clause &aux (clause restart-clause))
  969.                   (unless (and (consp clause) (consp (cdr clause)) (symbolp (first clause)))
  970.                     (error-of-type 'program-error
  971.                                    #L{
  972.                                    DEUTSCH "~S: Ungültige Restart-Spezifikation: ~S"
  973.                                    ENGLISH "~S: invalid restart specification ~S"
  974.                                    FRANCAIS "~S : spécification inadmissible d'un «restart»: ~S"
  975.                                    }
  976.                                    caller clause
  977.                   ) )
  978.                   (let ((name (pop clause))
  979.                         (passed-arglist nil)
  980.                         (passed-keywords nil)
  981.                         arglist
  982.                         (keywords '()))
  983.                     (loop
  984.                       (when (endp clause) (return))
  985.                       (cond ((and (not passed-arglist) (listp (first clause)))
  986.                              (setq arglist (pop clause))
  987.                              (setq passed-arglist t)
  988.                              (when keywords (setq passed-keywords t))
  989.                             )
  990.                             ((and (not passed-keywords) (consp (cdr clause)) (keywordp (first clause)))
  991.                              (push (pop clause) keywords)
  992.                              (push (pop clause) keywords)
  993.                             )
  994.                             (t (return))
  995.                     ) )
  996.                     (unless passed-arglist
  997.                       (error-of-type 'program-error
  998.                                      #L{
  999.                                      DEUTSCH "~S: Restart-Spezifikation ohne Lambda-Liste: ~S"
  1000.                                      ENGLISH "~S: missing lambda list in restart specification ~S"
  1001.                                      FRANCAIS "~S : il faut une liste lambda dans la spécification d'un «restart»: ~S"
  1002.                                      }
  1003.                                      caller clause
  1004.                     ) )
  1005.                     (multiple-value-bind (test interactive report)
  1006.                         (apply #'(lambda (&key (test 'DEFAULT-RESTART-TEST)
  1007.                                                (interactive 'DEFAULT-RESTART-INTERACTIVE)
  1008.                                                (report 'DEFAULT-RESTART-REPORT))
  1009.                                    (values test interactive report)
  1010.                                  )
  1011.                                (nreverse keywords)
  1012.                         )
  1013.                       (when (and (null name) (eq report 'DEFAULT-RESTART-REPORT))
  1014.                         ; CLtL2 p. 906: "It is an error if an unnamed restart is used
  1015.                         ; and no report information is provided."
  1016.                         (error-of-type 'program-error
  1017.                                        #L{
  1018.                                        DEUTSCH "~S: Bei unbenannten Restarts muß ~S angegeben werden: ~S"
  1019.                                        ENGLISH "~S: unnamed restarts require ~S to be specified: ~S"
  1020.                                        FRANCAIS "~S : Il faut spécifier ~S pour des «restarts» anonymes: ~S"
  1021.                                        }
  1022.                                        caller ':REPORT restart-clause
  1023.                       ) )
  1024.                       (when (and (consp arglist) (not (member (first arglist) lambda-list-keywords))
  1025.                                  (eq interactive 'DEFAULT-RESTART-INTERACTIVE)
  1026.                             )
  1027.                         ; restart takes required arguments but does not have an
  1028.                         ; interactive function that will prompt for them.
  1029.                         (warn 
  1030.                          #L{
  1031.                          DEUTSCH "~S: Restart kann nicht interaktiv aufgerufen werden, weil ~S fehlt: ~S"
  1032.                          ENGLISH "~S: restart cannot be invoked interactively because it is missing a ~S option: ~S"
  1033.                          FRANCAIS "~S : Ce «restart» ne peut prendre le contrôle en dialogue car il manque un ~S : ~S"
  1034.                          }
  1035.                          caller ':INTERACTIVE restart-clause
  1036.                       ) )
  1037.                       `(,(gensym)
  1038.                         ,name
  1039.                         ,test ,interactive ,report
  1040.                         ,arglist
  1041.                         ,@clause
  1042.                        )
  1043.                 ) ) )
  1044.               restart-clauses
  1045.           ) )
  1046.           (blockname (gensym))
  1047.           (arglistvar (gensym))
  1048.           (associate
  1049.             ;; Yick.  As a pretty lame way of allowing for an
  1050.             ;; association between conditions and restarts,
  1051.             ;; RESTART-CASE has to notice if its body is signalling a
  1052.             ;; condition, and, if so, associate the restarts with the
  1053.             ;; condition.
  1054.             (and (consp form)
  1055.                  (case (first form) ((SIGNAL ERROR CERROR WARN) t) (t nil))
  1056.                  (gensym)
  1057.          )) )
  1058.       `(BLOCK ,blockname
  1059.          (LET (,arglistvar) ; arglistvar is IGNORABLE since it is a gensym
  1060.            (TAGBODY
  1061.              ,(let ((restart-forms
  1062.                       (mapcar #'(lambda (xclause)
  1063.                                   (let ((tag (first xclause))
  1064.                                         (name (second xclause))
  1065.                                         (test (third xclause))
  1066.                                         (interactive (fourth xclause))
  1067.                                         (report (fifth xclause)))
  1068.                                     (make-restart-form `',name
  1069.                                                        `(FUNCTION ,test)
  1070.                                                        'NIL
  1071.                                                        `(FUNCTION
  1072.                                                           (LAMBDA (&REST ARGUMENTS)
  1073.                                                             (SETQ ,arglistvar ARGUMENTS)
  1074.                                                             (GO ,tag)
  1075.                                                         ) )
  1076.                                                        (if (eq report 'DEFAULT-RESTART-REPORT)
  1077.                                                          `NIL
  1078.                                                          `(FUNCTION
  1079.                                                             ,(if (stringp report)
  1080.                                                                `(LAMBDA (STREAM) (WRITE-STRING ,report STREAM))
  1081.                                                                 report
  1082.                                                              )
  1083.                                                           )
  1084.                                                        )
  1085.                                                        `(FUNCTION ,interactive)
  1086.                                      )
  1087.                                 ) )
  1088.                               xclauses
  1089.                     ) )
  1090.                     (form `(RETURN-FROM ,blockname ,form)))
  1091.                 `(LET* ,(if associate
  1092.                           `((,associate (LIST ,@restart-forms))
  1093.                             (*ACTIVE-RESTARTS* (APPEND ,associate *ACTIVE-RESTARTS*))
  1094.                             (*CONDITION-RESTARTS* *CONDITION-RESTARTS*)
  1095.                            )
  1096.                           `((*ACTIVE-RESTARTS* (LIST* ,@restart-forms *ACTIVE-RESTARTS*)))
  1097.                         )
  1098.                    ,(if associate
  1099.                       #| ; This code resignals the condition in a different dynamic context!
  1100.                       `(LET ((CONDITION
  1101.                                (HANDLER-CASE ,form ; evaluate the form
  1102.                                  (CONDITION (C) C) ; catch the condition
  1103.                             )) )
  1104.                          (WITH-CONDITION-RESTARTS CONDITION ,associate ; associate the condition with the restarts
  1105.                            (SIGNAL CONDITION) ; resignal the condition
  1106.                        ) )
  1107.                       |#
  1108.                       #| ; This code invokes the debugger even if it shouldn't!
  1109.                       `(HANDLER-BIND
  1110.                          ((CONDITION ; catch the condition
  1111.                             #'(LAMBDA (CONDITION)
  1112.                                 (WITH-CONDITION-RESTARTS CONDITION ,associate  ; associate the condition with the restarts
  1113.                                   (SIGNAL CONDITION) ; resignal the condition
  1114.                                   (INVOKE-DEBUGGER CONDITION) ; this is weird!
  1115.                          ))   ) )
  1116.                          ,form
  1117.                        )
  1118.                       |#
  1119.                       `(HANDLER-BIND
  1120.                          ((CONDITION ; catch the condition
  1121.                             #'(LAMBDA (CONDITION)
  1122.                                 (ADD-CONDITION-RESTARTS CONDITION ,associate) ; associate the condition with the restarts
  1123.                                 (SIGNAL CONDITION) ; resignal the condition
  1124.                          ))   )
  1125.                          ,form
  1126.                        )
  1127.                       form
  1128.                     )
  1129.                  )
  1130.               )
  1131.              ,@(mapcap #'(lambda (xclause)
  1132.                            (let ((tag (first xclause))
  1133.                                  (lambdabody (cdddr (cddr xclause))))
  1134.                              `(,tag
  1135.                                (RETURN-FROM ,blockname
  1136.                                  (APPLY (FUNCTION (LAMBDA ,@lambdabody)) ,arglistvar)
  1137.                               ))
  1138.                          ) )
  1139.                        xclauses
  1140.                )
  1141.        ) ) )
  1142.   ) )
  1143. )
  1144.  
  1145. (defmacro restart-case (form &rest restart-clauses)
  1146.   (expand-restart-case 'restart-case restart-clauses form)
  1147. )
  1148.  
  1149. (defmacro with-restarts (restart-clauses &body body)
  1150.   (expand-restart-case 'with-restarts restart-clauses `(PROGN ,@body))
  1151. )
  1152.  
  1153. ;; WITH-SIMPLE-RESTART, CLtL2 p. 902
  1154. (defmacro with-simple-restart ((name format-string &rest format-arguments) &body body)
  1155.   (if (or format-arguments (not (constantp format-string)))
  1156.     `(WITH-RESTARTS
  1157.          ((,name
  1158.            :REPORT (LAMBDA (STREAM) (FORMAT STREAM ,format-string ,@format-arguments))
  1159.            () (VALUES NIL T)
  1160.          ))
  1161.        ,@body
  1162.      )
  1163.     ;; Here's an example of how we can easily optimize things. There is no
  1164.     ;; need to refer to anything in the lexical environment, so we can avoid
  1165.     ;; consing a restart at run time.
  1166.     (let ((blockname (gensym))
  1167.           (tag (gensym)))
  1168.       `(BLOCK ,blockname
  1169.          (CATCH ',tag
  1170.            (LET ((*ACTIVE-RESTARTS*
  1171.                    (CONS
  1172.                      (LOAD-TIME-VALUE
  1173.                        (MAKE-RESTART :NAME ',name
  1174.                                      :INVOKE-TAG ',tag
  1175.                                      :REPORT #'(LAMBDA (STREAM) (FORMAT STREAM ,format-string))
  1176.                      ) )
  1177.                      *ACTIVE-RESTARTS*
  1178.                 )) )
  1179.              (RETURN-FROM ,blockname (PROGN ,@body))
  1180.            )
  1181.            (VALUES NIL T)
  1182.        ) )
  1183. ) ) )
  1184.  
  1185.  
  1186. ;;; 29.4.10. Restart Functions
  1187.  
  1188. ;; These functions are customary way to pass control from a handler to a
  1189. ;; restart. They just invoke the restart of the same name.
  1190.  
  1191. ;; ABORT, CLtL2 p. 913
  1192. (defun abort (&optional condition)
  1193.   (invoke-restart-condition 'abort condition)
  1194. )
  1195.  
  1196. ;; CONTINUE, CLtL2 p. 913
  1197. (defun continue (&optional condition)
  1198.   (invoke-restart-condition-if-exists 'continue condition)
  1199. )
  1200.  
  1201. ;; MUFFLE-WARNING, CLtL2 p. 913
  1202. (defun muffle-warning (&optional condition)
  1203.   (invoke-restart-condition 'muffle-warning condition)
  1204. )
  1205.  
  1206. ;; STORE-VALUE, CLtL2 p. 913
  1207. (defun store-value (value &optional condition)
  1208.   (invoke-restart-condition-if-exists 'store-value condition value)
  1209. )
  1210.  
  1211. ;; USE-VALUE, CLtL2 p. 914
  1212. (defun use-value (value &optional condition)
  1213.   (invoke-restart-condition-if-exists 'use-value condition value)
  1214. )
  1215.  
  1216.  
  1217. ;;; 29.4.2. Assertions
  1218.  
  1219. ;; These macros supersede the corresponding ones from macros2.lsp.
  1220.  
  1221. (defun report-new-value (stream)
  1222.   (write-string 
  1223.    #L{
  1224.    DEUTSCH "Sie dürfen einen neuen Wert eingeben."
  1225.    ENGLISH "You may input a new value."
  1226.    FRANCAIS "Vous avez l'occasion d'entrer une nouvelle valeur."
  1227.    }
  1228.    stream
  1229. ) )
  1230.  
  1231. (defun prompt-for-new-value (place)
  1232.   (format *query-io*
  1233.           #L{
  1234.           DEUTSCH "~%Neues ~S: "
  1235.           ENGLISH "~%New ~S: "
  1236.           FRANCAIS "~%Nouveau ~S : "
  1237.           }
  1238.           place
  1239.   )
  1240.   (read *query-io*)
  1241. )
  1242.  
  1243. ;; CHECK-TYPE, CLtL2 p. 889
  1244. (defmacro check-type (place typespec &optional (string nil))
  1245.   (let ((tag1 (gensym))
  1246.         (tag2 (gensym))
  1247.         (var (gensym)))
  1248.     `(TAGBODY
  1249.        ,tag1
  1250.        (LET ((,var ,place))
  1251.          (WHEN (TYPEP ,var ',typespec) (GO ,tag2))
  1252.          (RESTART-CASE
  1253.            (ERROR-OF-TYPE 'TYPE-ERROR
  1254.              :DATUM ,var :EXPECTED-TYPE ',typespec
  1255.              #L{
  1256.              DEUTSCH "~A~%Der Wert ist: ~S"
  1257.              ENGLISH "~A~%The value is: ~S"
  1258.              FRANCAIS "~A~%La valeur est : ~S"
  1259.              }
  1260.              ,(format nil 
  1261.                      #L{
  1262.                      DEUTSCH "Der Wert von ~S sollte ~:[vom Typ ~S~;~:*~A~] sein."
  1263.                      ENGLISH "The value of ~S should be ~:[of type ~S~;~:*~A~]."
  1264.                      FRANCAIS "La valeur de ~S devrait être ~:[de type ~S~;~:*~A~]."
  1265.                      }
  1266.                      place string typespec
  1267.              )
  1268.              ,var
  1269.            )
  1270.            ; only one restart, will "continue" invoke it?
  1271.            (STORE-VALUE
  1272.              :REPORT REPORT-NEW-VALUE
  1273.              :INTERACTIVE (LAMBDA () (LIST (PROMPT-FOR-NEW-VALUE ',place)))
  1274.              (NEW-VALUE) (SETF ,place NEW-VALUE)
  1275.            )
  1276.        ) )
  1277.        (GO ,tag1)
  1278.        ,tag2
  1279.      )
  1280. ) )
  1281.  
  1282. (defun report-no-new-value (stream)
  1283.   (write-string 
  1284.    #L{
  1285.    DEUTSCH "Neuer Anlauf"
  1286.    ENGLISH "Retry"
  1287.    FRANCAIS "Reéssayer"
  1288.    }
  1289.    stream
  1290. ) )
  1291.  
  1292. (defun report-new-values (stream)
  1293.   (write-string 
  1294.    #L{
  1295.    DEUTSCH "Sie dürfen neue Werte eingeben."
  1296.    ENGLISH "You may input new values."
  1297.    FRANCAIS "Vous pouvez entrer de nouvelles valeurs."
  1298.    }
  1299.    stream
  1300. ) )
  1301.  
  1302. ;; ASSERT, CLtL2 p. 891
  1303. (defmacro assert (test-form &optional (place-list nil) (datum nil) &rest args)
  1304.   (let ((tag1 (gensym))
  1305.         (tag2 (gensym)))
  1306.     `(TAGBODY
  1307.        ,tag1
  1308.        (WHEN ,test-form (GO ,tag2))
  1309.        (RESTART-CASE
  1310.          (PROGN ; no need for explicit association, see applicable-restart-p
  1311.            (ERROR ; of-type ??
  1312.              ,@(if datum
  1313.                  `(,datum ,@args) ; use coerce-to-condition??
  1314.                  `("~A"
  1315.                    ,(format nil
  1316.                             #L{
  1317.                             DEUTSCH "Der Wert von ~S darf nicht NIL sein."
  1318.                             ENGLISH "~S must evaluate to a non-NIL value."
  1319.                             FRANCAIS "La valeur de ~S ne peut pas être NIL."
  1320.                             }
  1321.                             test-form
  1322.                   ))
  1323.                )
  1324.          ) )
  1325.          ; only one restart: CONTINUE
  1326.          (CONTINUE
  1327.            :REPORT ,(case (length place-list)
  1328.                       (0 'REPORT-NO-NEW-VALUE)
  1329.                       (1 'REPORT-NEW-VALUE)
  1330.                       (t 'REPORT-NEW-VALUES)
  1331.                     )
  1332.            :INTERACTIVE
  1333.              (LAMBDA ()
  1334.                (LIST
  1335.                  ,@(mapcar #'(lambda (place) `(PROMPT-FOR-NEW-VALUE ',place))
  1336.                            place-list
  1337.                    )
  1338.              ) )
  1339.            ,@(let ((new-value-vars
  1340.                      (mapcar #'(lambda (place) (declare (ignore place)) (gensym))
  1341.                              place-list
  1342.                   )) )
  1343.                `(,new-value-vars
  1344.                  ,@(mapcar #'(lambda (place var) `(SETF ,place ,var))
  1345.                            place-list new-value-vars
  1346.                 )  )
  1347.              )
  1348.        ) )
  1349.        (GO ,tag1)
  1350.        ,tag2
  1351.      )
  1352. ) )
  1353.  
  1354. ;;; 29.4.3. Exhaustive Case Analysis
  1355.  
  1356. ;; These macros supersede the corresponding ones from macros2.lsp.
  1357.  
  1358. (flet ((typecase-errorstring (keyform keyclauselist)
  1359.          (let ((typelist (mapcar #'first keyclauselist)))
  1360.            (format nil
  1361.                    #L{
  1362.                    DEUTSCH "Der Wert von ~S muß einem der Typen ~{~S~^, ~} angehören."
  1363.                    ENGLISH "The value of ~S must be of one of the types ~{~S~^, ~}" 
  1364.                    FRANCAIS "La valeur de ~S doit appartenir à l'un des types ~{~S~^, ~}."
  1365.                    }
  1366.                    keyform typelist
  1367.            )
  1368.        ) )
  1369.        (typecase-expected-type (keyclauselist)
  1370.          `(OR ,@(mapcar #'first keyclauselist))
  1371.        )
  1372.        (case-errorstring (keyform keyclauselist)
  1373.          (let ((caselist
  1374.                  (mapcap #'(lambda (keyclause)
  1375.                              (setq keyclause (car keyclause))
  1376.                              (if (listp keyclause) keyclause (list keyclause))
  1377.                            )
  1378.                          keyclauselist
  1379.               )) )
  1380.            (format nil
  1381.                    #L{
  1382.                    DEUTSCH "Der Wert von ~S muß einer der folgenden sein: ~{~S~^, ~}"
  1383.                    ENGLISH "The value of ~S must be one of ~{~S~^, ~}" 
  1384.                    FRANCAIS "La valeur de ~S doit être l'une des suivantes : ~{~S~^, ~}" 
  1385.                    }
  1386.                    keyform caselist
  1387.             )
  1388.        ) )
  1389.        (case-expected-type (keyclauselist)
  1390.          `(MEMBER ,@(mapcap #'(lambda (keyclause)
  1391.                                 (setq keyclause (car keyclause))
  1392.                                 (if (listp keyclause) keyclause (list keyclause))
  1393.                               )
  1394.                             keyclauselist
  1395.           )         )
  1396.        )
  1397.        (simply-error (casename form clauselist errorstring expected-type)
  1398.          (let ((var (gensym)))
  1399.            `(LET ((,var ,form))
  1400.               (,casename ,var
  1401.                 ,@clauselist ; if a clause contains an OTHERWISE or T key,
  1402.                              ; we could treat it specially or warn about it.
  1403.                 (OTHERWISE
  1404.                   (ERROR-OF-TYPE 'TYPE-ERROR
  1405.                     :DATUM ,var :EXPECTED-TYPE ',expected-type
  1406.                     #L{
  1407.                     DEUTSCH "~A~%Der Wert ist: ~S"
  1408.                     ENGLISH "~A~%The value is: ~S"
  1409.                     FRANCAIS "~A~%La valeur est : ~S"
  1410.                     }
  1411.                     ,errorstring ,var
  1412.             ) ) ) )
  1413.        ) )
  1414.        (retry-loop (casename place clauselist errorstring)
  1415.          (let ((g (gensym))
  1416.                (h (gensym)))
  1417.            `(BLOCK ,g
  1418.               (TAGBODY
  1419.                 ,h
  1420.                 (RETURN-FROM ,g
  1421.                   (,casename ,place
  1422.                     ,@clauselist ; if a clause contains an OTHERWISE or T key,
  1423.                                  ; we could treat it specially or warn about it.
  1424.                     (OTHERWISE
  1425.                       (RESTART-CASE
  1426.                         (PROGN ; no need for explicit association, see applicable-restart-p
  1427.                           (ERROR ; of-type ??
  1428.                            #L{
  1429.                            DEUTSCH "~A~%Der Wert ist: ~S"
  1430.                            ENGLISH "~A~%The value is: ~S"
  1431.                            FRANCAIS "~A~%La valeur est : ~S"
  1432.                            }
  1433.                            ,errorstring
  1434.                            ,place
  1435.                         ) )
  1436.                         ; only one restart, will "continue" invoke it?
  1437.                         (STORE-VALUE
  1438.                           :REPORT REPORT-NEW-VALUE
  1439.                           :INTERACTIVE (LAMBDA () (LIST (PROMPT-FOR-NEW-VALUE ',place)))
  1440.                           (NEW-VALUE) (SETF ,place NEW-VALUE)
  1441.                       ) )
  1442.                       (GO ,h)
  1443.             ) ) ) ) )
  1444.       )) )
  1445.   (defmacro etypecase (keyform &rest keyclauselist)
  1446.     (simply-error 'TYPECASE keyform keyclauselist
  1447.                   (typecase-errorstring keyform keyclauselist)
  1448.                   (typecase-expected-type keyclauselist)
  1449.   ) )
  1450.   (defmacro ctypecase (keyplace &rest keyclauselist)
  1451.     (retry-loop 'TYPECASE keyplace keyclauselist
  1452.                 (typecase-errorstring keyplace keyclauselist)
  1453.   ) )
  1454.   (defmacro ecase (keyform &rest keyclauselist)
  1455.     (simply-error 'CASE keyform keyclauselist
  1456.                   (case-errorstring keyform keyclauselist)
  1457.                   (case-expected-type keyclauselist)
  1458.   ) )
  1459.   (defmacro ccase (keyform &rest keyclauselist)
  1460.     (retry-loop 'CASE keyform keyclauselist
  1461.                 (case-errorstring keyform keyclauselist)
  1462.   ) )
  1463. )
  1464.  
  1465. ;;; 29.4.11. Debugging Utilities
  1466.  
  1467. (defvar *debugger-hook* nil)
  1468.  
  1469. ;; INVOKE-DEBUGGER, CLtL2 p. 915
  1470. ; is in error.d
  1471.  
  1472. ;; BREAK, CLtL2 p. 914
  1473. ; (BREAK [format-string {arg}*])
  1474. ; It would be unfair to bypass the *debugger-hook* test in INVOKE-DEBUGGER.
  1475. ; So we call INVOKE-DEBUGGER and therefore need a condition.
  1476. (defun break (&optional (format-string "Break") &rest args)
  1477.   (let ((condition
  1478.           (make-condition 'simple-condition
  1479.                           :format-string format-string
  1480.                           :format-arguments args
  1481.        )) )
  1482.     (with-restarts
  1483.         ((CONTINUE
  1484.           :report (lambda (stream)
  1485.                     (format stream 
  1486.                             #L{
  1487.                             DEUTSCH "~S-Schleife beenden."
  1488.                             ENGLISH "Return from ~S loop"
  1489.                             FRANCAIS "Quitter le cycle de ~S."
  1490.                             }
  1491.                             'break
  1492.                   ) )
  1493.           ()
  1494.         ))
  1495.       (with-condition-restarts condition (list (find-restart 'CONTINUE))
  1496.         (invoke-debugger condition)
  1497.   ) ) )
  1498.   nil
  1499. )
  1500.  
  1501. ;;; 29.4.1. Signaling Conditions
  1502.  
  1503. ;; ERROR, CLtL2 p. 886
  1504. #| ; is in error.d
  1505. (defun error (errorstring &rest args)
  1506.   (if (or *error-handler* (not *use-clcs*))
  1507.     (progn
  1508.       (if *error-handler*
  1509.         (apply *error-handler* nil errorstring args)
  1510.         (progn
  1511.           (terpri *error-output*)
  1512.           (write-string "*** - " *error-output*)
  1513.           (apply #'format *error-output* errorstring args)
  1514.       ) )
  1515.       (funcall *break-driver* nil)
  1516.     )
  1517.     (let ((condition (coerce-to-condition errorstring args 'error 'simple-error)))
  1518.       (signal condition)
  1519.       (invoke-debugger condition)
  1520.     )
  1521. ) )
  1522. |#
  1523.  
  1524. ;; CERROR, CLtL2 p. 887
  1525. (defun cerror (continue-format-string error-format-string &rest args)
  1526.   (if *error-handler*
  1527.     (apply *error-handler*
  1528.            (or continue-format-string t) error-format-string args
  1529.     )
  1530.     (if (not *use-clcs*)
  1531.       (progn
  1532.         (terpri *error-output*)
  1533.         (write-string "** - Continuable Error" *error-output*)
  1534.         (terpri *error-output*)
  1535.         (apply #'format *error-output* error-format-string args)
  1536.         (terpri *debug-io*)
  1537.         (if (interactive-stream-p *debug-io*)
  1538.           (progn
  1539.             (write-string 
  1540.                      #L{
  1541.                      DEUTSCH "Wenn Sie (mit Continue) fortfahren: "
  1542.                      ENGLISH "If you continue (by typing 'continue'): "
  1543.                      FRANCAIS "Si vous continuez (en tapant 'continue'): "
  1544.                      }
  1545.                      *debug-io*
  1546.                     )
  1547.             (apply #'format *debug-io* continue-format-string args)
  1548.             (funcall *break-driver* t)
  1549.           )
  1550.           (apply #'format *debug-io* continue-format-string args)
  1551.       ) )
  1552.       (let ((condition (coerce-to-condition error-format-string args 'cerror 'simple-error)))
  1553.         (with-restarts
  1554.             ((CONTINUE
  1555.               :report (lambda (stream)
  1556.                         (apply #'format stream continue-format-string args)
  1557.                       )
  1558.               ()
  1559.             ))
  1560.           (with-condition-restarts condition (list (find-restart 'CONTINUE))
  1561.             (signal condition)
  1562.             (invoke-debugger condition)
  1563.       ) ) )
  1564.   ) )
  1565.   nil
  1566. )
  1567.  
  1568. ;;; 29.4.9. Warnings
  1569.  
  1570. ;; WARN, CLtL2 p. 912
  1571. ; (WARN format-string {arg}*)
  1572. (defun warn (format-string &rest args)
  1573.   (if (not *use-clcs*)
  1574.     (progn
  1575.       (terpri *error-output*)
  1576.       (write-string 
  1577.        #L{
  1578.        DEUTSCH "WARNUNG:"
  1579.        ENGLISH "WARNING:"
  1580.        FRANCAIS "AVERTISSEMENT :"
  1581.        }
  1582.        *error-output*
  1583.       )
  1584.       (terpri *error-output*)
  1585.       (apply #'format *error-output* format-string args)
  1586.       (when *break-on-warnings* (funcall *break-driver* t))
  1587.     )
  1588.     (block warn
  1589.       (let ((condition (coerce-to-condition format-string args 'warn 'simple-warning)))
  1590.         (unless (typep condition 'warning)
  1591.           (error-of-type 'type-error
  1592.             :datum condition :expected-type 'warning
  1593.             #L{
  1594.             DEUTSCH "~S: Das ist ernster als eine Warnung: ~A"
  1595.             ENGLISH "~S: This is more serious than a warning: ~A"
  1596.             FRANCAIS "~S : C'est plus sérieux qu'un avertissement: ~A"
  1597.             }
  1598.             'warn condition
  1599.         ) )
  1600.         (with-restarts
  1601.             ((MUFFLE-WARNING
  1602.                () (return-from warn)
  1603.             ))
  1604.           (with-condition-restarts condition (list (find-restart 'MUFFLE-WARNING))
  1605.             (signal condition)
  1606.         ) )
  1607.         (terpri *error-output*)
  1608.         (write-string 
  1609.          #L{
  1610.          DEUTSCH "WARNUNG:"
  1611.          ENGLISH "WARNING:"
  1612.          FRANCAIS "AVERTISSEMENT :"
  1613.          }
  1614.          *error-output*
  1615.         )
  1616.         (terpri *error-output*)
  1617.         (print-condition condition *error-output*)
  1618.         (when *break-on-warnings*
  1619.           (with-restarts
  1620.               ((CONTINUE
  1621.                 :report (lambda (stream)
  1622.                           (format stream 
  1623.                                   #L{
  1624.                                   DEUTSCH "~S-Schleife beenden."
  1625.                                   ENGLISH "Return from ~S loop"
  1626.                                   FRANCAIS "Quitter le cycle de ~S."
  1627.                                   }
  1628.                                   'break
  1629.                         ) )
  1630.                 () (return-from warn)
  1631.               ))
  1632.             (with-condition-restarts condition (list (find-restart 'CONTINUE))
  1633.               ; We don't call  (invoke-debugger condition)  because that
  1634.               ; would tell the user about a "Continuable error". Actually,
  1635.               ; it is only a warning!
  1636.               (funcall *break-driver* nil condition nil)
  1637.         ) ) )
  1638.     ) )
  1639.   )
  1640.   nil
  1641. )
  1642.  
  1643.  
  1644. ;; Bootstrapping done. Activate the Condition System.
  1645. (setq *use-clcs* t)
  1646.  
  1647.  
  1648. #|
  1649. Todo:
  1650. 29.3.6 29.3.7 29.3.8 29.3.9 29.3.10
  1651.       29.3.11 29.3.12 29.3.13 29.3.14 29.3.15 29.3.16 29.3.17 29.3.18
  1652. 29.4. 29.4.9 29.4.11
  1653. 29.5.
  1654. |#
  1655.  
  1656.  
  1657. ;; Extensions. They assume *USE-CLCS* is T.
  1658.  
  1659. ; (MUFFLE-CERRORS {form}*) executes the forms, but when a continuable
  1660. ; error occurs, the CONTINUE restart is silently invoked.
  1661. (defmacro muffle-cerrors (&body body)
  1662.   `(HANDLER-BIND ((ERROR #'(LAMBDA (CONDITION) (CONTINUE CONDITION))))
  1663.      ,@body
  1664.    )
  1665. )
  1666. #| ; This works as well, but looks more like a hack.
  1667. (defmacro muffle-cerrors (&body body)
  1668.   (let ((old-debugger-hook (gensym)))
  1669.     `(LET* ((,old-debugger-hook *DEBUGGER-HOOK*) 
  1670.             (*DEBUGGER-HOOK*
  1671.               #'(LAMBDA (CONDITION DEBUGGER-HOOK)
  1672.                   (CONTINUE CONDITION)
  1673.                   (WHEN ,old-debugger-hook
  1674.                     (FUNCALL ,old-debugger-hook CONDITION ,old-debugger-hook)
  1675.                 ) )
  1676.            ))
  1677.        (PROGN ,@body)
  1678.      )
  1679. ) )
  1680. |#
  1681.  
  1682. ; (APPEASE-CERRORS {form}*) executes the forms, but turns continuable errors
  1683. ; into warnings. A continuable error is signalled again as a warning, then
  1684. ; its CONTINUE restart is invoked.
  1685. (defmacro appease-cerrors (&body body)
  1686.   `(HANDLER-BIND ((ERROR #'(LAMBDA (CONDITION) (APPEASE-CERROR CONDITION))))
  1687.      ,@body
  1688.    )
  1689. )
  1690. (defun appease-cerror (condition)
  1691.   (let ((restart (find-restart 'CONTINUE condition)))
  1692.     (when restart
  1693.       (warn "~A" (with-output-to-string (stream)
  1694.                    (print-condition condition stream)
  1695.                    (let ((report-function (restart-report restart)))
  1696.                      (when report-function
  1697.                        (terpri stream)
  1698.                        (funcall report-function stream)
  1699.       )          ) ) )
  1700.       (invoke-restart restart)
  1701. ) ) )
  1702.  
  1703. ; (EXIT-ON-ERROR {form}*) executes the forms, but exits Lisp if a
  1704. ; non-continuable error occurs.
  1705. (defmacro exit-on-error (&body body)
  1706.   `(HANDLER-BIND ((ERROR #'(LAMBDA (CONDITION) (EXITONERROR CONDITION))))
  1707.      ,@body
  1708.    )
  1709. )
  1710. (defun exitonerror (condition)
  1711.   (unless (find-restart 'CONTINUE condition)
  1712.     (terpri *error-output*)
  1713.     (write-string "*** - " *error-output*)
  1714.     (print-condition condition *error-output*)
  1715.     (exit t) ; exit Lisp with error
  1716. ) )
  1717.  
  1718. ; (SYSTEM::BATCHMODE-ERRORS {form}*) executes the forms, but handles errors
  1719. ; just as a batch program should do: continuable errors are signalled as
  1720. ; warnings, non-continuable errors cause Lisp to exit.
  1721. (defmacro batchmode-errors (&body body)
  1722.   `(EXIT-ON-ERROR (APPEASE-CERRORS ,@body))
  1723. )
  1724.  
  1725.