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

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

New condition write-to-watched-object.

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