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

Last change on this file since 12481 was 12481, checked in by gb, 10 years ago

No such CL type as (SIMPLE-ARRAY CHAR (* * *)).

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