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

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

Add target and location slots to write-to-watched-object condition and fill
them in at initialization time; do a little clean-up.

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