error.lisp 44.6 KB
Newer Older
dtc's avatar
dtc committed
1
;;; -*- Package: conditions; Log: code.log -*-
ram's avatar
ram committed
2
3
;;;
;;; **********************************************************************
4
5
6
7
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
8
  "$Header: src/code/error.lisp $")
9
;;;
ram's avatar
ram committed
10
11
12
13
14
15
16
17
;;; **********************************************************************
;;;
;;; This is a condition system for CMU Common Lisp.
;;; It was originally taken from some prototyping code written by KMP@Symbolics
;;; and massaged for our uses.
;;;

(in-package "CONDITIONS")
18
(use-package "EXTENSIONS")
19
(use-package "KERNEL")
ram's avatar
ram committed
20

21
22
(intl:textdomain "cmucl")

23
(in-package "KERNEL")
24
(export '(layout-invalid condition-function-name simple-control-error
toy's avatar
toy committed
25
	  simple-file-error simple-program-error simple-parse-error
26
          simple-style-warning simple-undefined-function
27
	  constant-modified
pmai's avatar
pmai committed
28
29
          #+stack-checking stack-overflow
          #+heap-overflow-check heap-overflow))
30

ram's avatar
ram committed
31
32
33
(in-package "LISP")
(export '(break error warn cerror
	  ;;
rtoy's avatar
rtoy committed
34
	  ;; The following are found in macros.lisp:
ram's avatar
ram committed
35
36
37
38
39
40
	  check-type assert etypecase ctypecase ecase ccase
	  ;;
	  ;; These are all the new things to export from "LISP" now that this
	  ;; proposal has been accepted.
	  *break-on-signals* *debugger-hook* signal handler-case handler-bind
	  ignore-errors define-condition make-condition with-simple-restart
41
	  with-condition-restarts
ram's avatar
ram committed
42
43
44
	  restart-case restart-bind restart-name restart-name find-restart
	  compute-restarts invoke-restart invoke-restart-interactively abort
	  continue muffle-warning store-value use-value invoke-debugger restart
45
46
	  condition warning style-warning serious-condition simple-condition
	  simple-warning simple-error simple-condition-format-control
47
48
	  simple-condition-format-arguments storage-condition
	  type-error type-error-datum
49
	  type-error-expected-type simple-type-error program-error parse-error
ram's avatar
ram committed
50
	  control-error stream-error stream-error-stream end-of-file file-error
51
52
	  file-error-pathname cell-error cell-error-name unbound-variable
	  undefined-function
ram's avatar
ram committed
53
54
	  arithmetic-error arithmetic-error-operation arithmetic-error-operands
	  package-error package-error-package division-by-zero
55
	  floating-point-overflow floating-point-underflow
56
57
	  floating-point-inexact floating-point-invalid-operation
	  #+x86 floating-point-denormal-operand))
ram's avatar
ram committed
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74

(in-package "CONDITIONS")

;;;; Keyword utilities.

(eval-when (eval compile load)

(defun parse-keyword-pairs (list keys)
  (do ((l list (cddr l))
       (k '() (list* (cadr l) (car l) k)))
      ((or (null l) (not (member (car l) keys)))
       (values (nreverse k) l))))

(defmacro with-keyword-pairs ((names expression &optional keywords-var)
			      &body forms)
  (let ((temp (member '&rest names)))
    (unless (= (length temp) 2)
75
      (simple-program-error (intl:gettext "&rest keyword is ~:[missing~;misplaced~].") temp))
ram's avatar
ram committed
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
    (let ((key-vars (ldiff names temp))
          (key-var (or keywords-var (gensym)))
          (rest-var (cadr temp)))
      (let ((keywords (mapcar #'(lambda (x)
				  (intern (string x) ext:*keyword-package*))
			      key-vars)))
        `(multiple-value-bind (,key-var ,rest-var)
             (parse-keyword-pairs ,expression ',keywords)
           (let ,(mapcar #'(lambda (var keyword)
			     `(,var (getf ,key-var ,keyword)))
			 key-vars keywords)
	     ,@forms))))))

) ;eval-when



;;;; Restarts.

95
96
;;; A list of lists of restarts.
;;;
ram's avatar
ram committed
97
98
(defvar *restart-clusters* '())

99
100
101
102
103
104
;;;  An ALIST (condition . restarts) which records the restarts currently
;;; associated with Condition.
;;;
(defvar *condition-restarts* ())

(defun compute-restarts (&optional condition)
105
  "Return a list of all the currently active restarts ordered from most
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
   recently established to less recently established.  If Condition is
   specified, then only restarts associated with Condition (or with no
   condition) will be returned."
  (let ((associated ())
	(other ()))
    (dolist (alist *condition-restarts*)
      (if (eq (car alist) condition)
	  (setq associated (cdr alist))
	  (setq other (append (cdr alist) other))))
    (collect ((res))
      (dolist (restart-cluster *restart-clusters*)
	(dolist (restart restart-cluster)
	  (when (and (or (not condition)
			 (member restart associated)
			 (not (member restart other)))
121
		     (funcall (restart-test-function restart) condition))
122
123
124
	    (res restart))))
      (res))))

ram's avatar
ram committed
125
126
127
128

(defun restart-print (restart stream depth)
  (declare (ignore depth))
  (if *print-escape*
129
      (print-unreadable-object (restart stream :type t :identity t))
ram's avatar
ram committed
130
131
132
133
134
135
      (restart-report restart stream)))

(defstruct (restart (:print-function restart-print))
  name
  function
  report-function
136
137
  interactive-function
  (test-function #'(lambda (cond) (declare (ignore cond)) t)))
ram's avatar
ram committed
138
139

(setf (documentation 'restart-name 'function)
140
      _N"Returns the name of the given restart object.")
ram's avatar
ram committed
141
142
143
144
145
146
147
148
149

(defun restart-report (restart stream)
  (funcall (or (restart-report-function restart)
               (let ((name (restart-name restart)))
		 #'(lambda (stream)
		     (if name (format stream "~S" name)
			      (format stream "~S" restart)))))
           stream))

150
(defmacro with-condition-restarts (condition-form restarts-form &body body)
151
  "WITH-CONDITION-RESTARTS Condition-Form Restarts-Form Form*
152
153
154
155
156
157
158
159
160
161
162
163
164
   Evaluates the Forms in a dynamic environment where the restarts in the list
   Restarts-Form are associated with the condition returned by Condition-Form.
   This allows FIND-RESTART, etc., to recognize restarts that are not related
   to the error currently being debugged.  See also RESTART-CASE."
  (let ((n-cond (gensym)))
    `(let ((*condition-restarts*
	    (cons (let ((,n-cond ,condition-form))
		    (cons ,n-cond
			  (append ,restarts-form
				  (cdr (assoc ,n-cond *condition-restarts*)))))
		  *condition-restarts*)))
       ,@body)))

ram's avatar
ram committed
165
(defmacro restart-bind (bindings &body forms)
166
  "Executes forms in a dynamic context where the given restart bindings are
ram's avatar
ram committed
167
168
169
170
171
172
173
174
   in effect.  Users probably want to use RESTART-CASE.  When clauses contain
   the same restart name, FIND-RESTART will find the first such clause."
  `(let ((*restart-clusters*
	  (cons (list
		 ,@(mapcar #'(lambda (binding)
			       (unless (or (car binding)
					   (member :report-function
						   binding :test #'eq))
175
176
				 (warn (intl:gettext "Unnamed restart does not have a ~
					report function -- ~S")
ram's avatar
ram committed
177
178
179
180
181
182
183
184
185
				       binding))
			       `(make-restart
				 :name ',(car binding)
				 :function ,(cadr binding)
				 ,@(cddr binding)))
			       bindings))
		*restart-clusters*)))
     ,@forms))

186
(defun find-restart (name &optional condition)
187
  "Returns the first restart named name.  If name is a restart, it is returned
ram's avatar
ram committed
188
   if it is currently active.  If no such restart is found, nil is returned.
189
190
191
192
193
194
195
   It is an error to supply nil as a name.  If Condition is specified and not
   NIL, then only restarts associated with that condition (or with no
   condition) will be returned."
  (find-if #'(lambda (x)
	       (or (eq x name)
		   (eq (restart-name x) name)))
	   (compute-restarts condition)))
ram's avatar
ram committed
196
197

(defun invoke-restart (restart &rest values)
198
  "Calls the function associated with the given restart, passing any given
ram's avatar
ram committed
199
200
201
202
   arguments.  If the argument restart is not a restart or a currently active
   non-nil restart name, then a control-error is signalled."
  (let ((real-restart (find-restart restart)))
    (unless real-restart
203
      (error 'simple-control-error
204
	     :format-control (intl:gettext "Restart ~S is not active.")
ram's avatar
ram committed
205
206
207
208
	     :format-arguments (list restart)))
    (apply (restart-function real-restart) values)))

(defun invoke-restart-interactively (restart)
209
  "Calls the function associated with the given restart, prompting for any
ram's avatar
ram committed
210
211
212
213
   necessary arguments.  If the argument restart is not a restart or a
   currently active non-nil restart name, then a control-error is signalled."
  (let ((real-restart (find-restart restart)))
    (unless real-restart
214
      (error 'simple-control-error
215
	     :format-control (intl:gettext "Restart ~S is not active.")
ram's avatar
ram committed
216
	     :format-arguments (list restart)))
217
    (%invoke-restart-interactively real-restart)))
ram's avatar
ram committed
218

219
220
221
222
223
224
225
226
227
228
229
;;;
;;; Like Invoke-Restart-Interactively, but don't check if the restart
;;; is currently active.  Used by the debugger.
;;;
(defun %invoke-restart-interactively (restart)
  (apply (restart-function restart)
	 (let ((interactive-function
		(restart-interactive-function restart)))
	   (if interactive-function
	       (funcall interactive-function)
	       '()))))
ram's avatar
ram committed
230

231
(eval-when (compile load eval)
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247

;;;
;;; Return a list of restarts with names NAMES, taking duplicate
;;; names into account.
;;;
(defun %find-restarts (names)
  (let ((all (compute-restarts)))
    (collect ((restarts))
      (dolist (name names (restarts))
	(let ((restart (find-if (lambda (x)
				  (or (eq x name)
				      (eq (restart-name x) name)))
				all)))
	  (restarts restart)
	  (setq all (delete restart all)))))))

248
249
250
;;; Wrap the restart-case expression in a with-condition-restarts if
;;; appropriate.  Gross, but it's what the book seems to say...
;;;
251
252
(defun munge-restart-case-expression (expression data env)
  (let ((exp (macroexpand expression env)))
253
254
255
256
257
258
259
260
261
262
263
264
    (if (consp exp)
	(let* ((name (car exp))
	       (args (if (eq name 'cerror) (cddr exp) (cdr exp))))
	  (if (member name '(signal error cerror warn))
	      (once-only ((n-cond `(coerce-to-condition
				    ,(first args)
				    (list ,@(rest args))
				    ',(case name
					(warn 'simple-warning)
					(signal 'simple-condition)
					(t 'simple-error))
				    ',name)))
265
266
267
268
269
		 `(with-condition-restarts ,n-cond
		      (%find-restarts ',(mapcar (lambda (x) (nth 0 x)) data))
		    ,(if (eq name 'cerror)
			 `(cerror ,(second expression) ,n-cond)
			 `(,name ,n-cond))))
270
271
272
273
	      expression))
	expression)))

); eval-when (compile load eval)
ram's avatar
ram committed
274

275
(defmacro restart-case (expression &body clauses &environment env)
276
  "(RESTART-CASE form
ram's avatar
ram committed
277
278
279
280
   {(case-name arg-list {keyword value}* body)}*)
   The form is evaluated in a dynamic context where the clauses have special
   meanings as points to which control may be transferred (see INVOKE-RESTART).
   When clauses contain the same case-name, FIND-RESTART will find the first
281
282
283
284
   such clause.  If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or
   macroexpands into such) then the signalled condition will be associated with
   the new restarts."
  (flet ((transform-keywords (&key report interactive test)
ram's avatar
ram committed
285
286
287
288
289
290
291
292
293
294
295
296
	   (let ((result '()))
	     (when report
	       (setq result (list* (if (stringp report)
				       `#'(lambda (stream)
					    (write-string ,report stream))
				       `#',report)
				   :report-function
				   result)))
	     (when interactive
	       (setq result (list* `#',interactive
				   :interactive-function
				   result)))
297
298
299
300
	     (when test
	       (setq result (list* `#',test
				   :test-function
				   result)))
ram's avatar
ram committed
301
302
303
304
	     (nreverse result))))
    (let ((block-tag (gensym))
	  (temp-var  (gensym))
	  (data
305
306
307
308
309
310
311
312
313
314
315
316
	   (mapcar #'(lambda (clause)
		       (with-keyword-pairs ((report interactive test
						    &rest forms)
					    (cddr clause))
			 (list (car clause) ;name=0
			       (gensym) ;tag=1
			       (transform-keywords :report report ;keywords=2
						   :interactive interactive
						   :test test)
			       (cadr clause) ;bvl=3
			       forms))) ;body=4
		   clauses)))
ram's avatar
ram committed
317
318
319
      `(block ,block-tag
	 (let ((,temp-var nil))
	   (tagbody
320
321
322
323
324
325
326
327
328
329
330
	    (restart-bind
		,(mapcar #'(lambda (datum)
			     (let ((name (nth 0 datum))
				   (tag  (nth 1 datum))
				   (keys (nth 2 datum)))
			       `(,name #'(lambda (&rest temp)
					   (setq ,temp-var temp)
					   (go ,tag))
				       ,@keys)))
			 data)
	      (return-from ,block-tag
331
			   ,(munge-restart-case-expression expression data env)))
332
333
334
335
336
337
338
339
340
341
342
343
344
345
	    ,@(mapcan #'(lambda (datum)
			  (let ((tag  (nth 1 datum))
				(bvl  (nth 3 datum))
				(body (nth 4 datum)))
			    (list tag
				  `(return-from ,block-tag
						(apply #'(lambda ,bvl ,@body)
						       ,temp-var)))))
		      data)))))))


;;; If just one body form, then don't use progn.  This allows restart-case to
;;; "see" calls to error, etc.
;;;
ram's avatar
ram committed
346
347
348
(defmacro with-simple-restart ((restart-name format-string
					     &rest format-arguments)
			       &body forms)
349
  "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments)
ram's avatar
ram committed
350
351
352
353
   body)
   If restart-name is not invoked, then all values returned by forms are
   returned.  If control is transferred to this restart, it immediately
   returns the values nil and t."
354
  `(restart-case ,(if (= (length forms) 1) (car forms) `(progn ,@forms))
ram's avatar
ram committed
355
356
357
358
359
360
361
362
363
     (,restart-name ()
        :report (lambda (stream)
		  (format stream ,format-string ,@format-arguments))
      (values nil t))))



;;;; Conditions.

364
(eval-when (compile load eval)
ram's avatar
ram committed
365

366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
(defstruct (condition-class (:include slot-class))
  ;;
  ;; List of CONDITION-SLOT structures for the direct slots of this class.
  (slots nil :type list)
  ;;
  ;; List of CONDITION-SLOT structures for all of the effective class slots of
  ;; this class.
  (class-slots nil :type list)
  ;;
  ;; Report function or NIL.
  (report nil :type (or function null))
  ;;
  ;; List of alternating initargs and initforms.
  (default-initargs () :type list)
  ;;
  ;; CPL as a list of class objects, with all non-condition classes removed.
382
383
384
385
386
387
  (cpl () :type list)
  ;;
  ;; A list of all the effective instance allocation slots of this class that
  ;; have a non-constant initform or default-initarg.  Values for these slots
  ;; must be computed in the dynamic environment of MAKE-CONDITION.
  (hairy-slots nil :type list))
ram's avatar
ram committed
388

389
); eval-when (compile load eval)
ram's avatar
ram committed
390

391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
(defstruct (condition
	    (:constructor make-condition-object (actual-initargs))
	    (:alternate-metaclass instance condition-class
				  make-condition-class))
		      
  (function-name nil)
  ;;
  ;; Actual initargs supplied to MAKE-CONDITION.
  (actual-initargs (required-argument) :type list)
  ;;
  ;; Plist mapping slot names to any values that were assigned or defaulted
  ;; after creation.
  (assigned-slots () :type list))


(defstruct condition-slot
  (name (required-argument) :type symbol)
  ;;
  ;; List of all applicable initargs.
  (initargs (required-argument) :type list)
  ;;
  ;; Names of reader and writer functions.
  (readers (required-argument) :type list)
  (writers (required-argument) :type list)
  ;;
  ;; True if :INITFORM was specified.
  (initform-p (required-argument) :type (member t nil))
  ;;
  ;; If a function, call it with no args.  Otherwise, the actual value.
  (initform (required-argument) :type t)
  ;;
  ;; Allocation of this slot.  Nil only until defaulted.
  (allocation nil :type (member :instance :class nil))
  ;;
  ;; If :class allocation, a cons whose car holds the value.
426
427
428
429
  (cell nil :type (or cons null))
  ;;
  ;; Slot documentation.
  (documentation nil :type (or null string)))
ram's avatar
ram committed
430

431
(eval-when (compile load eval)
432
433
  (setf (condition-class-cpl (kernel::find-class 'condition))
	(list (kernel::find-class 'condition))))
ram's avatar
ram committed
434

435
(setf (condition-class-report (kernel::find-class 'condition))
436
      #'(lambda (cond stream)
437
	  (format stream (intl:gettext "Condition ~S was signalled.") (type-of cond))))
ram's avatar
ram committed
438

439
(eval-when (compile load eval)
ram's avatar
ram committed
440

441
442
443
444
445
446
(defun find-condition-layout (name parent-types)
  (let* ((cpl (remove-duplicates
	       (reverse
		(reduce #'append
			(mapcar #'(lambda (x)
				    (condition-class-cpl
447
				     (kernel::find-class x)))
448
449
450
				parent-types)))))
	 (cond-layout (info type compiler-layout 'condition))
	 (olayout (info type compiler-layout name))
451
452
453
	 (new-inherits
	  (order-layout-inherits (concatenate 'simple-vector
					      (layout-inherits cond-layout)
454
					      (mapcar #'%class-layout cpl)))))
455
456
457
458
459
460
461
462
463
    (if (and olayout
	     (not (mismatch (layout-inherits olayout) new-inherits)))
	olayout
	(make-layout :class (make-undefined-class name)
		     :inherits new-inherits
		     :inheritance-depth -1
		     :length (layout-length cond-layout)))))

); EVAL-WHEN (COMPILE LOAD EVAL)
ram's avatar
ram committed
464

465
466
467
468
469

;;;; Condition reporting:

(defun %print-condition (s stream d)
  (declare (ignore d))
470
471
472
473
474
  (if (fboundp 'print-object)
      (print-object s stream)
      (real-print-condition s stream)))

(defun real-print-condition (s stream)
475
476
  (if *print-escape*
      (print-unreadable-object (s stream :identity t :type t))
477
      (dolist (class (condition-class-cpl (kernel::class-of s))
478
		     (error (intl:gettext "No REPORT?  Shouldn't happen!")))
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
	(let ((report (condition-class-report class)))
	  (when report
	    (return (funcall report s stream)))))))

;;;; Condition slots:

(defvar *empty-slot* '(empty))

(defun find-slot-default (class slot)
  (let ((initargs (condition-slot-initargs slot))
	(cpl (condition-class-cpl class)))
    (dolist (class cpl)
      (let ((default-initargs (condition-class-default-initargs class)))
	(dolist (initarg initargs)
	  (let ((val (getf default-initargs initarg *empty-slot*)))
	    (unless (eq val *empty-slot*)
	      (return-from find-slot-default
			   (if (functionp val)
			       (funcall val)
			       val)))))))
  
    (if (condition-slot-initform-p slot)
	(let ((initform (condition-slot-initform slot)))
	  (if (functionp initform)
	      (funcall initform)
	      initform))
505
	(error (intl:gettext "Condition slot is not bound: ~S")
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
	       (condition-slot-name slot)))))

(defun find-slot (classes name)
  (dolist (sclass classes nil)
    (dolist (slot (condition-class-slots sclass))
      (when (eq (condition-slot-name slot) name)
	(return-from find-slot slot)))))

(defun condition-writer-function (condition new-value name)
  (dolist (cslot (condition-class-class-slots
		  (layout-class (%instance-layout condition)))
		 (setf (getf (condition-assigned-slots condition) name)
		       new-value))
    (when (eq (condition-slot-name cslot) name)
      (return (setf (car (condition-slot-cell cslot)) new-value)))))

(defun condition-reader-function (condition name)
  (let ((class (layout-class (%instance-layout condition))))
    (dolist (cslot (condition-class-class-slots class))
      (when (eq (condition-slot-name cslot) name)
	(return-from condition-reader-function
		     (car (condition-slot-cell cslot)))))

    (let ((val (getf (condition-assigned-slots condition) name 
		     *empty-slot*)))
      (if (eq val *empty-slot*)
	  (let ((actual-initargs (condition-actual-initargs condition))
		(slot (find-slot (condition-class-cpl class) name)))
534
	    (unless slot
535
	      (error (intl:gettext "Slot ~S of ~S missing.") name condition))
536
537
538
539
540
541
542
543
544
545
	    ;;
	    ;; Loop over actual initargs because the order of
	    ;; actual initargs determines how slots are initialized.
	    (loop with slot-initargs = (condition-slot-initargs slot)
		  for (initarg init-value) on actual-initargs by #'cddr
		  if (member initarg slot-initargs) do
		    (return-from condition-reader-function
		      (setf (getf (condition-assigned-slots condition)
				  name)
			    init-value)))
546
547
548
549
550
551
	    (setf (getf (condition-assigned-slots condition) name)
		  (find-slot-default class slot)))
	  val))))


(defun make-condition (thing &rest args)
552
  "Make an instance of a condition object using the specified initargs."
553
554
  ;; Note: ANSI specifies no exceptional situations in this function.
  ;; signalling simple-type-error would not be wrong.
555
  (let* ((thing (if (symbolp thing)
556
		    (kernel::find-class thing)
557
558
559
		    thing))
	 (class (typecase thing
		  (condition-class thing)
560
561
562
563
		  (pcl::condition-class
		   ;; Punt to CLOS
		   (return-from make-condition
		     (apply #'make-instance thing args)))
564
		  (class
565
566
567
		   (error 'simple-type-error
			  :datum thing
			  :expected-type 'condition-class
568
			  :format-control (intl:gettext "~S is not a condition class.")
569
			  :format-arguments (list thing)))
570
		  (t
571
572
573
		   (error 'simple-type-error
			  :datum thing
			  :expected-type 'condition-class
574
			  :format-control (intl:gettext "Bad thing for class arg:~%  ~S")
575
			  :format-arguments (list thing)))))
576
	 (res (make-condition-object args)))
577
    (setf (%instance-layout res) (%class-layout class))
578
579
580
581
582
583
584
    ;;
    ;; Set any class slots with initargs present in this call.
    (dolist (cslot (condition-class-class-slots class))
      (dolist (initarg (condition-slot-initargs cslot))
	(let ((val (getf args initarg *empty-slot*)))
	  (unless (eq val *empty-slot*)
	    (setf (car (condition-slot-cell cslot)) val)))))
585
586
587
588
    ;;
    ;; Default any slots with non-constant defaults now.
    (dolist (hslot (condition-class-hairy-slots class))
      (when (dolist (initarg (condition-slot-initargs hslot) t)
wlott's avatar
wlott committed
589
	      (unless (eq (getf args initarg *empty-slot*) *empty-slot*)
590
591
592
		(return nil)))
	(setf (getf (condition-assigned-slots res) (condition-slot-name hslot))
	      (find-slot-default class hslot))))
593
594
595
596
597

    res))


;;;; DEFINE-CONDITION
ram's avatar
ram committed
598

599
600
601
602
603
604
(eval-when (compile load eval)
(defun %compiler-define-condition (name direct-supers layout)
  (multiple-value-bind (class old-layout)
		       (insured-find-class name #'condition-class-p
					   #'make-condition-class)
    (setf (layout-class layout) class)
605
606
    (setf (%class-direct-superclasses class)
	  (mapcar #'kernel::find-class direct-supers))
607
608
    (cond ((not old-layout)
	   (register-layout layout))
609
610
611
	  ((not *type-system-initialized*)
	   (setf (layout-class old-layout) class)
	   (setq layout old-layout)
612
	   (unless (eq (%class-layout class) layout)
613
	     (register-layout layout)))
614
615
	  ((redefine-layout-warning old-layout "current"
				    layout "new")
ram's avatar
ram committed
616
	   (register-layout layout :invalidate t))
617
	  ((not (%class-layout class))
ram's avatar
ram committed
618
	   (register-layout layout)))
619

620
    (setf (layout-info layout)
621
	  (layout-info (%class-layout (kernel::find-class 'condition))))
622

623
    (setf (kernel::find-class name) class)
624
    ;;
625
626
627
628
    ;; Initialize CPL slot.
    (setf (condition-class-cpl class)
	  (remove-if-not #'condition-class-p 
			 (std-compute-class-precedence-list class))))
629
630
631
632
  (undefined-value))

); eval-when (compile load eval)
  
633
634
635
636
637
638
639
640

;;; COMPUTE-EFFECTIVE-SLOTS  --  Internal
;;;
;;;   Compute the effective slots of class, copying inherited slots and
;;; side-effecting direct slots.
;;;
(defun compute-effective-slots (class)
  (collect ((res (copy-list (condition-class-slots class))))
641
    (dolist (sclass (cdr (condition-class-cpl class)))
642
643
      (dolist (sslot (condition-class-slots sclass))
	(let ((found (find (condition-slot-name sslot) (res)
644
			   :key #'condition-slot-name :test #'eq)))
645
646
647
648
649
650
651
652
653
654
655
656
657
	  (cond (found
		 (setf (condition-slot-initargs found)
		       (union (condition-slot-initargs found)
			      (condition-slot-initargs sslot)))
		 (unless (condition-slot-initform-p found)
		   (setf (condition-slot-initform-p found)
			 (condition-slot-initform-p sslot))
		   (setf (condition-slot-initform found)
			 (condition-slot-initform sslot)))
		 (unless (condition-slot-allocation found)
		   (setf (condition-slot-allocation found)
			 (condition-slot-allocation sslot))))
		(t
ram's avatar
Typo.    
ram committed
658
		 (res (copy-structure sslot)))))))
659
660
    (res)))

661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
(eval-when (compile load eval)
  (defvar *make-condition-accessor-methods* nil))

;;;
;;; List of condition slot readers and writers defined early.  Used to
;;; change them to generic functions when PCL is ready to do so.
;;; Alas, we have to keep this list around after readers/writers have
;;; been made generic functions because the PCL build process requires
;;; us to undefine generic functions, so we need to change the
;;; accessors back to normal functions when building PCL.
;;;
(defvar *early-condition-accessors* ())

(defun make-early-condition-accessors-generic (&optional (generic-p t))
  (dolist (elt *early-condition-accessors*)
    (destructuring-bind (condition slot accessor kind) elt
      (fmakunbound accessor)
      (let ((new (make-condition-accessor accessor condition slot
					  kind generic-p))) 
	(when generic-p
	  (eval new)))))
  (setq *make-condition-accessor-methods* generic-p))

(defun make-condition-accessor (accessor condition slot kind generic-p)
  (if generic-p
      (if (eq kind 'reader)
	  `(defmethod ,accessor ((x ,condition))
	     (condition-reader-function x ',slot))
	  `(defmethod ,accessor (nv (x ,condition))
	     (condition-writer-function x nv ',slot)))
      (progn
	(pushnew (list condition slot accessor kind)
		 *early-condition-accessors* :test #'equal)
	(setf (fdefinition accessor)
	      (if (eq kind 'reader)
		  (lambda (x)
		    (condition-reader-function x slot))
		  (lambda (nv x)
		    (condition-writer-function x nv slot)))))))
700

701
(defun %define-condition (name slots documentation report default-initargs)
702
  (when (info declaration recognized name)
703
    (error (intl:gettext "Condition already names a declaration: ~S.") name))
704
  (let ((class (kernel::find-class name)))
705
706
707
708
709
710
    (setf (slot-class-print-function class) #'%print-condition)
    (setf (condition-class-slots class) slots)
    (setf (condition-class-report class) report)
    (setf (condition-class-default-initargs class) default-initargs)
    (setf (documentation name 'type) documentation)
    
711
712
713
714
715
716
717
    (unless *make-condition-accessor-methods*
      (dolist (slot slots)
	(let ((slot-name (condition-slot-name slot)))
	  (dolist (reader (condition-slot-readers slot))
	    (make-condition-accessor reader name slot-name 'reader nil))
	  (dolist (writer (condition-slot-writers slot))
	    (make-condition-accessor writer name slot-name 'writer nil)))))
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
    ;;
    ;; Compute effective slots and set up the class and hairy slots (subsets of
    ;; the effective slots.)
    (let ((eslots (compute-effective-slots class))
	  (e-def-initargs
	   (reduce #'append
		   (mapcar #'condition-class-default-initargs
			   (condition-class-cpl class)))))
      (dolist (slot eslots)
	(ecase (condition-slot-allocation slot)
	  (:class
	   (unless (condition-slot-cell slot)
	     (setf (condition-slot-cell slot)
		   (list (if (condition-slot-initform-p slot)
			     (let ((initform (condition-slot-initform slot)))
			       (if (functionp initform)
				   (funcall initform)
				   initform))
			     *empty-slot*))))
	   (push slot (condition-class-class-slots class)))
ram's avatar
ram committed
738
739
	  ((:instance nil)
	   (setf (condition-slot-allocation slot) :instance)
740
741
	   (when (or (functionp (condition-slot-initform slot))
		     (dolist (initarg (condition-slot-initargs slot) nil)
ram's avatar
ram committed
742
		       (when (functionp (getf e-def-initargs initarg))
743
			 (return t))))
ram's avatar
ram committed
744
	     (push slot (condition-class-hairy-slots class))))))))
745
746
747
748
749
  name)


(defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
				 &body options)
750
  "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
751
   Define NAME as a condition type.  This new type inherits slots and its
752
753
   report function from the specified PARENT-TYPEs.  A slot spec is either
   a symbol denoting the name of the slot, or a list of the form:
754

755
756
757
     (slot-name {slot-option value}*)

   where slot-option is one of :READER, :WRITER, :ACCESSOR, :ALLOCATION,
758
   :INITARG, :INITFORM, :DOCUMENTATION, and :TYPE.
759
760
761
762
763
764
765

   Each overall option is of the form

     (option-name {value}*)

   where option-name is one of :DEFAULT-INITARGS, :DOCUMENTATION,
   and :REPORT.
766
767
768
769
770
771
772

   The :REPORT option is peculiar to DEFINE-CONDITION.  Its argument is either
   a string or a two-argument lambda or function name.  If a function, the
   function is called with the condition and stream to report the condition.
   If a string, the string is printed.

   Condition types are classes, but (as allowed by ANSI and not as described in
ram's avatar
ram committed
773
   CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs.  WITH-SLOTS and
774
775
776
777
778
   SLOT-VALUE may not be used on condition objects."
  (let* ((parent-types (or parent-types '(condition)))
	 (layout (find-condition-layout name parent-types))
	 (documentation nil)
	 (report nil)
779
	 (slot-name/accessors ())
780
781
782
783
784
785
	 (default-initargs ()))
    (collect ((slots)
	      (all-readers nil append)
	      (all-writers nil append))
      (dolist (spec slot-specs)
	(when (keywordp spec)
786
	  (warn (intl:gettext "Keyword slot name indicates probable syntax error:~%  ~S")
787
788
789
790
		spec))
	(let* ((spec (if (consp spec) spec (list spec)))
	       (slot-name (first spec))
	       (allocation :instance)
791
	       (documentation nil)
792
793
794
795
796
797
798
799
	       (initform-p nil)
	       initform)
	  (collect ((initargs)
		    (readers)
		    (writers))
	    (do ((options (rest spec) (cddr options)))
		((null options))
	      (unless (and (consp options) (consp (cdr options)))
800
		(simple-program-error (intl:gettext "Malformed condition slot spec:~%  ~S.")
801
                                      spec))
802
803
804
805
806
807
808
809
810
	      (let ((arg (second options)))
		(case (first options)
		  (:reader (readers arg))
		  (:writer (writers arg))
		  (:accessor
		   (readers arg)
		   (writers `(setf ,arg)))
		  (:initform
		   (when initform-p
811
		     (simple-program-error (intl:gettext "More than one :INITFORM in:~%  ~S")
812
                                           spec))
813
814
815
816
817
		   (setq initform-p t)
		   (setq initform arg))
		  (:initarg (initargs arg))
		  (:allocation
		   (setq allocation arg))
818
819
820
		  (:documentation
		   (when documentation
		     (simple-program-error
821
		      (intl:gettext "More than one slot :DOCUMENTATION in~%  ~s") spec))
822
823
		   (unless (stringp arg)
		     (simple-program-error
824
		      (intl:gettext "Slot :DOCUMENTATION is not a string in~%  ~s") spec))
825
		   (setq documentation arg))
826
827
		  (:type)
		  (t
828
		   (simple-program-error (intl:gettext "Unknown slot option:~%  ~S")
829
                                         (first options))))))
830

831
	    (push (list slot-name (readers) (writers)) slot-name/accessors)
832
833
834
835
836
837
838
839
	    (all-readers (readers))
	    (all-writers (writers))
	    (slots `(make-condition-slot
		     :name ',slot-name
		     :initargs ',(initargs)
		     :readers ',(readers)
		     :writers ',(writers)
		     :initform-p ',initform-p
840
		     :documentation ',documentation
841
842
843
844
845
846
847
		     :initform
		     ,(if (constantp initform)
			  `',(eval initform)
			  `#'(lambda () ,initform)))))))
      
      (dolist (option options)
	(unless (consp option)
848
	  (simple-program-error (intl:gettext "Bad option:~%  ~S") option))
849
850
851
852
853
854
855
856
857
	(case (first option)
	  (:documentation (setq documentation (second option)))
	  (:report
	   (let ((arg (second option)))
	     (setq report
		   (if (stringp arg)
		       `#'(lambda (condition stream)
			    (declare (ignore condition))
			    (write-string ,arg stream))
pw's avatar
pw committed
858
859
		       `#'(lambda (condition stream)
			    (funcall #',arg condition stream))))))
860
861
862
863
864
865
866
867
868
869
870
	  (:default-initargs
	   (do ((initargs (rest option) (cddr initargs)))
	       ((endp initargs))
	     (let ((val (second initargs)))
	       (setq default-initargs
		     (list* `',(first initargs)
			    (if (constantp val)
				`',(eval val)
				`#'(lambda () ,val))
			    default-initargs)))))
	  (t
871
	   (simple-program-error (intl:gettext "Unknown option: ~S") (first option)))))
872
873
874
875
876
877
878
879

      `(progn
	 (eval-when (compile load eval)
	   (%compiler-define-condition ',name ',parent-types ',layout))

	 (declaim (ftype (function (t) t) ,@(all-readers)))
	 (declaim (ftype (function (t t) t) ,@(all-writers)))

880
881
882
883
884
885
886
887
888
889
890
891
	 ,@(when *make-condition-accessor-methods*
	     (collect ((methods))
	       (dolist (elt slot-name/accessors)
		 (destructuring-bind (slot-name readers writers) elt
		   (dolist (reader readers)
		     (methods (make-condition-accessor
			       reader name slot-name 'reader t)))
		   (dolist (writer writers)
		     (methods (make-condition-accessor
			       writer name slot-name 'writer t)))))
	       (methods)))

892
893
894
895
896
	 (%define-condition ',name
			    (list ,@(slots))
			    ,documentation
			    ,report
			    (list ,@default-initargs))))))
ram's avatar
ram committed
897
898
899
900
901
902
903


;;;; HANDLER-BIND and SIGNAL.

(defvar *handler-clusters* nil)

(defmacro handler-bind (bindings &body forms)
904
  "(HANDLER-BIND ( {(type handler)}* )  body)
ram's avatar
ram committed
905
906
907
908
909
   Executes body in a dynamic context where the given handler bindings are
   in effect.  Each handler must take the condition being signalled as an
   argument.  The bindings are searched first to last in the event of a
   signalled condition."
  (unless (every #'(lambda (x) (and (listp x) (= (length x) 2))) bindings)
910
    (simple-program-error (intl:gettext "Ill-formed handler bindings.")))
ram's avatar
ram committed
911
912
913
914
  `(let ((*handler-clusters*
	  (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x)))
				bindings))
		*handler-clusters*)))
ram's avatar
ram committed
915
     (multiple-value-prog1
916
      (progn ,@forms)
ram's avatar
ram committed
917
      ;; Wait for any float exceptions
918
      #+x87 (float-wait))))
ram's avatar
ram committed
919
920


921
;;;; Condition definitions.
ram's avatar
ram committed
922

923
(define-condition serious-condition (condition)())
ram's avatar
ram committed
924

925
(define-condition error (serious-condition) ())
ram's avatar
ram committed
926
927

(define-condition warning (condition) ())
928
(define-condition style-warning (warning) ())
ram's avatar
ram committed
929
930

(defun simple-condition-printer (condition stream)
931
  (apply #'format stream (simple-condition-format-control condition)
ram's avatar
ram committed
932
933
	 		 (simple-condition-format-arguments condition)))

934
935
936
937
938
939
(define-condition simple-condition ()
  ((format-control :reader simple-condition-format-control
		   :initarg :format-control)
   (format-arguments :reader simple-condition-format-arguments
		     :initarg :format-arguments
		     :initform '()))
ram's avatar
ram committed
940
941
  (:report simple-condition-printer))

942
943
(define-condition simple-warning (simple-condition warning) ())
(define-condition simple-style-warning (simple-condition style-warning) ())
ram's avatar
ram committed
944
945

(defun print-simple-error (condition stream)
946
  (format stream (intl:gettext "~&~@<Error in function ~S:  ~3i~:_~?~:>")
947
948
949
	  (condition-function-name condition)
	  (simple-condition-format-control condition)
	  (simple-condition-format-arguments condition)))
ram's avatar
ram committed
950

951
(define-condition simple-error (simple-condition error) ()
952
953
  ;; This is the condition type used by error and cerror when
  ;; a format-control string is supplied as the first argument.
954
  (:report print-simple-error))
ram's avatar
ram committed
955
956
957

(define-condition storage-condition (serious-condition) ())

958
959
960
961
962
#+stack-checking
(define-condition stack-overflow (storage-condition)
  ()
  (:report (lambda (condition stream)
	     (declare (ignore condition))
963
	     (format stream _"Control stack overflow"))))
964

965
966
967
968
969
#+heap-overflow-check
(define-condition heap-overflow (storage-condition)
  ()
  (:report (lambda (condition stream)
	     (declare (ignore condition))
970
	     (format stream _"Heap (dynamic space) overflow"))))
971

ram's avatar
ram committed
972
(define-condition type-error (error)
973
974
  ((datum :reader type-error-datum :initarg :datum)
   (expected-type :reader type-error-expected-type :initarg :expected-type))
975
976
  (:report
   (lambda (condition stream)
977
     (format stream (intl:gettext "~@<Type-error in ~S:  ~3i~:_~S is not of type ~S~:>")
978
	     (condition-function-name condition)
979
980
	     (type-error-datum condition)
	     (type-error-expected-type condition)))))
ram's avatar
ram committed
981

982
(define-condition simple-type-error (simple-condition type-error) ())
ram's avatar
ram committed
983

984
985
986
987
(define-condition kernel:layout-invalid (type-error)
  ()
  (:report
   (lambda (condition stream)
988
989
     (format stream (intl:gettext "Layout-invalid error in ~S:~@
		     Type test of class ~S was passed obsolete instance:~%  ~S")
990
	     (condition-function-name condition)
991
992
993
	     (kernel:class-proper-name (type-error-expected-type condition))
	     (type-error-datum condition)))))

ram's avatar
ram committed
994
(define-condition case-failure (type-error)
995
996
  ((name :reader case-failure-name :initarg :name)
   (possibilities :reader case-failure-possibilities :initarg :possibilities))
ram's avatar
ram committed
997
998
  (:report
    (lambda (condition stream)
999
      (format stream (intl:gettext "~@<~S fell through ~S expression.  ~:_Wanted one of ~:S.~:>")
ram's avatar
ram committed
1000
1001
1002
1003
1004
1005
	      (type-error-datum condition)
	      (case-failure-name condition)
	      (case-failure-possibilities condition)))))


(define-condition program-error (error) ())
1006
1007
1008
(define-condition parse-error   (error) ())
(define-condition control-error (error) ())
(define-condition stream-error  (error)
1009
  ((stream :reader stream-error-stream :initarg :stream)))
ram's avatar
ram committed
1010

1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
(defun print-reference (reference stream)
  (ecase (car reference)
    (:amop
     (format stream "AMOP")
     (format stream ", ")
     (destructuring-bind (type data) (cdr reference)
       (ecase type
         (:generic-function (format stream "Generic Function ~S" data))
         (:section (format stream "Section ~{~D~^.~}" data)))))
    (:ansi-cl
     (format stream "The ANSI Standard")
     (format stream ", ")
     (destructuring-bind (type data) (cdr reference)
       (ecase type
         (:function (format stream "Function ~S" data))
         (:special-operator (format stream "Special Operator ~S" data))
         (:macro (format stream "Macro ~S" data))
         (:section (format stream "Section ~{~D~^.~}" data))
         (:glossary (format stream "Glossary entry for ~S" data))
         (:issue (format stream "writeup for Issue ~A" data)))))
    #+nil
    (:cmucl
     (format stream "The CMUCL Manual")
     (format stream ", ")
     (destructuring-bind (type data) (cdr reference)
       (ecase type
         (:node (format stream "Node ~S" data))
         (:variable (format stream "Variable ~S" data))
         (:function (format stream "Function ~S" data)))))
    ;; FIXME: other documents (e.g. CLIM, Franz documentation :-)
    ))

(defun print-references (refs stream)
  (unless (or *print-escape* *print-readably*)
    (when refs
      (format stream "~&See also:~%")
      (pprint-logical-block (stream refs :per-line-prefix "  ")
	(do* ((rs refs (cdr rs))
	      (r (car rs) (car rs)))
	     ((null rs))
	  (print-reference r stream)
	  (unless (null (cdr rs))
	    (terpri stream)))))))

(define-condition reference-condition ()
  ((references :initarg :references
	       :reader reference-condition-references)))

1059
1060
1061
(define-condition end-of-file (stream-error) ()
  (:report
   (lambda (condition stream)
1062
     (format stream (intl:gettext "End-of-File on ~S")
1063
	     (stream-error-stream condition)))))
ram's avatar
ram committed
1064

1065
1066
(define-condition file-error (error)
  ((pathname :reader file-error-pathname :initarg :pathname)))
ram's avatar
ram committed
1067

1068
;;; INTERNAL
1069
(define-condition simple-program-error (simple-condition program-error)())
emarsden's avatar
   
emarsden committed
1070
(define-condition simple-parse-error (simple-condition parse-error)())
1071
(define-condition simple-control-error (simple-condition control-error)())
emarsden's avatar
   
emarsden committed
1072
(define-condition simple-stream-error (simple-condition stream-error) ())
1073

1074
1075
1076
(define-condition simple-file-error (simple-condition file-error) ()
  (:report
   (lambda (condition stream)
1077
     (format stream (intl:gettext "~&~@<File-error in function ~S:  ~3i~:_~?~:>")
1078
1079
1080
1081
	     (condition-function-name condition)
	     (simple-condition-format-control condition)
	     (simple-condition-format-arguments condition)))))

1082
1083
(define-condition package-error (error)
  ((package :reader package-error-package :initarg :package)))
ram's avatar
ram committed
1084

1085
1086
(define-condition cell-error (error)
  ((name :reader cell-error-name :initarg :name)))
ram's avatar
ram committed
1087
1088

(define-condition unbound-variable (cell-error) ()
1089
1090
1091
  (:report
   (lambda (condition stream)
     (format stream
1092
	     (intl:gettext "Error in ~S:  the variable ~S is unbound.")
1093
	     (condition-function-name condition)
1094
	     (cell-error-name condition)))))
ram's avatar
ram committed
1095
1096
  
(define-condition undefined-function (cell-error) ()
1097
1098
1099
  (:report
   (lambda (condition stream)
     (format stream
1100
	     (intl:gettext "Error in ~S:  the function ~S is undefined.")
1101
	     (condition-function-name condition)
1102
	     (cell-error-name condition)))))
ram's avatar
ram committed
1103

1104
1105
1106
(define-condition simple-undefined-function (simple-condition
					     undefined-function) ())

1107
(define-condition constant-modified (reference-condition warning)
1108
1109
  ((function-name :initarg :function-name :reader constant-modified-function-name))
  (:report (lambda (c s)
1110
1111
             (format s (intl:gettext "~@<Destructive function ~S called on ~
                         constant data.~@:>")
1112
1113
1114
                     (constant-modified-function-name c))
	     (print-references (reference-condition-references c) s)))
  (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3)))))
1115
  
1116
(define-condition arithmetic-error (error)
ram's avatar
ram committed
1117
1118
  ((operation :reader arithmetic-error-operation :initarg :operation
	      :initform nil)
1119
   (operands :reader arithmetic-error-operands :initarg :operands))
1120
  (:report (lambda (condition stream)
1121
	     (format stream (intl:gettext "Arithmetic error ~S signalled.")
1122
1123
		     (type-of condition))
	     (when (arithmetic-error-operation condition)
1124
	       (format stream (intl:gettext "~%Operation was ~S, operands ~S.")
1125
1126
		       (arithmetic-error-operation condition)
		       (arithmetic-error-operands condition))))))
ram's avatar
ram committed
1127
1128
1129
1130

(define-condition division-by-zero         (arithmetic-error) ())
(define-condition floating-point-overflow  (arithmetic-error) ())
(define-condition floating-point-underflow (arithmetic-error) ())
1131
(define-condition floating-point-inexact   (arithmetic-error) ())
1132
(define-condition floating-point-invalid-operation   (arithmetic-error) ())
1133
1134
#+x86
(define-condition floating-point-denormal-operand    (arithmetic-error) ())
ram's avatar
ram committed
1135

1136
1137
1138
1139
1140
1141
;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that
;;; compiler warnings can be emitted as appropriate.
;;;
(define-condition parse-unknown-type (condition)
  ((specifier :reader parse-unknown-type-specifier :initarg :specifier)))

ram's avatar
ram committed
1142
1143
1144

;;;; HANDLER-CASE and IGNORE-ERRORS.

1145
1146
1147
;;; This macro doesn't work in older version of CMUCL system due to lossage
;;; in closing over tags.  The previous version sets up unique run-time tags.
;;;
ram's avatar
ram committed
1148
(defmacro handler-case (form &rest cases)
1149
  "(HANDLER-CASE form
ram's avatar
ram committed
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
   { (type ([var]) body) }* )
   Executes form in a context with handlers established for the condition
   types.  A peculiar property allows type to be :no-error.  If such a clause
   occurs, and form returns normally, all its values are passed to this clause
   as if by MULTIPLE-VALUE-CALL.  The :no-error clause accepts more than one
   var specification."
  (let ((no-error-clause (assoc ':no-error cases)))
    (if no-error-clause
	(let ((normal-return (make-symbol "normal-return"))
	      (error-return  (make-symbol "error-return")))
	  `(block ,error-return
1161
	     (multiple-value-call (lambda ,@(cdr no-error-clause))
ram's avatar
ram committed
1162
1163
1164
1165
1166
1167
	       (block ,normal-return
		 (return-from ,error-return
		   (handler-case (return-from ,normal-return ,form)
		     ,@(remove no-error-clause cases)))))))
	(let ((tag (gensym))
	      (var (gensym))
1168
	      (annotated-cases (mapcar (lambda (case) (cons (gensym) case))
ram's avatar
ram committed
1169
1170
1171
				       cases)))
	  `(block ,tag
	     (let ((,var nil))
1172
	       (declare (ignorable ,var))
ram's avatar
ram committed
1173
	       (tagbody
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
		  (handler-bind
		      ,(mapcar (lambda (annotated-case)
				 (list (cadr annotated-case)
				       `#'(lambda (temp)
					    ,(if (caddr annotated-case)
						 `(setq ,var temp)
						 '(declare (ignore temp)))
					    (go ,(car annotated-case)))))
			       annotated-cases)
		    (return-from ,tag
1184
1185
		      #-x87 ,form
		      #+x87 (multiple-value-prog1 ,form
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
			      ;; Need to catch FP errors here!
			      (kernel::float-wait))))
		  ,@(mapcan
		     (lambda (annotated-case)
		       (list (car annotated-case)
			     (let ((body (cdddr annotated-case)))
			       `(return-from
				 ,tag
				  ,(if (caddr annotated-case)
				       `(let ((,(caaddr annotated-case) ,var))
					  ,@body)
				       `(locally ,@body))))))
		     annotated-cases))))))))
ram's avatar
ram committed
1199
1200

(defmacro ignore-errors (&rest forms)
1201
  "Executes forms after establishing a handler for all error conditions that
ram's avatar
ram committed
1202
1203
1204
1205
   returns from this form nil and the condition signalled."
  `(handler-case (progn ,@forms)
     (error (condition) (values nil condition))))

Raymond Toy's avatar
Raymond Toy committed
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226

;;;; Reader

(define-condition standard-readtable-modified-error (reference-condition error)
  ((operation :initarg :operation
	      :reader standard-readtable-modified-operation))
  (:report (lambda (condition stream)
	     (format stream "~S would modify the standard readtable."
		     (standard-readtable-modified-operation condition))))
  (:default-initargs :references `((:ansi-cl :section (2 1 1 2))
				   (:ansi-cl :glossary "standard readtable"))))

;;;; Pprint dispatch

(define-condition standard-pprint-dispatch-table-modified-error (reference-condition error)
  ((operation :initarg :operation
	      :reader standard-pprint-dispatch-table-modified-operation))
  (:report (lambda (condition stream)
	     (format stream "~S would modify the standard pprint dispatch table."
		     (standard-pprint-dispatch-table-modified-operation condition))))
  (:default-initargs :references `((:ansi-cl :glossary "standard pprint dispatch table"))))
ram's avatar
ram committed
1227
1228
1229
1230
1231


;;;; Restart definitions.

(define-condition abort-failure (control-error) ()
1232
1233
  (:report (lambda (condition stream)
	     (declare (ignore condition))
1234
	     (write-string (intl:gettext "Found an \"abort\" restart that failed to transfer control dynamically.")
1235
			   stream))))
ram's avatar
ram committed
1236
1237
1238