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; }
bool pointer_to_atomic_memory(node t){ /* return true if the memory allocated for an object of type t contains no pointers */ assert(istype(t)); if (isobjecttype(t) || istaggedobjecttype(t)) { node m; for (m=typedeftail(t); m != NULL; m = CDR(m)) { node k = CADAR(m); assert(istype(k)); if (k == void_T) continue; if (k->body.type.flags & raw_atomic_type_F) continue; if (k->body.type.flags & (raw_pointer_type_F|raw_atomic_pointer_type_F)) return FALSE; if (isbasictype(CADAR(m))) continue; return FALSE; } return TRUE; } if (isortype(t)) { return FALSE; } if (isarraytype(t)||istaggedarraytype(t)) { node m = typedeftail(t); assert(length(m) >= 1); node typ = CAR(m); assert(istype(typ)); if (typ->body.type.flags & (raw_pointer_type_F|raw_atomic_pointer_type_F)) { return FALSE; /* can we redefine isbasictype? */ } return isbasictype(typ); } if (t->body.type.flags & raw_pointer_type_F) return FALSE; if (t->body.type.flags & raw_atomic_pointer_type_F) return TRUE; assert(!((t->body.type.flags & raw_type_F))); assert(!((t->body.type.flags & raw_atomic_type_F))); if (isbasictype(t)) return TRUE; assert(FALSE); return FALSE; }
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; }
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); } }
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; } }
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))); }