int read_list(char *start, char **end, Atom *result)
{
Error err;
char *token;
Atom p = nil;
*result = nil;
*end = start; //
for(; ;)
{
err = lex(*end, &token, end);
//printf("%s\n", token);
//err = lex(start, &token, end);
if(err)
return ERROR_SYNTAX;
if(token[0] == ')')
return ERROR_OK;
Atom item;
if(token[0] == '.' && *end - token == 1)
{
if(nilp(p))
return ERROR_SYNTAX;
err = read_expr(*end, end, &item);
if(err)
return err;
cdr(p) = item;
err = lex(*end, &token, end);
/* when there is '.', must be the end*/
if(token[0] != ')')
return ERROR_SYNTAX;
return ERROR_OK;
}
err = read_expr(token, end, &item);
//err = read_expr(*end, end, &item);
if(err)
return ERROR_SYNTAX;
if(nilp(p))
{
/* first item */
*result = cons(item, nil);
p = *result;
}
else
{
cdr(p) = cons(item, nil);
p = cdr(p);
}
}
}
symbol_table *closing_to_table(closure *a)
{
symbol_table *ret = new_symbol_table();
while(!nilp(a)){
if(nilp(table_lookup(cheap_car(cheap_car(a)), ret))){
table_insert(cheap_car(cheap_car(a)),
second(cheap_car(a)),
ret);
}
a = cheap_cdr(a);
}
return ret;
}
void
test_pre()
{
/* char tmp_buf[256]; */
DBUG_ENTER("test_pre");
DBUG_PRINT("", ("sizeof(int)=%d", sizeof(int)));
DBUG_PRINT("", ("sizeof(CONS*)=%d", sizeof(CONS*)));
DBUG_PRINT("", ("sizeof(BEH)=%d", sizeof(BEH)));
assert(sizeof(int) == sizeof(CONS*));
assert(sizeof(BEH) == sizeof(CONS*));
DBUG_PRINT("", ("NIL=16#%08lx (%p)", NIL, NIL));
assert(nilp(NIL));
assert(nilp(NIL) == _nilp(NIL));
DBUG_PRINT("", ("sizeof(BOOL)=%d", sizeof(BOOL)));
assert(sizeof(BOOL) == sizeof(CONS*));
DBUG_PRINT("", ("TRUE=16#%08lx (%p)", TRUE, TRUE));
DBUG_PRINT("", ("FALSE=16#%08lx (%p)", FALSE, FALSE));
assert(TRUE);
assert(!FALSE);
assert(TRUE == ((BOOL)(0 == 0)));
assert(FALSE == ((BOOL)(0 != 0)));
#if TYPETAG_USES_3MSB
DBUG_PRINT("", ("Type tag in MSB[31:29]"));
#endif /* TYPETAG_USES_3MSB */
#if TYPETAG_USES_2LSB
DBUG_PRINT("", ("Type tag in LSB[1:0]"));
#endif /* TYPETAG_USES_2LSB */
#if TYPETAG_USES_3LSB
DBUG_PRINT("", ("Type tag in LSB[2/1:0]"));
#endif /* TYPETAG_USES_3LSB */
#if TYPETAG_USES_1LSB_2MSB
DBUG_PRINT("", ("Type tag in LSB[0]+MSB[31:30]"));
#endif /* TYPETAG_USES_1LSB_2MSB */
DBUG_PRINT("", ("_Program[]=16#%08lx (%p)", _Program, _Program));
assert(_Program == MK_PTR(MK_REF(_Program)));
/* FIXME: enable this test when stack allocation is allowed
DBUG_PRINT("", ("tmp_buf[]=%p", tmp_buf));
assert(tmp_buf == MK_PTR(MK_REF(tmp_buf)));
*/
DBUG_PRINT("", ("test_pre()=16#%08lx (%p)", test_pre, test_pre));
assert(test_pre == MK_BEH(MK_FUNC(test_pre)));
DBUG_RETURN;
}
object_t *prim_sub(object_t *arguments) {
long result = 0;
if (!nilp(arguments)) {
result = (car(arguments))->values.fixnum.value;
arguments = cdr(arguments);
while (!nilp(arguments)) {
result -= (car(arguments))->values.fixnum.value;
arguments = cdr(arguments);
}
}
return create_fixnum(result);
}
void push_instruction_list(machine * m,
oyster * ins,
table * scope, table * scope_below)
{
incref(ins);
frame *top = NULL;
frame **cur = ⊤
while (!nilp(ins)) {
(*cur) = make_frame(NULL,
scope, NULL, scope_below, car(ins), EVALUATE);
incref(*cur);
cur = &((*cur)->below);
oyster *ins2 = cdr(ins);
incref(ins2);
decref(ins);
ins = ins2;
}
decref(ins);
(*cur) = m->current_frame;
m->current_frame = top;
}
closure *reverse(closure *a){
closure *ret = nil();
while(!nilp(a)){
ret = cons(car(a), ret);
a = cdr(a);
}
return ret;
}
int prim_length(loliObj* lst){
int tmp = 0;
if(nilp(lst)){
return 0;
}else{
return 1 + prim_length(tail(lst));
}
}
object_t *make_arguments(object_t *args, object_t *env) {
if (nilp(args)) {
return get_nil();
} else {
return create_cons(eval(car(args), env),
make_arguments(cdr(args), env));
}
}
//Append[(a (b . nil))] -> (a .... (b .... . nil))
loliObj* prim_append(loliObj* lst){
if(nilp(head(lst))){
return tail(lst);
}
if(head(lst)->type != CONS){
std::cout<<"The first argument must be a CONS\n";
return nil;
}
return cons(head(head(lst)), cons(tail(head(lst)), tail(lst)));
}
object_t *prim_mul(object_t *arguments) {
long result = 1;
while (!nilp(arguments)) {
result *= (car(arguments))->values.fixnum.value;
arguments = cdr(arguments);
}
return create_fixnum(result);
}
object_t *eval(object_t *exp, object_t *env) {
object_t *ret = NULL;
if (evaluate_to_self(exp)) {
ret = exp;
}
else if (quoted(exp)) {
ret = car(cdr(exp));
}
else if (definition(exp)) {
object_t *symb = car(cdr(exp)),
*val = car(cdr(cdr(exp)));
if (val == NULL) {
create_new_variable(symb, get_nil(), env);
} else {
create_new_variable(symb,
eval(val, env),
env);
}
ret = symb;
}
else if (is_symbol(exp)) {
//printf("\nfound symbol: %s\n\n", exp->values.symbol.value);
ret = find_variable_value(exp, env);
}
else if (function(exp)) {
object_t *arguments = make_arguments(cdr(exp), env);
object_t *func = eval(car(exp), env);
if (func == NULL || func == get_nil() ||
func->type != t_primitive) {
fprintf(stderr, "func: %d\n", (unsigned int)func);
//fprintf(stderr, "type: %d\n", func->type);
die("Not a primitive!\n");
} else {
ret = (func->values.primitive.function)(arguments);
}
} else if (maybe_eval_to_function(exp)) {
object_t *c = car(exp);
object_t *func = eval(c, env);
if (!(func == NULL || nilp(func))) {
object_t *arguments = make_arguments(cdr(exp), env);
ret = (func->values.primitive.function)(arguments);
}
else {
die("Not a function!\n");
}
}
else {
die("Can't eval!\n");
}
return ret;
}
static void handle_external_mod_update
(struct kyu_module *newdef, struct kyu_module *mydef)
{
sexpr c, a, module, rv = sx_nil, flags = newdef->schedulerflags;
c = sx_set_difference (mydef->schedulerflags, newdef->schedulerflags);
if (eolp (c))
{
return;
}
while (consp (c) && nilp (rv))
{
a = car (c);
if (truep (equalp (a, sym_enabling)))
{
if (falsep (sx_set_memberp (mydef->schedulerflags, sym_enabling)))
{
rv = handle_enable_request (mydef);
if (falsep (rv))
{
flags = sx_set_add (mydef->schedulerflags, sym_blocked);
}
}
}
else if (truep (equalp (a, sym_disabling)))
{
if (falsep (sx_set_memberp (mydef->schedulerflags, sym_disabling)))
{
rv = handle_disable_request (mydef);
}
}
else if (consp (a) &&
falsep (sx_set_memberp (mydef->schedulerflags, a)))
{
rv = handle_action (mydef, cdr (a));
}
c = cdr (c);
}
module = kyu_make_module
(mydef->name, mydef->description, mydef->provides,
mydef->requires, mydef->before, mydef->after, mydef->conflicts,
flags, mydef->functions);
my_modules = lx_environment_unbind (my_modules, mydef->name);
my_modules = lx_environment_bind (my_modules, mydef->name, module);
kyu_command (cons (sym_update, cons (native_system,
cons (module, sx_end_of_list))));
}
void after_unwear(object player, string cmd) {
::after_unwear(player, cmd);
if (!player) {
return;
}
if (!nilp(cmd)) {
player->message("Yours is no longer a crowned head.");
}
}
symbol_table *table_union(symbol_table *a, symbol_table *b)
{
symbol_table *ret = new_symbol_table();
closure *item;
int i;
closure *chain;
start_table_iteration(b, item, i){
if (!leakedp(cheap_cdr(item)) ||
nilp(table_lookup(cheap_car(item), ret)))
table_insert(cheap_car(item), second(item), ret);
} end_table_iteration;
start_table_iteration(a, item, i){
if (!leakedp(cheap_cdr(item)) ||
nilp(table_lookup(cheap_car(item), ret)))
table_insert(cheap_car(item), second(item), ret);
} end_table_iteration;
return ret;
}
string trim_str(string str) {
string* parsed;
argcheck(str, 1, "string");
if (nilp(str) || str == "") {
return "";
}
parsed = parse_string("whitespace = /[\n\b\r\t ]+/ " +
"word = /[^\n\b\r\t ]+/ S: word S: S word", str);
parsed -= ({ "" });
bool evaluate_to_self(object_t *exp) {
switch (exp->type) {
case t_boolean:
case t_fixnum:
case t_character:
case t_string:
return TRUE;
default:
if (nilp(exp)) return TRUE;
}
return FALSE;
}
nomask int hat_stat_cmd(string str) {
object obj;
obj = get_teleport_destination();
if (!nilp(obj)) {
write("Teleport destination: " + obj->query_short());
if (query_wizard(this_player())) {
write("\t" + teleport_destination);
}
return 1;
}
write("Teleport destination has not yet been set.");
return 1;
}
void table_insert(closure *symbol, closure *value, symbol_table *table)
{
int hash = symbol_hash(symbol, table);
closure *chain = table->array[hash];
if (chain == NULL)
chain = nil();
closure *prev = assoc(symbol, chain);
if (!nilp(prev)){
prev->in->cons->car = value;
} else {
table->array[hash] = cheap_cons(cheap_list(2, symbol, value), chain);
}
table->entries++;
}
static void show_bindings(val env, val stream)
{
val level = zero;
put_string(lit("bindings:\n"), stream);
for (;; level = plus(level, one)) {
if (nilp(env))
break;
else if (consp(env)) {
format(stream, lit("~d: ~s\n"), level, env, nao);
break;
} else if (type(env) == ENV) {
format(stream, lit("~d: ~s\n"), level, env->e.vbindings, nao);
env = env->e.up_env;
} else {
format(stream, lit("invalid environment object: ~s\n"), env, nao);
break;
}
}
}
loliObj* eval(loliObj* obj, loliObj* env){
if(nilp(obj)){
return nil;
}else{
switch(obj->type){
case INT:
case FLT:
return obj;
case CONS:
case SYM:
case CHAR:
case STRING:
case PROC:
return obj;
default:
return nil;
}
}
}
void print_expr(Atom p)
{
Atom atom;
switch(p.type)
{
case ATOM_NIL:
printf("NIL");
break;
case ATOM_INTEGER:
printf("%d", p.value.integer);
break;
case ATOM_SYMBOL:
printf("%s", p.value.symbol);
break;
case ATOM_PAIR:
putchar('(');
print_expr(car(p));
atom = cdr(p);
while(!nilp(atom))
{
if(atom.type == ATOM_PAIR)
{
putchar(' ');
print_expr(car(atom));
atom = cdr(atom);
}
else
{
printf(" . ");
print_expr(atom);
break;
}
}
// print_expr(atom);
putchar(')');
break;
}
}
std::string toString(loliObj* obj) {
switch(obj->type) {
case INT:
case FLT:
case SYM:
return obj->value;
case CONS:
if(nilp(head(obj))) {
return "NIL";
// }else if(nilp(tail(obj))){
// return "(" + toString(head(obj)) + ")";
} else {
return "(" + toString(head(obj)) + " . " + toString(tail(obj)) + ")";
}
case CHAR:
case STRING:
return obj->value;
case PROC:
return "<PROCEDURE>";
case LAMBDA:
return "<LAMBDA>";
}
}
int empty_str(string str) {
return !str || nilp(str) || str == "";
}
bool function(object_t *exp) {
return (is_cons(exp) && !nilp(exp) &&
car(exp)->type == t_symbol);
}
bool isEnd(loliObj* tree){
if(nilp(tree->tail)){
return true;
}
return false;
}
