further improvements vm-disj2 compiles with 1 error

parent 5a60e4f1
(define-module (logic guile-log guile-prolog vm-compiler)
#:use-module (logic guile-log)
#:use-module (ice-9 pretty-print)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log guile-prolog hash)
#:use-module (logic guile-log guile-prolog ops)
......@@ -10,7 +11,7 @@
#:use-module (logic guile-log guile-prolog vm vm-var)
#:use-module (logic guile-log guile-prolog vm vm-goal)
#:use-module (logic guile-log prolog compile)
#:use-module ((logic guile-log umatch) #:select (gp-var!))
#:use-module ((logic guile-log umatch) #:select (gp-var! *current-stack*))
#:use-module (system vm assembler)
#:re-export (compile_goal begin_att end_att cc)
#:export (compilable_scm
......@@ -151,6 +152,7 @@ variables is the most difficult part to maintain
(format #t "~a ~a~%" x y)
y)
(define pack-start (@@ (logic guile-log code-load) pack-start))
(define (name-it x) (set-procedure-property! x 'name 'anonymous) x)
(<define> (compile_to_fkn code f)
......@@ -332,17 +334,24 @@ generate_stx(STX,X,F) :-
(list
(car o)
#,(let ((comp
(prolog-run-rewind
1 (meta)
(compile_to_meta source? all meta))))
(if (pk 'pair (pair? comp))
#`(lambda ()
(let ((f #,(car comp)))
(lambda (s p cc cut scut x)
(apply f s p cc cut scut x))))
(begin
(warn "failed compiling")
(lambda () (error "misscompiled")))))
(with-fluids ((*current-stack* s))
(prolog-run-rewind
1 (meta)
(compile_to_meta source? all meta)))))
((@ (guile) catch) #t
(lambda ()
(if (pair? comp)
#`(lambda ()
(let ((f #,(car comp)))
(lambda (s p cc cut scut x)
(apply f s p cc cut scut x))))
(begin
(warn "failed compiling")
#'(lambda () (error "misscompiled")))))
(lambda a
(pk a)
(warn "failed compiling")
#'(lambda () (error "misscompiled")))))
(cadr o)))
(let ((comp
(prolog-run-rewind
......
......@@ -628,7 +628,7 @@ code([push2,V2,V3],Code,Action) :-
)
).
code([push2,V2,V3],Code,Action) :-
code([push2,V1,V2],Code,Action) :-
(V1=[V1C|_] -> A1=1 ; (V1=V1C, A1=0)),
(V2=[V2C|_] -> A2=1 ; (V2=V2C, A2=0)),
A is A1 + A2 << 1,
......
......@@ -10,8 +10,7 @@
#:replace (tr)
#:export ())
(define unify_operators '((";" ";") ("," ",") ("\\+" "\\+")
("+" "+") ("*" "*") ("-" "-")))
(define unify_operators '())
(define *recurs* (make-fluid vlist-null))
(define *tag* (make-fluid 0))
(define *varn* (make-fluid 4))
......@@ -310,6 +309,8 @@ t(X,_) :-
print_error_if_fail.
bin(X,X) :- b_getval(pretty,#t),!.
bin1(min,min2_1).
bin1(max,max2_1).
bin1(+,plus2_1).
bin1(-,minus2_1).
bin1(*,mul2_1).
......@@ -350,6 +351,8 @@ binxx(=< ,'xx-le').
binxx(=:= ,'xx-e' ).
binxx(=\\= ,'xx-ne').
binss2_(min,'ss-min-s').
binss2_(max,'ss-max-s').
binss2_(+,'ss-add-s').
binss2_(-,'ss-sub-s').
binss2_(*,'ss-mul-s').
......@@ -364,6 +367,8 @@ binss2_(xor,'ss-xor-s').
binss2_(^,'ss-pow-s').
binss2_(**,'ss-pow-s').
binxx2_(min,'xx-min-x').
binxx2_(max,'xx-max-x').
binxx2_(+,'xx-add-x').
binxx2_(-,'xx-sub-x').
binxx2_(*,'xx-mul-x').
......@@ -378,6 +383,8 @@ binxx2_(xor,'xx-xor-x').
binxx2_(^,'xx-pow-x').
binxx2_(**,'xx-pow-x').
binxxu2_(min,'xx-umin-x').
binxxu2_(max,'xx-umax-x').
binxxu2_(+,'xx-uadd-x').
binxxu2_(-,'xx-usub-x').
binxxu2_(*,'xx-umul-x').
......
......@@ -25,7 +25,8 @@ compile_scm(X,V,L,LL) :-
instruction(X) -> (!,tr('push-instruction',Atomic), L=[[Atomic,X]|LL],
E=X,push_v(1,V)).
compile_scm((Op,(+ ; - ; * ; / ; << ; >> ; \\/ ; /\\ ; mod))(X,Y),V,L,LL) :- !,
compile_scm((Op,(max ; min ; + ; - ; * ; / ; << ; >> ; \\/ ; /\\ ; mod))
(X,Y),V,L,LL) :- !,
ifc(compile_scm(X,V,L,LX),EX,
(
(number(EX) -> true ; throw(EY)),
......
......@@ -578,14 +578,22 @@
(compile-var match-map-i x))
a))))
(else
(list (G vector) (cons* (G list)
(if (procedure? f)
(get-fkn f)
(get-var f))
(map* (lambda (x)
(compile-var match-map-i x))
a))))))))
((a . l)
(let* ((l (map* (lambda (x)
(compile-var match-map-i x))
a))
(l (let lp ((l l) (r '()))
(if (pair? l)
(lp (cdr l) (cons (car l) r))
(if (null? l)
(reverse (cons (list (G quote) '()) r))
(reverse (cons l r)))))))
(list (G vector) (cons* (G cons*)
(if (procedure? f)
(get-fkn f)
(get-var f))
l))))))))
((a . l)
(do x
(list (G cons) (compile-var match-map-i a)
(map-cons match-map-i l))))
......
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