;;; -*- mode: Lisp; Syntax: Common-Lisp; -*- ;;; ;;; Copyright (c) 2009 by the authors. ;;; ;;; See LICENCE for details. (in-package :hu.dwim.util) (def (special-variable e) *debug-on-error* #f "The default, system wide, value for debug-on-error.") (def (generic e) debug-on-error? (context error) (:method (context error) (declare (ignore context error)) *debug-on-error*)) (def (function ed) print-error-safely (&optional message &rest args) (when message (bind ((formatted (if args (or (ignore-errors (apply #'format nil message args)) (ignore-errors (format nil "Error while formatting error message.~% Format control: ~A~% Argument types: ~A" message (mapcar #'type-of args))) "Err, complete meltdown in BEST-EFFORT-LOG-ERROR. Sorry, no more clue is available...") message))) (ignore-errors (write-string formatted *error-output*) (terpri *error-output*) (finish-output *error-output*))))) (def (function ed) maybe-invoke-debugger (condition &key context) (when (debug-on-error? context condition) (when (fboundp 'invoke-slime-debugger) (restart-case (funcall 'invoke-slime-debugger condition) (continue-error-handling () :report "Continue processing the error as if the debugger was not available")))) (values)) (def (function e) collect-backtrace (&key (start 0) count) (if (fboundp 'collect-backtrace/impl) (funcall 'collect-backtrace/impl :start start :count count) (format t "[Backtrace is not available, see ~S for details.]" 'collect-backtrace))) (def (function e) collect-call-path (&key (start 0) count) (if (fboundp 'collect-call-path/impl) (funcall 'collect-call-path/impl :start start :count count) (format t "[Call path is not available, see ~S for details.]" 'collect-call-path/impl))) ;;;;;; ;;; Nested conditions ;; TODO rename... chainable-condition? an orthogonal way for instantiation so that the signature of the original condition constructors can stay the same (def (condition* e) nested-condition (condition) ((nested-condition nil))) ;;;;;; ;;; Error log decorators (def (special-variable :documentation "List of decorators that will be invoked when an error backtrace is logged. A decorator is a closure that will be FUNCALL'd and can print to *STANDARD-OUTPUT* (caret will not be on a new line when called).") *error-log-decorators* ()) (def (definer e :available-flags "eiod") error-log-decorator (name &body body) `(def function ,name () ,@body)) (def (macro e) make-error-log-decorator (&body body) `(named-lambda make-error-log-decorator/body () ,@body)) (def (macro e) make-special-variable-printing-error-log-decorator (&rest variables) `(named-lambda make-special-variable-printing-error-log-decorator/body () (declare (optimize (debug 2))) (bind ((*package* (find-package "COMMON-LISP")) (*print-right-margin* 150)) ,@(iter (for variable :in variables) (collect `(format t ,(bind ((*package* (find-package "COMMON-LISP"))) (format nil "~~%~S ~~A" variable)) (if (boundp ',variable) ,variable 'unbound))))))) (def (macro e) with-error-log-decorator (decorator &body body) `(bind ((*error-log-decorators* (cons ,decorator *error-log-decorators*))) ,@body)) (def (macro/multiple-arguments-variant e) with-error-log-decorator)