improved interactive environment with prolog interactive commands

parent 3d3669cc
......@@ -61,6 +61,7 @@ SOURCES = \
logic/guile-log/prolog/functions.scm \
logic/guile-log/prolog/util.scm \
logic/guile-log/prolog/conversion.scm \
logic/guile-log/prolog/closed.scm \
logic/guile-log/iso-prolog.scm \
logic/guile-log/guile-prolog/continuations.scm \
logic/guile-log/guile-prolog/hash.scm \
......
......@@ -77,6 +77,8 @@
prolog-closure-parent
prolog-closure-state
prolog-closure-closed?
setup-closed
))
;; Tos silence the compiler, those are fetched from the .so file
......@@ -173,7 +175,7 @@
;; `vlist-cons' call is inefficient. However, Bagwell's hack to avoid it
;; (Section 2.2) would require GC_ALL_INTERIOR_POINTERS, which would be a
;; performance hit for everyone.
(make-prolog-closure closure parent state)
(make-prolog-closure closure parent state closed?)
prolog-closure?
(closure prolog-closure-closure)
(parent prolog-closure-parent)
......
(define-module (logic guile-log guile-prolog interpreter)
#:use-module ((logic guile-log) #:select
(<clear> <define> <let> <let*> <=> <lookup> <match> <fail>
<cut>))
<cut> <wrap>))
#:use-module (logic guile-log guile-prolog hash)
#:use-module (logic guile-log guile-prolog fluid)
#:use-module (ice-9 match)
......@@ -10,17 +10,13 @@
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log prolog closed)
#:use-module (logic guile-log dynamic-features)
#:use-module (logic guile-log guile-prolog dynamic-features)
#:export (prolog-shell conversation leave read-prolog))
(define p (lambda x x))
(define cc (lambda x x))
(define s (fluid-ref *current-stack*))
(define -all- (make-fluid false))
(add-fluid-dynamics s p cc -all-)
(<wrap> add-fluid-dynamics -all-)
(define conversation1 #t)
(define conversation2 #t)
......@@ -58,10 +54,14 @@
-n-))
(define (read-prolog port env)
(define all? #f)
(define fail? #f)
(define n? #f)
(define help? #f)
(let* ((l
(with-input-from-port port
(lambda ()
(let lp ((first? #t) (ch (peek-char)) (r '()))
(let lp ((first? #t) (ch (peek-char)) (r '()))
(when (eof-object? ch)
(set! ch #\.))
(match ch
......@@ -70,6 +70,23 @@
(if first?
(lp first? (peek-char) r)
(lp first? (peek-char) (cons ch r))))
(#\.
(read-char)
(if first?
(let ((action ((@ (guile) read))))
(if (integer? action)
(set! n? action)
(case action
((all *) (set! all? #t))
((once) (set! n? 1))
((help) (set! help? #t))
(else
(set! fail? #t))))
(if fail?
#f
(lp #f (peek-char) '())))
(list->string (reverse (cons #\. r)))))
(#\,
(read-char)
......@@ -84,38 +101,45 @@
(read-char)
(lp #f (peek-char) (cons ch r)))))
(#\.
(read-char)
(list->string (reverse (cons #\. r))))
(_
(read-char)
(lp #f (peek-char) (cons ch r)))))))))
(if (string? l)
(let ((str l))
;(add-history str)
(when (eq? (string-ref str 0) #\,)
(string-set! str 0 #\space)
(set! str (string-append str " "))
(with-input-from-string (string-trim str)
(lambda ()
((@@ (system repl command) meta-command) repl)))
(set! str "do[#f]"))
`(let ((fr ((@ (logic guile-log umatch) gp-newframe)
((@ (guile) fluid-ref)
(@ (logic guile-log umatch) *current-stack*)))))
((@ (guile) dynamic-wind)
((@ (guile) lambda) () #f)
((@ (guile) lambda) ()
((@@ (logic guile-log iso-prolog) prolog-run) 1 ()
((@@ (logic guile-log guile-prolog interpreter)
conversation1)
,str)))
((@ (guile) lambda) ()
((@ (logic guile-log umatch) gp-unwind) fr)))
(if #f #f)))
l)))
(cond
(fail?
'(begin
((@ (guile) format) #t "wrong-input of '.' action ~%")
(if #f #f)))
((string? l)
(let ((str l))
(when (eq? (string-ref str 0) #\,)
(string-set! str 0 #\space)
(set! str (string-append str " "))
(with-input-from-string (string-trim str)
(lambda ()
((@@ (system repl command) meta-command) repl)))
(set! str "do[#f]"))
`(let ((fr ((@ (logic guile-log umatch) gp-newframe)
((@ (guile) fluid-ref)
(@ (logic guile-log umatch) *current-stack*)))))
((@ (guile) dynamic-wind)
((@ (guile) lambda) () #f)
((@ (guile) lambda) ()
((@@ (logic guile-log iso-prolog) prolog-run) 1 ()
((@@ (logic guile-log guile-prolog interpreter)
conversation1)
,str ,((@ (guile) cond)
(all? '(@ (logic guile-log iso-prolog) true))
(n? n?)
(else
'(@ (logic guile-log iso-prolog) false))))))
((@ (guile) lambda) ()
((@ (logic guile-log umatch) gp-unwind) fr)))
(if #f #f))))
(else
l))))
(<define> (readline_term T O)
(<let*> ((n (fluid-ref -n-))
......@@ -137,6 +161,9 @@
(#(XL) #(YL) (<cut> (vtosym XL YL I H)))
(_ _ (<cut> <fail>))))
(define -nsol- (make-fluid false))
(<wrap> add-fluid-dynamics -nsol-)
(compile-prolog-string
"
leave :- throw(leave).
......@@ -151,7 +178,7 @@ conversation :-
).
conversation__ :-
_=scm[(fluid-set! -n- (+ (fluid-ref -n-) 1))],
do[(fluid-set! -n- (+ (fluid-ref -n-) 1))],
conversation_.
conversation_ :-
......@@ -160,26 +187,27 @@ conversation_ :-
(
scm[-all-],
(
_ = scm[ (fluid-set! -all- false) ],
do[ (fluid-set! -all- false) ],
nl,read_term(T,[variables(V),variable_names(N)]),
consult(T,V,N)
consult(T,V,N,false)
)
)
) ; conversation_.
conversation1(X) :-
conversation1(X,All) :-
with_fluid_guard_dynamic_object
(
scm[-n-],
conversation2(X)
scm[-n-],scm[-nsol-],
conversation2(X,All)
).
conversation2(X) :-
_=scm[(fluid-set! -n- (+ (fluid-ref -n-) 1))],
conversation2(X,All) :-
do[(fluid-set! -n- (+ (fluid-ref -n-) 1))],
readline_term_str(X,T,[variables(V),variable_names(N)]),
consult(T,V,N).
consult(T,V,N,All).
consult(X,V,N) :-
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,
fail).
......@@ -207,7 +235,7 @@ hash_new(X,Y,H,I) :-
vhashq_cons(H,X,Y).
output_and_more(V,N) :-
(V==[] -> write('yes') ; once(vtosym(V,VV)),write_out(VV,N)),more.
(V==[] -> write('yes') ; (once(vtosym(V,VV)),write_out(VV,N),nl)), more.
write_out([],[]).
write_out([V|Vs],[N|Ns])
......@@ -215,13 +243,22 @@ write_out([V|Vs],[N|Ns])
write_out(Vs,Ns).
more :-
scm[(fluid-ref -all-)] == true -> fail ;
nl,readline('more (y/n/a) > ',Ans),
scm[(fluid-ref -all-)] == true -> fail ;
(
Ans == 'y' -> fail ;
Ans == 'n' -> throw(finish) ;
Ans == 'a' -> scm[(fluid-set! -all- true)]==1 ;
write(' wrong input'),more
N=scm[(fluid-ref -nsol-)],
(
N == true -> fail ;
integer(N) -> (N > 1 -> (do[(fluid-set! -nsol- (- (<lookup> N) 1))],
fail)
; throw(finish)) ;
readline('more (y/n/a) > ',Ans),
(
Ans == 'y' -> fail ;
Ans == 'n' -> throw(finish) ;
Ans == 'a' -> scm[(fluid-set! -all- true)]==1 ;
write(' wrong input'),more
)
)
).
empty :- peek_char(X),char_code(X,Code),Code==10->get_char(_);true.
......
......@@ -13,6 +13,7 @@
#:use-module (logic guile-log prolog char-conversion)
#:use-module (logic guile-log prolog conversion)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log prolog closed)
#:export (reset-flags reset-prolog)
#:re-export (;; Scheme functions
compile-prolog-string compile-prolog-file
......
......@@ -31,10 +31,13 @@
define-guile-log-parser-tool
<newframe> <unwind>
<define-guile-log-rule>
<get-fixed> <cp> <lookup>
<get-fixed> <cp> <lookup> <wrap>
))
(define (<wrap> f . l)
(apply f (fluid-ref *current-stack*) (lambda x #f) (lambda x #t) l))
(re-export define-and-log
define-guile-log guile-log-macro? log-code-macro log-code-macro?)
......
......@@ -89,7 +89,7 @@
(define (add-lambda x)
(fluid-set! lambdas (cons x (fluid-ref lambdas))))
(define* (compile stx l #:optional (name #f) (lam? #f))
(define* (compile stx l #:optional (name #f) (lam? #f) (closed? #f))
(define (less x y)
(match (pp 'less-x x)
((#:translated n x)
......@@ -286,7 +286,6 @@
(vstx (map (lambda (x)
(datum->syntax stx x))
vs)))
(pk 'lam)
(add-lambda (list name
vs
(pp 'closure
......@@ -298,7 +297,7 @@
#,@evl
(make-prolog-closure
#,nm parent
(list #,@vstx))))))
(list #,@vstx) #,closed?)))))
parent))))
(pp 'res #`(let () #,@ini (#,nm #,@vstx))))
(with-syntax (((lam-def ...)
......@@ -507,14 +506,13 @@
(compile #'n
(prolog-parse #'n (syntax->datum #'str)))))))
(define (re-compile stx str nm)
(define (re-compile stx str nm closed?)
(let ((str (string-trim-right str)))
(when (not (eq? (string-ref str (- (string-length str) 1)) #\.))
(set! str (string-append str ".")))
(pk str)
(compile stx
(prolog-parse stx str)
nm #t)))
nm #t closed?)))
(set! (@@ (logic guile-log prolog var) compile-lambda) re-compile)
(define-syntax compile-prolog-file
......
(define-module (logic guile-log prolog closed)
#:use-module ((logic guile-log code-load) #:select (setup-closed))
#:use-module (logic guile-log)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log dynamic-features)
#:export(closed_closure error_at_closed_p_handle close_error_true close_error_false))
(mk-sym closed_closure)
(define (err x y) (<wrap> permission_error closed_closure "=" (list x y)))
(define error-when-closed? #f)
(if #t
(begin
(set! error-when-closed? (setup-closed err))
(<wrap> add-fluid-dynamics error-when-closed?)))
(<define> (error_at_closed_p_handle x) (<=> x ,error-when-closed?))
(<define> (close_error_true) (<code> (fluid-set! error-when-closed? #t)))
(<define> (close_error_false) (<code> (fluid-set! error-when-closed? #f)))
\ No newline at end of file
......@@ -398,12 +398,19 @@
(<or> (.. (atom c0))
(<p-cc> #f)))
(.. (c2) (l c1))
(.. (c3) (e c2))
(xx (cl) (<or>
(<and>
(.. (a) (l c2))
(<p-cc> #t))
(<p-cc> #f)))
(.. (c3) (e cl))
(.. (c4) (r c3))
(.. (c5) (ws c4))
(xx (c5) (if cl
(.. (r c4))
(<p-cc> #f)))
(if (eq? c2 c3)
(<p-cc> `(#:lam-term ,c1 () ,n ,m))
(<p-cc> `(#:lam-term ,c1 ,(<scm> c3) ,n ,m)))))
(<p-cc> `(#:lam-term ,c1 () ,cl ,n ,m))
(<p-cc> `(#:lam-term ,c1 ,(<scm> c3) ,cl ,n ,m)))))
mk-id)))
(define termvar-tok
......
......@@ -47,8 +47,8 @@
((#:scm-term (#:atom s . _) l _ _)
(mk-scheme stx s l #t))
((#:lam-term (or (#:atom s . _) (and #f s)) l _ _)
#`(unquote #,(compile-lambda stx l s)))
((#:lam-term (or (#:atom s . _) (and #f s)) l closed? _ _)
#`(unquote #,(compile-lambda stx l s closed?)))
((#:term (and atom (#:atom f . _)) () #f . _)
(add-sym atom)
......@@ -169,8 +169,8 @@
((#:list v . _) (get-c fget v))
((#:scm-term (#:atom s . _) l _ _)
(mk-scheme stx s l #t))
((#:lam-term (or (#:atom s . _) (and #f s)) l _ _)
#`(unquote #,(compile-lambda stx l s)))
((#:lam-term (or (#:atom s . _) (and #f s)) l closed? _ _)
#`(unquote #,(compile-lambda stx l s closed?)))
((#:term (and atom (#:atom f . _)) () #f . _)
(add-sym atom)
......@@ -270,8 +270,8 @@
((#:scm-term (#:atom s . _) l _ _)
(mk-scheme stx s l #f))
((#:lam-term (or (#:atom s . _) (and #f s)) l _ _)
(compile-lambda stx l s))
((#:lam-term (or (#:atom s . _) (and #f s)) l closed? _ _)
(compile-lambda stx l s closed?))
((#:term (and atom (#:atom f . _)) () #f . _)
(add-sym atom)
......@@ -383,8 +383,8 @@
((#:scm-term (#:atom s . _) l _ _)
(mk-scheme stx s l #t))
((#:lam-term (or (#:atom s . _) (and #f s)) l _ _)
#`(unquote #,(compile-lambda stx l s)))
((#:lam-term (or (#:atom s . _) (and #f s)) l closed? _ _)
#`(unquote #,(compile-lambda stx l s closed?)))
((#:term (and atom (#:atom f . _)) () #f . _)
......
......@@ -4,7 +4,7 @@
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
scm version 3 of the License, or (at your option) any later version.
version 3 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
......@@ -891,6 +891,17 @@ SCM_DEFINE(gp_set_closure_struct,"set-closure-struct!",1,0,0,(SCM scm),
}
#undef FUNC_NAME
SCM closed_error_fkn = SCM_BOOL_F;
SCM throw_closed_p;
SCM_DEFINE(gp_setup_closed, "setup-closed",1,0,0,(SCM err),
"err is the error function called when unifying closures, returns a fluid that controls the throwing of error or not")
#define FUNC_NAME s_setup_closed
{
closed_error_fkn = err;
return throw_closed_p;
}
#undef FUNC_NAME
static int gp_recurent(SCM *id1,SCM *id2, SCM *l)
{
......@@ -1439,7 +1450,17 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
U_NEXT;
}
else
return (SCM) 0;
{
if(scm_is_true(GP_UNREF(bits1[3])) ||
scm_is_true(GP_UNREF(bits2[3])))
{
if(scm_is_true(scm_fluid_ref(throw_closed_p)))
{
scm_call_2(closed_error_fkn, scm1, scm2);
}
}
return (SCM) 0;
}
}
else
return (SCM) 0;
......@@ -2734,6 +2755,8 @@ void gp_init()
#include "unify.x"
/* stack initializations */
throw_closed_p = scm_make_fluid_with_default(SCM_BOOL_F);
gp_unbound_str = scm_from_locale_string ("<gp>");
gp_save_mark_sym = scm_from_latin1_symbol("mark");
gp_unbound_sym = scm_string_to_symbol (gp_unbound_str);
......
......@@ -32,6 +32,7 @@
#include "vlist/vlist.h"
#include "indexer/indexer.h"
SCM_API SCM gp_setup_closed(SCM err);
SCM_API SCM gp_set_closure_struct(SCM scm);
SCM_API SCM gp_gp(SCM scm);
......
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