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

Last change on this file since 12940 was 12940, checked in by gz, 10 years ago

From working-0711 branch: more extensive compile-time checking involving methods/gfs: warn about incongruent lambda lists, duplicate gf defs, required keyword args (from defgeneric), and invalid keyword args in gf calls. Also fix to keep method source files in env function info so dup method warnings can cite the right file.

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