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

Last change on this file since 11673 was 11673, checked in by gb, 11 years ago

Finally apply the contributed patch to ticket:321 in the trunk.

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