コード例 #1
0
ファイル: clisp.c プロジェクト: meesokim/z88dk
/* "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);
}
コード例 #2
0
ファイル: clisp.c プロジェクト: meesokim/z88dk
/* 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];
}
コード例 #3
0
ファイル: gc.c プロジェクト: guanqun/mruby
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;
}
コード例 #4
0
/* 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);
}
コード例 #5
0
ファイル: c-global-env.c プロジェクト: poschengband/emrys
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;    
}
コード例 #6
0
ファイル: gc.c プロジェクト: anehing/mruby
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;
}
コード例 #7
0
ファイル: main.c プロジェクト: mschaef/vcsh
  /**** 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);
}
コード例 #8
0
ファイル: gc.c プロジェクト: picrin-scheme/benz
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;
}
コード例 #9
0
ファイル: gc.c プロジェクト: picrin-scheme/benz
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;
}
コード例 #10
0
ファイル: c-obj.c プロジェクト: poschengband/emrys
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);
}
コード例 #11
0
ファイル: gc.c プロジェクト: Everysick/mruby
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;
}
コード例 #12
0
ファイル: zend.c プロジェクト: gpiszczek/php-src
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);
}
コード例 #13
0
ファイル: gc.c プロジェクト: cpylua/mark-sweep-gc
/* 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();
}
コード例 #14
0
ファイル: clisp.c プロジェクト: meesokim/z88dk
/* 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 */
  }
}
コード例 #15
0
/* 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);
}
コード例 #16
0
ファイル: example2.c プロジェクト: dhamidi/simple-gc
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;
}
コード例 #17
0
ファイル: gc.c プロジェクト: anehing/mruby
void
mrb_gc_protect(mrb_state *mrb, mrb_value obj)
{
  if (mrb_special_const_p(obj)) return;
  gc_protect(mrb, mrb_basic_ptr(obj));
}
コード例 #18
0
ファイル: main.c プロジェクト: mschaef/vcsh
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();
}
コード例 #19
0
ファイル: gc.c プロジェクト: holywyvern/mruby
/* 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));
}
コード例 #20
0
ファイル: clisp.c プロジェクト: meesokim/z88dk
/* 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;
}
コード例 #21
0
ファイル: clisp.c プロジェクト: meesokim/z88dk
/* 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;
}
コード例 #22
0
ファイル: gc.c プロジェクト: guanqun/mruby
void
mrb_gc_protect(mrb_state *mrb, mrb_value obj)
{
  if (SPECIAL_CONST_P(obj)) return;
  gc_protect(mrb, RBASIC(obj));
}