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

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

Temporary kludge (which will probably stay here for years) to avoid
warnings on ppc while I try to think of something better.

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