/* 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; }