BOOLEAN is_dynamic_memory_object(OBJECT_PTR obj)
{
return IS_CONS_OBJECT(obj) ||
IS_ARRAY_OBJECT(obj) ||
IS_CLOSURE_OBJECT(obj) ||
IS_MACRO_OBJECT(obj) ||
IS_CONTINUATION_OBJECT(obj) ||
IS_INTEGER_OBJECT(obj) ||
IS_FLOAT_OBJECT(obj) ||
IS_NATIVE_FN_OBJECT(obj) ||
IS_FUNCTION2_OBJECT(obj) ||
IS_MACRO2_OBJECT(obj);
}
BOOLEAN is_permitted_in_debug_mode(OBJECT_PTR exp)
{
if(IS_CONS_OBJECT(exp))
{
OBJECT_PTR car_obj = car(exp);
if(IS_SYMBOL_OBJECT(car_obj))
{
return (car_obj == RESUME) ||
(car_obj == ENV) ||
(car_obj == BACKTRACE) ||
(car_obj == CREATE_IMAGE) ||
(car_obj == ABORT);
}
return false;
}
else
return IS_SYMBOL_OBJECT(exp);
}
OBJECT_PTR eval_backquote(OBJECT_PTR form)
{
OBJECT_PTR car_obj;
assert(is_valid_object(form));
if(is_atom(form))
return form;
car_obj = car(form);
assert(is_valid_object(car_obj));
if(IS_SYMBOL_OBJECT(car_obj))
{
char buf[SYMBOL_STRING_SIZE];
print_symbol(car_obj, buf);
if(car_obj == COMMA)
{
OBJECT_PTR temp = compile(CADR(form), NIL);
#ifdef WIN32
if(temp == ERROR1)
#else
if(temp == ERROR)
#endif
{
throw_generic_exception("Backquote evaluation(1): compile failed");
return NIL;
}
reg_next_expression = cons(cons(FRAME, cons(cons(CONS_HALT_NIL, CADR(form)),
cons(temp, CADR(form)))),
CADR(form));
reg_current_value_rib = NIL;
while(car(reg_next_expression) != NIL)
{
//print_object(car(reg_next_expression));printf("\n");getchar();
eval(false);
if(in_error)
{
throw_generic_exception("Evaluation of backquote failed(1)");
return NIL;
}
}
reg_next_expression = cons(CONS_RETURN_NIL, cdr(reg_next_expression));
reg_current_value_rib = NIL;
return reg_accumulator;
}
}
if(form_contains_comma_at(form))
{
//1. loop through elements in form
//2. if element is not comma-at, call eval_backquote on
// it and append it to the result list without splicing
//3. if it is comma-at, get its symbol value and
// splice the value to the result list
//4. return the result list
OBJECT_PTR result = NIL;
OBJECT_PTR rest = form;
while(rest != NIL)
{
OBJECT_PTR ret;
OBJECT_PTR obj;
if(IS_CONS_OBJECT(car(rest)) &&
IS_SYMBOL_OBJECT(CAAR(rest)))
{
char buf[SYMBOL_STRING_SIZE];
print_symbol(CAAR(rest), buf);
if(CAAR(rest) == COMMA_AT)
{
OBJECT_PTR temp = compile(CADAR(rest), NIL);
#ifdef WIN32
if(temp == ERROR1)
#else
if(temp == ERROR)
#endif
{
throw_generic_exception("Backquote evaluation(2): compile failed");
return NIL;
}
reg_next_expression = cons(cons(FRAME, cons(cons(CONS_HALT_NIL, CADAR(rest)),
cons(temp, CADAR(rest)))),
CADAR(rest));
reg_current_value_rib = NIL;
while(car(reg_next_expression) != NIL)
{
eval(false);
if(in_error)
{
throw_generic_exception("Evaluation of backquote failed(2)");
return NIL;
}
}
reg_next_expression = cons(CONS_RETURN_NIL, cdr(reg_next_expression));
reg_current_value_rib = NIL;
obj = reg_accumulator;
if(result == NIL)
result = obj;
else
set_heap(last_cell(result) & POINTER_MASK, 1, obj);
}
else
{
obj = eval_backquote(car(rest));
if(result == NIL)
result = cons(obj, NIL);
else
set_heap(last_cell(result) & POINTER_MASK, 1, cons(obj, NIL));
}
}
else
{
obj = eval_backquote(car(rest));
if(result == NIL)
result = cons(obj, NIL);
else
set_heap(last_cell(result) & POINTER_MASK, 1, cons(obj, NIL));
}
rest = cdr(rest);
}
return result;
}
return cons(eval_backquote(car(form)),
eval_backquote(cdr(form)));
}
void gc_orig(BOOLEAN force, BOOLEAN clear_black)
{
static unsigned long count = 0;
if(!can_do_gc)
return;
//no new objects were created since the
//last GC cycle, so nothing to do.
if(is_set_empty(WHITE))
return;
//do GC every GC_FREQUENCYth time called
if((count % GC_FREQUENCY) != 0)
return;
//printf("Entering GC cycle... ");
unsigned int dealloc_words = memory_deallocated();
//assert(is_set_empty(GREY));
build_grey_set();
assert(!is_set_empty(GREY));
while(!is_set_empty(GREY))
{
OBJECT_PTR obj = get_an_object_from_grey();
assert(is_dynamic_memory_object(obj));
//FUNCTION2 and MACRO2 objects are handled
//by handling their undelying CONS objects
if(!IS_FUNCTION2_OBJECT(obj) && !IS_MACRO2_OBJECT(obj))
insert_node(BLACK, obj);
remove_node(GREY, obj);
if(IS_CONS_OBJECT(obj))
{
move_from_white_to_grey(car(obj));
move_from_white_to_grey(cdr(obj));
}
else if(IS_CLOSURE_OBJECT(obj) || IS_MACRO_OBJECT(obj))
{
move_from_white_to_grey(get_env_list(obj));
move_from_white_to_grey(get_params_object(obj));
move_from_white_to_grey(get_body_object(obj));
move_from_white_to_grey(get_source_object(obj));
}
else if(IS_ARRAY_OBJECT(obj))
{
uintptr_t ptr = extract_ptr(obj);
//OBJECT_PTR length_obj = get_heap(ptr, 0);
//move_from_white_to_grey(length_obj);
//int len = get_int_value(length_obj);
int len = *((OBJECT_PTR *)ptr);
int i;
for(i=1; i<=len; i++)
move_from_white_to_grey(get_heap(ptr, i));
}
else if(IS_CONTINUATION_OBJECT(obj))
move_from_white_to_grey(get_heap(extract_ptr(obj), 0));
else if(IS_FUNCTION2_OBJECT(obj) || IS_MACRO2_OBJECT(obj))
{
OBJECT_PTR cons_equiv = cons_equivalent(obj);
//move_from_white_to_grey(car(cons_equiv));
//move_from_white_to_grey(cdr(cons_equiv));
move_from_white_to_grey(cons_equiv);
}
} //end of while(!is_set_empty(GREY))
free_white_set_objects();
assert(is_set_empty(GREY));
assert(is_set_empty(WHITE));
assert(!is_set_empty(BLACK));
/* if(clear_black) */
/* recreate_black(); */
/* if(clear_black) */
/* assert(is_set_empty(BLACK)); */
//printf("%d words deallocated in current GC cycle\n", memory_deallocated() - dealloc_words);
}