Bugfix in parse in parse.scm

parent 73b75994
/usr/local/share/automake-1.13/INSTALL
\ No newline at end of file
This diff is collapsed. Click to expand it.
......@@ -20,6 +20,12 @@ Version 0.4.1
* Fixed bug in stall
Version 0.5, TODO
* Improved parsing tool (guile-log)
- Factorized and enabled for customized streams flow e.g.
current indentation level in python
- f-cons and similar tools for functional AST creation.
- Debug features
* Multi threading capabilities (all)
* Tablating (all)
* Circular datastructures (all)
......
......@@ -63,7 +63,9 @@
(identifier? #'id)
(call-with-values (lambda () (syntax-local-binding #'id))
(lambda (type value)
`(tester ,type ,value)
(let ((i (syntax->datum #'id)))
(if (eq? i '<let-with-lr-guard>)
`(tester ,type ,value ,#'id)))
(case type
((macro)
(hash-ref table value #f))
......@@ -108,7 +110,8 @@
(syntax-case x (quote)
((_ (quote x))
#'(eval-when (compile load eval)
(begin (log-code-macro! 'x) #f)))
(begin
(log-code-macro! 'x) #f)))
((_ x)
#'(log-code-macro 'x)))))
......
......@@ -497,7 +497,7 @@
(clear-tokens)
(<run> 1 (cout)
(<values> (x xl . l)
(matcher '() (make-file-reader) Init ... _))
(matcher '() (make-file-reader) NI MI Init ... _))
(<code> (print-last-line xl))
(<=> cout ,(car (reverse l))))))))
......@@ -744,4 +744,4 @@
;; Creating the standard parser
(setup-parser <p-define> <p-lambda> <fail> <p-cc> <succeds> .. xx
X XL ((N 0) (M 0))
s-false s-true s-mk-seq s-mk-and s-mk-or)
\ No newline at end of file
s-false s-true s-mk-seq s-mk-and s-mk-or)
......@@ -37,6 +37,12 @@ void *gp_after_mark_hook(void *hook_data, void *fn_data, void *data)
pthread_mutex_lock(&gp_gc_lock);
if(gp_gc_p)
{
gp_clear_marks(SCM_CAR(pt));
while(SCM_CONSP(pt))
{
gp_clear_marks(SCM_CAR(pt));
pt = SCM_CDR(pt);
}
pthread_mutex_unlock(&gp_gc_lock);
return (void *)0;
}
......@@ -44,6 +50,7 @@ void *gp_after_mark_hook(void *hook_data, void *fn_data, void *data)
while(SCM_CONSP(pt))
{
gp_sweep_handle(SCM_CAR(pt));
gp_clear_marks(SCM_CAR(pt));
pt = SCM_CDR(pt);
}
pthread_mutex_unlock(&gp_gc_lock);
......@@ -51,10 +58,33 @@ void *gp_after_mark_hook(void *hook_data, void *fn_data, void *data)
return (void *)0;
}
void *gp_before_mark_hook(void *hook_data, void *fn_data, void *data)
{
SCM pt = scm_fluid_ref(gp_stacks);
pthread_mutex_lock(&gp_gc_lock);
if(gp_gc_p)
{
pthread_mutex_unlock(&gp_gc_lock);
return (void *)0;
}
while(SCM_CONSP(pt))
{
gp_clear_marks(SCM_CAR(pt));
pt = SCM_CDR(pt);
}
pthread_mutex_unlock(&gp_gc_lock);
return (void *)0;
}
void init_gpgc()
{
const int appendp = 0;
void *data = (void *) 0;
scm_c_hook_add(&scm_after_gc_c_hook, gp_after_mark_hook, data, appendp);
scm_c_hook_add(&scm_before_gc_c_hook, gp_before_mark_hook, data, appendp);
}
#define gp_N2 100000
#define gp_N3 100000
struct GC_ms_entry *gp_stack_mark(SCM pt,
struct GC_ms_entry *ptr,
struct GC_ms_entry *limit);
scm_t_bits gp_stack_type;
#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))
struct gp_stack
......@@ -47,11 +52,12 @@ struct gp_stack
#define GP_TEST_STACK if(gp->gp_si > gp->gp_nns) scm_out_of_range(NULL, SCM_I_MAKINUM(gp->gp_ns))
#define GET_GP(scm) ((struct gp_stack *) GP_GETREF(scm)[1])
static inline struct gp_stack *get_gp()
{
SCM gp = scm_fluid_ref(gp_current_stack);
if(GP_STACKP(gp))
return (struct gp_stack *) SCM_SMOB_DATA(gp);
return (struct gp_stack *) GET_GP(gp);
scm_misc_error("get_gp","could not find stacks",SCM_EOL);
......@@ -69,7 +75,7 @@ static inline SCM *get_gp_var(struct gp_stack *gp)
gp->gp_si[0] = cand;
}
gp->gp_si ++;
GP_GETREF(cand)[0] = SCM_PACK(GP_MK_FRAME_EQ(gp_type));
return GP_GETREF(cand);
}
......@@ -177,9 +183,8 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, int ncs, s
{
int i;
*ggp =
(struct gp_stack *) scm_gc_malloc_pointerless(sizeof(struct gp_stack),"struct gp_stack");
*ggp = (struct gp_stack *) scm_gc_malloc_pointerless(sizeof(struct gp_stack),"struct gp_stack");
struct gp_stack *gp = *ggp;
if(!gp) goto error1;
......@@ -246,8 +251,10 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, int ncs, s
gp->thread_id = nthread;
gp->nrem = 0;
gp->n = 0;
SCM ret;
SCM_NEWSMOB(ret, gp_stack_type, (void*)0);
SCM ret = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell),
gp_variable_gc_kind));
GP_GETREF(ret)[0] = SCM_PACK(gp_stack_type);
GP_GETREF(ret)[1] = GP_UNREF((SCM *) gp);
for(i = 0; i < gp->gp_ncs; i++)
......@@ -376,21 +383,29 @@ inline int gp_at_newframe(SCM *pt)
}
static SCM gp_stack_mark0(SCM obj, int unlocked)
#define GC_MARK(x) (mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (x), mark_stack_ptr, mark_stack_limit, NULL))
#define GC_MARK_NT(x) (mark_stack_ptr = GC_MARK_AND_PUSH_NO_TOUCH (SCM2PTR (x), mark_stack_ptr, mark_stack_limit, NULL))
static struct GC_ms_entry *
gp_stack_mark0(SCM obj, int unlocked,
struct GC_ms_entry *mark_stack_ptr,
struct GC_ms_entry *mark_stack_limit)
{
struct gp_stack *gp = (struct gp_stack *) SCM_SMOB_DATA(obj);
struct gp_stack *gp = GET_GP(obj);
int i;
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));
//printf("mark\n");
GC_MARK(GP_UNREF((SCM *) gp));
GC_MARK(GP_UNREF(gp->gp_cstack));
GC_MARK(GP_UNREF(gp->gp_stack));
GC_MARK(GP_UNREF(gp->gp_cons_stack));
scm_gc_mark(gp->gp_cstack[0]);
scm_gc_mark(gp->gp_cstack[1]);
scm_gc_mark(gp->gp_cstack[2]);
scm_gc_mark(gp->gp_cstack[3]);
GC_MARK(gp->gp_cstack[0]);
GC_MARK(gp->gp_cstack[1]);
GC_MARK(gp->gp_cstack[2]);
GC_MARK(gp->gp_cstack[3]);
scm_gc_mark(gp->gp_stack[0]);
GC_MARK(gp->gp_stack[0]);
for(i=0;i < gp->gp_ci - gp->gp_cstack; i++)
{
......@@ -403,27 +418,29 @@ inline int gp_at_newframe(SCM *pt)
if(unlocked && i >= 4)
{
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]);
GP_GC_CAND(head);
GP_GETREF(val)[0] = SCM_PACK(head);
//printf("NTMARK(%p)\n",SCM_UNPACK(val));
GC_MARK_NT(val);
GC_MARK(GP_GETREF(val)[1]);
/*
val = GP_GETREF(val)[1];
retry:
if(GP(val))
{
head = SCM_UNPACK(GP_GETREF(val)[0]);
GP_GETREF(val)[0] = SCM_PACK(head);
GC_MARK_NT(val);
val = GP_GETREF(val)[1];
goto retry;
}
else
GC_MARK(val);
*/
}
else
scm_gc_mark(val);
GC_MARK(val);
}
else if(gp_at_newframe(pt))
{
......@@ -433,16 +450,16 @@ inline int gp_at_newframe(SCM *pt)
{
GP_GC_CAND(head);
f[0] = SCM_PACK(head);
gp_gc_mark_no_touch(GP_UNREF(f));
GC_MARK_NT(GP_UNREF(f));
}
else
scm_gc_mark(GP_UNREF(f));
GC_MARK(GP_UNREF(f));
if(SCM_CONSP(*pt))
scm_gc_mark(*pt);
GC_MARK(*pt);
}
else
scm_gc_mark(*pt);
GC_MARK(*pt);
}
}
......@@ -456,10 +473,10 @@ inline int gp_at_newframe(SCM *pt)
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);
GC_MARK_NT(*pt);
}
else
scm_gc_mark(*pt);
GC_MARK(*pt);
}
}
......@@ -468,15 +485,15 @@ inline int gp_at_newframe(SCM *pt)
SCM *pt = gp->gp_stack + i;
if(GP(*pt))
{
scm_gc_mark(*pt);
GC_MARK(*pt);
}
}
scm_gc_mark(gp->dynstack);
scm_gc_mark(gp->rguards);
scm_gc_mark(gp->handlers);
GC_MARK(gp->dynstack);
GC_MARK(gp->rguards);
GC_MARK(gp->handlers);
return SCM_BOOL_T;
return mark_stack_ptr;
}
#define QQ(x) SCM_PACK(((scm_t_bits) x)*4+2)
......@@ -581,17 +598,73 @@ SCM_DEFINE(gp_make_stack, "gp-make-stack", 5, 0, 0,
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
static inline int is_advanced_tag(SCM *pt);
void gp_clear_marks(SCM in)
{
struct gp_stack *gp = GET_GP(in);
SCM *pt;
//printf("clear\n");
// Search for the first newframe stored
for(pt = gp->gp_ci - 1; pt >= gp->gp_cstack + 4; pt--)
{
if(GP(*pt))
{
SCM val = *pt;
scm_t_bits head = SCM_UNPACK(GP_GETREF(val)[0]);
if(!(!GP_GC_ISMARKED(head) && GP_GC_ISCAND(head)))
{
GP_GC_CLEAR(head);
GP_GC_CLEARCAND(head);
GP_GETREF(val)[0] = SCM_PACK(head);
}
continue;
}
// Stop when we find the first newframe mark in the control stack
if(gp_at_newframe(pt))
{
SCM *f = get_ci_f(pt + 1);
scm_t_bits head = SCM_UNPACK(f[0]);
if(!(!GP_GC_ISMARKED(head) && GP_GC_ISCAND(head)))
{
GP_GC_CLEAR(head);
GP_GC_CLEARCAND(head);
f[0] = SCM_PACK(head);
}
pt -= 3;
continue;
}
}
//printf("sweep1 %d %d\n",n,nrem);
{
for(pt = gp->gp_stack; pt < gp->gp_nns; pt++)
{
if(GP(*pt))
{
SCM *f = GP_GETREF(*pt);
scm_t_bits head = SCM_UNPACK(f[0]);
if(pt >= gp->gp_si)
f[1] = SCM_UNBOUND;
GP_GC_CLEAR(head);
GP_GC_CLEARCAND(head);
f[0] = SCM_PACK(head);
}
}
}
}
void gp_sweep_handle(SCM in)
{
struct gp_stack *gp = (struct gp_stack *) SCM_SMOB_DATA(in);
struct gp_stack *gp = GET_GP(in);
int nrem = 0;
int n = 0;
SCM *pt;
// Search for the first newframe stored
......@@ -679,12 +752,8 @@ void gp_sweep_handle(SCM in)
{
SCM *f = GP_GETREF(*pt);
scm_t_bits head = SCM_UNPACK(f[0]);
if(!(!GP_GC_ISMARKED(head) && GP_GC_ISCAND(head)))
{
GP_GC_CLEAR(head);
GP_GC_CLEARCAND(head);
f[0] = SCM_PACK(head);
}
if(!GP_GC_ISMARKED(head) && GP_GC_ISCAND(head))
vrem++;
}
}
......@@ -697,20 +766,6 @@ void gp_sweep_handle(SCM in)
//printf("sweep2 %d %d\n",vn,vrem);
}
for(;pt < gp->gp_nns; pt++)
{
if(GP(*pt))
{
SCM *f = GP_GETREF(*pt);
scm_t_bits head = SCM_UNPACK(f[0]);
GP_GC_CLEAR(head);
GP_GC_CLEARCAND(head);
f[0] = SCM_PACK(head);
}
}
gp->n = n;
gp->nrem = nrem;
......@@ -718,34 +773,29 @@ void gp_sweep_handle(SCM in)
#include "gc.c"
static SCM gp_stack_mark(SCM obj)
struct GC_ms_entry *gp_stack_mark(SCM pt,
struct GC_ms_entry *ptr,
struct GC_ms_entry *limit)
{
SCM pt = scm_fluid_ref(gp_stacks);
SCM ret = SCM_BOOL_F;
struct GC_ms_entry * ret;
pthread_mutex_lock(&gp_gc_lock);
if(gp_gc_p)
{
ret = gp_stack_mark0(obj,0);
ret = gp_stack_mark0(pt,0,ptr,limit);
pthread_mutex_unlock(&gp_gc_lock);
return ret;
}
while(SCM_CONSP(pt))
{
ret = gp_stack_mark0(obj,1);
pt = SCM_CDR(pt);
}
pthread_mutex_unlock(&gp_gc_lock);
ret = gp_stack_mark0(pt,1,ptr,limit);
pthread_mutex_unlock(&gp_gc_lock);
return ret;
}
static void gp_module_stack_init()
{
gp_stack_type = scm_make_smob_type("unify-stacks",0);
scm_set_smob_mark(gp_stack_type, gp_stack_mark);
scm_set_smob_print(gp_stack_type,gp_stack_printer);
}
......@@ -919,7 +969,6 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
macro;
gp->gp_si = pt2_insert;
}
printf("gc finished\n");fflush(stdout);
}
gp->n = 0;
......
......@@ -327,7 +327,10 @@ static inline void gp_unwind0(SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
state = gp_do_cons(*i, state, &old, gp_unbd);
continue;
}
if(GP(*i) && gp_is_free(i))
*i = SCM_BOOL_F;
if(scm_is_false(*i))
{
if(state == gp_redo)
......
......@@ -232,16 +232,21 @@ scm_t_bits gp_smob_t;
#define H_BITS 36
#define GP_GC_MARK(x) (x = ((x) | GPI_SCM_M))
#define GP_GC_MARK(x) ((x) = ((x) | GPI_SCM_M))
#define GP_GC_ISMARKED(x) ((x) & GPI_SCM_M)
#define GP_GC_CLEAR(x) ((x) = (x) & ~(GPI_SCM_M))
#define GP_GC_CAND(x) (x = ((x) | GPI_SCM_C))
#define GP_GC_CAND(x) ((x) = ((x) | GPI_SCM_C))
#define GP_GC_ISCAND(x) ((x) & GPI_SCM_C)
#define GP_GC_CLEARCAND(x) ((x) = (x) & ~(GPI_SCM_C))
#define GP_GC_QAND(x) (x = ((x) | GPI_SCM_Q))
#define GP_GC_QAND(x) ((x) = ((x) | GPI_SCM_Q))
#define GP_GC_ISQAND(x) ((x) & GPI_SCM_Q)
#define GP_GC_CLEARQAND(x) ((x) = (x) & ~(GPI_SCM_Q))
inline int gp_is_free(SCM *pt)
{
scm_t_bits head = SCM_UNPACK(GP_GETREF(*pt)[0]);
return (!GP_GC_ISMARKED(head) && GP_GC_ISCAND(head));
}
inline static SCM GP_IT(SCM* id)
{
......@@ -309,7 +314,7 @@ static inline SCM gp_make_closure_heap(int n, SCM **closure)
a = scm_fluid_ref(gp_current_stack); \
if(!GP_STACKP(a)) \
scm_misc_error("unpack_s2",err,SCM_EOL); \
gp = (struct gp_stack *) SCM_SMOB_DATA(a); \
gp = GET_GP(a); \
gp_debug0(err); \
if(!SCM_CONSP(s)) \
{ \
......@@ -343,7 +348,7 @@ static inline SCM gp_make_closure_heap(int n, SCM **closure)
ggp = scm_fluid_ref(gp_current_stack); \
if(!GP_STACKP(ggp)) \
scm_misc_error("unpack_a2",err,SCM_EOL); \
gp = (struct gp_stack *) SCM_SMOB_DATA(ggp); \
gp = GET_GP(ggp); \
if(!SCM_CONSP(s)) \
{ \
ci = PTR2NUM(gp->gp_ci); \
......@@ -361,7 +366,7 @@ static inline SCM gp_make_closure_heap(int n, SCM **closure)
ggp = scm_fluid_ref(gp_current_stack); \
if(!GP_STACKP(ggp)) \
scm_misc_error("unpack_a2",err,SCM_EOL); \
gp = (struct gp_stack *) SCM_SMOB_DATA(ggp); \
gp = GET_GP(ggp); \
if(!SCM_CONSP(s)) \
{ \
l = SCM_EOL; \
......@@ -377,7 +382,7 @@ static inline SCM gp_make_closure_heap(int n, SCM **closure)
ggp = scm_fluid_ref(gp_current_stack); \
if(!GP_STACKP(ggp)) \
scm_misc_error("unpack_a2",err,SCM_EOL); \
gp = (struct gp_stack *) SCM_SMOB_DATA(ggp); \
gp = GET_GP(ggp); \
}
#define PACK_ALL(ci,l,lnew,gp,s) \
......@@ -898,7 +903,12 @@ static inline SCM gp_mk_cons(SCM s)
struct gp_stack *gp;
gp = get_gp();
if(1 || gp->_logical_) return scm_cons(make_logical(),make_logical());
if(1 || gp->_logical_)
{
SCM x = make_logical();
SCM y = make_logical();
return scm_cons(x, y);
}
......
......@@ -14,14 +14,35 @@ gp_mark_variable (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
cell = PTR2SCM (addr);
if (SCM_TYP7 (cell) != scm_tc7_smob)
if (!SCM_NIMP(cell) || SCM_TYP7 (cell) != scm_tc7_smob)
/* It is likely that the GC passed us a pointer to a free-list element
which we must ignore (see warning in `gc/gc_mark.h'). */
return mark_stack_ptr;
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_1 (cell)),
mark_stack_ptr,
mark_stack_limit, NULL);
if(SCM_SMOB_PREDICATE(gp_stack_type,cell))
{
mark_stack_ptr = gp_stack_mark(cell, mark_stack_ptr, mark_stack_limit);
}
else
{
SCM x = SCM_CELL_OBJECT_1 (cell);
/*
int i = 0, j = 0, k = 0;
printf("%p\n",SCM_UNPACK(x));fflush(stdout);
if(x && !(SCM_UNPACK(x)&1) && GP(x))
i = 1;
if(i && GP_GC_ISMARKED(SCM_UNPACK(GP_GETREF(x)[0])))
j = 1;
if(GP_GC_ISMARKED(SCM_UNPACK(GP_GETREF(cell)[0])))
k = 1;
*/
//printf("pushing val of [%p] %d {%p} %d %d\n", SCM_UNPACK(cell), k, SCM_UNPACK(x), i, j);
fflush(stdout);
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (x),
mark_stack_ptr,
mark_stack_limit, NULL);
}
return mark_stack_ptr;
}
#endif
......@@ -49,32 +70,6 @@ SCM gp_make_variable()
#endif
}
void
gp_gc_mark_no_touch (SCM o)
{
#ifdef GP_USE_GC_MOCK
if (SCM_NIMP (o))
{
void *mark_stack_ptr, *mark_stack_limit;
mark_stack_ptr = NULL;
mark_stack_limit = NULL;
GC_MARK_AND_PUSH_NO_TOUCH
(SCM2PTR (o),
mark_stack_ptr, mark_stack_limit,
NULL);
}
#else
{ // Mark the byte to prvent gc in the finalizer
SCM *v = GP_GETREF(o);
scm_t_bits head = SCM_UNPACK(v[0]);
GP_GC_QAND(head);
v[0] = SCM_PACK(head);
}
#endif
}
void init_variables()
{
#ifdef GP_USE_GC_MOCK
......
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