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

Last change on this file since 13066 was 13066, checked in by rme, 10 years ago

Change "OpenMCL" to "Clozure CL" in comments and docstrings.

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