struct lispobj *eval_let(struct lispobj *exps, struct lispobj *env)
{
struct lispobj *binds, *body, *vars, *vals, *lambda, *ret, *evals;
binds = CAR(exps);
body = CDR(exps);
if(length(binds) > 0) {
struct lispobj *tvars, *tvals;
vars = heap_grab(NEW_CONS(NULL, NULL));
vals = heap_grab(NEW_CONS(NULL, NULL));
tvars = vars; tvals = vals;
while(binds != NULL) {
struct lispobj *bind = CAR(binds);
if(length(bind) != 2) {
ret = NEW_ERROR("Bad binding in the let exp.\n");
goto exit;
}
CAR(tvars) = heap_grab(CAR(bind));
CAR(tvals) = heap_grab(CADR(bind));
CDR(tvars) = heap_grab(NEW_CONS(NULL, NULL));
CDR(tvals) = heap_grab(NEW_CONS(NULL, NULL));
tvars = CDR(tvars);
tvals = CDR(tvals);
binds = CDR(binds);
}
tvars = NULL;
tvals = NULL;
} else {
return NEW_ERROR("Empty bindgings in the let exp.\n");
}
lambda = heap_grab(env_proc_make(vars, body, env));
evals = heap_grab(env_val_list(vals, env));
if(evals != NULL && OBJ_TYPE(evals) == ERROR) {
ret = evals;
} else {
ret = apply(lambda, evals);
heap_release(evals);
}
heap_release(lambda);
exit:
heap_release(vals);
heap_release(vars);
return ret;
}
struct lispobj *env_var_define(struct lispobj *var, struct lispobj *val, struct lispobj *env)
{
struct lispobj *frame, *pair, *cell, *lookup;
/* Checking on variable existence. */
lookup = env_var_lookup(var, env);
/* If variable exists return error. */
if(OBJ_TYPE(lookup) != ERROR) {
char error[64];
snprintf(error, 64, "Variable already exists: %s.\n", SYMBOL_VALUE(var));
return NEW_ERROR(error);
}
/* Remove not necessary object. */
heap_release(lookup);
/* Get top frame from environment. */
frame = ENV_FIRST(env);
/* Creating cell for new variable. */
cell = NEW_CONS(var, val);
/* Appending new cell into the frame. */
pair = NEW_CONS(cell, frame);
frame = heap_grab(pair);
/* Appending the frame into the environment. */
CAR(env) = frame;
return val;
}
static struct lispobj* eval_cond(struct lispobj *exps, struct lispobj *env)
{
struct lispobj *ret = OBJ_FALSE;
if(exps != NULL) {
struct lispobj *cond;
cond = CAR(exps);
if(cond != NULL && OBJ_TYPE(cond) == CONS) {
struct lispobj *pred;
pred = eval(CAR(cond), env);
if(pred != NULL && OBJ_TYPE(pred) == ERROR) {
ret = pred;
} else {
if(pred) {
if(length(cond) == 1) {
ret = OBJ_TRUE;
} else {
ret = eval(CADR(cond), env);
}
} else {
ret = eval_cond(CDR(exps), env);
}
heap_release(pred);
}
} else {
ret = NEW_ERROR("Bad cond clause.\n");
}
}
return ret;
}
struct lispobj *apply(struct lispobj *proc, struct lispobj *args)
{
if(proc != NULL && OBJ_TYPE(proc) == CONS) {
struct lispobj *ret;
if(NEW_SYMBOL("SUBR") == CAR(proc)) {
/* Apply primitive function. */
struct lispobj *body, *(*subr)(struct lispobj *);
body = CADR(proc);
subr = (struct lispobj *) NUMBER_VALUE(body);
//subr = (struct lispobj *) body;
ret = heap_grab(subr(args));
} else if(NEW_SYMBOL("PROC") == CAR(proc)) {
/* Apply user defined procedure. */
struct lispobj *body, *params, *penv;
body = CADDR(proc);
params = CADR(proc);
penv = CADDDR(proc);
if(length(params) == length(args)) {
struct lispobj *env;
if(params == NULL || params == NEW_SYMBOL("NIL")) {
env = penv;
ret = eval_progn(body, env);
} else {
env = heap_grab(NEW_CONS(env_frame_make(params, args), penv));
ret = eval_progn(body, env);
heap_release(env);
}
} else {
char error[64];
snprintf(error,
64,
"Has recieved wrong number of parameters: %d.\n",
length(args));
ret = heap_grab(NEW_ERROR(error));
}
} else {
goto error;
}
return ret;
}
error:
return heap_grab(NEW_ERROR("Unknown procedure.\n"));
}
struct lispobj *subr_equal(struct lispobj *args)
{
if(length(args) != 2)
return ERROR_ARGS;
struct lispobj *obj1, *obj2, *ret;
obj1 = CAR(args);
obj2 = CADR(args);
if(obj1 == NULL && obj2 == NULL) {
ret = OBJ_TRUE;
} else if(obj1 != NULL && obj2 != NULL && OBJ_TYPE(obj1) == OBJ_TYPE(obj2)) {
if(OBJ_TYPE(obj1) == CONS) {
struct lispobj *args_equal_cars, *args_equal_cdrs;
args_equal_cars = heap_grab(list(2, CAR(obj1), CAR(obj2)));
args_equal_cdrs = heap_grab(list(2, CDR(obj1), CDR(obj2)));
if(subr_equal(args_equal_cars) &&
subr_equal(args_equal_cdrs)) {
ret = OBJ_TRUE;
} else {
ret = OBJ_FALSE;
}
heap_release(args_equal_cars);
heap_release(args_equal_cdrs);
} else {
struct lispobj *args_eq;
args_eq = heap_grab(list(2, obj1, obj2));
ret = subr_eq(args_eq);
heap_release(args_eq);
}
} else
ret = OBJ_FALSE;
return ret;
}
struct lispobj *subr_rplacd(struct lispobj *args)
{
if(length(args) != 2)
return ERROR_ARGS;
struct lispobj *old, *val, *place;
place = CAR(args);
val = CADR(args);
old = CDR(place);
CDR(place) = heap_grab(val);
heap_release(old);
return place;
}
int main()
{
int i;
int* val;
int* data;
int* key;
struct heap_t* heap;
heap = heap_init(heap_cmp_func);
assert(heap);
data = (int*)MALLOC(sizeof(int) * LOOP);
key = (int*)MALLOC(sizeof(int) * LOOP);
for(i=0; i<LOOP; i++)
{
data[i] = rand() % (LOOP * 2);
key[i] = heap_insert(heap, &data[i]);
printf("%d ", data[i]);
//_heap_debug(heap);
}
printf("\n");
for(i = 0; i < LOOP; i++)
{
val = (int*)heap_erase(heap, key[i]);
printf("%d ", *val);
//_heap_debug(heap);
}
/*
while(heap_count(heap) > 0)
{
val = (int*)heap_pop(heap);
printf("%d ", *val);
_heap_debug(heap);
}
printf("\n");
*/
FREE(data);
FREE(key);
heap_release(heap);
getchar();
return 0;
}
struct lispobj *env_var_assign(struct lispobj *var, struct lispobj *val, struct lispobj *env)
{
struct lispobj *cell;
if(var == NULL || OBJ_TYPE(var) != SYMBOL) {
return NEW_ERROR("Variable name is not a symbol.\n");
}
/* Checking on variable existence. */
cell = env_var_lookup(var, env);
/* If variable not exists return error. */
if(OBJ_TYPE(cell) == ERROR) {
return cell;
}
/* Remove old value. */
heap_release(CDR(cell));
/* Assign new value. */
CDR(cell) = heap_grab(val);
return val;
}
struct lispobj *env_val_list(struct lispobj *vars, struct lispobj *env)
{
if(vars != NULL) {
struct lispobj *vals, *car, *cdr;
car = eval(CAR(vars), env);
if(car != NULL && OBJ_TYPE(car) == ERROR) {
return car;
}
vals = NEW_CONS(NULL, NULL);
CAR(vals) = car;
cdr = env_val_list(CDR(vars), env);
if(cdr != NULL && OBJ_TYPE(cdr) == ERROR) {
heap_release(vals);
return cdr;
}
CDR(vals) = heap_grab(cdr);
return vals;
}
return NULL;
}
extern "C" int
main(stage2_args *args)
{
TRACE(("boot(): enter\n"));
if (heap_init(args) < B_OK)
panic("Could not initialize heap!\n");
TRACE(("boot(): heap initialized...\n"));
// set debug syslog default
#if KDEBUG_ENABLE_DEBUG_SYSLOG
gKernelArgs.keep_debug_output_buffer = true;
#endif
add_stage2_driver_settings(args);
platform_init_video();
// the main platform dependent initialisation
// has already taken place at this point.
if (vfs_init(args) < B_OK)
panic("Could not initialize VFS!\n");
dprintf("Welcome to the Haiku boot loader!\n");
bool mountedAllVolumes = false;
Directory *volume = get_boot_file_system(args);
if (volume == NULL || (platform_boot_options() & BOOT_OPTION_MENU) != 0) {
if (volume == NULL)
puts("\tno boot path found, scan for all partitions...\n");
if (mount_file_systems(args) < B_OK) {
// That's unfortunate, but we still give the user the possibility
// to insert a CD-ROM or just rescan the available devices
puts("Could not locate any supported boot devices!\n");
}
// ToDo: check if there is only one bootable volume!
mountedAllVolumes = true;
if (user_menu(&volume) < B_OK) {
// user requested to quit the loader
goto out;
}
}
if (volume != NULL) {
// we got a volume to boot from!
status_t status;
while ((status = load_kernel(args, volume)) < B_OK) {
// loading the kernel failed, so let the user choose another
// volume to boot from until it works
volume = NULL;
if (!mountedAllVolumes) {
// mount all other file systems, if not already happened
if (mount_file_systems(args) < B_OK)
panic("Could not locate any supported boot devices!\n");
mountedAllVolumes = true;
}
if (user_menu(&volume) < B_OK || volume == NULL) {
// user requested to quit the loader
goto out;
}
}
// if everything is okay, continue booting; the kernel
// is already loaded at this point and we definitely
// know our boot volume, too
if (status == B_OK) {
register_boot_file_system(volume);
if ((platform_boot_options() & BOOT_OPTION_DEBUG_OUTPUT) == 0)
platform_switch_to_logo();
load_modules(args, volume);
load_driver_settings(args, volume);
// apply boot settings
apply_boot_settings();
// set up kernel args version info
gKernelArgs.kernel_args_size = sizeof(kernel_args);
gKernelArgs.version = CURRENT_KERNEL_ARGS_VERSION;
// clone the boot_volume KMessage into kernel accessible memory
// note, that we need to 4 byte align the buffer and thus allocate
// 3 more bytes
void* buffer = kernel_args_malloc(gBootVolume.ContentSize() + 3);
if (!buffer) {
panic("Could not allocate memory for the boot volume kernel "
"arguments");
}
buffer = (void*)(((addr_t)buffer + 3) & ~(addr_t)0x3);
memcpy(buffer, gBootVolume.Buffer(), gBootVolume.ContentSize());
gKernelArgs.boot_volume = buffer;
gKernelArgs.boot_volume_size = gBootVolume.ContentSize();
// ToDo: cleanup, heap_release() etc.
platform_start_kernel();
}
}
out:
heap_release(args);
return 0;
}
struct lispobj *eval(struct lispobj *obj, struct lispobj *env)
{
struct lispobj *ret;
if(obj == NULL || OBJ_TYPE(obj) == NUMBER ||
OBJ_TYPE(obj) == ERROR || OBJ_TYPE(obj) == STRING) {
/* Return self-evaluating object. */
ret = heap_grab(obj);
} else if(OBJ_TYPE(obj) == SYMBOL) {
/* Lookup value of the variable in the env. */
struct lispobj *val;
val = env_var_lookup(obj, env);
if(OBJ_TYPE(val) == ERROR) {
ret = heap_grab(val);
} else {
ret = heap_grab(CDR(val));
}
} else if(NEW_SYMBOL("QUOTE") == CAR(obj)) {
/* (quote whatever) */
if(length(obj) != 2) {
ret = heap_grab(ERROR_ARGS);
} else {
/* Return quoted object. */
ret = heap_grab(CADR(obj));
}
#ifdef __DEBUG_GC__
printf("eval quote debug:");
heap_debug_object(ret);
printf("\n");
#endif
} else if(NEW_SYMBOL("SETQ") == CAR(obj)) {
/* (setq var val) */
if(length(obj) != 3) {
ret = heap_grab(ERROR_ARGS);
} else {
/* Try to assign existing variable. */
struct lispobj *val;
val = eval(CADDR(obj), env);
if(val != NULL && OBJ_TYPE(val) == ERROR) {
ret = val;
} else {
ret = heap_grab(env_var_assign(CADR(obj), val, env));
heap_release(val);
}
}
} else if(NEW_SYMBOL("LABEL") == CAR(obj)) {
/* (label var val) */
if(length(obj) != 3) {
ret = heap_grab(ERROR_ARGS);
} else {
/* Try to define new variable. */
struct lispobj *val;
val = eval(CADDR(obj), env);
if(val != NULL && OBJ_TYPE(val) == ERROR) {
ret = val;
} else {
ret = heap_grab(env_var_define(CADR(obj), val, env));
heap_release(val);
}
}
} else if(NEW_SYMBOL("IF") == CAR(obj)) {
/* (if predicate consequence alternative) */
if(length(obj) != 4) {
ret = heap_grab(ERROR_ARGS);
} else {
/* Invoke condition function. */
struct lispobj *pred;
pred = eval(CADR(obj), env);
if(pred != NULL && OBJ_TYPE(pred) == ERROR) {
ret = pred;
} else {
if(pred) {
/* Eval consequence. */
ret = eval(CADDR(obj), env);
} else {
/* Eval alternative. */
ret = eval(CADDDR(obj), env);
}
heap_release(pred);
}
}
} else if(NEW_SYMBOL("COND") == CAR(obj)) {
/* (cond (cond1 ret1) (cond2 ret2)) */
if(length(obj) < 2) {
ret = heap_grab(ERROR_ARGS);
} else {
ret = eval_cond(CDR(obj), env);
}
}
else if(NEW_SYMBOL("LET") == CAR(obj)) {
if(length(obj) < 3) {
ret = heap_grab(ERROR_ARGS);
} else {
ret = eval_let(CDR(obj), env);
}
} else if(NEW_SYMBOL("PROGN") == CAR(obj)) {
ret = eval_progn(CDR(obj), env);
} else if(NEW_SYMBOL("LAMBDA") == CAR(obj)) {
/* (lambda (var) (proc var var)) */
if(length(obj) < 3) {
ret = heap_grab(ERROR_ARGS);
} else {
/* Make and return new procedure. */
ret = heap_grab(env_proc_make(CADR(obj), CDDR(obj), env));
}
} else {
/* Apply case. */
struct lispobj *proc = eval(CAR(obj), env);
if(proc != NULL && OBJ_TYPE(proc) == ERROR) {
ret = proc;
} else {
struct lispobj *args = heap_grab(env_val_list(CDR(obj), env));
if(args != NULL && OBJ_TYPE(args) == ERROR) {
ret = args;
} else {
ret = apply(proc, args);
heap_release(args);
}
heap_release(proc);
}
}
return ret;
}
