/* "Cons" operation */
long
l_cons(long car, long cdr)
{
int s;
if (t_cons_free < 0){ /* no cons cells */
if (gc_protect(car) < 0)
return -1;
if (gc_protect(cdr) < 0)
return -1;
gcollect(); /* invoke garbage collector */
gc_unprotect(cdr);
gc_unprotect(car);
}
/* get a free cons cell from a free list */
s = t_cons_free;
if (t_cons_car[t_cons_free] != t_cons_free)
t_cons_free = t_cons_car[t_cons_free]; /* next free cell */
else
t_cons_free = -1; /* self-loop: end of free list */
/* constract a new cell */
t_cons_car[s] = car;
t_cons_cdr[s] = cdr;
return (TAG_CONS | s);
}
/* Evaluate arguments */
long
eval_args(long func, long arg, long av[2], int n)
{
long x, y;
if ((n != FTYPE_ANY_ARGS) && (n != list_len(arg)))
return err_msg(errmsg_ill_nargs, 1, func);
switch (n){
case 0:
av[0] = TAG_NIL;
break;
case 1:
if ((av[0] = l_eval(l_car(arg))) < 0)
return -1;
break;
case 2:
if ((av[0] = l_eval(l_car(arg))) < 0)
return -1;
if (gc_protect(av[0]) < 0)
return -1;
if ((av[1] = l_eval(l_car(l_cdr(arg)))) < 0)
return -1;
gc_unprotect(av[0]);
break;
case FTYPE_ANY_ARGS: /* return evaluated arguments as a list */
if (D_GET_TAG(arg) != TAG_CONS){
av[0] = TAG_NIL;
} else {
if ((x = l_eval(l_car(arg))) < 0)
return -1;
if ((av[0] = y = l_cons(x, TAG_NIL)) < 0)
return -1;
if (gc_protect(av[0]) < 0)
return -1;
for (arg = l_cdr(arg); D_GET_TAG(arg) == TAG_CONS; arg = l_cdr(arg)){
if ((x = l_eval(l_car(arg))) < 0)
return -1;
rplacd(y, l_cons(x, TAG_NIL));
y = l_cdr(y);
}
gc_unprotect(av[0]);
}
}
return av[0];
}
struct RBasic*
mrb_obj_alloc(mrb_state *mrb, enum mrb_vtype ttype, struct RClass *cls)
{
struct RBasic *p;
#ifdef MRB_GC_STRESS
mrb_garbage_collect(mrb);
#endif
if (mrb->gc_threshold < mrb->live) {
mrb_incremental_gc(mrb);
}
if (mrb->free_heaps == NULL) {
add_heap(mrb);
}
p = mrb->free_heaps->freelist;
mrb->free_heaps->freelist = ((struct free_obj*)p)->next;
if (mrb->free_heaps->freelist == NULL) {
unlink_free_heap_page(mrb, mrb->free_heaps);
}
mrb->live++;
gc_protect(mrb, p);
memset(p, 0, sizeof(RVALUE));
p->tt = ttype;
p->c = cls;
paint_partial_white(mrb, p);
return p;
}
/* Compile a string */
void compile_string(compiler_type *comp_void, char *str, bool include_baselib) {
compiler_core_type *compiler = (compiler_core_type *)comp_void;
ins_stream_type *baselib = 0; /* TODO: should be gc root */
char path[PATH_MAX];
/* Actually parse the input stream. */
yylex_init_extra(compiler, &(compiler->scanner));
yy_scan_string(str, compiler->scanner);
/* TODO: Need a better way to handle GC than leaking */
gc_protect(compiler->gc);
/* Inject include for base library */
if (include_baselib) {
strcpy(path, compiler->home);
strcat(path, "/lib/baselib.scm");
STREAM_NEW(baselib, string, path);
setup_include(compiler, baselib);
}
parse_internal(compiler, compiler->scanner);
gc_unprotect(compiler->gc);
yylex_destroy(compiler->scanner);
}
obj_ptr global_env(void)
{
static obj_ptr _global = 0;
if (!_global)
{
obj_ptr o;
_global = CONS(obj_alloc_map(), NIL);
gc_protect(_global);
_env_add_primitive(_global, "+", _add);
_env_add_primitive(_global, "*", _mul);
_env_add_primitive(_global, "-", _sub);
_env_add_primitive(_global, "/", _div);
_env_add_primitive1(_global, "floor", _floor);
_env_add_primitive1(_global, "++", _increment);
_env_add_primitive1(_global, "--", _decrement);
_env_add_primitive2(_global, "%", _mod);
_env_add_primitive(_global, "<", _lt);
_env_add_primitive(_global, "<=", _lte);
_env_add_primitive(_global, ">", _gt);
_env_add_primitive(_global, ">=", _gte);
_env_add_primitive(_global, "=", _e);
_env_add_primitive2(_global, "cons", _cons);
_env_add_primitive1(_global, "car", _car);
_env_add_primitive1(_global, "cdr", _cdr);
_env_add_primitive1(_global, "null?", _nullp);
_env_add_primitive0(_global, "gc", _gc);
_env_add_primitive1(_global, "load", _load);
_env_add_primitive0(_global, "quit", _quit);
_env_add_primitive(_global, "vec-alloc", _vec_alloc);
_env_add_primitive(_global, "vec-add", _vec_add);
_env_add_primitive1(_global, "vec-length", _vec_length);
_env_add_primitive1(_global, "vec-clear", _vec_clear);
_env_add_primitive2(_global, "vec-get", _vec_get);
_env_add_primitive3(_global, "vec-set", _vec_set);
_env_add_primitive0(_global, "map-alloc", _map_alloc);
_env_add_primitive3(_global, "map-add", _map_add);
_env_add_primitive1(_global, "map-clear", _map_clear);
_env_add_primitive1(_global, "map-size", _map_size);
_env_add_primitive(_global, "map-find", _map_find);
_env_add_primitive2(_global, "map-delete", _map_delete);
_env_add_primitive1(_global, "map-keys", _map_keys);
_env_add_primitive1(_global, "display", _display);
o = _load_imp("prelude.ang", _global);
if (ERRORP(o)) /* TODO */
{
port_ptr p = port_open_stdout();
obj_print(o, p);
port_close(p);
}
}
return _global;
}
struct RBasic*
mrb_obj_alloc(mrb_state *mrb, enum mrb_vtype ttype, struct RClass *cls)
{
struct RBasic *p;
static const RVALUE RVALUE_zero = { { { MRB_TT_FALSE } } };
#ifdef MRB_GC_STRESS
mrb_full_gc(mrb);
#endif
if (mrb->gc_threshold < mrb->live) {
mrb_incremental_gc(mrb);
}
if (mrb->free_heaps == NULL) {
add_heap(mrb);
}
p = mrb->free_heaps->freelist;
mrb->free_heaps->freelist = ((struct free_obj*)p)->next;
if (mrb->free_heaps->freelist == NULL) {
unlink_free_heap_page(mrb, mrb->free_heaps);
}
mrb->live++;
gc_protect(mrb, p);
*(RVALUE *)p = RVALUE_zero;
p->tt = ttype;
p->c = cls;
paint_partial_white(mrb, p);
return p;
}
/**** Interpreter Initialization and Shutdown */
static void init_base_scheme_objects(void)
{
size_t ii;
gc_protect(_T("trap-handlers"), interp.trap_handlers, TRAP_LAST + 1);
for(ii = 0; ii < TRAP_LAST; ii++)
interp.trap_handlers[ii] = NIL;
gc_protect(_T("startup-args"), &interp.startup_args, 1);
gc_protect(_T("control-fields"), interp.control_fields, sizeof(interp.control_fields) / sizeof(interp.control_fields[0]));
gc_protect(_T("internal-files"), &interp.internal_files, 1);
interp.subr_table = hashcons(false);
gc_protect(_T("subr-table"), &interp.subr_table, 1);
}
struct object *
pic_obj_alloc(pic_state *pic, int type)
{
struct object *obj;
obj = pic_obj_alloc_unsafe(pic, type);
gc_protect(pic, obj);
return obj;
}
pic_value
pic_protect(pic_state *pic, pic_value v)
{
if (! obj_p(pic, v))
return v;
gc_protect(pic, obj_ptr(pic, v));
return v;
}
void obj_startup(void)
{
gc_startup();
/* Globals (), #t and #f are allocated on the GC heap
to simplify tracing. Of course, they are protected! */
_obj_nil = gc_alloc();
_obj_nil->type = TYPE_NIL;
gc_protect(_obj_nil);
_obj_true = gc_alloc();
_obj_true->type = TYPE_BOOL;
INT(_obj_true) = 1;
gc_protect(_obj_true);
_obj_false = gc_alloc();
_obj_false->type = TYPE_BOOL;
INT(_obj_false) = 0;
gc_protect(_obj_false);
}
MRB_API struct RBasic*
mrb_obj_alloc(mrb_state *mrb, enum mrb_vtype ttype, struct RClass *cls)
{
struct RBasic *p;
static const RVALUE RVALUE_zero = { { { MRB_TT_FALSE } } };
mrb_gc *gc = &mrb->gc;
if (cls) {
enum mrb_vtype tt;
switch (cls->tt) {
case MRB_TT_CLASS:
case MRB_TT_SCLASS:
case MRB_TT_MODULE:
case MRB_TT_ENV:
break;
default:
mrb_raise(mrb, E_TYPE_ERROR, "allocation failure");
}
tt = MRB_INSTANCE_TT(cls);
if (tt != MRB_TT_FALSE &&
ttype != MRB_TT_SCLASS &&
ttype != MRB_TT_ICLASS &&
ttype != MRB_TT_ENV &&
ttype != tt) {
mrb_raisef(mrb, E_TYPE_ERROR, "allocation failure of %S", mrb_obj_value(cls));
}
}
#ifdef MRB_GC_STRESS
mrb_full_gc(mrb);
#endif
if (gc->threshold < gc->live) {
mrb_incremental_gc(mrb);
}
if (gc->free_heaps == NULL) {
add_heap(mrb, gc);
}
p = gc->free_heaps->freelist;
gc->free_heaps->freelist = ((struct free_obj*)p)->next;
if (gc->free_heaps->freelist == NULL) {
unlink_free_heap_page(gc, gc->free_heaps);
}
gc->live++;
gc_protect(mrb, gc, p);
*(RVALUE *)p = RVALUE_zero;
p->tt = ttype;
p->c = cls;
paint_partial_white(gc, p);
return p;
}
ZEND_API ZEND_COLD void _zend_bailout(const char *filename, uint32_t lineno) /* {{{ */
{
if (!EG(bailout)) {
zend_output_debug_string(1, "%s(%d) : Bailed out without a bailout address!", filename, lineno);
exit(-1);
}
gc_protect(1);
CG(unclean_shutdown) = 1;
CG(active_class_entry) = NULL;
CG(in_compilation) = 0;
EG(current_execute_data) = NULL;
LONGJMP(*EG(bailout), FAILURE);
}
/* test functions */
void f(void) {
object *obj;
object *list;
gc_protect(&obj);
obj = make_pair(100, NULL);
obj = make_pair(200, obj);
obj = make_pair(300, obj);
obj = make_pair(400, obj);
obj = make_pair(500, obj);
obj = make_pair(600, obj); /* gc */
/* triger gc, without protection*/
list = eat_pool(5); /* result is broken */
dump_object(list); /* print one object, this is implementation behavior */
gc_abandon();
}
/* Top level */
void
toplevel(void)
{
long s, v;
for (;;){
t_stack_ptr = 0;
printf("\n] "); /* prompt */
if ((s = l_read()) < 0) /* read */
continue;
if (s == TAG_EOF) /* end of file */
break;
if (gc_protect(s) < 0)
break;
if ((v = l_eval(s)) < 0) /* eval */
continue;
gc_unprotect(s);
printf("\n");
(void) l_print(v); /* print */
}
}
/* Compile a file */
void compile_file(compiler_type *comp_void, char *file_name, bool include_baselib) {
compiler_core_type *compiler = (compiler_core_type *)comp_void;
ins_stream_type *baselib = 0; /* TODO: should be gc root */
FILE *in = 0;
char path[PATH_MAX];
/* Actually parse the input stream. */
yylex_init_extra(compiler, &(compiler->scanner));
in = fopen(file_name, "r");
if (!in) {
(void)fprintf(stderr, "Error %i while attempting to open '%s'\n",
errno, file_name);
assert(0);
}
//yyset_in(in, compiler->scanner);
yy_switch_to_buffer(
yy_create_buffer(in, YY_BUF_SIZE, compiler->scanner), compiler->scanner);
push_include_path(compiler, file_name);
/* TODO: Need a better way to handle GC than leaking */
gc_protect(compiler->gc);
/* Inject include for base library */
if (include_baselib) {
strcpy(path, compiler->home);
strcat(path, "/lib/baselib.scm");
STREAM_NEW(baselib, string, path);
setup_include(compiler, baselib);
}
parse_internal(compiler, compiler->scanner);
gc_unprotect(compiler->gc);
yylex_destroy(compiler->scanner);
}
int main(int argc, char** argv) {
GarbageCollector gc = gc_create(10,sizeof(struct node),node_mark,NULL,NULL);
Node head = NULL;
gc_protect(gc,&head); /* protect the list from garbage collection */
/* populate the list */
head = node(gc,head,1);
head = node(gc,head,2);
head = node(gc,head,3);
/* force collect */
gc_collect(gc);
/* check whether list still exists */
Node cur;
for (cur = head; cur ; cur = cur->next)
printf("%d\n",cur->value);
gc_free(&gc);
return 0;
}
void
mrb_gc_protect(mrb_state *mrb, mrb_value obj)
{
if (mrb_special_const_p(obj)) return;
gc_protect(mrb, mrb_basic_ptr(obj));
}
void init0(int argc, _TCHAR * argv[], enum debug_flag_t initial_debug_flags)
{
global_environment_asserts();
previous_panic_handler = set_panic_handler(scan_panic_handler);
/** Initialize the interpreter globals */
memset(&interp, 0, sizeof(interp));
/* We need the debug flags pretty early on, so that we know how
* to set up debugger I/O. */
interp.debug_flags = debug_flags_from_environment(initial_debug_flags);
init_debugger_output();
interp.init_load_file_count = 0;
interp.intr_pending = VMINTR_NONE;
interp.intr_masked = false;
interp.launch_realtime = sys_runtime();
interp.fasl_package_list = NIL;
gc_protect(_T("fasl-package-list"), &interp.fasl_package_list, 1);
/* Statistics Counters */
interp.gc_heap_segment_size = DEFAULT_HEAP_SEGMENT_SIZE;
interp.gc_max_heap_segments = DEFAULT_MAX_HEAP_SEGMENTS;
interp.gc_current_heap_segments = 0;
interp.gc_heap_segments = NULL;
interp.gc_total_cells_allocated = 0;
interp.gc_malloc_bytes_threshold = (sizeof(struct lobject_t) * interp.gc_heap_segment_size);
interp.gc_total_run_time = 0.0;
interp.gc_start_time = 0.0;
interp.thread.fsp = &(interp.thread.frame_stack[FRAME_STACK_SIZE]);
interp.thread.frame = NULL;
process_vm_arguments(argc, argv);
if (interp.debug_flags != DF_NONE)
dscwritef(DF_ALWAYS, ("; DEBUG: debug_flags=0x~cx\n", interp.debug_flags));
/*** Create the gc heap and populate it with the standard objects */
gc_initialize_heap();
create_initial_packages();
init_base_scheme_objects();
init_stdio_ports();
register_main_subrs();
gc_protect(_T("handler-frames"), &(CURRENT_TIB()->handler_frames), 1);
gc_protect(_T("frame-stack"), (struct lobject_t **)&(CURRENT_TIB()->frame_stack[0]), sizeof(CURRENT_TIB()->frame_stack) / sizeof(lref_t));
accept_command_line_arguments(argc, argv);
load_init_load_files();
}
/* mrb_gc_protect() leaves the object in the arena */
MRB_API void
mrb_gc_protect(mrb_state *mrb, mrb_value obj)
{
if (mrb_immediate_p(obj)) return;
gc_protect(mrb, mrb_basic_ptr(obj));
}
/* Function application (user defined function) */
long
apply(long func, long aparams, int n)
{
long fdef, fbody, f, sym, a, v;
int i;
#ifdef ZX81
/*
..almost useless, let's save space
#asm
ld hl,0
add hl,sp
ld (__sp),hl
#endasm
if (200 + &t_stack[t_stack_ptr]>=_sp)
return err_msg(errmsg_stack_of, 0, 0);
*/
#else
if (t_stack_ptr + n > STACK_SIZE) /* stack overflow */
return err_msg(errmsg_stack_of, 0, 0);
#endif
if (D_GET_TAG(func) == TAG_SYMB){ /* function symbol */
fdef = t_symb_fval[D_GET_DATA(func)];
} else if (D_GET_TAG(func) == TAG_CONS){ /* lambda exp */
fdef = func;
}
/* bind */
f = l_car(fdef); /* formal parameters */
a = aparams; /* actual parameters */
t_stack_ptr = t_stack_ptr + n;
for (i = 0; i < n; i++, f = l_cdr(f), a = l_cdr(a)){
sym = l_car(f);
/* push old symbol values onto stack */
t_stack[t_stack_ptr - i - 1] = t_symb_val[D_GET_DATA(sym)];
/* bind argument value to symbol */
t_symb_val[D_GET_DATA(sym)] = l_car(a);
}
if (gc_protect(aparams) < 0)
return -1;
/* evaluate function body */
fbody = l_cdr(fdef); /* function body */
for (v = TAG_NIL; D_GET_TAG(fbody) == TAG_CONS; fbody = l_cdr(fbody)){
if ((v = l_eval(l_car(fbody))) < 0)
break; /* error ... never return immediately - need unbinding. */
}
/* pop gc_protected objects, including 'gc_unprotect(aparams)'. */
while ((t_stack[t_stack_ptr-1] & D_GC_MARK) != 0)
--t_stack_ptr;
/* unbind: restore old variable values from stack */
for (i = 0, f = l_car(fdef); i < n; i++, f = l_cdr(f)){
sym = l_car(f);
t_symb_val[D_GET_DATA(sym)] = t_stack[t_stack_ptr - i - 1];
}
t_stack_ptr = t_stack_ptr - n;
return v;
}
/* Read an S-expression */
long
l_read(void)
{
long s, v, t;
char token[32];
char ch, i;
/* skip spaces */
if ((ch = skip_space()) < 0){ /* eof */
return TAG_EOF;
} else if (ch == ';'){ /* comment */
while (gchar() != '\n')
;
return -1;
}
#ifdef ZX81
else if (ch == '\"'){ /* quote macro */
#else
else if (ch == '\''){ /* quote macro */
#endif
if ((t = l_read()) < 0)
return -1;
if (t == TAG_EOF)
return err_msg(errmsg_eof, 0, 0);
t = l_cons(t, TAG_NIL);
s = l_cons((TAG_SYMB|KW_QUOTE), t);
} else if (ch != '('){ /* t, nil, symbol, or integer */
token[0] = ch;
for (i = 1; ; i++){
ch = gchar();
if (isspace(ch) || iscntrl(ch) || (ch < 0)
|| (ch == ';') || (ch == '(') || (ch == ')')){
ugchar(ch);
token[i] = '\0';
/* Changed to permint the definition of "1+" and "1-" */
if ((isdigit((char)token[0]) && (token[1] != '+') && (token[1] != '-'))
/* if (isdigit((char)token[0]) */
|| ((token[0] == '-') && isdigit((char)token[1]))
|| ((token[0] == '+') && isdigit((char)token[1]))){ /* integer */
s = int_make_l(atol(token));
#ifdef SCHEME
} else if (strcmp(token, "#f") == 0){ /* nil */
s = TAG_NIL;
} else if (strcmp(token, "#t") == 0){ /* t */
s = TAG_T;
#else
} else if (strcmp(token, "nil") == 0){ /* nil */
s = TAG_NIL;
} else if (strcmp(token, "t") == 0){ /* t */
s = TAG_T;
#endif
} else { /* symbol */
s = TAG_SYMB | symb_make(token);
}
break;
}
token[i] = ch;
}
} else /* ch == '(' */ { /* list */
if ((ch = skip_space()) < 0){
return err_msg(errmsg_eof, 0, 0);
} else if (ch == ')'){
s = TAG_NIL; /* "()" = nil */
} else {
ugchar(ch);
if ((t = l_read()) < 0)
return err_msg(errmsg_eof, 0, 0);
if (t == TAG_EOF)
return -1;
if ((s = v = l_cons(t, TAG_NIL)) < 0)
return -1;
if (gc_protect(s) < 0)
return -1;
for (;;){
if ((ch = skip_space()) < 0) /* look ahead next char */
return err_msg(errmsg_eof, 0, 0);
if (ch == ')')
break;
ugchar(ch);
if ((t = l_read()) < 0)
return -1;
if (t == TAG_EOF)
return err_msg(errmsg_eof, 0, 0);
if ((t = l_cons(t, TAG_NIL)) < 0)
return -1;
rplacd(v, t);
v = l_cdr(v);
}
gc_unprotect(s);
}
}
return s;
}
char
skip_space(void)
{
char ch;
for (;;){
if ((ch = gchar()) < 0)
return -1; /* end-of-file */
if (!isspace(ch) && !iscntrl(ch))
break;
}
return ch;
}
void
mrb_gc_protect(mrb_state *mrb, mrb_value obj)
{
if (SPECIAL_CONST_P(obj)) return;
gc_protect(mrb, RBASIC(obj));
}
