source: branches/watchpoints/level-1/l1-error-system.lisp @ 12903

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

Add instruction slot to write-to-watched-object condition. Print it out
when reporting.

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