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

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

FORMAT cuteness with plurals when reporting bad number of args errors.

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