int
main(int argc, char* argv[])
{
init_symbol_table();
init_builtin_types();
init_global_env();
init_singleton_objects();
init_primitive_procs();
struct vm_context *global_ctx = make_vm_context(NULL, NULL,
global_env);
INC_REF(&global_ctx->obj);
struct vm_context **pctx = &global_ctx;
struct object *value;
value = load("prelude.scm", pctx);
YIELD_OBJ(value);
init_compiler();
value = load("stage2.scm", pctx);
YIELD_OBJ(value);
struct vm_context *repl_ctx;
repl_ctx = make_vm_context(NULL, make_stack(1024),
make_environment(global_env));
INC_REF(&repl_ctx->obj);
pctx = &repl_ctx;
struct object *ret = env_lookup(global_env, "initial-repl");
assert(ret->type->code == PROCEDURE_TYPE);
struct procedure *repl = container_of(ret, struct procedure, obj);
apply_and_run(repl, NIL, pctx);
return 0;
}
int main()
{
Environment *env;
pthread_t self;
pthread_t child;
int ret;
self = pthread_self ();
env = make_environment ();
/* the parent thread uses sproc to create the new thread, passing
a pointer to card as an argument */
ret = pthread_create (&child, NULL, entry, (void *) env);
if (ret == -1) {
perror ("pthread_create failed");
exit (-1);
}
loop_and_count (self, env);
printf ("Parent done looping.\n");
ret = pthread_join (child, NULL);
if (ret == -1) {
perror ("pthread_join failed");
exit (-1);
}
check_array (env);
return 0;
}
void init(void) {
the_empty_list = alloc_object();
the_empty_list->type = THE_EMPTY_LIST;
false = alloc_object();
false->type = BOOLEAN;
false->data.boolean.value = 0;
true = alloc_object();
true->type = BOOLEAN;
true->data.boolean.value = 1;
symbol_table = the_empty_list;
quote_symbol = make_symbol("quote");
define_symbol = make_symbol("define");
set_symbol = make_symbol("set!");
ok_symbol = make_symbol("ok");
if_symbol = make_symbol("if");
begin_symbol = make_symbol("begin");
cond_symbol = make_symbol("cond");
else_symbol = make_symbol("else");
let_symbol = make_symbol("let");
lambda_symbol = make_symbol("lambda");
and_symbol = make_symbol("and");
or_symbol = make_symbol("or");
eof_object = alloc_object();
eof_object->type = EOF_OBJECT;
the_empty_environment = the_empty_list;
the_global_environment = make_environment();
}
Environment fixed_environment(double canopy_openness,
double height_max) {
std::vector<double> x = {0, height_max/2.0, height_max};
std::vector<double> y = {canopy_openness, canopy_openness, canopy_openness};
interpolator::Interpolator env;
env.init(x, y);
Parameters<FF16_Strategy> p;
Environment ret(make_environment(p));
ret.light_environment = env;
return ret;
}
typename result<convert_farm(LHS, RHS, State, BackEnd)>::type
operator()(LHS const& lhs, RHS const& rhs, State& s, BackEnd const& be) const
{
convert<tag::process_network_> callee;
// Pre-compute environment to not copy it twice
BOOST_AUTO(lhe, callee(lhs,s,be) );
BOOST_AUTO(rhe, callee(rhs,lhe,be));
return make_environment ( join_network(lhe.network(),rhe.network())
, rhe.next_pid()
);
}
int main(int argc, char **argv)
{
int i;
environment *env = make_environment();
for(i = 1; i < argc; ++i){
FILE *fp = fopen(argv[i], "r");
if(!fp) file_error(argv[i]);
blazeit(fp, env);
fclose(fp);
}
blazeit(stdin, env);
free_environment(env);
return 0;
}
/*!
* Creates and initializes a new environment struct for the global environment.
* The global environment is the root of all other environments, and has a
* couple of unique characteristics. First, it has no parent environment
* (obvious, since it's the root of all environments). Second, all built-in
* functions are bound into this environment.
*/
Environment * init_global_environment(void) {
NativeLambdaBinding *binding;
assert(global_env == NULL);
global_env = make_environment(NULL);
binding = native_lambdas;
while (binding->name != NULL) {
create_binding(global_env, binding->name,
make_native_lambda(global_env, binding->func));
binding++;
}
return global_env;
}
environment* extend_environment(object* vars, object* vals, environment* enclosing_environment) {
environment* env = make_environment(enclosing_environment);
object* var, *val;
while (!is_empty_list(vars)) {
if(is_empty_list(vals)){
fprintf(stderr, "too much arguments\n");
exit(1);
}
var = car(vars);
val = car(vals);
define_variable(var, val, env);
vars = cdr(vars);
vals = cdr(vals);
}
return env;
}
static int win_spawn(const char *cmd, const char **argv, const char **envp,
const char *cwd, HANDLE handles[3], int background,
int shell)
{
char *args = make_command_line(shell, cmd, argv);
char *env = make_environment(envp);
char *program = shell ? NULL : find_program(cmd);
STARTUPINFO si;
PROCESS_INFORMATION pi;
BOOL result;
DWORD exitcode;
int i;
if (!shell) {
G_debug(3, "win_spawn: program = %s", program);
if (!program) {
G_free(args);
G_free(env);
return -1;
}
}
G_debug(3, "win_spawn: args = %s", args);
memset(&si, 0, sizeof(si));
si.cb = sizeof(si);
si.dwFlags |= STARTF_USESTDHANDLES;
si.hStdInput = handles[0];
si.hStdOutput = handles[1];
si.hStdError = handles[2];
result = CreateProcess(
program, /* lpApplicationName */
args, /* lpCommandLine */
NULL, /* lpProcessAttributes */
NULL, /* lpThreadAttributes */
1, /* bInheritHandles */
0, /* dwCreationFlags */
env, /* lpEnvironment */
cwd, /* lpCurrentDirectory */
&si, /* lpStartupInfo */
&pi /* lpProcessInformation */
);
G_free(args);
G_free(env);
G_free(program);
if (!result) {
G_warning(_("CreateProcess() failed: error = %d"), GetLastError());
return -1;
}
CloseHandle(pi.hThread);
for (i = 0; i < 3; i++)
if (handles[i] != INVALID_HANDLE_VALUE)
CloseHandle(handles[i]);
if (!background) {
WaitForSingleObject(pi.hProcess, INFINITE);
if (!GetExitCodeProcess(pi.hProcess, &exitcode))
return -1;
CloseHandle(pi.hProcess);
return (int) exitcode;
}
CloseHandle(pi.hProcess);
return pi.dwProcessId;
}
Value * evaluate(Environment *env, Value *expr) {
EvaluationContext *ctx;
Value *temp, *result;
Value *operator;
Value *operand_val, *operand_cons;
Value *operands, *operands_end, *nil_value;
int num_operands;
/* Set up a new evaluation context and record our local variables, so that
* the garbage-collector can see any temporary values we use.
*/
ctx = push_new_evalctx(env, expr);
evalctx_register(&temp);
evalctx_register(&result);
evalctx_register(&operator);
evalctx_register(&operand_val);
evalctx_register(&operand_cons);
evalctx_register(&operands);
evalctx_register(&operands_end);
evalctx_register(&nil_value);
#ifdef VERBOSE_EVAL
printf("\nEvaluating expression: ");
print_value(stdout, expr);
printf("\n");
#endif
/* If this is a special form, evaluate it. Otherwise, this function will
* simply pass the input through to the result.
*/
result = eval_special_form(env, expr);
if (result != expr)
goto Done; /* It was a special form. */
/*
* If the input is an atom, we need to resolve it to a value, using the
* current environment.
*/
if (is_atom(expr)) {
/* Treat the atom as a name - resolve it to a value. */
result = resolve_binding(env, expr->string_val);
if (result == NULL) {
result = make_error("couldn't resolve name \"%s\" to a value!",
expr->string_val);
}
goto Done;
}
/*
* If the input isn't an atom and isn't a cons-pair, then assume it's a
* value that doesn't need evaluating, and just return it.
*/
if (!is_cons_pair(expr)) {
result = expr;
goto Done;
}
/*
* Evaluate operator into a lambda expression.
*/
temp = get_car(expr);
operator = evaluate(env, temp);
if (is_error(operator)) {
result = operator;
goto Done;
}
if (!is_lambda(operator)) {
result = make_error("operator is not a valid lambda expression");
goto Done;
}
#ifdef VERBOSE_EVAL
printf("Operator: ");
print_value(stdout, operator);
printf("\n");
#endif
/*
* Evaluate each operand into a value, and build a list up of the values.
*/
#ifdef VERBOSE_EVAL
printf("Starting evaluation of operands.\n");
#endif
num_operands = 0;
operands_end = NULL;
operands = nil_value = make_nil();
temp = get_cdr(expr);
while (is_cons_pair(temp)) {
Value *raw_operand;
num_operands++;
/* This is the raw unevaluated value. */
raw_operand = get_car(temp);
/* Evaluate the raw input into a value. */
operand_val = evaluate(env, raw_operand);
if (is_error(operand_val)) {
result = operand_val;
goto Done;
}
operand_cons = make_cons(operand_val, nil_value);
if (operands_end != NULL)
set_cdr(operands_end, operand_cons);
else
operands = operand_cons;
operands_end = operand_cons;
temp = get_cdr(temp);
}
/*
* Apply the operator to the operands, to generate a result.
*/
if (operator->lambda_val->native_impl) {
/* Native lambdas don't need an environment created for them. Rather,
* we just pass the list of arguments to the native function, and it
* processes the arguments as needed.
*/
result = operator->lambda_val->func(num_operands, operands);
}
else {
/* These don't need registered on the explicit stack. (I hope.) */
Environment *child_env;
Value *body_iter;
/* It's an interpreted lambda. Create a child environment, then
* populate it with values based on the lambda's argument-specification
* and the input operands.
*/
child_env = make_environment(operator->lambda_val->parent_env);
temp = bind_arguments(child_env, operator->lambda_val, operands);
if (is_error(temp)) {
result = temp;
goto Done;
}
/* Evaluate each expression in the lambda, using the child environment.
* The result of the last expression is the result of the lambda.
*/
body_iter = operator->lambda_val->body;
do {
result = evaluate(child_env, get_car(body_iter));
body_iter = get_cdr(body_iter);
}
while (!is_nil(body_iter));
}
Done:
#ifdef VERBOSE_EVAL
printf("Result: ");
print_value(stdout, result);
printf("\n\n");
#endif
/* Record the result and then perform garbage-collection. */
pop_evalctx(result);
collect_garbage();
return result;
}
object *environment_proc(object *arguments) {
return make_environment();
}
void
load_command(regcontext_t *REGS, int run, int fd, char *cmd_name,
u_short *param, char **argv, char **envs)
{
struct exehdr hdr;
int min_memory, max_memory;
int biggest;
int envseg;
char *psp;
int text_size = 0;
int i;
int start_segment;
int exe_file;
char *p;
int used, n;
char *fcb;
int newpsp;
u_short init_cs, init_ip, init_ss, init_sp, init_ds, init_es;
if (envs)
envseg = make_environment(cmd_name, envs);
else
envseg = env_s[curpsp];
/* read exe header */
if (read (fd, &hdr, sizeof hdr) != sizeof hdr)
fatal ("can't read header\n");
/* proper header ? */
if (hdr.magic == 0x5a4d) {
exe_file = 1;
text_size = (hdr.size - 1) * 512 + hdr.bytes_on_last_page
- hdr.hdr_size * 16;
min_memory = hdr.min_memory + (text_size + 15)/16;
max_memory = hdr.max_memory + (text_size + 15)/16;
} else {
exe_file = 0;
min_memory = 64 * (1024/16);
max_memory = 0xffff;
}
/* alloc mem block */
pspseg = mem_alloc(max_memory, 1, &biggest);
if (pspseg == 0) {
if (biggest < min_memory ||
(pspseg = mem_alloc(biggest, 1, NULL)) == 0)
fatal("not enough memory: needed %d have %d\n",
min_memory, biggest);
max_memory = biggest;
}
mem_change_owner(pspseg, pspseg);
mem_change_owner(envseg, pspseg);
/* create psp */
newpsp = curpsp + 1;
psp_s[newpsp] = pspseg;
env_s[newpsp] = envseg;
psp = (char *)MAKEPTR(pspseg, 0);
memset(psp, 0, 256);
psp[0] = 0xcd;
psp[1] = 0x20;
*(u_short *)&psp[2] = pspseg + max_memory;
/*
* this is supposed to be a long call to dos ... try to fake it
*/
psp[5] = 0xcd;
psp[6] = 0x99;
psp[7] = 0xc3;
*(u_short *)&psp[0x16] = psp_s[curpsp];
psp[0x18] = 1;
psp[0x19] = 1;
psp[0x1a] = 1;
psp[0x1b] = 0;
psp[0x1c] = 2;
memset(psp + 0x1d, 0xff, 15);
*(u_short *)&psp[0x2c] = envseg;
*(u_short *)&psp[0x32] = 20;
*(u_long *)&psp[0x34] = MAKEVEC(pspseg, 0x18);
*(u_long *)&psp[0x38] = 0xffffffff;
psp[0x50] = 0xcd;
psp[0x51] = 0x98;
psp[0x52] = 0xc3;
p = psp + 0x81;
*p = 0;
used = 0;
for (i = 0; argv[i]; i++) {
n = strlen(argv[i]);
if (used + 1 + n > 0x7d)
break;
*p++ = ' ';
memcpy(p, argv[i], n);
p += n;
used += n;
}
psp[0x80] = strlen(psp + 0x81);
psp[0x81 + psp[0x80]] = 0x0d;
psp[0x82 + psp[0x80]] = 0;
p = psp + 0x81;
parse_filename(0x00, p, psp + 0x5c, &n);
p += n;
parse_filename(0x00, p, psp + 0x6c, &n);
if (param[4]) {
fcb = (char *)MAKEPTR(param[4], param[3]);
memcpy(psp + 0x5c, fcb, 16);
}
if (param[6]) {
fcb = (char *)MAKEPTR(param[6], param[5]);
memcpy(psp + 0x6c, fcb, 16);
}
#if 0
printf("005c:");
for (n = 0; n < 16; n++)
printf(" %02x", psp[0x5c + n]);
printf("\n");
printf("006c:");
for (n = 0; n < 16; n++)
printf(" %02x", psp[0x6c + n]);
printf("\n");
#endif
disk_transfer_addr = MAKEVEC(pspseg, 0x80);
start_segment = pspseg + 0x10;
if (!exe_file) {
load_com(fd, start_segment);
init_cs = pspseg;
init_ip = 0x100;
init_ss = init_cs;
init_sp = 0xfffe;
init_ds = init_cs;
init_es = init_cs;
} else {
load_exe(fd, start_segment, start_segment, &hdr, text_size);
init_cs = hdr.init_cs + start_segment;
init_ip = hdr.init_ip;
init_ss = hdr.init_ss + start_segment;
init_sp = hdr.init_sp;
init_ds = pspseg;
init_es = init_ds;
}
debug(D_EXEC, "cs:ip = %04x:%04x, ss:sp = %04x:%04x, "
"ds = %04x, es = %04x\n",
init_cs, init_ip, init_ss, init_sp, init_ds, init_es);
if (run) {
frames[newpsp] = *REGS;
curpsp = newpsp;
R_EFLAGS = 0x20202;
R_CS = init_cs;
R_IP = init_ip;
R_SS = init_ss;
R_SP = init_sp;
R_DS = init_ds;
R_ES = init_es;
R_AX = R_BX = R_CX = R_DX = R_SI = R_DI = R_BP = 0;
} else {
param[7] = init_sp;
param[8] = init_ss;
param[9] = init_ip;
param[10] = init_cs;
}
}
