further improvements, a little tracing capability

parent 8d8b10ed
......@@ -47,16 +47,16 @@
(<<case-lambda>>
(([K X] X D (((<lookup> K)) D)))))
(compile-string "yield(X) :- abort_to_prompt(generator,X,_).")
(compile-string "eat(X) :- abort_to_prompt(generator,_,X).")
(compile-string "generator(Goal,F) :-
(compile-prolog-string "yield(X) :- abort_to_prompt(generator,X,_).")
(compile-prolog-string "eat(X) :- abort_to_prompt(generator,_,X).")
(compile-prolog-string "generator(Goal,F) :-
with_prompt(generator, Goal,[generator,_,K,X],
F=[K,X]).")
(<define> (pref)
(<pp> (gp-handlers-ref)))
(compile-string
(compile-prolog-string
"
next([K,X],X,F) :- re_prompt(K,[generator,_,K2,XX],F=[K2,XX],_).
feed([K,_],Y,F) :- re_prompt(K,[generator,_,K2,_ ],F=[K2,_ ],Y).
......@@ -65,7 +65,7 @@ translate([K,X],X,Y,F) :- re_prompt(K,[generator,_,K2,XX],F=[K2,XX],Y).
;; Example 1 (run)
(compile-string
(compile-prolog-string
"
sum(S) :- write(sum(S)),nl,eat(X),write(y(X)),nl,SS is S + X,sum(SS).
run :- generator(iter(0),F),generator(sum(0),S),pr(F,S).
......@@ -74,7 +74,7 @@ iter(N) :- write(iter(N)),nl,N < 10 -> (yield(N),N2 is N + 1, iter(N2)).
")
;; Example 2 (run2)
(compile-string
(compile-prolog-string
"
iter2(N) :- write(iter2(N)),nl,N < 10 -> (yield(N) ; N2 is N + 1, iter2(N2)).
run2 :- generator(iter2(0),F),pr2(F,S).
......@@ -82,7 +82,7 @@ pr2(F,S) :- next(F,X,FF),fail.
")
;; Example 3 (run3)
(compile-string
(compile-prolog-string
"
iter3(S,N) :- N < 10 -> (write(iter3(S,N)),nl,N2 is N + 1, iter3(S,N2)) ; true.
run3 :- generator((eat(X),iter3(X,X)),F),pr3(F).
......@@ -90,7 +90,7 @@ pr3(F) :- call_k(F,_,0),write('--------'),nl,call_k(F,_,5).
")
;; Example 4 (run4)
(compile-string
(compile-prolog-string
"
iter4(S,N) :- N < 10 -> (write(iter4(S,N)),nl;N2 is N + 1, iter4(S,N2)).
run4 :- generator((eat(X),iter4(X,X)),F),pr4(F).
......
......@@ -23,8 +23,23 @@
#:export (compile-prolog-string compile-prolog-file
read-prolog-term save-operator-table))
(define *trace* (make-fluid #f))
(define (trace-fkn l)
(match l
((f a b c . l)
(pk 'trace (cons f l)))
(l
(pk 'trace l))))
(define (mktr f xx)
(lambda x
(if (fluid-ref *trace*) (apply trace-fkn f x))
(apply xx x)))
(define-syntax-rule (define-or-set! f x)
(let ((xx x))
(let* ((xx x)
(xx (mktr 'f xx)))
(if (module-locally-bound? (current-module) 'f)
(set! f xx)
(define! 'f xx))
......@@ -222,6 +237,7 @@
#`(<var> #,(map (lambda (x) (datum->syntax stx x)) var)
#,((get-rhs stx) rhs))))
(define (gen-fkn stx)
(lambda (com)
(match com
......@@ -240,7 +256,9 @@
(f (datum->syntax stx f)))
#'(define-or-set! f
(<<case-lambda>>
((lhs ... (<var> (v ...) rhs)) ...)
((lhs ...
(<var> (v ...)
rhs)) ...)
...))))))))
(define (union v1 v2)
......
......@@ -422,7 +422,7 @@
((not (prolog-output-stream? s))
(permission_error output stream ss))
(else
(<format> s "~%")))))
(<format> s "~%") <cc>))))
(()
(nl (fluid-ref *current-output*)))))
......@@ -494,7 +494,7 @@
((s t opts)
(<let*> ((ss (<lookup> s))
(s (stream-alias-lookup ss)))
(cond
(cond
((<var?> s)
(instantiation_error))
((not (prolog-stream-alias? s))
......@@ -512,14 +512,14 @@
(i #t)
(n #f))
(<recur> lp ((opts opts))
(<match> (#:mode + #:name write_term_opts) (opts)
(<match> (#:mode - #:name write_term_opts) (opts)
((opt . opts)
(<let> ((opt (<lookup> opt)))
(cond
((<var?> opt)
(instantiation_error))
(else
(<match> (#:mode + #:name write_term_opt) (opt)
(<match> (#:mode - #:name write_term_opt) (opt)
(#((,quoted ,true))
(<code> (set! q #t)))
(#((,quoted ,false))
......@@ -532,11 +532,11 @@
(<code> (set! n #f)))
(#((,numbervars ,true))
(<code> (set! n #t)))
(else
(_
(domain_error write_option opt)))))
(lp opts)))
(()
(<code> (format s "~a" (scm->pl S t q i n))))
(<cut> (<code> (format s "~a" (scm->pl S t q i n)))))
(_
(instantiation_error)))))))))
((t opts)
......@@ -550,7 +550,7 @@
(write_term stream term '()))))
(define qt (list (vector (list quoted true)) (vector (list numbervars true))))
(define write_quoted
(define writeq
(<case-lambda>
((s t)
(write_term s t qt))
......@@ -606,14 +606,14 @@
(else
(<var> (vars varnames singletons)
(<recur> lp ((opt opts))
(<match> (#:mode + #:name read_term_opts) (opts)
(<match> (#:mode - #:name read_term_opts) (opts)
((opt . opts)
(<let> ((opt (<lookup> opt)))
(cond
((<var?> opt)
(instantiation_error))
(else
(<match> (#:mode + #:name read_term_opt) (opt)
(<match> (#:mode - #:name read_term_opt) (opt)
(#((,variables X))
(<=> X vars))
(#((,variable_names X))
......@@ -624,7 +624,7 @@
(domain_error read_option opt)))
(lp opts)))))
(()
(read* s t vars varnames singletons))
(<cut> (read* s t vars varnames singletons)))
(_
(instantiation_error)))))))))
......
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