Debugged first variables short cut

parent 66e8ca94
...@@ -119,6 +119,7 @@ ...@@ -119,6 +119,7 @@
(warn (warn
"libguile-unify is not present, did you forget to make it?"))))) "libguile-unify is not present, did you forget to make it?")))))
;(define (gp-clear-frame . x) #t)
(define-syntax-rule (definek x val) (define-syntax-rule (definek x val)
(module-define! (current-module) 'x val)) (module-define! (current-module) 'x val))
......
...@@ -131,14 +131,14 @@ ...@@ -131,14 +131,14 @@
(q (f-char #\")) (q (f-char #\"))
(quote (f-seq!! bs any)) (quote (f-seq!! bs any))
(it (f-or! match nl quote butq)) (it (f-or! match nl quote butq))
(str (f-or! s-eof (f-seq!! it str) q))) (str (f-or! f-eof (f-seq!! it str) q)))
(f-seq!! q str))) (f-seq!! q str)))
(define (line-comment match nl) (define (line-comment match nl)
(letrec ((no-nl (f-reg "[^\n]")) (letrec ((no-nl (f-reg "[^\n]"))
(semi (f-char #\;)) (semi (f-char #\;))
(it (f-or! match no-nl)) (it (f-or! match no-nl))
(f (f-or! s-eof nl (f-seq!! it f)))) (f (f-or! f-eof nl (f-seq!! it f))))
(f-seq!! semi f))) (f-seq!! semi f)))
...@@ -147,7 +147,7 @@ ...@@ -147,7 +147,7 @@
(left (f-tag "#|")) (left (f-tag "#|"))
(not-right (f-not right)) (not-right (f-not right))
(it (f-or! nl match f not-right)) (it (f-or! nl match f not-right))
(g (f-or! s-eof (f-seq!! it g) right)) (g (f-or! f-eof (f-seq!! it g) right))
(f (f-seq!! left g))) (f (f-seq!! left g)))
f)) f))
...@@ -185,7 +185,7 @@ ...@@ -185,7 +185,7 @@
nleft)) nleft))
(item (lambda (g true) (item (lambda (g true)
(f-or! (f-seq!! it (Ds (item g true))) (f-or! (f-seq!! it (Ds (item g true)))
s-eof f-eof
true))) true)))
(gg (item (Ds gg) f-true)) (gg (item (Ds gg) f-true))
(g (item (Ds g) f-false))) (g (item (Ds g) f-false)))
......
...@@ -34,7 +34,6 @@ ...@@ -34,7 +34,6 @@
<get-fixed> <cp> <lookup> <wrap> <get-fixed> <cp> <lookup> <wrap>
)) ))
(define (gp-gc) #f)
(define (<wrap> f . l) (define (<wrap> f . l)
(apply f (fluid-ref *current-stack*) (lambda x #f) (lambda x #t) l)) (apply f (fluid-ref *current-stack*) (lambda x #f) (lambda x #t) l))
......
...@@ -525,9 +525,9 @@ ...@@ -525,9 +525,9 @@
(lambda (vl vs x) (lambda (vl vs x)
(with-varstat (with-varstat
(init-first-variables) (init-first-variables)
(for-each first-variable! (pk vl)) (for-each first-variable! vl)
(register-variables x) (register-variables x)
(let ((code (goal stx (pk x))) (let ((code (goal stx x))
(loc (let lp ((var vs)) (loc (let lp ((var vs))
(if (pair? var) (if (pair? var)
(if (local-variable? (car var)) (if (local-variable? (car var))
......
...@@ -292,7 +292,7 @@ ...@@ -292,7 +292,7 @@
((unify-tr stx n m x y) ((unify-tr stx n m x y)
(match x (match x
((#:variable v id nn mm) ((#:variable v id nn mm)
(if (and (first-variable? v id) (variable-not-included? v y)) (if (and (first-variable? v id) (pk 'first v) (variable-not-included? v y))
(begin (begin
(local-variable! v) (local-variable! v)
#`(<code> #`(<code>
...@@ -301,7 +301,8 @@ ...@@ -301,7 +301,8 @@
(_ (_
(match y (match y
((#:variable v id nn mm) ((#:variable v id nn mm)
(if (and (first-variable? v id) (variable-not-included? v x)) (if (and (first-variable? v id) v
(variable-not-included? v x))
(begin (begin
(local-variable! v) (local-variable! v)
#`(<code> (set! #,(datum->syntax stx v) (*var* stx x)))) #`(<code> (set! #,(datum->syntax stx v) (*var* stx x))))
...@@ -323,7 +324,7 @@ ...@@ -323,7 +324,7 @@
((tr-is stx n m x y) ((tr-is stx n m x y)
(match x (match x
((#:variable v id nn mm) ((#:variable v id nn mm)
(if (first-variable? v id) (if (and (first-variable? v id))
(begin (begin
(local-variable! v) (local-variable! v)
#`(<code> (set! #,(datum->syntax stx v) #,(scm stx y)))) #`(<code> (set! #,(datum->syntax stx v) #,(scm stx y))))
......
...@@ -7,16 +7,16 @@ ...@@ -7,16 +7,16 @@
(define-syntax-rule (with-varstat . code) (define-syntax-rule (with-varstat . code)
(with-fluids ((*vs* #f) (*vl* #f)) . code)) (with-fluids ((*vs* #f) (*vl* #f)) (begin (begin . code))))
(define *vs* (make-fluid (make-hash-table))) (define *vs* (make-fluid (make-hash-table)))
(define *vl* (make-fluid (make-hash-table))) (define *vl* (make-fluid (make-hash-table)))
(define (init-first-variables) (define (init-first-variables)
(fluid-set! *vs* (make-hash-table)) (fluid-set! *vs* (make-hash-table))
(fluid-set! *vl* (make-hash-table))) (fluid-set! *vl* (make-hash-table)))
(define (first-variable? v id) (define (first-variable? v id)
(let ((i (pk 'fisrt? (hash-ref (fluid-ref *vs*) v -2)))) (let ((i (hash-ref (fluid-ref *vs*) v -2)))
(= i id))) (= i id)))
(define (first-variable! v) (define (first-variable! v)
...@@ -31,7 +31,7 @@ ...@@ -31,7 +31,7 @@
(define (variable-not-included? v x) (define (variable-not-included? v x)
(define (off) #f) (define (off) #f)
(define (g x) (define (g x)
(match (pk 1 x) (match x
(() (()
#'<cc>) #'<cc>)
(((kind _ op _) x y n m) (((kind _ op _) x y n m)
...@@ -85,7 +85,7 @@ ...@@ -85,7 +85,7 @@
(define (g x gl) (define (g x gl)
(when (not o) (when (not o)
(match (pk x) (match x
(() (()
#'<cc>) #'<cc>)
(((kind _ op _) x y n m) (((kind _ op _) x y n m)
...@@ -121,8 +121,6 @@ ...@@ -121,8 +121,6 @@
((x) (g x gl)) ((x) (g x gl))
(_ #t)))) (_ #t))))
(fluid-set! *vs* (make-hash-table))
(g x #t)) (g x #t))
\ No newline at end of file
...@@ -60,7 +60,6 @@ static inline SCM *get_gp_var(struct gp_stack *gp) ...@@ -60,7 +60,6 @@ static inline SCM *get_gp_var(struct gp_stack *gp)
{ {
SCM cand; SCM cand;
GP_TEST_STACK; GP_TEST_STACK;
cand = *(gp->gp_si); cand = *(gp->gp_si);
if(scm_is_false(cand) || scm_is_eq(cand, SCM_BOOL_T)) if(scm_is_false(cand) || scm_is_eq(cand, SCM_BOOL_T))
{ {
...@@ -199,12 +198,18 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, int ncs, s ...@@ -199,12 +198,18 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, int ncs, s
{ {
SCM *pt, *end = gp->gp_stack + ns; SCM *pt, *end = gp->gp_stack + ns;
for(pt = gp->gp_stack; pt < end; pt++)
{
*pt = SCM_BOOL_F;
}
/*
for(pt = gp->gp_stack; pt < end; pt++) for(pt = gp->gp_stack; pt < end; pt++)
{ {
SCM scm; SCM scm;
scm = gp_make_variable(); scm = gp_make_variable();
*pt = scm; *pt = scm;
} }
*/
} }
......
...@@ -79,6 +79,25 @@ SCM closure_tag; ...@@ -79,6 +79,25 @@ SCM closure_tag;
DB(scm_simple_format(SCM_BOOL_T, \ DB(scm_simple_format(SCM_BOOL_T, \
scm_from_locale_string(str), \ scm_from_locale_string(str), \
scm_list_3(x,y,z))) scm_list_3(x,y,z)))
#define format0(str) \
(scm_simple_format(SCM_BOOL_T, \
scm_from_locale_string(str), \
SCM_EOL))
#define format1(str,x) \
(scm_simple_format(SCM_BOOL_T, \
scm_from_locale_string(str), \
scm_list_1(x)))
#define format2(str,x,y) \
(scm_simple_format(SCM_BOOL_T, \
scm_from_locale_string(str), \
scm_list_2(x,y)))
#define format3(str,x,y,z) \
(scm_simple_format(SCM_BOOL_T, \
scm_from_locale_string(str), \
scm_list_3(x,y,z)))
...@@ -493,6 +512,7 @@ static inline void handle_force(SCM *id, SCM flags, SCM v) ...@@ -493,6 +512,7 @@ static inline void handle_force(SCM *id, SCM flags, SCM v)
SCM * set_ci(SCM *ci, struct gp_stack *gp) SCM * set_ci(SCM *ci, struct gp_stack *gp)
{ {
SCM *f = get_gp_var(gp); SCM *f = get_gp_var(gp);
SCM flags = SCM_PACK(GP_MK_FRAME_EQ(gp_type)); SCM flags = SCM_PACK(GP_MK_FRAME_EQ(gp_type));
handle_force(f, flags, SCM_PACK(((ci - gp->gp_cstack)<<2) + 2)); handle_force(f, flags, SCM_PACK(((ci - gp->gp_cstack)<<2) + 2));
......
...@@ -119,4 +119,4 @@ ...@@ -119,4 +119,4 @@
(<var> (y) (<var> (y)
(<=> y ,(car x)) (<=> y ,(car x))
(loop (cdr x) (cons y l))) (loop (cdr x) (cons y l)))
(<=> r ,(apply vector (reverse l)))))) (<=> r ,(apply vector (reverse l))))))
\ No newline at end of file
...@@ -8,6 +8,9 @@ inc(X,Y) :- Y is X + 1. ...@@ -8,6 +8,9 @@ inc(X,Y) :- Y is X + 1.
test(N) :- test(N,0). test(N) :- test(N,0).
test(N,X) :- X < N, inc(X,Y), test(N,Y). test(N,X) :- X < N, inc(X,Y), test(N,Y).
test3(N) :- test3(N,0).
test3(N,X) :- X < N, Y is X + 1, test3(N,Y).
test2(N) :- test2(N,0). test2(N) :- test2(N,0).
test2(N,X) :- X < N -> (inc(X,Y), test2(N,Y)) ; (write('goaaaaaaaal!'),nl). test2(N,X) :- X < N -> (inc(X,Y), test2(N,Y)) ; (write('goaaaaaaaal!'),nl).
") ")
......
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