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);
}
