;;;
;;; CONDITIONS
;;;
;;; This is a sample implementation. It is not in any way intended as the definition
;;; of any aspect of the condition system. It is simply an existence proof that the
;;; condition system can be implemented.
;;;
;;; While this written to be "portable", this is not a portable condition system
;;; in that loading this file will not redefine your condition system. Loading this
;;; file will define a bunch of functions which work like a condition system. Redefining
;;; existing condition systems is beyond the goal of this implementation attempt.

(defpackage #:conditions
  (:use #:common-lisp)
  (:shadow
   #:break #:error #:cerror #:warn #:check-type #:assert #:etypecase
   #:ctypecase #:ecase #:ccase
   #:*break-on-signals* #:*debugger-hook* #:signal #:handler-case
   #:handler-bind #:ignore-errors #:define-condition #:make-condition
   #:with-simple-restart #:restart-case #:restart-bind #:restart-name
   #:restart-name #:find-restart #:compute-restarts #:invoke-restart
   #:invoke-restart-interactively #:abort #:continue #:muffle-warning
   #:store-value #:use-value #:invoke-debugger #:restart #:condition
   #:warning #:serious-condition #:simple-condition #:simple-warning
   #:simple-error #:simple-condition-format-string
   #:simple-condition-format-arguments #:storage-condition
   #:stack-overflow #:storage-exhausted #:type-error #:type-error-datum
   #:type-error-expected-type #:simple-type-error #:program-error
   #:control-error #:stream-error #:stream-error-stream #:end-of-file
   #:file-error #:file-error-pathname #:cell-error #:cell-error-name
   #:unbound-variable #:undefined-function #:arithmetic-error
   #:arithmetic-error-operation #:arithmetic-error-operands #:package-error
   #:package-error-package #:division-by-zero #:floating-point-overflow
   #:floating-point-underflow)
  (:export
   ;; Shadowed symbols
   #:break #:error #:cerror
   #:warn #:check-type #:assert
   #:etypecase #:ctypecase
   #:ecase #:ccase
   ;; New symbols
   #:*break-on-signals* #:*debugger-hook* #:signal #:handler-case
   #:handler-bind #:ignore-errors #:define-condition #:make-condition
   #:with-simple-restart #:restart-case #:restart-bind #:restart-name
   #:restart-name #:find-restart #:compute-restarts #:invoke-restart
   #:invoke-restart-interactively #:abort #:continue #:muffle-warning
   #:store-value #:use-value #:invoke-debugger #:restart #:condition
   #:warning #:serious-condition #:simple-condition #:simple-warning
   #:simple-error #:simple-condition-format-string
   #:simple-condition-format-arguments #:storage-condition
   #:stack-overflow #:storage-exhausted #:type-error #:type-error-datum
   #:type-error-expected-type #:simple-type-error #:program-error
   #:control-error #:stream-error #:stream-error-stream #:end-of-file
   #:file-error #:file-error-pathname #:cell-error #:unbound-variable
   #:undefined-function #:arithmetic-error #:arithmetic-error-operation
   #:arithmetic-error-operands #:package-error #:package-error-package
   #:division-by-zero #:floating-point-overflow
   #:floating-point-underflow #:*debug-eval* #:*debug-print*))

(in-package #:conditions)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar *this-package* (find-package 
"CONDITIONS" )))


;;; Unique Ids

(defvar *unique-id-table* (make-hash-table))
(defvar *unique-id-count* -1)

(defun unique-id (obj)
  
"Generates a unique integer ID for its argument."   (or (gethash obj *unique-id-table*)
      (setf (gethash obj *unique-id-table*) (incf *unique-id-count*))))

;;; Miscellaneous Utilities

(eval-when (:compile-toplevel :load-toplevel :execute)

  (defun parse-keyword-pairs (list keys)
    (do ((l list (cddr l))
         (k '() (list* (cadr l) (car l) k)))
        ((or (null l) (not (member (car l) keys)))
         (values (nreverse k) l))))

  (defmacro with-keyword-pairs ((names expression &optional keywords-var) &body forms)
    (let ((temp (member '&rest names)))
      (unless (= (length temp) 2) (error 
"&REST keyword is ~:[missing~;misplaced~]." temp))
      (let ((key-vars (ldiff names temp))
            (key-var (or keywords-var (gensym)))
            (rest-var (cadr temp)))
        (let ((keywords (mapcar #'(lambda (x) (intern (string x) (find-package 
"KEYWORD" )))
                                key-vars)))
          `(multiple-value-bind (,key-var ,rest-var)
               (parse-keyword-pairs ,expression ',keywords)
             (let ,(mapcar #'(lambda (var keyword) `(,var (getf ,key-var ,keyword)))
                    key-vars keywords)
               ,@forms))))))

  );NEHW-LAVE


;;; Restarts

