Bug in prolog parser, cleanup, prolog gc is working

parent e1568d10
......@@ -13,7 +13,7 @@
(<define> (closure_p x) (when (prolog-closure? (<lookup> x))))
(<define> (closure_state_ref x l) (<=> l ,(prolog-closure-state (<lookup> x))))
(<define> (closure_is_closed x)
(when (and (prolog-closure? (<lookup> x))
(prolog-closer-closed (<lookup> x)))))
(when (and (prolog-closure? (<lookup> x))
(prolog-closure-closed? (<lookup> x)))))
(<define> (closure_code_ref x l) (<=> l ,(prolog-closure-parent (<lookup> x))))
\ No newline at end of file
......@@ -92,7 +92,7 @@
(caar l)
(let ((r (cdar l)))
(if r
(list->string )
(list->string r)
'<eof>))))))
(define file-next-line
......
......@@ -26,7 +26,7 @@
error_on_namespace_switch
fail_on_namespace_switch
ok_on_namespace_switch
get_namespace_swich_handle x
get_namespace_switch_handle x
namespace_white_list_handle
set_no_namespace_whitelist
......@@ -96,7 +96,7 @@ Two things will happen
(<code> (fluid-set! fail-when-new-namespace? 'fail)))
(<define> (ok_on_namespace_switch)
(<code> (fluid-set! fail-when-new-namespace? #f)))
(<define> (get_namespace_swich_handle x)
(<define> (get_namespace_switch_handle x)
(<=> x ,fail-when-new-namespace?))
(define white-list-namespaces (make-fluid #f))
......@@ -113,7 +113,7 @@ Two things will happen
(mk-sym namespace_switch)
(define (err x) (<wrap> permission_error namespace_swich true x))
(define (err x) (<wrap> permission_error namespace_switch true x))
(define (comp-ok? ns1 local1? ns2 local2? binary? rw-in)
(define ret-ok (if rw-in #t 'read))
......
......@@ -159,7 +159,7 @@
(define quotes
(mk-token (f-seq (f-char #\') (f* (f-reg! "[^']")) (f-char #\'))))
(mk-token (f-seq 'quotes (f-char #\') (f* (f-reg! "[^']")) (f-char #\'))))
(define integer (f+ (f-reg! "[0-9]")))
(define fraction (f-seq integer (f-or! (f-seq (f-char! #\.) integer)
......@@ -191,7 +191,7 @@
mk-id))
(define keyword
(let ((sharp (f-reg "#"))
(let ((sharp (f-tag "#"))
(colon (f-char #\:)))
(p-freeze 'keyword
(<p-lambda> (c)
......@@ -207,7 +207,7 @@
(define f-quote (f-char #\'))
(define f-dquote (f-char #\"))
(define f-dquote (f-char #\"))
(define f-quote! (f-char! #\'))
(define f-dquote! (f-char! #\"))
(define f-esc (f-char #\\))
......@@ -284,7 +284,7 @@
(mk-string "modules")
(mk-string (list-ref cx 1)))))
(<and>
(.. (cx) (string c))
(.. (cx) (qstring c))
(<p-cc> (mk-list (mk-string "language")
(mk-string "prolog")
(mk-string "modules")
......@@ -312,13 +312,13 @@
(<p-cc> `(@ ,cx)))
(<p-cc> #f)))))))
(define string
(p-freeze 'string
(define qstring
(p-freeze 'qstring
(let ((l (f-tag "("))
(r (f-tag ")")))
(<p-lambda> (c)
(.. (c) (ws c))
(.. (c) (f-quote c))
(.. (c) (f-quote c))
(<let> ((n N) (m M))
(.. (c*) (str-body c))
(.. (c) (f-quote c*))
......@@ -333,7 +333,7 @@
mk-id))
(define dstring
(p-freeze 'string
(p-freeze 'dstring
(<p-lambda> (c)
(.. (c) (ws c))
(.. (c) (f-dquote c))
......@@ -425,7 +425,7 @@
(<p-lambda> (c)
(.. (c0) (ws c))
(<let> ((n N) (m M))
(xx (c1) (<or> (.. (atom c0)) (.. (string c0))))
(xx (c1) (<or> (.. (atom c0)) (.. (qstring c0))))
(.. (c2) (l c1))
(.. (c3) ((f-or expr ws) c2))
(.. (c4) (r c3))
......@@ -617,7 +617,7 @@
(define tok (f-or! paranthesis keyword
char list-tok termvar-tok term-binop-tok termop-tok
termstring-tok term-tok scm-tok lam-tok
number string dstring atom variable op-tok))
number qstring dstring atom variable op-tok))
(define e (mk-operator-expression tok symbolic-tok *prolog-ops*))
(set! expr* (<p-lambda> (c) (.. (e 1200))))
......
......@@ -16,6 +16,20 @@ void gp_do_gc()
pthread_mutex_unlock(&gp_gc_lock);
}
int is_gc_locked()
{
int ret = 0;
pthread_mutex_lock(&gp_gc_lock);
if(gp_gc_p)
ret = 1;
else
ret = 0;
pthread_mutex_unlock(&gp_gc_lock);
return ret;
}
void *gp_after_mark_hook(void *hook_data, void *fn_data, void *data)
{
SCM pt = scm_fluid_ref(gp_stacks);
......
......@@ -3,6 +3,8 @@
#include "variable.c"
int is_gc_locked();
scm_t_bits gp_stack_type;
#define GP_STACKP(scm) (SCM_NIMP(scm) && SCM_SMOB_PREDICATE(gp_stack_type,scm))
......@@ -379,8 +381,6 @@ inline int gp_at_newframe(SCM *pt)
struct gp_stack *gp = (struct gp_stack *) SCM_SMOB_DATA(obj);
int i;
printf("stack mark\n");
scm_gc_mark(GP_UNREF(gp->gp_cstack));
scm_gc_mark(GP_UNREF(gp->gp_stack));
scm_gc_mark(GP_UNREF(gp->gp_cons_stack));
......@@ -389,23 +389,39 @@ inline int gp_at_newframe(SCM *pt)
scm_gc_mark(gp->gp_cstack[1]);
scm_gc_mark(gp->gp_cstack[2]);
scm_gc_mark(gp->gp_cstack[3]);
scm_gc_mark(gp->gp_stack[0]);
for(i=0;i < gp->gp_ci - gp->gp_cstack; i++)
{
SCM *pt = gp->gp_cstack + i;
if(*pt)
{
{
if(GP(*pt))
{
SCM val = *pt;
if(unlocked && i >= 4)
{
scm_t_bits head = SCM_UNPACK(GP_GETREF(*pt)[0]);
GP_GC_CAND(head);
GP_GETREF(*pt)[0] = SCM_PACK(head);
gp_gc_mark_no_touch(*pt);
scm_t_bits head;
retry_gp:
head = SCM_UNPACK(GP_GETREF(val)[0]);
gp_gc_mark_no_touch(val);
if(!GP_GC_ISCAND(head))
{
GP_GC_CAND(head);
GP_GETREF(val)[0] = SCM_PACK(head);
val = GP_GETREF(val)[1];
if(0 && GP(val))
goto retry_gp;
else
scm_gc_mark(val);
}
else
scm_gc_mark(GP_GETREF(val)[1]);
}
else
scm_gc_mark(*pt);
scm_gc_mark(val);
}
else if(gp_at_newframe(pt))
{
......@@ -415,7 +431,7 @@ inline int gp_at_newframe(SCM *pt)
{
GP_GC_CAND(head);
f[0] = SCM_PACK(head);
gp_gc_mark_no_touch(GP_UNREF(f));
gp_gc_mark_no_touch(GP_UNREF(f));
}
else
scm_gc_mark(GP_UNREF(f));
......@@ -613,6 +629,9 @@ void gp_sweep_handle(SCM in)
{
nrem += 4;
pt[0] = SCM_BOOL_F;
if(SCM_CONSP(pt[-1]) ||SCM_CONSP(pt[-2]) ||SCM_CONSP(pt[-3]))
printf("ERROR 1\n");
pt[-1] = SCM_BOOL_F;
pt[-2] = SCM_BOOL_F;
pt[-3] = SCM_BOOL_F;
......@@ -633,6 +652,8 @@ void gp_sweep_handle(SCM in)
{
SCM_SETCDR(SCM_CDR(*pt), SCM_BOOL_F);
}
if(SCM_CONSP(pt[-1]) ||SCM_CONSP(pt[-2]) ||SCM_CONSP(pt[-3]))
printf("ERROR 2\n");
pt[-1] = SCM_BOOL_F;
pt[-2] = SCM_BOOL_F;
......@@ -644,7 +665,7 @@ void gp_sweep_handle(SCM in)
}
}
printf("sweep1 %d %d\n",n,nrem);
//printf("sweep1 %d %d\n",n,nrem);
{
int vn = 0;
......@@ -672,7 +693,7 @@ void gp_sweep_handle(SCM in)
n = vn;
}
printf("sweep2 %d %d\n",vn,vrem);
//printf("sweep2 %d %d\n",vn,vrem);
}
......@@ -743,7 +764,7 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
gp_no_gc();
if(gp->n > 100 && gp->nrem*4 > gp->n)
{
printf("gc: %d %d\n",gp->n, gp->nrem);
//printf("gc: %d %d\n",gp->n, gp->nrem);
SCM *pt1,*pt2, *pt1_insert, *pt2_insert, *last_redo = gp->gp_cstack,
*last_save = gp->gp_cstack;
......
......@@ -2923,7 +2923,7 @@ static SCM gp_type_mark(SCM obj)
GP_GC_MARK(head);
v[0] = SCM_PACK(head);
scm_gc_mark(v[1]);
return SCM_BOOL_T;
}
......
......@@ -12,9 +12,10 @@ test3(N) :- test3(N,0).
test3(N,X) :- X < N, Y is X + 1, test3(N,Y).
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).
")
(<define> (gl-test m)
(<recur> lp ((n 0))
(when (< n m)
......
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