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

Last change on this file since 12821 was 12821, checked in by rme, 10 years ago

When reporting a write-to-watched-object condition, try to figure out
and report the uvector index from the faulting address.

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