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

Last change on this file since 3541 was 3541, checked in by gb, 15 years ago

Define IMPOSSIBLE-NUMBER as a subtype of READER-ERROR.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 46.8 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 type-error (error)
85  ((datum :initarg :datum)
86   (expected-type :initarg :expected-type :reader type-error-expected-type)
87   (format-control :initarg :format-control  :initform (%rsc-string  $xwrongtype) :reader type-error-format-control))
88  (:report (lambda (c s)
89             (format s (type-error-format-control c)
90                     (type-error-datum c) 
91                     (type-error-expected-type c)))))
92
93(define-condition bad-slot-type (type-error)
94  ((slot-definition :initform nil :initarg :slot-definition)
95   (instance :initform nil :initarg :instance))
96  (:report (lambda (c s)
97             (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. "
98                     (type-error-datum c)
99                     (slot-definition-name (slot-value c 'slot-definition))
100                     (slot-value c 'instance)
101                     (type-error-expected-type c)))))
102
103(define-condition bad-slot-type-from-initform (bad-slot-type)
104  ()
105  (:report (lambda (c s)
106             (let* ((slotd (slot-value c 'slot-definition)))
107               (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. "
108                     (type-error-datum c)
109                     (slot-definition-initform slotd)
110                     (slot-definition-name slotd)
111                     (slot-value c 'instance)
112                     (type-error-expected-type c))))))
113
114(define-condition bad-slot-type-from-initarg (bad-slot-type)
115  ((initarg-name :initarg :initarg-name))
116  (:report (lambda (c s)
117             (let* ((slotd (slot-value c 'slot-definition)))
118               (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. "
119                     (type-error-datum c)
120                     (slot-value c 'initarg-name)
121                     (slot-definition-name slotd)
122                     (slot-value c 'instance)
123                     (type-error-expected-type c))))))
124 
125
126(define-condition improper-list (type-error)
127  ((expected-type :initform '(satisfies proper-list-p) :reader type-error-expected-type)))
128
129(define-condition cant-construct-arglist (improper-list)
130  ())
131
132
133
134(let* ((magic-token '("Unbound")))
135  (defmethod type-error-datum ((c type-error))
136    (let* ((datum-slot (slot-value c 'datum)))
137      (if (eq magic-token datum-slot)
138        (%unbound-marker-8)
139        datum-slot)))
140
141; do we need this
142  (defun signal-type-error (datum expected &optional (format-string (%rsc-string  $xwrongtype)))
143    (let ((error #'error))
144      (funcall error (make-condition 'type-error
145                                     :format-control format-string
146                                     :datum (if (eq datum (%unbound-marker-8)) magic-token datum)
147                                     :expected-type (%type-error-type expected)))))
148)
149
150
151(define-condition sequence-index-type-error (type-error)
152  ((sequence :initarg :sequence))
153  (:report (lambda (c s)
154             (format s "~s is not a valid sequence index for ~s"
155                     (type-error-datum c)
156                     (slot-value c 'sequence)))))
157
158
159;;; This is admittedly sleazy; ANSI CL requires TYPE-ERRORs to be
160;;; signalled in cases where a type-specifier is not of an appropriate
161;;; subtype.  The sleazy part is whether it's right to overload TYPE-ERROR
162;;; like this.
163
164(define-condition invalid-subtype-error (type-error)
165  ()
166  (:report (lambda (c s)
167             (format s "The type specifier ~S is not determinably a subtype of the type ~S"
168                     (type-error-datum c)
169                     (type-error-expected-type c)))))
170
171(define-condition simple-type-error (simple-condition type-error))
172
173
174
175(define-condition program-error (error))
176(define-condition simple-program-error (simple-condition program-error)
177  ((context :initarg :context :reader simple-program-error-context :initform nil)))
178
179(defun signal-program-error (string &rest args)
180  (let* ((e #'error))
181    (funcall e
182             (make-condition 'simple-program-error
183                             :format-control (if (fixnump string) (%rsc-string string) string)
184                             :format-arguments args))))
185
186(define-condition simple-destructuring-error (simple-program-error))
187
188(define-condition wrong-number-of-arguments (program-error)
189  ((nargs :initform nil
190          :initarg :nargs :reader wrong-number-of-arguments-nargs)
191   (fn :initform nil :initarg :fn :reader wrong-number-of-arguments-fn))
192  (:report report-argument-mismatch))
193       
194(define-condition too-many-arguments (wrong-number-of-arguments))
195
196(define-condition too-few-arguments (wrong-number-of-arguments))
197
198(defun report-argument-mismatch (c s)
199  (let* ((nargs-provided (wrong-number-of-arguments-nargs c))
200         (fn (wrong-number-of-arguments-fn c))
201         (too-many (typep c 'too-many-arguments)))
202    (multiple-value-bind (min max scaled-nargs)
203        (min-max-actual-args fn nargs-provided)
204      (if (not min)
205        (progn
206          (format s "Function ~s called with too ~a arguments. "
207                  fn
208                  (if too-many
209                    "many"
210                    "few")))
211        (if too-many
212          (format s "Too many arguments in call to ~s: ~d provided, at most ~d accepted. " fn scaled-nargs max)
213          (format s "Too few arguments in call to ~s: ~d provided, at least ~d required. " fn  scaled-nargs min))))))
214
215
216
217(define-condition compile-time-program-error (simple-program-error)
218  nil ;((context :initarg :context :reader compile-time-program-error-context))
219  (:report
220   (lambda (c s)
221     (format s "While compiling ~a :~%~a" 
222             (simple-program-error-context c)
223             (apply #'format nil (simple-condition-format-control c) (simple-condition-format-arguments c))))))
224
225(define-condition eval-program-error (simple-program-error)
226  nil ;((context :initarg :context :reader eval-program-error-context))
227  (:report
228   (lambda (c s)
229     (format s "While preprocessing ~a :~%~a" 
230             (simple-program-error-context c)
231             (apply #'format nil (simple-condition-format-control c) (simple-condition-format-arguments c))))))
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(define-condition parse-error (error) ())
340(define-condition parse-integer-not-integer-string (parse-error)
341  ((string :initarg :string))
342  (:report (lambda (c s)
343             (format s "Not an integer string: ~s" (slot-value c 'string)))))
344
345(define-condition reader-error (parse-error stream-error) ())
346(define-condition end-of-file (stream-error) ()
347  (:report (lambda (c s)
348             (format s "Unexpected end of file on ~s" (stream-error-stream c)))))
349(define-condition impossible-number (reader-error)
350  ((token :initarg :token :reader impossible-number-token)
351   (condition :initarg :condition :reader impossible-number-condition))
352  (:report (lambda (c s)
353             (format s "Condition of type ~s raised while trying to parse numeric token ~s on ~s"
354                     (type-of (impossible-number-condition c))
355                     (impossible-number-token c)
356                     (stream-error-stream c)))))
357
358
359   
360(define-condition simple-stream-error (stream-error simple-condition) () 
361  (:report (lambda (c s) 
362             (format s "Error on ~s : ~&~a" (stream-error-stream c) 
363                     (apply #'format
364                            nil
365                            (simple-condition-format-control c)
366                            (simple-condition-format-arguments c))))))
367
368
369(define-condition modify-read-only-buffer (error) ()
370  (:report (lambda (c s)
371             (declare (ignore c))
372             (format s "Cannot modify a read-only buffer"))))
373
374(define-condition file-error (error)
375  ((pathname :initarg :pathname :initform "<unspecified>" :reader file-error-pathname)
376   (error-type :initarg :error-type :initform "File error on file ~S"))
377  (:report (lambda (c s)
378              (format s (slot-value c 'error-type) 
379                     (file-error-pathname c)))))
380
381(define-condition simple-file-error (simple-condition file-error)
382  ()
383  (:report (lambda (c s)
384             (apply #'format s (slot-value c 'error-type) 
385                    (file-error-pathname c)
386                    (simple-condition-format-arguments c)))))
387
388
389(define-condition namestring-parse-error (error)
390  ((complaint :reader namestring-parse-error-complaint :initarg :complaint)
391   (arguments :reader namestring-parse-error-arguments :initarg :arguments
392              :initform nil)
393   (namestring :reader namestring-parse-error-namestring :initarg :namestring)
394   (offset :reader namestring-parse-error-offset :initarg :offset))
395  (:report (lambda (condition stream) 
396  (format stream "Parse error in namestring: ~?~%  ~A~%  ~V@T^"
397          (namestring-parse-error-complaint condition)
398          (namestring-parse-error-arguments condition)
399          (namestring-parse-error-namestring condition)
400          (namestring-parse-error-offset condition)))))
401
402(define-condition cell-error (error)
403  ((name :initarg :name :reader cell-error-name)
404   (error-type :initarg :error-type :initform "Cell error" :reader cell-error-type))
405  (:report (lambda (c s) (format s "~A: ~S" (cell-error-type c) (cell-error-name c)))))
406
407(define-condition unbound-variable (cell-error)
408  ((error-type :initform "Unbound variable")))
409
410(define-condition undefined-function (cell-error)
411  ((error-type :initform "Undefined function")))
412(define-condition undefined-function-call (control-error undefined-function)
413  ((function-arguments :initarg :function-arguments :reader undefined-function-call-arguments))
414  (:report (lambda (c s) (format s "Undefined function ~S called with arguments ~:S ."
415                                 (cell-error-name c)
416                                 (undefined-function-call-arguments c)))))
417
418(define-condition call-special-operator-or-macro (undefined-function-call)
419  ()
420  (:report (lambda (c s) (format s "Special operator or global macro-function ~s can't be FUNCALLed or APPLYed" (cell-error-name c)))))
421
422 
423(define-condition unbound-slot (cell-error)
424  ((instance :initarg :instance :accessor unbound-slot-instance))
425  (:report (lambda (c s) (format s "Slot ~s is unbound in ~s"
426                                 (cell-error-name c)
427                                 (unbound-slot-instance c)))))
428 
429
430(define-condition arithmetic-error (error) 
431  ((operation :initform nil :initarg :operation :reader arithmetic-error-operation)
432   (operands :initform nil :initarg :operands :reader arithmetic-error-operands))
433  (:report (lambda (c s) (format s "~S detected ~&performing ~S on ~:S"
434                                 (type-of c) 
435                                 (arithmetic-error-operation c) 
436                                 (arithmetic-error-operands c)))))
437
438(define-condition division-by-zero (arithmetic-error))
439 
440(define-condition floating-point-underflow (arithmetic-error))
441(define-condition floating-point-overflow (arithmetic-error))
442(define-condition floating-point-inexact (arithmetic-error))
443(define-condition floating-point-invalid-operation (arithmetic-error))
444
445(defun restartp (thing) 
446  (istruct-typep thing 'restart))
447(setf (type-predicate 'restart) 'restartp)
448
449(defmethod print-object ((restart restart) stream)
450  (let ((report (%restart-report restart)))
451    (cond ((or *print-escape* (null report))
452           (print-unreadable-object (restart stream :identity t)
453             (format stream "~S ~S"
454                     'restart (%restart-name restart))))
455          ((stringp report)
456           (write-string report stream))
457          (t
458           (funcall report stream)))))
459
460(defun %make-restart (name action report interactive test)
461  (%cons-restart name action report interactive test))
462
463(defun make-restart (vector name action-function &key report-function interactive-function test-function)
464  (unless vector (setq vector (%cons-restart nil nil nil nil nil)))
465  (setf (%restart-name vector) name
466        (%restart-action vector) (require-type action-function 'function)
467        (%restart-report vector) (if report-function (require-type report-function 'function))
468        (%restart-interactive vector) (if interactive-function (require-type interactive-function 'function))
469        (%restart-test vector) (if test-function (require-type test-function 'function)))
470  vector)
471
472(defun restart-name (restart)
473  "Return the name of the given restart object."
474  (%restart-name (require-type restart 'restart)))
475
476(defun applicable-restart-p (restart condition)
477  (let* ((pair (if condition (assq restart *condition-restarts*)))
478         (test (%restart-test restart)))
479    (and (or (null pair) (eq (%cdr pair) condition))
480         (or (null test) (funcall test condition)))))
481
482(defun compute-restarts (&optional condition &aux restarts)
483  "Return a list of all the currently active restarts ordered from most
484   recently established to less recently established. If CONDITION is
485   specified, then only restarts associated with CONDITION (or with no
486   condition) will be returned."
487  (dolist (cluster %restarts% (nreverse restarts))
488    (dolist (restart cluster)
489      (when (applicable-restart-p restart condition)
490        (push restart restarts)))))
491
492(defun find-restart (name &optional condition)
493  "Return the first active restart named NAME. If NAME names a
494   restart, the restart is returned if it is currently active. If no such
495   restart is found, NIL is returned. It is an error to supply NIL as a
496   name. If CONDITION is specified and not NIL, then only restarts
497   associated with that condition (or with no condition) will be
498   returned."
499  (dolist (cluster %restarts%)
500    (dolist (restart cluster)
501      (when (and (or (eq restart name) (eq (restart-name restart) name))
502                 (applicable-restart-p restart condition))
503        (return-from find-restart restart)))))
504
505(defun %active-restart (name)
506  (dolist (cluster %restarts%)
507    (dolist (restart cluster)
508      (let* ((rname (%restart-name restart))
509             (rtest (%restart-test restart)))
510        (when (and (or (eq restart name) (eq rname name))
511                   (or (null rtest) (funcall rtest nil)))
512          (return-from %active-restart (values restart cluster))))))
513  (error 'inactive-restart :restart-name name))
514
515(defun invoke-restart (restart &rest values)
516  "Calls the function associated with the given restart, passing any given
517   arguments. If the argument restart is not a restart or a currently active
518   non-nil restart name, then a CONTROL-ERROR is signalled."
519  (multiple-value-bind (restart tag) (%active-restart restart)
520    (let ((fn (%restart-action restart)))
521      (cond ((null fn)                  ; simple restart
522             (unless (null values) (%err-disp $xtminps))
523             (throw tag nil))
524            ((fixnump fn)               ; restart case
525             (throw tag (cons fn values)))
526            ((functionp fn)             ; restart bind
527             (apply fn values))         
528            (t                          ; with-simple-restart
529             (throw tag (values nil t)))))))
530
531(defun invoke-restart-no-return (restart)
532  (invoke-restart restart)
533  (error 'restart-failure :restart restart))
534
535(defun invoke-restart-interactively (restart)
536  "Calls the function associated with the given restart, prompting for any
537   necessary arguments. If the argument restart is not a restart or a
538   currently active non-NIL restart name, then a CONTROL-ERROR is signalled."
539  (let* ((restart (find-restart restart)))
540    (format *error-output* "~&Invoking restart: ~a~&" restart)
541    (let* ((argfn (%restart-interactive restart))
542           (values (when argfn (funcall argfn))))
543      (apply #'invoke-restart restart values))))
544
545
546
547(defun maybe-invoke-restart (restart value condition)
548  (let ((restart (find-restart restart condition)))
549    (when restart (invoke-restart restart value))))
550
551(defun use-value (value &optional condition)
552  "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if
553   none exists."
554  (maybe-invoke-restart 'use-value value condition))
555
556(defun store-value (value &optional condition)
557  "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if
558   none exists."
559  (maybe-invoke-restart 'store-value value condition))
560
561(defun condition-arg (thing args type)
562  (cond ((condition-p thing) (if args (%err-disp $xtminps) thing))
563        ((symbolp thing) (apply #'make-condition thing args))
564        (t (make-condition type :format-control thing :format-arguments args))))
565
566(defun make-condition (name &rest init-list)
567  "Make an instance of a condition object using the specified initargs."
568  (declare (dynamic-extent init-list))
569  (let ((class (or (and (symbolp name) (find-class name nil))
570                   name)))
571    (if (condition-p (class-prototype class))
572        (apply #'make-instance class init-list)
573        (error "~S is not a defined condition type name" name))))
574
575(defmethod print-object ((c condition) stream)
576  (if *print-escape* 
577    (call-next-method)
578    (report-condition c stream)))
579
580(defmethod report-condition ((c condition) stream)
581  (princ (cond ((typep c 'error) "Error ")
582               ((typep c 'warning) "Warning ")
583               (t "Condition "))
584         stream)
585  ;Here should dump all slots or something.  For now...
586  (let ((*print-escape* t))
587    (print-object c stream)))
588
589(defun signal-simple-condition (class-name format-string &rest args)
590  (let ((e #'error))  ; Never-tail-call.
591    (funcall e (make-condition class-name :format-control format-string :format-arguments args))))
592
593(defun signal-simple-program-error (format-string &rest args)
594  (apply #'signal-simple-condition 'simple-program-error format-string args))
595
596;;getting the function name for error functions.
597
598
599(defun %last-fn-on-stack (&optional (number 0) (s (%get-frame-ptr)))
600  (let* ((fn nil))
601    (let ((p s))
602      (dotimes (i number)
603        (declare (fixnum i))
604        (unless (setq p (parent-frame p nil))
605          (return)))
606      (do* ((i number (1+ i)))
607           ((null p))
608        (if (setq fn (cfp-lfun p))
609          (return (values fn i))
610          (setq p (parent-frame p nil)))))))
611 
612(defun %err-fn-name (lfun)
613  "given an lfun returns the name or the string \"Unknown\""
614  (if (lfunp lfun) (or (lfun-name lfun) lfun)
615     (or lfun "Unknown")))
616
617(defun %real-err-fn-name (error-pointer)
618  (multiple-value-bind (fn p) (%last-fn-on-stack 0 error-pointer)
619    (let ((name (%err-fn-name fn)))
620      (if (and (memq name '( call-check-regs)) p)
621        (%err-fn-name (%last-fn-on-stack (1+ p) error-pointer))
622        name))))
623
624
625;; Some simple restarts for simple error conditions.  Callable from the kernel.
626
627
628
629(def-kernel-restart $xvunbnd %default-unbound-variable-restarts (frame-ptr cell-name)
630  (unless *level-1-loaded*
631    (dbg cell-name))       ;  user should never see this.
632  (let ((condition (make-condition 'unbound-variable :name cell-name)))
633    (flet ((new-value ()
634             (catch-cancel
635              (return-from new-value
636                           (list (read-from-string 
637                                  (get-string-from-user
638                                   (format nil "New value for ~s : " cell-name))))))
639             (continue condition))) ; force error again if cancelled, var still not set.
640      (restart-case (%error condition nil frame-ptr)
641        (continue ()
642                  :report (lambda (s) (format s "Retry getting the value of ~S." cell-name))
643                  (symbol-value cell-name))
644        (use-value (value)
645                   :interactive new-value
646                   :report (lambda (s) (format s "Specify a value of ~S to use this time." cell-name))
647                   value)
648        (store-value (value)
649                     :interactive new-value
650                     :report (lambda (s) (format s "Specify a value of ~S to store and use." cell-name))
651                     (setf (symbol-value cell-name) value))))))
652
653(def-kernel-restart $xnopkg %default-no-package-restart (frame-ptr package-name)
654  (or (and *autoload-lisp-package*
655           (or (string-equal package-name "LISP") 
656               (string-equal package-name "USER"))
657           (progn
658             (require "LISP-PACKAGE")
659             (find-package package-name)))
660      (let* ((alias (or (%cdr (assoc package-name '(("LISP" . "COMMON-LISP")
661                                                    ("USER" . "CL-USER")) 
662                                     :test #'string-equal))
663                        (if (packagep *package*) (package-name *package*))))
664             (condition (make-condition 'no-such-package :package package-name)))
665        (flet ((try-again (p)
666                          (or (find-package p) (%kernel-restart $xnopkg p))))
667          (restart-case
668            (restart-case (%error condition nil frame-ptr)
669              (continue ()
670                        :report (lambda (s) (format s "Retry finding package with name ~S." package-name))
671                        (try-again package-name))
672              (use-value (value)
673                         :interactive (lambda () (block nil 
674                                                   (catch-cancel
675                                                    (return (list (get-string-from-user
676                                                                   "Find package named : "))))
677                                                   (continue condition)))
678                         :report (lambda (s) (format s "Find specified package instead of ~S ." package-name))
679                         (try-again value))
680              (make-nickname ()
681                             :report (lambda (s) (format s "Make ~S be a nickname for package ~S." package-name alias))
682                             (let ((p (try-again alias)))
683                               (push package-name (cdr (pkg.names p)))
684                               p)))
685            (require-lisp-package ()
686                                  :test (lambda (c)
687                                          (and (eq c condition)
688                                               (or (string-equal package-name "LISP") (string-equal package-name "USER"))))
689                                  :report (lambda (s) 
690                                            (format s "(require :lisp-package) and retry finding package ~s"
691                                                    package-name))
692                                  (require "LISP-PACKAGE")
693                                  (try-again package-name)))))))
694
695(def-kernel-restart $xunintc unintern-conflict-restarts (frame-ptr sym package conflicts)
696  (let ((condition (make-condition 'unintern-conflict-error :package package :sym sym :conflicts conflicts)))
697    (restart-case (%error condition nil frame-ptr)
698      (continue ()
699                :report (lambda (s) (format s "Try again to unintern ~s from ~s" sym package))
700                (unintern sym package))
701      (do-shadowing-import (ssym)
702                           :report (lambda (s) (format s "SHADOWING-IMPORT one of ~S in ~S." conflicts package))
703                           :interactive (lambda ()
704                                          (block nil
705                                            (catch-cancel
706                                             (return (select-item-from-list conflicts 
707                                                                            :window-title 
708                                                                            (format nil "Shadowing-import one of the following in ~s" package)
709                                                                            :table-print-function #'prin1)))
710                                            (continue condition)))
711                           (shadowing-import (list ssym) package)))))
712
713
714(def-kernel-restart $xusec blub (frame-ptr package-to-use using-package conflicts)
715  (resolve-use-package-conflict-error frame-ptr package-to-use using-package conflicts nil))
716
717(def-kernel-restart $xusecX blub (frame-ptr package-to-use using-package conflicts)
718  (resolve-use-package-conflict-error frame-ptr package-to-use using-package conflicts t))
719
720(defun resolve-use-package-conflict-error (frame-ptr package-to-use using-package conflicts external-p)
721  (let ((condition (make-condition 'use-package-conflict-error 
722                                   :package using-package
723                                   :package-to-use package-to-use
724                                   :conflicts conflicts
725                                   :external-p external-p)))
726    (flet ((external-test (&rest ignore) (declare (ignore ignore)) external-p)
727           (present-test (&rest ignore) (declare (ignore ignore)) (not external-p)))
728      (declare (dynamic-extent #'present-test #'external-test))
729      (restart-case (%error condition nil frame-ptr)
730        (continue ()
731                  :report (lambda (s) (format s "Try again to use ~s in ~s" package-to-use using-package)))
732        (resolve-by-shadowing-import (&rest shadowing-imports)
733                                     :test external-test
734                                     :interactive (lambda ()
735                                                    (mapcar #'(lambda (pair) 
736                                                                (block nil
737                                                                  (catch-cancel
738                                                                    (return (car (select-item-from-list pair
739                                                                                                        :window-title 
740                                                                                                        (format nil "Shadowing-import one of the following in ~s" using-package)
741                                                                                                        :table-print-function #'prin1))))
742                                                                  (continue condition)))
743                                                            conflicts))
744                                     :report (lambda (s) (format s "SHADOWING-IMPORT one of each pair of conflicting symbols."))
745                                     (shadowing-import shadowing-imports using-package))
746        (unintern-all ()
747                      :test present-test
748                      :report (lambda (s) (format s "UNINTERN all conflicting symbols from ~S" using-package))
749                      (dolist (c conflicts)
750                        (unintern (car c) using-package)))
751        (shadow-all ()
752                      :test present-test
753                      :report (lambda (s) (format s "SHADOW all conflicting symbols in ~S" using-package))
754                      (dolist (c conflicts)
755                        (shadow-1 using-package (car c))))
756        (resolve-by-unintern-or-shadow (&rest dispositions)
757                                       :test present-test
758                                       :interactive (lambda ()
759                                                      (mapcar #'(lambda (pair)
760                                                                  (let* ((present-sym (car pair)))
761                                                                    (block nil
762                                                                      (catch-cancel
763                                                                        (return (car (select-item-from-list (list 'shadow 'unintern) 
764                                                                                                            :window-title
765                                                                                                            (format nil "SHADOW ~S in, or UNINTERN ~S from ~S" 
766                                                                                                                    present-sym 
767                                                                                                                    present-sym
768                                                                                                                    using-package)
769                                                                                                            :table-print-function #'prin1)))
770                                                                        (continue condition)))))
771                                                              conflicts))
772                                       :report (lambda (s) (format s "SHADOW or UNINTERN the conflicting symbols in ~S." using-package))
773                                       (dolist (d dispositions)
774                                         (let* ((sym (car (pop conflicts))))
775                                           (if (eq d 'shadow)
776                                             (shadow-1 using-package sym)
777                                             (unintern sym using-package)))))))))
778
779
780(defun resolve-export-conflicts (conflicts package)
781  (let* ((first-inherited (caar conflicts))
782         (all-same (dolist (conflict (cdr conflicts) t)
783                     (unless (eq (car conflict) first-inherited) (return nil))))
784         (all-inherited (and all-same first-inherited))
785         (all-present (and all-same (not first-inherited)))
786         (condition (make-condition 'export-conflict-error
787                                    :conflicts conflicts
788                                    :package package)))
789    (flet ((check-again () 
790             (let* ((remaining-conflicts (check-export-conflicts (mapcar #'cadr conflicts) package)))
791               (if remaining-conflicts (resolve-export-conflicts remaining-conflicts package)))))
792      (restart-case (%error condition nil (%get-frame-ptr))
793        (resolve-all-by-shadowing-import-inherited 
794         ()
795         :test (lambda (&rest ignore) (declare (ignore ignore)) all-inherited)
796         :report (lambda (s) (format s "SHADOWING-IMPORT all conflicting inherited symbol(s) in using package(s)."))
797         (dolist (conflict conflicts (check-again))
798           (destructuring-bind (using-package inherited-sym) (cddr conflict)
799             (shadowing-import-1 using-package inherited-sym))))
800        (resolve-all-by-shadowing-import-exported 
801         ()
802         :test (lambda (&rest ignore) (declare (ignore ignore)) all-inherited)
803         :report (lambda (s) (format s "SHADOWING-IMPORT all conflicting symbol(s) to be exported in using package(s)."))
804         (dolist (conflict conflicts (check-again))
805           (destructuring-bind (exported-sym using-package ignore) (cdr conflict)
806             (declare (ignore ignore))
807             (shadowing-import-1 using-package exported-sym))))
808        (resolve-all-by-uninterning-present 
809         ()
810         :test (lambda (&rest ignore) (declare (ignore ignore)) all-present)
811         :report (lambda (s) (format s "UNINTERN all present conflicting symbol(s) in using package(s)."))
812         (dolist (conflict conflicts (check-again))
813           (destructuring-bind (using-package inherited-sym) (cddr conflict)
814             (unintern inherited-sym using-package))))
815        (resolve-all-by-shadowing-present 
816         ()
817         :test (lambda (&rest ignore) (declare (ignore ignore)) all-present)
818         :report (lambda (s) (format s "SHADOW all present conflicting symbol(s) in using package(s)."))
819         (dolist (conflict conflicts (check-again))
820           (destructuring-bind (using-package inherited-sym) (cddr conflict)
821             (shadow-1 using-package inherited-sym))))
822        (review-and-resolve 
823         (dispositions)
824         :report (lambda (s) (format s "Review each name conflict and resolve individually."))
825         :interactive (lambda ()
826                        (let* ((disp nil))
827                          (block b
828                            (catch-cancel
829                              (dolist (conflict conflicts (return-from b (list disp)))
830                                (destructuring-bind (inherited-p exported-sym using-package conflicting-sym) conflict
831                                  (let* ((syms (list exported-sym conflicting-sym)))
832                                    (if inherited-p
833                                      (push (list 'shadowing-import
834                                                  (select-item-from-list syms
835                                                                              :window-title 
836                                                                              (format nil "Shadowing-import one of the following in ~s" using-package)
837                                                                              :table-print-function #'prin1)
838                                                  using-package)
839                                            disp)
840                                      (let* ((selection (car (select-item-from-list syms
841                                                                                    :window-title 
842                                                                                    (format nil "Shadow ~S or unintern ~s in ~s"
843                                                                                            exported-sym 
844                                                                                            conflicting-sym using-package)
845                                                                                    :table-print-function #'prin1))))
846                                        (push (if (eq selection 'exported-sym)
847                                                (list 'shadow (list exported-sym) using-package)
848                                                (list 'unintern conflicting-sym using-package))
849                                              disp)))))))
850                            nil)))
851         (dolist (disp dispositions (check-again))
852           (apply (car disp) (cdr disp))))))))
853
854
855(def-kernel-restart $xwrongtype default-require-type-restarts (frame-ptr value typespec)
856  (setq typespec (%type-error-type typespec))
857  (let ((condition (make-condition 'type-error 
858                                   :datum value
859                                   :expected-type typespec)))
860    (restart-case (%error condition nil frame-ptr)
861      (use-value (newval)
862                 :report (lambda (s)
863                           (format s "Use a new value of type ~s instead of ~s." typespec value))
864                 :interactive (lambda ()
865                                (format *query-io* "~&New value of type ~S :" typespec)
866                                (list (read *query-io*)))
867                 (require-type newval typespec)))))
868
869(def-kernel-restart $xudfcall default-undefined-function-call-restarts (frame-ptr function-name args)
870  (unless *level-1-loaded*
871    (dbg function-name))   ; user should never see this
872  (let ((condition (make-condition 'undefined-function-call
873                                   :name function-name
874                                   :function-arguments args)))
875    (restart-case (%error condition nil frame-ptr)
876      (continue ()
877                :report (lambda (s) (format s "Retry applying ~S to ~S." function-name args))
878                (apply function-name args))
879      (use-value (function)
880                 :interactive (lambda ()
881                                (format *query-io* "Function to apply instead of ~s :" function-name)
882                                (let ((f (read *query-io*)))
883                                  (unless (symbolp f) (setq f (eval f))) ; almost-the-right-thing (tm)
884                                  (list (coerce f 'function))))
885                 :report (lambda (s) (format s "Apply specified function to ~S this time." args))
886                 (apply function args))
887      (store-value (function)
888                   :interactive (lambda ()
889                                (format *query-io* "Function to apply as new definition of ~s :" function-name)
890                                (let ((f (read *query-io*)))
891                                  (unless (symbolp f) (setq f (eval f))) ; almost-the-right-thing (tm)
892                                  (list (coerce f 'function))))
893                   :report (lambda (s) (format s "Specify a function to use as the definition of ~S." function-name))
894                   (apply (setf (symbol-function function-name) function) args)))))
895
896
897
898
899; This has to be defined fairly early (assuming, of course, that it "has" to be defined at all ...
900
901(defun ensure-value-of-type (value typespec placename &optional typename)
902  (tagbody
903    again
904    (unless (typep value typespec)
905      (let ((condition (make-condition 'type-error 
906                                       :datum value
907                                       :expected-type typespec)))
908        (if typename
909            (setf (slot-value condition 'format-control)
910                  (format nil "value ~~S is not ~A (~~S)." typename)))
911        (restart-case (%error condition nil (%get-frame-ptr))
912          (store-value (newval)
913                       :report (lambda (s)
914                                 (format s "Assign a new value of type ~a to ~s" typespec placename))
915                       :interactive (lambda ()
916                                      (format *query-io* "~&New value for ~S :" placename)
917                                      (list (eval (read))))
918                       (setq value newval)
919                       (go again))))))
920  value)
921
922;;;The Error Function
923
924(defparameter *kernel-simple-error-classes*
925  (list (cons $xcalltoofew 'simple-destructuring-error)
926        (cons $xcalltoomany 'simple-destructuring-error)
927        (cons $xstkover 'stack-overflow-condition)
928        (cons $xmemfull 'simple-storage-condition)
929        (cons $xwrongtype 'type-error) ; this one needs 2 args
930        (cons $xdivzro 'division-by-zero)
931        (cons $xflovfl 'floating-point-overflow)
932        (cons $xfunbnd 'undefined-function)
933        (cons $xbadkeys 'simple-program-error)
934        (cons $xnotfun 'call-special-operator-or-macro)
935        (cons $xaccessnth 'sequence-index-type-error)
936        (cons $ximproperlist 'improper-list)
937        (cons $xnospread 'cant-construct-arglist)
938        ))
939
940
941(defparameter *simple-error-types*
942  (vector nil 'simple-program-error 'simple-file-error))
943
944(defconstant $pgm-err #x10000)
945
946
947
948
949(defparameter %type-error-typespecs%
950  #(array
951    bignum
952    fixnum
953    character
954    integer
955    list
956    number
957    sequence
958    simple-string
959    simple-vector
960    string
961    symbol
962    macptr
963    real
964    cons
965    unsigned-byte
966    (integer 2 36)
967    float
968    rational
969    ratio
970    short-float
971    double-float
972    complex
973    vector
974    simple-base-string
975    function
976    (unsigned-byte 16)
977    (unsigned-byte 8)
978    (unsigned-byte 32)
979    (signed-byte 32)
980    (signed-byte 16)
981    (signed-byte 8)
982    base-char
983    bit
984    (unsigned-byte 24)                  ; (integer 0 (array-total-size-limit))
985    (unsigned-byte 64)
986    (signed-byte 64)
987    (unsigned-byte 56)
988))
989
990
991(defun %type-error-type (type)
992  (if (fixnump type) 
993    (svref %type-error-typespecs% type)
994    type))
995
996(defun %typespec-id (typespec)
997  (flet ((type-equivalent (t1 t2) (ignore-errors (and (subtypep t1 t2) (subtypep t2 t1)))))
998    (position typespec %type-error-typespecs% :test #'type-equivalent)))
999
1000
1001(defmethod condition-p ((x t)) nil)
1002(defmethod condition-p ((x condition)) t)
1003
1004
1005
1006(let* ((globals ()))
1007
1008  (defun %check-error-globals ()
1009    (let ((vars ())
1010          (valfs ())
1011          (oldvals ()))
1012      (dolist (g globals (values vars valfs oldvals))
1013        (destructuring-bind (sym predicate newvalf) g
1014          (let* ((boundp (boundp sym))
1015                 (oldval (if boundp (symbol-value sym) (%unbound-marker-8))))
1016          (unless (and boundp (funcall predicate oldval))
1017            (push sym vars)
1018            (push oldval oldvals)
1019            (push newvalf valfs)))))))
1020
1021  (defun check-error-global (sym checkfn newvalfn)
1022    (setq sym (require-type sym 'symbol)
1023          checkfn (require-type checkfn 'function)
1024          newvalfn (require-type newvalfn 'function))
1025    (let ((found (assq sym globals)))
1026      (if found
1027        (setf (cadr found) checkfn (caddr found) newvalfn)
1028        (push (list sym checkfn newvalfn) globals))
1029      sym))
1030)
1031
1032(check-error-global '*package* #'packagep #'(lambda () (find-package "CL-USER")))
1033
1034
1035 
1036
Note: See TracBrowser for help on using the repository browser.