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

Last change on this file since 15232 was 15018, checked in by gz, 8 years ago

Make invoke-restart-no-return accept and pass on values

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