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

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

Restore %CHECK-TYPE.

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