← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to clcs/unused/test.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
clcs/unused/test.lisp
 
1
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-
 
2
 
 
3
(in-package "CONDITIONS")
 
4
 
 
5
(defvar *internal-error-table* (make-hash-table :test 'equal))
 
6
 
 
7
(defmacro find-internal-error-data (error-name error-format-string)
 
8
  `(gethash (list ,error-name ,error-format-string) *internal-error-table*))
 
9
 
 
10
(defun clcs-universal-error-handler (error-name correctable function-name
 
11
                                     continue-format-string error-format-string
 
12
                                     &rest args)
 
13
  (if correctable
 
14
      (with-simple-restart 
 
15
          (continue "~a" (apply #'format nil continue-format-string args))
 
16
        (error 'internal-simple-error 
 
17
               :function-name function-name
 
18
               :format-string error-format-string 
 
19
               :format-arguments args))
 
20
      (let ((e-d (find-internal-error-data error-name error-format-string)))
 
21
        (print e-d)
 
22
        (if e-d
 
23
            (let ((condition-name (car e-d)))
 
24
              (apply #'error condition-name
 
25
                     :function-name function-name
 
26
                     (let ((k-a (mapcan #'list (cdr e-d) args)))
 
27
                       (if (simple-condition-class-p condition-name)
 
28
                           (list* :format-string error-format-string
 
29
                                  :format-arguments args
 
30
                                  k-a)
 
31
                           k-a))))
 
32
            (error 'internal-simple-error :function-name function-name
 
33
                   :format-string error-format-string :format-arguments args)))))
 
34
 
 
35
(defun set-internal-error (error-keyword error-format condition-name
 
36
                                         &rest keyword-list)
 
37
  (setf (find-internal-error-data error-keyword error-format)
 
38
        (cons condition-name keyword-list)))
 
39
 
 
40
(defun initialize-internal-error-table ()
 
41
  (declare (special *internal-error-list*))
 
42
  (clrhash *internal-error-table*)
 
43
  (dolist (error-data *internal-error-list*)
 
44
    (apply #'set-internal-error (cdr error-data))))
 
45
 
 
46
(defparameter *internal-error-list*
 
47
  '(("FEwrong_type_argument" :wrong-type-argument "~S is not of type ~S."
 
48
     internal-type-error :datum :expected-type)
 
49
    ("FEtoo_few_arguments" :too-few-arguments "~S [or a callee] requires more than ~R argument~:p." 
 
50
     internal-simple-control-error) ; |<function>| |top - base|
 
51
    ("FEtoo_few_argumentsF" :too-few-arguments "Too few arguments."
 
52
     internal-simple-control-error) ; |<function>| |args|
 
53
    ("FEtoo_many_arguments" :too-many-arguments "~S [or a callee] requires less than ~R argument~:p."
 
54
     internal-simple-control-error) ; |<function>| |top - base|
 
55
    ("FEtoo_many_argumentsF" :too-many-arguments "Too many arguments."
 
56
     internal-simple-control-error) ; |<function>| |args|
 
57
    ("FEinvalid_macro_call" :invalid-form "Invalid macro call to ~S."
 
58
     internal-simple-program-error) ; |<function>|
 
59
    ("FEunexpected_keyword" :unexpected-keyword "~S does not allow the keyword ~S."
 
60
     internal-simple-control-error) ; |<function>| |key|
 
61
    ("FEunbound_variable" :unbound-variable "The variable ~S is unbound."
 
62
     internal-unbound-variable :name) ; |sym|
 
63
    ("FEundefined_function" :undefined-function "The function ~S is undefined."
 
64
     internal-undefined-function :name)
 
65
    ("FEinvalid_function" :invalid-function "~S is invalid as a function."
 
66
     internal-simple-program-error) ; |obj|
 
67
    ("check_arg_failed" :too-few-arguments "~S [or a callee] requires ~R argument~:p,~%\
 
68
but only ~R ~:*~[were~;was~:;were~] supplied."
 
69
     internal-simple-control-error) ; |<function>| |n| |top - base|
 
70
    ("check_arg_failed" :too-many-arguments "~S [or a callee] requires only ~R argument~:p,~%\
 
71
but ~R ~:*~[were~;was~:;were~] supplied."
 
72
     internal-simple-control-error) ; |<function>| |n| |top - base|
 
73
    ("ck_larg_at_least" :error "APPLY sended too few arguments to LAMBDA."
 
74
     internal-simple-control-error) 
 
75
    ("ck_larg_exactly" :error "APPLY sended too few arguments to LAMBDA."
 
76
     internal-simple-control-error) 
 
77
    ("keyword_value_mismatch" :error "Keywords and values do not match."
 
78
     internal-simple-error) ;??
 
79
    ("not_a_keyword" :error "~S is not a keyword."
 
80
     internal-simple-error) ;??
 
81
    ("illegal_declare" :invalid-form "~S is an illegal declaration form."
 
82
     internal-simple-program-error)
 
83
    ("not_a_symbol" :invalid-variable "~S is not a symbol."
 
84
     internal-simple-error) ;??
 
85
    ("not_a_variable" :invalid-variable "~S is not a variable."
 
86
     internal-simple-program-error)
 
87
    ("illegal_index" :error "~S is an illegal index to ~S."
 
88
     internal-simple-error)
 
89
    ("vfun_wrong_number_of_args" :error "Expected ~S args but received ~S args"
 
90
     internal-simple-control-error)
 
91
    
 
92
    ("end_of_stream" :error "Unexpected end of ~S."
 
93
     internal-end-of-file :stream)
 
94
    ("open_stream" :error "~S is an illegal IF-DOES-NOT-EXIST option."
 
95
     internal-simple-control-error)
 
96
    ("open_stream" :error "The file ~A already exists."
 
97
     internal-simple-file-error :pathname)
 
98
    ("open_stream" :error "Cannot append to the file ~A."
 
99
     internal-simple-file-error :pathname)
 
100
    ("open_stream" :error "~S is an illegal IF-EXISTS option."
 
101
     internal-simple-control-error)
 
102
    ("close_stream" :error "Cannot close the standard output."
 
103
     internal-simple-stream-error) ; no stream here!!
 
104
    ("close_stream" :error "Cannot close the standard input."
 
105
     internal-simple-stream-error) ; no stream here!!
 
106
    ("too_long_file_name" :error "~S is a too long file name."
 
107
     internal-simple-file-error :pathname)
 
108
    ("cannot_open" :error "Cannot open the file ~A."
 
109
     internal-simple-file-error :pathname)
 
110
    ("cannot_create" :error "Cannot create the file ~A."
 
111
     internal-simple-file-error :pathname)
 
112
    ("cannot_read" :error "Cannot read the stream ~S."
 
113
     internal-simple-stream-error :stream)
 
114
    ("cannot_write" :error "Cannot write to the stream ~S."
 
115
     internal-simple-stream-error :stream)
 
116
    ))
 
117
 
 
118
(initialize-internal-error-table)
 
119
 
 
120
(defun condition-backtrace (condition)
 
121
  (let* ((*debug-io* *error-output*)
 
122
         (si::*ihs-base* (1+ si::*ihs-top*))
 
123
         (si::*ihs-top* (1- (si::ihs-top)))
 
124
         (si::*current-ihs* si::*ihs-top*)
 
125
         (si::*frs-base* (or (si::sch-frs-base si::*frs-top* si::*ihs-base*)
 
126
                             (1+ (si::frs-top))))
 
127
         (si::*frs-top* (si::frs-top))
 
128
         (si::*break-env* nil))
 
129
    (format *error-output* "~%~A~%" condition)
 
130
    (si::simple-backtrace)))
 
131
 
 
132
(defvar *error-set-break-p* nil)
 
133
 
 
134
(defun clcs-error-set (form)
 
135
  (let ((cond nil))
 
136
    (restart-case (handler-bind ((error #'(lambda (condition)
 
137
                                            (unless (or si::*break-enable*
 
138
                                                        *error-set-break-p*)
 
139
                                              (condition-backtrace condition)
 
140
                                              (return-from clcs-error-set condition))
 
141
                                            (setq cond condition)
 
142
                                            nil)))
 
143
                     (values-list (cons nil (multiple-value-list (eval form)))))
 
144
       (si::error-set ()
 
145
          :report (lambda (stream)
 
146
                    (format stream "~S" `(si::error-set ',form)))
 
147
          cond))))
 
148
 
 
149
(eval-when (compile load eval)
 
150
 
 
151
(defun reset-function (symbol) ; invoke compiler::compiler-clear-compiler-properties
 
152
  (setf (symbol-function symbol) (symbol-function symbol)))
 
153
 
 
154
(reset-function 'si::error-set)
 
155
(reset-function 'load)
 
156
(reset-function 'open)
 
157
)
 
158
 
 
159
(setq compiler::*compiler-break-enable* t)
 
160
 
 
161
(defun compiler::cmp-toplevel-eval (form)
 
162
   (let* (;;(si::*ihs-base* si::*ihs-top*) ; show the whole stack
 
163
          (si::*ihs-top* (1- (si::ihs-top)))
 
164
          (*break-enable* compiler::*compiler-break-enable*)
 
165
          (si::*break-hidden-packages*
 
166
           (cons (find-package 'compiler)
 
167
                 si::*break-hidden-packages*)))
 
168
         (si:error-set form)))