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

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

Add a reader for the instruction slot in a write-to-watched-object
condition.

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