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);
}
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 ();
}
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 */
}
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 */
}
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;
}
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;
}
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);
}
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;
}
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);
}
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);
}
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);
}
}
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);
}
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);
}
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;
}
}
Value *native_car(Value *args) { return CAAR(args); }
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)));
}
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;
}
}
}