removed bug in memoize.scm, inriasuite starts to work

parent 3da53cb6
......@@ -129,7 +129,6 @@
(lambda ()
(load-extension file "gp_init"))
(lambda x
(pk x)
(warn
"libguile-log is not loadable!")))
(warn
......
......@@ -447,7 +447,7 @@ add/run * vlist *
(define (walk-raw s p a F walk-dynlist e rev)
(let* ((ar (get-ar e))
(db (get-li e)))
(let lp ((l (rev (pk (get-index-set s a db)))))
(let lp ((l (rev (get-index-set s a db))))
(if (null? l)
(p)
(F (lambda () (lp (cdr l)))
......
......@@ -17,8 +17,12 @@
#:use-module (logic guile-log prolog namespace)
#:use-module (system base language)
#:use-module (logic guile-log)
#:use-module ((logic guile-log umatch) #:select (gp-var!))
#:export (reset-flags reset-prolog set)
#:re-export (;; Functor management
#:re-export (;;unknown cludge
gp-var!
;; Functor management
Trace Level trace-level
functorize adaptable_vars trace
......@@ -81,6 +85,7 @@
not_less_than_zero evaluable callable modify
static_procedure access end_of_file
predicate_indicator private_procedure
procedure
;; characters
atom_length atom_concat atom_chars atom_codes char_code
......
......@@ -501,6 +501,7 @@ compare_subst_lists(F,S, FNS,SNF) :-
length(F,1),!,
del_item(F, S, SNF),
(member(F,S) -> FNS =[]; FNS = F).
compare_subst_lists(F,S, FNS,SNF) :-
length(S,1),
del_item(S, F, FNS),
......@@ -521,8 +522,8 @@ list_del_item([It|R], L1, Left) :-
del_item(_Item, [],[]).
del_item(Item, [It |R], R) :-
same_subst(Item, It), ! .
% del_item(Item, Rest, R).
same_subst(Item, It), !.
% del_item(Item, Rest, R).
del_item(Item, [It|Rest], [It |R]) :-
del_item(Item, Rest, R).
......@@ -575,14 +576,10 @@ read_test(Extra, Missing) :-
%
run_tests(File) :-
write(1),
run_tests(File) :-
asserta(score(File, total(0), wrong(0))),
write(File),
open(File, read, S),
write(3),
loop_through(File,S),
write(4),
close(S),
write_results,!.
......
(define-module (inriasuite)
#:use-module (logic guile-log iso-prolog)
#:use-module ((guile) #:select (@ define))
#:use-module ((guile) #:select (@ @@ define))
#:pure
#:re-export (prolog-run)
#:export (run_tests run_all_tests))
#:export (run_tests run_all_tests unexpected_ball
failure success impl_def undefined))
(compile-prolog-file "inriasuite.pl")
(save-operator-table)
......@@ -93,6 +93,16 @@ Also it is possible to solve inifinite recursion.
(if m
(vhasha-ref (fluid-ref m) tag #f)
#f)))
(define (rec-ref00 f)
(let ((m (vhashq-ref (fluid-ref recs) f #f)))
(fluid-ref m)))
(define (rec-set0! f h)
(let ((m (vhashq-ref (fluid-ref recs) f #f)))
(if m
(fluid-set! m h)
#f)))
(define (table-ref0 f tag)
(let ((m (vhashq-ref (fluid-ref tables) f #f)))
(if m
......@@ -272,7 +282,7 @@ Also it is possible to solve inifinite recursion.
(with-state-guard-dynamic-object h
(<lambda> () (D h code)))))))
(define-syntax-rule (get-tag s x) (map (lambda (x) (<lookup> x)) x))
(define-syntax-rule (get-tag s x) (map (lambda (x) (<lookup> x)) x))
(define-syntax-rule (mk-rec-lam rec with get-tag-1)
(define (rec f guard doit)
......@@ -457,9 +467,13 @@ Also it is possible to solve inifinite recursion.
(lam (a . b)
(<let> ((a (<lookup> a))
(b (<lookup> b)))
(rec-action lam a)
(rec-action lam b)))
(b (<lookup> b))
(h (rec-ref00 rec-action*)))
(rec-action lam a)
(<code>
(vhash-truncate! h)
(rec-set0! rec-action* h))
(rec-action lam b)))
(lam x
(<let> ((x (<lookup> x)))
......@@ -479,9 +493,9 @@ Also it is possible to solve inifinite recursion.
(rec-action lam (namespace-val x)))
(else
<cc>)))))
(define rec-action (rec-lam-once-0 rec-action* unify-guard doit-id))
(define rec-action00 (rec-00 rec-action* unify-guard doit-id))
(define rec-action (rec-lam-00 rec-action* unify-guard doit-id))
(define rec-action00 rec-action)
(define (gp-rec= x y s)
(rec= s (lambda x #f) (lambda (s . u) s) x y))
......@@ -500,10 +514,11 @@ Also it is possible to solve inifinite recursion.
(gp-cp-rec x '() s))
((x l s)
(define mp (make-hash-table))
(define track vlist-null)
(fluid-set! mpf mp)
(<wrap-s> rec-action00 s
(<lambda> (y)
(<code> (hashq-set! mp (<lookup> y) #t)))
(<code> (hashq-set! mp (<lookup> y) #t)))
x)
(gp-cp++ #f x l s))))
......@@ -640,3 +655,4 @@ Also it is possible to solve inifinite recursion.
(lambda (g)
(<lambda> (f . x)
(with-canon- (<lambda> () (<apply> f x)) g))))
......@@ -24,6 +24,16 @@
(when do-print
(pretty-print (syntax->datum x)))
x)))
(define ppp
(case-lambda
((s x)
(when #t
(pretty-print `(,s ,(syntax->datum x))))
x)
((x)
(when #t
(pretty-print (syntax->datum x)))
x)))
(define-syntax define-goal-functor
(syntax-rules ()
......
......@@ -58,7 +58,6 @@
(define-syntax-rule (define-syntax-rule-pk (f . a) c)
(define-syntax f
(lambda (x)
(pk (syntax->datum x))
(syntax-case x ()
((_ . a) #'c)))))
......@@ -419,9 +418,9 @@ floor(x) (floor x)
x))
(<define> (func=.. x y)
(<let> ((xx (<lookup> x))
(x (project@ S x))
(y (<scm> y)))
(<let*> ((xx (<lookup> x))
(x (project@ S xx))
(y (<scm> y)))
(cond
((or (number? x) (null? x))
(<cut> (<=> (x) y)))
......@@ -448,7 +447,7 @@ floor(x) (floor x)
(else
(<=> xx ,(vector y)))))))
(y
(<cut>
(<cut>
(<=> xx ,(vector y)))))))
(_ (type_error 'compound x)))))
......@@ -865,14 +864,19 @@ floor(x) (floor x)
(<ret> `(halt ,x))))))
s p cc x))))
(set! (@ (logic guile-log prolog names) float) float)
(set! (@ (logic guile-log prolog names) number) number)
(set! (@ (logic guile-log prolog names) integer) integer)
(set! (@ (logic guile-log prolog names) divide) divide)
(set! (@ (logic guile-log prolog names) plus) plus)
(set! (@ (logic guile-log prolog names) fact) fact)
(set! (@ (logic guile-log prolog names) true) true)
(set! (@ (logic guile-log prolog names) fail) fail)
(set! (@ (logic guile-log prolog names) !) !)
(set! (@ (logic guile-log prolog names) atom) atom)
(define first? #t)
(if first?
(begin
(set! (@ (logic guile-log prolog names) float) float)
(set! (@ (logic guile-log prolog names) number) number)
(set! (@ (logic guile-log prolog names) integer) integer)
(set! (@ (logic guile-log prolog names) divide) divide)
(set! (@ (logic guile-log prolog names) plus) plus)
(set! (@ (logic guile-log prolog names) fact) fact)
(set! (@ (logic guile-log prolog names) true) true)
(set! (@ (logic guile-log prolog names) fail) fail)
(set! (@ (logic guile-log prolog names) !) !)
(set! (@ (logic guile-log prolog names) atom) atom)
(set! first? #f)))
(define-module (logic guile-log prolog io)
#:use-module (logic guile-log)
#:use-module (logic guile-log vlist)
#:use-module (logic guile-log memoize)
#:use-module (logic guile-log attributed)
#:use-module (logic guile-log guile-prolog attribute)
......@@ -7,7 +8,8 @@
#:select (gp-var? gp-lookup gp->scm))
#:use-module (logic guile-log guile-prolog closure)
#:use-module (rnrs io ports)
#:use-module (ice-9 match)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 format)
#:use-module (logic guile-log prolog base)
#:use-module ((logic guile-log prolog util)
......@@ -447,7 +449,11 @@
(define qt (cons 'quoted 'var))
(define* (scm->pl s x #:optional (ns? #f) (quoted? #f) (ignore? #f) (numbervars? #f))
(define first-map (make-hash-table))
(define (first-redo h)
(set! first-map h)
(vlist-truncate! h))
(define first-map vlist-null)
(define action-map (make-hash-table))
(define action-i 0)
(<define> (action x)
......@@ -473,57 +479,71 @@
s)))
(define (list-it x)
(umatch (#:mode -r #:status s #:name list-it) (x)
((a)
(format #f "~a" (lp a)))
((a . b)
(begin
(let ((r (lp? b (lambda ()
(format #f "[~a]" (list-it b))))))
(if r
(format #f "~a|~a" (lp a) r)
(umatch (#:mode -r #:status s #:name list-it) (b)
((_ . _)
(format #f "~a, ~a" (lp a) (list-it b)))
(_
(format #f "~a|~a" (lp a) (lp b))))))))))
(let ((h first-map))
(umatch (#:mode -r #:status s #:name list-it) (x)
((a)
(begin
(first-redo h)
(format #f "~a" (lp a))))
((a . b)
(begin
(first-redo h)
(let ((r (lp? b (lambda ()
(format #f "[~a]" (list-it b))))))
(first-redo h)
(if r
(format #f "~a|~a" (lp a) r)
(umatch (#:mode -r #:status s #:name list-it) (b)
((_ . _)
(format #f "~a, ~a" (lp a) (begin (first-redo h)
(list-it b))))
(_
(format #f "~a|~a" (lp a) (begin (first-redo h)
(lp b))))))))))))
(define (str x) (if (symbol? x)
(symbol->string x)
x))
(define (gen@ ll a)
(cond
((not ns?)
(format #f "~a" (procedure-name a)))
(format #f "~a" (str (procedure-name a))))
((and ns? (not quoted?))
(let ((m (current-module))
(n (procedure-name a)))
(if (and (module-defined? m n) (eq? (module-ref m n) a))
(let ((m (current-module))
(ns (procedure-name a))
(n (str (procedure-name a))))
(if (not quoted?)
(format #f "~a" n)
(match ll
(('language 'prolog 'modules x)
(format #f "~a@@~a"
(procedure-name a) x))
(("language" "prolog" "modules" x)
(format #f "~a@@~a"
(procedure-name a) x))
((_ . _)
(format #f "~a@@(~a~{, ~a~})"
(procedure-name a) (car ll) (cdr ll)))
(_
(format #f "~a" (procedure-name a)))))))
(if (and (module-defined? m ns) (eq? (module-ref m ns) a))
(format #f "~a" n)
(match ll
(('language 'prolog 'modules x)
(format #f "~a@@~a"
n x))
(("language" "prolog" "modules" x)
(format #f "~a@@~a"
n x))
((_ . _)
(format #f "~a@@(~a~{, ~a~})"
n (car ll) (cdr ll)))
(_
(format #f "~a" n)))))))
(else
(match ll
(('language 'prolog 'modules x)
(format #f "~a@@~a"
(procedure-name a) x))
(str (procedure-name a)) x))
(("language" "prolog" "modules" x)
(format #f "~a@@~a"
(procedure-name a) x))
(str (procedure-name a)) x))
((_ . _)
(format #f "~a@@(~a~{, ~a~})"
(procedure-name a) (car ll) (cdr ll)))
(str (procedure-name a)) (car ll) (cdr ll)))
(_
(format #f "~a" (procedure-name a)))))))
(format #f "~a" (str (procedure-name a))))))))
......@@ -531,11 +551,11 @@
(let ((x (gp-lookup x s)))
(let ((v (hashq-ref action-map x #f)))
(if v
(let ((w (hashq-ref first-map x #f)))
(let ((w (vhashq-ref first-map x #f)))
(if w
(format #f "ref[~a]" v)
(begin
(hashq-set! first-map x #t)
(vhash-consq x #t first-map)
(string-append
(format #f "{~a}" v)
(trail x #t)))))
......@@ -545,11 +565,11 @@
(let ((x (gp-lookup x s)))
(let ((v (hashq-ref action-map x #f)))
(if v
(let ((w (hashq-ref first-map x #f)))
(let ((w (vhashq-ref first-map x #f)))
(if w
(format #f "ref[~a]" v)
(begin
(hashq-set! first-map x #t)
(vhash-consq x #t first-map)
(format #f "{~a}~a" v (trail)))))
#f))))
......@@ -559,14 +579,16 @@
(umatch (#:mode -r #:status s #:name scm->pl) (x)
(#((f a . l))
(let ((f (gp-lookup f s))
(x (gp-lookup x s)))
(x (gp-lookup x s))
(h first-map))
(cond
((string? f)
(format #f "'~a'(~a~{, ~a~})" f (lp a) (map lp (gp->scm l s))))
((and (struct? f) (prolog-closure? f))
(let ((args (map lp (prolog-closure-state f)))
(let ((args (map (lambda (x) (first-redo h) (lp x))
(prolog-closure-state f)))
(pre (lp (vector (cons* (prolog-closure-parent f) l)))))
(if quoted?
(let ((n (hashq-ref *closures* x #f)))
......@@ -586,11 +608,14 @@
))))
(else
(let ((op (procedure-property f 'prolog-operator)))
(let ((h first-map)
(op (procedure-property f 'prolog-operator)))
(if (and op (not (and ns? quoted?)))
(format #f "'~a'(~a~{, ~a~})"
op
(lp a) (map lp (gp->scm l s)))
(lp a) (map (lambda (x) (first-redo h) (lp x))
(gp->scm l s)))
(let ((ll (map (lambda (x) (format #f "'~a'" x))
(get-attached-module f ns?))))
(format #f "~a(~a~{, ~a~})"
......@@ -668,9 +693,12 @@
((struct? a)
(cond
((prolog-closure? a)
(let ((args (map lp (prolog-closure-state a)))
(pre (lp (vector
(cons* (prolog-closure-parent a) '())))))
(let* ((h first-map)
(args (map (lambda (x) (first-redo h) (lp x))
(prolog-closure-state a)))
(pre (lp (vector
(cons* (prolog-closure-parent a) '())))))
(if quoted?
(if (pair? args)
(format #f "~a()[~a~{, ~a~}]"
......@@ -783,6 +811,17 @@
(set-procedure-property! write 'name 'write)
(define ppp
(case-lambda
((s x)
(when #t
(pretty-print `(,s ,(syntax->datum x))))
x)
((x)
(when #t
(pretty-print (syntax->datum x)))
x)))
(define pp
(<case-lambda>
((x)
......@@ -795,7 +834,9 @@
(e (call-with-values
(lambda () (read-prolog-term S s (current-module)))
(lambda x x))))
(<=> ,(list term v vn si) e)
(<or>
(<and> (<=> ,(list term v vn si) e) <cut>)
(<=> ,(list term v vn si) ,(list end_of_file '() '() '())))
(<code> (fluid-set! *closure-creations* (make-hash-table)))))
......
......@@ -109,6 +109,7 @@
char-convert))
(define first? #t)
(define get-flag #f)
(define cc (lambda x #t))
......@@ -116,8 +117,9 @@
(define ss (fluid-ref *current-stack*))
(define (make-unbound-fkn nm)
(letrec ((warn-message
(format #f "fkn ~a is not evaluable, will fail" f))
(letrec ((warn-message
(lambda (f)
(format #f "fkn ~a is not evaluable, will fail" f)))
(d #f)
(f (lambda k
(match k
......@@ -140,7 +142,7 @@
(vector `(,divide ,f
,(length l)))))
((eq? e warning)
(<code> (warn warn-message))
(<code> (warn (warn-message (procedure-name f))))
<fail>)
((eq? e fail)
......@@ -166,7 +168,7 @@
(set-procedure-property! a 'name 'a)))
(define (make-sym mod a)
(if (not (module-defined? mod a))
(if (and first? (not (module-defined? mod a)))
(let ((f (make-unbound-fkn a)))
(module-define! mod a f)
(set-procedure-property! f 'module (module-name mod))
......@@ -274,4 +276,6 @@
(set! (@@ (logic guile-log prolog error) number) number)
(set! (@@ (logic guile-log prolog error) integer) integer)
(set! (@@ (logic guile-log prolog error) source_sink) source_sink)
\ No newline at end of file
(set! (@@ (logic guile-log prolog error) source_sink) source_sink)
(set! first? #f)
......@@ -606,8 +606,8 @@
(_
#f))
(<p-cc>
(wrap@ u (pk `(#:term (#:atom ,(string->symbol c1) ,n ,m)
,(<scm> c3) #f ,n ,m))))
(wrap@ u `(#:term (#:atom ,(string->symbol c1) ,n ,m)
,(<scm> c3) #f ,n ,m)))
<fail>)))
mk-id)))
......@@ -684,7 +684,7 @@
char list-tok true/false
termvar-tok term-binop-tok termop-tok
termstring-tok term-tok scm-tok lam-tok
number qstring dstring atom variable symbolic-tok
number qstring dstring atom variable #;symbolic-tok
#;op-tok))
(define e (mk-operator-expression tok symbolic-tok2 *prolog-ops*))
......@@ -777,7 +777,7 @@
(define-syntax-rule (retit x ...)
(catch #t
(lambda () x ...)
(lambda y (pk y) #f)))
(lambda y #f)))
(define (prolog-tokens stx)
(let ((f (f* (f-or!
......
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