Example #1
0
elem XmlRpc_DecodeMember(elem obj, elem mem)
{
	elem t, x;
	elem cur;

	elem var, val;

	t=MISC_NULL;
	cur=CDDR(mem);
	while(ELEM_CONSP(cur))
	{
		if(CAAR(cur)==SYM("name"))
		{
			var=SYM(ELEM_TOSTRING(CADDR(CAR(cur))));
		}
		if(CAAR(cur)==SYM("value"))
		{
			val=XmlRpc_DecodeValue(CADDR(CAR(cur)));
		}
		cur=CDR(cur);
	}
	TyObj_SetSlot(obj, var, val);

	return(t);
}
Example #2
0
static SCM
lookup (SCM x, SCM env)
{
  int d = 0;
  for (; scm_is_pair (env); env = CDR (env), d++)
    {
      SCM link = CAR (env);
      if (env_link_is_flat (link))
        {
          int w;
          SCM vars;

          for (vars = env_link_vars (link), w = scm_ilength (vars) - 1;
               scm_is_pair (vars);
               vars = CDR (vars), w--)
            if (scm_is_eq (x, (CAAR (vars))))
              return make_pos (d, w);

          env_link_add_flat_var (link, x, lookup (x, CDR (env)));
          return make_pos (d, scm_ilength (env_link_vars (link)) - 1);
        }
      else
        {
          int w = try_lookup_rib (x, env_link_vars (link));
          if (w < 0)
            continue;
          return make_pos (d, w);
        }
    }
  abort ();
}
Example #3
0
static int
expand_env_var_is_free (SCM env, SCM x)
{
  for (; scm_is_pair (env); env = CDR (env))
    if (scm_is_eq (x, CAAR (env)))
      return 0; /* bound */
  return 1; /* free */
}
Example #4
0
static SCM
expand_env_lexical_gensym (SCM env, SCM name)
{
  for (; scm_is_pair (env); env = CDR (env))
    if (scm_is_eq (name, CAAR (env)))
      return CDAR (env); /* bound */
  return SCM_BOOL_F; /* free */
}
Example #5
0
OBJECT_PTR get_continuation_for_return(OBJECT_PTR obj)
{
  OBJECT_PTR rest = continuations_map;

  while(rest != NIL)
  {
    if(CAAR(rest) == obj)
      return CDAR(rest);

    rest = cdr(rest);
  }
  return NIL;
}
Example #6
0
node ormembertype(node ortype, node membername) {
     node m;
     assert(isortype(ortype));
     membername = unpos(membername);
     m = ortype->body.type.commons;
     while (m != NULL) {
	  if (equal(CAAR(m),membername)) {
	       node t = typeforward(CADAR(m));
	       return t;
	       }
	  m = CDR(m);
	  }
     return NULL;
     }
Example #7
0
elem XmlRpc_HandleCall(elem req)
{
	elem cur, t;
	elem method, params;

	method=MISC_NULL;
	params=MISC_EOL;

	if(CAR(req)==SYM("methodCall"))
	{
		cur=CDDR(req);
		while(ELEM_CONSP(cur))
		{
			if(CAAR(cur)==SYM("methodName"))
			{
				method=CADDR(CAR(cur));
			}
			if(CAAR(cur)==SYM("params"))
			{
				t=CDDR(CAR(cur));
				params=XmlRpc_DecodeParams(t);
			}
			cur=CDR(cur);
		}
	}

	kprint("method call: ");
	TyFcn_DumpElem(method);
	kprint(" with: ");
	TyFcn_DumpElemBR(params);

	method=SYM(ELEM_TOSTRING(method));
	t=Verify_Func(method, params);
//	t=MISC_NULL;

	return(t);
}
Example #8
0
node membertype(node structtype, node membername) {
     node m;
     membername = unpos(membername);
     if (membername == len_S) return int_T;
     if (membername == type__S) return int_T;
     if (istype(structtype)) m = typedeftail(structtype);
     else m = CDR(structtype);
     if (ispos(membername)) membername = membername->body.position.contents;
     while (m != NULL) {
	  if (equal(CAAR(m),membername)) {
	       node t = typeforward(CADAR(m));
	       return t;
	       }
	  m = CDR(m);
	  }
     return NULL;
     }
