Example #1
0
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);
}
Example #2
0
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);
}
Example #3
0
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)));

}
Example #4
0
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);
}