Implementation of Common Lisp Condition System in CL

(in-package #:cl-user)

(defpackage #:clcs
  (:use #:cl)
  (:shadow
    #:condition
    #:simple-condition
    #:simple-condition-format-control
    #:simple-condition-format-arguments
    #:error
    #:simple-error
    #:warning
    #:simple-warning
    #:restart
    #:restart-name
    #:signal
    #:warn
    #:invoke-debugger
    #:muffle-warning
    #:abort
    #:find-restart
    #:invoke-restart
    #:compute-restarts
    #:define-condition
    #:make-condition
    #:handler-bind
    #:handler-case
    #:restart-bind
    #:restart-case)
  (:export
    #:condition
    #:simple-condition
    #:simple-condition-format-control
    #:simple-condition-format-arguments
    #:error
    #:simple-error
    #:warning
    #:simple-warning
    #:restart
    #:restart-name
    #:signal
    #:warn
    #:invoke-debugger
    #:muffle-warning
    #:abort
    #:find-restart
    #:invoke-restart
    #:compute-restarts
    #:define-condition
    #:make-condition
    #:handler-bind
    #:handler-case
    #:restart-bind
    #:restart-case))

(in-package #:clcs)

;;;;==========================================
;;;;                Conditions
;;;;==========================================

(defclass condition ()
  ((report-function :initform #'default-report-function)))

(defmethod print-object ((object condition) stream)
  (if *print-escape*
    (print-unreadable-object (object stream :type t :identity t))
    (funcall (slot-value object 'report-function) object stream))
  object)

(defun default-report-function (c s)
  (format s "Condition of type ~s signalled." c))

(defmacro define-condition (name (&rest superclasses)
                                 (&rest slots)
                                 &rest options)
  `(defclass ,name (,@superclasses condition)
     ,(append (let ((report (find :report options :key #'car)))
                (if report
                  `((report-function
                      :initform ,(make-report-lambda report)))
                  '()))
              slots)
     ,@(remove :report options :key #'car)))

(defun make-report-lambda (report-form)
  (typecase (second report-form)
    (string `(lambda (c s)
               (declare (ignore c))
               (write-string ,(second report-form) s)))
    (symbol `(function ,(second report-form)))
    ((cons (eql lambda) (cons list list)) (second report-form))
    (T (error "Invalid :report argument: ~s" report-form))))

(defclass simple-condition (condition)
  ((report-function :initform #'report-simple-condition)
   (format-control :initform nil :initarg :format-control
                   :accessor simple-condition-format-control)
   (format-arguments :initform '() :initarg :format-arguments
                     :accessor simple-condition-format-arguments)))

(defun report-simple-condition (c s)
  (apply #'format s
         (or (slot-value c 'format-control)
             (error "No format control for ~s" c))
         (slot-value c 'format-arguments)))

(defclass error (condition)
  ())

(defclass simple-error (error simple-condition)
  ())

(defclass warning (condition)
  ())

(defclass simple-warning (warning simple-condition)
  ())

(defvar *active-handlers* '())

(defmacro handler-bind ((&rest bindings) &body body)
  `(let* ,(mapcar (lambda (binding)
                    (destructuring-bind
                        (type handler) binding
                      `(*active-handlers* (cons (cons ',type ,handler)
                                                *active-handlers*))))
            (reverse bindings))
     ,@body))

(defmacro handler-case (body &rest cases)
  (let ((block (gensym)))
    `(block ,block
       (handler-bind
         ,(mapcar (lambda (case)
                    (destructuring-bind
                        (type (&optional (var (gensym) var-p)) &body body) case
                      `(,type (lambda (,var)
                                ,(unless var-p `(declare (ignore ,var)))
                                (return-from ,block (locally ,@body))))))
            cases)
         ,body))))

;;;;==========================================
;;;;                Restarts
;;;;==========================================

(defstruct restart
  (name nil :type symbol :read-only t)
  (function (constantly nil) :type function :read-only t))

(defmethod print-object ((object restart) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (format stream "~s" (restart-name object)))
  object)

(defvar *active-restarts* '())

(defun compute-restarts ()
  (copy-list *active-restarts*))

(defun find-restart (name)
  (unless (symbolp name)
    (error "~a is not a symbol." name))
  (find name *active-restarts* :key #'restart-name))

(defun invoke-restart (restart &rest args)
  (typecase restart
    (symbol (let ((r (find restart *active-restarts* :key #'restart-name)))
              (if r
                (apply (restart-function r) args)
                (error "No restart named ~s is active" restart))))
    (restart (if (find restart *active-restarts*)
               (apply (restart-function restart) args)
               (error "Restart ~s is inactive" restart)))
    (t (error "~s is not a restart designator." restart))))

(defmacro restart-bind ((&rest restarts) &body body)
  `(let* ,(mapcar (lambda (binding)
                    (destructuring-bind
                        (name function) binding
                      `(*active-restarts* (cons (make-restart
                                                  :name ',name
                                                  :function ,function)
                                                *active-restarts*))))
            (reverse restarts))
     ,@body))

(defmacro restart-case (body &rest cases)
  (let ((block (gensym)))
    `(block ,block
       (restart-bind
         ,(mapcar (lambda (case)
                    (destructuring-bind
                        (name (&rest args) &body body) case
                      `(,name (lambda ,args (return-from ,block (locally ,@body))))))
            cases)
         ,body))))

(defun make-condition (type &rest args)
  (let ((class (typecase type
                 (symbol (if (subtypep type 'condition)
                           (find-class type)
                           (error "~s is not a condition class" type)))
                 (class (if (subtypep (class-name type) 'condition)
                          type
                          (error "~s is not a condition class" (class-name type))))
                 (T (error "Bad type argument: ~s" type)))))
    (apply #'make-instance class args)))

(defun signal (datum &rest args)
  (let ((condition (if (stringp datum)
                     (make-instance 'simple-condition
                       :format-control datum
                       :format-arguments args)
                     (apply #'make-condition datum args))))
    (dolist (binding *active-handlers*)
      (when (typep condition (car binding))
        (funcall (cdr binding) condition)))))

(defun warn (datum &rest args)
  (let ((condition (if (stringp datum)
                     (make-instance 'simple-warning
                       :format-control datum
                       :format-arguments args)
                     (apply #'make-condition datum args))))
    (unless (typep condition 'warning)
      (error "~a is not a warning" condition))
    (restart-case
      (dolist (binding *active-handlers*
                       (format *error-output* "WARNING: ~a" condition))
        (when (typep condition (car binding))
          (funcall (cdr binding) condition)))
      (muffle-warning () (return-from warn nil)))))

(defun muffle-warning (&optional condition)
  (declare (ignore condition))
  (invoke-restart 'muffle-warning))

(defun error (datum &rest args)
  (let ((condition (if (stringp datum)
                     (make-instance 'simple-error
                       :format-control datum
                       :format-arguments args)
                     (apply #'make-condition datum args))))
    (dolist (binding *active-handlers*
                     (invoke-debugger condition))
      (when (typep condition (car binding))
        (funcall (cdr binding) condition)))))

;;;;====================================
;;;;          Toplevel & debugger
;;;;====================================

(defvar *debug-level* 0)

(defmacro within-toplevel (&body body)
  `(restart-case
     (progn ,@body)
     (abort () (values))))

(defun invoke-debugger (condition)
  (let ((*debug-level* (1+ *debug-level*)))
    (within-toplevel
      (unless (typep condition 'condition)
        (error "~s is not a condition object" condition))
      (format *error-output* "~&Debugger invoked on ~s: ~_ ~a~%~%"
              (class-name (class-of condition)) condition)
      (loop (format *error-output* "~&DEBUG ~a " (make-string *debug-level*
                                                   :initial-element #\>))
            (force-output *error-output*)
            (print (eval (read)) *error-output*)))))

(defun abort (&optional condition)
  (declare (ignore condition))
  (invoke-restart 'abort))