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

Last change on this file was 16784, checked in by gb, 3 years ago

THREAD-CONDITIONs (like PROCESS-RESET) are not SERIOUS-CONDITIONs

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