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

Last change on this file since 14376 was 13878, checked in by gb, 9 years ago

%ACTIVE-RESTART: if we match a RESTART (not the name of one), don't
call the restart's test function.

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