source: release/1.3/source/level-1/l1-error-system.lisp @ 11747

Last change on this file since 11747 was 11747, checked in by rme, 11 years ago

Merge trunk changes through r11740.

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