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

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

Merge r12186: check io vars for bogosity on entry to debugger and C

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