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

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

Add address slot to write-to-watched-object condition.

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