(defvar *restart-clusters* '())

(defun compute-restarts ()
  (copy-list (apply #'append *restart-clusters*)))

(defun restart-print (restart stream depth)
  (declare (ignore depth))
  (if *print-escape*
      (format stream 
"#<~S.~D>" (type-of restart) (unique-id restart))
      (restart-report restart stream)))

(defstruct (restart (:print-function restart-print))
  name
  function
  report-function
  interactive-function)

(defun restart-report (restart stream)
  (funcall (or (restart-report-function restart)
               (let ((name (restart-name restart)))
                 #'(lambda (stream)
                     (if name (format stream 
"~S" name)
                         (format stream 
"~S" restart)))))
           stream))

(defmacro restart-bind (bindings &body forms)
  `(let ((*restart-clusters* (cons (list ,@(mapcar #'(lambda (binding)
                                                       `(make-restart
                                                         :name     ',(car binding)
                                                         :function ,(cadr binding)
                                                         ,@(cddr binding)))
                                                   bindings))
                                   *restart-clusters*)))
     ,@forms))

(defun find-restart (name)
  (dolist (restart-cluster *restart-clusters*)
    (dolist (restart restart-cluster)
      (when (or (eq restart name) (eq (restart-name restart) name))
        (return-from find-restart restart)))))

(defun invoke-restart (restart &rest values)
  (let ((real-restart (or (find-restart restart)
                          (error 
"Restart ~S is not active." restart))))
    (apply (restart-function real-restart) values)))

