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

Last change on this file since 15311 was 15311, checked in by gb, 7 years ago

Primary method on NO-APPLICABLE-METHOD signals an error of type

CCL:NO-APPLICABLE-METHOD-EXISTS.

Fixes ticket:938.

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