Example #9
0
elem XmlRpc_DecodeArray(elem str)
{
	elem t, x;
	elem cur;

	t=MISC_EOL;
	cur=CDDR(str);
	while(ELEM_CONSP(cur))
	{
		if(CAAR(cur)==SYM("data"))
		{
			t=XmlRpc_DecodeArraySlots(CAR(cur));
		}
		cur=CDR(cur);
	}
	return(t);
}
Example #10
0
elem XmlRpc_DecodeParam(elem param)
{
	elem t, x;
	elem cur;

	t=MISC_NULL;
	cur=CDDR(param);
	while(ELEM_CONSP(cur))
	{
		if(CAAR(cur)==SYM("value"))
		{
			t=XmlRpc_DecodeValue(CADDR(CAR(cur)));
		}
		cur=CDR(cur);
	}
	return(t);
}
Example #11
0
void BGBCC_BMC_CompileEnum(BGBCC_State *ctx, BCCX_Node *l)
{
	BCCX_Node *c, *t, *n, *v;

	c=BCCX_Fetch(l, "body");
	while(BS1_CONSP(c))
	{
		n=CAAR(c);
		v=CADAR(c);
		t=BS1_MM_NULL;

		SET(ctx->mlenv, CONS(n, ctx->mlenv));
		SET(ctx->mtenv, CONS(t, ctx->mtenv));
		SET(ctx->mvenv, CONS(v, ctx->mvenv));

		c=CDR(c);
	}
}
Example #12
0
elem XmlRpc_DecodeArraySlots(elem param)
{
	elem t, x;
	elem cur;

	x=MISC_EOL;
	cur=CDDR(param);
	while(ELEM_CONSP(cur))
	{
		if(CAAR(cur)==SYM("value"))
		{
			t=XmlRpc_DecodeValue(CADDR(CAR(cur)));
			x=CONS(t, x);
		}
		cur=CDR(cur);
	}
	x=TyFcn_NReverse(x);
	return(x);
}
Example #13
0
elem XmlRpc_DecodeParams(elem lst)
{
	elem t, x;
	elem cur;

	x=MISC_EOL;
	cur=lst;
	while(ELEM_CONSP(cur))
	{
		if(CAAR(cur)==SYM("param"))
		{
			t=XmlRpc_DecodeParam(CAR(cur));
			x=CONS(t, x);
		}
		cur=CDR(cur);
	}
	x=TyFcn_NReverse(x);

	return(x);
}
Example #14
0
node ExpandType(node t, node *f) {
     /* t should be a type expression that might need expanding.  Its expanded
        form gets returned, and also put on the top of the list f
	unless it's already a type or basic type */
     switch(t->tag) {
	  case position_tag: return ExpandType(t->body.position.contents,f);
     	  case type_tag: return t;
     	  case symbol_tag: {
	       if (t->body.symbol.type == type__T) {
	  	    assert(istype(t->body.symbol.value));
		    return t->body.symbol.value;
		    }
	       if (t == bad__K) return bad_or_undefined_T;
	       assert(FALSE); return NULL;
	       }
	  case cons_tag: {
	       node fun = CAR(t);
	       if (ispos(fun)) fun = fun->body.position.contents;
	       t = CDR(t);
	       if (fun == or_K) {
		    /* here we should sort! */
		    /* we should also merge sub-or's in, and eliminate
		       duplicates */
		    /* we really only handle (or null (object)) now! */
		    node newN = NULL;
		    node mems = NULL;
		    while (t != NULL) {
			 node u = ExpandType(CAR(t),f);
			 push(mems,u);
			 t = CDR(t);
			 }
		    apply(reverse,mems);
		    newN = newtype(cons(fun,mems),NULL,FALSE);
		    push(*f,newN);
		    return newN;
		    }
	       else if (fun == object__K || fun == tagged_object_K /* ? */ ) {
		    node newN = NULL;
		    while (t != NULL) {
			 node name = CAAR(t);
			 node u = CADAR(t);
			 push(newN, list(2, unpos(name), ExpandType(u,f)));
			 t = CDR(t);
			 }
		    apply(reverse,newN);
		    newN = newtype(cons(fun,newN),NULL,FALSE);
		    push(*f,newN);
		    return newN;
		    }
	       else if (fun == array_K || fun == tarray_K) {
		    node newN;
		    newN = cons(fun,cons(ExpandType(car(t),f),cdr(t)));
		    newN = newtype(newN,NULL,FALSE);
		    *f = cons(newN,*f);
		    return newN;
		    }
	       else if (fun == function_S) {
		    node argtypes = car(t);
		    node rettype = cadr(t);
		    node newargtypes = NULL;
		    node newN;
		    while (argtypes != NULL) {
			 newargtypes = cons( 
			      ExpandType(car(argtypes),f), newargtypes);
			 argtypes = cdr(argtypes);
			 }
		    newargtypes = reverse(newargtypes);
		    rettype = ExpandType(rettype,f);
		    newN = list(3,fun,newargtypes,rettype);
		    newN = newtype(newN,NULL,FALSE);
		    *f = cons(newN,*f);
		    return newN;
		    }
	       else assert(FALSE); return NULL;
	       }
	  default: assert(FALSE); return NULL;
	  }
     }
