/[cmucl]/src/code/error.lisp
ViewVC logotype

Contents of /src/code/error.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.91 - (show annotations)
Tue Apr 20 17:57:44 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.90: +38 -38 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Package: conditions; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/error.lisp,v 1.91 2010/04/20 17:57:44 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This is a condition system for CMU Common Lisp.
13 ;;; It was originally taken from some prototyping code written by KMP@Symbolics
14 ;;; and massaged for our uses.
15 ;;;
16
17 (in-package "CONDITIONS")
18 (use-package "EXTENSIONS")
19 (use-package "KERNEL")
20
21 (intl:textdomain "cmucl")
22
23 (in-package "KERNEL")
24 (export '(layout-invalid condition-function-name simple-control-error
25 simple-file-error simple-program-error simple-parse-error
26 simple-style-warning simple-undefined-function
27 constant-modified
28 #+stack-checking stack-overflow
29 #+heap-overflow-check heap-overflow))
30
31 (in-package "LISP")
32 (export '(break error warn cerror
33 ;;
34 ;; The following are found in macros.lisp:
35 check-type assert etypecase ctypecase ecase ccase
36 ;;
37 ;; These are all the new things to export from "LISP" now that this
38 ;; proposal has been accepted.
39 *break-on-signals* *debugger-hook* signal handler-case handler-bind
40 ignore-errors define-condition make-condition with-simple-restart
41 with-condition-restarts
42 restart-case restart-bind restart-name restart-name find-restart
43 compute-restarts invoke-restart invoke-restart-interactively abort
44 continue muffle-warning store-value use-value invoke-debugger restart
45 condition warning style-warning serious-condition simple-condition
46 simple-warning simple-error simple-condition-format-control
47 simple-condition-format-arguments storage-condition
48 type-error type-error-datum
49 type-error-expected-type simple-type-error program-error parse-error
50 control-error stream-error stream-error-stream end-of-file file-error
51 file-error-pathname cell-error cell-error-name unbound-variable
52 undefined-function
53 arithmetic-error arithmetic-error-operation arithmetic-error-operands
54 package-error package-error-package division-by-zero
55 floating-point-overflow floating-point-underflow
56 floating-point-inexact floating-point-invalid-operation))
57
58 (in-package "CONDITIONS")
59
60 ;;;; Keyword utilities.
61
62 (eval-when (eval compile load)
63
64 (defun parse-keyword-pairs (list keys)
65 (do ((l list (cddr l))
66 (k '() (list* (cadr l) (car l) k)))
67 ((or (null l) (not (member (car l) keys)))
68 (values (nreverse k) l))))
69
70 (defmacro with-keyword-pairs ((names expression &optional keywords-var)
71 &body forms)
72 (let ((temp (member '&rest names)))
73 (unless (= (length temp) 2)
74 (simple-program-error (intl:gettext "&rest keyword is ~:[missing~;misplaced~].") temp))
75 (let ((key-vars (ldiff names temp))
76 (key-var (or keywords-var (gensym)))
77 (rest-var (cadr temp)))
78 (let ((keywords (mapcar #'(lambda (x)
79 (intern (string x) ext:*keyword-package*))
80 key-vars)))
81 `(multiple-value-bind (,key-var ,rest-var)
82 (parse-keyword-pairs ,expression ',keywords)
83 (let ,(mapcar #'(lambda (var keyword)
84 `(,var (getf ,key-var ,keyword)))
85 key-vars keywords)
86 ,@forms))))))
87
88 ) ;eval-when
89
90
91
92 ;;;; Restarts.
93
94 ;;; A list of lists of restarts.
95 ;;;
96 (defvar *restart-clusters* '())
97
98 ;;; An ALIST (condition . restarts) which records the restarts currently
99 ;;; associated with Condition.
100 ;;;
101 (defvar *condition-restarts* ())
102
103 (defun compute-restarts (&optional condition)
104 "Return a list of all the currently active restarts ordered from most
105 recently established to less recently established. If Condition is
106 specified, then only restarts associated with Condition (or with no
107 condition) will be returned."
108 (let ((associated ())
109 (other ()))
110 (dolist (alist *condition-restarts*)
111 (if (eq (car alist) condition)
112 (setq associated (cdr alist))
113 (setq other (append (cdr alist) other))))
114 (collect ((res))
115 (dolist (restart-cluster *restart-clusters*)
116 (dolist (restart restart-cluster)
117 (when (and (or (not condition)
118 (member restart associated)
119 (not (member restart other)))
120 (funcall (restart-test-function restart) condition))
121 (res restart))))
122 (res))))
123
124
125 (defun restart-print (restart stream depth)
126 (declare (ignore depth))
127 (if *print-escape*
128 (print-unreadable-object (restart stream :type t :identity t))
129 (restart-report restart stream)))
130
131 (defstruct (restart (:print-function restart-print))
132 name
133 function
134 report-function
135 interactive-function
136 (test-function #'(lambda (cond) (declare (ignore cond)) t)))
137
138 (setf (documentation 'restart-name 'function)
139 _N"Returns the name of the given restart object.")
140
141 (defun restart-report (restart stream)
142 (funcall (or (restart-report-function restart)
143 (let ((name (restart-name restart)))
144 #'(lambda (stream)
145 (if name (format stream "~S" name)
146 (format stream "~S" restart)))))
147 stream))
148
149 (defmacro with-condition-restarts (condition-form restarts-form &body body)
150 "WITH-CONDITION-RESTARTS Condition-Form Restarts-Form Form*
151 Evaluates the Forms in a dynamic environment where the restarts in the list
152 Restarts-Form are associated with the condition returned by Condition-Form.
153 This allows FIND-RESTART, etc., to recognize restarts that are not related
154 to the error currently being debugged. See also RESTART-CASE."
155 (let ((n-cond (gensym)))
156 `(let ((*condition-restarts*
157 (cons (let ((,n-cond ,condition-form))
158 (cons ,n-cond
159 (append ,restarts-form
160 (cdr (assoc ,n-cond *condition-restarts*)))))
161 *condition-restarts*)))
162 ,@body)))
163
164 (defmacro restart-bind (bindings &body forms)
165 "Executes forms in a dynamic context where the given restart bindings are
166 in effect. Users probably want to use RESTART-CASE. When clauses contain
167 the same restart name, FIND-RESTART will find the first such clause."
168 `(let ((*restart-clusters*
169 (cons (list
170 ,@(mapcar #'(lambda (binding)
171 (unless (or (car binding)
172 (member :report-function
173 binding :test #'eq))
174 (warn (intl:gettext "Unnamed restart does not have a ~
175 report function -- ~S")
176 binding))
177 `(make-restart
178 :name ',(car binding)
179 :function ,(cadr binding)
180 ,@(cddr binding)))
181 bindings))
182 *restart-clusters*)))
183 ,@forms))
184
185 (defun find-restart (name &optional condition)
186 "Returns the first restart named name. If name is a restart, it is returned
187 if it is currently active. If no such restart is found, nil is returned.
188 It is an error to supply nil as a name. If Condition is specified and not
189 NIL, then only restarts associated with that condition (or with no
190 condition) will be returned."
191 (find-if #'(lambda (x)
192 (or (eq x name)
193 (eq (restart-name x) name)))
194 (compute-restarts condition)))
195
196 (defun invoke-restart (restart &rest values)
197 "Calls the function associated with the given restart, passing any given
198 arguments. If the argument restart is not a restart or a currently active
199 non-nil restart name, then a control-error is signalled."
200 (let ((real-restart (find-restart restart)))
201 (unless real-restart
202 (error 'simple-control-error
203 :format-control (intl:gettext "Restart ~S is not active.")
204 :format-arguments (list restart)))
205 (apply (restart-function real-restart) values)))
206
207 (defun invoke-restart-interactively (restart)
208 "Calls the function associated with the given restart, prompting for any
209 necessary arguments. If the argument restart is not a restart or a
210 currently active non-nil restart name, then a control-error is signalled."
211 (let ((real-restart (find-restart restart)))
212 (unless real-restart
213 (error 'simple-control-error
214 :format-control (intl:gettext "Restart ~S is not active.")
215 :format-arguments (list restart)))
216 (%invoke-restart-interactively real-restart)))
217
218 ;;;
219 ;;; Like Invoke-Restart-Interactively, but don't check if the restart
220 ;;; is currently active. Used by the debugger.
221 ;;;
222 (defun %invoke-restart-interactively (restart)
223 (apply (restart-function restart)
224 (let ((interactive-function
225 (restart-interactive-function restart)))
226 (if interactive-function
227 (funcall interactive-function)
228 '()))))
229
230 (eval-when (compile load eval)
231
232 ;;;
233 ;;; Return a list of restarts with names NAMES, taking duplicate
234 ;;; names into account.
235 ;;;
236 (defun %find-restarts (names)
237 (let ((all (compute-restarts)))
238 (collect ((restarts))
239 (dolist (name names (restarts))
240 (let ((restart (find-if (lambda (x)
241 (or (eq x name)
242 (eq (restart-name x) name)))
243 all)))
244 (restarts restart)
245 (setq all (delete restart all)))))))
246
247 ;;; Wrap the restart-case expression in a with-condition-restarts if
248 ;;; appropriate. Gross, but it's what the book seems to say...
249 ;;;
250 (defun munge-restart-case-expression (expression data env)
251 (let ((exp (macroexpand expression env)))
252 (if (consp exp)
253 (let* ((name (car exp))
254 (args (if (eq name 'cerror) (cddr exp) (cdr exp))))
255 (if (member name '(signal error cerror warn))
256 (once-only ((n-cond `(coerce-to-condition
257 ,(first args)
258 (list ,@(rest args))
259 ',(case name
260 (warn 'simple-warning)
261 (signal 'simple-condition)
262 (t 'simple-error))
263 ',name)))
264 `(with-condition-restarts ,n-cond
265 (%find-restarts ',(mapcar (lambda (x) (nth 0 x)) data))
266 ,(if (eq name 'cerror)
267 `(cerror ,(second expression) ,n-cond)
268 `(,name ,n-cond))))
269 expression))
270 expression)))
271
272 ); eval-when (compile load eval)
273
274 (defmacro restart-case (expression &body clauses &environment env)
275 "(RESTART-CASE form
276 {(case-name arg-list {keyword value}* body)}*)
277 The form is evaluated in a dynamic context where the clauses have special
278 meanings as points to which control may be transferred (see INVOKE-RESTART).
279 When clauses contain the same case-name, FIND-RESTART will find the first
280 such clause. If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or
281 macroexpands into such) then the signalled condition will be associated with
282 the new restarts."
283 (flet ((transform-keywords (&key report interactive test)
284 (let ((result '()))
285 (when report
286 (setq result (list* (if (stringp report)
287 `#'(lambda (stream)
288 (write-string ,report stream))
289 `#',report)
290 :report-function
291 result)))
292 (when interactive
293 (setq result (list* `#',interactive
294 :interactive-function
295 result)))
296 (when test
297 (setq result (list* `#',test
298 :test-function
299 result)))
300 (nreverse result))))
301 (let ((block-tag (gensym))
302 (temp-var (gensym))
303 (data
304 (mapcar #'(lambda (clause)
305 (with-keyword-pairs ((report interactive test
306 &rest forms)
307 (cddr clause))
308 (list (car clause) ;name=0
309 (gensym) ;tag=1
310 (transform-keywords :report report ;keywords=2
311 :interactive interactive
312 :test test)
313 (cadr clause) ;bvl=3
314 forms))) ;body=4
315 clauses)))
316 `(block ,block-tag
317 (let ((,temp-var nil))
318 (tagbody
319 (restart-bind
320 ,(mapcar #'(lambda (datum)
321 (let ((name (nth 0 datum))
322 (tag (nth 1 datum))
323 (keys (nth 2 datum)))
324 `(,name #'(lambda (&rest temp)
325 (setq ,temp-var temp)
326 (go ,tag))
327 ,@keys)))
328 data)
329 (return-from ,block-tag
330 ,(munge-restart-case-expression expression data env)))
331 ,@(mapcan #'(lambda (datum)
332 (let ((tag (nth 1 datum))
333 (bvl (nth 3 datum))
334 (body (nth 4 datum)))
335 (list tag
336 `(return-from ,block-tag
337 (apply #'(lambda ,bvl ,@body)
338 ,temp-var)))))
339 data)))))))
340
341
342 ;;; If just one body form, then don't use progn. This allows restart-case to
343 ;;; "see" calls to error, etc.
344 ;;;
345 (defmacro with-simple-restart ((restart-name format-string
346 &rest format-arguments)
347 &body forms)
348 "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments)
349 body)
350 If restart-name is not invoked, then all values returned by forms are
351 returned. If control is transferred to this restart, it immediately
352 returns the values nil and t."
353 `(restart-case ,(if (= (length forms) 1) (car forms) `(progn ,@forms))
354 (,restart-name ()
355 :report (lambda (stream)
356 (format stream ,format-string ,@format-arguments))
357 (values nil t))))
358
359
360
361 ;;;; Conditions.
362
363 (eval-when (compile load eval)
364
365 (defstruct (condition-class (:include slot-class))
366 ;;
367 ;; List of CONDITION-SLOT structures for the direct slots of this class.
368 (slots nil :type list)
369 ;;
370 ;; List of CONDITION-SLOT structures for all of the effective class slots of
371 ;; this class.
372 (class-slots nil :type list)
373 ;;
374 ;; Report function or NIL.
375 (report nil :type (or function null))
376 ;;
377 ;; List of alternating initargs and initforms.
378 (default-initargs () :type list)
379 ;;
380 ;; CPL as a list of class objects, with all non-condition classes removed.
381 (cpl () :type list)
382 ;;
383 ;; A list of all the effective instance allocation slots of this class that
384 ;; have a non-constant initform or default-initarg. Values for these slots
385 ;; must be computed in the dynamic environment of MAKE-CONDITION.
386 (hairy-slots nil :type list))
387
388 ); eval-when (compile load eval)
389
390 (defstruct (condition
391 (:constructor make-condition-object (actual-initargs))
392 (:alternate-metaclass instance condition-class
393 make-condition-class))
394
395 (function-name nil)
396 ;;
397 ;; Actual initargs supplied to MAKE-CONDITION.
398 (actual-initargs (required-argument) :type list)
399 ;;
400 ;; Plist mapping slot names to any values that were assigned or defaulted
401 ;; after creation.
402 (assigned-slots () :type list))
403
404
405 (defstruct condition-slot
406 (name (required-argument) :type symbol)
407 ;;
408 ;; List of all applicable initargs.
409 (initargs (required-argument) :type list)
410 ;;
411 ;; Names of reader and writer functions.
412 (readers (required-argument) :type list)
413 (writers (required-argument) :type list)
414 ;;
415 ;; True if :INITFORM was specified.
416 (initform-p (required-argument) :type (member t nil))
417 ;;
418 ;; If a function, call it with no args. Otherwise, the actual value.
419 (initform (required-argument) :type t)
420 ;;
421 ;; Allocation of this slot. Nil only until defaulted.
422 (allocation nil :type (member :instance :class nil))
423 ;;
424 ;; If :class allocation, a cons whose car holds the value.
425 (cell nil :type (or cons null))
426 ;;
427 ;; Slot documentation.
428 (documentation nil :type (or null string)))
429
430 (eval-when (compile load eval)
431 (setf (condition-class-cpl (kernel::find-class 'condition))
432 (list (kernel::find-class 'condition))))
433
434 (setf (condition-class-report (kernel::find-class 'condition))
435 #'(lambda (cond stream)
436 (format stream (intl:gettext "Condition ~S was signalled.") (type-of cond))))
437
438 (eval-when (compile load eval)
439
440 (defun find-condition-layout (name parent-types)
441 (let* ((cpl (remove-duplicates
442 (reverse
443 (reduce #'append
444 (mapcar #'(lambda (x)
445 (condition-class-cpl
446 (kernel::find-class x)))
447 parent-types)))))
448 (cond-layout (info type compiler-layout 'condition))
449 (olayout (info type compiler-layout name))
450 (new-inherits
451 (order-layout-inherits (concatenate 'simple-vector
452 (layout-inherits cond-layout)
453 (mapcar #'%class-layout cpl)))))
454 (if (and olayout
455 (not (mismatch (layout-inherits olayout) new-inherits)))
456 olayout
457 (make-layout :class (make-undefined-class name)
458 :inherits new-inherits
459 :inheritance-depth -1
460 :length (layout-length cond-layout)))))
461
462 ); EVAL-WHEN (COMPILE LOAD EVAL)
463
464
465 ;;;; Condition reporting:
466
467 (defun %print-condition (s stream d)
468 (declare (ignore d))
469 (if (fboundp 'print-object)
470 (print-object s stream)
471 (real-print-condition s stream)))
472
473 (defun real-print-condition (s stream)
474 (if *print-escape*
475 (print-unreadable-object (s stream :identity t :type t))
476 (dolist (class (condition-class-cpl (kernel::class-of s))
477 (error (intl:gettext "No REPORT? Shouldn't happen!")))
478 (let ((report (condition-class-report class)))
479 (when report
480 (return (funcall report s stream)))))))
481
482 ;;;; Condition slots:
483
484 (defvar *empty-slot* '(empty))
485
486 (defun find-slot-default (class slot)
487 (let ((initargs (condition-slot-initargs slot))
488 (cpl (condition-class-cpl class)))
489 (dolist (class cpl)
490 (let ((default-initargs (condition-class-default-initargs class)))
491 (dolist (initarg initargs)
492 (let ((val (getf default-initargs initarg *empty-slot*)))
493 (unless (eq val *empty-slot*)
494 (return-from find-slot-default
495 (if (functionp val)
496 (funcall val)
497 val)))))))
498
499 (if (condition-slot-initform-p slot)
500 (let ((initform (condition-slot-initform slot)))
501 (if (functionp initform)
502 (funcall initform)
503 initform))
504 (error (intl:gettext "Condition slot is not bound: ~S")
505 (condition-slot-name slot)))))
506
507 (defun find-slot (classes name)
508 (dolist (sclass classes nil)
509 (dolist (slot (condition-class-slots sclass))
510 (when (eq (condition-slot-name slot) name)
511 (return-from find-slot slot)))))
512
513 (defun condition-writer-function (condition new-value name)
514 (dolist (cslot (condition-class-class-slots
515 (layout-class (%instance-layout condition)))
516 (setf (getf (condition-assigned-slots condition) name)
517 new-value))
518 (when (eq (condition-slot-name cslot) name)
519 (return (setf (car (condition-slot-cell cslot)) new-value)))))
520
521 (defun condition-reader-function (condition name)
522 (let ((class (layout-class (%instance-layout condition))))
523 (dolist (cslot (condition-class-class-slots class))
524 (when (eq (condition-slot-name cslot) name)
525 (return-from condition-reader-function
526 (car (condition-slot-cell cslot)))))
527
528 (let ((val (getf (condition-assigned-slots condition) name
529 *empty-slot*)))
530 (if (eq val *empty-slot*)
531 (let ((actual-initargs (condition-actual-initargs condition))
532 (slot (find-slot (condition-class-cpl class) name)))
533 (unless slot
534 (error (intl:gettext "Slot ~S of ~S missing.") name condition))
535 ;;
536 ;; Loop over actual initargs because the order of
537 ;; actual initargs determines how slots are initialized.
538 (loop with slot-initargs = (condition-slot-initargs slot)
539 for (initarg init-value) on actual-initargs by #'cddr
540 if (member initarg slot-initargs) do
541 (return-from condition-reader-function
542 (setf (getf (condition-assigned-slots condition)
543 name)
544 init-value)))
545 (setf (getf (condition-assigned-slots condition) name)
546 (find-slot-default class slot)))
547 val))))
548
549
550 (defun make-condition (thing &rest args)
551 "Make an instance of a condition object using the specified initargs."
552 ;; Note: ANSI specifies no exceptional situations in this function.
553 ;; signalling simple-type-error would not be wrong.
554 (let* ((thing (if (symbolp thing)
555 (kernel::find-class thing)
556 thing))
557 (class (typecase thing
558 (condition-class thing)
559 (pcl::condition-class
560 ;; Punt to CLOS
561 (return-from make-condition
562 (apply #'make-instance thing args)))
563 (class
564 (error 'simple-type-error
565 :datum thing
566 :expected-type 'condition-class
567 :format-control (intl:gettext "~S is not a condition class.")
568 :format-arguments (list thing)))
569 (t
570 (error 'simple-type-error
571 :datum thing
572 :expected-type 'condition-class
573 :format-control (intl:gettext "Bad thing for class arg:~% ~S")
574 :format-arguments (list thing)))))
575 (res (make-condition-object args)))
576 (setf (%instance-layout res) (%class-layout class))
577 ;;
578 ;; Set any class slots with initargs present in this call.
579 (dolist (cslot (condition-class-class-slots class))
580 (dolist (initarg (condition-slot-initargs cslot))
581 (let ((val (getf args initarg *empty-slot*)))
582 (unless (eq val *empty-slot*)
583 (setf (car (condition-slot-cell cslot)) val)))))
584 ;;
585 ;; Default any slots with non-constant defaults now.
586 (dolist (hslot (condition-class-hairy-slots class))
587 (when (dolist (initarg (condition-slot-initargs hslot) t)
588 (unless (eq (getf args initarg *empty-slot*) *empty-slot*)
589 (return nil)))
590 (setf (getf (condition-assigned-slots res) (condition-slot-name hslot))
591 (find-slot-default class hslot))))
592
593 res))
594
595
596 ;;;; DEFINE-CONDITION
597
598 (eval-when (compile load eval)
599 (defun %compiler-define-condition (name direct-supers layout)
600 (multiple-value-bind (class old-layout)
601 (insured-find-class name #'condition-class-p
602 #'make-condition-class)
603 (setf (layout-class layout) class)
604 (setf (%class-direct-superclasses class)
605 (mapcar #'kernel::find-class direct-supers))
606 (cond ((not old-layout)
607 (register-layout layout))
608 ((not *type-system-initialized*)
609 (setf (layout-class old-layout) class)
610 (setq layout old-layout)
611 (unless (eq (%class-layout class) layout)
612 (register-layout layout)))
613 ((redefine-layout-warning old-layout "current"
614 layout "new")
615 (register-layout layout :invalidate t))
616 ((not (%class-layout class))
617 (register-layout layout)))
618
619 (setf (layout-info layout)
620 (layout-info (%class-layout (kernel::find-class 'condition))))
621
622 (setf (kernel::find-class name) class)
623 ;;
624 ;; Initialize CPL slot.
625 (setf (condition-class-cpl class)
626 (remove-if-not #'condition-class-p
627 (std-compute-class-precedence-list class))))
628 (undefined-value))
629
630 ); eval-when (compile load eval)
631
632
633 ;;; COMPUTE-EFFECTIVE-SLOTS -- Internal
634 ;;;
635 ;;; Compute the effective slots of class, copying inherited slots and
636 ;;; side-effecting direct slots.
637 ;;;
638 (defun compute-effective-slots (class)
639 (collect ((res (copy-list (condition-class-slots class))))
640 (dolist (sclass (cdr (condition-class-cpl class)))
641 (dolist (sslot (condition-class-slots sclass))
642 (let ((found (find (condition-slot-name sslot) (res)
643 :key #'condition-slot-name :test #'eq)))
644 (cond (found
645 (setf (condition-slot-initargs found)
646 (union (condition-slot-initargs found)
647 (condition-slot-initargs sslot)))
648 (unless (condition-slot-initform-p found)
649 (setf (condition-slot-initform-p found)
650 (condition-slot-initform-p sslot))
651 (setf (condition-slot-initform found)
652 (condition-slot-initform sslot)))
653 (unless (condition-slot-allocation found)
654 (setf (condition-slot-allocation found)
655 (condition-slot-allocation sslot))))
656 (t
657 (res (copy-structure sslot)))))))
658 (res)))
659
660 (eval-when (compile load eval)
661 (defvar *make-condition-accessor-methods* nil))
662
663 ;;;
664 ;;; List of condition slot readers and writers defined early. Used to
665 ;;; change them to generic functions when PCL is ready to do so.
666 ;;; Alas, we have to keep this list around after readers/writers have
667 ;;; been made generic functions because the PCL build process requires
668 ;;; us to undefine generic functions, so we need to change the
669 ;;; accessors back to normal functions when building PCL.
670 ;;;
671 (defvar *early-condition-accessors* ())
672
673 (defun make-early-condition-accessors-generic (&optional (generic-p t))
674 (dolist (elt *early-condition-accessors*)
675 (destructuring-bind (condition slot accessor kind) elt
676 (fmakunbound accessor)
677 (let ((new (make-condition-accessor accessor condition slot
678 kind generic-p)))
679 (when generic-p
680 (eval new)))))
681 (setq *make-condition-accessor-methods* generic-p))
682
683 (defun make-condition-accessor (accessor condition slot kind generic-p)
684 (if generic-p
685 (if (eq kind 'reader)
686 `(defmethod ,accessor ((x ,condition))
687 (condition-reader-function x ',slot))
688 `(defmethod ,accessor (nv (x ,condition))
689 (condition-writer-function x nv ',slot)))
690 (progn
691 (pushnew (list condition slot accessor kind)
692 *early-condition-accessors* :test #'equal)
693 (setf (fdefinition accessor)
694 (if (eq kind 'reader)
695 (lambda (x)
696 (condition-reader-function x slot))
697 (lambda (nv x)
698 (condition-writer-function x nv slot)))))))
699
700 (defun %define-condition (name slots documentation report default-initargs)
701 (when (info declaration recognized name)
702 (error (intl:gettext "Condition already names a declaration: ~S.") name))
703 (let ((class (kernel::find-class name)))
704 (setf (slot-class-print-function class) #'%print-condition)
705 (setf (condition-class-slots class) slots)
706 (setf (condition-class-report class) report)
707 (setf (condition-class-default-initargs class) default-initargs)
708 (setf (documentation name 'type) documentation)
709
710 (unless *make-condition-accessor-methods*
711 (dolist (slot slots)
712 (let ((slot-name (condition-slot-name slot)))
713 (dolist (reader (condition-slot-readers slot))
714 (make-condition-accessor reader name slot-name 'reader nil))
715 (dolist (writer (condition-slot-writers slot))
716 (make-condition-accessor writer name slot-name 'writer nil)))))
717 ;;
718 ;; Compute effective slots and set up the class and hairy slots (subsets of
719 ;; the effective slots.)
720 (let ((eslots (compute-effective-slots class))
721 (e-def-initargs
722 (reduce #'append
723 (mapcar #'condition-class-default-initargs
724 (condition-class-cpl class)))))
725 (dolist (slot eslots)
726 (ecase (condition-slot-allocation slot)
727 (:class
728 (unless (condition-slot-cell slot)
729 (setf (condition-slot-cell slot)
730 (list (if (condition-slot-initform-p slot)
731 (let ((initform (condition-slot-initform slot)))
732 (if (functionp initform)
733 (funcall initform)
734 initform))
735 *empty-slot*))))
736 (push slot (condition-class-class-slots class)))
737 ((:instance nil)
738 (setf (condition-slot-allocation slot) :instance)
739 (when (or (functionp (condition-slot-initform slot))
740 (dolist (initarg (condition-slot-initargs slot) nil)
741 (when (functionp (getf e-def-initargs initarg))
742 (return t))))
743 (push slot (condition-class-hairy-slots class))))))))
744 name)
745
746
747 (defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
748 &body options)
749 "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
750 Define NAME as a condition type. This new type inherits slots and its
751 report function from the specified PARENT-TYPEs. A slot spec is either
752 a symbol denoting the name of the slot, or a list of the form:
753
754 (slot-name {slot-option value}*)
755
756 where slot-option is one of :READER, :WRITER, :ACCESSOR, :ALLOCATION,
757 :INITARG, :INITFORM, :DOCUMENTATION, and :TYPE.
758
759 Each overall option is of the form
760
761 (option-name {value}*)
762
763 where option-name is one of :DEFAULT-INITARGS, :DOCUMENTATION,
764 and :REPORT.
765
766 The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
767 a string or a two-argument lambda or function name. If a function, the
768 function is called with the condition and stream to report the condition.
769 If a string, the string is printed.
770
771 Condition types are classes, but (as allowed by ANSI and not as described in
772 CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
773 SLOT-VALUE may not be used on condition objects."
774 (let* ((parent-types (or parent-types '(condition)))
775 (layout (find-condition-layout name parent-types))
776 (documentation nil)
777 (report nil)
778 (slot-name/accessors ())
779 (default-initargs ()))
780 (collect ((slots)
781 (all-readers nil append)
782 (all-writers nil append))
783 (dolist (spec slot-specs)
784 (when (keywordp spec)
785 (warn (intl:gettext "Keyword slot name indicates probable syntax error:~% ~S")
786 spec))
787 (let* ((spec (if (consp spec) spec (list spec)))
788 (slot-name (first spec))
789 (allocation :instance)
790 (documentation nil)
791 (initform-p nil)
792 initform)
793 (collect ((initargs)
794 (readers)
795 (writers))
796 (do ((options (rest spec) (cddr options)))
797 ((null options))
798 (unless (and (consp options) (consp (cdr options)))
799 (simple-program-error (intl:gettext "Malformed condition slot spec:~% ~S.")
800 spec))
801 (let ((arg (second options)))
802 (case (first options)
803 (:reader (readers arg))
804 (:writer (writers arg))
805 (:accessor
806 (readers arg)
807 (writers `(setf ,arg)))
808 (:initform
809 (when initform-p
810 (simple-program-error (intl:gettext "More than one :INITFORM in:~% ~S")
811 spec))
812 (setq initform-p t)
813 (setq initform arg))
814 (:initarg (initargs arg))
815 (:allocation
816 (setq allocation arg))
817 (:documentation
818 (when documentation
819 (simple-program-error
820 (intl:gettext "More than one slot :DOCUMENTATION in~% ~s") spec))
821 (unless (stringp arg)
822 (simple-program-error
823 (intl:gettext "Slot :DOCUMENTATION is not a string in~% ~s") spec))
824 (setq documentation arg))
825 (:type)
826 (t
827 (simple-program-error (intl:gettext "Unknown slot option:~% ~S")
828 (first options))))))
829
830 (push (list slot-name (readers) (writers)) slot-name/accessors)
831 (all-readers (readers))
832 (all-writers (writers))
833 (slots `(make-condition-slot
834 :name ',slot-name
835 :initargs ',(initargs)
836 :readers ',(readers)
837 :writers ',(writers)
838 :initform-p ',initform-p
839 :documentation ',documentation
840 :initform
841 ,(if (constantp initform)
842 `',(eval initform)
843 `#'(lambda () ,initform)))))))
844
845 (dolist (option options)
846 (unless (consp option)
847 (simple-program-error (intl:gettext "Bad option:~% ~S") option))
848 (case (first option)
849 (:documentation (setq documentation (second option)))
850 (:report
851 (let ((arg (second option)))
852 (setq report
853 (if (stringp arg)
854 `#'(lambda (condition stream)
855 (declare (ignore condition))
856 (write-string ,arg stream))
857 `#'(lambda (condition stream)
858 (funcall #',arg condition stream))))))
859 (:default-initargs
860 (do ((initargs (rest option) (cddr initargs)))
861 ((endp initargs))
862 (let ((val (second initargs)))
863 (setq default-initargs
864 (list* `',(first initargs)
865 (if (constantp val)
866 `',(eval val)
867 `#'(lambda () ,val))
868 default-initargs)))))
869 (t
870 (simple-program-error (intl:gettext "Unknown option: ~S") (first option)))))
871
872 `(progn
873 (eval-when (compile load eval)
874 (%compiler-define-condition ',name ',parent-types ',layout))
875
876 (declaim (ftype (function (t) t) ,@(all-readers)))
877 (declaim (ftype (function (t t) t) ,@(all-writers)))
878
879 ,@(when *make-condition-accessor-methods*
880 (collect ((methods))
881 (dolist (elt slot-name/accessors)
882 (destructuring-bind (slot-name readers writers) elt
883 (dolist (reader readers)
884 (methods (make-condition-accessor
885 reader name slot-name 'reader t)))
886 (dolist (writer writers)
887 (methods (make-condition-accessor
888 writer name slot-name 'writer t)))))
889 (methods)))
890
891 (%define-condition ',name
892 (list ,@(slots))
893 ,documentation
894 ,report
895 (list ,@default-initargs))))))
896
897
898 ;;;; HANDLER-BIND and SIGNAL.
899
900 (defvar *handler-clusters* nil)
901
902 (defmacro handler-bind (bindings &body forms)
903 "(HANDLER-BIND ( {(type handler)}* ) body)
904 Executes body in a dynamic context where the given handler bindings are
905 in effect. Each handler must take the condition being signalled as an
906 argument. The bindings are searched first to last in the event of a
907 signalled condition."
908 (unless (every #'(lambda (x) (and (listp x) (= (length x) 2))) bindings)
909 (simple-program-error (intl:gettext "Ill-formed handler bindings.")))
910 `(let ((*handler-clusters*
911 (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x)))
912 bindings))
913 *handler-clusters*)))
914 (multiple-value-prog1
915 (progn ,@forms)
916 ;; Wait for any float exceptions
917 #+x87 (float-wait))))
918
919
920 ;;;; Condition definitions.
921
922 (define-condition serious-condition (condition)())
923
924 (define-condition error (serious-condition) ())
925
926 (define-condition warning (condition) ())
927 (define-condition style-warning (warning) ())
928
929 (defun simple-condition-printer (condition stream)
930 (apply #'format stream (simple-condition-format-control condition)
931 (simple-condition-format-arguments condition)))
932
933 (define-condition simple-condition ()
934 ((format-control :reader simple-condition-format-control
935 :initarg :format-control)
936 (format-arguments :reader simple-condition-format-arguments
937 :initarg :format-arguments
938 :initform '()))
939 (:report simple-condition-printer))
940
941 (define-condition simple-warning (simple-condition warning) ())
942 (define-condition simple-style-warning (simple-condition style-warning) ())
943
944 (defun print-simple-error (condition stream)
945 (format stream (intl:gettext "~&~@<Error in function ~S: ~3i~:_~?~:>")
946 (condition-function-name condition)
947 (simple-condition-format-control condition)
948 (simple-condition-format-arguments condition)))
949
950 (define-condition simple-error (simple-condition error) ()
951 ;; This is the condition type used by error and cerror when
952 ;; a format-control string is supplied as the first argument.
953 (:report print-simple-error))
954
955 (define-condition storage-condition (serious-condition) ())
956
957 #+stack-checking
958 (define-condition stack-overflow (storage-condition)
959 ()
960 (:report (lambda (condition stream)
961 (declare (ignore condition))
962 (format stream (intl:gettext "Control stack overflow")))))
963
964 #+heap-overflow-check
965 (define-condition heap-overflow (storage-condition)
966 ()
967 (:report (lambda (condition stream)
968 (declare (ignore condition))
969 (format stream (intl:gettext "Heap (dynamic space) overflow")))))
970
971 (define-condition type-error (error)
972 ((datum :reader type-error-datum :initarg :datum)
973 (expected-type :reader type-error-expected-type :initarg :expected-type))
974 (:report
975 (lambda (condition stream)
976 (format stream (intl:gettext "~@<Type-error in ~S: ~3i~:_~S is not of type ~S~:>")
977 (condition-function-name condition)
978 (type-error-datum condition)
979 (type-error-expected-type condition)))))
980
981 (define-condition simple-type-error (simple-condition type-error) ())
982
983 (define-condition kernel:layout-invalid (type-error)
984 ()
985 (:report
986 (lambda (condition stream)
987 (format stream (intl:gettext "Layout-invalid error in ~S:~@
988 Type test of class ~S was passed obsolete instance:~% ~S")
989 (condition-function-name condition)
990 (kernel:class-proper-name (type-error-expected-type condition))
991 (type-error-datum condition)))))
992
993 (define-condition case-failure (type-error)
994 ((name :reader case-failure-name :initarg :name)
995 (possibilities :reader case-failure-possibilities :initarg :possibilities))
996 (:report
997 (lambda (condition stream)
998 (format stream (intl:gettext "~@<~S fell through ~S expression. ~:_Wanted one of ~:S.~:>")
999 (type-error-datum condition)
1000 (case-failure-name condition)
1001 (case-failure-possibilities condition)))))
1002
1003
1004 (define-condition program-error (error) ())
1005 (define-condition parse-error (error) ())
1006 (define-condition control-error (error) ())
1007 (define-condition stream-error (error)
1008 ((stream :reader stream-error-stream :initarg :stream)))
1009
1010 (defun print-reference (reference stream)
1011 (ecase (car reference)
1012 (:amop
1013 (format stream "AMOP")
1014 (format stream ", ")
1015 (destructuring-bind (type data) (cdr reference)
1016 (ecase type
1017 (:generic-function (format stream "Generic Function ~S" data))
1018 (:section (format stream "Section ~{~D~^.~}" data)))))
1019 (:ansi-cl
1020 (format stream "The ANSI Standard")
1021 (format stream ", ")
1022 (destructuring-bind (type data) (cdr reference)
1023 (ecase type
1024 (:function (format stream "Function ~S" data))
1025 (:special-operator (format stream "Special Operator ~S" data))
1026 (:macro (format stream "Macro ~S" data))
1027 (:section (format stream "Section ~{~D~^.~}" data))
1028 (:glossary (format stream "Glossary entry for ~S" data))
1029 (:issue (format stream "writeup for Issue ~A" data)))))
1030 #+nil
1031 (:cmucl
1032 (format stream "The CMUCL Manual")
1033 (format stream ", ")
1034 (destructuring-bind (type data) (cdr reference)
1035 (ecase type
1036 (:node (format stream "Node ~S" data))
1037 (:variable (format stream "Variable ~S" data))
1038 (:function (format stream "Function ~S" data)))))
1039 ;; FIXME: other documents (e.g. CLIM, Franz documentation :-)
1040 ))
1041
1042 (defun print-references (refs stream)
1043 (unless (or *print-escape* *print-readably*)
1044 (when refs
1045 (format stream "~&See also:~%")
1046 (pprint-logical-block (stream refs :per-line-prefix " ")
1047 (do* ((rs refs (cdr rs))
1048 (r (car rs) (car rs)))
1049 ((null rs))
1050 (print-reference r stream)
1051 (unless (null (cdr rs))
1052 (terpri stream)))))))
1053
1054 (define-condition reference-condition ()
1055 ((references :initarg :references
1056 :reader reference-condition-references)))
1057
1058 (define-condition end-of-file (stream-error) ()
1059 (:report
1060 (lambda (condition stream)
1061 (format stream (intl:gettext "End-of-File on ~S")
1062 (stream-error-stream condition)))))
1063
1064 (define-condition file-error (error)
1065 ((pathname :reader file-error-pathname :initarg :pathname)))
1066
1067 ;;; INTERNAL
1068 (define-condition simple-program-error (simple-condition program-error)())
1069 (define-condition simple-parse-error (simple-condition parse-error)())
1070 (define-condition simple-control-error (simple-condition control-error)())
1071 (define-condition simple-stream-error (simple-condition stream-error) ())
1072
1073 (define-condition simple-file-error (simple-condition file-error) ()
1074 (:report
1075 (lambda (condition stream)
1076 (format stream (intl:gettext "~&~@<File-error in function ~S: ~3i~:_~?~:>")
1077 (condition-function-name condition)
1078 (simple-condition-format-control condition)
1079 (simple-condition-format-arguments condition)))))
1080
1081 (define-condition package-error (error)
1082 ((package :reader package-error-package :initarg :package)))
1083
1084 (define-condition cell-error (error)
1085 ((name :reader cell-error-name :initarg :name)))
1086
1087 (define-condition unbound-variable (cell-error) ()
1088 (:report
1089 (lambda (condition stream)
1090 (format stream
1091 (intl:gettext "Error in ~S: the variable ~S is unbound.")
1092 (condition-function-name condition)
1093 (cell-error-name condition)))))
1094
1095 (define-condition undefined-function (cell-error) ()
1096 (:report
1097 (lambda (condition stream)
1098 (format stream
1099 (intl:gettext "Error in ~S: the function ~S is undefined.")
1100 (condition-function-name condition)
1101 (cell-error-name condition)))))
1102
1103 (define-condition simple-undefined-function (simple-condition
1104 undefined-function) ())
1105
1106 (define-condition constant-modified (reference-condition warning)
1107 ((function-name :initarg :function-name :reader constant-modified-function-name))
1108 (:report (lambda (c s)
1109 (format s (intl:gettext "~@<Destructive function ~S called on ~
1110 constant data.~@:>")
1111 (constant-modified-function-name c))
1112 (print-references (reference-condition-references c) s)))
1113 (:default-initargs :references (list '(:ansi-cl :section (3 2 2 3)))))
1114
1115 (define-condition arithmetic-error (error)
1116 ((operation :reader arithmetic-error-operation :initarg :operation
1117 :initform nil)
1118 (operands :reader arithmetic-error-operands :initarg :operands))
1119 (:report (lambda (condition stream)
1120 (format stream (intl:gettext "Arithmetic error ~S signalled.")
1121 (type-of condition))
1122 (when (arithmetic-error-operation condition)
1123 (format stream (intl:gettext "~%Operation was ~S, operands ~S.")
1124 (arithmetic-error-operation condition)
1125 (arithmetic-error-operands condition))))))
1126
1127 (define-condition division-by-zero (arithmetic-error) ())
1128 (define-condition floating-point-overflow (arithmetic-error) ())
1129 (define-condition floating-point-underflow (arithmetic-error) ())
1130 (define-condition floating-point-inexact (arithmetic-error) ())
1131 (define-condition floating-point-invalid-operation (arithmetic-error) ())
1132
1133 ;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that
1134 ;;; compiler warnings can be emitted as appropriate.
1135 ;;;
1136 (define-condition parse-unknown-type (condition)
1137 ((specifier :reader parse-unknown-type-specifier :initarg :specifier)))
1138
1139
1140 ;;;; HANDLER-CASE and IGNORE-ERRORS.
1141
1142 ;;; This macro doesn't work in older version of CMUCL system due to lossage
1143 ;;; in closing over tags. The previous version sets up unique run-time tags.
1144 ;;;
1145 (defmacro handler-case (form &rest cases)
1146 "(HANDLER-CASE form
1147 { (type ([var]) body) }* )
1148 Executes form in a context with handlers established for the condition
1149 types. A peculiar property allows type to be :no-error. If such a clause
1150 occurs, and form returns normally, all its values are passed to this clause
1151 as if by MULTIPLE-VALUE-CALL. The :no-error clause accepts more than one
1152 var specification."
1153 (let ((no-error-clause (assoc ':no-error cases)))
1154 (if no-error-clause
1155 (let ((normal-return (make-symbol "normal-return"))
1156 (error-return (make-symbol "error-return")))
1157 `(block ,error-return
1158 (multiple-value-call (lambda ,@(cdr no-error-clause))
1159 (block ,normal-return
1160 (return-from ,error-return
1161 (handler-case (return-from ,normal-return ,form)
1162 ,@(remove no-error-clause cases)))))))
1163 (let ((tag (gensym))
1164 (var (gensym))
1165 (annotated-cases (mapcar (lambda (case) (cons (gensym) case))
1166 cases)))
1167 `(block ,tag
1168 (let ((,var nil))
1169 (declare (ignorable ,var))
1170 (tagbody
1171 (handler-bind
1172 ,(mapcar (lambda (annotated-case)
1173 (list (cadr annotated-case)
1174 `#'(lambda (temp)
1175 ,(if (caddr annotated-case)
1176 `(setq ,var temp)
1177 '(declare (ignore temp)))
1178 (go ,(car annotated-case)))))
1179 annotated-cases)
1180 (return-from ,tag
1181 #-x87 ,form
1182 #+x87 (multiple-value-prog1 ,form
1183 ;; Need to catch FP errors here!
1184 (kernel::float-wait))))
1185 ,@(mapcan
1186 (lambda (annotated-case)
1187 (list (car annotated-case)
1188 (let ((body (cdddr annotated-case)))
1189 `(return-from
1190 ,tag
1191 ,(if (caddr annotated-case)
1192 `(let ((,(caaddr annotated-case) ,var))
1193 ,@body)
1194 `(locally ,@body))))))
1195 annotated-cases))))))))
1196
1197 (defmacro ignore-errors (&rest forms)
1198 "Executes forms after establishing a handler for all error conditions that
1199 returns from this form nil and the condition signalled."
1200 `(handler-case (progn ,@forms)
1201 (error (condition) (values nil condition))))
1202
1203
1204
1205 ;;;; Restart definitions.
1206
1207 (define-condition abort-failure (control-error) ()
1208 (:report (lambda (condition stream)
1209 (declare (ignore condition))
1210 (write-string (intl:gettext "Found an \"abort\" restart that failed to transfer control dynamically.")
1211 stream))))
1212
1213 ;;; ABORT signals an error in case there was a restart named abort that did
1214 ;;; not tranfer control dynamically. This could happen with RESTART-BIND.
1215 ;;;
1216 (defun abort (&optional condition)
1217 "Transfers control to a restart named abort, signalling a control-error if
1218 none exists."
1219 (invoke-restart (find-restart 'abort condition))
1220 (error 'abort-failure))
1221
1222
1223 (defun muffle-warning (&optional condition)
1224 "Transfers control to a restart named muffle-warning, signalling a
1225 control-error if none exists."
1226 (invoke-restart (find-restart 'muffle-warning condition)))
1227
1228
1229 ;;; DEFINE-NIL-RETURNING-RESTART finds the restart before invoking it to keep
1230 ;;; INVOKE-RESTART from signalling a control-error condition.
1231 ;;;
1232 (defmacro define-nil-returning-restart (name args doc)
1233 `(defun ,name (,@args &optional condition)
1234 ,doc
1235 (let ((restart (find-restart ',name condition)))
1236 (when restart
1237 (invoke-restart restart ,@args)))))
1238
1239 (define-nil-returning-restart continue ()
1240 "Transfer control to a restart named continue, returning nil if none exists.")
1241
1242 (define-nil-returning-restart store-value (value)
1243 "Transfer control and value to a restart named store-value, returning nil if
1244 none exists.")
1245
1246 (define-nil-returning-restart use-value (value)
1247 "Transfer control and value to a restart named use-value, returning nil if
1248 none exists.")

  ViewVC Help
Powered by ViewVC 1.1.5