compiles inriasuite, but does not evaluate

parent 8a862ea5
......@@ -84,6 +84,7 @@ SOURCES = \
logic/guile-log/guile-prolog/gc-call.scm \
logic/guile-log/guile-prolog/coroutine.scm \
logic/guile-log/guile-prolog/attributator.scm \
logic/guile-log/examples/kanren/type-inference.scm \
language/prolog/spec.scm
AM_MAKEINFOFLAGS=--force
......
......@@ -656,7 +656,7 @@ add/run * vlist *
(define-syntax mk-varpat
(lambda (x)
(syntax-case x ()
((_ y) #``#,(ppp 'parse-list (parse-list #'y))))))
((_ y) #``#,(parse-list #'y)))))
(define-syntax <lambda-dyn>
......
......@@ -72,7 +72,6 @@ run_all_tests :-
test_all(Files),
write_results, !.
test_all([]).
test_all([F|Fs]) :-
run_tests(F),
......@@ -587,7 +586,7 @@ run_tests(File) :-
% the catch is for syntax errors
% (which will be errors in the processor).
%
loop_through(F, S) :-
catch((read(S,X),write([found,X]),nl), B, X = B),
(
......@@ -605,6 +604,7 @@ loop_through(F, S) :-
%
% do the tests. Handles syntax erros in input and end_of_file
%
test(_,end_of_file).
test(F, error(R, _)) :- !,
write('Error in Input: '), write(R), nl,nl,
......@@ -622,6 +622,7 @@ test(F, [G, ProgFile, Expected]) :-
compare_subst_lists(R, Expected, Extra, Missing),
write_if_wrong(F, G, Expected, Extra, Missing),
update_score(F, Missing, Extra).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% write_if_wrong(+File, +Goal, +Expected, +Extra, +Missing)
......
(define-module (logic guile-log iso-prolog inriasuite inriasuite)
(define-module (inriasuite)
#:use-module (logic guile-log iso-prolog)
#:pure
#:re-export (prolog-run)
#:export (run_tests))
#:export (run_tests run_all_tests))
(compile-prolog-file "inriasuite.pl")
(save-operator-table)
(compile-file "inriasuite.pl")
(save-operator-table)
\ No newline at end of file
......@@ -3,6 +3,7 @@
#:use-module (ice-9 match-phd)
#:use-module (logic guile-log guile-log-pre)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log undovar)
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
......
......@@ -45,6 +45,17 @@
(pretty-print (syntax->datum x)))
x)))
(define ppp
(case-lambda
((s x)
(when #t
(pretty-print `(,s ,(syntax->datum x))))
x)
((x)
(when #t
(pretty-print (syntax->datum x)))
x)))
(define-syntax-rule (Ds f) (lambda x (apply f x)))
(define *freeze-map* (make-fluid #f))
......@@ -483,11 +494,14 @@
(lambda ()
(with-fluids ((*freeze-map* (fluid-ref *freeze-map*)))
(clear-tokens)
(<run> 1 (cout)
(<values> (x xl . l)
(matcher '() (make-file-reader) NI MI Init ... _))
(<code> (print-last-line (if xl xl '())))
(<=> cout ,(car (reverse l)))))))
((<lambda> ()
(<values> (x xl . l)
(matcher '() (make-file-reader) NI MI Init ... _))
(<code> (print-last-line (if xl xl '())))
(<cc> (car (reverse l))))
(fluid-ref *current-stack*)
(lambda () #f)
(lambda (s p cc) cc)))))
(if (string? str)
(with-input-from-string str f)
(with-input-from-port str f)))
......@@ -495,11 +509,16 @@
((matcher)
(with-fluids ((*freeze-map* (fluid-ref *freeze-map*)))
(clear-tokens)
(<run> 1 (cout)
(<values> (x xl . l)
(matcher '() (make-file-reader) NI MI Init ... _))
(<code> (print-last-line (if xl xl '())))
(<=> cout ,(car (reverse l))))))))
((<lambda> ()
(<and>
(<values> (x xl . l)
(matcher '() (make-file-reader) NI MI Init ... _))
(<code> (print-last-line (if xl xl '())))
(<cc> (car (reverse l)))))
(fluid-ref *current-stack*)
(lambda () #f)
(lambda (s p cc) cc))))))
(define parse-no-clear
(case-lambda
......
......@@ -30,6 +30,30 @@
trace read-prolog-term save-operator-table
Trace Level trace-level))
(define do-print #f)
(define pp
(case-lambda
((s x)
(when do-print
(pretty-print `(,s ,(syntax->datum x))))
x)
((x)
(when do-print
(pretty-print (syntax->datum x)))
x)))
(define ppp
(case-lambda
((s x)
(when #t
(pretty-print `(,s ,(syntax->datum x))))
x)
((x)
(when #t
(pretty-print (syntax->datum x)))
x)))
(define (goal stx x)
((@ (logic guile-log prolog goal) goal) stx x))
......@@ -89,29 +113,6 @@
(set-procedure-property! xx 'name f)))
(define do-print #f)
(define pp
(case-lambda
((s x)
(when do-print
(pretty-print `(,s ,(syntax->datum x))))
x)
((x)
(when do-print
(pretty-print (syntax->datum x)))
x)))
(define ppp
(case-lambda
((s x)
(when #t
(pretty-print `(,s ,(syntax->datum x))))
x)
((x)
(when #t
(pretty-print (syntax->datum x)))
x)))
(define lambdas (make-fluid '()))
(define functors '())
(define (add-lambda x)
......@@ -191,7 +192,7 @@
1 ,#`(prolog-run
1 () #,(mk-rhs stx
`(#:term (#:atom assertz #f #f ,n ,m)
,(car x) #f ,n ,m))))
,x #f ,n ,m))))
(let ((fu (pp v functors)))
(set! functors '())
(match y
......@@ -208,7 +209,7 @@
1 ,#`(prolog-run
1 () #,(mk-rhs stx
`(#:term (#:atom assertz #f #f ,n ,m)
,(car x) #f ,n ,m))))
,x #f ,n ,m))))
(let ((fu (pp v functors)))
(set! functors '())
(list v '() z fu))))
......@@ -223,7 +224,7 @@
((('xfx _ ":-" _) (((_ _ op _) a _ _)) z _ _)
(if (is-dynamic? (string->symbol op))
(error "dynamic operator not supprted")
(error "dynamic operator not supported")
(let ((fu functors))
(set! functors '())
(list (string->symbol op) (list a) z fu))))
......@@ -285,8 +286,8 @@
(define-syntax-rule (wi x) (if lam? x (with-fluids ((lambdas '())) x)))
(define (mcar x) (if (pair? x) (car x) '()))
(pp 'compile-1 l)
(define (mcar x) (if x x '()))
(ppp 'compile-1 l)
(if l (begin
(clear-syms)
(with-fluids ((v-variables '()))
......@@ -393,7 +394,7 @@
(let* ((syms (get-syms))
(syms (union syms syms)))
(pp 'res #`(begin
(ppp 'res #`(begin
(eval-when (compile load eval)
(add-non-defined
(quote #,(datum->syntax stx syms))))
......
......@@ -41,6 +41,17 @@
(pretty-print (syntax->datum x)))
x)))
(define ppp
(case-lambda
((s x)
(when #t
(pretty-print `(,s ,(syntax->datum x))))
x)
((x)
(when #t
(pretty-print (syntax->datum x)))
x)))
(define do-character-convert #f)
(define (acar x)
......@@ -388,4 +399,4 @@
(set! (@@ (logic guile-log prolog names) is-a-num?) is-a-num?)
(set! (@@ (logic guile-log prolog names) check-num) check-num)
(set! (@@ (logic guile-log prolog names) get-flag ) get-flag)
\ No newline at end of file
(set! (@@ (logic guile-log prolog names) get-flag ) get-flag)
......@@ -203,7 +203,7 @@
(goal-ck 'nm-code (tp 'a) ...))
(set-object-property! nm-func 'goal-compile-stub
(lambda (a ...)
`(,(GT code) ,(GT nm-code) ,a ...)))
`(,(GT nm-tr) ,a ...)))
(set-object-property! nm-func 'goal-compile-types
'(tp ...))
(define-goal-transformer nm-func (nm-tr stx n m a ...)
......
......@@ -210,7 +210,7 @@
((#:group x)
(goal- stx x))
((#:list (or (#:variable x _ _)
((#:list (or (#:variable x _ _ _)
(#:atom x _ _ _ _)
(#:string x _ _)) _ _)
(datum->syntax stx `(load-prolog ,x)))
......
......@@ -13,7 +13,7 @@
#:use-module ((logic guile-log) #:select (<let> <pp> <scm> <code> <let*>
<var> <=> <fail> <match>
<cut> <and> <or> <define>
<cc> <not> <if>
<cc> <not> <if> <values>
(_ . GL:_)))
#:re-export (*prolog-file* get-refstr)
#:export (prolog-parse define-parser-directive add-op rem-op
......@@ -36,6 +36,17 @@
(pretty-print (syntax->datum x)))
x)))
(define ppp
(case-lambda
((s x)
(when #t
(pretty-print `(,s ,(syntax->datum x))))
x)
((x)
(when #t
(pretty-print (syntax->datum x)))
x)))
(eval-when (compile eval load)
(define haserror #f)
(define oldwarn warn)
......@@ -155,13 +166,13 @@
(define opsym
(<p-lambda> (c)
(.. (p) (fop c))
(<match> (#:mode - #:name 'opsym) (p)
(<match> (#:mode - #:name 'opsym) ((ppp 'op p))
((_ _ op _)
(<cut> (<and> (<p-cc> (<scm> op))))))))
(define symbolic-1 (f-not! (f-or! wf-char special rest-var )))
(define symbolic (letrec ((sym* (f-or f-true (f-seq symbolic-1 (Ds sym*)))))
(f-or (mk-token (f-seq symbolic-1 sym*)))))
(define symbolic-1 (f-not! (f-or! wf-char special rest-var)))
(define symbolic (letrec ((sym* (f-or! (f-seq! symbolic-1 (Ds sym*)) f-true)))
(mk-token (f-seq symbolic-1 sym*))))
(define quotes
......@@ -377,14 +388,42 @@
(define symbolic-tok
(<p-lambda> (c)
(.. (c) (ws c))
(<let> ((n N) (m M))
(.. (c) (symbolic c))
(.. (q) (ws c))
(.. (u) (@tag q))
(<p-cc>
(if u
`(#:atom ,(string->symbol c) ,(car u) ,(cadr u) ,n ,m)
`(#:symbolic ,(string->symbol c) ,n ,m))))))
(<let> ((x X) (xl XL) (n N) (m M))
(.. (c1) (symbolic c))
(<let*> ((an N) (am M))
(<or>
(<and>
(<values> (bx bxl bn bm bc) (fop x xl n m c))
(<cut>
(when (or (> am bm) (and (= am bm) (> an bn)))
(.. (q) (ws c1))
(.. (u) (@tag q))
(<p-cc>
(if u
`(#:atom
,(string->symbol c1) ,(car u) ,(cadr u) ,n ,m)
`(#:symbolic ,(string->symbol c1) ,n ,m))))))
(<and>
(.. (q) (ws c1))
(.. (u) (@tag q))
(<p-cc>
(if u
`(#:atom
,(string->symbol c1) ,(car u) ,(cadr u) ,n ,m)
`(#:symbolic ,(string->symbol c1) ,n ,m)))))))))
(define symbolic-tok2
(<p-lambda> (c)
(.. (c) (ws c))
(<let> ((x X) (xl XL) (n N) (m M))
(.. (c1) (symbolic c))
(.. (q) (ws c1))
(.. (u) (@tag q))
(<p-cc>
(if u
`(#:atom
,(string->symbol c1) ,(car u) ,(cadr u) ,n ,m)
`(#:symbolic ,(string->symbol c1) ,n ,m))))))
(define op-tok
(<p-lambda> (c)
......@@ -640,13 +679,15 @@
#;(define tok (f-or! list-e term-tok termvar-tok atom symbolic variable number))
(define tok (f-or! paranthesis keyword
(define tok (f-or! 'token
paranthesis keyword
char list-tok true/false
termvar-tok term-binop-tok termop-tok
termstring-tok term-tok scm-tok lam-tok
number qstring dstring atom variable op-tok))
number qstring dstring atom variable symbolic-tok
#;op-tok))
(define e (mk-operator-expression tok symbolic-tok *prolog-ops*))
(define e (mk-operator-expression tok symbolic-tok2 *prolog-ops*))
(set! expr* (<p-lambda> (c) (.. (e 1200))))
(define (read-1 stx x) x)
......@@ -658,7 +699,7 @@
(define (f-parse-1 stx m)
(<p-lambda> (c)
(.. (d) (m GL:_))
(<p-cc> (cons (pp 'p1 (parse-1 S stx (<scm> d))) c))))
(<p-cc> (cons (pp 'p1 (parse-1 S stx (pp 'man (<scm> d)))) c))))
;; For now we do not do anything here but it is possible to implement
;; parser directions here
......@@ -735,20 +776,20 @@
(define-syntax-rule (retit x ...)
(catch #t
(lambda () x ...)
(lambda y #f)))
(lambda y (pk y) #f)))
(define (prolog-tokens stx)
(let ((f (f* (f-or
(f-seq ws (f-parse-1 stx expr)
ws (f-char #\.) ws)
ferr))))
(let ((f (f* (f-or!
(f-seq ws (f-parse-1 stx expr)
ws (f-char #\.) ws)
ferr))))
(<p-lambda> (c)
(.. (d) (f '()))
(<p-cc> (pp 'token (retit(reverse d)))))))
(<p-cc> (ppp 'token (retit (reverse d)))))))
(define (prolog-read-token stx)
(let ((f (f-or (f-seq ws (f-read-1 stx expr)
(let ((f (f-or 'statement (f-seq ws (f-read-1 stx expr)
ws (f-char #\.))
ferr)))
(<p-lambda> (c)
......
......@@ -239,6 +239,7 @@
(<continue>))))
(equal? a b)))
(define (//-test-2)
(<run> 100 (x y)
(<with-generators> ((i 0))
......@@ -465,7 +466,6 @@
(//-test-3))
(pass-if "fold-test-3"
(//-test-3))
(pass-if "postpone-test-1"
(postpone-test-1))
(pass-if "postpone-test-2"
......
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