/* Print an error message */
char
err_msg(char *msg, char f, long s)
{
printf("\nERROR. \n%s", msg);
if (f != 0)
l_print(s);
printf("\n");
return -1;
}
static inline int l_factorial(int f_max, int l_max)
{
long double factorial = 1.0;
long double old_value = factorial;
int i;
for (i = 1; i < 300; i++)
{
old_value = factorial;
factorial *= i;
if (!isfinite(factorial))
break;
if (i <= 12 ||
(i == f_max + 1 || i == f_max) ||
(i == l_max + 1 || i == l_max))
l_print(i, factorial);
}
l_print(i - 1, old_value);
return i - 1;
}
/*
Test the print function. Just print the expected output
and actual output to the screen. The array vals
contains the items expected in the list, in order of appearance
in the list.
*/
void print_test(linked_list list, int* vals, int n) {
printf("Expecting:");
int i;
for (i = 0; i < n; i++) {
printf(" %d", vals[i]);
}
printf("\n");
printf("Got : ");
l_print(list);
printf("\n\n");
}
/*
** Do the REPL: repeatedly read (load) a line, evaluate (call) it, and
** print any results.
*/
static void doREPL (lua_State *L) {
int status;
const char *oldprogname = progname;
progname = NULL; /* no 'progname' on errors in interactive mode */
while ((status = loadline(L)) != -1) {
if (status == LUA_OK)
status = docall(L, 0, LUA_MULTRET);
if (status == LUA_OK) l_print(L);
else report(L, status);
}
lua_settop(L, 0); /* clear stack */
lua_writeline();
progname = oldprogname;
}
/* Top level */
void
toplevel(void)
{
long s, v;
for (;;){
t_stack_ptr = 0;
printf("\n] "); /* prompt */
if ((s = l_read()) < 0) /* read */
continue;
if (s == TAG_EOF) /* end of file */
break;
if (gc_protect(s) < 0)
break;
if ((v = l_eval(s)) < 0) /* eval */
continue;
gc_unprotect(s);
printf("\n");
(void) l_print(v); /* print */
}
}
/* Call a built-in function */
long
fcall(long f, long av[2]) /*, int n*/
{
long v, t;
long r, d;
switch (D_GET_DATA(f)){
case KW_RPLACA:
case KW_RPLACD:
case KW_CAR:
case KW_CDR:
if (D_GET_TAG(av[0]) != TAG_CONS)
return err_msg(errmsg_ill_type, 1, f);
break;
case KW_GT:
#ifndef MINIMALISTIC
case KW_LT:
case KW_GTE:
case KW_LTE:
case KW_REM:
#endif
if ((D_GET_TAG(av[0]) != TAG_INT) || (D_GET_TAG(av[1]) != TAG_INT))
return err_msg(errmsg_ill_type, 1, f);
break;
#ifndef MINIMALISTIC
case KW_ZEROP:
case KW_RAND:
case KW_INCR:
case KW_DECR:
if (D_GET_TAG(av[0]) != TAG_INT)
return err_msg(errmsg_ill_type, 1, f);
break;
#endif
}
switch (D_GET_DATA(f)){
#ifndef MINIMALISTIC
case KW_LAMBDA:
return err_msg(errmsg_ill_call, 1, f);
break;
#endif
case KW_QUIT:
quit();
break;
case KW_EQ:
#ifndef MINIMALISTIC
case KW_EQMATH:
#endif
v = (av[0] == av[1]) ? TAG_T : TAG_NIL;
break;
#ifndef MINIMALISTIC
case KW_EQUAL:
return l_equal(av[0], av[1]);
#endif
case KW_CONS:
v = l_cons(av[0], av[1]);
break;
case KW_RPLACA:
v = t_cons_car[D_GET_DATA(av[0])] = av[1];
break;
case KW_RPLACD:
v = t_cons_cdr[D_GET_DATA(av[0])] = av[1];
break;
case KW_CAR:
v = l_car(av[0]);
break;
case KW_CDR:
v = l_cdr(av[0]);
break;
case KW_NULL:
v = (D_GET_TAG(av[0]) == TAG_NIL) ? TAG_T : TAG_NIL;
break;
case KW_CONSP:
return (D_GET_TAG(av[0]) == TAG_CONS) ? TAG_T : TAG_NIL;
case KW_SYMBP:
return (D_GET_TAG(av[0]) == TAG_SYMB) ? TAG_T : TAG_NIL;
case KW_NUMBERP:
v = (D_GET_TAG(av[0]) == TAG_INT) ? TAG_T : TAG_NIL;
break;
case KW_LIST:
v = av[0];
break;
case KW_NOT:
v = (D_GET_TAG(av[0]) == TAG_NIL) ? TAG_T : TAG_NIL;
break;
case KW_READ:
v = l_read();
break;
case KW_EVAL:
v = l_eval(av[0]);
break;
case KW_PRINC:
v = l_print(av[0]);
break;
case KW_TERPRI:
printf("\n");
v = TAG_NIL;
break;
case KW_GC:
gcollect();
v = TAG_T;
break;
case KW_ADD:
for (r = 0, t = av[0]; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if (D_GET_TAG(l_car(t)) != TAG_INT)
return err_msg(errmsg_ill_type, 1, f);
r = r + int_get_c(l_car(t));
}
v = int_make_l(r);
break;
case KW_TIMES:
for (r = 1, t = av[0]; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if (D_GET_TAG(l_car(t)) != TAG_INT)
return err_msg(errmsg_ill_type, 1, f);
r = r * int_get_c(l_car(t));
}
v = int_make_l(r);
break;
case KW_SUB:
if (D_GET_TAG(av[0]) == TAG_NIL){
r = 0;
} else if (D_GET_TAG(l_car(av[0])) != TAG_INT){
return err_msg(errmsg_ill_type, 1, f);
} else if (D_GET_TAG(l_cdr(av[0])) == TAG_NIL){
r = 0 - int_get_c(l_car(av[0]));
} else {
r = int_get_c(l_car(av[0]));
for (t = l_cdr(av[0]); D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if (D_GET_TAG(l_car(t)) != TAG_INT)
return err_msg(errmsg_ill_type, 1, f);
r = r - int_get_c(l_car(t));
}
}
v = int_make_l(r);
break;
case KW_QUOTIENT:
if (D_GET_TAG(av[0]) == TAG_NIL){
r = 1;
} else if (D_GET_TAG(l_car(av[0])) != TAG_INT){
return err_msg(errmsg_ill_type, 1, f);
} else if ((d = int_get_c(l_car(av[0]))) == 0){
return err_msg(errmsg_zero_div, 1, f);
} if (D_GET_TAG(l_cdr(av[0])) == TAG_NIL){
r = 1 / d;
} else {
for (r = d, t = l_cdr(av[0]); D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if (D_GET_TAG(l_car(t)) != TAG_INT)
return err_msg(errmsg_ill_type, 1, f);
if ((d = int_get_c(l_car(t))) == 0)
return err_msg(errmsg_zero_div, 1, f);
r = r / d;
}
}
v = int_make_l(r);
break;
case KW_GT:
v = (int_get_c(av[0]) > int_get_c(av[1])) ? TAG_T : TAG_NIL;
break;
#ifndef MINIMALISTIC
case KW_DIVIDE:
r = int_get_c(av[0]);
if ((d = int_get_c(av[1])) == 0)
return err_msg(errmsg_zero_div, 1, f);
v = l_cons(int_make_l(r / d), int_make_l(r % d));
break;
case KW_LT:
v = (int_get_c(av[0]) < int_get_c(av[1])) ? TAG_T : TAG_NIL;
break;
case KW_ATOM:
v = (D_GET_TAG(av[0]) != TAG_CONS) ? TAG_T : TAG_NIL;
break;
case KW_GTE:
v = (int_get_c(av[0]) >= int_get_c(av[1])) ? TAG_T : TAG_NIL;
break;
case KW_LTE:
v = (int_get_c(av[0]) <= int_get_c(av[1])) ? TAG_T : TAG_NIL;
break;
case KW_ZEROP:
v = (int_get_c(av[0]) == 0) ? TAG_T : TAG_NIL;
break;
case KW_RAND:
v = int_make_l(rand() % int_get_c(av[0]));
break;
case KW_INCR:
v = int_make_l(int_get_c(av[0])+1);
break;
case KW_DECR:
v = int_make_l(int_get_c(av[0])-1);
break;
case KW_REM:
r = int_get_c(av[0]);
if ((d = int_get_c(av[1])) == 0)
return err_msg(errmsg_zero_div, 1, f);
v = int_make_l(r % d);
break;
#endif
}
return v;
}
/* Print an S-expression */
long
l_print(long s)
{
long v, t;
int i;
switch(D_GET_TAG(s)){
#ifdef SCHEME
case TAG_NIL:
printf("#f");
break;
case TAG_T:
printf("#t");
break;
#else
case TAG_NIL:
printf("nil");
break;
case TAG_T:
printf("t");
break;
#endif
case TAG_INT:
v = int_get_c(s);
printf("%ld", v);
break;
case TAG_SYMB:
i = s & D_MASK_DATA;
printf("%s", t_symb_pname[i]);
break;
case TAG_EOF:
printf("<eof>");
break;
case TAG_UNDEF: /* for debugging */
printf("<undefined>");
break;
case TAG_CONS:
printf("(");
t = s;
l_print(l_car(t));
while (D_GET_TAG(l_cdr(t)) == TAG_CONS) {
printf(" ");
t = l_cdr(t);
l_print(l_car(t));
}
if (D_GET_TAG(l_cdr(t)) != TAG_NIL){
printf(" . ");
l_print(l_cdr(t));
}
printf(")");
break;
}
return TAG_T;
}