Coverage report: /home/ellis/comp/core/std/condition.lisp

Kind	Covered	All	%
expression	54	275	19.6
branch	0	4	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; condition.lisp --- Conditions and other exception handlers

2

3

;;; Code:

4

(in-package :std/condition)

5

(declaim (optimize (speed 3)))

6

;;; Vars

7

(defvar *error-message* "An error occured"

8

"The default error message used in STD-ERROR conditions.")

9

(defvar *handlers* nil

10

"A list of condition handlers - often useful in asynchronous contexts.")

11

12

;;; Utils

13

(declaim (inline car-eql))

14

(defun car-eql (a cons)

15

"Return T if the CAR of CONS is EQL to A."

16

(eql a (car cons)))

17

18

(defmacro nyi! (&optional comment)

19

`(prog1

20

(error "Not Yet Implemented!")

21

(when ',comment (print ',comment))))

22

23

;;; Standard Conditions

24

(define-condition std-error (error)

25

((message :initarg :message

26

:initform *error-message*

27

:reader error-message))

28

(:documentation "Standard Error")

29

(:report (lambda (condition stream)

30

(format stream "~A" (error-message condition)))))

31

32

(defun std-error (&rest args)

33

"Signal an error of type STD-ERROR."

34

(cerror

35

"Ignore and continue"

36

'std-error

37

:message (format nil "~A: ~A" *error-message* args)))

38

39

(define-condition std-warning (warning)

40

((message :initarg :message

41

:initform nil

42

:reader std-warning-message))

43

(:documentation "Standard Warning")

44

(:report

45

(lambda (condition stream)

46

(when (std-warning-message condition)

47

(format stream "~X" (std-warning-message condition))))))

48

49

(defun std-warning (&optional message)

50

(warn 'std-warning :message message))

51

52

;;; Deferror

53

(defmacro deferror (name (&rest parent-types) (&rest slot-specs) &rest options)

54

"Define an error condition."

55

(let ((fun (member :auto options :test #'car-eql))

56

(%ancestors (flatten (mapcar (lambda (x)

57

(mapcar 'sb-mop:class-name

58

                                                (sb-mop:class-precedence-list (find-class x))))

59

parent-types))))

60

(when fun

61

(setf options (remove (car fun) options))

62

(setf fun (cadar fun)))

63

`(prog1

64

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

65

(define-condition ,name ,(or parent-types '(std-error)) ,slot-specs ,@options))

66

(when ',fun

67

(cond

68

((or (member 'simple-error ',%ancestors)

69

(member 'simple-condition ',%ancestors))

70

(def-simple-error-reporter ,name))

71

((or

72

(member 'invalid-item ',%ancestors)

73

(member 'invalid-argument ',%ancestors))

74

(def-invalid-item-reporter ,name))

75

((stringp ',fun)

76

(define-error-reporter ,name ',fun))

77

(t (define-error-reporter ,name)))))))

78

79

(defmacro define-error-reporter (err &optional (message *error-message*))

80

`(defun ,err (&rest args)

81

,(format nil "Signal an error of type ~A with ARGS." err)

82

(cerror

83

"Ignore and continue"

84

',err

85

:message (format nil "~A: ~A" ,message args))))

86

87

(defmacro def-simple-error-reporter (name)

88

`(progn

89

(defun ,name (fmt &rest args)

90

,(format nil "Signal an error of type ~A with FMT string and ARGS." name)

91

(cerror

92

"Ignore and continue"

93

',name

94

:format-control fmt

95

:format-arguments args))))

96

97

(defmacro def-invalid-item-reporter (name)

98

`(defun ,name (item &optional reason)

99

,(format nil "Signal an error of type ~A." name)

100

(apply 'cerror

101

"Ignore and continue"

102

',name

103

:item item

104

(when reason (list :reason reason)))))

105

106

;;; Defwarning

107

(defmacro defwarning (name (&rest parent-types) (&rest slot-specs) &rest options)

108

"Define an warning condition."

109

(let ((fun (member :auto options :test #'car-eql)))

110

(when fun (setq options (remove (car fun) options)))

111

`(prog1

112

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

113

(define-condition ,name ,(or parent-types '(std-warning)) ,slot-specs ,@options))

114

(when ',fun

115

(if (or (find 'simple-warning ',parent-types)

116

(find 'simple-condition ',parent-types))

117

(def-simple-warning-reporter ,name)

118

(def-warning-reporter ,name))))))

119

120

(defmacro def-warning-reporter (name)

121

`(defun ,name (&optional message)

122

,(format nil "Signal a warning of type ~A with optional MESSAGE." name)

123

(warn

124

',name

125

:message message)))

126

127

(defmacro def-simple-warning-reporter (name)

128

`(defun ,name (fmt &rest args)

129

,(format nil "Signal an error of type ~A with FMT string and ARGS." name)

130

(warn

131

',name

132

:format-control fmt

133

:format-arguments args)))

134

135

;;; Conditions

136

(defun required-argument (&optional name)

137

"Signals an error for a missing argument of NAME. Intended for

138

use as an initialization form for structure and class-slots, and

139

a default value for required keyword arguments."

140

(error "Required argument ~@[~S ~]missing." name))

141

142

;;;; Simple

143

(define-condition simple-style-warning (simple-warning style-warning)

144

()

145

(:documentation "Simple style warnings."))

146

147

(defun simple-style-warning (message &rest args)

148

"Signal a SIMPLE-STYLE-WARNING using format-contorl MESSAGE and format-arguments ARGS."

149

(warn 'simple-style-warning :format-control message :format-arguments args))

150

151

;; We don't specify a :report for simple-reader-error to let the

152

;; underlying implementation report the line and column position for

153

;; us. Unfortunately this way the message from simple-error is not

154

;; displayed, unless there's special support for that in the

155

;; implementation. But even then it's still inspectable from the

156

;; debugger...

157

(define-condition simple-reader-error (sb-int:simple-reader-error)

158

()

159

(:documentation "Simple reader errors."))

160

161

(defun simple-reader-error (stream message &rest args)

162

"Signal an error of type SIMPLE-READER-ERROR."

163

(error 'simple-reader-error

164

:stream stream

165

:format-control message

166

:format-arguments args))

167

168

(define-condition simple-parse-error (simple-error parse-error)

169

()

170

(:documentation "Simple parse errors."))

171

172

(defun simple-parse-error (message &rest args)

173

"Signal an error of type SIMPLE-PARSE-ERROR."

174

(error 'simple-parse-error

175

:format-control message

176

:format-arguments args))

177

178

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

179

()

180

(:documentation "Simple program errors."))

181

182

(defun simple-program-error (message &rest args)

183

"Signal an error of type SIMPLE-PROGRAM-ERROR."

184

(error 'simple-program-error

185

:format-control message

186

:format-arguments args))

187

188

(define-condition circular-dependencies (simple-error)

189

((items

190

:initarg :items

191

:initform (error "Must specify items")

192

:reader error-items))

193

(:report (lambda (condition stream)

194

(declare (ignore condition))

195

(format stream "Circular dependency detected")))

196

(:documentation "A condition which is signalled when a circular dependency is encountered."))

197

198

(define-condition unknown-argument (error)

199

((name

200

:initarg :name

201

:initform (error "Must specify argument name")

202

:reader error-name)

203

(kind

204

:initarg :kind

205

:initform (error "Must specify argument kind")

206

:reader error-kind))

207

(:report (lambda (condition stream)

208

(format stream "Unknown argument ~A of kind ~A"

209

(error-name condition)

210

(error-kind condition))))

211

(:documentation "A condition which is signalled when an unknown argument is encountered."))

212

213

(defun unknown-argument-p (value)

214

"Return T if VALUE is a condition of type UNKNOWN-ARGUMENT."

215

(typep value 'unknown-argument))

216

217

(define-condition missing-argument (simple-error)

218

((item

219

:initarg :item

220

:initform (error "Must specify argument item")

221

:reader error-item))

222

(:report (lambda (condition stream)

223

(declare (ignore condition))

224

(format stream "Missing argument")))

225

    (:documentation "A condition which is signalled when an option expects an argument, but none was provided"))

226

227

(defun missing-argument-p (value)

228

"Return T if VALUE is a condition of type MISSING-ARGUMENT."

229

(typep value 'missing-argument))

230

231

(define-condition invalid-item ()

232

((item

233

:initarg :item

234

:initform (error "Must specify argument item")

235

:reader error-item

236

:documentation "The item which is identified as invalid")

237

(reason

238

:initarg :reason

239

:initform (error "Must specify reason")

240

:reader error-reason

241

:documentation "The reason why this item is invalid"))

242

(:documentation "A condition which is signalled when an argument is identified as invalid."))

243

244

(define-condition invalid-argument (simple-error invalid-item) ()

245

(:report (lambda (condition stream)

246

              (format stream "Invalid argument: ~A~%Reason: ~A" (error-item condition) (error-reason condition))))

247

(:documentation "Invalid argument errors."))

248

249

(define-condition conflicting-arguments (simple-error invalid-item) ()

250

(:report (lambda (condition stream)

251

              (format stream "Conflicting arguments: ~A~%Reason: ~A" (error-item condition) (error-reason condition))))

252

(:documentation "Conflicting argument errors."))

253

254

(define-condition unknown-token (std-error)

255

((token :reader error-token :initarg :token))

256

(:documentation "Unknown token errors."))

257

258

(defmethod print-object ((c unknown-token) stream)

259

(when (slot-boundp c 'token)

260

(format stream "Unknown token: ~A.~%" (error-token c)))

261

(call-next-method))

262

263

;;; Macros

264

(defmacro ignore-some-conditions ((&rest conditions) &body body)

265

"Similar to CL:IGNORE-ERRORS but the (unevaluated) CONDITIONS

266

list determines which specific conditions are to be ignored."

267

`(handler-case

268

(progn ,@body)

269

,@(loop for condition in conditions collect

270

`(,condition (c) (values nil c)))))

271

272

(defmacro unwind-protect-case ((&optional abort-flag) protected-form &body clauses)

273

"Like CL:UNWIND-PROTECT, but you can specify the circumstances that

274

the cleanup CLAUSES are run.

275

276

clauses ::= (:NORMAL form*)* | (:ABORT form*)* | (:ALWAYS form*)*

277

278

Clauses can be given in any order, and more than one clause can be

279

given for each circumstance. The clauses whose denoted circumstance

280

occured, are executed in the order the clauses appear.

281

282

ABORT-FLAG is the name of a variable that will be bound to T in

283

CLAUSES if the PROTECTED-FORM aborted preemptively, and to NIL

284

otherwise.

285

286

Examples:

287

288

(unwind-protect-case ()

289

(protected-form)

290

(:normal (format t \"This is only evaluated if PROTECTED-FORM executed normally.~%\"))

291

(:abort (format t \"This is only evaluated if PROTECTED-FORM aborted preemptively.~%\"))

292

(:always (format t \"This is evaluated in either case.~%\")))

293

294

(unwind-protect-case (aborted-p)

295

(protected-form)

296

(:always (perform-cleanup-if aborted-p)))

297

"

298

(check-type abort-flag (or null symbol))

299

(let ((gflag (gensym "FLAG+")))

300

`(let ((,gflag t))

301

(unwind-protect (multiple-value-prog1 ,protected-form (setf ,gflag nil))

302

(let ,(and abort-flag `((,abort-flag ,gflag)))

303

,@(loop for (cleanup-kind . forms) in clauses

304

collect (ecase cleanup-kind

305

(:normal `(when (not ,gflag) ,@forms))

306

(:abort `(when ,gflag ,@forms))

307

(:always `(progn ,@forms)))))))))

308

309

;;; Debugger

310

;; from hunchentoot

311

(defvar *catch-errors-p* nil

312

"When non-nil catch and log errors instead of invoking the debugger.")

313

314

(defgeneric maybe-invoke-debugger (condition)

315

(:documentation "This generic function is called whenever a

316

condition CONDITION is signaled in Hunchentoot. You might want to

317

specialize it on specific condition classes for debugging purposes.")

318

(:method (condition)

319

"The default method invokes the debugger with CONDITION if

320

*CATCH-ERRORS-P* is NIL."

321

(unless *catch-errors-p*

322

(invoke-debugger condition))))

323

324

(defmacro with-debugger (&body body)

325

"Executes BODY and invokes the debugger if an error is signaled and

326

*CATCH-ERRORS-P* is NIL."

327

`(handler-bind ((error #'maybe-invoke-debugger))

328

,@body))

329

330

(defmacro ignore-errors* (&body body)

331

"Like IGNORE-ERRORS, but observes *CATCH-ERRORS-P*."

332

`(ignore-errors (with-debugger ,@body)))

333

334

(defmacro handler-case* (expression &rest clauses)

335

"Like HANDLER-CASE, but observes *CATCH-ERRORS-P*."

336

`(handler-case (with-debugger ,expression)

337

,@clauses))

338

339

(defun get-backtrace ()

340

"Returns a string with a backtrace of what the Lisp system thinks is

341

the 'current' error."

342

(handler-case

343

(with-output-to-string (s)

344

(sb-debug:print-backtrace :stream s))

345

(error (condition)

346

(format nil "Could not generate backtrace: ~A." condition))))

347

348

;;; Meta

349

(define-condition meta-condition () ()

350

(:documentation "A condition which is signalled somewhere within the CLOS/MOP machinery."))

351

352

(define-condition missing-method (error meta-condition)

353

((method))

354

(:documentation "Missing CLOS method errors."))

355

356

(define-condition missing-methods (error meta-condition)

357

((methods))

358

(:documentation "Multiple missing CLOS methods errors."))

359

360

;;;; Wrapped

361

(define-condition wrapped-condition ()

362

((value :type condition :reader wrapped-condition-value))

363

(:documentation

364

"A container for transporting conditions - usually to another thread."))

365

366

(defun wrap-condition (condition)

367

"Wrap a condition. A non-error condition may also be wrapped, though it

368

will still be signaled with `signal'."

369

(make-condition

370

'wrapped-condition

371

:value (ctypecase condition

372

(symbol (make-condition condition))

373

(condition condition))))

374

375

(define-condition wrapped-error (wrapped-condition) ()

376

(:documentation "A container for transporting errors - usually to another thread."))

377

378

(defun wrap-error (condition)

379

"Wrap an error. A non-error condition may also be wrapped, though it

380

will still be signaled with `error'."

381

(make-condition

382

'wrapped-error

383

:value (ctypecase condition

384

(symbol (make-condition condition))

385

(condition condition))))