source: trunk/ccl/level-1/l1-error-system.lisp @ 7126

Last change on this file since 7126 was 7126, checked in by gz, 14 years ago

Add a restart for unbound variable/undefined function errors -- if there is a unique bound/fbound symbol of the same name in another package, offer to use it instead.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 50.6 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17
18;;; This file contains the error/condition system.  Functions that
19;;; signal/handle errors are defined later.
20
21(in-package "CCL")
22
23;;;***********************************
24;;; Error System
25;;;***********************************
26
27(defclass condition () ())
28(defclass warning (condition) ())
29(defclass serious-condition (condition) ())
30(defclass error (serious-condition) ())
31
32(define-condition simple-condition (condition)
33  ((format-control :initarg :format-control
34                  :reader simple-condition-format-control)
35   (format-arguments :initarg :format-arguments
36                     :initform nil
37                     :reader simple-condition-format-arguments))
38  (:report (lambda (c stream)  ;; If this were a method, slot value might be faster someday.  Accessors always faster ?
39                               ;; And of course it's terribly important that this be as fast as humanly possible...
40            ;Use accessors because they're documented and users can specialize them.
41            (apply #'format stream (simple-condition-format-control c)
42                   (simple-condition-format-arguments c)))))
43
44
45(define-condition storage-condition (serious-condition) ())
46
47(define-condition thread-condition (serious-condition) ())
48
49(define-condition process-reset (thread-condition)
50  ((kill :initarg :kill :initform nil :reader process-reset-kill)))
51
52
53(define-condition print-not-readable (error)
54  ((object :initarg :object :reader print-not-readable-object)
55   (stream :initarg :stream :reader print-not-readable-stream))
56  (:report (lambda (c stream)
57             (let* ((*print-readably* nil))
58               (format stream "Attempt to print object ~S on stream ~S ."
59                       (print-not-readable-object c)
60                       (print-not-readable-stream c))))))
61
62(define-condition simple-warning (simple-condition warning))
63
64(define-condition compiler-warning (warning)
65  ((file-name :initarg :file-name :initform nil :accessor compiler-warning-file-name)
66   (stream-position :initform nil :accessor compiler-warning-stream-position)
67   (function-name :initarg :function-name :initform nil :accessor compiler-warning-function-name)
68   (warning-type :initarg :warning-type :reader compiler-warning-warning-type)
69   (args :initarg :args :reader compiler-warning-args)
70   (nrefs :initform 1 :accessor compiler-warning-nrefs))
71  (:report report-compiler-warning))
72
73(define-condition style-warning (compiler-warning))
74(define-condition undefined-function-reference (style-warning))
75(define-condition macro-used-before-definition (compiler-warning))
76(define-condition invalid-arguments (style-warning))
77(define-condition invalid-arguments-global (style-warning))
78
79(define-condition simple-error (simple-condition error))
80
81(define-condition simple-storage-condition (simple-condition storage-condition))
82(define-condition stack-overflow-condition (simple-storage-condition))
83
84(define-condition invalid-memory-access (storage-condition)
85  ((address :initarg :address)
86   (write-p :initform nil :initarg :write-p))
87  (:report (lambda (c s)
88             (with-slots (address write-p) c
89               (format s "Fault during ~a memory address #x~x" (if write-p "write to" "read of") address)))))
90 
91(define-condition type-error (error)
92  ((datum :initarg :datum)
93   (expected-type :initarg :expected-type :reader type-error-expected-type)
94   (format-control :initarg :format-control  :initform (%rsc-string  $xwrongtype) :reader type-error-format-control))
95  (:report (lambda (c s)
96             (format s (type-error-format-control c)
97                     (type-error-datum c) 
98                     (type-error-expected-type c)))))
99
100(define-condition bad-slot-type (type-error)
101  ((slot-definition :initform nil :initarg :slot-definition)
102   (instance :initform nil :initarg :instance))
103  (:report (lambda (c s)
104             (format s "The value ~s can not be used to set the value of the slot ~s in ~s, because it is not of type ~s. "
105                     (type-error-datum c)
106                     (slot-definition-name (slot-value c 'slot-definition))
107                     (slot-value c 'instance)
108                     (type-error-expected-type c)))))
109
110(define-condition bad-slot-type-from-initform (bad-slot-type)
111  ()
112  (:report (lambda (c s)
113             (let* ((slotd (slot-value c 'slot-definition)))
114               (format s "The value ~s, derived from the initform ~s, can not be used to set the value of the slot ~s in ~s, because it is not of type ~s. "
115                     (type-error-datum c)
116                     (slot-definition-initform slotd)
117                     (slot-definition-name slotd)
118                     (slot-value c 'instance)
119                     (type-error-expected-type c))))))
120
121(define-condition bad-slot-type-from-initarg (bad-slot-type)
122  ((initarg-name :initarg :initarg-name))
123  (:report (lambda (c s)
124             (let* ((slotd (slot-value c 'slot-definition)))
125               (format s "The value ~s, derived from the initarg ~s, can not be used to set the value of the slot ~s in ~s, because it is not of type ~s. "
126                     (type-error-datum c)
127                     (slot-value c 'initarg-name)
128                     (slot-definition-name slotd)
129                     (slot-value c 'instance)
130                     (type-error-expected-type c))))))
131 
132
133(define-condition improper-list (type-error)
134  ((expected-type :initform '(satisfies proper-list-p) :reader type-error-expected-type)))
135
136(define-condition cant-construct-arglist (improper-list)
137  ())
138
139
140
141(let* ((magic-token '("Unbound")))
142  (defmethod type-error-datum ((c type-error))
143    (let* ((datum-slot (slot-value c 'datum)))
144      (if (eq magic-token datum-slot)
145        (%unbound-marker-8)
146        datum-slot)))
147
148; do we need this
149  (defun signal-type-error (datum expected &optional (format-string (%rsc-string  $xwrongtype)))
150    (let ((error #'error))
151      (funcall error (make-condition 'type-error
152                                     :format-control format-string
153                                     :datum (if (eq datum (%unbound-marker-8)) magic-token datum)
154                                     :expected-type (%type-error-type expected)))))
155)
156
157
158(define-condition sequence-index-type-error (type-error)
159  ((sequence :initarg :sequence))
160  (:report (lambda (c s)
161             (format s "~s is not a valid sequence index for ~s"
162                     (type-error-datum c)
163                     (slot-value c 'sequence)))))
164
165
166;;; This is admittedly sleazy; ANSI CL requires TYPE-ERRORs to be
167;;; signalled in cases where a type-specifier is not of an appropriate
168;;; subtype.  The sleazy part is whether it's right to overload TYPE-ERROR
169;;; like this.
170
171(define-condition invalid-subtype-error (type-error)
172  ()
173  (:report (lambda (c s)
174             (format s "The type specifier ~S is not determinably a subtype of the type ~S"
175                     (type-error-datum c)
176                     (type-error-expected-type c)))))
177
178(define-condition simple-type-error (simple-condition type-error))
179
180
181
182(define-condition program-error (error))
183(define-condition simple-program-error (simple-condition program-error)
184  ((context :initarg :context :reader simple-program-error-context :initform nil)))
185
186(defun signal-program-error (string &rest args)
187  (let* ((e #'error))
188    (funcall e
189             (make-condition 'simple-program-error
190                             :format-control (if (fixnump string) (%rsc-string string) string)
191                             :format-arguments args))))
192
193(define-condition simple-destructuring-error (simple-program-error))
194
195(define-condition wrong-number-of-arguments (program-error)
196  ((nargs :initform nil
197          :initarg :nargs :reader wrong-number-of-arguments-nargs)
198   (fn :initform nil :initarg :fn :reader wrong-number-of-arguments-fn))
199  (:report report-argument-mismatch))
200       
201(define-condition too-many-arguments (wrong-number-of-arguments))
202
203(define-condition too-few-arguments (wrong-number-of-arguments))
204
205(defun report-argument-mismatch (c s)
206  (let* ((nargs-provided (wrong-number-of-arguments-nargs c))
207         (fn (wrong-number-of-arguments-fn c))
208         (too-many (typep c 'too-many-arguments)))
209    (multiple-value-bind (min max scaled-nargs)
210        (min-max-actual-args fn nargs-provided)
211      (if (not min)
212        (progn
213          (format s "Function ~s called with too ~a arguments. "
214                  fn
215                  (if too-many
216                    "many"
217                    "few")))
218        (if too-many
219          (format s "Too many arguments in call to ~s:~&~d arguments provided, at most ~d accepted. " fn scaled-nargs max)
220          (format s "Too few arguments in call to ~s:~&~d arguments provided, at least ~d required. " fn  scaled-nargs min))))))
221
222
223
224(define-condition compile-time-program-error (simple-program-error)
225  nil ;((context :initarg :context :reader compile-time-program-error-context))
226  (:report
227   (lambda (c s)
228     (format s "While compiling ~a :~%~a" 
229             (simple-program-error-context c)
230             (apply #'format nil (simple-condition-format-control c) (simple-condition-format-arguments c))))))
231
232
233
234;;; Miscellaneous error during compilation (caused by macroexpansion, transforms, compile-time evaluation, etc.)
235;;; NOT program-errors.
236(define-condition compile-time-error (simple-error)
237  ((context :initarg :context :reader compile-time-error-context))
238  (:report
239   (lambda (c s)
240     (format s "While compiling ~a :~%~a" 
241             (compile-time-error-context c)
242             (format nil "~a" c)))))
243
244(define-condition control-error (error))
245
246(define-condition cant-throw-error (control-error)
247  ((tag :initarg :tag))
248  (:report (lambda (c s)
249             (format s "Can't throw to tag ~s" (slot-value c 'tag)))))
250
251(define-condition inactive-restart (control-error)
252  ((restart-name :initarg :restart-name))
253  (:report (lambda (c s)
254             (format s "Restart ~s is not active" (slot-value c 'restart-name)))))
255
256(define-condition lock-protocol-error (control-error)
257  ((lock :initarg :lock)))
258
259(define-condition not-lock-owner (lock-protocol-error)
260  ()
261  (:report (lambda (c s)
262             (format s "Current process ~s does not own lock ~s"
263                     *current-process* (slot-value c 'lock)))))
264
265(define-condition package-error (error)
266  ((package :initarg :package :reader package-error-package)))
267(define-condition no-such-package (package-error)
268  ()
269  (:report (lambda (c s) (format s (%rsc-string $xnopkg) (package-error-package c)))))
270(define-condition unintern-conflict-error (package-error)
271  ((sym-to-unintern :initarg :sym)
272   (conflicting-syms :initarg :conflicts))
273  (:report (lambda (c s)
274             (format s (%rsc-string $xunintc) (slot-value c 'sym-to-unintern) (package-error-package c) (slot-value c 'conflicting-syms)))))
275
276(define-condition import-conflict-error (package-error)
277  ((imported-sym :initarg :imported-sym)
278   (conflicting-sym :initarg :conflicting-sym)
279   (conflict-external-p :initarg :conflict-external))
280  (:report (lambda (c s)
281             (format s (%rsc-string (if (slot-value c 'conflict-external-p) $ximprtcx $ximprtc))
282                     (slot-value c 'imported-sym)
283                     (package-error-package c)
284                     (slot-value c 'conflicting-sym)))))
285
286(define-condition use-package-conflict-error (package-error)
287  ((package-to-use :initarg :package-to-use)
288   (conflicts :initarg :conflicts)
289   (external-p :initarg :external-p))
290  (:report (lambda (c s)
291             (format s (%rsc-string (if (slot-value c 'external-p) $xusecX $xusec))
292                     (slot-value c 'package-to-use)
293                     (package-error-package c)
294                     (slot-value c 'conflicts)))))
295
296(define-condition export-conflict-error (package-error)
297  ((conflicts :initarg :conflicts))
298  (:report 
299   (lambda (c s)
300     (format s "Name conflict~p detected by ~A :" (length (slot-value c 'conflicts)) 'export)
301     (let* ((package (package-error-package c)))
302       (dolist (conflict (slot-value c 'conflicts))
303         (destructuring-bind (inherited-p sym-to-export using-package conflicting-sym) conflict
304           (format s "~&~A'ing ~S from ~S would cause a name conflict with ~&~
305                      the ~a symbol ~S in the package ~s, which uses ~S."
306                   'export 
307                   sym-to-export 
308                   package 
309                   (if inherited-p "inherited" "present")
310                   conflicting-sym
311                   using-package
312                   package)))))))
313
314(define-condition export-requires-import (package-error)
315  ((to-be-imported :initarg :to-be-imported))
316  (:report
317   (lambda (c s)
318     (let* ((p (package-error-package c)))
319       (format s "The following symbols need to be imported to ~S before they can be exported ~& from that package:~%~s:" p (slot-value c 'to-be-imported) p)))))
320
321
322(define-condition package-name-conflict-error (package-error simple-error) ())
323
324(define-condition package-is-used-by (package-error)
325  ((using-packages :initarg :using-packages))
326  (:report (lambda (c s)
327             (format s "~S is used by ~S" (package-error-package c)
328                     (slot-value c 'using-packages)))))
329
330(define-condition symbol-name-not-accessible (package-error)
331  ((symbol-name :initarg :symbol-name))
332  (:report (lambda (c s)
333             (format s "No aymbol named ~S is accessible in package ~s"
334                     (slot-value c 'symbol-name)
335                     (package-error-package c)))))
336
337(define-condition stream-error (error)
338  ((stream :initarg :stream :reader stream-error-stream)))
339
340(defun stream-error-context (condition)
341  (let* ((stream (stream-error-stream condition)))
342    (with-output-to-string (s)
343       (format s "on ~s" stream)
344       (let* ((pos (ignore-errors (stream-position stream))))
345         (when pos
346           (format s ", near position ~d" pos)))
347       (let* ((surrounding (stream-surrounding-characters stream)))
348         (when surrounding
349           (format s ", within ~s" surrounding))))))
350
351(define-condition parse-error (error) ())
352(define-condition parse-integer-not-integer-string (parse-error)
353  ((string :initarg :string))
354  (:report (lambda (c s)
355             (format s "Not an integer string: ~s" (slot-value c 'string)))))
356
357(define-condition reader-error (parse-error stream-error) ())
358(define-condition end-of-file (stream-error) ()
359  (:report (lambda (c s)
360             (format s "Unexpected end of file ~s" (stream-error-context c)))))
361(define-condition impossible-number (reader-error)
362  ((token :initarg :token :reader impossible-number-token)
363   (condition :initarg :condition :reader impossible-number-condition))
364  (:report (lambda (c s)
365             (format s "Condition of type ~s raised ~&while trying to parse numeric token ~s ~&~s"
366                     (type-of (impossible-number-condition c))
367                     (impossible-number-token c)
368                     (stream-error-context c)))))
369
370
371   
372(define-condition simple-stream-error (stream-error simple-condition) () 
373  (:report (lambda (c s) 
374             (format s "Error ~s : ~&~a" (stream-error-context c) 
375                     (apply #'format
376                            nil
377                            (simple-condition-format-control c)
378                            (simple-condition-format-arguments c))))))
379
380
381
382
383(define-condition file-error (error)
384  ((pathname :initarg :pathname :initform "<unspecified>" :reader file-error-pathname)
385   (error-type :initarg :error-type :initform "File error on file ~S"))
386  (:report (lambda (c s)
387              (format s (slot-value c 'error-type) 
388                     (file-error-pathname c)))))
389
390(define-condition simple-file-error (simple-condition file-error)
391  ()
392  (:report (lambda (c s)
393             (apply #'format s (slot-value c 'error-type) 
394                    (file-error-pathname c)
395                    (simple-condition-format-arguments c)))))
396
397
398(define-condition namestring-parse-error (error)
399  ((complaint :reader namestring-parse-error-complaint :initarg :complaint)
400   (arguments :reader namestring-parse-error-arguments :initarg :arguments
401              :initform nil)
402   (namestring :reader namestring-parse-error-namestring :initarg :namestring)
403   (offset :reader namestring-parse-error-offset :initarg :offset))
404  (:report (lambda (condition stream) 
405  (format stream "Parse error in namestring: ~?~%  ~A~%  ~V@T^"
406          (namestring-parse-error-complaint condition)
407          (namestring-parse-error-arguments condition)
408          (namestring-parse-error-namestring condition)
409          (namestring-parse-error-offset condition)))))
410
411(define-condition cell-error (error)
412  ((name :initarg :name :reader cell-error-name)
413   (error-type :initarg :error-type :initform "Cell error" :reader cell-error-type))
414  (:report (lambda (c s) (format s "~A: ~S" (cell-error-type c) (cell-error-name c)))))
415
416(define-condition unbound-variable (cell-error)
417  ((error-type :initform "Unbound variable")))
418
419(define-condition undefined-function (cell-error)
420  ((error-type :initform "Undefined function")))
421(define-condition undefined-function-call (control-error undefined-function)
422  ((function-arguments :initarg :function-arguments :reader undefined-function-call-arguments))
423  (:report (lambda (c s) (format s "Undefined function ~S called with arguments ~:S ."
424                                 (cell-error-name c)
425                                 (undefined-function-call-arguments c)))))
426
427(define-condition call-special-operator-or-macro (undefined-function-call)
428  ()
429  (:report (lambda (c s) (format s "Special operator or global macro-function ~s can't be FUNCALLed or APPLYed" (cell-error-name c)))))
430
431 
432(define-condition unbound-slot (cell-error)
433  ((instance :initarg :instance :accessor unbound-slot-instance))
434  (:report (lambda (c s) (format s "Slot ~s is unbound in ~s"
435                                 (cell-error-name c)
436                                 (unbound-slot-instance c)))))
437 
438
439(define-condition arithmetic-error (error) 
440  ((operation :initform nil :initarg :operation :reader arithmetic-error-operation)
441   (operands :initform nil :initarg :operands :reader arithmetic-error-operands))
442  (:report (lambda (c s) (format s "~S detected ~&performing ~S on ~:S"
443                                 (type-of c) 
444                                 (arithmetic-error-operation c) 
445                                 (arithmetic-error-operands c)))))
446
447(define-condition division-by-zero (arithmetic-error))
448 
449(define-condition floating-point-underflow (arithmetic-error))
450(define-condition floating-point-overflow (arithmetic-error))
451(define-condition floating-point-inexact (arithmetic-error))
452(define-condition floating-point-invalid-operation (arithmetic-error))
453
454(defun restartp (thing) 
455  (istruct-typep thing 'restart))
456(setf (type-predicate 'restart) 'restartp)
457
458(defmethod print-object ((restart restart) stream)
459  (let ((report (%restart-report restart)))
460    (cond ((or *print-escape* (null report))
461           (print-unreadable-object (restart stream :identity t)
462             (format stream "~S ~S"
463                     'restart (%restart-name restart))))
464          ((stringp report)
465           (write-string report stream))
466          (t
467           (funcall report stream)))))
468
469(defun %make-restart (name action report interactive test)
470  (%cons-restart name action report interactive test))
471
472(defun make-restart (vector name action-function &key report-function interactive-function test-function)
473  (unless vector (setq vector (%cons-restart nil nil nil nil nil)))
474  (setf (%restart-name vector) name
475        (%restart-action vector) (require-type action-function 'function)
476        (%restart-report vector) (if report-function (require-type report-function 'function))
477        (%restart-interactive vector) (if interactive-function (require-type interactive-function 'function))
478        (%restart-test vector) (if test-function (require-type test-function 'function)))
479  vector)
480
481(defun restart-name (restart)
482  "Return the name of the given restart object."
483  (%restart-name (require-type restart 'restart)))
484
485(defun applicable-restart-p (restart condition)
486  (let* ((pair (if condition (assq restart *condition-restarts*)))
487         (test (%restart-test restart)))
488    (and (or (null pair) (eq (%cdr pair) condition))
489         (or (null test) (funcall test condition)))))
490
491(defun compute-restarts (&optional condition &aux restarts)
492  "Return a list of all the currently active restarts ordered from most
493   recently established to less recently established. If CONDITION is
494   specified, then only restarts associated with CONDITION (or with no
495   condition) will be returned."
496  (dolist (cluster %restarts% (nreverse restarts))
497    (dolist (restart cluster)
498      (when (applicable-restart-p restart condition)
499        (push restart restarts)))))
500
501(defun find-restart (name &optional condition)
502  "Return the first active restart named NAME. If NAME names a
503   restart, the restart is returned if it is currently active. If no such
504   restart is found, NIL is returned. It is an error to supply NIL as a
505   name. If CONDITION is specified and not NIL, then only restarts
506   associated with that condition (or with no condition) will be
507   returned."
508  (dolist (cluster %restarts%)
509    (dolist (restart cluster)
510      (when (and (or (eq restart name) (eq (restart-name restart) name))
511                 (applicable-restart-p restart condition))
512        (return-from find-restart restart)))))
513
514(defun %active-restart (name)
515  (dolist (cluster %restarts%)
516    (dolist (restart cluster)
517      (let* ((rname (%restart-name restart))
518             (rtest (%restart-test restart)))
519        (when (and (or (eq restart name) (eq rname name))
520                   (or (null rtest) (funcall rtest nil)))
521          (return-from %active-restart (values restart cluster))))))
522  (error 'inactive-restart :restart-name name))
523
524(defun invoke-restart (restart &rest values)
525  "Calls the function associated with the given restart, passing any given
526   arguments. If the argument restart is not a restart or a currently active
527   non-nil restart name, then a CONTROL-ERROR is signalled."
528  (multiple-value-bind (restart tag) (%active-restart restart)
529    (let ((fn (%restart-action restart)))
530      (cond ((null fn)                  ; simple restart
531             (unless (null values) (%err-disp $xtminps))
532             (throw tag nil))
533            ((fixnump fn)               ; restart case
534             (throw tag (cons fn values)))
535            ((functionp fn)             ; restart bind
536             (apply fn values))         
537            (t                          ; with-simple-restart
538             (throw tag (values nil t)))))))
539
540(defun invoke-restart-no-return (restart)
541  (invoke-restart restart)
542  (error 'restart-failure :restart restart))
543
544(defun invoke-restart-interactively (restart)
545  "Calls the function associated with the given restart, prompting for any
546   necessary arguments. If the argument restart is not a restart or a
547   currently active non-NIL restart name, then a CONTROL-ERROR is signalled."
548  (let* ((restart (find-restart restart)))
549    (format *error-output* "~&Invoking restart: ~a~&" restart)
550    (let* ((argfn (%restart-interactive restart))
551           (values (when argfn (funcall argfn))))
552      (apply #'invoke-restart restart values))))
553
554
555
556(defun maybe-invoke-restart (restart value condition)
557  (let ((restart (find-restart restart condition)))
558    (when restart (invoke-restart restart value))))
559
560(defun use-value (value &optional condition)
561  "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if
562   none exists."
563  (maybe-invoke-restart 'use-value value condition))
564
565(defun store-value (value &optional condition)
566  "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if
567   none exists."
568  (maybe-invoke-restart 'store-value value condition))
569
570(defun condition-arg (thing args type)
571  (cond ((condition-p thing) (if args (%err-disp $xtminps) thing))
572        ((symbolp thing) (apply #'make-condition thing args))
573        (t (make-condition type :format-control thing :format-arguments args))))
574
575(defun make-condition (name &rest init-list)
576  "Make an instance of a condition object using the specified initargs."
577  (declare (dynamic-extent init-list))
578  (let ((class (or (and (symbolp name) (find-class name nil))
579                   name)))
580    (if (condition-p (class-prototype class))
581        (apply #'make-instance class init-list)
582        (error "~S is not a defined condition type name" name))))
583
584(defmethod print-object ((c condition) stream)
585  (if *print-escape* 
586    (call-next-method)
587    (report-condition c stream)))
588
589(defmethod report-condition ((c condition) stream)
590  (princ (cond ((typep c 'error) "Error ")
591               ((typep c 'warning) "Warning ")
592               (t "Condition "))
593         stream)
594  ;Here should dump all slots or something.  For now...
595  (let ((*print-escape* t))
596    (print-object c stream)))
597
598(defun signal-simple-condition (class-name format-string &rest args)
599  (let ((e #'error))  ; Never-tail-call.
600    (funcall e (make-condition class-name :format-control format-string :format-arguments args))))
601
602(defun signal-simple-program-error (format-string &rest args)
603  (apply #'signal-simple-condition 'simple-program-error format-string args))
604
605;;getting the function name for error functions.
606
607
608(defun %last-fn-on-stack (&optional (number 0) (s (%get-frame-ptr)))
609  (let* ((fn nil))
610    (let ((p s))
611      (dotimes (i number)
612        (declare (fixnum i))
613        (unless (setq p (parent-frame p nil))
614          (return)))
615      (do* ((i number (1+ i)))
616           ((null p))
617        (if (setq fn (cfp-lfun p))
618          (return (values fn i))
619          (setq p (parent-frame p nil)))))))
620 
621(defun %err-fn-name (lfun)
622  "given an lfun returns the name or the string \"Unknown\""
623  (if (lfunp lfun) (or (lfun-name lfun) lfun)
624     (or lfun "Unknown")))
625
626(defun %real-err-fn-name (error-pointer)
627  (multiple-value-bind (fn p) (%last-fn-on-stack 0 error-pointer)
628    (let ((name (%err-fn-name fn)))
629      (if (and (memq name '( call-check-regs)) p)
630        (%err-fn-name (%last-fn-on-stack (1+ p) error-pointer))
631        name))))
632
633
634;; Some simple restarts for simple error conditions.  Callable from the kernel.
635
636(defun find-unique-homonym (name &optional test)
637  (let ((pname (and name (symbolp name) (symbol-name name)))
638        (other-name nil))
639    (dolist (pkg (list-all-packages) other-name)
640      (let ((candidate (find-symbol pname pkg)))
641        (when (and candidate
642                   (not (eq candidate name))
643                   (or (null test) (funcall test candidate)))
644          (when (and other-name (neq other-name candidate))
645            (return nil)) ;; more than one, too complicated, give up
646          (setq other-name candidate))))))
647
648
649(def-kernel-restart $xvunbnd %default-unbound-variable-restarts (frame-ptr cell-name)
650  (unless *level-1-loaded*
651    (dbg cell-name))       ;  user should never see this.
652  (let ((condition (make-condition 'unbound-variable :name cell-name))
653        (other-variable (find-unique-homonym cell-name #'boundp)))
654    (flet ((new-value ()
655             (catch-cancel
656              (return-from new-value
657                           (list (read-from-string 
658                                  (get-string-from-user
659                                   (format nil "New value for ~s : " cell-name))))))
660             (continue condition))) ; force error again if cancelled, var still not set.
661      (restart-case (%error condition nil frame-ptr)
662        (continue ()
663                  :report (lambda (s) (format s "Retry getting the value of ~S." cell-name))
664                  (symbol-value cell-name))
665        (use-homonym ()
666                     :test (lambda (c) (and (or (null c) (eq c condition)) other-variable))
667                     :report (lambda (s) (format s "Use the value of ~s this time." other-variable))
668                     (symbol-value other-variable))
669        (use-value (value)
670                   :interactive new-value
671                   :report (lambda (s) (format s "Specify a value of ~S to use this time." cell-name))
672                   value)
673        (store-value (value)
674                     :interactive new-value
675                     :report (lambda (s) (format s "Specify a value of ~S to store and use." cell-name))
676                     (setf (symbol-value cell-name) value))))))
677
678(def-kernel-restart $xnopkg %default-no-package-restart (frame-ptr package-name)
679  (or (and *autoload-lisp-package*
680           (or (string-equal package-name "LISP") 
681               (string-equal package-name "USER"))
682           (progn
683             (require "LISP-PACKAGE")
684             (find-package package-name)))
685      (let* ((alias (or (%cdr (assoc package-name '(("LISP" . "COMMON-LISP")
686                                                    ("USER" . "CL-USER")) 
687                                     :test #'string-equal))
688                        (if (packagep *package*) (package-name *package*))))
689             (condition (make-condition 'no-such-package :package package-name)))
690        (flet ((try-again (p)
691                          (or (find-package p) (%kernel-restart $xnopkg p))))
692          (restart-case
693            (restart-case (%error condition nil frame-ptr)
694              (continue ()
695                        :report (lambda (s) (format s "Retry finding package with name ~S." package-name))
696                        (try-again package-name))
697              (use-value (value)
698                         :interactive (lambda () (block nil 
699                                                   (catch-cancel
700                                                    (return (list (get-string-from-user
701                                                                   "Find package named : "))))
702                                                   (continue condition)))
703                         :report (lambda (s) (format s "Find specified package instead of ~S ." package-name))
704                         (try-again value))
705              (make-nickname ()
706                             :report (lambda (s) (format s "Make ~S be a nickname for package ~S." package-name alias))
707                             (let ((p (try-again alias)))
708                               (push package-name (cdr (pkg.names p)))
709                               p)))
710            (require-lisp-package ()
711                                  :test (lambda (c)
712                                          (and (eq c condition)
713                                               (or (string-equal package-name "LISP") (string-equal package-name "USER"))))
714                                  :report (lambda (s) 
715                                            (format s "(require :lisp-package) and retry finding package ~s"
716                                                    package-name))
717                                  (require "LISP-PACKAGE")
718                                  (try-again package-name)))))))
719
720(def-kernel-restart $xunintc unintern-conflict-restarts (frame-ptr sym package conflicts)
721  (let ((condition (make-condition 'unintern-conflict-error :package package :sym sym :conflicts conflicts)))
722    (restart-case (%error condition nil frame-ptr)
723      (continue ()
724                :report (lambda (s) (format s "Try again to unintern ~s from ~s" sym package))
725                (unintern sym package))
726      (do-shadowing-import (ssym)
727                           :report (lambda (s) (format s "SHADOWING-IMPORT one of ~S in ~S." conflicts package))
728                           :interactive (lambda ()
729                                          (block nil
730                                            (catch-cancel
731                                             (return (select-item-from-list conflicts 
732                                                                            :window-title 
733                                                                            (format nil "Shadowing-import one of the following in ~s" package)
734                                                                            :table-print-function #'prin1)))
735                                            (continue condition)))
736                           (shadowing-import (list ssym) package)))))
737
738
739(def-kernel-restart $xusec blub (frame-ptr package-to-use using-package conflicts)
740  (resolve-use-package-conflict-error frame-ptr package-to-use using-package conflicts nil))
741
742(def-kernel-restart $xusecX blub (frame-ptr package-to-use using-package conflicts)
743  (resolve-use-package-conflict-error frame-ptr package-to-use using-package conflicts t))
744
745(defun resolve-use-package-conflict-error (frame-ptr package-to-use using-package conflicts external-p)
746  (let ((condition (make-condition 'use-package-conflict-error 
747                                   :package using-package
748                                   :package-to-use package-to-use
749                                   :conflicts conflicts
750                                   :external-p external-p)))
751    (flet ((external-test (&rest ignore) (declare (ignore ignore)) external-p)
752           (present-test (&rest ignore) (declare (ignore ignore)) (not external-p)))
753      (declare (dynamic-extent #'present-test #'external-test))
754      (restart-case (%error condition nil frame-ptr)
755        (continue ()
756                  :report (lambda (s) (format s "Try again to use ~s in ~s" package-to-use using-package)))
757        (resolve-by-shadowing-import (&rest shadowing-imports)
758                                     :test external-test
759                                     :interactive (lambda ()
760                                                    (mapcar #'(lambda (pair) 
761                                                                (block nil
762                                                                  (catch-cancel
763                                                                    (return (car (select-item-from-list pair
764                                                                                                        :window-title 
765                                                                                                        (format nil "Shadowing-import one of the following in ~s" using-package)
766                                                                                                        :table-print-function #'prin1))))
767                                                                  (continue condition)))
768                                                            conflicts))
769                                     :report (lambda (s) (format s "SHADOWING-IMPORT one of each pair of conflicting symbols."))
770                                     (shadowing-import shadowing-imports using-package))
771        (unintern-all ()
772                      :test present-test
773                      :report (lambda (s) (format s "UNINTERN all conflicting symbols from ~S" using-package))
774                      (dolist (c conflicts)
775                        (unintern (car c) using-package)))
776        (shadow-all ()
777                      :test present-test
778                      :report (lambda (s) (format s "SHADOW all conflicting symbols in ~S" using-package))
779                      (dolist (c conflicts)
780                        (shadow-1 using-package (car c))))
781        (resolve-by-unintern-or-shadow (&rest dispositions)
782                                       :test present-test
783                                       :interactive (lambda ()
784                                                      (mapcar #'(lambda (pair)
785                                                                  (let* ((present-sym (car pair)))
786                                                                    (block nil
787                                                                      (catch-cancel
788                                                                        (return (car (select-item-from-list (list 'shadow 'unintern) 
789                                                                                                            :window-title
790                                                                                                            (format nil "SHADOW ~S in, or UNINTERN ~S from ~S" 
791                                                                                                                    present-sym 
792                                                                                                                    present-sym
793                                                                                                                    using-package)
794                                                                                                            :table-print-function #'prin1)))
795                                                                        (continue condition)))))
796                                                              conflicts))
797                                       :report (lambda (s) (format s "SHADOW or UNINTERN the conflicting symbols in ~S." using-package))
798                                       (dolist (d dispositions)
799                                         (let* ((sym (car (pop conflicts))))
800                                           (if (eq d 'shadow)
801                                             (shadow-1 using-package sym)
802                                             (unintern sym using-package)))))))))
803
804
805(defun resolve-export-conflicts (conflicts package)
806  (let* ((first-inherited (caar conflicts))
807         (all-same (dolist (conflict (cdr conflicts) t)
808                     (unless (eq (car conflict) first-inherited) (return nil))))
809         (all-inherited (and all-same first-inherited))
810         (all-present (and all-same (not first-inherited)))
811         (condition (make-condition 'export-conflict-error
812                                    :conflicts conflicts
813                                    :package package)))
814    (flet ((check-again () 
815             (let* ((remaining-conflicts (check-export-conflicts (mapcar #'cadr conflicts) package)))
816               (if remaining-conflicts (resolve-export-conflicts remaining-conflicts package)))))
817      (restart-case (%error condition nil (%get-frame-ptr))
818        (resolve-all-by-shadowing-import-inherited 
819         ()
820         :test (lambda (&rest ignore) (declare (ignore ignore)) all-inherited)
821         :report (lambda (s) (format s "SHADOWING-IMPORT all conflicting inherited symbol(s) in using package(s)."))
822         (dolist (conflict conflicts (check-again))
823           (destructuring-bind (using-package inherited-sym) (cddr conflict)
824             (shadowing-import-1 using-package inherited-sym))))
825        (resolve-all-by-shadowing-import-exported 
826         ()
827         :test (lambda (&rest ignore) (declare (ignore ignore)) all-inherited)
828         :report (lambda (s) (format s "SHADOWING-IMPORT all conflicting symbol(s) to be exported in using package(s)."))
829         (dolist (conflict conflicts (check-again))
830           (destructuring-bind (exported-sym using-package ignore) (cdr conflict)
831             (declare (ignore ignore))
832             (shadowing-import-1 using-package exported-sym))))
833        (resolve-all-by-uninterning-present 
834         ()
835         :test (lambda (&rest ignore) (declare (ignore ignore)) all-present)
836         :report (lambda (s) (format s "UNINTERN all present conflicting symbol(s) in using package(s)."))
837         (dolist (conflict conflicts (check-again))
838           (destructuring-bind (using-package inherited-sym) (cddr conflict)
839             (unintern inherited-sym using-package))))
840        (resolve-all-by-shadowing-present 
841         ()
842         :test (lambda (&rest ignore) (declare (ignore ignore)) all-present)
843         :report (lambda (s) (format s "SHADOW all present conflicting symbol(s) in using package(s)."))
844         (dolist (conflict conflicts (check-again))
845           (destructuring-bind (using-package inherited-sym) (cddr conflict)
846             (shadow-1 using-package inherited-sym))))
847        (review-and-resolve 
848         (dispositions)
849         :report (lambda (s) (format s "Review each name conflict and resolve individually."))
850         :interactive (lambda ()
851                        (let* ((disp nil))
852                          (block b
853                            (catch-cancel
854                              (dolist (conflict conflicts (return-from b (list disp)))
855                                (destructuring-bind (inherited-p exported-sym using-package conflicting-sym) conflict
856                                  (let* ((syms (list exported-sym conflicting-sym)))
857                                    (if inherited-p
858                                      (push (list 'shadowing-import
859                                                  (select-item-from-list syms
860                                                                              :window-title 
861                                                                              (format nil "Shadowing-import one of the following in ~s" using-package)
862                                                                              :table-print-function #'prin1)
863                                                  using-package)
864                                            disp)
865                                      (let* ((selection (car (select-item-from-list syms
866                                                                                    :window-title 
867                                                                                    (format nil "Shadow ~S or unintern ~s in ~s"
868                                                                                            exported-sym 
869                                                                                            conflicting-sym using-package)
870                                                                                    :table-print-function #'prin1))))
871                                        (push (if (eq selection 'exported-sym)
872                                                (list 'shadow (list exported-sym) using-package)
873                                                (list 'unintern conflicting-sym using-package))
874                                              disp)))))))
875                            nil)))
876         (dolist (disp dispositions (check-again))
877           (apply (car disp) (cdr disp))))))))
878
879
880(def-kernel-restart $xwrongtype default-require-type-restarts (frame-ptr value typespec)
881  (setq typespec (%type-error-type typespec))
882  (let ((condition (make-condition 'type-error 
883                                   :datum value
884                                   :expected-type typespec)))
885    (restart-case (%error condition nil frame-ptr)
886      (use-value (newval)
887                 :report (lambda (s)
888                           (format s "Use a new value of type ~s instead of ~s." typespec value))
889                 :interactive (lambda ()
890                                (format *query-io* "~&New value of type ~S :" typespec)
891                                (list (read *query-io*)))
892                 (require-type newval typespec)))))
893
894(def-kernel-restart $xudfcall default-undefined-function-call-restarts (frame-ptr function-name args)
895  (unless *level-1-loaded*
896    (dbg function-name))   ; user should never see this
897  (let ((condition (make-condition 'undefined-function-call
898                                   :name function-name
899                                   :function-arguments args))
900        (other-function (find-unique-homonym function-name #'fboundp)))
901    (restart-case (%error condition nil frame-ptr)
902      (continue ()
903                :report (lambda (s) (format s "Retry applying ~S to ~S." function-name args))
904                (apply function-name args))
905      (use-homonym ()
906                   :test (lambda (c) (and (or (null c) (eq c condition)) other-function))
907                   :report (lambda (s) (format s "Apply ~s to ~S this time." other-function args))
908                   (apply other-function args))
909      (use-value (function)
910                 :interactive (lambda ()
911                                (format *query-io* "Function to apply instead of ~s :" function-name)
912                                (let ((f (read *query-io*)))
913                                  (unless (symbolp f) (setq f (eval f))) ; almost-the-right-thing (tm)
914                                  (list (coerce f 'function))))
915                 :report (lambda (s) (format s "Apply specified function to ~S this time." args))
916                 (apply function args))
917      (store-value (function)
918                   :interactive (lambda ()
919                                (format *query-io* "Function to apply as new definition of ~s :" function-name)
920                                (let ((f (read *query-io*)))
921                                  (unless (symbolp f) (setq f (eval f))) ; almost-the-right-thing (tm)
922                                  (list (coerce f 'function))))
923                   :report (lambda (s) (format s "Specify a function to use as the definition of ~S." function-name))
924                   (apply (setf (symbol-function function-name) function) args)))))
925
926
927
928
929; This has to be defined fairly early (assuming, of course, that it "has" to be defined at all ...
930
931(defun ensure-value-of-type (value typespec placename &optional typename)
932  (tagbody
933    again
934    (unless (typep value typespec)
935      (let ((condition (make-condition 'type-error 
936                                       :datum value
937                                       :expected-type typespec)))
938        (if typename
939            (setf (slot-value condition 'format-control)
940                  (format nil "value ~~S is not ~A (~~S)." typename)))
941        (restart-case (%error condition nil (%get-frame-ptr))
942          (store-value (newval)
943                       :report (lambda (s)
944                                 (format s "Assign a new value of type ~a to ~s" typespec placename))
945                       :interactive (lambda ()
946                                      (format *query-io* "~&New value for ~S :" placename)
947                                      (list (eval (read))))
948                       (setq value newval)
949                       (go again))))))
950  value)
951
952;;;The Error Function
953
954(defparameter *kernel-simple-error-classes*
955  (list (cons $xcalltoofew 'simple-destructuring-error)
956        (cons $xcalltoomany 'simple-destructuring-error)
957        (cons $xstkover 'stack-overflow-condition)
958        (cons $xmemfull 'simple-storage-condition)
959        (cons $xwrongtype 'type-error) ; this one needs 2 args
960        (cons $xdivzro 'division-by-zero)
961        (cons $xflovfl 'floating-point-overflow)
962        (cons $xfunbnd 'undefined-function)
963        (cons $xbadkeys 'simple-program-error)
964        (cons $xnotfun 'call-special-operator-or-macro)
965        (cons $xaccessnth 'sequence-index-type-error)
966        (cons $ximproperlist 'improper-list)
967        (cons $xnospread 'cant-construct-arglist)
968        ))
969
970
971(defparameter *simple-error-types*
972  (vector nil 'simple-program-error 'simple-file-error))
973
974(defconstant $pgm-err #x10000)
975
976
977
978
979(defparameter %type-error-typespecs%
980  #(array
981    bignum
982    fixnum
983    character
984    integer
985    list
986    number
987    sequence
988    simple-string
989    simple-vector
990    string
991    symbol
992    macptr
993    real
994    cons
995    unsigned-byte
996    (integer 2 36)
997    float
998    rational
999    ratio
1000    short-float
1001    double-float
1002    complex
1003    vector
1004    simple-base-string
1005    function
1006    (unsigned-byte 16)
1007    (unsigned-byte 8)
1008    (unsigned-byte 32)
1009    (signed-byte 32)
1010    (signed-byte 16)
1011    (signed-byte 8)
1012    base-char
1013    bit
1014    (unsigned-byte 24)                  ; (integer 0 (array-total-size-limit))
1015    (unsigned-byte 64)
1016    (signed-byte 64)
1017    (unsigned-byte 56)
1018    (simple-array double-float (* *))
1019    (simple-array single-float (* *))
1020    (mod #x110000)
1021    (array * (* *))                     ;2d array
1022    (array * (* *))                     ;3d array
1023    (array t)
1024    (array bit)
1025    (array (signed-byte 8))
1026    (array (unsigned-byte 8))
1027    (array (signed-byte 16))
1028    (array (unsigned-byte 16))
1029    (array (signed-byte 32))
1030    (array (unsigned-byte 32))
1031    (array (signed-byte 64))
1032    (array (unsigned-byte 64))
1033    (array fixnum)
1034    (array single-float)
1035    (array double-float)
1036    (array character)
1037    (array t (* *))
1038    (array bit (* *))
1039    (array (signed-byte 8) (* *))
1040    (array (unsigned-byte 8) (* *))
1041    (array (signed-byte 16) (* *))
1042    (array (unsigned-byte 16) (* *))
1043    (array (signed-byte 32) (* *))
1044    (array (unsigned-byte 32) (* *))
1045    (array (signed-byte 64) (* *))
1046    (array (unsigned-byte 64) (* *))
1047    (array fixnum (* *))
1048    (array single-float (* *))
1049    (array double-float (* *))
1050    (array character (* *))
1051    (simple-array t (* *))
1052    (simple-array bit (* *))
1053    (simple-array (signed-byte 8) (* *))
1054    (simple-array (unsigned-byte 8) (* *))
1055    (simple-array (signed-byte 16) (* *))
1056    (simple-array (unsigned-byte 16) (* *))
1057    (simple-array (signed-byte 32) (* *))
1058    (simple-array (unsigned-byte 32) (* *))
1059    (simple-array (signed-byte 64) (* *))
1060    (simple-array (unsigned-byte 64) (* *))
1061    (simple-array fixnum (* *))
1062    (simple-array character (* *))
1063    (array t (* * *))
1064    (array bit (* * *))
1065    (array (signed-byte 8) (* * *))
1066    (array (unsigned-byte 8) (* * *))
1067    (array (signed-byte 16) (* * *))
1068    (array (unsigned-byte 16) (* * *))
1069    (array (signed-byte 32) (* * *))
1070    (array (unsigned-byte 32) (* * *))
1071    (array (signed-byte 64) (* * *))
1072    (array (unsigned-byte 64) (* * *))
1073    (array fixnum (* * *))
1074    (array single-float (* * *))
1075    (array double-float (* * *))
1076    (array character (* * *))
1077    (simple-array t (* * *))
1078    (simple-array bit (* * *))
1079    (simple-array (signed-byte 8) (* * *))
1080    (simple-array (unsigned-byte 8) (* * *))
1081    (simple-array (signed-byte 16) (* * *))
1082    (simple-array (unsigned-byte 16) (* * *))
1083    (simple-array (signed-byte 32) (* * *))
1084    (simple-array (unsigned-byte 32) (* * *))
1085    (simple-array (signed-byte 64) (* * *))
1086    (simple-array (unsigned-byte 64) (* * *))
1087    (simple-array fixnum (* * *))
1088    (simple-array single-float (* * *))
1089    (simple-array double-float (* * *))
1090    (simple-array char (* * *))
1091   
1092    ))
1093
1094
1095(defun %type-error-type (type)
1096  (if (fixnump type) 
1097    (svref %type-error-typespecs% type)
1098    type))
1099
1100(defun %typespec-id (typespec)
1101  (flet ((type-equivalent (t1 t2) (ignore-errors (and (subtypep t1 t2) (subtypep t2 t1)))))
1102    (position typespec %type-error-typespecs% :test #'type-equivalent)))
1103
1104
1105(defmethod condition-p ((x t)) nil)
1106(defmethod condition-p ((x condition)) t)
1107
1108
1109
1110(let* ((globals ()))
1111
1112  (defun %check-error-globals ()
1113    (let ((vars ())
1114          (valfs ())
1115          (oldvals ()))
1116      (dolist (g globals (values vars valfs oldvals))
1117        (destructuring-bind (sym predicate newvalf) g
1118          (let* ((boundp (boundp sym))
1119                 (oldval (if boundp (symbol-value sym) (%unbound-marker-8))))
1120          (unless (and boundp (funcall predicate oldval))
1121            (push sym vars)
1122            (push oldval oldvals)
1123            (push newvalf valfs)))))))
1124
1125  (defun check-error-global (sym checkfn newvalfn)
1126    (setq sym (require-type sym 'symbol)
1127          checkfn (require-type checkfn 'function)
1128          newvalfn (require-type newvalfn 'function))
1129    (let ((found (assq sym globals)))
1130      (if found
1131        (setf (cadr found) checkfn (caddr found) newvalfn)
1132        (push (list sym checkfn newvalfn) globals))
1133      sym))
1134)
1135
1136(check-error-global '*package* #'packagep #'(lambda () (find-package "CL-USER")))
1137
1138
1139 
1140
Note: See TracBrowser for help on using the repository browser.