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