source: branches/working-0711/ccl/level-1/l1-error-system.lisp @ 11701

Last change on this file since 11701 was 11701, checked in by gz, 11 years ago

Merge back some of the source location changes made in the trunk (in
particular this fixes the bug where source locations weren't actually
getting attached to inner functions, plus it makes the current source
note available in *nx-current-note*). Use *nx-curent-note* to record
the source note in compiler warnings.

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