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

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

Revise the definition of the write-to-watched-object condition.
Use an offset slot instead of an (absolute) address. Add an instruction
slot, which will contain the disassembled faulting instruction (or nil,
if something went wrong with the disassembly).

Provide a fancier report function.

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