void set_variable_value(OBJ name,OBJ value,OBJ env) { OBJ frame; OBJ names; OBJ values; while(!nullp(env)) { frame = env_frame(env); names = car(frame); values = cdr(frame); while(!nullp(names)) { if(eq(car(names),name)) { car(values) = value; return; } names = cdr(names); values = cdr(values); } env = env_base(env); } fprintf(stderr, "can't set! unbound variable, %s\n", obj_symbol_data(name)); }
static obj_t * lang_if(obj_t **frame, obj_t **tailp) { obj_t *expr = *frame_ref(frame, 0); obj_t *pred, *todo, *otherwise; *tailp = tail_token; pred = pair_car(expr); todo = pair_cadr(expr); otherwise = pair_cddr(expr); if (nullp(otherwise)) { otherwise = unspec_wrap(); } else if (!nullp(pair_cdr(otherwise))) { fatal_error("if -- too many arguments", frame); } else { otherwise = pair_car(otherwise); } { // start to evaluate the predicate. obj_t **pred_frame = frame_extend( frame, 1, FR_CONTINUE_ENV | FR_SAVE_PREV); *frame_ref(pred_frame, 0) = pred; pred = eval_frame(pred_frame); } if (to_boolean(pred)) { return todo; } else { return otherwise; } }
/* * Create cons graph for given list that can be rendered by Graphviz. * * Example usage: * * /mickey -e '(display (:list->dot (quote (define (square x) (* x x * 123)))))' | dot -Tpng -o graph.png && open graph.png * */ cons_t* proc_list_to_dot_helper(cons_t *p, environment_t* e) { static const char* line_style = "[\"ol\"=\"box\"]"; static const char* shape = "record"; if ( nullp(p) ) return string(""); std::string s; if ( pairp(p) ) { if ( !nullp(car(p)) ) { const char* port = ""; if ( pairp(car(p)) ) port = ":head"; s += format(" \"%p\":head -> \"%p\"%s %s;\n", p, car(p), port, line_style); s += proc_list_to_dot_helper(car(p), e)->string; } if ( !nullp(cdr(p)) ) { const char* port = ""; if ( pairp(cdr(p)) ) port = ":head"; s += format(" \"%p\":tail -> \"%p\"%s %s;\n", p, cdr(p), port, line_style); s += proc_list_to_dot_helper(cdr(p), e)->string; } s += format(" \"%p\" [label=\"<head>|<tail>\", shape=\"%s\"];\n", p, shape); } else s += format(" \"%p\" [label=\"%s\", shape=\"none\"];\n", p, sprint(p).c_str()); return string(s.c_str()); }
static void cell_write(SExp s, int b_escape, struct StreamBase* strm) { // 省略表示系のチェック if (consp(CDR(s)) && nullp(CDDR(s))) { SExp t = CAR(s); const char* str = NULL; if (eq(t, intern("quote"))) { str = "'"; } else if (eq(t, intern("quasiquote"))) { str = "`"; } if (str != NULL) { strm_puts(strm, str, 0); swrite(CADR(s), b_escape, strm); return; } } { int first = TRUE; SExp p; strm_puts(strm, "(", 0); for (p = s; consp(p); p = CDR(p)) { if (!first) strm_puts(strm, " ", 0); first = FALSE; swrite(CAR(p), b_escape, strm); } if (!nullp(p)) { strm_puts(strm, " . ", 0); swrite(p, b_escape, strm); } strm_puts(strm, ")", 0); } }
static obj_t * lang_begin(obj_t **frame, obj_t **tailp) { obj_t *expr = *frame_ref(frame, 0); *tailp = tail_token; obj_t *iter; for (iter = expr; pairp(iter); iter = pair_cdr(iter)) { // Eval each expression except the last. if (!pairp(pair_cdr(iter))) { break; } obj_t **expr_frame = frame_extend(frame, 1, FR_SAVE_PREV | FR_CONTINUE_ENV); *frame_ref(expr_frame, 0) = pair_car(iter); eval_frame(expr_frame); } if (nullp(iter)) { // Empty (begin) expression return unspec_wrap(); } else if (!nullp(pair_cdr(iter))) { fatal_error("begin -- not a well-formed list", frame); } return pair_car(iter); }
static void log_cleanup() { nullp(&prefix); nullp(&filename); if (output != stdout) fclose(output); }
varargs string wrap(string str, int width, int indent) { if (nullp(str)) return ""; if (nullp(width)) width = SZ; if (nullp(indent)) indent = 0; return terminal_colour(str, TERMINAL_D->query_term_info("wrap"), width, indent)+"\n"; }
Cell* op_plus::eval_op(Cell* operand) const { // keep adding until reaches nil pointer int int_sum = 0; double double_sum = 0.0; bool double_exist = false; //to store the result of car cell if it is a list Cell* operand_ptr; //check if operand is not empty while(!nullp(operand)) { if (nullp(car(operand))) { if (operand_ptr != NULL) delete operand_ptr; throw runtime_error("'+' can only deal with integer and double."); } else if (listp(car(operand))) { operand_ptr = eval(car(operand)); } else if (symbolp(car(operand))) { operand_ptr = search_symbol(get_symbol(car(operand)),true); } else { operand_ptr = car(operand); } if (intp(operand_ptr)) { int_sum += get_int(operand_ptr); } else if (doublep(operand_ptr)) { double_sum += get_double(operand_ptr); double_exist = true; } else { delete operand_ptr; throw runtime_error("'+' can only deal with integer and double."); } operand = cdr(operand); } if (double_exist) return make_double(double_sum+int_sum); else return make_int(int_sum); };
static obj_t * lang_quote(obj_t **frame, obj_t **tailp) { obj_t *expr = *frame_ref(frame, 0); *tailp = NULL; if (nullp(expr) || !nullp(pair_cdr(expr))) { fatal_error("quote -- wrong number of argument", frame); } return pair_car(expr); }
void judge_nil_cell(Cell* const c, string oper) { if (!nullp(c)) { return; } if (nullp(c) && oper != "begin") { throw operate_on_nil_error(oper + " operator requires non-nil operand"); } if (nullp(c) || oper == "begin") { throw operate_on_nil_error("empty list cannot be evaluated"); } }
static obj_t * lang_quasiquote(obj_t **frame, obj_t **tailp) { obj_t *expr = *frame_ref(frame, 0); obj_t *content; *tailp = NULL; if (nullp(expr) || !nullp(pair_cdr(expr))) { fatal_error("quasiquote -- wrong number of argument", frame); } // Expand... content = pair_car(expr); return expand_quasiquote(frame, content, NULL); }
OBJ lookup_variable_value(OBJ name,OBJ env) { OBJ find; while(!nullp(env)) { find = assq(name,env_frame(env)); if(!nullp(find)) return cdr(find); env = env_base(env); } if(find == OBJ_NULL) fprintf(stderr,"undefined variable:%s\n",obj_symbol_data(name)); return OBJ_NULL; }
// // list creation/access // node *lastcell(node *list) { node *ptr = list; while (consp(ptr) and not nullp(cdr(ptr))) { nextptr(ptr); } return ptr; }
static environment_t* only(environment_t* e, cons_t* ids) { assert_type(PAIR, ids); // build a new environment and return it environment_t *r = null_environment(); for ( dict_t::const_iterator i = e->symbols.begin(); i != e->symbols.end(); ++i ) { std::string name = (*i).first; // only import specified names // TODO: Fix slow O(n^2) algo below for ( cons_t *id = ids; !nullp(id); id = cdr(id) ) { assert_type(SYMBOL, car(id)); if ( symbol_name(car(id)) == name ) { r->symbols[name] = (*i).second; break; } } } return r; }
int last(int lis){ while(!nullp(cdr(lis))) lis = cdr(lis); return(car(lis)); }
cons_t* proc_mul(cons_t *p, environment_t *env) { rational_t product; product.numerator = 1; product.denominator = 1; bool exact = true; for ( ; !nullp(p); p = cdr(p) ) { cons_t *i = listp(p)? car(p) : p; if ( integerp(i) ) { product *= i->number.integer; if ( !i->number.exact ) exact = false; } else if ( rationalp(i) ) { if ( !i->number.exact ) exact = false; product *= i->number.rational; } else if ( realp(i) ) { // automatically convert; perform rest of computation in floats exact = false; return proc_mulf(cons(real(product), p), env); } else raise(runtime_exception("Cannot multiply integer with " + to_s(type_of(i)) + ": " + sprint(i))); } return rational(product, exact); }
/* * Transform * * (case-lambda * ((<form1> <body1>) * (<form2> <body2>) * ...) * * to * * (lambda args * (cond * (((if (variadic? <form1>) >= =) (length args) <form1-min-args>) * (apply (lambda (<form1>) <body1>) args)) * ...)) */ cons_t* proc_case_lambda(cons_t* p, environment_t* e) { cons_t *cond_cases = list(); cons_t *cases = p; for ( cons_t* c = cases; !nullp(c); c = cdr(c) ) { cons_t *formals = caar(c); cons_t *body = cdar(c); // ((if (variadic? <form1>) >= =) argc <form1-min-args>) cons_t* cond_if = cons(symbol(variadicp(formals)? ">=" : "="), cons(cons(symbol("length"), cons(symbol("args"))), cons(integer(min_args(formals))))); // (apply (lambda (<form1>) <body1>) args) cons_t *cond_then = cons(symbol("apply"), cons(cons(symbol("lambda"), cons(formals, body)), cons(symbol("args")))); cond_cases = append(cond_cases, list(list(cond_if, cond_then))); } cond_cases = splice(cons(symbol("cond")), cond_cases); return make_closure(symbol("args"), cons(cond_cases), e); }
string print_vars(mixed *vars) { string *result = allocate(sizeof(vars)); int i; for (i=0; i<sizeof(vars); i++) { if (mapp(vars[i])) result[i] = "([ ... ])"; else if (functionp(vars[i])) result[i] = "(: ... :)"; else if (intp(vars[i])) { if (vars[i]) result[i]=vars[i]+""; else if (nullp(vars[i])) result[i]="NULL"; else if (undefinedp(vars[i])) result[i]="UNDEFINED"; else result[i]="0"; } else if (stringp(vars[i])) result[i] = "\""+vars[i]+"\""; else if (arrayp(vars[i])) result[i] = "({ ... })"; else if (floatp(vars[i])) result[i] = vars[i]+""; else if (bufferp(vars[i])) result[i] = "<BUFFER>"; } return implode(result, ", "); }
int f_cond(int arglist){ int arg1,arg2,arg3; if(nullp(arglist)) return(NIL); arg1 = car(arglist); checkarg(LIST_TEST, "cond", arg1); arg2 = car(arg1); arg3 = cdr(arg1); if(! (nullp(eval(arg2)))) return(f_begin(arg3)); else return(f_cond(cdr(arglist))); }
cons_t* proc_lcm(cons_t* p, environment_t* e) { switch ( length(p) ) { case 0: return integer(1); case 1: assert_type(INTEGER, car(p)); return integer(abs(car(p)->number.integer)); case 2: { assert_type(INTEGER, cadr(p)); int a = abs(car(p)->number.integer), b = abs(cadr(p)->number.integer); return integer(lcm(a, b)); } default: { /* * We have at least 3 numbers; handle recursively, since * lcm(a, b, c) = lcm(lcm(a, b), c) */ cons_t *r = car(p); p = cdr(p); while ( !nullp(p) ) { r = proc_lcm(list(r, car(p)), e); p = cdr(p); } return integer(r->number.integer); } } }
static environment_t* except(environment_t* e, cons_t* ids) { assert_type(PAIR, ids); // build a new environment and return it environment_t *r = null_environment(); for ( dict_t::const_iterator i = e->symbols.begin(); i != e->symbols.end(); ++i ) { std::string name = (*i).first; // do not import specified name // TODO: Fix slow O(n^2) algo below for ( cons_t *id = ids; !nullp(id); id = cdr(id) ) { assert_type(SYMBOL, car(id)); if ( symbol_name(car(id)) == name ) goto DO_NOT_IMPORT; } r->symbols[name] = (*i).second; DO_NOT_IMPORT: continue; } return r; }
static int parse_headword(chasen_cell_t *cell, int default_weight, lexicon_t *lex) { chasen_cell_t *headword; if (atomp(cell)) { headword = cell; lex->weight = (unsigned short)default_weight; } else if (atomp(cha_car(cell))) { headword = cha_car(cell); if (nullp(cha_cdr(cell))) lex->weight = (unsigned short)default_weight; else if (!atomp(cha_car(cha_cdr(cell)))) return err_msg("has invalid form", cell); else { int weight; weight = (int)(atof(s_atom_val(cha_car(cha_cdr(cell)))) * MRPH_DEFAULT_WEIGHT); if (weight < 0) { weight = 0; return err_msg(": weight must be between 0 and 6553.5", cell); } else if (weight > MRPH_WEIGHT_MAX) { weight = MRPH_WEIGHT_MAX; return err_msg(": weight must be between 0 and 6553.5", cell); } lex->weight = (unsigned short)weight; } } else { return err_msg("has invalid form", cell); } if (get_string(headword, lex->headword, MIDASI_LEN) < 0) return -1; return lex->weight; }
cons_t* proc_add(cons_t *p, environment_t* env) { /* * Integers have an IDENTITY, so we can do this, * but a more correct approach would be to take * the value of the FIRST number we find and * return that. */ rational_t sum; sum.numerator = 0; sum.denominator = 1; bool exact = true; for ( ; !nullp(p); p = cdr(p) ) { cons_t *i = listp(p)? car(p) : p; if ( integerp(i) ) { if ( !i->number.exact ) exact = false; sum += i->number.integer; } else if ( rationalp(i) ) { if ( !i->number.exact ) exact = false; sum += i->number.rational; } else if ( realp(i) ) { // automatically convert; perform rest of computation in floats exact = false; return proc_addf(cons(real(sum), p), env); } else raise(runtime_exception( "Cannot add integer with " + to_s(type_of(i)) + ": " + sprint(i))); } return rational(sum, exact); }
/* * (set-video-mode <width> <height> <bits per pixel>?) or * (set-video-mode <width> <height> <bits per pixel> <mode flags>+) * * where <symbols> are: * swsurface * hwsurface * asyncblit * anyformat * hwpalette * doublebuf * fullscreen * opengl * openglblit * resizable * noframe * */ cons_t* set_video_mode(cons_t* p, environment_t*) { assert_length_min(p, 2); assert_type(INTEGER, car(p)); assert_type(INTEGER, cadr(p)); // dimension int x = car(p)->integer; int y = cadr(p)->integer; // default values int bits = 32; uint32_t mode = 0; /////////////////// raise(runtime_exception("Testing")); /////////////////// // bits per pixel if ( integerp(caddr(p)) ) bits = caddr(p)->integer; // options cons_t *opts = symbolp(caddr(p))? cddr(p) : symbolp(cadddr(p))? cdddr(p) : nil();; for ( cons_t *s = opts; !nullp(s); s = cdr(s) ) { assert_type(SYMBOL, car(s)); std::string sym = symbol_name(s); int size = sizeof(sdl_flags) / sizeof(key_value_t<std::string, uint32_t>); for ( int n=0; n < size; ++n ) if ( sym == sdl_flags[n].key ) { /////////////////// printf("flag %s\n", sym.c_str()); printf("value %d and %d\n", sdl_flags[n].value, SDL_HWSURFACE); /////////////////// mode |= sdl_flags[n].value; goto NEXT_FLAG; } raise(runtime_exception("Unknown SDL video mode flag: " + sym)); NEXT_FLAG: continue; } mode = SDL_HWSURFACE; /////////////////// printf("video mode\n"); fflush(stdout); /////////////////// SDL_Surface *screen = SDL_SetVideoMode(x, y, bits, mode); if ( screen == NULL ) raise(runtime_exception(SDL_GetError())); return pointer(new pointer_t("sdl-surface", (void*)screen)); }
static environment_t* rename(environment_t* e, cons_t* ids) { assert_type(PAIR, ids); // build a new environment and return it environment_t *r = null_environment(); // TODO: Below code runs in slow O(n^2) time for ( dict_t::const_iterator i = e->symbols.begin(); i != e->symbols.end(); ++i ) { std::string name = (*i).first; // find new name for ( cons_t *id = ids; !nullp(id); id = cdr(id) ) { assert_type(PAIR, car(id)); assert_type(SYMBOL, caar(id)); assert_type(SYMBOL, cadar(id)); if ( symbol_name(caar(id)) == name ) { name = symbol_name(cadar(id)); break; } } r->symbols[name] = (*i).second; } return r; }
cons_t* proc_import(cons_t* p, environment_t* e) { assert_length_min(p, 1); assert_type(PAIR, car(p)); /* * Handle all import sets in (import <import set> ...) */ for ( ; !nullp(p); p = cdr(p) ) { environment_t *impenv = import_set(car(p)); /* * Now we need to bring the imported environment to the environment, * so that the new definitions are available there. * * We do this by copying the definitions. */ merge(e, impenv); /* * But we also need to connect the lower level imported environment to * definitions found in its outer environment. * * This is because the exported functions in impenv must be able to see * definitions in the toplevel, controlling, environment. * * Consider the (mickey environment) module, which has a "syntactic" * procedure bound?. * * If we (import (scheme write)) then we get the procedure display. But * if we now (import (mickey environment)) and call (bound? display) * then bound? will not be able to see any definition of display, and * will wrongly return #f. * * Note that I'm not entirely certain that this is the correct way of * handling things, since closures must be evaluated in the environment * they were defined in. * * TODO: Think hard about this and write some tests. * * Note that this behaviour might be different for libraries that are * imported as scheme source code. They must be first evaluated in * their own closed environment (to bind definitions) before being * connected to the outer one. * * I think what we need is a global pointer to the ACTUAL top-level * environment. * */ impenv->outer = e; } /* * TODO: Should we return the final environment, so we can easily run * cond-expand on it from outside define-library? E.g., (cond-expand * (import (foo bar))) */ return unspecified(nil()); }
static void generate_app(struct vec *v,OBJ ast) { OBJ procedure; OBJ primitive; OBJ cell; OBJ formals; if(obj_app_type(ast) == 0) /* procedure */ { generate_begin(v,obj_app_params(ast)); procedure = obj_app_data(ast); formals = obj_procedure_formals(procedure); while(obj_pairp(formals)) { emit(v,PUSH); emitv(v,car(formals)); emit(v,SET_CDR); emit(v,POP); formals = cdr(formals); } if(!nullp(formals)) { emit(v,PUSH); emitv(v,formals); /* fixme: something should do to support other form formals */ } emit(v,PUSH); emitv(v,procedure); emit(v,obj_app_tail(ast)?TAIL_CALL:CALL); } else if(obj_app_type(ast) == 1) /* primitive */ { generate_begin(v,obj_app_params(ast)); primitive = obj_app_data(ast); switch(obj_primitive_type(primitive)) { case DATA: emit(v,obj_primitive_opcode(primitive)); emitv(v,obj_primitive_data(primitive)); break; case FUNCALL: emit(v,obj_primitive_opcode(primitive)); emitv(v,obj_primitive_proc(primitive)); break; default: emit(v,obj_primitive_opcode(primitive)); } } else if(obj_app_type(ast) == 2) /* uninitialized procedure */ { cell = obj_app_data(ast); generate_begin(v,obj_app_params(ast)); emit(v,PUSH); emitv(v,cell); emit(v,UNINIT_REF); emit(v,BIND); emit(v,obj_app_tail(ast)?TAIL_CALL:CALL); } }
int assv(int obj, int lis){ while(!nullp(lis)) if(eqvp(obj,caar(lis))) return(car(lis)); else lis = cdr(lis); return(BOOLF); }
// // argument/struture access // node *nextarg(node **pargs) { if (not consp(*pargs) or nullp(*pargs)) { setflag("too few arguments\n"); } node *arg = car(*pargs); *pargs = cdr(*pargs); return arg; }
int assoc(int sym, int lis){ if(nullp(lis)) return(0); else if(eqp(sym, caar(lis))) return(car(lis)); else return(assoc(sym,cdr(lis))); }