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

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

INVALID-MEMORY-OPERATION, for generic memory faults.

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