tabling now works accaptably plus bugfixes in the interpretter

parent cba2e046
......@@ -18,12 +18,9 @@
(define mp (make-hash-table))
(define n 0)
(define nn 0)
(pk 'gp->scm gp->scm)
(call-with-values (lambda () (gp->scm x s))
(lambda (x)
(pk 'scm x)
(analyze mp x s)
(pk 'anal)
(let lp ((x x) (first #t))
(cond
((and first (hashq-ref mp x))
......@@ -63,7 +60,6 @@
(define vs vals)
(define n 0)
(define tr (make-hash-table))
(pk 'uncanon
(let lp ((x x))
(cond
((pair? x)
......@@ -102,5 +98,5 @@
(hash-set! tr x untag)
untag)
x)))
x))))))
x)))))
......@@ -480,18 +480,17 @@ before. This works very much like a fluid
(let* ((api (get-dynamic-api h))
(old (backtrack-ref h s)))
(if (not api)
(fail s p cc h)
(when (not old)
(let* ((ref (get api iref))
(e (ref h))
(bt (mk api e h ref (dobt))))
(backtrack-add bt s)
(gp-fluid-set bt e)
(code s p
(lambda (s p)
(gp-fluid-set bt e)
(backtrack-remove h s)
(cc s p))))))))
(fail s p cc h)
(let* ((ref (get api iref))
(e (ref h))
(bt (mk api e h ref (dobt))))
(backtrack-add bt s)
(gp-fluid-set bt e)
(code s p
(lambda (s p)
(gp-fluid-set bt e)
(backtrack-remove h s)
(cc s p)))))))
(define* (with-backtrack-dynamic-object-once
......@@ -501,18 +500,17 @@ before. This works very much like a fluid
(old (backtrack-ref h s)))
(if (not api)
(fail s p cc h)
(when (not old)
(let* ((ref (get api iref))
(e (ref h))
(bt (mk api e h ref (dobt))))
(backtrack-add bt s)
(gp-fluid-set bt e)
(let ((old-bt (bt)))
(code s p
(lambda (s pp)
(backtrack-remove h s)
(gp-fluid-set bt e)
(cc s p)))))))))
(let* ((ref (get api iref))
(e (ref h))
(bt (mk api e h ref (dobt))))
(backtrack-add bt s)
(gp-fluid-set bt e)
(let ((old-bt (bt)))
(code s p
(lambda (s pp)
(backtrack-remove h s)
(gp-fluid-set bt e)
(cc s p))))))))
(define* (with-not-backtrack-dynamic-object
......
......@@ -3,7 +3,7 @@
(<clear> <define> <let> <let*> <=> <lookup> <match> <fail>
<cut> <wrap> <state-ref> <state-set!> <continue>
<code> <scm> <stall> <case-lambda> <cc>
<newframe> <=> <and> <lambda> <apply>))
<newframe> <=> <and> <lambda> <apply> <pp>))
#:use-module (logic guile-log guile-prolog hash)
#:use-module (logic guile-log guile-prolog fluid)
#:use-module (logic guile-log vlist)
......@@ -99,11 +99,12 @@
(define *states* (make-hash-table))
(define (read-prolog port env)
(define nn? #f)
(define all? #f)
(define fail? #f)
(define mute? #f)
(define n? #f)
(define help? #f)
(define save #f)
(define load #f)
......@@ -112,6 +113,7 @@
(define set #f)
(define old #f)
(define clear #f)
(define endl #f)
(let* ((l
(with-input-from-port port
(lambda ()
......@@ -131,14 +133,14 @@
(let ((action ((@ (guile) read))))
(cond
((integer? action)
(set! n? action))
(set! nn? action))
((pair? action)
action)
(else
(case action
((mute m) (set! mute? #t))
((all *) (set! all? #t))
((once) (set! n? 1))
((once) (set! nn? 1))
((h help) (set! help? #t))
((s save) (set! save ((@ (guile) read))))
((l load) (set! load ((@ (guile) read))))
......@@ -146,20 +148,22 @@
((ref) (set! ref ((@ (guile) read))))
((set) (set! set (list ((@ (guile) read))
((@ (guile) read)))))
((clear) (set! clear #t))
((clear) (set! clear #t) (set! endl #\.))
((lo lold)
(set! old #t)
(if lold (<state-set!> lold)))
(else
(set! fail? #t)))
(cond
((or fail? help?)
#f)
((or load save cont ref set old)
#t)
(else
(lp #t (peek-char) '() #f))))))
(set! fail? #t)))))
(cond
(endl
(if #f #f))
((or fail? help?)
#f)
((or load save cont ref set old)
#t)
(else
(lp #t (peek-char) '() #f))))
(let ((ch (peek-char)))
(if dot-cont?
(lp #f ch (cons #\. r) #f)
......@@ -179,7 +183,9 @@
(cond
(clear
`((@ (logic guile-log) <clear>)))
`((@ (logic guile-log) begin)
((@ (logic guile-log) <clear>))
((@ (logic guile-log) if) #f #f)))
(old
'((@ (guile) if) #f #f))
(ref
......@@ -255,7 +261,7 @@ HELP FOR PROLOG COMMANDS
,str
,((@ (guile) cond)
(all? '(@ (logic guile-log iso-prolog) true))
(n? n?)
(nn? nn?)
(else
'(@ (logic guile-log iso-prolog) false)))
,(if mute?
......@@ -325,7 +331,7 @@ conversation_ :-
consult(T,V,N,false,false)
) ; conversation_.
conversation1(X,All,Mute) :-
conversation1(X,All,Mute) :-
fluid_guard_dynamic_object(scm[-n-], scm[-nsol-], scm[-all-]),
state_guard_dynamic_object(scm[-n-], scm[-nsol-], scm[-all-],
scm[*user-data*]),
......
......@@ -5,7 +5,7 @@
#:use-module (ice-9 rdelim)
#:use-module (logic guile-log dynamic-features)
#:use-module ((logic guile-log iso-prolog) #:select (read_term prolog-run))
#:export (readline readline_term -n-))
#:export (readline readline_term -n- do-readline-warning))
(define p (lambda x x))
(define cc (lambda x x))
......@@ -14,11 +14,16 @@
(define -n- (make-fluid 0))
(add-fluid-dynamics s p cc -n-)
(define do-readline-warning #t)
(define readline_
(if (provided? 'readline)
(@ (ice-9 readline) readline)
(begin
(warn "readline is not installed - read the guile manual about scheme interactive use")
(lambda (pr)
(when do-readline-warning
(warn "readline is not installed - read the guile manual about scheme interactive use"))
(format #t "~a" pr)
(readline))
(lambda (pr)
(format #t "~a" pr)
(read-line)))))
......
......@@ -74,7 +74,7 @@ Also it is possible to solve inifinite recursion.
(let ((m (hashq-ref memos f #f)))
(if m
(let ((l (vhash-ref (fluid-ref m) tag #f)))
(if (not x)
(if l
(fluid-set!
m
(vhash-cons tag (cons (F s x) l) (fluid-ref m)))
......@@ -99,32 +99,33 @@ Also it is possible to solve inifinite recursion.
(vhash-ref (fluid-ref m) tag #f)
#f)))
(define mark (list (cons 1 2)))
(<define> (add-rec f tag x D F)
(<let> ((m (vhashq-ref (fluid-ref recs) f #f)))
(if m
(<recur> lp ((first #t))
(if first
(if (eq? (pk 'first (fluid-ref m)) vlist-null)
(if (eq? (fluid-ref m) vlist-null)
(D m
(<lambda> ()
(lp #f)))
(lp #f))
(<let> ((q (vhasha-ref (fluid-ref m) tag #f)))
(<pp> 'a-m)
(if (not q)
(<and>
(<pp> 'not-x)
(<code> (fluid-set! m (vhash-consa tag
#t (fluid-ref m))))
(F))
<cc>))))
(<let> ((m (<make-vhash>)))
(<pp> `(add-dynamics ,f))
(add-vhash-dynamics m)
(<code> (fluid-set! recs (vhash-consq f m (fluid-ref recs))))
(D m
(<lambda> ()
(<code>
(fluid-set! m (vhash-consa mark #t (fluid-ref m))))
(add-rec f tag x D F)))))))
(define tables (<make-vhash>))
......@@ -147,19 +148,27 @@ Also it is possible to solve inifinite recursion.
(<define> (init-table f tag xin D F)
(<let> ((m (vhashq-ref (fluid-ref tables) f #f)))
(if m
(<let> ((x (vhash-ref (fluid-ref m) tag #f)))
(if (not x)
(<code> (fluid-set! m (vhash-cons tag xin (fluid-ref m))))
<cc>)
(F))
(<recur> lp ((first #t))
(if first
(if (eq? (fluid-ref m) vlist-null)
(D m (<lambda> () (lp #f)))
(lp #f))
(<let> ((x (vhash-ref (fluid-ref m) tag #f)))
(if (not x)
(<code> (fluid-set! m
(vhash-cons tag xin
(fluid-ref m))))
<cc>)
(F))))
(<let> ((m (<make-vhash>)))
(add-vhash-dynamics m)
(<code> (fluid-set! tables (vhash-consq f m (fluid-ref recs))))
(D m
(<lambda> ()
(init-table f tag xin D F)))))))
(<lambda> ()
(<code> (fluid-set! m (vhash-cons 1 1 (fluid-ref m))))
(init-table f tag xin D F)))))))
(<define> (memo-ref f x) (<=> x ,(hashq-ref memo f #f)))
(<define> (rec-ref f x) (<=> x ,(vhashq-ref (fluid-ref recs) f #f)))
......@@ -174,7 +183,7 @@ Also it is possible to solve inifinite recursion.
((f tag x)
(<recur> lp1 ((P '()))
(<let> ((L0 (pk 'lp1 (memo-ref0 f tag '()))))
(<let> ((L0 (memo-ref0 f tag '())))
(<recur> lp2 ((L L0))
(if (eq? L P)
(<and>
......@@ -182,12 +191,12 @@ Also it is possible to solve inifinite recursion.
(postpone 1 1)
<cc>)
(<recur> lp ()
(<let> ((L1 (pk 'lp2 (memo-ref0 f tag '()))))
(<let> ((L1 (memo-ref0 f tag '())))
(if (eq? L0 L1)
(<and> (postpone) (lp))
(lp1 L1)))))
(lp1 L0)))))
(<or>
((car L) x)
(<and> ((car L) x))
(lp2 (cdr L))))))))))
......@@ -238,13 +247,17 @@ Also it is possible to solve inifinite recursion.
(cc CC))
(cond
(me
(if (not first)
(postpone-frame 0 0 10000)
<cc>)
(do-tabling f tag x))
(first
(do-tabling f tag x first))
(else
(postpone-frame 0 0 10000)
(postpone-frame 0 0 10000)
(<let> ((p P))
(init-table f tag x (Q with-backtrack-dynamic-object)
(<lambda> ()
(<with-fail> (lambda ()
......@@ -254,12 +267,12 @@ Also it is possible to solve inifinite recursion.
(<with-cc> (lambda (s p . u)
(add-table-cc f tag x s)
(apply cc s p u))
(<apply> f x)))))))))
(<apply> f x))))))))))
(define (Q D) (<lambda> (h code)
(with-fluid-guard-dynamic-object h
(with-fluid-guard-dynamic-object h
(<lambda> ()
(with-state-guard-dynamic-object h
(with-state-guard-dynamic-object h
(<lambda> () (D h code)))))))
(define-syntax-rule (get-tag s x) (map (lambda (x) (<lookup> x)) x))
......@@ -272,20 +285,16 @@ Also it is possible to solve inifinite recursion.
(<values> (tag) (guard tag S))
(cond
((eq? tag #f)
(<pp> 'false-tag)
<cc>)
(tag
(<pp> 'tag)
(<let> ((hit (rec-ref0 f tag)))
(if hit
(<and>
(<pp> 'hit)
(doit x)
(<apply> lam x))
(add-rec f tag x with
(<lambda> () (<apply> f lam x))))))
(else
(<pp> 'pos-tag)
(<apply> f lam x)))))))
(define-syntax-rule (mk-rec rec with get-tag-1)
......@@ -402,16 +411,13 @@ Also it is possible to solve inifinite recursion.
(lam (a . b)
(<and>
(<pp> 'cons)
(rec-action lam a)
(rec-action lam b)))
(lam x
(<let> ((x (<lookup> x)))
(<pp> 'element)
(cond
((variable? x)
(<pp> 'variable)
(rec-action lam (variable-ref x)))
((prolog-closure? x)
(<let> ((lx (prolog-closure-state x)))
......@@ -445,23 +451,20 @@ Also it is possible to solve inifinite recursion.
(define (gp->scm-rec x s)
(define mp (make-hash-table))
(pk 'scm-anal)
(fluid-set! mpf mp)
(<wrap-s> rec-action s
(<lambda> (y)
(<pp> 'hit)
(<code> (hashq-set! mp (<lookup> y) #t)))
x)
(pk 'scm-it)
(gp-cp++ x s #t))
(define (canon-it-rec x s)
(define (analyze mp x s)
(<wrap-s> rec-action s
(<lambda> (y)
(<code> (hashq-set! mp (pk 'analyze (<lookup> y)) #t)))
(<code> (hashq-set! mp (<lookup> y) #t)))
x))
(pk 'canon (canon-it++ gp->scm-rec analyze x s)))
(canon-it++ gp->scm-rec analyze x s))
......
......@@ -131,8 +131,17 @@
(if (pair? l)
(loop (cdr l) (max s (caar l)))
s)))
(let ((l (fluid-ref *conts*)))
(if (and-map (lambda (x) (< (car x) 0)) l)
(let* ((l (fluid-ref *conts*)))
#;(format #t "nold : ~a, nnew : ~a, nfault ~a~%"
(length lold) (length l)
(let lp ((i 0) (x l))
(if (pair? x)
(if (< (caar x) 0)
(lp (+ i 1) (cdr x))
(lp i (cdr x)))
i)))
(if (and (and-map (lambda (x) (< (car x) 0)) l) (eq? (length l)
(length lold)))
(p)
(if (pair? l)
(let ((n (length l))
......
......@@ -470,7 +470,7 @@
((a . b)
(begin
(let ((r (lp? b (lambda ()
(format #f "(~a" (lp b))))))
(format #f "[~a]" (list-it b))))))
(if r
(format #f "~a|~a" (lp a) r)
(umatch (#:mode -r #:status s #:name list-it) (b)
......
......@@ -542,6 +542,7 @@ SCM manage_dyn_wind(SCM obj, SCM K, SCM *rguard) {
}
else
{
temp = scm_call_0(var);
scm_call_1(var, val);
}
vnew[D_FLUID_VAL] = temp;
......
......@@ -613,6 +613,9 @@
(namespace-local? x)
(namespace-lexical? x)))))
((variable? x)
(lp (variable-ref x)))
(else
x)))))))
......
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