Example #15
0
Value *native_car(Value *args)  { return CAAR(args); }
Example #16
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 #17
0
void
VM::backtrace_seek()
{
    if (flags.m_backtrace != scm_false) {
        backtrace_seek_make_cont(m_trace);
        backtrace_seek_make_cont(m_trace_tail);
        m_trace = m_trace_tail = scm_unspecified;
        scm_obj_t lst = CDR(m_pc);
        while (lst != scm_nil) {
            scm_obj_t operands = (scm_obj_t)CDAR(lst);
            int opcode = instruction_to_opcode(CAAR(lst));
            switch (opcode) {
            case VMOP_RET_SUBR_GLOC_OF:
            case VMOP_APPLY_GLOC_OF:
                fatal("%s:%u internal error: backtrace_seek()", __FILE__, __LINE__);
            case VMOP_RET_SUBR:
                if (PAIRP(CDR(operands))) {
                    backtrace_seek_make_cont(CDR(operands));
                    goto more_seek;
                }
                break;
            case VMOP_APPLY_GLOC:
                if (PAIRP(CDR(operands))) {
                    backtrace_seek_make_cont(CDR(operands));
                    goto more_seek;
                }
                break;
            case VMOP_APPLY_ILOC:
                if (PAIRP(CDR(operands))) {
                    backtrace_seek_make_cont(CDR(operands));
                    goto more_seek;
                }
                break;
            case VMOP_APPLY_ILOC_LOCAL:
                if (PAIRP(CDR(operands))) {
                    backtrace_seek_make_cont(CDR(operands));
                    goto more_seek;
                }
                break;
            case VMOP_APPLY:
                if (PAIRP(operands)) {
                    backtrace_seek_make_cont(operands);
                    goto more_seek;
                }
                break;
            case VMOP_RET_CONS:
            case VMOP_RET_EQP:
            case VMOP_RET_NULLP:
            case VMOP_RET_PAIRP:
                if (PAIRP(operands)) {
                    backtrace_seek_make_cont(operands);
                    goto more_seek;
                }
                break;
            case VMOP_EXTEND:
            case VMOP_EXTEND_UNBOUND:
                goto more_seek;
            }
            lst = CDR(lst);
        }
more_seek:
        scm_obj_t lst2 = m_pc;
more_more_seek:
        if (lst2 == scm_nil) return;
        if (!PAIRP(CAR(lst2))) return;
        scm_obj_t operands = (scm_obj_t)CDAR(lst2);
        int opcode = instruction_to_opcode(CAAR(lst2));
        switch (opcode) {
        case VMOP_SUBR_GLOC_OF:
            fatal("%s:%u intern error backtrace_seek()", __FILE__, __LINE__);
        case VMOP_SUBR:
            if (PAIRP(CDDR(operands))) backtrace_seek_make_cont(CDDR(operands));
            return;
        case VMOP_EQ_ILOC:
        case VMOP_LT_ILOC:
        case VMOP_LE_ILOC:
        case VMOP_GT_ILOC:
        case VMOP_GE_ILOC:
            if (PAIRP(CDR(operands))) backtrace_seek_make_cont(CDR(operands));
            return;
        case VMOP_EQ_N_ILOC:
        case VMOP_LT_N_ILOC:
        case VMOP_LE_N_ILOC:
        case VMOP_GT_N_ILOC:
        case VMOP_GE_N_ILOC:
        case VMOP_NADD_ILOC:
        case VMOP_PUSH_NADD_ILOC:
        case VMOP_PUSH_SUBR:
            if (PAIRP(CDDR(operands))) backtrace_seek_make_cont(CDDR(operands));
            return;
        case VMOP_CAR_ILOC:
        case VMOP_CDR_ILOC:
        case VMOP_VECTREF_ILOC:
        case VMOP_PUSH_CAR_ILOC:
        case VMOP_PUSH_CDR_ILOC:
        case VMOP_PUSH_CADR_ILOC:
        case VMOP_PUSH_CDDR_ILOC:
        case VMOP_PUSH_VECTREF_ILOC:
            if (PAIRP(CDR(operands))) backtrace_seek_make_cont(CDR(operands));
            return;
        case VMOP_CONST:
        case VMOP_GLOC:
        case VMOP_ILOC:
        case VMOP_ILOC0:
        case VMOP_ILOC1:
        case VMOP_CLOSE:
        case VMOP_CONST_UNSPEC:
        case VMOP_PUSH_CONST:
        case VMOP_PUSH_GLOC:
        case VMOP_PUSH_ILOC:
        case VMOP_PUSH_ILOC0:
        case VMOP_PUSH_ILOC1:
        case VMOP_PUSH_CLOSE:
        case VMOP_PUSH:
        case VMOP_CALL:
            lst2 = CDR(lst2);
            goto more_more_seek;
        }
    }
}