src/lsp/conditns.lsp

   1 ;;;;
   2 ;;;; Common Lisp Condition System for XLISP-STAT 2.0
   3 ;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney
   4 ;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz
   5 ;;;; You may give out copies of this software; for conditions see the file
   6 ;;;; COPYING included with this distribution.
   7 ;;;;
   8
   9
  10 ;; The condition system is used if the variable xlisp::*condition-hook* is
  11 ;; not nil. The internal functions xlerror and xlcerror, as well as the
  12 ;; Lisp-callable C functions xerror, xcerror, xsignal, xwarn, xbreak and
  13 ;; xdebug, call the hook with the function symbol, the frame index and the
  14 ;; current environment as arguments. The environment can be used by evalhook
  15 ;; for evaluating things in the environment that was active when the
  16 ;; condition was signaled.
  17 ;;
  18 ;; If an image containing the condition system is saved, then the function
  19 ;; xlisp::use-conditions needs t be called on startup to enable the
  20 ;; condition system.
  21
  22 ;; To do:
  23 ;; **** rethink handling of internal xlabort's
  24 ;; **** make full version of assert, etypecase, ctypecase, ecase, ccase
  25 ;; **** make remaining standard condition types
  26
  27 ;; **** collect debugger features
  28 ;; **** different debugging tools -- get-value, set-value as alt to evalhook?
  29 ;; **** move around in stack frames?
  30
  31
  32 (in-package "XLISP")
  33
  34 (require "common")
  35
  36
  37 ;;;;
  38 ;;;; Exported Symbols
  39 ;;;;
  40
  41 ;; Signaling Conditions
  42 (export '(error cerror signal *break-on-signals*))
  43
  44 ;; Assertions
  45 (export '(check-type assert))
  46
  47 ;; Exhaustive Case Analysis
  48 (export '(etypecase ctypecase ecase ccase))
  49
  50 ;; Handling Conditions
  51 (export '(handler-case ignore-errors handler-bind))
  52
  53 ;; Defining and Creating Conditions
  54 (export '(define-condition make-condition))
  55
  56 ;; Establishing Restarts
  57 (export '(with-simple-restart restart-case restart-bind))
  58
  59 ;; Finding and manipulating Restarts
  60 (export '(compute-restarts restart-name find-restart invoke-restart
  61           invoke-restart-interactively))
  62
  63 ;; Warnings
  64 (export 'warn)
  65
  66 ;; Restart Functions
  67 (export '(abort continue muffle-warning store-value use-value))
  68
  69 ;; Debugging Utilities
  70 (export '(break invoke-debugger *debugger-hook*))
  71
  72 ;; Predefined Condition Types
  73 (export '(condition simple-condition serious-condition
  74           error simple-error arithmetic-error division-by-zero
  75           cell-error unbound-variable undefined-function
  76           control-error file-error package-error program-error
  77           stream-error end-of-file type-error simple-type-error
  78           storage-condition warning simple-warning
  79
  80           simple-condition-format-string simple-condition-format-arguments
  81           type-error-datum type-error-expected-type package-error-package
  82           stream-error-stream file-error-pathname cell-error-name
  83           arithmetic-error-operation arithmetic-error-operands))
  84
  85 ;; Restart Data Type
  86 (export 'restart)
  87
  88
  89 ;;;;
  90 ;;;; Public Variables
  91 ;;;;
  92
  93 (defvar *break-on-signals* nil)
  94 (defvar *debugger-hook* nil)
  95
  96
  97 ;;;;
  98 ;;;; Internal Variables
  99 ;;;;
 100
 101
 102 ;; Unique Markers
 103 (defvar *eof-mark* (gensym "EOF"))
 104 (defvar *not-found* (gensym "NOT-FOUND"))
 105
 106 ;; Handler Variables
 107 (defvar *default-handler* nil)
 108 (defvar *active-handlers* nil)
 109
 110 ;; Restart Variables
 111 (defvar *default-restart* nil)
 112 (defvar *active-restarts* nil)
 113 (defvar *continue-restarts* nil)
 114 (defvar *condition-restarts* nil)
 115
 116 ;; Debugger Variables
 117 (defvar *debug-level* 0)
 118 (defvar *debug-env* nil)
 119 (defvar *debug-frame* nil)
 120 (defvar *debug-print-length* nil)
 121 (defvar *debug-print-level* nil)
 122
 123
 124 ;;;;
 125 ;;;; Initialization Function
 126 ;;;; (Must be called on each system startup, e. g. as a startup action)
 127 ;;;;
 128
 129 (defun use-conditions (&optional (reset nil))
 130   (setf *condition-hook* 'condition-hook)
 131   (setf *active-restarts* (list (list nil *default-restart*)))
 132   (setf *continue-restarts* *active-restarts*)
 133   (setf *active-handlers*
 134         (if *default-handler* (list (list nil t *default-handler*))))
 135   (if reset (top-level)))
 136
 137 (defun unuse-conditions ()
 138   (setf *condition-hook* nil)
 139   (top-level))
 140
 141
 142 ;;;;
 143 ;;;; Internal Restart Representation
 144 ;;;;
 145
 146 (defstruct (restart (:print-function print-restart))
 147   name
 148   function
 149   (test-function #'(lambda (c) (declare (ignore c)) t))
 150   interactive-function
 151   report-function)
 152
 153 (defun print-restart (restart stream depth)
 154   (declare (ignore depth))
 155   (if *print-escape*
 156       (format stream "#<Restart ~a: ~d>"
 157               (restart-name restart)
 158               (address-of restart))
 159     (let ((report (restart-report-function restart)))
 160       (if report
 161           (funcall report stream)
 162         (let ((name (restart-name restart)))
 163           (if name
 164               (format stream "~a." name)
 165             (error "can't print restart ~s without escapes"
 166                    restart)))))))
 167
 168 (setf *default-restart*
 169       (make-restart :name 'abort
 170                     :function
 171                       #'(lambda (&rest args)
 172                           (declare (ignore args))
 173                           (top-level nil))
 174                     :test-function #'(lambda (c) (declare (ignore c)) t)
 175                     :report-function
 176                       #'(lambda (s)
 177                           (format s "Return to Lisp Toplevel."))))
 178
 179
 180 ;;;;
 181 ;;;; Helper Functions for RESTART-CASE and RESTART-BIND
 182 ;;;;
 183
 184 (defun push-restarts (c reslist)
 185   (dolist (r (reverse reslist))
 186     (push (list c r) *active-restarts*)))
 187
 188 (defun expand-restart-binding-form (x)
 189   (let ((name (first x))
 190         (function (second x))
 191         (options (rest (rest x))))
 192     (unless function (error "restart form missing function - ~s" x))
 193     (when (and (null name) (not (getf options :report-function)))
 194           (error "anonymous restart needs a report function - ~s"x))
 195     `(make-restart :name ',name :function ,function ,@options)))
 196
 197 (defun make-restart-case-parts (tagsym argsym cases)
 198   (let ((syms (mapcar #'(lambda (x) (gensym "GO")) cases))
 199         (head nil)
 200         (tail nil))
 201     (mapc #'(lambda (c s)
 202               (push `(,(first c)
 203                       #'(lambda (&rest temp)
 204                           (setq ,argsym temp)
 205                           (go ,s))
 206                       ,@(transform-restart-case-options c))
 207                     head)
 208               (push s tail)
 209               (push `(return-from ,tagsym
 210                                   (apply #'(lambda ,(second c)
 211                                              ,@(restart-case-case-body c))
 212                                          ,argsym))
 213                     tail))
 214           cases
 215           syms)
 216     (cons (nreverse head) (nreverse tail))))
 217
 218 (defun transform-restart-case-options (c)
 219   (let ((opts nil))
 220     (loop
 221      (setf c (rest (rest c)))
 222      (case (first c)
 223        (:report
 224         (push :report-function opts)
 225         (push (if (stringp (second c))
 226                   `(function (lambda (s) (format s "~a" ,(second c))))
 227                   `(function ,(second c)))
 228               opts))
 229        (:test
 230         (push :test-function opts)
 231         (push `(function ,(second c)) opts))
 232        (:interactive
 233         (push :interactive-function opts)
 234         (push `(function ,(second c)) opts))
 235        (t (return (nreverse opts)))))))
 236
 237 (defun restart-case-case-body (c)
 238   (loop
 239    (setf c (rest (rest c)))
 240    (unless (member (first c) '(:report :test :interactive))
 241            (return c))))
 242
 243 (defun condition-restarts (expr clist)
 244   (if (and (consp expr) (member (first expr) '(error cerror signal warn)))
 245       (mapcar #'second
 246               (butlast *active-restarts*
 247                        (- (length *active-restarts*) (length clist))))))
 248
 249
 250 ;;;;
 251 ;;;; Internal Condition Representation
 252 ;;;;
 253
 254 (setf (get 'condition '*struct-slots*) nil)
 255 (setf (get 'condition '*struct-print-function*) 'print-condition)
 256
 257 (defun transform-condition-report-option (x)
 258   (if x
 259       (if (stringp x) x `(function ,x))))
 260
 261 (defun plist-to-alist (plist)
 262   (do ((plist plist (rest (rest plist)))
 263        (alist nil (push (list (first plist) (second plist)) alist)))
 264       ((not (consp (rest plist))) (nreverse alist))))
 265
 266 (defun transform-condition-slot-options (spec)
 267   (let* ((name (if (consp spec) (first spec) spec))
 268          (opts (if (consp spec) (plist-to-alist (rest spec)) nil))
 269          (iform (assoc :initform opts)))
 270     (if iform
 271         (let ((form (second iform)))
 272           `(cons
 273             ',name
 274             (cons
 275              ,(if (constantp form)
 276                        `'(:initform ,form)
 277                        `(list :initform
 278                               (list 'eval
 279                                     (list (function (lambda () ,form))))))
 280              ',(remove-if #'(lambda (x) (eq (first x) :initform)) opts))))
 281         `'(,name ,@opts))))
 282
 283 (defun print-condition (c s d)
 284   (declare (ignore d))
 285   (let ((type (type-of c)))
 286     (if *print-escape*
 287         (format s "#<Condition ~s: ~d>" (type-of c) (address-of c))
 288         (let ((rep (get type '*condition-report*)))
 289           (cond
 290            ((null rep) (format s "~s" type))
 291            ((stringp rep) (format s "~s" rep))
 292            (t (funcall rep c s)))))))
 293
 294 (defun make-condition-class (name parent report doc slots)
 295   (setf (get name '*struct-print-function*) 'print-condition)
 296   (if parent (setf (get name '*struct-include*) parent))
 297   (setf (get name '*condition-report*)
 298         (if report report (get parent '*condition-report*)))
 299   (if (stringp doc) (setf (documentation name 'type) doc))
 300   (let ((old (if parent (mapcar #'copy-list (get parent '*struct-slots*))))
 301         (new nil))
 302     (dolist (s slots)
 303       (unless (assoc (first s) old) (push (list (first s) nil nil) new)))
 304     (let ((entries (append old (nreverse new))))
 305       (dolist (spec slots)
 306         (let* ((entry (assoc (first spec) entries))
 307                (opts (rest spec))
 308                (i (+ (position entry entries) 1)))
 309           (dolist (opt opts)
 310             (case (first opt)
 311              (:reader
 312               (setf (symbol-function (second opt))
 313                     (eval `(function (lambda (x) (%struct-ref x ,i))))))
 314              (:writer
 315               (setf (symbol-function (second opt))
 316                     (eval `(function (lambda (x v) (%struct-set x ,i v))))))
 317              (:accessor
 318               (setf (symbol-function (second opt))
 319                     (eval `(function (lambda (x) (%struct-ref x ,i)))))
 320               (setf (get (second opt) '*setf*)
 321                     (eval `(function (lambda (x v) (%struct-set x ,i v))))))
 322              (:initarg (push (second opt) (second entry)))
 323              (:initform (setf (third entry) (second opt)))
 324             ))))
 325       (setf (get name '*struct-slots*) entries)))
 326   name)
 327
 328 (defun initialize-condition (c info args)
 329   (do* ((i 1 (+ i 1))
 330         (info info (rest info))
 331         (vi (first info) (first info)))
 332       ((null info))
 333       (let* ((iargs (second vi))
 334              (ival  *not-found*)
 335              (iform (third vi)))
 336         (dolist (i iargs)
 337           (setf ival (getf args i *not-found*))
 338           (unless (eq ival *not-found*) (return)))
 339         (if (eq ival *not-found*)
 340             (setf ival (if (constantp iform) iform (eval iform))))
 341         (%struct-set c i ival))))
 342
 343
 344 ;;;;
 345 ;;;; Helper Functions for HANDLER-BIND and HANDLER-CASE
 346 ;;;;
 347
 348 (defun reverse-expand-handler-bind-forms (th)
 349   (let ((forms nil))
 350     (dolist (f th forms)
 351       (push `(list ',(first f) ,(second f)) forms))))
 352
 353 (defun push-condition-handlers (clist active)
 354   (dolist (ch clist)
 355     (push (cons active ch) *active-handlers*)))
 356
 357 (defun handler-case-handler-bind-forms (hforms varsym tagsyms)
 358   (mapcar #'(lambda (ht ts)
 359               `(,(first ht) #'(lambda (temp) (setq ,varsym temp) (go ,ts))))
 360           hforms
 361           tagsyms))
 362
 363 (defun expand-handler-case-bodies (hforms bsym varsym tagsyms)
 364   (apply #'nconc
 365          (mapcar #'(lambda (hf ts)
 366                      (let ((v (if (second hf) (first (second hf)) varsym)))
 367                        `(,ts
 368                          (return-from ,bsym
 369                                       (let ((,v ,varsym))
 370                                         ,@(rest (rest hf)))))))
 371                  hforms
 372                  tagsyms)))
 373
 374
 375 ;;;;
 376 ;;;; Hook Function and Lisp-Level Signaling Functions
 377 ;;;;
 378
 379 (defun handle-condition (c)
 380   (if (typep c *break-on-signals*)
 381       (with-simple-restart (continue "Proceed with signalling.")
 382         (format *debug-io* "~&Break on signal: ")
 383         (do-debugger c)))
 384   (dolist (he *active-handlers*)
 385     (let* ((*active-handlers* (first he))
 386            (tspec (second he))
 387            (h (third he)))
 388       (if (typep c tspec) (funcall h c)))))
 389
 390 (defun condition-argument (datum args &optional
 391                                  (simple-type 'simple-error)
 392                                  (type 'condition))
 393   (cond
 394    ((typep datum type) datum) ;;**** check for no additional args?
 395    ((symbolp datum) (apply #'make-condition datum args))
 396    ((stringp datum)
 397     (make-condition simple-type :format-string datum :format-arguments args))
 398    (t (error "bad condition arguments - ~s" (cons datum args)))))
 399
 400 (defun base-condition-hook (type *debug-frame* *debug-env* &rest args)
 401   (let ((*condition-hook* 'condition-hook))
 402     (case type
 403       (error (apply #'do-error args))
 404       (cerror (apply #'do-cerror args))
 405       (signal (apply #'do-signal args))
 406       (warn (apply #'do-warn args))
 407       (break (apply #'do-break args))
 408       (debug (apply #'do-debugger args)))))
 409
 410 (defun condition-hook (&rest args)
 411   (let ((*condition-hook* 'condition-hook))
 412     (handler-bind
 413      ((unbound-variable #'(lambda (c)
 414                       (autoload-variable (cell-error-name c))))
 415       (undefined-function #'(lambda (c)
 416                         (autoload-function (cell-error-name c)))))
 417      (apply #'base-condition-hook args))))
 418
 419 (defun do-error (datum &rest args)
 420   (let ((condition (condition-argument datum args)))
 421     (with-condition-restarts condition *condition-restarts*
 422       (setf *condition-restarts* nil)
 423       (handle-condition condition)
 424       (format *debug-io* "~&Error: ")
 425       (do-debugger condition))))
 426
 427 (defun do-cerror (cmsg datum &rest args)
 428   (let ((condition (condition-argument datum args)))
 429     (with-condition-restarts condition *condition-restarts*
 430       (setf *condition-restarts* nil)
 431       (restart-case
 432        (progn
 433          (handle-condition condition)
 434          (format *debug-io* "~&Error: ")
 435          (do-debugger condition))
 436        (continue ()
 437         :report (lambda (s) (apply #'format s cmsg args))
 438         :test (lambda (c) (eq c condition)))))
 439       nil))
 440
 441 (defun do-signal (datum &rest args)
 442   (let ((condition (condition-argument datum args 'simple-condition)))
 443     (with-condition-restarts condition *condition-restarts*
 444       (setf *condition-restarts* nil)
 445       (handle-condition condition))
 446     nil))
 447
 448 (defun do-warn (datum &rest args)
 449   (let ((condition (condition-argument datum args 'simple-warning 'warning)))
 450     (with-condition-restarts condition *condition-restarts*
 451       (setf *condition-restarts* nil)
 452       (restart-case
 453        (progn
 454          (signal condition)
 455          (format *error-output* "~&Warning: ~a~%" condition))
 456        (muffle-warning ()
 457         :report "Muffle warning"
 458         :test (lambda (c) (eq c condition)))))
 459     nil))
 460
 461 (defun do-break (&optional (fmt-string "**BREAK**") &rest fmt-args)
 462   (with-simple-restart (continue "Return from BREAK.")
 463     (format *debug-io* "Break: ")
 464     (do-debugger
 465      (make-condition 'simple-condition
 466                      :format-string fmt-string
 467                      :format-arguments fmt-args)))
 468   nil)
 469
 470
 471 ;;;;
 472 ;;;; Debugger Functions
 473 ;;;;
 474
 475 (defun do-debugger (condition)
 476   ;; should probably check for a condition
 477   (let ((*print-readably* nil))
 478     (when *debugger-hook*
 479       (let* ((hook *debugger-hook*)
 480              (*debugger-hook* nil))
 481         (funcall hook condition hook)))
 482     (let* ((*debug-level* (+ *debug-level* 1))
 483            (current-level *debug-level*)
 484            (*print-level* (if *debug-print-level*
 485                               *debug-print-level*
 486                             *print-level*))
 487            (*print-length* (if *debug-print-length*
 488                                *debug-print-length*
 489                              *print-length*)))
 490       ;; print the error message
 491       (when condition
 492         (multiple-value-bind (val err)
 493                              (ignore-errors
 494                               (format *debug-io* "~a~%" condition))
 495           (declare (ignore val))
 496           (when err (format *debug-io* "~s~%" condition))))
 497
 498       ;; flush the input buffer and reset the system internals
 499       (reset-system)
 500
 501       ;; do the back trace
 502       (if *tracenable* (baktrace (if *tracelimit* *tracelimit* -1)))
 503
 504       ;; read-eval-print loop
 505       (let ((*continue-restarts* (compute-restarts condition)))
 506         (loop
 507          (with-simple-restart (abort "Return to break level ~d." current-level)
 508
 509            (when *batch-mode* (format *debug-io* "uncaught error~%") (exit))
 510
 511            ;; print restart information (**** optional??)
 512            (format *debug-io* "Break level ~d.~%" current-level)
 513            (format
 514             *debug-io*
 515             "To continue, type (continue n), where n is an option number:~%")
 516            (dotimes (i (length *continue-restarts*))
 517              (multiple-value-bind
 518               (val err)
 519               (ignore-errors
 520                (format *debug-io* "~2d: ~a~%" i (nth i *continue-restarts*)))
 521               (declare (ignore val))
 522               (when err
 523                 (ignore-errors
 524                  (format *debug-io* "~s~%" (nth i *continue-restarts*))))))
 525
 526            (loop
 527             ;; print a prompt
 528             (if (eq *package* (find-package "USER"))
 529                 (format *debug-io* "~&~d> " *debug-level*)
 530               (format *debug-io* "~&~A ~d> "
 531                       (package-name *package*)
 532                       *debug-level*))
 533
 534             ;; read and save an input expression
 535             (let ((expr (read *debug-io* nil *eof-mark*)))
 536               (if (eq expr *eof-mark*) (continue 0));;**** is this right??
 537               (setf +++ ++ ++ + + - - expr))
 538
 539             ;; evaluate the expression, save and print the results
 540             (let ((vals (multiple-value-list (evalhook - nil nil *debug-env*))))
 541               (setf *** ** ** * * (first vals))
 542
 543               (fresh-line *debug-io*)
 544
 545               (dolist (v vals) (format *debug-io* "~s~%" v))))))))))
 546
 547 (defun debug-fun ()
 548   (if (or (null *debug-frame*) (null (stack-value *debug-frame*)))
 549       nil
 550       (stack-value (+ *debug-frame* 1))))
 551
 552 (defun clean-up (&optional c) (continue c))
 553
 554 (defun baktrace (&optional levels (print-args *baktrace-print-arguments*))
 555   (if *debug-frame*
 556       (do ((fp *debug-frame* (- fp (stack-value fp)))
 557            (n (if levels levels -1) (- n 1)))
 558           ((or (= n 0) (null (stack-value fp))))
 559           (let ((p (+ fp 1)))
 560             (format *error-output* "Function: ~s~%" (stack-value p))
 561             (incf p)
 562             (if print-args
 563                 (let ((argc (stack-value p)))
 564                   (incf p)
 565                   (when (> argc 0)
 566                         (format *error-output* "Arguments:~%")
 567                         (dotimes (i argc)
 568                           (format *error-output* "  ~s~%"
 569                                   (stack-value (+ p i))))))))))
 570   (values))
 571
 572 (defun show-bindings (&optional vars)
 573   (dolist (a (first *debug-env*))
 574     (if (consp a)
 575         (dolist (b a)
 576           (if (consp b)
 577               (let ((s (car b))
 578                     (v (cdr b)))
 579                 (if (and (symbolp s)
 580                          (or (null vars)
 581                              (eq s vars)
 582                              (and (consp vars) (member s vars))))
 583                     (format *error-output* "~s~15t~s~%" s v)))))))
 584   (values))
 585
 586 (defmacro get-value (form) `(evalhook ,form nil nil *debug-env*))
 587
 588 (defmacro set-value (form val) `(evalhook (setf ,form ,val) *debug-env*))
 589
 590
 591 ;;;;
 592 ;;;; Public Interface
 593 ;;;;
 594
 595 (defun prompt-for (type fmt-string &rest fmt-args)
 596   (loop
 597    (apply #'format *debug-io* fmt-string fmt-args)
 598    (let ((val (eval (read *debug-io*))))
 599      (if (typep val type) (return val))
 600      (format *debug-io* "~s is not of type ~s.~%" val type))))
 601
 602 ;;**** simple version -- use this in define-cmp-macro
 603 (defun type-check (x spec)
 604   (unless (typep x spec) (error "~s is not of type ~s." x spec))
 605   nil)
 606
 607 #|
 608 (defmacro check-type (place spec &optional string)
 609   `(type-check ,place ',spec))
 610 |#
 611
 612 ;; version of check-type that returns the final value of the place form
 613 (defmacro base-check-type (place spec &optional string)
 614   (let ((valsym (gensym "VAL")))
 615     `(loop
 616       (let ((,valsym ,place))
 617         (if (typep ,valsym ',spec)
 618             (return ,valsym)
 619             (restart-case
 620              (error 'check-type-error
 621                     :datum ,valsym
 622                     :expected-type ',spec
 623                     :form ',place
 624                     :type-string ,string)
 625              (store-value (,valsym)
 626               :report "Store new value."
 627               :interactive (lambda ()
 628                              (list
 629                               (prompt-for ',spec "Value for ~s: " ',place)))
 630               (setf ,place ,valsym))))))))
 631
 632 (defmacro check-type (place spec &optional string)
 633   `(progn (base-check-type ,place ,spec ,string)
 634           nil))
 635
 636 ;;**** simple versions
 637 (defmacro assert (testform &optional places datum &rest args)
 638   (if datum
 639       `(unless ,testform (error ,datum ,@args))
 640       `(unless ,testform
 641                (error "The assertion ~S failed" ',testform))))
 642
 643 (defmacro etypecase (var &rest forms)
 644   (let ((vsym (gensym "VAR")))
 645     `(let ((,vsym ,var))
 646        (typecase ,vsym
 647                  ,@forms
 648                  (t (error 'type-error
 649                            :datum ,vsym
 650                            :expected-type '(or ,@(mapcar #'first forms))))))))
 651
 652 (defmacro ctypecase (var &rest body)
 653   `(typecase (base-check-type ,var (or ,@(mapcar #'first body)))
 654              ,@body))
 655
 656 (defun compute-case-match-type (cases)
 657   (let ((keys nil))
 658     (dolist (b cases (cons 'member (nreverse keys)))
 659       (if (consp (first b))
 660           (dolist (k (first b)) (push k keys)))
 661           (push (first b) keys))))
 662
 663 (defmacro ecase (var &rest forms)
 664   (let ((vsym (gensym "VAR")))
 665     `(let ((,vsym ,var))
 666        (case ,vsym
 667              ,@forms
 668              (t (error 'type-error
 669                        :datum ,vsym
 670                        :expected-type (compute-case-match-type ',forms)))))))
 671
 672 (defmacro ccase (var &rest body)
 673   `(case (base-check-type ,var ,(compute-case-match-type body))
 674          ,@body))
 675
 676 (defmacro handler-case (expr &rest hforms)
 677   (if (eq (first (first (last hforms))) :no-error)
 678       (let ((errsym (gensym "ERROR"))
 679             (normsym (gensym "NORMAL"))
 680             (ne-form (first (last hforms)))
 681             (e-forms (butlast hforms)))
 682         `(block ,errsym
 683            (multiple-value-call #'(lambda ,@(rest ne-form))
 684              (block ,normsym
 685                (return-from ,errsym
 686                  (handler-case (return-from ,normsym ,expr)
 687                    ,@e-forms))))))
 688       (let ((bsym (gensym "BLOCK"))
 689             (varsym (gensym "VAR"))
 690             (tagsyms (mapcar #'(lambda (x) (gensym "TAG")) hforms)))
 691         `(block ,bsym
 692            (let (,varsym)
 693              (tagbody
 694               (handler-bind
 695                ,(handler-case-handler-bind-forms hforms varsym tagsyms)
 696                (return-from ,bsym ,expr))
 697               ,@(expand-handler-case-bodies hforms bsym varsym tagsyms)))))))
 698
 699 (defmacro ignore-errors (&rest forms)
 700   `(handler-case (progn ,@forms)
 701      (error (c) (values nil c))))
 702
 703 (defmacro handler-bind (th &rest body)
 704   (let ((valsym (gensym "VALUE")))
 705     `(let ((*active-handlers* *active-handlers*))
 706        (push-condition-handlers (list ,@(reverse-expand-handler-bind-forms th))
 707                                 *active-handlers*)
 708        ;; this errset traps internal xlabort's (from stack overflows)
 709        ;; and converts them to calls to (abort)
 710        (let ((,valsym (errset (multiple-value-list (progn ,@body)) nil)))
 711          (if ,valsym
 712              (values-list (first ,valsym))
 713              (error "stack overflow"))))))
 714
 715 #|
 716 (defmacro handler-bind (th &rest body)
 717   `(let ((*active-handlers* *active-handlers*))
 718      (push-condition-handlers (list ,@(reverse-expand-handler-bind-forms th))
 719                               *active-handlers*)
 720      ,@body))
 721 |#
 722
 723 (defmacro handler-bind (th &rest body)
 724   (let ((valsym (gensym "VALUE")))
 725     `(let ((*active-handlers* *active-handlers*))
 726        (push-condition-handlers (list ,@(reverse-expand-handler-bind-forms th))
 727                                 *active-handlers*)
 728        ;; this errset traps internal xlabort's (from stack overflows)
 729        ;; and converts them to calls to (abort)
 730        (let ((,valsym (errset (multiple-value-list (progn ,@body)))))
 731          (if ,valsym
 732              (values-list (first ,valsym))
 733              (error "stack overflow"))))))
 734
 735 (defmacro define-condition (name plist &optional slots &rest options)
 736   (if (< 1 (length plist)) (error "multiple inheritance not supported"))
 737   (if (null plist) (error "new conditions must inherit from an existing one"))
 738   `(make-condition-class ',name
 739                          ',(first plist)
 740                          ,(transform-condition-report-option
 741                            (second (assoc :report options)))
 742                          ',(second (assoc :documentation options))
 743                          (list ,@(mapcar #'transform-condition-slot-options
 744                                          slots))))
 745
 746 (defun make-condition (type &rest args)
 747   (when (eq (get type '*struct-slots* *not-found*) *not-found*)
 748         (error "bad condition type - ~s" type))
 749   (let* ((info (get type '*struct-slots*))
 750          (c (apply #'%make-struct type (make-list (length info)))))
 751     (initialize-condition c info args)
 752     c))
 753
 754 (defmacro with-simple-restart (rfa &rest forms)
 755   (let ((restart-name (first rfa))
 756         (format-string (second rfa))
 757         (format-args (rest (rest rfa))))
 758     `(restart-case (progn ,@forms)
 759        (,restart-name ()
 760          :report (lambda (stream) (format stream ,format-string ,@format-args))
 761          (values nil t)))))
 762
 763 (defmacro restart-case (expr &rest cases)
 764   (let* ((tagsym (gensym "TAG"))
 765          (argsym (gensym "ARGS"))
 766          (valsym (gensym "VALS"))
 767          (parts (make-restart-case-parts tagsym argsym cases)))
 768     `(block ,tagsym
 769        (let ((,argsym nil))
 770          (tagbody
 771           (restart-bind
 772            ,(first parts)
 773            (let ((*condition-restarts* (condition-restarts ',expr ',cases)))
 774              (return-from ,tagsym ,expr)))
 775           ,@(rest parts))))))
 776
 777 #|
 778 (defmacro restart-bind (bds &rest body)
 779   (let ((valsym (gensym "VALUE")))
 780     `(let ((*active-restarts* *active-restarts*))
 781        (push-restarts nil (list ,@(mapcar #'expand-restart-binding-form bds)))
 782        ;; this errset traps internal xlabort's (from stack overflows)
 783        ;; and converts them to calls to (abort)
 784        (let ((,valsym (errset (multiple-value-list (progn ,@body)))))
 785          (if ,valsym (values-list (first ,valsym)) (abort))))))
 786 |#
 787
 788 (defmacro restart-bind (bds &rest body)
 789   `(let ((*active-restarts* *active-restarts*))
 790      (push-restarts nil (list ,@(mapcar #'expand-restart-binding-form bds)))
 791      ,@body))
 792
 793 (defmacro with-condition-restarts (condition rlist &rest forms)
 794   `(let ((*active-restarts* *active-restarts*))
 795      (push-restarts ,condition ,rlist)
 796      ,@forms))
 797
 798
 799 (defun compute-restarts (&optional condition)
 800   (let ((result nil))
 801     (dolist (cr *active-restarts*)
 802       (if (restart-entry-applicable-p cr condition)
 803           (push (second cr) result)))
 804     (nreverse (delete-duplicates result))))
 805
 806 ;restart-name
 807 (defun restart-entry-applicable-p (cr condition)
 808   (let ((c (first cr))
 809         (r (second cr)))
 810     (if c
 811         (eq c condition)
 812         (or (null condition)
 813             (funcall (restart-test-function r) condition)))))
 814
 815 (defun find-restart (identifier &optional condition)
 816   (cond
 817    ((null identifier) nil)
 818    ((symbolp identifier)
 819     (second
 820      (find-if #'(lambda (x)
 821                   (and (restart-entry-applicable-p x condition)
 822                        (eq identifier (restart-name (second x)))))
 823               *active-restarts*)))
 824    ((restart-p identifier)
 825     (second (find identifier *active-restarts* :key #'second)))))
 826
 827
 828 (defun invoke-restart (identifier &rest args)
 829   (let ((restart (find-restart identifier)))
 830     (if restart
 831         (apply (restart-function restart) args)
 832         (error "invalid restart - ~s" identifier))))
 833
 834 (defun invoke-restart-interactively (identifier)
 835   (let* ((restart (find-restart identifier))
 836          (ifun (restart-interactive-function restart))
 837          (rfun (restart-function restart)))
 838     (if restart
 839         (if ifun (apply rfun (funcall ifun)) (funcall rfun))
 840         (error "invalid restart - ~s" identifier))))
 841
 842
 843 (defun abort (&optional condition)
 844   (invoke-restart (find-restart 'abort condition)))
 845
 846 (defun continue (&optional condition)
 847   (if (integerp condition)
 848       (let ((restart (nth condition *continue-restarts*)))
 849         (if restart (invoke-restart-interactively restart)))
 850       (let ((restart (find-restart 'continue condition)))
 851         (if restart (invoke-restart restart)))))
 852
 853 (defun muffle-warning (&optional condition)
 854   (invoke-restart (find-restart 'muffle-warning condition)))
 855
 856 (defun store-value (value &optional condition)
 857   (let ((restart (find-restart 'store-value condition)))
 858     (if restart (invoke-restart restart value))))
 859
 860 (defun use-value (value &optional condition)
 861   (let ((restart (find-restart 'use-value condition)))
 862     (if restart (invoke-restart restart value))))
 863
 864
 865 ;;;;
 866 ;;;; Condition Types
 867 ;;;;
 868
 869 (defun print-simple-condition (c s)
 870   (if *print-escape*
 871       (print-condition c s nil)
 872       (apply #'format
 873              s
 874              (simple-condition-format-string c)
 875              (simple-condition-format-arguments c))))
 876
 877 (define-condition simple-condition (condition)
 878   ((format-string :accessor simple-condition-format-string
 879                   :initform "Simple condition."
 880                   :initarg :format-string)
 881    (format-arguments :accessor simple-condition-format-arguments
 882                      :initarg :format-arguments))
 883   (:report print-simple-condition))
 884
 885 (define-condition serious-condition (condition))
 886 (define-condition error (serious-condition))
 887
 888 (define-condition simple-error (error)
 889   ((format-string :initform "Simple error." :initarg :format-string)
 890    (format-arguments :initarg :format-arguments))
 891   (:report print-simple-condition))
 892
 893 (define-condition warning (condition))
 894
 895 (define-condition simple-warning (warning)
 896   ((format-string :initform "Simple warning." :initarg :format-string)
 897    (format-arguments :initarg :format-arguments))
 898   (:report print-simple-condition))
 899
 900 (define-condition storage-condition (condition))
 901
 902 (define-condition cell-error (error)
 903   ((name :accessor cell-error-name :initarg :name))
 904   (:report "Cell error"))
 905
 906 (define-condition unbound-variable (cell-error)
 907   ()
 908   (:report
 909    (lambda (c s)
 910      (format s "The variable ~s is unbound." (cell-error-name c)))))
 911
 912 (define-condition undefined-function (cell-error)
 913   ()
 914   (:report
 915    (lambda (c s)
 916      (format s "The function ~s is not defined." (cell-error-name c)))))
 917
 918 (define-condition type-error (error)
 919   (format-string
 920    format-arguments
 921    (datum :initarg :datum :accessor type-error-datum)
 922    (expected-type :initarg :expected-type
 923                   :accessor type-error-expected-type))
 924   (:report
 925    (lambda (c s)
 926      (format s "~s is not of type ~s."
 927              (type-error-datum c)
 928              (type-error-expected-type c)))))
 929
 930 (define-condition check-type-error (type-error)
 931   ((form :initarg :form :accessor check-type-error-form)
 932    (type-string :initarg :type-string :accessor check-type-error-type-string))
 933   (:report
 934    (lambda (c s)
 935      (if (check-type-error-type-string c)
 936          (format s "The value of ~s, ~s, is not ~a."
 937                  (check-type-error-form c)
 938                  (type-error-datum c)
 939                  (check-type-error-type-string c))
 940          (format s "The value of ~s, ~s, is not of type ~s."
 941                  (check-type-error-form c)
 942                  (type-error-datum c)
 943                  (type-error-expected-type c))))))
 944
 945 (define-condition simple-type-error (type-error))
 946
 947 #|
 948                         arithmetic-error
 949                                 division-by-zero
 950                         control-error
 951                         file-error
 952                         package-error
 953                         program-error
 954                         stream-error
 955                                 end-of-file
 956
 957 package-error-package
 958
 959 stream-error-stream
 960 file-error-pathname
 961
 962 arithmetic-error-operation
 963 arithmetic-error-operands
 964 |#