source: release/1.9/source/level-1/l1-error-system.lisp @ 15706

Last change on this file since 15706 was 15706, checked in by gb, 6 years ago

Propagate recent trunk changes.

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