/*
* (initialize) ==> nothing
*/
cons_t* initialize(cons_t*, environment_t*)
{
if ( SDL_Init(SDL_INIT_VIDEO) != 0 )
raise(runtime_exception(SDL_GetError()));
return unspecified();
}
cons_t* proc_display(cons_t *p, environment_t*)
{
assert_length(p, 1, 2);
/*
* Get port to write to.
*
* TODO: Should we check if the file descriptor
* is open?
*/
port_t* port = &global_opts.current_output_device;
if ( length(p) == 2 ) {
assert_type(PORT, cadr(p));
port = cadr(p)->port;
}
/*
* TODO: Implement display in terms of (write) and
* use tail call elimination to be able to
* endlessly print circular lists.
*/
std::string s = print(car(p));
fwrite(s.c_str(), s.length(), 1, port->file());
return unspecified();
}
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());
}
cons_t* flush_output_port(cons_t* p, environment_t*)
{
assert_length(p, 0, 1);
FILE *f = global_opts.current_output_device.file();
if ( length(p) == 1 ) {
assert_type(PORT, car(p));
f = car(p)->port->file();
}
fflush(f);
return unspecified();
}
/* evaldef.c 147e */
Env evaldef(Def d, Env env, Echo echo) {
switch (d->alt) {
case VAL:
/* evaluate [[val]] binding and return new environment 148a */
{
Value v;
if (find(d->u.val.name, env) == NULL)
env = bindalloc(d->u.val.name, unspecified(), env);
v = eval(d->u.val.exp, env);
*find(d->u.val.name, env) = v;
if (echo == ECHOING) {
if (d->u.val.exp->alt == LAMBDAX)
print("%n\n", d->u.val.name);
else
print("%v\n", v);
}
return env;
}
case EXP:
/* evaluate expression, store the result in [[it]], and return new environment 148b */
{
Value v = eval(d->u.exp, env);
Value *itloc = find(strtoname("it"), env);
if (echo == ECHOING)
print("%v\n", v);
if (itloc == NULL) {
return bindalloc(strtoname("it"), v, env);
} else {
*itloc = v;
return env;
}
}
case DEFINE:
/* evaluate function definition and return new environment 148c */
/* if [[d->u.define.lambda.formals]] contains a duplicate, call [[error]] 715d */
if (duplicatename(d->u.define.lambda.formals) != NULL)
error(
"formal parameter %n appears twice in definition of function %n",
duplicatename(d->u.define.lambda.formals), d->u.define.name);
return evaldef(mkVal(d->u.define.name, mkLambdax(d->u.define.lambda)),
env, echo);
}
assert(0);
return NULL;
}
cons_t* proc_load(cons_t *args, environment_t *env)
{
assert_length(args, 1, 2);
assert_type(STRING, car(args));
cons_t *filename = car(args);
cons_t *env_spec = cadr(args);
if ( !nullp(env_spec) ) {
assert_type(ENVIRONMENT, env_spec);
env = env_spec->environment;
} else {
/*
* We are supposed to use (interaction-environment) here, but we'll
* cheeat and use the topmost environment for now.
*/
env = env->outermost();
}
// first try filename without include path
std::string file = filename->string;
// no cigar? try include path
if ( !file_exists(file) )
file = format("%s/%s", global_opts.include_path, filename->string);
if ( !file_exists(file) ) {
raise(runtime_exception(format(
"Could not find file '%s' in any search paths", filename->string)));
}
// Set current filename, in case we need it for error reporting.
const char* prev = global_opts.current_filename;
global_opts.current_filename = file.c_str();
// Parse and evaluate file.
program_t *p = parse(slurp(open_file(file)), env);
eval(cons(symbol("begin"), p->root), p->globals);
// Restore filename.
global_opts.current_filename = prev;
return unspecified();
}
cons_t* proc_help(cons_t*, environment_t*)
{
printf(
"\n"
"Welcome to Mickey, a scheme interperter that aims to correctly implement\n"
"the whole of R7RS-small.\n"
"\n"
"In this REPL environment, you have several libraries preloaded for your\n"
"convenience. You can import additional libraries by invoking, e.g.,\n"
"(import (scheme lazy)).\n"
"\n"
"Also, note that files executed from the command line have NO libraries\n"
"imported by default, so you have to explicitly import typically\n"
"(scheme base) and (scheme write).\n"
"\n"
"You will also stumble upon various bugs in Mickey, so please send bug\n"
"reports.\n"
"\n"
);
return unspecified();
}
/*
* As in Impcore, the evaluator is still a [[switch]]:
* <eval.c>=
*/
Value eval(Exp e, Env env) {
checkoverflow(1000000 * sizeof(char *)); /* OMIT */
switch (e->alt) {
case LITERAL:
/*
* <evaluate [[e->u.literal]] and return the result>=
*/
return e->u.literal;
case VAR:
/*
* Variables
*
* Variable lookup and assignment are simpler than in
* Impcore, because we have only one rule each. We
* implement rho(x) by find(x, rho), we implement sigma
* (l) by [[*]]l, and we update sigma(l) by assigning to
* [[*]]l. [*]
* <evaluate [[e->u.var]] and return the result>=
*/
if (find(e->u.var, env) == NULL)
error("variable %n not found", e->u.var);
return *find(e->u.var, env);
case SET:
/*
* [*] [*]
* <evaluate [[e->u.set]] and return the result>=
*/
if (find(e->u.set.name, env) == NULL)
error("set unbound variable %n", e->u.set.name);
return *find(e->u.set.name, env) = eval(e->u.set.exp, env);
case IFX:
/*
* Conditional, iteration, and sequence
*
* The implementations of the control-flow operations
* are very much as in Impcore. We don't bother
* repeating the operational semantics.
* <evaluate [[e->u.ifx]] and return the result>=
*/
if (istrue(eval(e->u.ifx.cond, env)))
return eval(e->u.ifx.true, env);
else
return eval(e->u.ifx.false, env);
case WHILEX:
/*
* <evaluate [[e->u.whilex]] and return the result>=
*/
while (istrue(eval(e->u.whilex.cond, env)))
eval(e->u.whilex.body, env);
return falsev;
case BEGIN:
/*
* <evaluate [[e->u.begin]] and return the result>=
*/
{
Explist el;
Value v = falsev;
for (el = e->u.begin; el; el = el->tl)
v = eval(el->hd, env);
return v;
}
case APPLY:
/*
* We handle application of primitives separately from
* application of closures.
*
* <evaluate [[e->u.apply]] and return the result>=
*/
{
Value f = eval (e->u.apply.fn, env);
Valuelist vl = evallist(e->u.apply.actuals, env);
switch (f.alt) {
case PRIMITIVE:
/*
* Applying a primitive is simpler than in our Impcore
* interpreter because we represent primitives by
* function pointers and tags. The tag is passed to the
* function, along with the arguments ([[vl]]), plus the
* abstract syntax [[e]], which is used in error
* messages.
* <apply [[f.u.primitive]] to [[vl]] and return the result>=
*/
return f.u.primitive.function(e, f.u.primitive.tag, vl);
case CLOSURE:
/*
* To apply a closure, we extend the closure's
* environment (rho_c in the operational semantics) with
* the bindings for the formal variables and then
* evaluate the body in that environment.
* <apply [[f.u.closure]] to [[vl]] and return the result>=
*/
{
Namelist nl = f.u.closure.lambda.formals;
checkargc(e, lengthNL(nl), lengthVL(vl));
return eval(f.u.closure.lambda.body,
bindalloclist(nl, vl, f.u.closure.env));
}
default:
error("%e evaluates to non-function %v in %e", e->u.apply.fn, f,
e);
}
}
case LETX:
/*
* Let, let*, and letrec
*
* Each expression in the [[let]] family uses its
* internal names and expressions to create a new
* environment, then evaluates the body in that
* environment. The rules for creating the environment
* depend on the keyword.
* <evaluate [[e->u.letx]] and return the result>=
*/
switch (e->u.letx.let) {
case LET:
/*
* <if [[e->u.letx.nl]] contains a duplicate, complain of error in
[[let]]>=
*/
if (duplicatename(e->u.letx.nl) != NULL)
error("bound name %n appears twice in let", duplicatename(e->
u.letx.nl));
/*
* A \xlet expression evaluates the expressions to be
* bound, then binds them all at once. The functions
* [[evallist]] and [[bindalloclist]] do all the work.
* <extend [[env]] by simultaneously binding [[el]] to [[nl]]>=
*/
env = bindalloclist(e->u.letx.nl, evallist(e->u.letx.el, env), env);
break;
case LETSTAR:
/*
* A \xletstar expression binds a new name as each
* expression is evaluated.
*
* <extend [[env]] by sequentially binding [[el]] to [[nl]]>=
*/
{
Namelist nl;
Explist el;
for (nl = e->u.letx.nl, el = e->u.letx.el;
nl && el;
nl = nl->tl, el = el->tl)
env = bindalloc(nl->hd, eval(el->hd, env), env);
assert(nl == NULL && el == NULL);
}
break;
case LETREC:
/*
* <if [[e->u.letx.nl]] contains a duplicate, complain of error in
[[letrec]]>=
*/
if (duplicatename(e->u.letx.nl) != NULL)
error("bound name %n appears twice in letrec", duplicatename(e->
u.letx.nl));
/*
* Finally, \xletrec must bind each name to a location
* before evaluating any of the expressions. The initial
* contents of the new locations are unspecified. To be
* faithful to the semantics, we compute all the values
* before storing any of them.
* <extend [[env]] by recursively binding [[el]] to [[nl]]>=
*/
{
Namelist nl;
Valuelist vl;
for (nl = e->u.letx.nl; nl; nl = nl->tl)
env = bindalloc(nl->hd, unspecified(), env);
vl = evallist(e->u.letx.el, env);
for (nl = e->u.letx.nl;
nl && vl;
nl = nl->tl, vl = vl->tl)
*find(nl->hd, env) = vl->hd;
}
break;
default:
assert(0);
}
return eval(e->u.letx.body, env);
case LAMBDAX:
/*
* Closures and function application
*
* Wrapping a closure is simple; we need only to check
* for duplicate names.
* <evaluate [[e->u.lambdax]] and return the result>=
*/
/*
* Error checking
*
* Here are a few bits of error checking that were
* omitted from Chapter [->].
* <if [[e->u.lambdax.formals]] contains a duplicate, call [[error]]>=
*/
if (duplicatename(e->u.lambdax.formals) != NULL)
error("formal parameter %n appears twice in lambda",
duplicatename(e->u.lambdax.formals));
return mkClosure(e->u.lambdax, env);
}
/* eval.c 143a */
Value eval(Exp e, Env env) {
checkoverflow(1000000 * sizeof(char *)); /* OMIT */
switch (e->alt) {
case LITERAL:
/* evaluate [[e->u.literal]] and return the result 143b */
return e->u.literal;
case VAR:
/* evaluate [[e->u.var]] and return the result 143c */
if (find(e->u.var, env) == NULL)
error("variable %n not found", e->u.var);
return *find(e->u.var, env);
case SET:
/* evaluate [[e->u.set]] and return the result 143d */
if (find(e->u.set.name, env) == NULL)
error("set unbound variable %n", e->u.set.name);
return *find(e->u.set.name, env) = eval(e->u.set.exp, env);
case IFX:
/* evaluate [[e->u.ifx]] and return the result 147a */
if (istrue(eval(e->u.ifx.cond, env)))
return eval(e->u.ifx.true, env);
else
return eval(e->u.ifx.false, env);
case WHILEX:
/* evaluate [[e->u.whilex]] and return the result 147b */
while (istrue(eval(e->u.whilex.cond, env)))
eval(e->u.whilex.body, env);
return falsev;
case BEGIN:
/* evaluate [[e->u.begin]] and return the result 147c */
{
Explist el;
Value v = falsev;
for (el = e->u.begin; el; el = el->tl)
v = eval(el->hd, env);
return v;
}
case APPLY:
/* evaluate [[e->u.apply]] and return the result 144b */
{
Value f = eval (e->u.apply.fn, env);
Valuelist vl = evallist(e->u.apply.actuals, env);
switch (f.alt) {
case PRIMITIVE:
/* apply [[f.u.primitive]] to [[vl]] and return the result 144d */
return f.u.primitive.function(e, f.u.primitive.tag, vl);
case CLOSURE:
/* apply [[f.u.closure]] to [[vl]] and return the result 144e */
{
Namelist nl = f.u.closure.lambda.formals;
checkargc(e, lengthNL(nl), lengthVL(vl));
return eval(f.u.closure.lambda.body,
bindalloclist(nl, vl, f.u.closure.env));
}
default:
error("%e evaluates to non-function %v in %e", e->u.apply.fn, f,
e);
}
}
case LETX:
/* evaluate [[e->u.letx]] and return the result 145c */
switch (e->u.letx.let) {
case LET:
/* if [[e->u.letx.nl]] contains a duplicate, complain of error in [[let]] 715b */
if (duplicatename(e->u.letx.nl) != NULL)
error("bound name %n appears twice in let", duplicatename(e->
u.letx.nl));
/* extend [[env]] by simultaneously binding [[el]] to [[nl]] 145d */
env = bindalloclist(e->u.letx.nl, evallist(e->u.letx.el, env), env);
break;
case LETSTAR:
/* extend [[env]] by sequentially binding [[el]] to [[nl]] 146a */
{
Namelist nl;
Explist el;
for (nl = e->u.letx.nl, el = e->u.letx.el;
nl && el;
nl = nl->tl, el = el->tl)
env = bindalloc(nl->hd, eval(el->hd, env), env);
assert(nl == NULL && el == NULL);
}
break;
case LETREC:
/* if [[e->u.letx.nl]] contains a duplicate, complain of error in [[letrec]] 715c */
if (duplicatename(e->u.letx.nl) != NULL)
error("bound name %n appears twice in letrec", duplicatename(e->
u.letx.nl));
/* extend [[env]] by recursively binding [[el]] to [[nl]] 146b */
{
Namelist nl;
Valuelist vl;
for (nl = e->u.letx.nl; nl; nl = nl->tl)
env = bindalloc(nl->hd, unspecified(), env);
vl = evallist(e->u.letx.el, env);
for (nl = e->u.letx.nl;
nl && vl;
nl = nl->tl, vl = vl->tl)
*find(nl->hd, env) = vl->hd;
}
break;
default:
assert(0);
}
return eval(e->u.letx.body, env);
case LAMBDAX:
/* evaluate [[e->u.lambdax]] and return the result 144a */
/* if [[e->u.lambdax.formals]] contains a duplicate, call [[error]] 715a */
if (duplicatename(e->u.lambdax.formals) != NULL)
error("formal parameter %n appears twice in lambda",
duplicatename(e->u.lambdax.formals));
return mkClosure(e->u.lambdax, env);
}
/*
* <evaldef.c>=
*/
Env evaldef(Def d, Env env, Echo echo) {
switch (d->alt) {
case VAL:
/*
* According to the operational semantics, the
* right-hand side of a [[val]] binding must be
* evaluated in an environment in which the name [[d->
* u.val.name]] is bound. If the binding is not already
* present, we bind the name to an unspecified value.
* <evaluate [[val]] binding and return new environment>=
*/
{
Value v;
if (find(d->u.val.name, env) == NULL)
env = bindalloc(d->u.val.name, unspecified(), env);
v = eval(d->u.val.exp, env);
*find(d->u.val.name, env) = v;
if (echo == ECHOING) {
if (d->u.val.exp->alt == LAMBDAX)
print("%n\n", d->u.val.name);
else
print("%v\n", v);
}
return env;
}
case EXP:
/*
* As in Impcore, evaluating a top-level expression has
* the same effect on the environment as evaluating a
* definition of [[it]], except that the interpreter
* always prints the value, never the name ``it.''
* <evaluate expression, store the result in [[it]], and return new
environment>=
*/
{
Value v = eval(d->u.exp, env);
Value *itloc = find(strtoname("it"), env);
if (echo == ECHOING)
print("%v\n", v);
if (itloc == NULL) {
return bindalloc(strtoname("it"), v, env);
} else {
*itloc = v;
return env;
}
}
case DEFINE:
/*
* We rewrite \xdefine to \xval.
* <evaluate function definition and return new environment>=
*/
/*
* <if [[d->u.define.lambda.formals]] contains a duplicate, call
[[error]]>=
*/
if (duplicatename(d->u.define.lambda.formals) != NULL)
error(
"formal parameter %n appears twice in definition of function %n",
duplicatename(d->u.define.lambda.formals), d->u.define.name);
return evaldef(mkVal(d->u.define.name, mkLambdax(d->u.define.lambda)),
env, echo);
}
assert(0);
return NULL;
}
