1.1--- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2+++ b/lisp/std/condition.lisp Sun Jul 28 20:49:47 2024 -0400
1.3@@ -0,0 +1,193 @@
1.4+;;; condition.lisp --- Conditions and other exception handlers
1.5+
1.6+;;; Code:
1.7+(in-package :std/condition)
1.8+
1.9+(defvar *std-error-message* "An error occured")
1.10+
1.11+(define-condition std-error (error)
1.12+ ((message :initarg :message
1.13+ :initform *std-error-message*
1.14+ :reader std-error-message))
1.15+ (:documentation "Std Error")
1.16+ (:report (lambda (condition stream)
1.17+ (format stream "~X" (std-error-message condition)))))
1.18+
1.19+(defun std-error (&rest args)
1.20+ (cerror
1.21+ "Ignore and continue"
1.22+ 'std-error
1.23+ :message (format nil "~A: ~A" *std-error-message* args)))
1.24+
1.25+(defun car-eql (a cons)
1.26+ (eql a (car cons)))
1.27+
1.28+(defmacro deferror (name (&rest parent-types) (&rest slot-specs) &rest options)
1.29+ "Define an error condition."
1.30+ (let ((fun (member :auto options :test #'car-eql)))
1.31+ (when fun (setq options (remove (car fun) options)))
1.32+ `(prog1
1.33+ (define-condition ,name ,(or parent-types '(std-error)) ,slot-specs ,@options)
1.34+ (when ',fun (def-error-reporter ,name)))))
1.35+
1.36+(defmacro def-error-reporter (err)
1.37+ `(defun ,err (&rest args)
1.38+ ,(format nil "Signal an error of type ~A with ARGS." err)
1.39+ (cerror
1.40+ "Ignore and continue"
1.41+ ',err
1.42+ :message (format nil "~A: ~A" *std-error-message* args))))
1.43+
1.44+(defmacro nyi! (&optional comment)
1.45+ `(prog1
1.46+ (error "Not Yet Implemented!")
1.47+ (when ',comment (print ',comment))))
1.48+
1.49+(defun required-argument (&optional name)
1.50+ "Signals an error for a missing argument of NAME. Intended for
1.51+use as an initialization form for structure and class-slots, and
1.52+a default value for required keyword arguments."
1.53+ (error "Required argument ~@[~S ~]missing." name))
1.54+
1.55+(define-condition simple-style-warning (simple-warning style-warning)
1.56+ ())
1.57+
1.58+(defun simple-style-warning (message &rest args)
1.59+ (warn 'simple-style-warning :format-control message :format-arguments args))
1.60+
1.61+;; We don't specify a :report for simple-reader-error to let the
1.62+;; underlying implementation report the line and column position for
1.63+;; us. Unfortunately this way the message from simple-error is not
1.64+;; displayed, unless there's special support for that in the
1.65+;; implementation. But even then it's still inspectable from the
1.66+;; debugger...
1.67+(define-condition simple-reader-error
1.68+ (sb-int:simple-reader-error)
1.69+ ())
1.70+
1.71+(defun simple-reader-error (stream message &rest args)
1.72+ (error 'simple-reader-error
1.73+ :stream stream
1.74+ :format-control message
1.75+ :format-arguments args))
1.76+
1.77+(define-condition simple-parse-error (simple-error parse-error)
1.78+ ())
1.79+
1.80+(defun simple-parse-error (message &rest args)
1.81+ (error 'simple-parse-error
1.82+ :format-control message
1.83+ :format-arguments args))
1.84+
1.85+(define-condition simple-program-error (simple-error program-error)
1.86+ ())
1.87+
1.88+(defun simple-program-error (message &rest args)
1.89+ (error 'simple-program-error
1.90+ :format-control message
1.91+ :format-arguments args))
1.92+
1.93+(define-condition circular-dependency (simple-error)
1.94+ ((items
1.95+ :initarg :items
1.96+ :initform (error "Must specify items")
1.97+ :reader circular-dependency-items))
1.98+ (:report (lambda (condition stream)
1.99+ (declare (ignore condition))
1.100+ (format stream "Circular dependency detected")))
1.101+ (:documentation "A condition which is signalled when a circular dependency is encountered."))
1.102+
1.103+(define-condition unknown-argument (error)
1.104+ ((name
1.105+ :initarg :name
1.106+ :initform (error "Must specify argument name")
1.107+ :reader unknown-argument-name)
1.108+ (kind
1.109+ :initarg :kind
1.110+ :initform (error "Must specify argument kind")
1.111+ :reader unknown-argument-kind))
1.112+ (:report (lambda (condition stream)
1.113+ (format stream "Unknown argument ~A of kind ~A"
1.114+ (unknown-argument-name condition)
1.115+ (unknown-argument-kind condition))))
1.116+ (:documentation "A condition which is signalled when an unknown argument is encountered."))
1.117+
1.118+(defun unknown-argument-p (value)
1.119+ (typep value 'unknown-argument))
1.120+
1.121+(define-condition missing-argument (simple-error)
1.122+ ((item
1.123+ :initarg :item
1.124+ :initform (error "Must specify argument item")
1.125+ :reader missing-argument-item)
1.126+ (command
1.127+ :initarg :command
1.128+ :initform (error "Must specify command")
1.129+ :reader missing-argument-command))
1.130+ (:report (lambda (condition stream)
1.131+ (declare (ignore condition))
1.132+ (format stream "Missing argument")))
1.133+ (:documentation "A condition which is signalled when an option expects an argument, but none was provided"))
1.134+
1.135+(defun missing-argument-p (value)
1.136+ (typep value 'missing-argument))
1.137+
1.138+(define-condition invalid-argument (simple-error)
1.139+ ((item
1.140+ :initarg :item
1.141+ :initform (error "Must specify argument item")
1.142+ :reader invalid-argument-item
1.143+ :documentation "The argument which is identified as invalid")
1.144+ (reason
1.145+ :initarg :reason
1.146+ :initform (error "Must specify reason")
1.147+ :reader invalid-argument-reason
1.148+ :documentation "The reason why this argument is invalid"))
1.149+ (:report (lambda (condition stream)
1.150+ (format stream "Invalid argument: ~A~%Reason: ~A" (invalid-argument-item condition) (invalid-argument-reason condition))))
1.151+ (:documentation "A condition which is signalled when an argument is identified as invalid."))
1.152+
1.153+(defmacro ignore-some-conditions ((&rest conditions) &body body)
1.154+ "Similar to CL:IGNORE-ERRORS but the (unevaluated) CONDITIONS
1.155+list determines which specific conditions are to be ignored."
1.156+ `(handler-case
1.157+ (progn ,@body)
1.158+ ,@(loop for condition in conditions collect
1.159+ `(,condition (c) (values nil c)))))
1.160+
1.161+(defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses)
1.162+ "Like CL:UNWIND-PROTECT, but you can specify the circumstances that
1.163+the cleanup CLAUSES are run.
1.164+
1.165+ clauses ::= (:NORMAL form*)* | (:ABORT form*)* | (:ALWAYS form*)*
1.166+
1.167+Clauses can be given in any order, and more than one clause can be
1.168+given for each circumstance. The clauses whose denoted circumstance
1.169+occured, are executed in the order the clauses appear.
1.170+
1.171+ABORT-FLAG is the name of a variable that will be bound to T in
1.172+CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL
1.173+otherwise.
1.174+
1.175+Examples:
1.176+
1.177+ (unwind-protect-case ()
1.178+ (protected-form)
1.179+ (:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\"))
1.180+ (:abort (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\"))
1.181+ (:always (format t \"This is evaluated in either case.~%\")))
1.182+
1.183+ (unwind-protect-case (aborted-p)
1.184+ (protected-form)
1.185+ (:always (perform-cleanup-if aborted-p)))
1.186+"
1.187+ (check-type abort-flag (or null symbol))
1.188+ (let ((gflag (gensym "FLAG+")))
1.189+ `(let ((,gflag t))
1.190+ (unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil))
1.191+ (let ,(and abort-flag `((,abort-flag ,gflag)))
1.192+ ,@(loop for (cleanup-kind . forms) in clauses
1.193+ collect (ecase cleanup-kind
1.194+ (:normal `(when (not ,gflag) ,@forms))
1.195+ (:abort `(when ,gflag ,@forms))
1.196+ (:always `(progn ,@forms)))))))))
