source: branches/working-0711/ccl/level-1/l1-error-system.lisp @ 12944

Last change on this file since 12944 was 12585, checked in by gz, 10 years ago

more extensive compile-time checking involving methods/gfs: warn about incongruent lambda lists, duplicate gf defs, required keyword args (from defgeneric), and invalid keyword args in gf calls. Also fix to keep method source files in env function info so dup method warnings can cite the right file. Also merged r12581 and r12583 from trunk

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