object *lookup_variable_value(object *var, object *env) { object *frame; object *vars; object *vals; if (debug) { fprintf(stderr, "entering lookup_variable_value searching for %s\n", var->data.symbol.value); } while (!is_the_empty_list(env)) { frame = first_frame(env); vars = frame_variables(frame); vals = frame_values(frame); if (debug) { fprintf(stderr, "1 searching symbol %s\n", var->data.symbol.value); fprintf(stderr, "1 vars %p\n", vars); } while (!is_the_empty_list(vars)) { if (is_pair(vars)) { if (var == car(vars)) { if (debug) { fprintf(stderr, "vals---\n"); write(stdout, is_pair(vals) ? car(vals) : the_empty_list); fflush(stdout); fprintf(stderr, "\nend---\n"); } return is_pair(vals) ? car(vals) : the_empty_list; } } else if(is_symbol(vars)) { if (debug) { fprintf(stderr, "2 searched symbol %s\n", var->data.symbol.value); fprintf(stderr, "last cdr symbol %s\n", vars->data.symbol.value); } if (var == vars) { if (debug) { fprintf(stderr, "vals---\n"); write(stdout, vals); fflush(stdout); fprintf(stderr, "\nend---\n"); } return vals; } else { break; } } vars = cdr(vars); vals = cdr(vals); } env = enclosing_environment(env); } fprintf(stderr, "unbound variable, %s\n", var->data.symbol.value); exit(1); }
void GC_CALLBACK pair_dct(void *obj, void *cd) { pair_t p = obj; int checksum; /* Check that obj and its car and cdr are not trashed. */ # ifdef DEBUG_DISCLAIM_DESTRUCT printf("Destruct %p = (%p, %p)\n", (void *)p, (void *)p->car, (void *)p->cdr); # endif my_assert(GC_base(obj)); my_assert(is_pair(p)); my_assert(!p->car || is_pair(p->car)); my_assert(!p->cdr || is_pair(p->cdr)); checksum = 782; if (p->car) checksum += p->car->checksum; if (p->cdr) checksum += p->cdr->checksum; my_assert(p->checksum == checksum); /* Invalidate it. */ memset(p->magic, '*', sizeof(p->magic)); p->checksum = 0; p->car = cd; p->cdr = NULL; }
void print(Value x) { if (is_nil(x)) prints("nil"); else if (is_eof(x)) printf("#eof"); else if (is_fixnum(x)) printf("%d", as_fixnum(x)); else if (is_bool(x)) printf("%s", as_bool(x) ? "true" : "false"); else if (is_char(x)) printf("'%c'", as_char(x)); else if (is_pair(x)) print_list(x); else if (is_symbol(x)) prints(as_symbol(x)->value); else if (is_string(x)) print_string(as_string(x)); else if (is_procedure(x)) printf("#<procedure %s>", as_procedure(x)->name->value); else if (is_module(x)) printf("#<module>"); else if (is_type(x)) printf("#<type %s>", as_type(x)->name->value); else if (is_ptr(x)) printf("#<object %p>", as_ptr(x)); else if (is_undefined(x)) printf("#undefined"); else printf("#ufo"); }
void print_env(obj_t *env) { if (!is_pair(env)) { printf_unchecked("%O\n", env); return; } const char *sep = ""; while (env) { printf("%s", sep); if (pair_cdr(env)) { obj_t *f = pair_car(env); printf("["); sep = ""; while (f) { obj_t *binding = pair_car(f); printf_unchecked("%s%O: %O", sep, binding_name(binding), binding_value(binding)); f = pair_cdr(f); sep = ", "; } printf("]"); } else printf("[builtins]\n"); env = pair_cdr(env); sep = " -> "; } }
void send_pair_decomposed(struct network_status *net_stat) /*@ requires [?f0]world(?pub, ?key_clsfy) &*& proof_obligations(pub) &*& network_status(net_stat) &*& principal(?principal, ?count1) &*& true == bad(principal); @*/ /*@ ensures [f0]world(pub, key_clsfy) &*& proof_obligations(pub) &*& network_status(net_stat) &*& principal(principal, ?count2); @*/ { struct item *pair = network_receive(net_stat); //@ assert item(pair, ?p, pub); if (is_pair(pair)) { struct item *first = pair_get_first(pair); struct item *second = pair_get_second(pair); //@ open proof_obligations(pub); //@ assert is_public_pair_decompose(?proof1, pub); //@ assert is_public_collision(?proof2, pub); //@ proof1(p); //@ assert item(first, ?f, pub); //@ if (col) proof2(f); //@ assert item(second, ?s, pub); //@ if (col) proof2(s); //@ close proof_obligations(pub); network_send(net_stat, first); network_send(net_stat, second); item_free(first); item_free(second); } item_free(pair); }
static const wchar_t *block_name(C_procedure_t *block, obj_t *env) { if (block == b_eval) return L"b_eval"; if (block == b_accum_operator) return L"b_accum_operator"; if (block == b_accum_arg) return L"b_accum_arg"; if (block == b_eval_sequence) return L"b_eval_sequence"; if (block == NULL) return L"NULL"; /* XXX Move this code into env.c. */ if (!env) env = library_env(r6rs_library()); if (is_pair(env)) { obj_t *frame = pair_car(env); while (frame) { obj_t *binding = pair_car(frame); obj_t *value = binding_value(binding); if (is_procedure(value) && procedure_is_C(value)) { C_procedure_t *body; body = (C_procedure_t *)procedure_body(value); if (body == block) { obj_t *name = symbol_name(binding_name(binding)); return string_value(name); } } frame = pair_cdr(frame); } } return L"<some-proc>"; }
// A tagged list is a pair whose car is a specified symbol. The value of // the tagged list is the cdr of the pair bool is_tagged_list(object *expression, object *tag) { object *the_car; if (!is_pair(expression)) return false; the_car = car(expression); return is_symbol(the_car) && (the_car == tag); }
void check_is_pair(struct item *item) //@ requires [?f]world(?pub, ?key_clsfy) &*& item(item, ?p, pub); /*@ ensures [f]world(pub, key_clsfy) &*& item(item, p, pub) &*& p == pair_item(_, _); @*/ { if (!is_pair(item)) abort_crypto_lib("Presented item is not a pair item"); }
void add_pairs(const sp_table *ss) { sp_table *sp=ss; while(sp!=NULL){ if(is_pair(sp->str_one) && !in_table(sp->str_one, SP_STR)) sp=sp->next; } }
// (vector x y ...) Cell* op_vector(Scheme *sc) { Cell* x; int len = ls_length(sc, sc->args); if (len < 0) return error_helper(sc, "vector: not a proper list:", sc->args); Cell* vec = make_vector(sc, len); int index = 0; for (x = sc->args; is_pair(x); x = cdr(x), index++) { set_vector_item(vec, index, car(x)); } return s_return_helper(sc, vec); }
//two args: exp & label static cellpoint is_tagged_list(void) { if (is_true(is_pair(args_ref(1)))){ reg = car(args_ref(1)); args_push(args_ref(2)); args_push(reg); reg = eq(); }else { reg = a_false; } args_pop(2); return reg; }
void print_pair(ptr x) { pair* p = to_pair(x); print_ptr_rec(p->car); if (is_pair(p->cdr)) { printf(" "); print_pair(p->cdr); } else if (is_null(p->cdr)) { /*pass*/ } else { printf(" . "); print_ptr_rec(p->cdr); } }
int main() { int num; printf ("Digite o numero: "); scanf ("%d", &num); if (is_pair(num)) printf ("\nNumero par\n"); else printf ("\nNumero impar\n"); return 0; }
void mark_object(object *pair) { object *obj; obj = pair; while (is_pair(obj)) { dump_object(obj); gc_set(obj); obj = obj_pn(obj); } if (is_atom(obj)) { dump_object(obj); gc_set(obj); } }
static void print_list(Value x) { putchar('('); print(car(x)); x = cdr(x); for (; is_pair(x); x = cdr(x)) { putchar(' '); print(car(x)); } if (x != NIL) { prints(" . "); print(x); } putchar(')'); }
lua_list_type read_list( const std::string &path ) { lua_list_type result; int level = state_.get_table( path.c_str( ) ); if( level ) { frlua::objects::base_sptr t = state_.get_table( -1 ); for( size_t i=0; i<t->count( ); ++i ) { const frlua::objects::base *next( t->at( i ) ); if( is_pair( next ) && is_string( next->at( 1 ) ) ) { result.push_back( next->at( 1 )->str( ) ); } } state_.pop( level ); } return result; }
static obj_t find_symbol(obj_t name) { obj_t p, sym; obj_t sym_name; CHECK(is_string(name), "must be string", name); for (p = all_symbols_list; !is_null(p); p = pair_cdr(p)) { assert(is_pair(p)); sym = pair_car(p); assert(is_symbol(sym)); sym_name = symbol_name(sym); assert(is_string(sym_name)); if (strings_are_equal(sym_name, name)) return sym; } return EMPTY_LIST; }
void display(LISP_OBJ_PTR objp) { switch (objp->form) { case INT_FORM: fprintf(out_stream, "%d", int_value(objp)); break; case FLOAT_FORM: fprintf(out_stream, "%g", float_value(objp)); break; case CHAR_FORM: fprintf(out_stream, "%c", char_value(objp)); break; case STRING_FORM: fprintf(out_stream, "%s", string_value(objp)); break; case SYMBOL_FORM: fprintf(out_stream, "%s", symbol_value(objp)); break; case PROCEDURE_FORM: fprintf(out_stream, "<PROCEDURE>"); break; case BOOLEAN_FORM: fprintf(out_stream, "#%c", bool_value(objp) ? 't' : 'f'); break; case CONS_FORM: fprintf(out_stream, "("); while (TRUE) { print_lispobj(car(objp)); objp = cdr(objp); if (objp == nil_ptr) break; if (!(is_pair(objp))) { printf(" . "); print_lispobj(objp); break; } fprintf(out_stream, " "); } fprintf(out_stream, ")"); break; case NO_FORM: fprintf(out_stream, "no form, boss"); break; default: fprintf(out_stream, "dunno that form %d", form(objp)); } }
static void print_list(FILE *out, obj_t obj) { putc('(', out); print_atom(out, car(obj)); for (obj = cdr(obj); is_pair(obj); obj = cdr(obj)) { putc(' ', out); print_atom(out, car(obj)); } if (is_null(obj)) { putc(')', out); } else { fputs(" . ", out); print_atom(out, obj); putc(')', out); } }
void write_pair(obj_t pair) { obj_t car_obj; obj_t cdr_obj; car_obj = car(pair); cdr_obj = cdr(pair); write(car_obj); if (is_pair(cdr_obj)) { printf(" "); write_pair(cdr_obj); } else if (cdr_obj == imm_empty_list) { return; } else { printf(" . "); write(cdr_obj); } }
object* evlist_cc(object* lst, environment* env, continuation* cc) { DEBUG("evlist_cc lst", lst); DEBUG("evlist_cc cc", cc); if (is_null(lst)) { return cc->apply(lst); } else if (!is_pair(lst)) { return error("illegal arg list: " + stringify(lst)); } else { continuation* cc2 = new continuation_evlist(cdr(lst), env, cc); return eval_cc(car(lst), env, cc2); } }
void print_ptr_rec(ptr x) { /*printf("%u\n", x);*/ if (is_fixnum(x)) { printf("%d", to_fixnum(x)); } else if (x == bool_f) { printf("#f"); } else if (x == bool_t) { printf("#t"); } else if (is_null(x)) { print_null(); } else if (is_char(x)) { printf("%s", beautify(to_char(x))); } else if (is_pair(x)) { printf("("); print_pair(x); printf(")"); } else { printf("#<unknown 0x%08x>", x); } }
value_t compile(value_t expr, value_t next) { value_t result; expr = macro_expand(expr); protect_value(expr); if (is_symbol(expr)) { result = make_list(OP_LOOKUP, expr, next, 0); } else if (is_pair(expr)) { result = compile_form(expr, next); } else if (expr == EMPTY_LIST) { error(1, 0, "Illegal empty combination ()"); } else { result = make_list(OP_CONSTANT, expr, next, 0); } unprotect_storage(1); return result; }
static void write_pair(object pair, FILE *out) { object car_obj, cdr_obj; car_obj = car(pair); cdr_obj = cdr(pair); lisp_print(car_obj, out); if (is_pair(cdr_obj)) { fprintf(out, " "); write_pair(cdr_obj, out); } else if (is_null(cdr_obj)) { return; } else { fprintf(out, " . "); lisp_print(cdr_obj, out); } }
static int print_quotation(FILE *out, obj_t obj) { obj_t sym = car(obj); if (!is_symbol(sym)) return 0; if (!is_pair(cdr(obj))) return 0; if (!is_null(cdr(cdr(obj)))) return 0; register_quotation_symbols(); if (fetch_symbol(sym) == S_QUOTE) { fputs("'", out); } else if (fetch_symbol(sym) == S_QUASIQUOTE) { fputs("`", out); } else if (fetch_symbol(sym) == S_UNQUOTE) { fputs(",", out); } else if (fetch_symbol(sym) == S_UNQUOTE_SPLICING) { fputs(",@", out); } else { return 0; } print_atom(out, car(cdr(obj))); return 1; }
static void print_atom(FILE *out, obj_t obj) { if (eq(obj, unspecific)) { fputs("#<unspecified>", out); } else if (is_null(obj)) { fputs("()", out); } else if (is_bool(obj)) { if (fetch_bool(obj)) fputs("#t", out); else fputs("#f", out); } else if (is_symbol(obj)) { print_string(out, fetch_symbol(obj)); } else if (is_num(obj)) { fprintf(out, "%ld", (long)fetch_num(obj)); } else if (is_char(obj)) { char ch = fetch_char(obj); switch (ch) { case ' ': fputs("#\\space", out); break; case '\n': fputs("#\\newline", out); break; default: fprintf(out, "#\\%c", ch); break; } } else if (is_string(obj)) { putc('"', out); print_string(out, fetch_string(obj)); putc('"', out); } else if (is_pair(obj)) { if (!print_quotation(out, obj)) print_list(out, obj); } else { fputs("#<unknown>", out); /* TODO: function, lambda */ } }
obj_t *apply_procedure(obj_t *proc, obj_t *args) { PUSH_ROOT(proc); PUSH_ROOT(args); AUTO_ROOT(body, procedure_body(proc)); if (procedure_is_C(proc)) { obj_t *env = F_ENV; if (!procedure_is_special_form(proc)) env = procedure_env(proc); GOTO_FRAME(make_short_frame, (C_procedure_t *)body, args, env); } AUTO_ROOT(new_env, make_env(procedure_env(proc))); AUTO_ROOT(formals, procedure_args(proc)); AUTO_ROOT(actuals, args); while (!is_null(formals) || !is_null(actuals)) { if (is_null(formals)) { printf_unchecked("calling %O\n", proc); RAISE("too many args"); } obj_t *formal, *actual; if (is_pair(formals)) { if (is_null(actuals)) { printf_unchecked("proc=%O\n", proc); RAISE("not enough args"); } formal = pair_car(formals); formals = pair_cdr(formals); actual = pair_car(actuals); actuals = pair_cdr(actuals); } else { formal = formals; actual = actuals; formals = actuals = NIL; } env_bind(new_env, formal, BT_LEXICAL, M_MUTABLE, actual); } GOTO(b_eval_sequence, body, new_env); }
pair_t pair_new(pair_t car, pair_t cdr) { pair_t p; static const struct GC_finalizer_closure fc = { pair_dct, NULL }; p = GC_finalized_malloc(sizeof(struct pair_s), &fc); if (p == NULL) { fprintf(stderr, "Out of memory!\n"); exit(3); } my_assert(!is_pair(p)); my_assert(memeq(p, 0, sizeof(struct pair_s))); memcpy(p->magic, pair_magic, sizeof(p->magic)); p->checksum = 782 + (car? car->checksum : 0) + (cdr? cdr->checksum : 0); p->car = car; p->cdr = cdr; # ifdef DEBUG_DISCLAIM_DESTRUCT printf("Construct %p = (%p, %p)\n", (void *)p, (void *)p->car, (void *)p->cdr); # endif return p; }
Cell eval(Cell exp, Cell env) { if (is_self_evaluating(exp)) { return exp; } else if (is_atom(exp)) { return lookup(exp, env); } else if (is_tagged(exp, atom("define"))) { return define(car(cdr(exp)), eval(car(cdr(cdr(exp))), env), env); } else if (is_tagged(exp, atom("set!"))) { return set(car(cdr(exp)), eval(car(cdr(cdr(exp))), env), env); } else if (is_tagged(exp, atom("if"))) { Cell cond = eval(car(cdr(exp)), env); if (is_atom(cond) && is_eq(cond, atom("#f"))) { exp = car(cdr(cdr(cdr(exp)))); } else { exp = car(cdr(cdr(exp))); } return eval(exp, env); } else if (is_tagged(exp, atom("vau"))) { return procedure(exp, env); } else if (is_pair(exp)) { Cell proc = eval(car(exp), env); if (is_primitive(proc)) { return (proc->primitive)(eval_operands(cdr(exp), env)); } else if (is_procedure(proc)) { Cell src = car(proc); Cell e = car(cdr(cdr(src))); Cell para = cons(e, cons(car(cdr(src)), null)); Cell args = cons(env, cons(cdr(exp), null)); Cell body = car(cdr(cdr(cdr(src)))); return eval(body, extend_env(para, args, cdr(proc))); } } fprintf(stderr, "eval illegal state\n"); return atom("#<void>"); }
bool is_application(object *exp) { return is_pair(exp); }