Mercurial > core / lisp/std/condition.lisp
changeset 696: |
38e9c3be2392 |
parent: |
f51b73f49946
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Fri, 04 Oct 2024 21:11:52 -0400 |
permissions: |
-rw-r--r-- |
description: |
prep for adding zdict wrapper, change default control stack size of inferior-lisp to 8M |
1 ;;; condition.lisp --- Conditions and other exception handlers 4 (in-package :std/condition) 6 (defvar *std-error-message* "An error occured") 8 (define-condition std-error (error) 9 ((message :initarg :message 10 :initform *std-error-message* 11 :reader std-error-message)) 12 (:documentation "Standard Error") 13 (:report (lambda (condition stream) 14 (format stream "~A" (std-error-message condition))))) 16 (defun std-error (&rest args) 20 :message (format nil "~A: ~A" *std-error-message* args))) 22 (define-condition std-warning (warning) 23 ((message :initarg :message 25 :reader std-warning-message)) 26 (:documentation "Standard Warning") 28 (lambda (condition stream) 29 (when (std-warning-message condition) 30 (format stream "~X" (std-warning-message condition)))))) 32 (defun std-warning (&optional message) 33 (warn 'std-warning :message message)) 35 (defun car-eql (a cons) 38 (defmacro deferror (name (&rest parent-types) (&rest slot-specs) &rest options) 39 "Define an error condition." 40 (let ((fun (member :auto options :test #'car-eql))) 41 (when fun (setq options (remove (car fun) options))) 43 (define-condition ,name ,(or parent-types '(std-error)) ,slot-specs ,@options) 45 (if (member 'simple-error ',parent-types) 46 (def-simple-error-reporter ,name) 47 (def-error-reporter ,name)))))) 49 (defmacro def-error-reporter (err) 50 `(defun ,err (&rest args) 51 ,(format nil "Signal an error of type ~A with ARGS." err) 55 :message (format nil "~A: ~A" ,*std-error-message* args)))) 57 (defmacro def-simple-error-reporter (name) 59 (defun ,name (fmt &rest args) 60 ,(format nil "Signal an error of type ~A with FMT string and ARGS." name) 65 :format-arguments args)))) 67 (defmacro defwarning (name (&rest parent-types) (&rest slot-specs) &rest options) 68 "Define an warning condition." 69 (let ((fun (member :auto options :test #'car-eql))) 70 (when fun (setq options (remove (car fun) options))) 72 (eval-when (:compile-toplevel :load-toplevel :execute) 73 (define-condition ,name ,(or parent-types '(std-warning)) ,slot-specs ,@options)) 75 (if (member 'simple-warning ',parent-types) 76 (def-simple-warning-reporter ,name) 77 (def-warning-reporter ,name)))))) 79 (defmacro def-warning-reporter (name) 80 `(defun ,name (&optional message) 81 ,(format nil "Signal a warning of type ~A with optional MESSAGE." name) 86 (defmacro def-simple-warning-reporter (name) 87 `(defun ,name (fmt &rest args) 88 ,(format nil "Signal an error of type ~A with FMT string and ARGS." name) 92 :format-arguments args))) 94 (defmacro nyi! (&optional comment) 96 (error "Not Yet Implemented!") 97 (when ',comment (print ',comment)))) 99 (defun required-argument (&optional name) 100 "Signals an error for a missing argument of NAME. Intended for 101 use as an initialization form for structure and class-slots, and 102 a default value for required keyword arguments." 103 (error "Required argument ~@[~S ~]missing." name)) 105 (define-condition simple-style-warning (simple-warning style-warning) 108 (defun simple-style-warning (message &rest args) 109 (warn 'simple-style-warning :format-control message :format-arguments args)) 111 ;; We don't specify a :report for simple-reader-error to let the 112 ;; underlying implementation report the line and column position for 113 ;; us. Unfortunately this way the message from simple-error is not 114 ;; displayed, unless there's special support for that in the 115 ;; implementation. But even then it's still inspectable from the 117 (define-condition simple-reader-error 118 (sb-int:simple-reader-error) 121 (defun simple-reader-error (stream message &rest args) 122 (error 'simple-reader-error 124 :format-control message 125 :format-arguments args)) 127 (define-condition simple-parse-error (simple-error parse-error) 130 (defun simple-parse-error (message &rest args) 131 (error 'simple-parse-error 132 :format-control message 133 :format-arguments args)) 135 (define-condition simple-program-error (simple-error program-error) 138 (defun simple-program-error (message &rest args) 139 (error 'simple-program-error 140 :format-control message 141 :format-arguments args)) 143 (define-condition circular-dependency (simple-error) 146 :initform (error "Must specify items") 147 :reader circular-dependency-items)) 148 (:report (lambda (condition stream) 149 (declare (ignore condition)) 150 (format stream "Circular dependency detected"))) 151 (:documentation "A condition which is signalled when a circular dependency is encountered.")) 153 (define-condition unknown-argument (error) 156 :initform (error "Must specify argument name") 157 :reader unknown-argument-name) 160 :initform (error "Must specify argument kind") 161 :reader unknown-argument-kind)) 162 (:report (lambda (condition stream) 163 (format stream "Unknown argument ~A of kind ~A" 164 (unknown-argument-name condition) 165 (unknown-argument-kind condition)))) 166 (:documentation "A condition which is signalled when an unknown argument is encountered.")) 168 (defun unknown-argument-p (value) 169 (typep value 'unknown-argument)) 171 (define-condition missing-argument (simple-error) 174 :initform (error "Must specify argument item") 175 :reader missing-argument-item)) 176 (:report (lambda (condition stream) 177 (declare (ignore condition)) 178 (format stream "Missing argument"))) 179 (:documentation "A condition which is signalled when an option expects an argument, but none was provided")) 181 (defun missing-argument-p (value) 182 (typep value 'missing-argument)) 184 (define-condition invalid-argument (simple-error) 187 :initform (error "Must specify argument item") 188 :reader invalid-argument-item 189 :documentation "The argument which is identified as invalid") 192 :initform (error "Must specify reason") 193 :reader invalid-argument-reason 194 :documentation "The reason why this argument is invalid")) 195 (:report (lambda (condition stream) 196 (format stream "Invalid argument: ~A~%Reason: ~A" (invalid-argument-item condition) (invalid-argument-reason condition)))) 197 (:documentation "A condition which is signalled when an argument is identified as invalid.")) 199 (defmacro ignore-some-conditions ((&rest conditions) &body body) 200 "Similar to CL:IGNORE-ERRORS but the (unevaluated) CONDITIONS 201 list determines which specific conditions are to be ignored." 204 ,@(loop for condition in conditions collect 205 `(,condition (c) (values nil c))))) 207 (defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses) 208 "Like CL:UNWIND-PROTECT, but you can specify the circumstances that 209 the cleanup CLAUSES are run. 211 clauses ::= (:NORMAL form*)* | (:ABORT form*)* | (:ALWAYS form*)* 213 Clauses can be given in any order, and more than one clause can be 214 given for each circumstance. The clauses whose denoted circumstance 215 occured, are executed in the order the clauses appear. 217 ABORT-FLAG is the name of a variable that will be bound to T in 218 CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL 223 (unwind-protect-case () 225 (:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\")) 226 (:abort (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\")) 227 (:always (format t \"This is evaluated in either case.~%\"))) 229 (unwind-protect-case (aborted-p) 231 (:always (perform-cleanup-if aborted-p))) 233 (check-type abort-flag (or null symbol)) 234 (let ((gflag (gensym "FLAG+"))) 236 (unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil)) 237 (let ,(and abort-flag `((,abort-flag ,gflag))) 238 ,@(loop for (cleanup-kind . forms) in clauses 239 collect (ecase cleanup-kind 240 (:normal `(when (not ,gflag) ,@forms)) 241 (:abort `(when ,gflag ,@forms)) 242 (:always `(progn ,@forms)))))))))