(defun invoke-restart-interactively (restart)
  (let ((real-restart (or (find-restart restart)
                          (error 
"Restart ~S is not active." restart))))
    (apply (restart-function real-restart)
           (let ((interactive-function
                   (restart-interactive-function real-restart)))
             (if interactive-function
                 (funcall interactive-function)
                 '())))))


(defmacro restart-case (expression &body clauses)
  (flet ((transform-keywords (&key report interactive)
           (let ((result '()))
             (when report
               (setq result (list* (if (stringp report)
                                       `#'(lambda (stream)
                                            (write-string ,report stream))
                                       `#',report)
                                   :report-function
                                   result)))
             (when interactive
               (setq result (list* `#',interactive
                                   :interactive-function
                                   result)))
             (nreverse result))))
    (let ((block-tag (gensym))
          (temp-var  (gensym))
          (data
            (mapcar #'(lambda (clause)
                        (with-keyword-pairs ((report interactive &rest forms)
                                             (cddr clause))
                          (list (car clause)			   ;Name=0
                                (gensym)			   ;Tag=1
                                (transform-keywords :report report ;Keywords=2
                                                    :interactive interactive)
                                (cadr clause)			   ;BVL=3
                                forms)))			   ;Body=4
                    clauses)))
      `(block ,block-tag
         (let ((,temp-var nil))
           (tagbody
              (restart-bind
                  ,(mapcar #'(lambda (datum)
                               (let ((name (nth 0 datum))
                                     (tag  (nth 1 datum))
                                     (keys (nth 2 datum)))
                                 `(,name #'(lambda (&rest temp)
                                             #+lispm (setq temp (copy-list temp))
                                             (setq ,temp-var temp)
                                             (go ,tag))
                                         ,@keys)))
                    data)
                (return-from ,block-tag ,expression))
              ,@(mapcan #'(lambda (datum)
                            (let ((tag  (nth 1 datum))
                                  (bvl  (nth 3 datum))
                                  (body (nth 4 datum)))
                              (list tag
                                    `(return-from ,block-tag
                                       (apply #'(lambda ,bvl ,@body)
                                              ,temp-var)))))
                        data)))))))

(defmacro with-simple-restart ((restart-name format-string
                                &rest format-arguments)
                               &body forms)
  `(restart-case (progn ,@forms)
     (,restart-name ()
       :report (lambda (stream)
                 (format stream ,format-string ,@format-arguments))
       (values nil t))))


(defun condition-print (condition stream depth)
  depth ;ignored
  (cond (*print-escape*
         (format stream 
"#<~S.~D>" (type-of condition) (unique-id condition)))
        (t
         (condition-report condition stream))))

(defstruct (condition :conc-name
                      (:constructor |constructor for condition|)
                      (:predicate nil)
                      (:print-function condition-print))
  (-dummy-slot- nil))

(eval-when (:compile-toplevel :load-toplevel :execute)

  (defmacro parent-type     (condition-type) `(get ,condition-type 'parent-type))
  (defmacro slots           (condition-type) `(get ,condition-type 'slots))
  (defmacro conc-name       (condition-type) `(get ,condition-type 'conc-name))
  (defmacro report-function (condition-type) `(get ,condition-type 'report-function))
  (defmacro make-function   (condition-type) `(get ,condition-type 'make-function))

  );NEHW-LAVE

(defun condition-report (condition stream)
  (do ((type (type-of condition) (parent-type type)))
      ((not type) (format stream 
"The condition ~A occurred." condition))
    (let ((reporter (report-function type)))
      (when reporter
        (funcall reporter condition stream)
        (return nil)))))

(setf (make-function   'condition) '|constructor for condition|)

(defun make-condition (type &rest slot-initializations)
  (let ((fn (make-function type)))
    (cond ((not fn) (error 'simple-type-error
                           :datum type
                           :expected-type '(satisfies make-function)
                           :format-string 
"Not a condition type: ~S"                            :format-arguments (list type)))
          (t (apply fn slot-initializations)))))

(eval-when (:compile-toplevel :load-toplevel :execute) ;Some utilities that are used at macro expansion time

  (defmacro resolve-function (function expression resolver)
    `(cond ((and ,function ,expression)
            (cerror 
"Use only the :~A information."                     
"Only one of :~A and :~A is allowed."                     ',function ',expression))
           (,expression
            (setq ,function ,resolver))))
  
  (defun parse-new-and-used-slots (slots parent-type)
    (let ((new '()) (used '()))
      (dolist (slot slots)
        (if (slot-used-p (car slot) parent-type)
            (push slot used)
            (push slot new)))
      (values new used)))

  (defun slot-used-p (slot-name type)
    (cond ((eq type 'condition) nil)
          ((not type) (error 
"The type ~S does not inherit from CONDITION." type))
          ((assoc slot-name (slots type)))
          (t
           (slot-used-p slot-name (parent-type type)))))

  );NEHW-LAVE

(defmacro define-condition (name (parent-type) slot-specs &rest options)
  (let ((constructor (let ((*package* *this-package*)) ;Bind for the INTERN -and- the FORMAT
                       (intern (format nil 
"Constructor for ~S" name)))))
    (let ((slots (mapcar #'(lambda (slot-spec)
                             (if (atom slot-spec) (list slot-spec) slot-spec))
                         slot-specs)))
      (multiple-value-bind (new-slots used-slots)
          (parse-new-and-used-slots slots parent-type)
        (let ((conc-name-p     nil)
              (conc-name       nil)
              (report-function nil)
              (documentation   nil))
          (do ((o options (cdr o)))
              ((null o))
            (let ((option (car o)))
              (case (car option) ;Should be ECASE
                (:conc-name (setq conc-name-p t)
                 (setq conc-name (cadr option)))
                (:report (setq report-function (if (stringp (cadr option))
                                                   `(lambda (stream)
                                                      (write-string ,(cadr option) stream))
                                                   (cadr option))))
                (:documentation (setq documentation (cadr option)))
                (otherwise (cerror 
"Ignore this DEFINE-CONDITION option."                                    
"Invalid DEFINE-CONDITION option: ~S" option)))))
          (if (not conc-name-p) (setq conc-name (intern (format nil 
"~A-" name) *package*)))
          ;; The following three forms are compile-time side-effects. For now, they affect
          ;; the global environment, but with modified abstractions for PARENT-TYPE, SLOTS, 
          ;; and CONC-NAME, the compiler could easily make them local.
          (setf (parent-type name) parent-type)
          (setf (slots name)       slots)
          (setf (conc-name name)   conc-name)
          ;; Finally, the expansion ...
          `(progn (defstruct (,name
                              (:constructor ,constructor)
                              (:predicate nil)
                              (:copier nil)
                              (:print-function condition-print)
                              (:include ,parent-type ,@used-slots)
                              (:conc-name ,conc-name))
                    ,@new-slots)
                  (setf (documentation ',name 'type) ',documentation)
                  (setf (parent-type ',name) ',parent-type)
                  (setf (slots ',name) ',slots)
                  (setf (conc-name ',name) ',conc-name)
                  (setf (report-function ',name) ,(if report-function `#',report-function))
                  (setf (make-function ',name) ',constructor)
                  ',name))))))


(eval-when (:compile-toplevel :load-toplevel :execute)

  (defun accumulate-cases (macro-name cases list-is-atom-p)
    (do ((l '())
         (c cases (cdr c)))
        ((null c) (nreverse l))
      (let ((keys (caar c)))
        (cond ((atom keys)
               (cond ((null keys))
                     ((member keys '(otherwise t))
                      (error 
"OTHERWISE is not allowed in ~S expressions."                              macro-name))
                     (t (push keys l))))
              (list-is-atom-p
               (push keys l))
              (t
               (dolist (key keys) (push key l)))))))

  );NEHW-LAVE

(defmacro ecase (keyform &rest cases)
  (let ((keys (accumulate-cases 'ecase cases nil))
        (var (gensym)))
    `(let ((,var ,keyform))
       (case ,var
         ,@cases
         (otherwise
          (error 'case-failure :name 'ecase
                               :datum ,var
                               :expected-type '(member ,@keys)
                               :possibilities ',keys))))))

(defmacro ccase (keyplace &rest cases)
  (let ((keys (accumulate-cases 'ccase cases nil))
        (tag1 (gensym))
        (tag2 (gensym)))
    `(block ,tag1
       (tagbody ,tag2
          (return-from ,tag1
            (case ,keyplace
              ,@cases
              (otherwise
               (restart-case (error 'case-failure
                                    :name 'ccase
                                    :datum ,keyplace
                                    :expected-type '(member ,@keys)
                                    :possibilities ',keys)
                 (store-value (value)
                   :report (lambda (stream)
                             (format stream 
"Supply a new value of ~S."                                      ',keyplace))
                   :interactive read-evaluated-form
                   (setf ,keyplace value)
                   (go ,tag2))))))))))



(defmacro etypecase (keyform &rest cases)
  (let ((types (accumulate-cases 'etypecase cases t))
        (var (gensym)))
    `(let ((,var ,keyform))
       (typecase ,var
         ,@cases
         (otherwise
          (error 'case-failure :name 'etypecase
                               :datum ,var
                               :expected-type '(or ,@types)
                               :possibilities ',types))))))

(defmacro ctypecase (keyplace &rest cases)
  (let ((types (accumulate-cases 'ctypecase cases t))
        (tag1 (gensym))
        (tag2 (gensym)))
    `(block ,tag1
       (tagbody ,tag2
          (return-from ,tag1
            (typecase ,keyplace
              ,@cases
              (otherwise
               (restart-case (error 'case-failure
                                    :name 'ctypecase
                                    :datum ,keyplace
                                    :expected-type '(or ,@types)
                                    :possibilities ',types)
                 (store-value (value)
                   :report (lambda (stream)
                             (format stream 
"Supply a new value of ~S."                                      ',keyplace))
                   :interactive read-evaluated-form
                   (setf ,keyplace value)
                   (go ,tag2))))))))))



(defun assert-report (names stream)
  (format stream 
"Retry assertion" )
  (if names
      (format stream 
" with new value~P for ~{~S~^, ~}."               (length names) names)
      (format stream 
"." )))

(defun assert-prompt (name value)
  (cond ((y-or-n-p 
"The old value of ~S is ~S.~
		  ~%Do you want to supply a new value? "                    name value)
         (format *query-io* 
"~&Type a form to be evaluated:~%" )
         (flet ((read-it () (eval (read *query-io*))))
           (if (symbolp name) ;Help user debug lexical variables
               (progv (list name) (list value) (read-it))
               (read-it))))
        (t value)))

(defun simple-assertion-failure (assertion)
  (error 'simple-type-error
         :datum assertion
         :expected-type nil			; This needs some work in next revision. -kmp
         :format-string 
"The assertion ~S failed."          :format-arguments (list assertion)))

(defmacro assert (test-form &optional places datum &rest arguments)
  (let ((tag (gensym)))
    `(tagbody ,tag
        (unless ,test-form
          (restart-case ,(if datum
                             `(error ,datum ,@arguments)
                             `(simple-assertion-failure ',test-form))
            (continue ()
              :report (lambda (stream) (assert-report ',places stream))
              ,@(mapcar #'(lambda (place)
                            `(setf ,place (assert-prompt ',place ,place)))
                        places)
              (go ,tag)))))))



(defun read-evaluated-form ()
  (format *query-io* 
"~&Type a form to be evaluated:~%" )
  (list (eval (read *query-io*))))

(defmacro check-type (place type &optional type-string)
  (let ((tag1 (gensym))
        (tag2 (gensym)))
    `(block ,tag1
       (tagbody ,tag2
          (if (typep ,place ',type) (return-from ,tag1 nil))
          (restart-case ,(if type-string
                             `(error 
"The value of ~S is ~S, ~
				     which is not ~A."                                      ',place ,place ,type-string)
                             `(error 
"The value of ~S is ~S, ~
				     which is not of type ~S."                                      ',place ,place ',type))
            (store-value (value)
              :report (lambda (stream)
                        (format stream 
"Supply a new value of ~S."                                 ',place))
              :interactive read-evaluated-form
              (setf ,place value)
              (go ,tag2)))))))

(defvar *handler-clusters* nil)

(defmacro handler-bind (bindings &body forms)
  (unless (every #'(lambda (x) (and (listp x) (= (length x) 2))) bindings)
    (error 
"Ill-formed handler bindings." ))
  `(let ((*handler-clusters* (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x)))
                                                   bindings))
                                   *handler-clusters*)))
     ,@forms))

(defvar *break-on-signals* nil)

(defun signal (datum &rest arguments)
  (let ((condition (coerce-to-condition datum arguments 'simple-condition 'signal))
        (*handler-clusters* *handler-clusters*))
    (if (typep condition *break-on-signals*)
        (break 
"~A~%Break entered because of *BREAK-ON-SIGNALS*."                condition))
    (loop (if (not *handler-clusters*) (return))
          (let ((cluster (pop *handler-clusters*)))
            (dolist (handler cluster)
              (when (typep condition (car handler))
                (funcall (cdr handler) condition)
                (return nil) ;?
                ))))
    nil))



;;; COERCE-TO-CONDITION
;;;  Internal routine used in ERROR, CERROR, BREAK, and WARN for parsing the
;;;  hairy argument conventions into a single argument that's directly usable 
;;;  by all the other routines.

(defun coerce-to-condition (datum arguments default-type function-name)
  #+lispm (setq arguments (copy-list arguments))
  (cond ((typep datum 'condition)
         (if arguments
             (cerror 
"Ignore the additional arguments."                      'simple-type-error
                     :datum arguments
                     :expected-type 'null
                     :format-string 
"You may not supply additional arguments ~
				     when giving ~S to ~S."                      :format-arguments (list datum function-name)))
         datum)
        ((symbolp datum)                  ;roughly, (SUBTYPEP DATUM 'CONDITION)
         (apply #'make-condition datum arguments))
        ((stringp datum)
         (make-condition default-type
                         :format-string datum
                         :format-arguments arguments))
        (t
         (error 'simple-type-error
                :datum datum
                :expected-type '(or symbol string)
                :format-string 
"Bad argument to ~S: ~S"                 :format-arguments (list function-name datum)))))

(defun error (datum &rest arguments)
  (let ((condition (coerce-to-condition datum arguments 'simple-error 'error)))
    (signal condition)
    (invoke-debugger condition)))

(defun cerror (continue-string datum &rest arguments)
  (with-simple-restart (continue 
"~A" (apply #'format nil continue-string arguments))
    (apply #'error datum arguments))
  nil)

(defun break (&optional (format-string 
"Break" ) &rest format-arguments)
  (with-simple-restart (continue 
"Return from BREAK." )
    (invoke-debugger
     (make-condition 'simple-condition
                     :format-string    format-string
                     :format-arguments format-arguments)))
  nil)

(define-condition warning (condition) ())

(defvar *break-on-warnings* nil)

(defun warn (datum &rest arguments)
  (let ((condition
          (coerce-to-condition datum arguments 'simple-warning 'warn)))
    (check-type condition warning 
"a warning condition" )
    (if *break-on-warnings*
        (break 
"~A~%Break entered because of *BREAK-ON-WARNINGS*."                condition))
    (restart-case (signal condition)
      (muffle-warning ()
        :report 
"Skip warning."         (return-from warn nil)))
    (format *error-output* 
"~&Warning:~%~A~%" condition)
    nil))



(define-condition serious-condition (condition) ())

(define-condition error (serious-condition) ())

(defun simple-condition-printer (condition stream)
  (apply #'format stream (simple-condition-format-string    condition)
         (simple-condition-format-arguments condition)))

(define-condition simple-condition (condition) (format-string (format-arguments '()))
  (:conc-name internal-simple-condition-)
  (:report simple-condition-printer))

(define-condition simple-warning (warning) (format-string (format-arguments '()))
  (:conc-name internal-simple-warning-)
  (:report simple-condition-printer))

(define-condition simple-error (error) (format-string (format-arguments '()))
  (:conc-name internal-simple-error-)
  (:report simple-condition-printer))

(define-condition storage-condition (serious-condition) ())

(define-condition stack-overflow    (storage-condition) ())
(define-condition storage-exhausted (storage-condition) ())

(define-condition type-error (error) (datum expected-type))

(define-condition simple-type-error (type-error) (format-string (format-arguments '()))
  (:conc-name internal-simple-type-error-)
  (:report simple-condition-printer))

(define-condition case-failure (type-error) (name possibilities)
  (:report
   (lambda (condition stream)
     (format stream 
"~S fell through ~S expression.~%Wanted one of ~:S."              (type-error-datum condition)
             (case-failure-name condition)
             (case-failure-possibilities condition)))))

(defun simple-condition-format-string (condition)
  (etypecase condition
    (simple-condition  (internal-simple-condition-format-string  condition))
    (simple-warning    (internal-simple-warning-format-string    condition))
    (simple-type-error (internal-simple-type-error-format-string condition))
    (simple-error      (internal-simple-error-format-string      condition))))

(defun simple-condition-format-arguments (condition)
  (etypecase condition
    (simple-condition  (internal-simple-condition-format-arguments  condition))
    (simple-warning    (internal-simple-warning-format-arguments    condition))
    (simple-type-error (internal-simple-type-error-format-arguments condition))
    (simple-error      (internal-simple-error-format-arguments      condition))))

(define-condition program-error (error) ())

(define-condition control-error (error) ())

(define-condition stream-error (error) (stream))

(define-condition end-of-file (stream-error) ())

(define-condition file-error (error) (pathname))

(define-condition package-error (error) (pathname))



(define-condition cell-error (error) (name))

(define-condition unbound-variable (cell-error) ()
  (:report (lambda (condition stream)
             (format stream 
"The variable ~S is unbound."                      (cell-error-name condition)))))

(define-condition undefined-function (cell-error) ()
  (:report (lambda (condition stream)
             (format stream 
"The function ~S is undefined."                      (cell-error-name condition)))))

(define-condition arithmetic-error (error) (operation operands))

(define-condition division-by-zero         (arithmetic-error) ())
(define-condition floating-point-overflow  (arithmetic-error) ())
(define-condition floating-point-underflow (arithmetic-error) ())



(defmacro handler-case (form &rest cases)
  (let ((no-error-clause (assoc ':no-error cases)))
    (if no-error-clause
        (let ((normal-return (make-symbol 
"NORMAL-RETURN" ))
              (error-return  (make-symbol 
"ERROR-RETURN" )))
          `(block ,error-return
             (multiple-value-call #'(lambda ,@(cdr no-error-clause))
               (block ,normal-return
                 (return-from ,error-return
                   (handler-case (return-from ,normal-return ,form)
                     ,@(remove no-error-clause cases)))))))
        (let ((tag (gensym))
              (var (gensym))
              (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
                                       cases)))
          `(block ,tag
             (let ((,var nil))
               ,var				;ignorable
               (tagbody
                  (handler-bind ,(mapcar #'(lambda (annotated-case)
                                             (list (cadr annotated-case)
                                                   `#'(lambda (temp)
                                                        ,@(if (caddr annotated-case)
                                                              `((setq ,var temp)))
                                                        (go ,(car annotated-case)))))
                                  annotated-cases)
                    (return-from ,tag ,form))
                  ,@(mapcan #'(lambda (annotated-case)
                                (list (car annotated-case)
                                      (let ((body (cdddr annotated-case)))
                                        `(return-from ,tag
                                           ,(cond ((caddr annotated-case)
                                                   `(let ((,(caaddr annotated-case)
                                                            ,var))
                                                      ,@body))
                                                  ((not (cdr body))
                                                   (car body))
                                                  (t
                                                   `(progn ,@body)))))))
                            annotated-cases))))))))

(defmacro ignore-errors (&rest forms)
  `(handler-case (progn ,@forms)
     (error (condition) (values nil condition))))

(define-condition abort-failure (control-error) ()
  (:report 
"Abort failed." ))

(defun abort          ()      (invoke-restart 'abort)
  (error 'abort-failure))
(defun continue       ()      (invoke-restart 'continue))
(defun muffle-warning ()      (invoke-restart 'muffle-warning))
(defun store-value    (value) (invoke-restart 'store-value value))
(defun use-value      (value) (invoke-restart 'use-value   value))



(defvar *debug-level* 0)
(defvar *debug-abort* nil)
(defvar *debug-continue* nil)
(defvar *debug-condition* nil)
(defvar *debug-restarts* nil)
(defvar *number-of-debug-restarts* 0)
(defvar *debug-eval* 'eval)
(defvar *debug-print* #'(lambda (values) (format t 
"~&~{~S~^,~%~}" values)))

(defmacro debug-command                (x) `(get ,x 'debug-command))
(defmacro debug-command-argument-count (x) `(get ,x 'debug-command-argument-count))

(defmacro define-debug-command (name bvl &rest body)
  `(progn (setf (debug-command ',name) #'(lambda ,bvl ,@body))
          (setf (debug-command-argument-count ',name) ,(length bvl))
          ',name))

(defun read-debug-command ()
  (format t 
"~&Debug ~D> " *debug-level*)
  (cond ((char= (peek-char t) #\:)
         (with-input-from-string (stream (read-line))
           (let ((eof (list nil)))
             (do ((form (let ((*package* (find-package 
"KEYWORD" )))
                          (read-char) ;Eat the ":" so that ":1" reliably reads a number.
                          (read stream nil eof))
                        (read stream nil eof))
                  (l '() (cons form l)))
                 ((eq form eof) (nreverse l))))))
        (t
         (list :eval (read)))))

(define-debug-command :eval (form)
  (funcall *debug-print* (multiple-value-list (funcall *debug-eval* form))))

(define-debug-command :abort ()
  (if *debug-abort*
      (invoke-restart-interactively *debug-abort*)
      (format t 
"~&There is no way to abort.~%" )))

(define-debug-command :continue ()
  (if *debug-continue*
      (invoke-restart-interactively *debug-continue*)
      (format t 
"~&There is no way to continue.~%" )))

(define-debug-command :error ()
  (format t 
"~&~A~%" *debug-condition*))

(define-debug-command :help ()
  (format t 
"~&You are in a portable debugger.~
             ~%Type a debugger command or a form to evaluate.~
             ~%Commands are:~%" )
  (show-restarts *debug-restarts* *number-of-debug-restarts* 16)
  (format t 
"~& :EVAL form     Evaluate a form.~
             ~% :HELP          Show this text.~%" )
  (if *debug-abort*    (format t 
"~& :ABORT         Exit by ABORT.~%" ))
  (if *debug-continue* (format t 
"~& :CONTINUE      Exit by CONTINUE.~%" ))
  (format t 
"~& :ERROR         Reprint error message.~%" ))



(defun show-restarts (&optional (restarts *debug-restarts*)
                        (max *number-of-debug-restarts*)
                        target-column)
  (unless max (setq max (length restarts)))
  (when restarts
    (do ((w (if target-column
                (- target-column 3)
                (ceiling (log max 10))))
         (p restarts (cdr p))
         (i 0 (1+ i)))
        ((or (not p) (= i max)))
      (format t 
"~& :~A "               (let ((s (format nil 
"~D" (+ i 1))))
                (with-output-to-string (str)
                  (format str 
"~A" s)
                  (dotimes (i (- w (length s)))
                    (write-char #\space str)))))
      (if (eq (car p) *debug-abort*) (format t 
"(Abort) " ))
      (if (eq (car p) *debug-continue*) (format t 
"(Continue) " ))
      (format t 
"~A" (car p))
      (format t 
"~%" ))))

(defvar *debugger-hook* nil)

(defun invoke-debugger (&optional (datum 
"Debug" ) &rest arguments)
  (let ((condition (coerce-to-condition datum arguments 'simple-condition 'debug)))
    (when *debugger-hook*
      (let ((hook *debugger-hook*)
            (*debugger-hook* nil))
        (funcall hook condition hook)))
    (standard-debugger condition)))

(defun standard-debugger (condition)
  (let* ((*debug-level* (1+ *debug-level*))
         (*debug-restarts* (compute-restarts))
         (*number-of-debug-restarts* (length *debug-restarts*))
         (*debug-abort*    (find-restart 'abort))
         (*debug-continue* (or (let ((c (find-restart 'continue)))
                                 (if (or (not *debug-continue*)
                                         (not (eq *debug-continue* c)))
                                     c nil))
                               (let ((c (if *debug-restarts*
                                            (first *debug-restarts*) nil)))
                                 (if (not (eq c *debug-abort*)) c nil))))
         (*debug-condition* condition))
    (format t 
"~&~A~%" condition)
    (show-restarts)
    (do ((command (read-debug-command)
                  (read-debug-command)))
        (nil)
      (execute-debugger-command (car command) (cdr command) *debug-level*))))

(defun execute-debugger-command (cmd args level)
  (with-simple-restart (abort 
"Return to debug level ~D." level)
    (cond ((not cmd))
          ((integerp cmd)
           (cond ((and (plusp cmd)
                       (< cmd (+ *number-of-debug-restarts* 1)))
                  (let ((restart (nth (- cmd 1) *debug-restarts*)))
                    (if args
                        (apply #'invoke-restart restart (mapcar *debug-eval* args))
                        (invoke-restart-interactively restart))))
                 (t
                  (format t 
"~&No such restart." ))))
          (t
           (let ((fn (debug-command cmd)))
             (if fn
                 (cond ((not (= (length args) (debug-command-argument-count cmd)))
                        (format t 
"~&Too ~:[few~;many~] arguments to ~A."                                 (> (length args) (debug-command-argument-count cmd))
                                cmd))
                       (t
                        (apply fn args)))
                 (format t 
"~&~S is not a debugger command.~%" cmd)))))))


;;;; Sample Use
;;;
;;; To install this condition system, you must make your evaluator call the
;;; functions above. To make it more useful, you should try to establish reasonable
;;; restarts. What follows is an illustration of how this might be done if your
;;; evaluator were actually written in Lisp. (Note: The evaluator shown is not
;;; following CL evaluation rules, but that's not relevant to the points we're trying
;;; to make here.)


(defpackage conditions-sample-application
  (:use :common-lisp :conditions)
  (:shadowing-import-from
   :conditions
   #:break #:error #:cerror #:warn #:check-type #:assert #:etypecase
   #:ctypecase #:ecase #:ccase
   #:*break-on-signals* #:*debugger-hook* #:signal #:handler-case
   #:handler-bind #:ignore-errors #:define-condition #:make-condition
   #:with-simple-restart #:restart-case #:restart-bind #:restart-name
   #:restart-name #:find-restart #:compute-restarts #:invoke-restart
   #:invoke-restart-interactively #:abort #:continue #:muffle-warning
   #:store-value #:use-value #:invoke-debugger #:restart #:condition
   #:warning #:serious-condition #:simple-condition #:simple-warning
   #:simple-error #:simple-condition-format-string
   #:simple-condition-format-arguments #:storage-condition
   #:stack-overflow #:storage-exhausted #:type-error #:type-error-datum
   #:type-error-expected-type #:simple-type-error #:program-error
   #:control-error #:stream-error #:stream-error-stream #:end-of-file
   #:file-error #:file-error-pathname #:cell-error #:cell-error-name
   #:unbound-variable #:undefined-function #:arithmetic-error
   #:arithmetic-error-operation #:arithmetic-error-operands #:package-error
   #:package-error-package #:division-by-zero #:floating-point-overflow
   #:floating-point-underflow)
  (:export #:my-repl #:my-print #:my-apply #:my-eval))

(in-package :conditions-sample-application)

(defun prompt-for (type &optional prompt)
  (flet ((try () (format t 
"~&~A? " (or prompt type)) (read)))
    (do ((ans (try) (try)))
        ((typep ans type) ans)
      (format t 
"~&Wrong type of response -- wanted ~S~%" type))))

(defun my-prompt-for-value ()
  (list (my-eval (prompt-for t 
"Value" ))))

(defun my-repl ()
  (let ((*debug-eval* 'my-eval)
        (*debug-print* 'my-print))
    (do ((form (prompt-for 't 
"Eval" )
               (prompt-for 't 
"Eval" )))
        ((not form))
      (with-simple-restart (abort 
"Return to MY-REPL toplevel." )
        (my-print (multiple-value-list (my-eval form)))))))

(defun my-print (values)
  (format t 
"~{~&=> ~S~}" values))

(defun my-apply (fn &rest args)
  (if (functionp fn)
      (apply #'apply fn args)
      (restart-case (error 
"Invalid function: ~S" fn)
        (use-value (x)
          :report 
"Use a different function."           :interactive my-prompt-for-value
          (apply #'my-apply x args)))))

(defun my-eval (x)
  (cond ((numberp x) x)
        ((symbolp x) (my-eval-symbol x))
        ((stringp x) x)
        ((atom x) (error 
"Illegal form: ~S" x))
        ((not (atom (car x)))
         (my-apply (my-eval (car x)) (mapcar #'my-eval (cdr x))))
        ((eq (car x) 'lambda)
         #'(lambda (&rest args)
             (my-eval `(let ,(mapcar #'list (cadr x) args) ,@(cddr x)))))
        ((member (car x) '(quote function)) (cadr x))
        ((eq (car x) 'setq) (setf (symbol-value (cadr x)) (my-eval (caddr x))))
        ((eq (car x) 'defun) (setf (symbol-function (cadr x))
                                   (my-eval `(lambda ,@(cddr x)))))
        ((eq (car x) 'if) (if (my-eval (cadr x))
                              (my-eval (caddr x))
                              (my-eval (cadddr x))))
        ((eq (car x) 'let) (progv (mapcar #'car (cadr x))
                               (mapcar #'my-eval (mapcar #'cadr (cadr x)))
                             (my-eval `(progn ,@(cddr x)))))
        ((eq (car x) 'progn) (do ((l (cdr x) (cdr l)))
                                 ((not (cdr l)) (my-eval (car l)))
                               (my-eval (car l))))
        ((not (symbolp (car x))) (error 
"Illegal form: ~S" x))
        (t (my-apply (my-feval-symbol (car x)) (mapcar #'my-eval (cdr x))))))


(defun my-eval-symbol (x)
  (if (boundp x)
      (symbol-value x)
      (restart-case (error 'unbound-variable :name x)
        (use-value (value)
          :report (lambda (stream)
                    (format stream 
"Specify another value of ~S to use this time." x))
          :interactive my-prompt-for-value
          value)
        (nil ()
          :report (lambda (stream)
                    (format stream 
"Retry the SYMBOL-VALUE operation on ~S." x))
          (my-eval-symbol x))
        (my-store-value (value)
          :report (lambda (stream)
                    (format stream 
"Specify another value of ~S to store and use." x))
          :interactive my-prompt-for-value
          (setf (symbol-value x) value)
          value))))

(defun my-feval-symbol (x)
  (if (fboundp x)
      (symbol-function x)
      (restart-case (error 'undefined-function :name x)
        (use-value (value)
          :report (lambda (stream)
                    (format stream 
"Specify a function to use instead of ~S this time." x))
          :interactive my-prompt-for-value
          value)
        (nil ()
          :report (lambda (stream)
                    (format stream 
"Retry the SYMBOL-FUNCTION operation on ~S." x))
          (my-feval-symbol x))
        (my-store-value (value)
          :report my-prompt-for-value
          (setf (symbol-function x) value)
          value))))