iso-prolog testsuite passes as good as possible

parent 2fbbbda1
......@@ -45,6 +45,8 @@
seed)
((l 0)
(f l seed))
((l n)
(lp l seed))
((l n . r)
(lp l (fold-dynlist-rl-r r seed))))))
......@@ -63,6 +65,8 @@
seed)
((l 0)
(f l seed))
((l n)
(lp l seed))
((l n . r)
(fold-dynlist-lr-r r (lp l seed)))
(l (f l seed)))))
......
......@@ -6,6 +6,8 @@
#:use-module (logic guile-log prompts)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log prolog names)
#:use-module (system repl error-handling)
#:replace (error)
#:export (type_error instantiation_error domain_error existence_error
permission_error list/plist? existence_error
......@@ -19,6 +21,11 @@
(vector `(,f ,(fkn-it x) ...)))
((_ x) x)))
(define *debug* #f)
(define (call-with-eh th . l)
(if *debug*
(call-with-error-handling th)
(th)))
(define error (lambda x (error "symbol is not defined")))
......@@ -37,9 +44,11 @@
(G
(lambda ()
(catch #t
(lambda ()
(<abort> s p cc
'prolog non-reentrant (fkn-it code)))
(lambda ()
(call-with-eh
(lambda ()
(<abort> s p cc
'prolog non-reentrant (fkn-it code)))))
H)))))))
(define evaluation_error
......@@ -50,10 +59,12 @@
(G
(lambda ()
(catch #t
(lambda () (<abort>
s p cc
'prolog non-reentrant
(fkn-it (error evaluation_error 'iso-prolog))))
(lambda ()
(call-with-eh
(lambda () (<abort>
s p cc
'prolog non-reentrant
(fkn-it (error evaluation_error 'iso-prolog))))))
H))))))
((s p cc x)
(abort-to-prompt tag
......@@ -61,10 +72,12 @@
(G
(lambda ()
(catch #t
(lambda () (<abort> s p cc
'prolog non-reentrant
(fkn-it (error (evaluation_error x)
'iso-prolog))))
(lambda ()
(call-with-eh
(lambda () (<abort> s p cc
'prolog non-reentrant
(fkn-it (error (evaluation_error x)
'iso-prolog))))))
H))))))))
(define-error (instantiation_error)
......@@ -133,10 +146,12 @@
(abort-to-prompt tag
(lambda ()
(catch #t
(lambda () f)
(lambda ()
(call-with-eh f))
h))))
(let ((s (fluid-ref *current-stack*)))
(match x
;; To avoid an inifinite recursion
(('misc-error _ _ (_ 123) _)
......@@ -172,7 +187,11 @@
(set! G g)
(set! H h)
(lambda (thk) (g (lambda () (catch #t thk h)))))))
(lambda (thk) (g (lambda ()
(catch #t
(lambda ()
(call-with-eh thk))
h)))))))
(define *call-expression* (gp-make-var #f))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment