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

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

Define INVALID-TYPE-SPECIFIER as a subtype of PROGRAM-ERROR.
(Note that there are lots of ways to lose when parsing an alleged
type-specifier, e.g., (INTEGER 1 2 3) will likely lead to a destructuring
error.)

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