/[gcl]/gcl/clcs/kcl-cond.lisp
ViewVC logotype

Diff of /gcl/clcs/kcl-cond.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1.1.1 by wfs, Mon Dec 6 22:43:55 1999 UTC revision 1.2 by camm, Wed Oct 9 03:46:33 2002 UTC
# Line 4  Line 4 
4    
5  (defvar *internal-error-table* (make-hash-table :test 'equal))  (defvar *internal-error-table* (make-hash-table :test 'equal))
6    
7  (defmacro find-internal-error-data (error-name error-format-string)  ;(defmacro find-internal-error-data (error-name error-format-string)
8    `(gethash (list ,error-name ,error-format-string) *internal-error-table*))  ;  `(gethash (list ,error-name ,error-format-string) *internal-error-table*))
9    (defmacro find-internal-error-data (error-name)
10      `(gethash (list ,error-name) *internal-error-table*))
11    
12    ;(defun clcs-universal-error-handler (error-name correctable function-name
13    ;                                    continue-format-string error-format-string
14    ;                                    &rest args)
15    ;  (if correctable
16    ;      (with-simple-restart
17    ;         (continue "~a" (apply #'format nil continue-format-string args))
18    ;       (error 'internal-simple-error
19    ;              :function-name function-name
20    ;              :format-string error-format-string
21    ;              :format-arguments args))
22    ;      (let ((e-d (find-internal-error-data error-name error-format-string)))
23    ;       (if e-d
24    ;           (let ((condition-name (car e-d)))
25    ;             (apply #'error condition-name
26    ;                    :function-name function-name
27    ;                    (let ((k-a (mapcan #'list (cdr e-d) args)))
28    ;                      (if (simple-condition-class-p condition-name)
29    ;                          (list* :format-string error-format-string
30    ;                                 :format-arguments args
31    ;                                 k-a)
32    ;                          k-a))))
33    ;           (error 'internal-simple-error :function-name function-name
34    ;                  :format-string error-format-string :format-arguments args)))))
35    
36  (defun clcs-universal-error-handler (error-name correctable function-name  (defun clcs-universal-error-handler (error-name correctable function-name
37                                       continue-format-string error-format-string                                       continue-format-string error-format-string
38                                       &rest args)                                       &rest args)
39    (if correctable    (let ((e-d (find-internal-error-data error-name)))
40        (with-simple-restart      (if e-d
41            (continue "~a" (apply #'format nil continue-format-string args))          (let ((condition-name (car e-d)))
42          (error 'internal-simple-error            (if correctable
43                 :function-name function-name                (with-simple-restart
44                 :format-string error-format-string                 (continue "~a" (apply #'format nil continue-format-string args))
45                 :format-arguments args))                 (apply #'error condition-name
46        (let ((e-d (find-internal-error-data error-name error-format-string)))                        :function-name function-name
47          (if e-d                        (let ((k-a (mapcan #'list (cdr e-d) args)))
48              (let ((condition-name (car e-d)))                          (if (simple-condition-class-p condition-name)
49                (apply #'error condition-name                              (list* :format-string error-format-string
50                       :function-name function-name                                     :format-arguments args
51                       (let ((k-a (mapcan #'list (cdr e-d) args)))                                     k-a)
52                         (if (simple-condition-class-p condition-name)                            k-a))))
53                             (list* :format-string error-format-string              (apply #'error condition-name
54                                    :format-arguments args                     :function-name function-name
55                                    k-a)                     (let ((k-a (mapcan #'list (cdr e-d) args)))
56                             k-a))))                       (if (simple-condition-class-p condition-name)
57              (error 'internal-simple-error :function-name function-name                           (list* :format-string error-format-string
58                     :format-string error-format-string :format-arguments args)))))                                  :format-arguments args
59                                    k-a)
60                           k-a)))))
61          (error 'internal-simple-error :function-name function-name
62                 :format-string error-format-string :format-arguments args))))
63    
64  (defun set-internal-error (error-keyword error-format condition-name  (defun set-internal-error (error-keyword error-format condition-name
65                                           &rest keyword-list)                                           &rest keyword-list)
66    (setf (find-internal-error-data error-keyword error-format)  ;  (setf (find-internal-error-data error-keyword error-format)
67      (setf (find-internal-error-data error-keyword)
68          (cons condition-name keyword-list)))          (cons condition-name keyword-list)))
69    
70  (defun initialize-internal-error-table ()  (defun initialize-internal-error-table ()
# Line 45  Line 76 
76  (defparameter *internal-error-list*  (defparameter *internal-error-list*
77    '(("FEwrong_type_argument" :wrong-type-argument "~S is not of type ~S."    '(("FEwrong_type_argument" :wrong-type-argument "~S is not of type ~S."
78       internal-type-error :datum :expected-type)       internal-type-error :datum :expected-type)
79        ("FEpackage_error" :package-error "A package error occurred on ~S:~S."
80         internal-package-error) ; |<function>| |top - base|
81      ("FEtoo_few_arguments" :too-few-arguments "~S [or a callee] requires more than ~R argument~:p."      ("FEtoo_few_arguments" :too-few-arguments "~S [or a callee] requires more than ~R argument~:p."
82       internal-simple-control-error) ; |<function>| |top - base|       internal-simple-control-error) ; |<function>| |top - base|
83      ("FEtoo_few_argumentsF" :too-few-arguments "Too few arguments."      ("FEtoo_few_argumentsF" :too-few-arguments "Too few arguments."

Legend:
Removed from v.1.1.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26