source: release/1.2/source/level-1/l1-error-system.lisp @ 11672

Last change on this file since 11672 was 11672, checked in by gb, 12 years ago

Finally apply the contributed patch to ticket:321.

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