int equal_p(object o1, object o2) {
if (eqv_p(o1,o2)) return 1;
if (PAIR_P(o1)) {
return PAIR_P(o2)&&equal_p(CAR(o1),CAR(o2))&&equal_p(CDR(o1),CDR(o2));
} else if (VECTOR_P(o1)) {
if (VECTOR_P(o2)) {
long max = VECTOR_LENGTH(o1);
if (max == VECTOR_LENGTH(o2)) {
object *e1 = VECTOR_ELEMENTS(o1), *e2 = VECTOR_ELEMENTS(o2);
long i;
for (i=0; i<max; i++)
if (!equal_p(e1[i],e2[i]))
return 0;
return 1;
}
}
} else if (STRING_P(o1)) {
if (STRING_P(o2)) {
long max = STRING_LENGTH(o1);
if (max == STRING_LENGTH(o2)) {
char *p1 = STRING_VALUE(o1);
char *p2 = STRING_VALUE(o2);
while (*p1 && *p2) {
if (*p1++ != *p2++) return 0;
}
return (*p1 == *p2);
}
}
}
return 0;
}
static void primop_table(long argc) {
if (argc & 1)
error(sp[0], "table requires an even number of arguments");
else {
object *pBindings, tbl = make_table(argc/2);
long i;
pBindings = VECTOR_ELEMENTS(TABLE_BINDINGS(tbl));
for (i=0; i<argc; i++)
*pBindings++ = *sp++;
*--sp = tbl;
}
}
void garbage_collect(long min_space) {
char *p;
object **gcp;
object *op;
long i, max, count;
int old_interrupt;
if (*will_gc_hook) (*will_gc_hook)();
old_interrupt = enable_interrupts(0);
/* switch heap space */
gc_count++;
/* printf("[GC]\n"); */
heap += heap_size;
if (heap >= max_heap)
heap = min_memory;
heap_pointer = heap;
heap_end = heap + heap_size;
/* migrate objects */
count = gc_root_stack_pointer - gc_root_stack_begin;
migrate_object(gc_root_stack_buffer);
if (FORWARDED_P(gc_root_stack_buffer)) gc_root_stack_buffer = FORWARDED_POINTER(gc_root_stack_buffer);
gc_root_stack_begin = (object **)BUFFER_DATA(gc_root_stack_buffer);
gc_root_stack_end = gc_root_stack_begin + GC_ROOT_STACK_MAX;
gc_root_stack_pointer = gc_root_stack_begin + count;
gcp = gc_root_stack_begin;
for (i=0; i<count; i++)
migrate_object(*gcp[i]);
for (op = sp; op < stack_top; op++)
migrate_object(*op);
/* eliminate forwarding pointers */
gcp = gc_root_stack_begin;
for (i=0; i<count; i++) {
object o = *gcp[i];
if (FORWARDED_P(o))
*gcp[i] = FORWARDED_POINTER(o);
}
for (op = sp; op < stack_top; op++) {
object o = *op;
if (FORWARDED_P(o))
*op = FORWARDED_POINTER(o);
}
p = heap;
while (p < heap_pointer) {
object *q, obj, o;
obj = (object)p;
switch (POINTER_TYPE(obj)) {
case PAIR_TYPE:
o = CAR(obj); if (FORWARDED_P(o)) CAR(obj) = FORWARDED_POINTER(o);
o = CDR(obj); if (FORWARDED_P(o)) CDR(obj) = FORWARDED_POINTER(o);
break;
case WEAK_TYPE:
if (FORWARDED_P(WEAK_VALUE(obj))) {
WEAK_BOUND(obj) = 1;
} else {
WEAK_BOUND(obj) = 0;
migrate_object(WEAK_VALUE(obj));
}
o = WEAK_VALUE(obj); if (FORWARDED_P(o)) WEAK_VALUE(obj) = FORWARDED_POINTER(o);
break;
case SYMBOL_TYPE:
o = SYMBOL_VALUE(obj); if (FORWARDED_P(o)) SYMBOL_VALUE(obj) = FORWARDED_POINTER(o);
break;
case VECTOR_TYPE:
max = VECTOR_LENGTH(obj);
q = VECTOR_ELEMENTS(obj);
for (i=0; i<max; i++) {
o = q[i]; if (FORWARDED_P(o)) q[i] = FORWARDED_POINTER(o);
}
o = VECTOR_TAG(obj); if (FORWARDED_P(o)) VECTOR_TAG(obj) = FORWARDED_POINTER(o);
break;
case PROCEDURE_TYPE:
o = PROC_MODULE(obj); if (FORWARDED_P(o)) PROC_MODULE(obj) = FORWARDED_POINTER(o);
break;
case FRAME_TYPE:
o = FRAME_PREVIOUS(obj); if (FORWARDED_P(o)) FRAME_PREVIOUS(obj) = FORWARDED_POINTER(o);
o = FRAME_ENV(obj); if (FORWARDED_P(o)) FRAME_ENV(obj) = FORWARDED_POINTER(o);
max = (POINTER_LENGTH(obj) - sizeof(struct frame_heap_structure))/sizeof(long);
q = FRAME_ELEMENTS(obj);
for (i=0; i<max; i++) {
o = q[i]; if (FORWARDED_P(o)) q[i] = FORWARDED_POINTER(o);
}
break;
case CLOSURE_TYPE:
o = CLOSURE_PROC(obj); if (FORWARDED_P(o)) CLOSURE_PROC(obj) = FORWARDED_POINTER(o);
o = CLOSURE_ENV(obj); if (FORWARDED_P(o)) CLOSURE_ENV(obj) = FORWARDED_POINTER(o);
break;
case CONTINUATION_TYPE:
o = CONTINUATION_FRAME(obj); if (FORWARDED_P(o)) CONTINUATION_FRAME(obj) = FORWARDED_POINTER(o);
max = CONTINUATION_STACKSIZE(obj);
q = CONTINUATION_STACK(obj);
for (i=0; i<max; i++) {
o = q[i]; if (FORWARDED_P(o)) q[i] = FORWARDED_POINTER(o);
}
break;
case SYMBOLTABLE_TYPE:
o = SYMBOLTABLE_MAPPINGS(obj); if (FORWARDED_P(o)) SYMBOLTABLE_MAPPINGS(obj) = FORWARDED_POINTER(o);
break;
case PORT_TYPE:
o = PORT_BUFFER(obj); if (FORWARDED_P(o)) PORT_BUFFER(obj) = FORWARDED_POINTER(o);
break;
default:
fatal_error("Unknown pointer type: heap.c#garbage_collect(): %p\n", obj);
return;
}
p += POINTER_LENGTH(obj);
}
/* finalization of ports */
close_stale_ports();
fix_runtime_pointers();
/* Finish up */
enable_interrupts(old_interrupt);
i = heap_size - (heap_pointer - heap);
if (i < min_space)
fatal_error("out of heap space: %d\n", i);
if (*did_gc_hook) (*did_gc_hook)();
}