vm-scm-model, logic for extended matching

parent d40a905f
......@@ -118,6 +118,7 @@ PSSOURCES = \
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/guile-prolog/macros.scm \
logic/guile-log/guile-prolog/vm/vm-pre.scm \
logic/guile-log/guile-prolog/vm/vm-var.scm \
logic/guile-log/guile-prolog/vm/vm-scm.scm \
......@@ -129,6 +130,7 @@ PSSOURCES = \
logic/guile-log/guile-prolog/vm/vm-unify.scm \
logic/guile-log/guile-prolog/vm/vm-goal.scm \
logic/guile-log/guile-prolog/vm-compiler.scm \
logic/guile-log/guile-prolog/vm/vm-scm2.scm \
logic/guile-log/guile-prolog/vm/vm-args2.scm \
logic/guile-log/guile-prolog/vm/vm-disj2.scm \
logic/guile-log/guile-prolog/vm/vm-imprint2.scm \
......
(define-module (logic guile-log guile-prolog macros)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log)
#:replace (extended)
#:export (*extended* extended_macro))
(<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))))
(compile-prolog-string "
:- dynamic([register/2,register_f/2]).
on(L) :-
register(X,L) -> X=on.
add_f(F) :-
(
(
on(L) ->
(
asserta(register(off,L)),
asserta(register_f(F,L))
) ;
register_f(F,L)
) ->
set_extended(L) ;
set_extended(#f)
).
extended_macro(\"op2-\"(extended(|L)),[]) :-
write(F(|L)),nl,
asserta(register(on,L)).
extended_macro(\"op2-\"(extended),[]) :-
write(extended([])),nl,
asserta(register(on,[])).
extended_macro((F(|L) :- Code), _) :- !,
add_f(F),fail.
extended_macro((F(|L) --> Code), _) :- !,
add_f(F),fail.
extended_macro(F(|L) , _) :- !,
add_f(F),fail.
")
(define-module (logic guile-log guile-prolog vm vm-args2)
(define-module (logic guile-log guile-prolog vm vm-scm)
#:use-module (logic guile-log)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log guile-prolog hash)
#:use-module (logic guile-log guile-prolog ops)
#:use-module (logic guile-log prolog swi)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var)
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:use-module (logic guile-log guile-prolog vm-compiler)
#:export (caller push_args_args2 push_args_args push_args))
#;
(eval-when (compile)
(pk (prolog-run-rewind 1 (x)
(dyntrace (@@ (logic guile-log guile-prolog vm vm-handle)
handle)))))
(compile-prolog-string
"
- eval_when(compile).
the_tr2(X,[X]).
:- add_term_expansion_temp(the_tr2).
")
(eval-when (compile)
(set! (@@ (logic guile-log prolog compile) include-meta) #f))
(include-from-path "logic/guile-log/guile-prolog/vm/vm-args-model.scm")
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var)
#:export (compile_scm))
(eval-when (compile)
(set! (@@ (logic guile-log prolog compile) include-meta) #t))
(include-from-path "logic/guile-log/guile-prolog/vm/vm-scm-model.scm")
......@@ -94,7 +94,7 @@ chech_push(F) :-
throw(first_variable_in_scheme_context);
true.
handle([softie,A],I,II,L,LL) :- !,write(A),nl,
handle([softie,A],I,II,L,LL) :- !,
(
(var(A) ; number(A)) ->
L=[[softie,A]|LL] ;
......
(compile-prolog-string
"
-extended.
compile_scm(X,V,L,LL) :-
var_p(X) ->
( !,
add_var(X,V,Tag),tr('push-variable-scm',Push),
push_v(1,V),
L=[[Push,Tag]|LL]
);
constant(X) -> (!,tr('push-constant',Atom), L=[[Atom ,XX]|LL],
E=X,regconst(X,XX), push_v(1,V));
instruction(X) -> (!,tr('push-instruction',Atomic), L=[[Atomic,X]|LL],
E=X,push_v(1,V)).
compile_scm((Op,(max ; min ; + ; - ; * ; / ; << ; >> ; \\/ ; /\\ ; mod))
(X,Y),V,L,LL) :- !,
ifc(compile_scm(X,V,L,LX),EX,
(
(number(EX) -> true ; throw(EY)),
ifc(compile_scm(Y,V,L,LY),EY,
(
(number(EY) -> true ; throw(EY)),
call(E is Op(EX,EY)),
throw(E)
),
(
binop1L(Op,O),
LY=[[O,EX]|LL]
))
),
ifc(compile_scm(Y,V,LX,LY),EY,
(
(number(EY) -> true ; throw(EY)),
binop1R(Op,O),
LX=[[O,EY]|LL]
),
(
push_v(-1,V),
tr(Op,O),
LY=[[Op]|LL]
))).
compile_scm((Op,(+ ; -))(X),V,L,LL) :- !,
ifc(compile_scm(X,V,L,LX),EX,
(
(number(EX) -> true ; throw(EX)),
call(E is Op(EX)),
throw(E)
),
(
Op=='+' -> LX=LL ;
(
(
Op=='-' -> unop('op1_-',O) ;
unop(Op,O)
),
LX=[[O]|LL]
)
)).
")
......@@ -10,64 +10,4 @@
#:use-module (logic guile-log guile-prolog vm vm-var)
#:export (compile_scm))
(compile-prolog-string
"
-extended.
compile_scm(X,V,L,LL) :-
var_p(X) ->
( !,
add_var(X,V,Tag),tr('push-variable-scm',Push),
push_v(1,V),
L=[[Push,Tag]|LL]
);
constant(X) -> (!,tr('push-constant',Atom), L=[[Atom ,XX]|LL],
E=X,regconst(X,XX), push_v(1,V));
instruction(X) -> (!,tr('push-instruction',Atomic), L=[[Atomic,X]|LL],
E=X,push_v(1,V)).
compile_scm((Op,(max ; min ; + ; - ; * ; / ; << ; >> ; \\/ ; /\\ ; mod))
(X,Y),V,L,LL) :- !,
ifc(compile_scm(X,V,L,LX),EX,
(
(number(EX) -> true ; throw(EY)),
ifc(compile_scm(Y,V,L,LY),EY,
(
(number(EY) -> true ; throw(EY)),
call(E is Op(EX,EY)),
throw(E)
),
(
binop1L(Op,O),
LY=[[O,EX]|LL]
))
),
ifc(compile_scm(Y,V,LX,LY),EY,
(
(number(EY) -> true ; throw(EY)),
binop1R(Op,O),
LX=[[O,EY]|LL]
),
(
push_v(-1,V),
tr(Op,O),
LY=[[Op]|LL]
))).
compile_scm((Op,(+ ; -))(X),V,L,LL) :- !,
ifc(compile_scm(X,V,L,LX),EX,
(
(number(EX) -> true ; throw(EX)),
call(E is Op(EX)),
throw(E)
),
(
Op=='+' -> LX=LL ;
(
(
Op=='-' -> unop('op1_-',O) ;
unop(Op,O)
),
LX=[[O]|LL]
)
)).
")
(include-from-path "logic/guile-log/guile-prolog/vm/vm-scm-model.scm")
(define-module (logic guile-log guile-prolog vm vm-scm2)
#:use-module (logic guile-log)
#:use-module (logic guile-log iso-prolog)
#:use-module (logic guile-log guile-prolog hash)
#:use-module (logic guile-log guile-prolog ops)
#:use-module (logic guile-log guile-prolog macros)
#:use-module (logic guile-log prolog swi)
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:use-module (logic guile-log guile-prolog vm-compiler)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var)
#:export (compile_scm))
#;
(eval-when (compile)
(pk (prolog-run-rewind 1 (x)
(dyntrace (@@ (logic guile-log guile-prolog vm vm-handle)
handle)))))
(compile-prolog-string
"
- eval_when(compile).
the_tr2(X,[X]).
:- add_term_expansion_temp(the_tr2).
:- add_term_expansion_temp(extended_macro).
")
(eval-when (compile)
(set! (@@ (logic guile-log prolog compile) include-meta) #f))
(include-from-path "logic/guile-log/guile-prolog/vm/vm-scm-model.scm")
......@@ -28,18 +28,18 @@
(define nq 8)
(<define> (push_Q e v u)
;(<pp> `(push ,e))
(<pp> `(push ,e))
(let ((v (<lookup> v)))
(<set> (vector-ref v nq) (cons u (<lookup> (vector-ref v nq))))))
(<define> (pop_Q e v x)
;(<pp> `(pop ,e))
(<pp> `(pop ,e))
(let ((v (<lookup> v)))
(<=> x ,(car (<lookup> (vector-ref v nq))))
(<set> (vector-ref v nq) (cdr (<lookup> (vector-ref v nq))))))
(<define> (touch_Q e v)
;(<pp> `(touch ,e))
(<pp> `(touch ,e))
(<recur> lp ((l (<lookup> (vector-ref (<lookup> v) nq))))
(if (pair? l)
(<and>
......@@ -48,7 +48,7 @@
<cc>)))
(<define> (read_Q e v q)
;(<pp> `(read ,e))
(<pp> `(read ,e))
(let* ((v (<lookup> v)))
(<=> q ,(car (<lookup> (vector-ref v nq))))))
......
......@@ -1176,6 +1176,21 @@
(lp (list x) r))))))
(define (code? code)
(define (test x)
(let ((x (module-ref (current-module) x)))
(if (and (procedure? x)
(procedure-property x 'module))
#t
#f)))
(match code
((#:term (#:atom x . _) . _)
(test x))
((#:atom x . _)
(test x))
(_ #t)))
(define (parse-1 line s stx x)
(define (ferr f n m)
`(#:translated 0
......@@ -1186,7 +1201,7 @@
(pk-time 'parse)
(init-time)
(let ((code
(if (match x (((_ _ "-" _) . _) #f) (_ #t))
(if (match x (((_ _ "-" _) code . _) (code? code)) (_ #t))
(with line
(expand-0
s (lambda () #f) (lambda (s p x) 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