inriasuite almost passes

parent 58281305
......@@ -278,21 +278,16 @@ HELP FOR PROLOG COMMANDS
(lambda ()
((@@ (system repl command) meta-command) repl)))
(set! str "do[#f]"))
`((@ (guile) let)
((fr ((@ (logic guile-log umatch) gp-newframe)
((@ (guile) fluid-ref)
(@ (logic guile-log umatch) *current-stack*)))))
((@@ (logic guile-log iso-prolog) prolog-run) 1 ()
((@@ (logic guile-log guile-prolog interpreter)
`((@ (guile) begin)
((@@ (logic guile-log prolog run) prolog-run-0)
(@@ (logic guile-log guile-prolog interpreter)
conversation1)
,str
,((@ (guile) cond)
,(cond
(all? '(@ (logic guile-log iso-prolog) true))
(nn? nn?)
(else
'(@ (logic guile-log iso-prolog) false))))
((@ (logic guile-log) <code>)
((@ (logic guile-log umatch) gp-unwind) fr)))
(if #f #f))))
(else
l))))
......@@ -377,8 +372,7 @@ conversation2(X,All) :-
consult(X,V,N,All) :-
do[(fluid-set! -nsol- (<lookup> All))],
catch(((solve(X),output_and_more(V,N)) ; (nl,write(no),nl,fail)),
finish,
catch(((solve(X),output_and_more(V,N)) ; (nl,write(no),nl,fail)),finish,
fail).
vtosym(X,Y) :- make_vhash(H),make_fluid(0,I),rec_analyze(X),vtosym4(X,Y,H,I).
......
......@@ -75,6 +75,7 @@
;; Error functions
error type_error instantiation_error domain_error
permission_error existence_error representation_error
system_error
character_code syntax_error
source_sink evaluation_error
......
......@@ -29,8 +29,6 @@
:- scm[(define foo #f)].
:- scm[(define bar #f)].
:- scm[(define <-- #f)].
%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
......@@ -78,7 +76,7 @@ run_all_tests :-
test_all([]).
test_all([F|Fs]) :-
run_tests(F),
run_tests(F),!,
test_all(Fs).
%%%%%%%%%%%%%%%%%%%%%%%%%
......@@ -598,7 +596,7 @@ loop_through(F, S) :-
-> (write(end_of_file),nl,true)
;
reset_flags,
test(F,X),
test(F,X),!,
loop_through(F,S)
).
......
......@@ -3,7 +3,7 @@
#:use-module ((guile) #:select (@ @@ define))
#:pure
#:re-export (prolog-run)
#:export (run_tests run_all_tests unexpected_ball <--
#:export (run_tests run_all_tests unexpected_ball <-- exists
failure success impl_def undefined))
(compile-prolog-file "inriasuite.pl")
......
......@@ -39,14 +39,6 @@
<raw-attvar> <attvar-raw?> <set>
))
(define iter 0)
(define (gp-gc)
(if (= iter 10)
(begin
(set! iter 0)
((@ (logic guile-log umatch) gp-gc)))
(set! iter (+ iter 1))))
(define (<wrap> f . l)
(apply f (fluid-ref *current-stack*) (lambda x #f) (lambda (s . l) s) l))
(define (<wrap-s> f s . l)
......@@ -622,12 +614,12 @@
(define-guile-log <match>
(syntax-rules ()
((_ wc as ...)
(match0 (#f + '<match>) wc as ...))))
(match0 (+ '<match> #f) wc as ...))))
(define-syntax match0
(syntax-rules ()
((_ (m n dd) wc (#:dual . u) . l)
(match0 (m0 n #t) wc u . l))
(match0 (m n #t) wc u . l))
((_ (m n dd) wc (#:mode m0 . u) . l)
(match0 (m0 n dd) wc u . l))
((_ (m n dd) wc (#:name n0 . u) . l)
......
......@@ -2,6 +2,8 @@
#:use-module (logic guile-log parsing operator-parser)
#:use-module (logic guile-log guile-log-pre)
#:use-module (ice-9 eval-string)
#:use-module ((system base compile) #:select ((compile . scm-compile)))
#:use-module (ice-9 time)
#:use-module (logic guile-log guile-prolog closure)
#:use-module (logic guile-log prolog order)
#:use-module ((srfi srfi-1) #:select (lset-union
......@@ -413,7 +415,7 @@
(let* ((syms (get-syms))
(syms (union syms syms)))
(ppp 'res #`(begin
(pp 'res #`(begin
(eval-when (compile load eval)
(add-non-defined
(quote #,(datum->syntax stx syms))))
......@@ -728,7 +730,6 @@
(add-non-defined (get-syms))
(pp 'lambdas (fluid-ref lambdas))
;; Make sure to define closure parents in current module
(let lp ((lams (fluid-ref lambdas)))
(match lams
......@@ -756,11 +757,12 @@
`#,r)))
(values
(apply
(eval `(let-syntax ((fexpr (lambda (x) ,burp)))
fexpr)
(let ((r (apply
(eval `((lambda () (let-syntax ((fexpr (lambda (x) ,burp)))
fexpr)))
mod)
state w)
state w)))
r)
w wl ws))
end_of_file)))))))
......
......@@ -93,10 +93,6 @@
(c2 (chars-> c1)))
(<=> (a b c) (a2 b2 c2))))))))))
(define unary-minus (@@ (logic guile-log prolog
goal-transformers)
op1-))
(<define> (check-achars l L)
(<let> ((l (<lookup> l)))
(if (<var?> l)
......@@ -109,7 +105,10 @@
((<var?> x)
(instantiation_error))
((not (or (char? x)
(and (procedure? x) (eq? x unary-minus))
(and (procedure? x)
(or (eq? x unary-minus)
(eq? x binary-minus)
(eq? x binary-plus)))
(and (string? x)
(= (string-length x) 1))
(and (procedure? x)
......@@ -154,9 +153,15 @@
((number? x)
(cons (integer->char x) (plist->chars (cdr l))))
((procedure? x)
(cons (if (eq? x unary-minus)
#\-
(string-ref (symbol->string (procedure-name x)) 0))
(cons (cond
((eq? x unary-minus)
#\-)
((eq? x binary-minus)
#\-)
((eq? x binary-plus)
#\+)
(else
(string-ref (symbol->string (procedure-name x)) 0)))
(plist->chars (cdr l))))
(else
(cons x (plist->chars (cdr l)))))))
......@@ -206,6 +211,8 @@
(type_error integer code))))
((<var?> code)
(<=> code ,(char->integer (list-ref (->chaars ch) 0))))
((< code 0)
(representation_error character_code))
((<var?> ch)
(<=> ch ,(list->string (list (integer->char code)))))
(else
......
......@@ -465,6 +465,6 @@
<lambda-dyn>) ,aa
(,(GL <var>) ,vars ,ff)
,(list (G cons) `,aaa `,fff))))
#:env (current-module))
#:env (current-module))
(append ffkn (map (lambda (x) (gp-make-var)) (append vars ovars))))))
......@@ -211,9 +211,10 @@
((eq? x 'yfx) yfx)
((eq? x 'xfy) xfy)
(else x)))
(define-parser-directive-onfkn op (op-spc stx l N M)
(match (pk (get.. "," l))
(match (get.. "," l)
(((#:number prio _ _)
(#:atom spec . _)
(or (#:string x _ _) (#:atom x . _) (#:symbolic x _ _)))
......@@ -288,7 +289,7 @@
(,debug #t ,off ,on ,off)
(,max_arity #f ,1024)
(,unknown #t ,error ,error ,fail ,warning)
(,double_quotes #t ,chars ,chars ,codes ,atom)))
(,double_quotes #t ,atom ,chars ,codes ,atom)))
(for-each
(lambda (x)
(match x
......@@ -317,9 +318,12 @@
x))
(define (is-a-num? x)
(if (number? x)
x
(evaluation_error (fluid-ref *current-stack*) p cc)))
(cond
((number? x)
x)
(else
(evaluation_error (fluid-ref *current-stack*) p cc))))
(define (check-flags k v static)
(let ((r (assq k *flags*)))
(if r
......
......@@ -11,7 +11,7 @@
#:export (type_error instantiation_error domain_error existence_error
permission_error list/plist? existence_error
*call-expression* representation_error syntax_error
scheme-wrapper evaluation_error))
scheme-wrapper evaluation_error throw-it system_error))
(define-syntax fkn-it
(syntax-rules (quote)
......@@ -20,7 +20,7 @@
(vector `(,f ,(fkn-it x) ...)))
((_ x) x)))
(define *debug* #t)
(define *debug* #f)
(define (call-with-eh th . l)
(if *debug*
(call-with-error-handling th)
......@@ -107,6 +107,12 @@
(error (syntax_error a)
'iso-prolog))
(define-error (system_error)
(error system_error
'iso-prolog))
(define-error (throw-it a) a)
#;
(define-error (evaluation_error a )
(error (evaluation_error a)
......@@ -145,7 +151,7 @@
(g f)))))
(h (lambda x
(define-syntax-rule (wrap f)
(define-syntax-rule (wrap f)
(abort-to-prompt tag
(lambda ()
(catch #t
......
......@@ -103,7 +103,7 @@
(cond
((eq? f float)
(apply exact->inexact (map (lambda (a) (scm-eval* s a)) l)))
((eq? v #:goal)
((eq? v #:scm)
(apply f s (map (lambda (a) (scm-eval* s a)) l)))
(else
(apply f (map (lambda (a) (scm-eval* s a)) l))))))
......
......@@ -412,14 +412,16 @@
(define e1 1.000000000001)
(define e2 0.999999999999)
(define (my-equal? x y)
(if (< x 0) (set! x (- x)))
(if (< y 0) (set! y (- y)))
(if (and (number? x) (number? y))
(if (inexact? x)
(and (<= y (* e1 x)) (>= y (* e2 x)))
(if (inexact? y)
(and (<= x (* e1 y)) (>= x (* e2 y)))
(= x y)))
(if (and (is-a-num? x) (is-a-num? y))
(begin
(if (< x 0) (set! x (- x)))
(if (< y 0) (set! y (- y)))
(if (inexact? x)
(and (<= y (* e1 x)) (>= y (* e2 x)))
(if (inexact? y)
(and (<= x (* e1 y)) (>= x (* e2 y)))
(= x y))))
(= x y)))
(define (my-<= x y)
......@@ -461,6 +463,9 @@ floor(x) (floor x)
(cond
((or (number? x) (null? x))
(<cut> (<=> (x) y)))
((procedure? x)
(sup=.. (vector (list x)) y))
((vector? x)
(<cut>
......@@ -549,7 +554,7 @@ floor(x) (floor x)
(match x
((('xfy _ "->" _) i t n m)
(let lp ((i i))
(match (pk i)
(match i
((x) (lp x))
(((_ _ (or "<" ">" "=<" ">=" "==" "=:=" "=\\=") _) a b n2 m2)
......@@ -589,7 +594,7 @@ floor(x) (floor x)
(mk-prolog-term-3 tr-catch catch catch-mac a a a)
;; THROW
(<define> (throw x) (<abort> 'prolog (<lambda> () <cc>) x))
(<define> (throw x) (throw-it x))
;; COPY_TERM
(<define-guile-log-rule> (<copy_term> x l)
......@@ -917,7 +922,10 @@ floor(x) (floor x)
(set! (@ (logic guile-log prolog names) divide) op2/)
(set! (@ (logic guile-log prolog names) plus) op2+)
(set! (@ (logic guile-log prolog names) fact) op2*)
(set! (@ (logic guile-log prolog names) unary-minus) op1-)
(set! (@ (logic guile-log prolog names) binary-minus) op2-)
(set! (@ (logic guile-log prolog names) binary-plus) op2+)
(set! (@ (logic guile-log prolog names) fact) :-)
(set! (@ (logic guile-log prolog names) true) true)
(set! (@ (logic guile-log prolog names) fail) fail)
(set! (@ (logic guile-log prolog names) !) !)
......
......@@ -165,7 +165,7 @@
(lambda ()
(let ((s (open-file fn mode)))
(cons s #f)))
(lambda x (pk x) (cons #t #t)))))
(lambda x (cons #t #t)))))
(define *open-ports* (make-fluid '()))
......
......@@ -24,6 +24,9 @@
;; goal transformers
divide
plus
unary-minus
binary-minus
binary-plus
fact
true
!
......@@ -129,8 +132,8 @@
(begin
(mk-dyn nm (lambda (x) (set! d x)))
d)))
((x) d)
((a b c . l)
((a b c . l)
(if d (apply d k)
(apply
(<lambda> l
......@@ -157,7 +160,7 @@
(_
(type_error ss p cc evaluable
(vector `(,divide ,f
,(- (length k) 1)))))))))
,(- (length k) 0)))))))))
(set-object-property! f 'prolog-symbol #t)
f))
......@@ -180,6 +183,9 @@
(mk-sym check-num)
(mk-sym divide)
(mk-sym unary-minus)
(mk-sym binary-minus)
(mk-sym binary-plus)
(mk-sym plus)
(mk-sym fact)
(mk-sym true)
......
......@@ -186,14 +186,14 @@
(begin
(define (nm . a) . code)
(attach-defined-module! nm)
(set-object-property! nm 'prolog-functor-type #:goal)
(set-object-property! nm 'prolog-functor-type #:scm)
(set-object-property! nm 'prolog-functor-stx #'nm)))
((_ nm code)
(begin
(define nm code)
(attach-defined-module! nm)
(set-object-property! nm 'prolog-functor-type #:goal)
(set-object-property! nm 'prolog-functor-type #:scm)
(set-object-property! nm 'prolog-functor-stx #'nm)))))
(define* (attach-defined-module! f #:optional (mod (current-module)))
......
......@@ -5,7 +5,7 @@
#:use-module (ice-9 format)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log prompts)
#:export (prolog-run))
#:export (prolog-run prolog-run-0))
(define (var->code x)
(define (get-fkn a)
......@@ -45,3 +45,13 @@
(<lambda> (tag next l)
(<format> #t "DYNAMIC ERROR:~%=> ~a~%~%" (var->code (<scm> l)))
(<ret> (<scm> l)))))))))
(define (prolog-run-0 f . l)
(let ((fr ((@ (logic guile-log umatch) gp-newframe)
(fluid-ref (@ (logic guile-log umatch) *current-stack*)))))
(prolog-run 1 ()
(<apply> f l)
(<code>
((@ (logic guile-log umatch) gp-unwind) fr)))))
\ No newline at end of file
......@@ -6,7 +6,7 @@
#:use-module (logic guile-log prolog symbols)
#:use-module (logic guile-log prolog namespace)
#:use-module ((logic guile-log umatch)
#:select (gp-newframe gp-unwind))
#:select (gp-newframe gp-unwind gp-make-var))
#:use-module (ice-9 eval-string)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
......@@ -107,8 +107,8 @@
((#:variable '_ . _) x_x)
((#:variable v . _) (-var- (datum->syntax stx v)))
((#:list () . _) (-list- '()))
(((or #:string #:keyword) str . _) (-eval- str))
((#:dstring str . _) (-eval- ((get-double-quote-flag-fkn) str)))
((#:keyword str . _) (-eval- str))
((#:string str . _) (-eval- ((get-double-quote-flag-fkn) str)))
((#:list v . _) (-list- (get-c fget v)))
((#:scm-term (#:atom s . _) l _ _)
(-eval- (mk-scheme stx s l)))
......@@ -163,8 +163,14 @@
#,@(map fget (get.. "," x)))))
((and atom (#:atom f _ _ n m))
(add-sym mod local? atom)
(-eval- (car (f->stxfkn mod f local? atom arg #f stx #f n m '()))))
(let ((str (symbol->string f)))
(if (and (> (string-length str) 0)
(char-upper-case? (string-ref str 0)))
str
(begin
(add-sym mod local? atom)
(-eval- (car (f->stxfkn mod f local? atom arg #f stx #f n m
'())))))))
((#:number n . _)
(-eval- n))
......@@ -172,13 +178,15 @@
(((_ _ "-" _) (#:number n _ _) _ _)
(- n))
((or ((tp _ op _) x y n m)
((or ((tp _ op _) x y n m)
(#:termstring (#:string (and tp op) _ _) (x y) n m))
(add-sym mod local? `(#:atom ,(string->symbol op) #f #f ,n ,m))
(-term-
(f->stxfkn #f op #f #f arg #f stx 2 n m (list x y))))
((or ((tp _ op _) x n m)
(#:termstring (#:string (and tp op) _ _) (x) n m))
(add-sym mod local? `(#:atom ,(string->symbol op) #f #f ,n ,m))
(-term-
(f->stxfkn #f op #f #f arg #f stx 1 n m (list x))))
......@@ -240,7 +248,7 @@
(hashq-set! (fluid-ref *variables*) v #t)
#`,#,x))
(define x_term #',GL:_)
(define x_term #',(gp-make-var))
(define (eval-term x) #`,#,x)
(define (list-term x) x)
(define (term-term x)
......
......@@ -224,7 +224,7 @@
(define *states* #t)
(define *gp* (gp-current-stack-ref))
(fluid-set! *gp* (gp-make-stack 0 0 500000 50000 50000))
(fluid-set! *gp* (gp-make-stack 0 0 500000 500000 500000))
(define *current-stack* (make-fluid '()))
(fluid-set! *current-stack* (newf (fluid-ref *current-stack*)))
......
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