An prolog interpreter

parent 6ac62b5c
......@@ -66,7 +66,9 @@ SOURCES = \
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/interpreter.scm
logic/guile-log/guile-prolog/readline.scm \
logic/guile-log/guile-prolog/interpreter.scm \
language/prolog/spec.scm
AM_MAKEINFOFLAGS=--force
AM_MAKEINFOHTMLFLAGS=--force
......
(define-module (language prolog spec)
#:use-module (system base language)
#:use-module (logic guile-log guile-prolog readline)
#:use-module (logic guile-log iso-prolog)
#:use-module (language scheme compile-tree-il)
#:use-module (logic guile-log guile-prolog interpreter)
#:export (prolog))
;;;
;;; Language definition
;;;
(define-language prolog
#:title "Prolog"
#:reader read-prolog
#:compilers `((tree-il . ,compile-tree-il))
#:evaluator (lambda (x module) (eval x module))
#:printer write)
......@@ -87,7 +87,7 @@ used it is then a safe journey.
(if (tp? h)
(begin
(hash-set! *dynamic-trackers* h
(vector tp dref dset d++ dtrunc bt rd))
(vector tp dref dset d++ dtrunc mk bt rd))
(cc s p))
(fail s p cc h tp)))
......
(define-module (logic guile-log guile-prolog interpreter)
#:use-module ((logic guile-log) #:select
(<clear> <define> <let> <let*> <=>))
#:use-module (ice-9 match)
#:use-module (ice-9 readline)
#:use-module (ice-9 rdelim)
#: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))
#:export (prolog-shell conversation leave read-prolog))
(define p (lambda x x))
(define cc (lambda x x))
......@@ -13,9 +19,9 @@
(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 conversation1 #t)
(define conversation2 #t)
(define loop #f)
(define finish #f)
(define leave #f)
(define solve #t)
......@@ -23,45 +29,151 @@
(define consult #t)
(define conversation #t)
(define conversation_ #t)
(define conversation__ #t)
(define more #t)
(define write_out #t)
(define empty #t)
(mk-sym finish)
(mk-sym leave)
(define (prolog-shell)
((@ (guile) catch) #t
(lambda ()
(<clear>)
(prolog-run 1 () (loop))
(format #t "leaving prolog~%"))
(lambda x
(format #t "System error~%~a~%RESTARTING~%" x)
(prolog-shell))))
(define readline_term* (@ (logic guile-log guile-prolog readline)
readline_term))
(define readline (@ (logic guile-log guile-prolog readline)
readline))
(define -n- (@ (logic guile-log guile-prolog readline)
-n-))
(define (read-prolog port env)
(let* ((l
(with-input-from-port port
(lambda ()
(let lp ((first? #t) (ch (peek-char)) (r '()))
(when (eof-object? ch)
(set! ch #\.))
(match ch
(#\space
(read-char)
(if first?
(lp first? (read-char) r)
(lp first? (read-char) (cons ch r))))
(#\,
(read-char)
(if first?
(cons ch (string->list (read-line)))
(lp #f (peek-char) (cons ch r))))
(#\[
(if first?
((@ (guile) read))
(begin
(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) #\()
(set! str (string-append "do[" 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)))
(<define> (readline_term T O)
(<let*> ((n (fluid-ref -n-))
(pr (if (= n 1) "-? " (format #f "(~a)? " n)))
(cr (let lp ((n (string-length pr)))
(if (= n 1)
" "
(string-append "." (lp (- n 1)))))))
(readline_term* pr cr T O)))
(define (readline_term_str s p cc Str T O)
(with-input-from-string Str
(lambda ()
(let ((S (current-input-port)))
(read_term s p cc S T O)))))
(compile-prolog-string
"
exit :- throw(leave).
leave :- throw(leave).
loop :- catch(conversation,X,(write(X),nl,loop)).
conversation :-
with_fluid_guard_dynamic_object
(
scm[-n-],
(
X=scm[(fluid-set! -n- (+ (fluid-ref -n-) 1))],
catch(conversation_, leave, fail)
)
conversation__
).
conversation__ :-
_=scm[(fluid-set! -n- (+ (fluid-ref -n-) 1))],
conversation_.
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)]),
_ = scm[ (fluid-set! -all- false) ],
nl,read_term(T,[variables(V),variable_names(N)]),
consult(T,V,N)
)
)
) ; conversation_.
conversation1(X) :-
with_fluid_guard_dynamic_object
(
scm[-n-],
conversation2(X)
).
conversation2(X) :-
_=scm[(fluid-set! -n- (+ (fluid-ref -n-) 1))],
readline_term_str(X,T,[variables(V),variable_names(N)]),
consult(T,V,N).
consult(X,V,N) :-
catch(((solve(X),output_and_more(V,N)) ; (nl,write(no),fail)),
catch(((solve(X),output_and_more(V,N)) ; (nl,write(no),nl,fail)),
finish,
fail).
......@@ -75,11 +187,15 @@ write_out([V|Vs],[N|Ns])
more :-
scm[(fluid-ref -all-)] == true -> fail ;
nl,write('more (y/n/a) > '),get_char(Ans),
nl,readline('more (y/n/a) > ',Ans),
(
Ans == 'y' -> fail ;
Ans == 'n' -> throw(finish) ;
Ans == 'a' -> scm[(fluid-set! -all- #t)]==1 ;
write(' wrong input'),more.
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.
solve(X) :- X.
")
(define-module (logic guile-log guile-prolog readline)
#:use-module (logic guile-log)
#:use-module ((logic guile-log umatch) #:select (*current-stack*))
#:use-module (ice-9 match)
#: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-))
(define p (lambda x x))
(define cc (lambda x x))
(define s (fluid-ref *current-stack*))
(define -n- (make-fluid 0))
(add-fluid-dynamics s p cc -n-)
(define readline_
(if (provided? 'readline)
(@ (ice-9 readline) readline)
(lambda (pr)
(format #t "~a" pr)
(read-line))))
(define add-history
(if (provided? 'readline)
(@ (ice-9 readline) add-history)
(lambda (pr) pr)))
(define repl ((@@ (system repl repl) make-repl) 'scheme #f))
(<define> (readline pr t) (<=> t ,(readline_ pr)))
(<define> (readline_term pr cr T O)
(<let*> ((l (let lp ((txt (readline_ pr)) (r '()))
(let lp2 ((l (string->list txt)) (rr '()))
(match l
((#\. . l)
(reverse ((@ (guile) append) (cons #\. rr) r)))
((x . l)
(lp2 l (cons x rr)))
(()
(lp (readline_ cr) ((@ (guile) append) rr r)))))))
(str (let ((str (string-trim (list->string l))))
(add-history str)
(when (eq? (string-ref str 0) #\()
(set! str (string-append "do[" str "]")))
(when (eq? (string-ref str 0) #\,)
(string-set! str 0 #\space)
(string-set! str (- (string-length str) 1) #\space)
(with-input-from-string (string-trim str)
(lambda ()
((@@ (system repl command) meta-command) repl)))
(set! str "do[#f]"))
str))
(p (open-input-string str)))
(read_term p T O)))
(<define> (read_yes ch) (<let> ((x (readline_ "more (y/n/a) > "))) (<=> x ch)))
......@@ -493,10 +493,10 @@
(let ((x (car vl)))
(if (hash-ref s x)
(begin
(hash-set! s x #f)
(hash-set! s x 1)
(lp (cdr vl) r))
(begin
(hash-set! s x #t)
(hash-set! s x 0)
(lp (cdr vl) (cons x r)))))
(reverse! r))))
(ws (let lp ((vs vs))
......@@ -518,7 +518,7 @@
(syntax->datum r))))
module)
w) (reverse! w) wl ws))
w) w wl ws))
end_of_file))))))
(define (add-non-defined l)
......
......@@ -310,19 +310,17 @@
(let* ((sym (eval-string (string-append "'" l)))
(lam (if unq? (lambda (x) #`(unquote #,x)) (lambda (x) x)))
(w (datum->syntax stx sym))
(v #`(vector
(list eval-scheme
(lambda () #,w)))))
(v #`(lambda () #,w)))
(case s
((do)
(lam #`(do-eval-scheme #,v)))
(lam #`(vector (list do-eval-scheme #,v))))
((when)
(lam #`(when-eval-scheme #,v)))
(lam #`(vector (list when-eval-scheme #,v))))
((v var)
(fluid-set! v-variables (cons sym (fluid-ref v-variables)))
(lam w))
((s scm)
(lam v)))))
(lam w)))))
(define (mk-var x_x goal?)
......
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