initial interpreter support

parent 544e1b73
......@@ -65,7 +65,8 @@ SOURCES = \
logic/guile-log/guile-prolog/hash.scm \
logic/guile-log/guile-prolog/dynamic-features.scm \
logic/guile-log/guile-prolog/interleave.scm \
logic/guile-log/guile-prolog/zip.scm
logic/guile-log/guile-prolog/zip.scm \
logic/guile-log/guile-prolog/interpreter.scm
AM_MAKEINFOFLAGS=--force
AM_MAKEINFOHTMLFLAGS=--force
......
......@@ -71,7 +71,7 @@ used it is then a safe journey.
(define ibt 6)
(define itr 7)
(define (get d i) (vector-ref d i))
(define (get d i) (vector-ref d i))
(define (set d i b) (vector-set! d i b))
(define (params->id x) (x params->id))
......@@ -178,7 +178,7 @@ used it is then a safe journey.
bt
(let* ((aset (get api iset))
(++ (get api i++))
(tr (get api truncate))
(tr (get api itrunc))
(bt (case-lambda
(()
(let ((ret (ref h)))
......
(define-module (logic guile-log prolog dynamic-features)
(define-module (logic guile-log guile-prolog dynamic-features)
#:use-module (logic guile-log)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log dynamic-features)
......
(define-module (logic guile-log guile-prolog interpreter)
#: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 dynamic-features)
#:use-module (logic guile-log guile-prolog dynamic-features)
#:export (conversation exit))
(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-)
(define -n- (make-fluid 0))
(add-fluid-dynamics s p cc -n-)
(define finish #f)
(define leave #f)
(define solve #t)
(define output_and_more #t)
(define consult #t)
(define conversation #t)
(define conversation_ #t)
(define more #t)
(define write_out #t)
(mk-sym finish)
(mk-sym leave)
(compile-prolog-string
"
exit :- throw(leave).
conversation :-
with_fluid_guard_dynamic_object
(
scm[-n-],
(
X=scm[(fluid-set! -n- (+ (fluid-ref -n-) 1))],
catch(conversation_, leave, fail)
)
).
conversation_ :-
(
nl,
X = scm[(fluid-ref -n-)],
(X == 1 -> write('-? ') ; (write('('),write(X),write(')-? '))),
with_fluid_guard_dynamic_object
(
scm[-all-],
(
Y = scm[ (fluid-set! -all- false) ],
read_term(T,[variables(V),variable_names(N)]),
consult(T,V,N)
)
)
) ; conversation_.
consult(X,V,N) :-
catch(((solve(X),output_and_more(V,N)) ; (nl,write(no),fail)),
finish,
fail).
output_and_more(V,N) :-
(V==[] -> write('yes') ; write_out(V,N)),more.
write_out([],[]).
write_out([V|Vs],[N|Ns])
:- nl,write(' '),write(N),write(' = '),write(V),
write_out(Vs,Ns).
more :-
scm[(fluid-ref -all-)] == true -> fail ;
nl,write('more (y/n/a) > '),get_char(Ans),
Ans == 'y' -> fail ;
Ans == 'n' -> throw(finish) ;
Ans == 'a' -> scm[(fluid-set! -all- #t)]==1 ;
write(' wrong input'),more.
solve(X) :- X.
")
......@@ -38,12 +38,13 @@
(apply xx x)))
(define-syntax-rule (define-or-set! f x)
(let* ((xx x)
(xx (mktr 'f xx)))
(letrec ((xx x)
(f (mktr 'f xx)))
(if (module-locally-bound? (current-module) 'f)
(set! f xx)
(define! 'f xx))
(set-procedure-property! xx 'name 'f)))
(module-set! (current-module) 'f f)
(define! 'f f))
(set-procedure-property! f 'module (module-name (current-module)))
(set-procedure-property! f 'name 'f)))
(define do-print #f)
......@@ -413,13 +414,17 @@
r))
vs))
(s (make-hash-table))
(wl (map (lambda (x)
(if (hash-ref s x)
(hash-set! s x #f)
(begin
(hash-set! s x #t)
(hash-ref h x))))
vl))
(wl (let lp ((vl vl) (r '()))
(if (pair? vl)
(let ((x (car vl)))
(if (hash-ref s x)
(begin
(hash-set! s x #f)
(lp (cdr vl) r))
(begin
(hash-set! s x #t)
(lp (cdr vl) (cons x r)))))
(reverse! r))))
(ws (let lp ((vs vs))
(if (pair? vs)
(let ((x (car vs)))
......@@ -439,7 +444,7 @@
(syntax->datum r))))
module)
w) w wl ws))
w) (reverse! w) wl ws))
end_of_file))))))
(define (add-non-defined l)
......@@ -453,7 +458,8 @@
(let ((f (make-unbound-fkn x)))
;(format #t "Defined non defined variable ~a~%" x)
(module-define! mod x f)
(set-procedure-property! f 'name x))))
(set-procedure-property! f 'module (module-name mod))
(set-procedure-property! f 'name x))))
(lp l))
(() #t)))))
......
......@@ -295,10 +295,11 @@
(<cut>
(<=> m ,(if props
(cdr (assq #:mode props))
(case (port-mode s)
(("w") output)
(("r") input)
(("a") append))))))
(let ((q (port-mode s)))
(cond
((equal? q "w") output)
((equal? q "r") input)
((equal? q "a") append)))))))
(#((,type t))
(<cut>
......@@ -459,7 +460,8 @@
(format #f "'~a'(~a~{, ~a~})"
op
(lp a) (map lp (gp->scm l s)))
(let ((ll (map (lambda (x) (format #f "'~a'" x)) (get-attached-module f ns?))))
(let ((ll (map (lambda (x) (format #f "'~a'" x))
(get-attached-module f ns?))))
(if (pair? ll)
(format #f "~a@@(~a~{, ~a~})(~a~{, ~a~})"
(procedure-name f) (car ll) (cdr ll)
......@@ -470,9 +472,11 @@
(#((f))
(if (string? f)
(format #f "'~a'" f)
(let ((ll (map (lambda (x) (format #f "'~a'" x)) (get-attached-module f ns?))))
(let ((ll (map (lambda (x) (format #f "'~a'" x))
(get-attached-module f ns?))))
(if (pair? ll)
(format #f "~a@@(~a~{, ~a~})" (procedure-name f) (car ll) (cdr ll))
(format #f "~a@@(~a~{, ~a~})"
(procedure-name f) (car ll) (cdr ll))
(format #f "~a" (procedure-name f))))))
......@@ -501,9 +505,11 @@
(hashq-set! *variables* a n)
n))))
((procedure? a)
(let ((ll (map (lambda (x) (format #f "'~a'" x)) (get-attached-module a ns?))))
(let ((ll (map (lambda (x) (format #f "'~a'" x))
(get-attached-module a ns?))))
(if (pair? ll)
(format #f "~a@@(~a~{, ~a~})" (procedure-name a) (car ll) (cdr ll))
(format #f "~a@@(~a~{, ~a~})"
(procedure-name a) (car ll) (cdr ll))
(format #f "~a" (procedure-name a)))))
(else
(format #f "~a" a)))))))
......
......@@ -160,8 +160,9 @@
f))
(define-syntax-rule (mk-sym a)
(begin
(define a (make-unbound-fkn 'a))
(when (not (module-defined? (current-module) 'a))
(define! 'a (make-unbound-fkn 'a))
(set-procedure-property! a 'module (module-name (current-module)))
(set-procedure-property! a 'name 'a)))
(mk-sym is-a-num?)
......
......@@ -81,7 +81,10 @@
(set-procedure-property! f 'module (module-name mod)))
(define* (get-attached-module f #:optional (not-pretty? #t))
(define (st l) (map symbol->string l))
(if (and (not not-pretty?) (module-ref (current-module) (procedure-name f)))
(if (and (not not-pretty?)
(symbol? (procedure-name f))
(module-defined?
(current-module) (procedure-name f)))
'()
(let ((x (procedure-property f 'module)))
(if 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