new paralell rich pzip and pand now works

parent 16846cd4
...@@ -11,48 +11,59 @@ ...@@ -11,48 +11,59 @@
(() <fail>) (() <fail>)
((x) (goal-eval x)) ((x) (goal-eval x))
((fail x y) ((fail x y)
(<pand> (</.> (goal-eval fail)) (let ((fail- #f))
(p1 l1 s1 (gp-make-engine (+ next-level 1) 100) (goal-eval x)) (<pand> n fail-
(p2 l2 s2 (gp-make-engine (+ next-level 1) 100) (goal-eval y)))) (p1 l1 s1 (gp-make-engine (+ n 1) 100) (goal-eval x))
(p2 l2 s2 (gp-make-engine (+ n 1) 100) (goal-eval y)))
(fail- (</.> (goal-eval fail)))))
((fail x y u) ((fail x y u)
(<pand> (</.> (goal-eval fail)) (let ((fail- #f))
(p1 l1 s1 (gp-make-engine (+ next-level 1) 100) (goal-eval x)) (<pand> n fail-
(p2 l2 s2 (gp-make-engine (+ next-level 1) 100) (goal-eval y)) (p1 l1 s1 (gp-make-engine (+ n 1) 100) (goal-eval x))
(p3 l3 s3 (gp-make-engine (+ next-level 1) 100) (goal-eval u)))) (p2 l2 s2 (gp-make-engine (+ n 1) 100) (goal-eval y))
(p3 l3 s3 (gp-make-engine (+ n 1) 100) (goal-eval u)))
(fail- (</.> (goal-eval fail)))))
((fail x y u v) ((fail x y u v)
(<pand> (</.> (goal-eval fail)) (let ((fail- #f))
(p1 l1 s1 (gp-make-engine (+ next-level 1) 100) (goal-eval x)) (<pand> n fail-
(p2 l2 s2 (gp-make-engine (+ next-level 1) 100) (goal-eval y)) (p1 l1 s1 (gp-make-engine (+ n 1) 100) (goal-eval x))
(p3 l3 s3 (gp-make-engine (+ next-level 1) 100) (goal-eval u)) (p2 l2 s2 (gp-make-engine (+ n 1) 100) (goal-eval y))
(p4 l4 s4 (gp-make-engine (+ next-level 1) 100) (goal-eval v)))) (p3 l3 s3 (gp-make-engine (+ n 1) 100) (goal-eval u))
(p4 l4 s4 (gp-make-engine (+ n 1) 100) (goal-eval v)))
(fail- (</.> (goal-eval fail)))))
((fail . l) ((fail . l)
(let ((l-u (let lp ((l l) (u '()) (n (/ (length l) 2))) (let ((fail- #f)
(l-u (let lp ((l l) (u '()) (n (/ (length l) 2)))
(if (= n 0) (if (= n 0)
(cons l u) (cons l u)
(lp (cdr l) (cons (car l) u) (- n 1)))))) (lp (cdr l) (cons (car l) u) (- n 1))))))
(<pand> (</.> (goal-eval fail)) (<pand> n fail-
(p1 l1 s1 (gp-make-engine (+ next-level 1) 100) (p1 l1 s1 (gp-make-engine (+ n 1) 100)
(<apply> paralell fail (car l-u))) (<apply> paralell fail (car l-u)))
(p3 l3 s3 (gp-make-engine (+ next-level 1) 100) (p3 l3 s3 (gp-make-engine (+ n 1) 100)
(<apply> paralell fail (cdr l-u)))))))) (<apply> paralell fail (cdr l-u))))
(fail- (</.> (goal-eval fail)))))))
(define (fail x) x) (define (fail- x) x)
(define pzip (define pzip
(<case-lambda> (<case-lambda>
(() <fail>) (() <fail>)
((x) (goal-eval x)) ((x) (goal-eval x))
((x y) ((x y)
(<pzip> fail (<pzip> fail-
(p1 l1 s1 q1 (goal-eval x)) (p1 l1 s1 q1 (goal-eval x))
(p2 l2 s2 q2 (goal-eval y)))) (p2 l2 s2 q2 (goal-eval y))))
((x y u) ((x y u)
(<pzip> fail (<pzip> fail-
(p1 l1 s1 q1 (goal-eval x)) (p1 l1 s1 q1 (goal-eval x))
(p2 l2 s2 q2 (goal-eval y)) (p2 l2 s2 q2 (goal-eval y))
(p3 l3 s3 q3 (goal-eval u)))) (p3 l3 s3 q3 (goal-eval u))))
((x y u v) ((x y u v)
(<pzip> fail (<pzip> fail-
(p1 l1 s1 q1 (goal-eval x)) (p1 l1 s1 q1 (goal-eval x))
(p2 l2 s2 q2 (goal-eval y)) (p2 l2 s2 q2 (goal-eval y))
(p3 l3 s3 q3 (goal-eval u)) (p3 l3 s3 q3 (goal-eval u))
...@@ -62,7 +73,7 @@ ...@@ -62,7 +73,7 @@
(if (= n 0) (if (= n 0)
(cons l u) (cons l u)
(lp (cdr l) (cons (car l) u) (- n 1)))))) (lp (cdr l) (cons (car l) u) (- n 1))))))
(<pzip> fail (<pzip> fail-
(p2 l2 s2 q2 (<apply> pzip (car l-u))) (p2 l2 s2 q2 (<apply> pzip (car l-u)))
(p3 l3 s3 q3 (<apply> pzip (cdr l-u)))))))) (p3 l3 s3 q3 (<apply> pzip (cdr l-u))))))))
...@@ -14,7 +14,8 @@ ...@@ -14,7 +14,8 @@
#:export (<next> <or> <and> <not> <cond> <if> <scm-if> <fast-if> #:export (<next> <or> <and> <not> <cond> <if> <scm-if> <fast-if>
functorize adaptable_vars functorize adaptable_vars
<with-guile-log> <if-some> <with-guile-log> <if-some>
<cc> <fail> <let> <let*> <var> <modvar> <hvar> </.> <when> <cc> <fail> <let> <let*> <var> <nvar>
<modvar> <hvar> </.> <when>
<define> <define*> <cut> <pp> <pp-dyn> <dyn> <unify> <define> <define*> <cut> <pp> <pp-dyn> <dyn> <unify>
<recur> <letrec> <recur> <letrec>
<lambda> <case-lambda> <with-fail> <with-cut> <with-s> <lambda> <case-lambda> <with-fail> <with-cut> <with-s>
...@@ -484,6 +485,16 @@ ...@@ -484,6 +485,16 @@
(fl-let (cut s p cc) (fl-let (cut s p cc)
(parse<> (cut s p cc) (<and> code ...)))))))) (parse<> (cut s p cc) (<and> code ...))))))))
(define gp-make-nvar (@@ (logic guile-log code-load) gp-make-nvar))
(define-guile-log <nvar>
(syntax-rules ()
((_ (cut s p cc) n (v ...) code ...)
(let ((nn n))
(let ((v (gp-make-nvar n)) ...)
(fl-let (cut s p cc)
(parse<> (cut s p cc) (<and> code ...))))))))
(define-guile-log <modvar> (define-guile-log <modvar>
(syntax-rules () (syntax-rules ()
((_ (cut s p cc) (v ...) code ...) ((_ (cut s p cc) (v ...) code ...)
...@@ -1160,7 +1171,7 @@ For tabling, negations are tricky. the reason is that when a recursive applicati ...@@ -1160,7 +1171,7 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
(lambda () #f) (lambda () #f)
undo undo
s) s)
(cc p s))))) (cc s p)))))
#;(log-code-macro '<dynwind>) #;(log-code-macro '<dynwind>)
;; This is code that allow to store a state ;; This is code that allow to store a state
......
...@@ -29,8 +29,8 @@ ...@@ -29,8 +29,8 @@
(define level 0) (define level 0)
(define next-level 0) (define next-level 0)
(<define-guile-log-rule> (<pand> check (v l se engine code ...) ...) (<define-guile-log-rule> (<pand> n check (v l se engine code ...) ...)
(<var> (v ...) (<nvar> (+ next-level 1) (v ...)
(let ((i level) (n next-level) (l level) ...) (let ((i level) (n next-level) (l level) ...)
(<dynwind> (<dynwind>
(lambda x #f) (lambda x #f)
...@@ -45,9 +45,7 @@ ...@@ -45,9 +45,7 @@
(let* ((s frame) (let* ((s frame)
(ccc (lambda (ss pp) (ccc (lambda (ss pp)
(gp-combine-engines data) (gp-combine-engines data)
(cc (gp-combine-state (cc s p))))
s (list se ...))
p))))
(<with-s> s (<with-s> s
(<pit> s p ccc (<pit> s p ccc
(<with-fail> p (<with-fail> p
...@@ -56,13 +54,15 @@ ...@@ -56,13 +54,15 @@
(<code> (gp-var-set v (gp-peek-engine) S)) (<code> (gp-var-set v (gp-peek-engine) S))
(<dynwind> (<dynwind>
(lambda x (lambda x
(set! level (+ 1 n)) (set! level (+ 1 n))
(set! next-level (+ 1 n))) (set! next-level (+ 1 n)))
(lambda x #f)) (lambda x #f))
(<code> (<code>
(set! level (+ 1 n)) (set! level (+ 1 n))
(set! next-level (+ 1 n))) (set! next-level (+ 1 n)))
code ... code ...
(<dynwind> (<dynwind>
(lambda x (set! l next-level)) (lambda x (set! l next-level))
(lambda x (set! next-level l))) (lambda x (set! next-level l)))
...@@ -82,14 +82,17 @@ ...@@ -82,14 +82,17 @@
(set! next-level (max l ...)) (set! next-level (max l ...))
(set! level i)) (set! level i))
(<code> (gp-combine-engines data)) (<code> (gp-combine-engines data))
(let ((s.bindings (gp-combine-state s (list se ...)))) (<code>
(check-bindings check (cdr s.bindings)) (set! check
(<with-s> (car s.bindings) (<lambda> (fail-)
(<with-fail> p <cc>)))))))) (let ((s.bindings (gp-combine-state s (list se ...))))
(check-bindings fail- (cdr s.bindings))
(<with-s> (car s.bindings))))))
(<with-fail> p <cc>))))))
(<define-guile-log-rule> (<pzip> check (v ll se p code ...) ...) (<define-guile-log-rule> (<pzip> check (v ll se p code ...) ...)
(<var> (p ...) (<nvar> (+ next-level 1) (p ...)
(<letrec> ((l '()) (<letrec> ((l '())
(pwork (pwork
(lambda (q) (lambda (q)
...@@ -98,6 +101,7 @@ ...@@ -98,6 +101,7 @@
(set! l (cdr l)) (set! l (cdr l))
(pp)) (pp))
(q)))) (q))))
(pand-check #f)
(ccwork (ccwork
(lambda (s pp cc) (lambda (s pp cc)
(pwork (lambda () (cc s pp))))) (pwork (lambda () (cc s pp)))))
...@@ -105,10 +109,14 @@ ...@@ -105,10 +109,14 @@
(lambda () (lambda ()
(set! l (list (<lookup> p) ...)) (set! l (list (<lookup> p) ...))
(pwork #f)))) (pwork #f))))
(<pand> (check pend) ((</.>
(v ll se (gp-make-engine (+ next-level 1) 100) (<pand> n pand-check
code ... (<set> p P)) ...) (v ll se (gp-make-engine (+ n 1) 100)
code ... (<set> p P)) ...)))
(ccwork) (ccwork)
(pand-check (check (</.> (<ret> (pend)))))
(<with-fail> pend <cc>)))) (<with-fail> pend <cc>))))
......
...@@ -1507,7 +1507,9 @@ SCM_DEFINE(gp_pop_engine, "gp-pop-engine", 0, 0, 0, (), ...@@ -1507,7 +1507,9 @@ SCM_DEFINE(gp_pop_engine, "gp-pop-engine", 0, 0, 0, (),
gp_debug0("Pop Engine>\n"); gp_debug0("Pop Engine>\n");
SCM s_stack = SCM_CAR(gp_engine_path); SCM s_stack = SCM_CAR(gp_engine_path);
//printf("pop\n");
//format1("shall pop store_path: ~a~%",gp_store_path);
if(SCM_CONSP(gp_store_path)) if(SCM_CONSP(gp_store_path))
gp_store_path = SCM_CDR(gp_store_path); gp_store_path = SCM_CDR(gp_store_path);
else else
...@@ -1559,6 +1561,7 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e), ...@@ -1559,6 +1561,7 @@ SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e),
struct gp_stack *gp = get_gp(); struct gp_stack *gp = get_gp();
//printf("push\n");
int logical = gp->_logical_; int logical = gp->_logical_;
SCM rguards = gp->rguards; SCM rguards = gp->rguards;
...@@ -1645,7 +1648,9 @@ SCM_DEFINE(gp_set_engine, "gp-set-engine", 1, 0, 0, (SCM paths), ...@@ -1645,7 +1648,9 @@ SCM_DEFINE(gp_set_engine, "gp-set-engine", 1, 0, 0, (SCM paths),
{ {
SCM e = SCM_CDR(SCM_CAR(SCM_CAR(paths))); SCM e = SCM_CDR(SCM_CAR(SCM_CAR(paths)));
SCM pathout = gp_paths; SCM pathout = gp_paths;
//printf("set\n");
if(SCM_CONSP(paths)) if(SCM_CONSP(paths))
{ {
gp_engine_path = SCM_CAR(paths); gp_engine_path = SCM_CAR(paths);
...@@ -1683,6 +1688,7 @@ SCM_DEFINE(gp_combine_pop, "gp-combine-pop", 0, 0, 0, (), ...@@ -1683,6 +1688,7 @@ SCM_DEFINE(gp_combine_pop, "gp-combine-pop", 0, 0, 0, (),
#define FUNC_NAME s_gp_combine_pop #define FUNC_NAME s_gp_combine_pop
{ {
//printf("combine pop\n");
SCM ret = SCM_CAR(gp_store_path); SCM ret = SCM_CAR(gp_store_path);
gp_store_path = SCM_CDR(gp_store_path); gp_store_path = SCM_CDR(gp_store_path);
return ret; return ret;
...@@ -1696,12 +1702,18 @@ SCM_DEFINE(gp_combine_push, "gp-combine-push", 1, 0, 0, (SCM r), ...@@ -1696,12 +1702,18 @@ SCM_DEFINE(gp_combine_push, "gp-combine-push", 1, 0, 0, (SCM r),
{ {
gp_store_path = scm_cons(r, gp_store_path); gp_store_path = scm_cons(r, gp_store_path);
//printf("combine push\n");
//format1("pushed store_path: ~a~%",gp_store_path);
if(SCM_CONSP(gp_paths)) if(SCM_CONSP(gp_paths))
SCM_SETCDR(gp_paths, gp_store_path); SCM_SETCDR(gp_paths, gp_store_path);
else else
scm_misc_error("gp-combine-push","gp_paths not a cons ~a~%", scm_misc_error("gp-combine-push","gp_paths not a cons ~a~%",
scm_list_1(gp_paths)); scm_list_1(gp_paths));
//format1("pushed store_path: ~a~%",gp_store_path);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #undef FUNC_NAME
...@@ -1712,13 +1724,14 @@ SCM all_variable_bindings = SCM_BOOL_F; ...@@ -1712,13 +1724,14 @@ SCM all_variable_bindings = SCM_BOOL_F;
SCM folder(SCM key, SCM val, SCM seed, SCM data) SCM folder(SCM key, SCM val, SCM seed, SCM data)
{ {
//printf("folder\n");fflush(stdout);
//format2("key, val : ~a, ~a ~%",key,val);
int level = scm_to_int(SCM_CDR(data)); int level = scm_to_int(SCM_CDR(data));
if(GP_ID(key) > level) if(GP_ID(key) > level)
return seed; return seed;
SCM val2 = scm_hash_ref(key, variable_bindings, SCM_BOOL_F); SCM val2 = scm_hashq_ref(variable_bindings, key, SCM_BOOL_F);
if(scm_is_true(val2)) if(scm_is_true(val2))
{ {
...@@ -1726,24 +1739,30 @@ SCM folder(SCM key, SCM val, SCM seed, SCM data) ...@@ -1726,24 +1739,30 @@ SCM folder(SCM key, SCM val, SCM seed, SCM data)
} }
else else
{ {
SCM val3 = scm_hash_ref(key, all_variable_bindings, SCM_BOOL_F); //printf("new\n");
scm_hashq_set_x(variable_bindings, key, SCM_BOOL_T);
SCM val3 = scm_hashq_ref(all_variable_bindings, key, SCM_BOOL_F);
if(scm_is_true(val3)) if(scm_is_true(val3))
{ {
SCM val4 = scm_hash_ref(key, variable_bindings_found, SCM_BOOL_F); //printf("registred\n");
SCM val4 = scm_hashq_ref(variable_bindings_found, key, SCM_BOOL_F);
if(scm_is_true(val4)) if(scm_is_true(val4))
{ {
//printf("fat\n");
return scm_cons(scm_cons(key,val),seed); return scm_cons(scm_cons(key,val),seed);
} }
else else
{ {
scm_hash_set_x(key, SCM_BOOL_T, variable_bindings_found); //printf("thin\n");
scm_hashq_set_x(variable_bindings_found, key, SCM_BOOL_T);
return scm_cons(scm_cons(key,val), return scm_cons(scm_cons(key,val),
scm_cons(scm_cons(key, val3), seed)); scm_cons(scm_cons(key, val3), seed));
} }
} }
else else
{ {
scm_hash_set_x(key, val, all_variable_bindings); //printf("not registred\n");
scm_hashq_set_x(all_variable_bindings, key, val);
return seed; return seed;
} }
} }
...@@ -1752,6 +1771,8 @@ SCM folder(SCM key, SCM val, SCM seed, SCM data) ...@@ -1752,6 +1771,8 @@ SCM folder(SCM key, SCM val, SCM seed, SCM data)
SCM level1(SCM data, SCM ll, SCM ret); SCM level1(SCM data, SCM ll, SCM ret);
SCM level0(SCM data, SCM l, SCM ret) SCM level0(SCM data, SCM l, SCM ret)
{ {
//printf("level0\n");fflush(stdout);
for(;SCM_CONSP(l);l = SCM_CDR(l)) for(;SCM_CONSP(l);l = SCM_CDR(l))
{ {
ret = level1(data,SCM_CAR(l),ret); ret = level1(data,SCM_CAR(l),ret);
...@@ -1763,6 +1784,9 @@ SCM level0(SCM data, SCM l, SCM ret) ...@@ -1763,6 +1784,9 @@ SCM level0(SCM data, SCM l, SCM ret)
SCM level1(SCM data, SCM ll, SCM ret) SCM level1(SCM data, SCM ll, SCM ret)
{ {
SCM l0 = SCM_CAR(data); SCM l0 = SCM_CAR(data);
//printf("level1\n");fflush(stdout);
for(;SCM_CONSP(ll);ll=SCM_CDR(ll)) for(;SCM_CONSP(ll);ll=SCM_CDR(ll))
{ {
if(scm_is_eq(ll, l0)) if(scm_is_eq(ll, l0))
...@@ -1770,12 +1794,22 @@ SCM level1(SCM data, SCM ll, SCM ret) ...@@ -1770,12 +1794,22 @@ SCM level1(SCM data, SCM ll, SCM ret)
{ {
SCM x = SCM_CAR(ll); SCM x = SCM_CAR(ll);
if(scm_vlist_p(x)) if(scm_is_true(scm_vlist_p(x)))
ret = vhash_fold_all_exp(data, folder, ret, x); {
if(SCM_I_IS_VECTOR(x)) //printf("vlist\n");fflush(stdout);
ret = level0(data, scm_c_vector_ref(ret, 0), ret); //format1("vlist : ~a~%", x);
ret = vhash_fold_all_exp(data, folder, ret, x);
}
if(SCM_I_IS_VECTOR(x))
{
//printf("vector\n");fflush(stdout);
ret = level0(data, scm_c_vector_ref(ret, 0), ret);
}
if(SCM_CONSP(x)) if(SCM_CONSP(x))
ret = folder(SCM_CAR(x), SCM_CDR(x), ret, data); {
//printf("cons\n");fflush(stdout);
ret = folder(SCM_CAR(x), SCM_CDR(x), ret, data);
}
} }
} }
...@@ -1788,6 +1822,8 @@ SCM get_all_conflicting_bindings(SCM l, SCM data) ...@@ -1788,6 +1822,8 @@ SCM get_all_conflicting_bindings(SCM l, SCM data)
variable_bindings_found = scm_c_make_hash_table(100); variable_bindings_found = scm_c_make_hash_table(100);
all_variable_bindings = scm_c_make_hash_table(100); all_variable_bindings = scm_c_make_hash_table(100);
//printf("conflict\n");fflush(stdout);
SCM ret = SCM_EOL; SCM ret = SCM_EOL;
for(;SCM_CONSP(l);l=SCM_CDR(l)) for(;SCM_CONSP(l);l=SCM_CDR(l))
{ {
...@@ -1804,6 +1840,8 @@ SCM_DEFINE(gp_combine_state, "gp-combine-state", 2, 0, 0, (SCM s, SCM l), ...@@ -1804,6 +1840,8 @@ SCM_DEFINE(gp_combine_state, "gp-combine-state", 2, 0, 0, (SCM s, SCM l),
{ {
SCM data = gp_gp_cdr(s,s); SCM data = gp_gp_cdr(s,s);
SCM l0 = SCM_CAR(data); SCM l0 = SCM_CAR(data);
//printf("combine state\n");fflush(stdout);
struct gp_stack * gp = get_gp(); struct gp_stack * gp = get_gp();
......
...@@ -987,11 +987,15 @@ static inline void gp_unwind_(SCM s , int ncons, int nvar, int nci, ...@@ -987,11 +987,15 @@ static inline void gp_unwind_(SCM s , int ncons, int nvar, int nci,
} }
else else
{ {
path = gp_engine_path; path = gp_engine_path,
spath = gp_store_path;
} }
} }
else else
path = gp_engine_path; {
path = gp_engine_path;
spath = gp_store_path;
}
if(SCM_CONSP(path)) if(SCM_CONSP(path))
{ {
......
...@@ -222,7 +222,7 @@ scm_t_bits gp_smob_t; ...@@ -222,7 +222,7 @@ scm_t_bits gp_smob_t;
#define GP_CLEAR_MARK(x) (x & (~GPI_GL_M)) #define GP_CLEAR_MARK(x) (x & (~GPI_GL_M))
//#define GP_HASH(x) ((SCM_UNPACK(x) & GPHA) >> H_BITS) //#define GP_HASH(x) ((SCM_UNPACK(x) & GPHA) >> H_BITS)
#define GP_ID(x) ((SCM_UNPACK(x) & GPID) >> N_BITS) #define GP_ID(x) ((SCM_UNPACK(x) & GPID) >> N_BITS)
#define GP_SETID(x,id) (((unsigned long) (id)) << N_BITS | (x)) #define GP_SETID(x,id) (((unsigned long) (id)) << N_BITS | (x))
#define GP_COUNT(X) ((scm_t_bits) ((SCM_UNPACK(X) & GPHA) >> H_BITS)) #define GP_COUNT(X) ((scm_t_bits) ((SCM_UNPACK(X) & GPHA) >> H_BITS))
#define GP_SETCOUNT(X,i) (((SCM_UNPACK(X) & (~GPHA)) \ #define GP_SETCOUNT(X,i) (((SCM_UNPACK(X) & (~GPHA)) \
...@@ -262,8 +262,8 @@ scm_t_bits gp_smob_t; ...@@ -262,8 +262,8 @@ scm_t_bits gp_smob_t;
#define GP_UNREF(x) ((SCM) (x)) #define GP_UNREF(x) ((SCM) (x))
#define N_BITS 26 #define N_BITS 27
#define H_BITS 36 #define H_BITS 37
#define GP_ATTR_IT(x) ((x) = ((x) | GPI_ATTR)) #define GP_ATTR_IT(x) ((x) = ((x) | GPI_ATTR))
...@@ -517,7 +517,7 @@ inline SCM handle(SCM *id, SCM flags, SCM v, SCM l, struct gp_stack *gp, int k, ...@@ -517,7 +517,7 @@ inline SCM handle(SCM *id, SCM flags, SCM v, SCM l, struct gp_stack *gp, int k,
if(!bang && gp->_logical_) return logical_add2(GP_UNREF(id),v,l); if(!bang && gp->_logical_) return logical_add2(GP_UNREF(id),v,l);
if(!bang && GP_ID(*id) != gp->id && gp->_thread_safe_) if(!bang && GP_ID(*id) < gp->id && gp->_thread_safe_)
{ {
gp_debug0("logical add\n"); gp_debug0("logical add\n");
return logical_add2(GP_UNREF(id),v,l); return logical_add2(GP_UNREF(id),v,l);
...@@ -543,7 +543,7 @@ static inline SCM handle_l(SCM *id, SCM flags, SCM v, SCM *l, struct gp_stack *g ...@@ -543,7 +543,7 @@ static inline SCM handle_l(SCM *id, SCM flags, SCM v, SCM *l, struct gp_stack *g
if(gp->_logical_) return logical_add2_l(GP_UNREF(id),v,l); if(gp->_logical_) return logical_add2_l(GP_UNREF(id),v,l);
if(GP_ID(*id) != gp->id && gp->_thread_safe_) if(GP_ID(*id) < gp->id && gp->_thread_safe_)
{ {
gp_debug0("logical add\n"); gp_debug0("logical add\n");
return logical_add2_l(GP_UNREF(id),v,l); return logical_add2_l(GP_UNREF(id),v,l);
...@@ -3588,6 +3588,14 @@ SCM_DEFINE(gp_soft_init, "gp-module-init", 0, 0, 0, (), ...@@ -3588,6 +3588,14 @@ SCM_DEFINE(gp_soft_init, "gp-module-init", 0, 0, 0, (),
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE(gp_make_nvariable, "gp-make-nvar", 1, 0, 0, (SCM id),
"makes a gp n variable")
#define FUNC_NAME gp_make_nvariable
{
return gp_make_variable_id(scm_to_int(id));
}
#undef FUNC_NAME
SCM_DEFINE(gp_make_fluid, "gp-make-var", 0, 0, 0, (), SCM_DEFINE(gp_make_fluid, "gp-make-var", 0, 0, 0, (),
"makes a gp fluid variable") "makes a gp fluid variable")
#define FUNC_NAME s_gp_make_fluid #define FUNC_NAME s_gp_make_fluid
......
...@@ -118,7 +118,9 @@ SCM_API SCM gp_gp_unwind_tail(SCM fr); ...@@ -118,7 +118,9 @@ SCM_API SCM gp_gp_unwind_tail(SCM fr);
SCM_API SCM gp_gp_store_state(SCM s); SCM_API SCM gp_gp_store_state(SCM s);
SCM_API SCM gp_gp_restore_state(SCM cont, SCM K); SCM_API SCM gp_gp_restore_state(SCM cont, SCM K);
SCM_API SCM gp_make_fluid(); SCM_API SCM gp_make_fluid();
SCM_API SCM gp_make_nvariable(SCM id);
SCM_API SCM gp_fluid_set_bang(SCM f, SCM v, SCM s); SCM_API SCM gp_fluid_set_bang(SCM f, SCM v, SCM s);
SCM_API SCM gp_dynwind(SCM in, SCM out, SCM s); SCM_API SCM gp_dynwind(SCM in, SCM out, SCM s);
......
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