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

Last change on this file since 15236 was 15236, checked in by gb, 8 years ago

Change the initial-values *TERMINAL-CHARACTER-ENCODING-NAME* and
*DEFAULT-FILE-CHARACTER-ENCODING* to :UTF-8, mostly for the benefit of
the Init-File-Editing-Impaired. (I've resolved not to make fun of
the IFEI.) Note that this may require changes to startup scripts etc.

Define new conditions CCL:DECODING-PROBLEM and CCL:ENCODING-PROBLEM.
Signal these conditions (via SIGNAL) when decoding characters
from/enoding them to a stream, pointer or octet vector and a substitution
or replacement character would be used.

New macros (CCL:WITH-DECODING-PROBLEMS-AS-ERRORS &body body) and
(CCL:WITH-ENCODING-PROBLEMS-AS-ERRORS &body body) signal the corresponding
conditions as ERRORs if they are signaled during execution of the body.

(Arguably) fixes ticket:749.

FILE-STRING-LENGTH checks to see if the encoding wants to use a
byte-order-mark before subtracting the length of an encoded BOM
from the encoded string length if the file is at its beginning.

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