示例#1
0
文件: oostruct.c 项目: barak/lush
static at *call_method(at *obj, struct hashelem *hx, at *args)
{
   at *fun = hx->function;
   assert(FUNCTIONP(fun));
   
   if (Class(fun) == de_class) {
      // DE
      at *p = eval_arglist(args);
      return with_object(obj, fun, p, hx->sofar);

   } else if (Class(fun) == df_class) {
      // DF
      return with_object(obj, fun, args, hx->sofar);

   } else if (Class(fun) == dm_class) {
      // DM
      at *p = new_cons(new_cons(fun, args), NIL);
      at *q = with_object(obj, at_mexpand, p, hx->sofar);
      return eval(q);
      
   } else {
      // DX, DY, DH
      at *p = new_cons(fun, new_cons(obj, args));
      return Class(fun)->listeval(fun, p);
   }
}
示例#2
0
文件: oostruct.c 项目: barak/lush
void putmethod(class_t *cl, at *name, at *value)
{
   ifn (SYMBOLP(name))
      RAISEF("not a symbol", name);
   if (value && !FUNCTIONP(value))
      RAISEF("not a function", value);

   clear_hashok(cl);
   at **last = &(cl->methods);
   at *list = *last;
   while (CONSP(list)) {
      at *q = Car(list);
      ifn (CONSP(q))
         RAISEF("not a pair", q);
      if (Car(q) == name) {
         if (value) {
            /* replace */
            Cdr(q) = value;
            return;
         } else {
            /* remove */
            *last = Cdr(list);
            Cdr(list) = NIL;
            return;
         }
      }
      last = &Cdr(list);
      list = *last;
   }
   /* not an existing method, append */
   if (value)
      *last = new_cons(new_cons(name, value), NIL);
}
示例#3
0
文件: eval.c 项目: jbf/tonsai-scheme
cell_t *evaluate(cell_t *exp, environ_t *env) {
  ++__tl_eval_level;

  // push a frame
  eval_stack_t s;
  s.next = eval_stack;
  s.value = env;
  eval_stack = &s;

  if (DFLAG) {
    printf("Eval (%d) got : ", __tl_eval_level);
    pretty_print(exp);
  }

  if (NULL == exp) {
    DRETURN(RET_VAL, NULL);
  } else if (NILP(exp)) {
    DRETURN(RET_VAL, nil_cell);
  } else if (ATOMP(exp)) {
    if (SYMBOLP(exp)) {
      DRETURN(RET_VAL, find_value(env, exp));
    } else if (STRINGP(exp) || NUMBERP(exp)) {
      DRETURN(RET_VAL, exp);
    } else {
      DEBUGPRINT_("Expression not valid.\n");
      pretty_print(orig_sexpr);
      GOTO_TOPLEVEL();
      return NULL; /* unreachable */
    }
  } else { /* list */
    handle_t *he = handle_push(exp);
    cell_t *first = evaluate(CAR(exp), env); // exp handled
    exp = handle_get(he);
    handle_pop(he);
    cell_t *rest = CDR(exp);

    if (DFLAG) {
      printf("First is: ");
      pretty_print(first);
      printf("Rest is: ");
      pretty_print(rest);
    }

    if (NULL == first) {
      fast_error(" malformed expression.");
      /* This is unreachable */
    } else if (PRIMITIVEP(first)) {
      cell_t *(*f)(cell_t *, environ_t *) = CELL_PRIMITIVE(first);
      DRETURN(RET_PRIM, (*f)(rest, env));
    } else if (FUNCTIONP(first)) { /* function call */
      cell_t *t;
      handle_t *hf;

      hf = handle_push(first);
      t = evargs(rest, env); // first handled
      first = handle_get(hf);
      handle_pop(hf);

      DRETURN(RET_FUNCALL, invoke(first, t, env)); // no need for handles
    }
    undefun_error(first, exp); /* Not primitive or funcall, error.*/
    return NULL; /* Unreachable, undefun_error() does not return. */
  }
}