build systems and better usr_zip
[gule-log:guile-log.git] / logic / guile-log / prolog / error.scm
1 (define-module (logic guile-log prolog error)
2   #:use-module ((logic guile-log) 
3                 #:select (</.> <abort> <define> <match> <cut> <let>
4                                <lookup> <var?> <cc> <fail>))
5   #:use-module (ice-9 match)
6   #:use-module (logic guile-log prompts)
7   #:use-module (logic guile-log umatch)
8   #:use-module (system repl error-handling)
9
10   #:replace (error)
11   #:export (type_error instantiation_error domain_error existence_error
12                        permission_error list/plist? existence_error
13                        *call-expression* representation_error syntax_error
14                        scheme-wrapper evaluation_error))
15
16 (define-syntax fkn-it
17   (syntax-rules (quote)
18     ((_ 'x) 'x)
19     ((_ (f x ...))
20      (vector `(,f ,(fkn-it x) ...)))
21     ((_ x) x)))
22
23 (define *debug* #t)
24 (define (call-with-eh th . l)
25   (if *debug*
26       (call-with-error-handling th)
27       (th)))
28
29 (define error (lambda x (error "symbol is not defined")))
30
31 (define non-reentrant 
32   (letrec ((f (</.> (<abort> 'prolog f 'reentrant_error))))
33     f))
34
35 (define tag (make-prompt-tag))
36 (define G #f)
37 (define H #f)
38
39 (define-syntax-rule (define-error (nm a ...) code)
40   (define (nm s p cc a ...)
41     (abort-to-prompt tag
42       (lambda ()
43         (G
44          (lambda ()
45            (catch #t
46              (lambda ()
47                (call-with-eh
48                 (lambda () 
49                   (<abort> s p cc 
50                            'prolog non-reentrant (fkn-it code)))))
51              H)))))))
52
53 (define evaluation_error
54   (case-lambda
55     ((s p cc)
56      (abort-to-prompt tag
57        (lambda ()
58          (G
59           (lambda ()
60             (catch #t
61               (lambda ()
62                 (call-with-eh
63                  (lambda () (<abort> 
64                              s p cc 
65                              'prolog non-reentrant 
66                              (fkn-it (error evaluation_error 'iso-prolog))))))
67               H))))))
68     ((s p cc x)
69      (abort-to-prompt tag
70        (lambda ()
71          (G
72           (lambda ()
73             (catch #t
74               (lambda ()
75                 (call-with-eh
76                  (lambda () (<abort> s p cc 
77                                      'prolog non-reentrant 
78                                      (fkn-it (error (evaluation_error x) 
79                                                     'iso-prolog))))))
80               H))))))))
81
82 (define-error (instantiation_error)    
83   (error instantiation_error
84          'iso-prolog))
85
86 (define-error (type_error a b)         
87   (error (type_error a b)
88          'iso-prolog))
89
90 (define-error (domain_error a b)       
91   (error (domain_error a b)
92          'iso-prolog))
93
94 (define-error (permission_error a b c) 
95   (error (permission_error a b c)
96          'iso-prolog))
97
98 (define-error (existence_error a b) 
99   (error (existence_error a b)
100          'iso-prolog))
101
102 (define-error (representation_error a)
103   (error (representation_error a)
104          'iso-prolog))
105
106 (define-error (syntax_error a)
107   (error (syntax_error a)
108          'iso-prolog))
109
110 #;
111 (define-error (evaluation_error a )
112   (error (evaluation_error a)
113          'iso-prolog))
114     
115 (<define> (list/plist? l)
116   (<match> (#:mode - #:name list/plist?) (l)
117     ((x . l) 
118      (<cut> (list/plist? l)))
119     (x
120      (<let> ((x (<lookup> x)))
121        (if (or (<var?> x) (null? x))
122            <cc>
123            (<cut> <fail>))))))
124                              
125 ;;This does not work with assoc lists e.g. can't lookup  
126 (define cc (lambda x #t))
127 (define p  (lambda x #f))
128 (define ariths '("=" "floor" "+" "-" "*" "/" "truncate/" "remainder"
129                  "<" "<=" ">=" ">" "abs" "floor" "round" "ceiling" "truncate"
130                  "inexact->exact"))
131 (define (id x) (x) (pk 'end))
132
133 (define arith-ints '("ash" "logior" "logand" "lognot"  "modulo"))
134
135 (define number #f)
136 (define integer #f)
137 (define source_sink #f)
138
139 (define scheme-wrapper
140   (let ()
141     (letrec ((g  (lambda (fkn)                  
142                    (call-with-prompt tag
143                       fkn
144                       (lambda (k f)
145                         (g f)))))
146              
147              (h  (lambda x
148                    (define-syntax-rule (wrap f)
149                      (abort-to-prompt tag
150                                       (lambda ()
151                                         (catch #t
152                                           (lambda () 
153                                             (call-with-eh f))
154                                           h))))
155
156                    (let ((s (fluid-ref *current-stack*)))                     
157                      (match x
158                        ;; To avoid an inifinite recursion
159                        (('misc-error _ _ (_ 123) _)
160                         x)
161
162                        #;(('wrong-type-arg #f . _))
163                        (('system-error "open-file" pat
164                                        (_ file) (2))
165                         (wrap (existence_error s p cc source_sink file)))
166
167                        (('numerical-overflow . _)
168                         (wrap (evaluation_error s p cc 'num)))
169
170                        (('wrong-type-arg fkn str ("exact integer" val) . _)
171                         (wrap (type_error s p cc integer val)))
172
173                        (('wrong-type-arg fkn str (arg val) . _)
174                         (let ((val (gp-lookup val s)))
175                           (cond                         
176                            ((gp-var? val s)
177                             (wrap (instantiation_error s p cc)))
178
179                            ((member fkn ariths)
180                             (wrap (type_error s p cc number val)))
181
182                            ((member fkn arith-ints)
183                             (wrap (type_error s p cc integer val)))
184
185                            (else
186                             (wrap (syntax_error s p cc (format #f "~s" x)))))))
187
188                        (_ (wrap (syntax_error s p cc (format #f "~s" x)))))))))
189
190       (set! G g)
191       (set! H h)
192       (lambda (thk) (g (lambda () 
193                          (catch #t 
194                            (lambda () 
195                              (call-with-eh thk))
196                            h)))))))
197
198 (define *call-expression* (gp-make-var #f))