extended matching now genereates good looking code

parent 45a045e8
......@@ -2,45 +2,78 @@
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log)
#:replace (extended)
#:export (*extended* extended_macro))
#:export (*extended*
*extended-body*
extended_macro
extended_body
all_extended
all_extended_body))
(<define> (extended . l)
(<code> (error "extended is no good function")))
(define *extended* #f)
(<define> (set_extended L)
(<pp> `(set_extended ,L))
(<code> (set! *extended* (<scm> L))))
(<define> (set_extended L B)
(<pp> `(set_extended ,L ,B))
(<code> (set! *extended* (<scm> L)))
(<code> (set! *extended-body* (<scm> B))))
(compile-prolog-string "
:- dynamic([register/2,register_f/2]).
on(L) :-
register(X,L) -> X=on.
on(L,Body) :-
register(X,L,Body) -> X=on.
add_f(F) :-
(
(
on(L) ->
(
asserta(register(off,L)),
asserta(register_f(F,L))
on(L,Body) ->
(
asserta(register(off,L,Body)),
asserta(register_f(F,L,Body))
) ;
register_f(F,L)
register_f(F,L,Body)
) ->
set_extended(L) ;
set_extended(#f)
set_extended(L,Body) ;
set_extended(#f,#f)
).
extended_macro(\"op2-\"(extended(|L)),[]) :-
write(F(|L)),nl,
asserta(register(on,L)).
write(extended(|L)),nl,
asserta(register(on,L,#f)).
extended_macro(\"op2-\"(extended_body(|L)),[]) :-
write(extended_body(|L)),nl,
asserta(register(on,L,#t)).
extended_macro(\"op2-\"(extended),[]) :-
write(extended([])),nl,
asserta(register(on,[])).
asserta(register(on,[],#f)).
extended_macro(\"op2-\"(extended_body),[]) :-
write(extended_body([])),nl,
asserta(register(on,[],#t)).
extended_macro(\"op2-\"(all_extended(|L)),[]) :-
write(all_extended(|L)),nl,
asserta(register_F(_,L,#f)).
extended_macro(\"op2-\"(all_extended_body(|L)),[]) :-
write(all_extended_body(|L)),nl,
asserta(register_f(_,L,#t)).
extended_macro(\"op2-\"(all_extended),[]) :-
write(all_extended([])),nl,
asserta(register_f(_,[],#f)).
extended_macro(\"op2-\"(all_extended_body),[]) :-
write(all_extended_body([])),nl,
asserta(register_f(_,[],#t)).
extended_macro((F(|L) :- Code), _) :- !,
add_f(F),fail.
extended_macro((F(|L) --> Code), _) :- !,
......
......@@ -7,13 +7,14 @@
#:use-module (logic guile-log prolog swi)
#:use-module (logic guile-log vlist)
#:use-module (logic guile-log match)
#:use-module (logic guile-log guile-prolog macros)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#: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! *current-stack*))
#:use-module (system vm assembler)
#:re-export (compile_goal begin_att end_att cc pr)
#:re-export (compile_goal begin_att end_att cc pr extended_off extended_on)
#:export (compilable_scm
collect_data define-prolog-fkn
make-vm-function
......@@ -153,9 +154,19 @@ variables is the most difficult part to maintain
y)
(define (get-extended)
(let lp ((l (combine_ops *extended*)) (r '()))
(if (pair? l)
(lp (cdr l) (cons* (cadr (car l)) (car (car l)) r))
r)))
(define (parse-extended)
(set! unify_operators (combine_ops *extended*)))
(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)
(<code> (parse-extended))
(<var> (stackSize constants l nvar nsvar tvar narg)
(compile_goal code l stackSize narg constants #f)
(get_varn nvar)
......@@ -190,6 +201,7 @@ variables is the most difficult part to maintain
(module-name (current-module)))))
(<define> (compile_to_meta stx code meta)
(<code> (parse-extended))
(<var> (stackSize constants l nvar nsvar tvar narg)
(compile_goal code l stackSize narg constants #f)
(get_varn nvar)
......@@ -327,12 +339,19 @@ generate_stx(STX,X,F) :-
(define-syntax-rule (with a code) code)
(define (comma x y) (vector (list #{,}# x y)))
(define (mockalambda source? s pat code)
(let* ((Cut (gp-var! s))
(SCut (gp-var! s))
(rhs (vector (list #{,}# (vector (list with_cut Cut SCut)) code)))
(rhs (if *extended-body*
(comma extended_off
(comma (vector (list with_cut Cut SCut))
code))
(comma (vector (list with_cut Cut SCut)) code)))
(lhs (vector (cons* mockalambda Cut SCut pat)))
(oth (with 'cccc (compile-prolog s pat code source? (list #t #t))))
(oth (with 'cccc (compile-prolog s pat code source?
(cons* #t #t
(get-extended)))))
(all (vector (list :- lhs rhs))))
;(<pp> (s (lambda () #f) (lambda () #f) (lambda x x)) all)
(if source?
......
......@@ -15,7 +15,11 @@
#:use-module (logic guile-log guile-prolog vm vm-conj)
#:use-module (logic guile-log guile-prolog vm vm-handle)
#:use-module (system vm assembler)
#:export (begin_att end_att recur verbatim_call with_cut pr))
#:export (begin_att end_att recur verbatim_call with_cut pr
extended_off extended_on))
(<define> (set_extended x)
(<code> (set! unify_operators (combine_ops (<scm> x)))))
(compile-prolog-string "
reverse_op(<,>).
......@@ -66,7 +70,7 @@ compile_goal(Code,Iout,StackSize,Narg,Constants,Pretty) :- !,
get_M(V,StackSize),
handle_all(L,LL),
(var(Constants)->Constants=scm[(get-consts)];true),
%print(LL),nl,!,
print(LL),nl,!,
(Pretty==#t -> Iout=LL ; (b_setval(pretty,#f),mmtr(LL,Iout))).
compile_goal(X,Tail,V,L) :- var_p(X),!,
......@@ -171,6 +175,15 @@ compile_goal((F :- Goal),Tail,V,L) :- !,
compile_goal(newtag_F(F),Tail,V,[L,L]) :-
F=scm[(gensym \"disj\")].
compile_goal(extended_off,Tail,V,[L,L]) :- !,
set_extended(#f).
compile_goal(extended_on(|L),Tail,V,[L,L]) :- !,
set_extended(L).
compile_goal(extended_on,Tail,V,[L,L]) :- !,
set_extended([]).
compile_goal(collect_F(F),Tail,V,[L,L]) :-
get_F(V,F).
......
......@@ -11,6 +11,26 @@
#:export ())
(define unify_operators '())
(define ops
(list
(list op2+ op2+ )
(list op2- op2- )
(list op2* op2* )
(list #{;}# #{;}# )
(list #{,}# #{,}# )
(list #{\\+}# #{\\+}#)))
(define (combine_ops *extended*)
(if *extended*
(let lp ((l ops) (r '()))
(if (pair? l)
(let ((x (car l)))
(if (assq (car x) *extended*)
(lp (cdr l) r)
(lp (cdr l) (cons x r))))
((@ (guile) append) r *extended*)))
'()))
(define *recurs* (make-fluid vlist-null))
(define *tag* (make-fluid 0))
(define *varn* (make-fluid 4))
......
......@@ -13,7 +13,7 @@ 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,(max ; min ; + ; - ; * ; / ; << ; >> ; \\/ ; /\\ ; mod))
compile_scm((Op, ';'(max,min,+,-,*,/,<<,>>,\\/,/\\,mod))
(X,Y),V,L,LL) :- !,
ifc(compile_scm(X,V,L,LX),EX,
(
......
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