5704 Lines
/* * Scheme 9 from Empty Space, Reimagined * By Nils M Holm, 2007-2018 * In the public domain * If your country does not have a public domain, the CC0 applies: * https://creativecommons.org/share-your-work/public-domain/cc0/ */ #define RELEASE_DATE "2018-12-05" #define PATCHLEVEL 0 #include "s9core.h" #include "s9import.h" #include "s9ext.h" #ifdef unix #include <signal.h> #include <setjmp.h> #define handle_sigquit() signal(SIGQUIT, keyboard_quit) #define handle_sigint() signal(SIGINT, keyboard_interrupt) #endif #ifdef plan9 #define handle_sigquit() #define handle_sigint() notify(keyboard_interrupt) #endif #define IMAGE_FILE "s9.image" #ifndef IMAGE_DIR #define IMAGE_DIR "." #endif #ifndef LIBRARY_PATH #ifdef unix #define LIBRARY_PATH \ "." \ ":lib" \ ":ext/unix" \ ":ext/csv" \ ":ext/curses" \ ":contrib" \ ":~/.s9fes" \ ":/usr/local/share/s9fes" #endif #ifdef plan9 #define LIBRARY_PATH \ "." \ ":lib" \ ":ext/csv" \ ":ext/plan9" \ ":contrib" \ ":~/lib/s9fes" #endif #endif /* * Configurable options */ #define TOKEN_LENGTH 1024 #define MAX_PORTS 32 #define MAX_IO_DEPTH 65536 #define MAX_REF_TRACE 5 #define MAX_EXPAND 10000 #define CHUNK_SIZE 1024 /* * Globals */ cell Tmp = NIL; cell Env = NIL, Envp = NIL; cell Glob = NIL, Hash = NIL; cell Macros = NIL; cell Trace[MAX_REF_TRACE]; int Tp = 0; cell Emitbuf; cell Prog = NIL; int Here = 0; cell Cts = NIL, Rts = NIL; volatile int Running = 1; volatile int Intr = 0; int Stats = 0; cell Acc = NIL; cell E0 = NIL, Ep = NIL; int Ip = 0, Sp = -1, Fp = -1; int Sz = CHUNK_SIZE; jmp_buf Restart; jmp_buf Error_tag; cell Error_handler; cell Argv = NIL; char Srcfile[TOKEN_LENGTH+1] = { 0 }; int Line_no = 1; int Level = 0; int Opening_line = 0; int Displaying = 0; volatile int Expand_level = 0; char S9magic[17]; int O_quiet = 0; int Report_to_stderr = 0; cell *Image_vars[] = { &Glob, &Hash, &Macros, NULL }; cell *GC_roots[] = { &Prog, &Env, &Cts, &Emitbuf, &Glob, &Hash, &Macros, &Rts, &Acc, &Ep, &E0, &Argv, &Tmp, NULL }; /* * Pre-defined symbols */ /* Internals */ cell I_arg, I_closure, I_ref, I_a, I_e; /* Special Ops */ cell S_apply, S_arguments, S_begin, S_define, S_define_syntax, S_epsilon, S_error_tag, S_error_value, S_extensions, S_host_system, S_if, S_ifstar, S_image_file, S_lambda, S_letrec, S_library_path, S_loading, S_quasiquote, S_quote, S_release_date, S_set_b, S_starstar, S_unquote, S_unquote_splicing; /* Procedures */ cell P_abs, P_append, P_assq, P_assv, P_bit_op, P_boolean_p, P_caaaar, P_caaadr, P_caaar, P_caadar, P_caaddr, P_caadr, P_caar, P_cadaar, P_cadadr, P_cadar, P_caddar, P_cadddr, P_caddr, P_cadr, P_call_cc, P_call_with_current_continuation, P_car, P_catch, P_catch_tag_p, P_cdaaar, P_cdaadr, P_cdaar, P_cdadar, P_cdaddr, P_cdadr, P_cdar, P_cddaar, P_cddadr, P_cddar, P_cdddar, P_cddddr, P_cdddr, P_cddr, P_cdr, P_ceiling, P_char_alphabetic_p, P_char_ci_equal_p, P_char_ci_grtr_p, P_char_ci_gteq_p, P_char_ci_less_p, P_char_ci_lteq_p, P_char_downcase, P_char_equal_p, P_char_grtr_p, P_char_gteq_p, P_char_less_p, P_char_lower_case_p, P_char_lteq_p, P_char_numeric_p, P_char_p, P_char_to_integer, P_char_upcase, P_char_upper_case_p, P_char_whitespace_p, P_close_input_port, P_close_output_port, P_command_line, P_cons, P_current_error_port, P_current_input_port, P_current_output_port, P_delete_file, P_display, P_divide, P_dump_image, P_environment_variable, P_eof_object_p, P_eq_p, P_equal, P_eqv_p, P_error, P_eval, P_even_p, P_exact_p, P_exact_to_inexact, P_exponent, P_expt, P_file_exists_p, P_floor, P_gensym, P_grtr, P_gteq, P_inexact_p, P_inexact_to_exact, P_input_port_p, P_integer_p, P_integer_p, P_integer_to_char, P_length, P_less, P_list, P_list_ref, P_list_tail, P_list_to_string, P_list_to_string, P_list_to_vector, P_list_to_vector, P_load, P_lteq, P_macro_expand, P_macro_expand_1, P_make_string, P_make_vector, P_mantissa, P_max, P_memq, P_memv, P_min, P_minus, P_negative_p, P_not, P_null_p, P_odd_p, P_number_p, P_open_append_file, P_open_input_file, P_open_output_file, P_output_port_p, P_pair_p, P_peek_char, P_plus, P_positive_p, P_procedure_p, P_quit, P_quotient, P_read, P_read_char, P_real_p, P_remainder, P_reverse, P_reverse_b, P_s9_bytecode, P_set_car_b, P_set_cdr_b, P_set_input_port_b, P_set_output_port_b, P_stats, P_string_append, P_string_ci_equal, P_string_ci_grtr, P_string_ci_gteq, P_string_ci_less, P_string_ci_lteq, P_string_copy, P_string_equal, P_string_fill_b, P_string_grtr, P_string_gteq, P_string_length, P_string_less, P_string_lteq, P_string_p, P_string_ref, P_string_set_b, P_string_to_list, P_string_to_symbol, P_substring, P_symbol_p, P_symbol_p, P_symbol_to_string, P_symbols, P_system_command, P_throw, P_times, P_truncate, P_vector, P_vector_append, P_vector_copy, P_vector_fill_b, P_vector_length, P_vector_p, P_vector_ref, P_vector_set_b, P_vector_to_list, P_write, P_write_char, P_zero_p; /* * Abstract machine opcodes */ enum { OP_APPLIS, OP_APPLY, OP_ARG, OP_COPY_ARG, OP_CLOSURE, OP_COPY_REF, OP_DEF_MACRO, OP_ENTER, OP_ENTER_COLL, OP_HALT, OP_JMP, OP_JMP_FALSE, OP_JMP_TRUE, OP_MAKE_ENV, OP_PROP_ENV, OP_POP, OP_PUSH, OP_PUSH_VAL, OP_QUOTE, OP_REF, OP_RETURN, OP_SET_ARG, OP_SET_REF, OP_TAIL_APPLIS, OP_TAIL_APPLY, OP_ABS, OP_APPEND, OP_ASSQ, OP_ASSV, OP_BIT_OP, OP_BOOLEAN_P, OP_CAAAAR, OP_CAAADR, OP_CAAAR, OP_CAADAR, OP_CAADDR, OP_CAADR, OP_CAAR, OP_CADAAR, OP_CADADR, OP_CADAR, OP_CADDAR, OP_CADDDR, OP_CADDR, OP_CADR, OP_CALL_CC, OP_CAR, OP_CATCH, OP_CATCH_TAG_P, OP_CDAAAR, OP_CDAADR, OP_CDAAR, OP_CDADAR, OP_CDADDR, OP_CDADR, OP_CDAR, OP_CDDAAR, OP_CDDADR, OP_CDDAR, OP_CDDDAR, OP_CDDDDR, OP_CDDDR, OP_CDDR, OP_CDR, OP_CEILING, OP_CHAR_ALPHABETIC_P, OP_CHAR_CI_EQUAL_P, OP_CHAR_CI_GRTR_P, OP_CHAR_CI_GTEQ_P, OP_CHAR_CI_LESS_P, OP_CHAR_CI_LTEQ_P, OP_CHAR_DOWNCASE, OP_CHAR_EQUAL_P, OP_CHAR_GRTR_P, OP_CHAR_GTEQ_P, OP_CHAR_LESS_P, OP_CHAR_LOWER_CASE_P, OP_CHAR_LTEQ_P, OP_CHAR_NUMERIC_P, OP_CHAR_P, OP_CHAR_TO_INTEGER, OP_CHAR_UPCASE, OP_CHAR_UPPER_CASE_P, OP_CHAR_WHITESPACE_P, OP_CLOSE_INPUT_PORT, OP_CLOSE_OUTPUT_PORT, OP_COMMAND_LINE, OP_CONS, OP_CURRENT_ERROR_PORT, OP_CURRENT_INPUT_PORT, OP_CURRENT_OUTPUT_PORT, OP_DELETE_FILE, OP_DISPLAY, OP_DIVIDE, OP_DUMP_IMAGE, OP_ENVIRONMENT_VARIABLE, OP_EOF_OBJECT_P, OP_EQUAL, OP_EQV_P, OP_EQ_P, OP_ERROR, OP_ERROR2, OP_EVAL, OP_EVEN_P, OP_EXACT_P, OP_EXACT_TO_INEXACT, OP_EXPONENT, OP_EXPT, OP_FILE_EXISTS_P, OP_FIX_EXACTNESS, OP_FLOOR, OP_GENSYM, OP_GRTR, OP_GTEQ, OP_INEXACT_P, OP_INEXACT_TO_EXACT, OP_INPUT_PORT_P, OP_INTEGER_P, OP_INTEGER_TO_CHAR, OP_LENGTH, OP_LESS, OP_LIST, OP_LIST_REF, OP_LIST_TAIL, OP_LIST_TO_STRING, OP_LIST_TO_VECTOR, OP_LOAD, OP_LTEQ, OP_MACRO_EXPAND, OP_MACRO_EXPAND_1, OP_MAKE_STRING, OP_MAKE_VECTOR, OP_MANTISSA, OP_MAX, OP_MEMQ, OP_MEMV, OP_MIN, OP_MINUS, OP_NEGATE, OP_NEGATIVE_P, OP_NOT, OP_NULL_P, OP_ODD_P, OP_OPEN_APPEND_FILE, OP_OPEN_INPUT_FILE, OP_OPEN_OUTPUT_FILE, OP_OUTPUT_PORT_P, OP_PAIR_P, OP_PEEK_CHAR, OP_PLUS, OP_POSITIVE_P, OP_PROCEDURE_P, OP_QUIT, OP_QUOTIENT, OP_READ, OP_READ_CHAR, OP_REAL_P, OP_REMAINDER, OP_REVERSE, OP_REVERSE_B, OP_S9_BYTECODE, OP_SET_CAR_B, OP_SET_CDR_B, OP_SET_INPUT_PORT_B, OP_SET_OUTPUT_PORT_B, OP_STATS, OP_STRING_APPEND, OP_STRING_COPY, OP_STRING_EQUAL_P, OP_STRING_FILL_B, OP_STRING_GRTR_P, OP_STRING_GTEQ_P, OP_STRING_LENGTH, OP_STRING_LESS_P, OP_STRING_LTEQ_P, OP_STRING_P, OP_STRING_REF, OP_STRING_SET_B, OP_STRING_CI_EQUAL_P, OP_STRING_CI_GRTR_P, OP_STRING_CI_GTEQ_P, OP_STRING_CI_LESS_P, OP_STRING_CI_LTEQ_P, OP_STRING_TO_LIST, OP_STRING_TO_SYMBOL, OP_SUBSTRING, OP_SYMBOLS, OP_SYMBOL_P, OP_SYMBOL_TO_STRING, OP_SYSTEM_COMMAND, OP_THROW, OP_TIMES, OP_TRUNCATE, OP_VECTOR, OP_VECTOR_APPEND, OP_VECTOR_COPY, OP_VECTOR_FILL_B, OP_VECTOR_LENGTH, OP_VECTOR_P, OP_VECTOR_REF, OP_VECTOR_SET_B, OP_VECTOR_TO_LIST, OP_WRITE, OP_WRITE_CHAR, OP_ZERO_P }; /* * Types */ #define RPAREN (USER_SPECIALS-1) #define RBRACK (USER_SPECIALS-2) #define DOT (USER_SPECIALS-3) #define T_CATCH_TAG (USER_SPECIALS-100) /* * Extension setup, add your own ones here */ void sys_init(void); void curs_init(void); void csv_init(void); #ifndef EXTENSIONS #define EXTENSIONS #endif /* * Error reporting and handling */ void prints(char *s); void print_form(cell x); char *ntoa(char *b, cell x, int w); cell getbind(cell x); void rerror(char *s, cell x) { int i, j, o; char buf[100]; Error_handler = getbind(S_error_tag); if (Error_handler != NIL) longjmp(Error_tag, 1); s9_abort(); o = set_output_port(Report_to_stderr? 2: 1); prints("*** error: "); prints(s); if (x != UNDEFINED) { prints(": "); set_printer_limit(100); print_form(x); set_printer_limit(0); } nl(); if (Srcfile[0] != 0) { prints("*** file \""); prints(Srcfile); prints("\", line "); prints(ntoa(buf, Line_no, 0)); nl(); } prints("*** trace:"); i = Tp; for (j=0; j<MAX_REF_TRACE; j++) { if (i >= MAX_REF_TRACE) i = 0; if (Trace[i] != NIL) { prints(" "); print_form(Trace[i]); } i++; } nl(); set_output_port(o); } void error(char *s, cell x) { rerror(s, x); longjmp(Restart, 1); } void expect(char *who, char *what, cell got) { char b[100]; sprintf(b, "%s: expected %s, got", who, what); error(b, got); } /* * Type implementations */ cell closure(cell i, cell e) { cell c; c = cons(Prog, NIL); c = cons(e, c); c = cons(i, c); return new_atom(T_FUNCTION, c); } #define closure_ip(c) cadr(c) #define closure_env(c) caddr(c) #define closure_prog(c) cadddr(c) cell catch(void) { cell n; n = cons(Prog, NIL); Tmp = n; n = cons(Ep, n); Tmp = n; n = cons(mkfix(Fp), n); Tmp = n; n = cons(mkfix(Sp), n); Tmp = n; n = cons(mkfix(Ip+2), n); Tmp = NIL; return new_atom(T_CATCH_TAG, n); } #define catch_tag_p(n) \ (!s9_special_p(n) && (tag(n) & S9_ATOM_TAG) && T_CATCH_TAG == car(n)) int throw(cell ct, cell v) { ct = cdr(ct); Ip = fixval(car(ct)); ct = cdr(ct); Sp = fixval(car(ct)); ct = cdr(ct); Fp = fixval(car(ct)); ct = cdr(ct); Ep = car(ct); ct = cdr(ct); Prog = car(ct); Acc = v; return Ip; } cell subvector(cell v, int k0, int k1); cell capture_cont(void) { cell n, *v; int i; n = cons(subvector(Rts, 0, Sz), NIL); v = vector(car(n)); for (i = Sp+1; i < Sz; i++) v[i] = UNDEFINED; Tmp = n; n = cons(mkfix(Sz), n); Tmp = n; n = cons(Prog, n); Tmp = n; n = cons(Ep, n); Tmp = n; n = cons(mkfix(Fp), n); Tmp = n; n = cons(mkfix(Sp), n); Tmp = n; n = cons(mkfix(Ip+2), n); Tmp = NIL; return new_atom(T_CONTINUATION, n); } int call_cont(cell c, cell v) { int nsp; c = cdr(c); Ip = fixval(car(c)); c = cdr(c); nsp = fixval(car(c)); c = cdr(c); Fp = fixval(car(c)); c = cdr(c); Ep = car(c); c = cdr(c); Prog = car(c); c = cdr(c); Sz = fixval(car(c)); c = cdr(c); Rts = subvector(car(c), 0, Sz); Sp = nsp; Acc = v; return Ip; } #define list_p(x) (pair_p(x) || NIL == (x)) unsigned hash(char *s) { unsigned int h = 0; while (*s) h = ((h<<5)+h) ^ *s++; return h; } int hash_size(int n) { if (n < 47) return 47; if (n < 97) return 97; if (n < 199) return 199; if (n < 499) return 499; if (n < 997) return 997; if (n < 9973) return 9973; if (n < 19997) return 19997; return 39989; } void rehash(void) { unsigned int i; cell *v, n, p, new; unsigned int h, k; if (NIL == Hash) k = hash_size(length(Env)); else k = hash_size(fixval(vector(Hash)[0])); Hash = new_vec(T_VECTOR, (k+1) * sizeof(cell)); v = vector(Hash); for (i=1; i<=k; i++) v[i] = NIL; i = 0; for (p = Env; p != NIL; p = cdr(p)) { h = hash(symbol_name(car(p))); n = cons(car(p), mkfix(i)); n = cons(n, vector(Hash)[h%k+1]); vector(Hash)[h%k+1] = n; i++; } new = mkfix(i); vector(Hash)[0] = new; } void addhash(cell x) { cell n, new; unsigned int h, i, k; if (NIL == Hash) { rehash(); return; } i = fixval(vector(Hash)[0]); k = vector_len(Hash)-1; if (i > k) { rehash(); return; } h = hash(symbol_name(x)); n = cons(x, mkfix(i)); n = cons(n, vector(Hash)[h%k+1]); vector(Hash)[h%k+1] = n; new = mkfix(i+1); vector(Hash)[0] = new; } int lookup(cell x) { unsigned int h, k; cell n; k = vector_len(Hash)-1; h = hash(symbol_name(x)); for (n = vector(Hash)[h%k+1]; n != NIL; n = cdr(n)) if (x == caar(n)) return fixval(cdar(n)); return FALSE; } /* * Low-level utility functions */ int strcmp_ci(char *s1, char *s2) { int c1, c2; while (1) { c1 = tolower((int) *s1++); c2 = tolower((int) *s2++); if ('\0' == c1 || '\0' == c2 || c1 != c2) break; } return c1 < c2? -1: c1 > c2? 1: 0; } char *ntoa(char *b, cell x, int w) { char buf[40]; int i = 0, neg = 0; char *p = &buf[sizeof(buf)-1]; if (x < 0) { x = -x; neg = 1; } *p = 0; while (x || 0 == i) { i++; if (i >= sizeof(buf)-1) fatal("ntoa: number too big"); p--; *p = x % 10 + '0'; x = x / 10; } while (i < (w-neg) && i < sizeof(buf)-1) { i++; p--; *p = '0'; } if (neg) { if (i >= sizeof(buf)-1) fatal("ntoa: number too big"); p--; *p = '-'; } strcpy(b, p); return b; } cell reverse(cell n) { cell m; m = NIL; while (n != NIL) { if (atom_p(n)) error("reverse: improper list", n); m = cons(car(n), m); n = cdr(n); } return m; } cell nreverse(cell n) { cell h, m; m = NIL; while (n != NIL) { if (atom_p(n)) error("reverse!: improper list", n); h = cdr(n); cdr(n) = m; m = n; n = h; } return m; } cell conc(cell a, cell b) { cell n; a = reverse(a); save(a); n = b; while (a != NIL) { n = cons(car(a), n); a = cdr(a); } unsave(1); return n; } cell nconc(cell a, cell b) { cell n; n = a; if (NIL == a) return b; while (cdr(a) != NIL) a = cdr(a); cdr(a) = b; return n; } int memq(cell x, cell a) { if (!symbol_p(x)) return FALSE; for (; a != NIL; a = cdr(a)) if (car(a) == x) return a; return FALSE; } int assq(cell x, cell a) { if (!symbol_p(x)) return FALSE; for (; a != NIL; a = cdr(a)) if (caar(a) == x) return car(a); return FALSE; } int posq(cell x, cell a) { int n; if (!symbol_p(x)) return FALSE; n = 0; for (; a != NIL; a = cdr(a)) { if (car(a) == x) return n; n++; } return FALSE; } int hashq(cell x, cell e) { if (!symbol_p(x)) return FALSE; if (e == Env) return lookup(x); return posq(x, e); } cell set_union(cell a, cell b) { cell n; a = reverse(a); save(a); save(n = b); while (pair_p(a)) { if (memq(car(a), b) == FALSE) { n = cons(car(a), n); car(Stack) = n; } a = cdr(a); } if (a != NIL && memq(a, b) == FALSE) n = cons(a, n); unsave(2); return n; } cell flatargs(cell a) { cell n; save(n = NIL); while (pair_p(a)) { n = cons(car(a), n); car(Stack) = n; a = cdr(a); } if (a != NIL) n = cons(a, n); unsave(1); return nreverse(n); } cell dotted_p(cell x) { while (pair_p(x)) x = cdr(x); return x != NIL; } cell carof(cell a) { cell n; save(n = NIL); while (a != NIL) { n = cons(caar(a), n); car(Stack) = n; a = cdr(a); } unsave(1); return nreverse(n); } cell zip(cell a, cell b) { cell n, p; save(n = NIL); while (a != NIL && b != NIL) { p = cons(car(a), car(b)); n = cons(p, n); car(Stack) = n; a = cdr(a); b = cdr(b); } unsave(1); return nreverse(n); } cell lastpair(cell x) { if (NIL == x) return NIL; while (cdr(x) != NIL) x = cdr(x); return x; } cell exists_p(char *s) { FILE *f; f = fopen(s, "r"); if (f != NULL) fclose(f); return NULL == f? FALSE: TRUE; } cell subvector(cell x, int k0, int k1) { cell n, *vx, *vn; int i, j; n = make_vector(k1-k0); vx = vector(x); vn = vector(n); j = 0; for (i=k0; i<k1; i++) { vn[j] = vx[i]; j++; } return n; } cell list_to_vector(cell m, char *msg, int flags) { cell n, vec; int k; cell *p; k = 0; for (n = m; n != NIL; n = cdr(n)) { if (atom_p(n)) error(msg, m); k++; } if (0 == k) return make_vector(0); vec = new_vec(T_VECTOR, k*sizeof(cell)); Tag[vec] |= flags; p = vector(vec); for (n = m; n != NIL; n = cdr(n)) { *p = car(n); p++; } return vec; } cell list_to_string(cell x) { cell n; int k = length(x); char *s; n = make_string("", k); s = string(n); while (x != NIL) { if (atom_p(x)) error("list->string: improper list", x); if (!char_p(car(x))) { error("list->string: expected list of char," " got list containing", car(x)); } *s++ = char_value(car(x)); x = cdr(x); } *s = 0; return n; } cell string_to_list(cell x) { char *s; cell n, a, new; int k, i; k = string_len(x); n = NIL; a = NIL; for (i=0; i<k-1; i++) { s = string(x); if (NIL == n) { n = a = cons(make_char(s[i]), NIL); save(n); } else { new = cons(make_char(s[i]), NIL); cdr(a) = new; a = cdr(a); } } if (n != NIL) unsave(1); return n; } cell vector_to_list(cell x) { cell n, a, new; int k, i; k = vector_len(x); n = NIL; a = NIL; for (i=0; i<k; i++) { if (NIL == n) { n = a = cons(vector(x)[i], NIL); save(n); } else { new = cons(vector(x)[i], NIL); cdr(a) = new; a = cdr(a); } } if (n != NIL) unsave(1); return n; } /* * Interpreter-side access to bindings. * Using deep binding here. At program run time * shallow binding will be used exclusively. */ void envbind(cell v, cell a) { cell n; n = cons(a, NIL); n = cons(v, n); Glob = cons(n, Glob); } void setbind(cell v, cell a) { cell b; b = assq(v, Glob); if (b != FALSE) cadr(b) = a; } cell getbind(cell v) { cell b; b = assq(v, Glob); if (NIL == b) error("internal variable undefined", v); return cadr(b); } /* * System initialization */ void clear_trace(void) { int i; for (i=0; i<MAX_REF_TRACE; i++) Trace[i] = NIL; } cell make_library_path(void) { char path[TOKEN_LENGTH+1], *s; int i, j; cell n, new; save(n = NIL); s = getenv("S9FES_LIBRARY_PATH"); if (NULL == s) s = LIBRARY_PATH; i = j = 0; for (;;) { if ('\0' == s[i] || ':' == s[i]) { path[j] = 0; new = make_string(path, j); j = 0; n = cons(new, n); car(Stack) = n; if ('\0' == s[i]) break; i++; } if (j >= TOKEN_LENGTH) fatal("library path element too long"); path[j++] = s[i]; i++; } return nreverse(unsave(1)); } void add_primitives(char *name, S9_PRIM *p) { cell x, v, n, b; int i; if (name) { n = symbol_ref(name); x = getbind(S_extensions); x = nconc(x, cons(n, NIL)); setbind(S_extensions, x); } save(b = NIL); for (i=0; p && p[i].name; i++) { v = symbol_ref(p[i].name); n = cons(make_primitive(&p[i]), NIL); n = cons(v, n); b = cons(n, b); car(Stack) = b; } b = nreverse(b); unsave(1); Glob = nconc(Glob, b); } cell eval(cell x, int r); void init_extensions(void) { cell n, p; #define LEN 100 char b[LEN+2], *s; for (n = getbind(S_extensions); n != NIL; n = cdr(n)) { if (symbol_len(car(n)) > LEN/2) error("extension init name too long", car(n)); s = symbol_name(car(n)); sprintf(b, "%s:%s", s, s); p = symbol_ref(b); p = assq(p, Glob); if (FALSE == p) continue; p = cons(cadr(p), NIL); eval(p, 1); } p = symbol_ref("s9:s9"); p = assq(p, Glob); if (FALSE == p) return; p = cons(cadr(p), NIL); eval(p, 1); } void init_rts(void) { Rts = NIL; Rts = make_vector(CHUNK_SIZE); Sz = CHUNK_SIZE; Sp = -1; Fp = -1; } void init(void) { s9_init(GC_roots, &Rts, &Sp); init_rts(); image_vars(Image_vars); exponent_chars("eEdDfFlLsS"); memset(S9magic, 0, sizeof(S9magic)); if (strlen(RELEASE_DATE) == 10) sprintf(S9magic, "S9:%s:%c", RELEASE_DATE, PATCHLEVEL+'0'); else strcpy(S9magic, "S9:BAD-VERSION"); clear_trace(); I_a = symbol_ref("a"); I_e = symbol_ref("e"); I_arg = symbol_ref("%arg"); I_closure = symbol_ref("%closure"); I_ref = symbol_ref("%ref"); S_apply = symbol_ref("apply"); S_arguments = symbol_ref("*arguments*"); S_begin = symbol_ref("begin"); S_define = symbol_ref("define"); S_define_syntax = symbol_ref("define-syntax"); S_epsilon = symbol_ref("*epsilon*"); S_error_tag = symbol_ref("*error-tag*"); S_error_value = symbol_ref("*error-value*"); S_extensions = symbol_ref("*extensions*"); S_host_system = symbol_ref("*host-system*"); S_if = symbol_ref("if"); S_ifstar = symbol_ref("if*"); S_image_file = symbol_ref("*image-file*"); S_lambda = symbol_ref("lambda"); S_letrec = symbol_ref("letrec"); S_library_path = symbol_ref("*library-path*"); S_loading = symbol_ref("*loading*"); S_quasiquote = symbol_ref("quasiquote"); S_quote = symbol_ref("quote"); S_release_date = symbol_ref("*release-date*"); S_set_b = symbol_ref("set!"); S_starstar = symbol_ref("**"); S_unquote = symbol_ref("unquote"); S_unquote_splicing = symbol_ref("unquote-splicing"); P_abs = symbol_ref("abs"); P_append = symbol_ref("append"); P_assq = symbol_ref("assq"); P_assv = symbol_ref("assv"); P_bit_op = symbol_ref("bit-op"); P_boolean_p = symbol_ref("boolean?"); P_caaaar = symbol_ref("caaaar"); P_caaadr = symbol_ref("caaadr"); P_caaar = symbol_ref("caaar"); P_caadar = symbol_ref("caadar"); P_caaddr = symbol_ref("caaddr"); P_caadr = symbol_ref("caadr"); P_caar = symbol_ref("caar"); P_cadaar = symbol_ref("cadaar"); P_cadadr = symbol_ref("cadadr"); P_cadar = symbol_ref("cadar"); P_caddar = symbol_ref("caddar"); P_cadddr = symbol_ref("cadddr"); P_caddr = symbol_ref("caddr"); P_cadr = symbol_ref("cadr"); P_call_cc = symbol_ref("call/cc"); P_call_with_current_continuation = symbol_ref("call-with-current-continuation"); P_car = symbol_ref("car"); P_catch = symbol_ref("catch"); P_catch_tag_p = symbol_ref("catch-tag?"); P_cdaaar = symbol_ref("cdaaar"); P_cdaadr = symbol_ref("cdaadr"); P_cdaar = symbol_ref("cdaar"); P_cdadar = symbol_ref("cdadar"); P_cdaddr = symbol_ref("cdaddr"); P_cdadr = symbol_ref("cdadr"); P_cdar = symbol_ref("cdar"); P_cddaar = symbol_ref("cddaar"); P_cddadr = symbol_ref("cddadr"); P_cddar = symbol_ref("cddar"); P_cdddar = symbol_ref("cdddar"); P_cddddr = symbol_ref("cddddr"); P_cdddr = symbol_ref("cdddr"); P_cddr = symbol_ref("cddr"); P_cdr = symbol_ref("cdr"); P_ceiling = symbol_ref("ceiling"); P_char_alphabetic_p = symbol_ref("char-alphabetic?"); P_char_ci_equal_p = symbol_ref("char-ci=?"); P_char_ci_grtr_p = symbol_ref("char-ci>?"); P_char_ci_gteq_p = symbol_ref("char-ci>=?"); P_char_ci_less_p = symbol_ref("char-ci<?"); P_char_ci_lteq_p = symbol_ref("char-ci<=?"); P_char_alphabetic_p = symbol_ref("char-alphabetic?"); P_char_downcase = symbol_ref("char-downcase"); P_char_equal_p = symbol_ref("char=?"); P_char_grtr_p = symbol_ref("char>?"); P_char_gteq_p = symbol_ref("char>=?"); P_char_less_p = symbol_ref("char<?"); P_char_lower_case_p = symbol_ref("char-lower-case?"); P_char_lteq_p = symbol_ref("char<=?"); P_char_numeric_p = symbol_ref("char-numeric?"); P_char_p = symbol_ref("char?"); P_char_to_integer = symbol_ref("char->integer"); P_char_upcase = symbol_ref("char-upcase"); P_char_upper_case_p = symbol_ref("char-upper-case?"); P_char_whitespace_p = symbol_ref("char-whitespace?"); P_close_input_port = symbol_ref("close-input-port"); P_close_output_port = symbol_ref("close-output-port"); P_command_line = symbol_ref("command-line"); P_cons = symbol_ref("cons"); P_current_error_port = symbol_ref("current-error-port"); P_current_input_port = symbol_ref("current-input-port"); P_current_output_port = symbol_ref("current-output-port"); P_delete_file = symbol_ref("delete-file"); P_display = symbol_ref("display"); P_divide = symbol_ref("/"); P_dump_image = symbol_ref("dump-image"); P_environment_variable = symbol_ref("environment-variable"); P_eof_object_p = symbol_ref("eof-object?"); P_eq_p = symbol_ref("eq?"); P_equal = symbol_ref("="); P_eqv_p = symbol_ref("eqv?"); P_error = symbol_ref("error"); P_eval = symbol_ref("eval"); P_even_p = symbol_ref("even?"); P_exact_p = symbol_ref("exact?"); P_exact_to_inexact = symbol_ref("exact->inexact"); P_exponent = symbol_ref("exponent"); P_expt = symbol_ref("expt"); P_file_exists_p = symbol_ref("file-exists?"); P_floor = symbol_ref("floor"); P_gensym = symbol_ref("gensym"); P_grtr = symbol_ref(">"); P_gteq = symbol_ref(">="); P_inexact_p = symbol_ref("inexact?"); P_inexact_to_exact = symbol_ref("inexact->exact"); P_input_port_p = symbol_ref("input-port?"); P_integer_p = symbol_ref("integer?"); P_integer_p = symbol_ref("integer?"); P_integer_to_char = symbol_ref("integer->char"); P_length = symbol_ref("length"); P_less = symbol_ref("<"); P_list = symbol_ref("list"); P_list_ref = symbol_ref("list-ref"); P_list_tail = symbol_ref("list-tail"); P_list_to_string = symbol_ref("list->string"); P_list_to_string = symbol_ref("list->string"); P_list_to_vector = symbol_ref("list->vector"); P_list_to_vector = symbol_ref("list->vector"); P_load = symbol_ref("load"); P_lteq = symbol_ref("<="); P_macro_expand = symbol_ref("macro-expand"); P_macro_expand_1 = symbol_ref("macro-expand-1"); P_make_string = symbol_ref("make-string"); P_make_vector = symbol_ref("make-vector"); P_mantissa = symbol_ref("mantissa"); P_max = symbol_ref("max"); P_memq = symbol_ref("memq"); P_memv = symbol_ref("memv"); P_min = symbol_ref("min"); P_minus = symbol_ref("-"); P_negative_p = symbol_ref("negative?"); P_not = symbol_ref("not"); P_null_p = symbol_ref("null?"); P_number_p = symbol_ref("number?"); P_odd_p = symbol_ref("odd?"); P_open_append_file = symbol_ref("open-append-file"); P_open_input_file = symbol_ref("open-input-file"); P_open_output_file = symbol_ref("open-output-file"); P_output_port_p = symbol_ref("output-port?"); P_pair_p = symbol_ref("pair?"); P_peek_char = symbol_ref("peek-char"); P_plus = symbol_ref("+"); P_positive_p = symbol_ref("positive?"); P_procedure_p = symbol_ref("procedure?"); P_quit = symbol_ref("quit"); P_quotient = symbol_ref("quotient"); P_read = symbol_ref("read"); P_read_char = symbol_ref("read-char"); P_real_p = symbol_ref("real?"); P_remainder = symbol_ref("remainder"); P_reverse = symbol_ref("reverse"); P_reverse_b = symbol_ref("reverse!"); P_s9_bytecode = symbol_ref("s9:bytecode"); P_set_car_b = symbol_ref("set-car!"); P_set_cdr_b = symbol_ref("set-cdr!"); P_set_input_port_b = symbol_ref("set-input-port!"); P_set_output_port_b = symbol_ref("set-output-port!"); P_stats = symbol_ref("stats"); P_string_copy = symbol_ref("string-copy"); P_string_append = symbol_ref("string-append"); P_string_ci_equal = symbol_ref("string-ci=?"); P_string_ci_grtr = symbol_ref("string-ci>?"); P_string_ci_gteq = symbol_ref("string-ci>=?"); P_string_ci_less = symbol_ref("string-ci<?"); P_string_ci_lteq = symbol_ref("string-ci<=?"); P_string_equal = symbol_ref("string=?"); P_string_fill_b = symbol_ref("string-fill!"); P_string_grtr = symbol_ref("string>?"); P_string_gteq = symbol_ref("string>=?"); P_string_length = symbol_ref("string-length"); P_string_less = symbol_ref("string<?"); P_string_lteq = symbol_ref("string<=?"); P_string_p = symbol_ref("string?"); P_string_ref = symbol_ref("string-ref"); P_string_set_b = symbol_ref("string-set!"); P_string_to_list = symbol_ref("string->list"); P_string_to_symbol = symbol_ref("string->symbol"); P_substring = symbol_ref("substring"); P_symbol_p = symbol_ref("symbol?"); P_symbol_to_string = symbol_ref("symbol->string"); P_symbols = symbol_ref("symbols"); P_system_command = symbol_ref("system-command"); P_throw = symbol_ref("throw"); P_times = symbol_ref("*"); P_truncate = symbol_ref("truncate"); P_vector = symbol_ref("vector"); P_vector_append = symbol_ref("vector-append"); P_vector_copy = symbol_ref("vector-copy"); P_vector_fill_b = symbol_ref("vector-fill!"); P_vector_length = symbol_ref("vector-length"); P_vector_p = symbol_ref("vector?"); P_vector_ref = symbol_ref("vector-ref"); P_vector_set_b = symbol_ref("vector-set!"); P_vector_to_list = symbol_ref("vector->list"); P_write = symbol_ref("write"); P_write_char = symbol_ref("write-char"); P_zero_p = symbol_ref("zero?"); envbind(S_arguments, NIL); envbind(S_epsilon, Epsilon); envbind(S_error_tag, NIL); envbind(S_error_value, NIL); envbind(S_extensions, NIL); envbind(S_image_file, FALSE); envbind(S_library_path, make_library_path()); envbind(S_loading, FALSE); envbind(S_release_date, make_string(RELEASE_DATE, strlen(RELEASE_DATE))); envbind(S_starstar, NIL); #ifdef unix envbind(S_host_system, symbol_ref("unix")); #else #ifdef plan9 envbind(S_host_system, symbol_ref("plan9")); #else envbind(S_host_system, symbol_ref("unknown")); #endif #endif EXTENSIONS } void loadfile(char *s); void load_initial_image(char *image) { char *path, pbuf[TOKEN_LENGTH+1]; char *s, *imgdir; if (setjmp(Restart) != 0) fatal("could not load S9 image or library"); Report_to_stderr = 1; imgdir = getenv("S9FES_IMAGE_DIR"); if (NULL == imgdir) imgdir = IMAGE_DIR; if ('.' == *image || '/' == *image) { path = image; } else { if (strlen(image) + strlen(imgdir) > TOKEN_LENGTH) error("image path too long", UNDEFINED); sprintf(pbuf, "%s/%s", imgdir, image); path = pbuf; } if (strcmp(image, "-") == 0) { loadfile("s9.scm"); } else if (exists_p(path) != FALSE) { s = load_image(path, S9magic); if (s != NULL) { error(s, make_string(path, strlen(path))); fatal("aborting"); } setbind(S_image_file, make_string(path, strlen(path))); } else if (exists_p(IMAGE_FILE) != FALSE) { s = load_image(IMAGE_FILE, S9magic); if (s != NULL) { error(s, make_string(path, strlen(path))); fatal("aborting"); } setbind(S_image_file, make_string(IMAGE_FILE, strlen(IMAGE_FILE))); } else { error("cannot open image file", make_string(path, strlen(path))); } Report_to_stderr = 0; } /* * Reader */ cell read_form(int flags); cell read_list(int flags, int delim) { cell n, m, a; int c; cell new; char badpair[] = "malformed pair"; char msg[80]; if (!Level) Opening_line = Line_no; if (++Level > MAX_IO_DEPTH) { error("reader: too many nested lists or vectors", UNDEFINED); return NIL; } m = cons3(NIL, NIL, flags); save(m); a = NIL; c = 0; while (1) { if (Intr) { unsave(1); return NIL; } n = read_form(flags); if (END_OF_FILE == n) { sprintf(msg, "missing ')', started in line %d", Opening_line); error(msg, UNDEFINED); } if (DOT == n) { if (c < 1) { error(badpair, UNDEFINED); continue; } n = read_form(flags); cdr(a) = n; if (n == delim || read_form(flags) != delim) { error(badpair, UNDEFINED); continue; } unsave(1); Level--; return m; } if (RPAREN == n || RBRACK == n) { if (n != delim) error(RPAREN == n? "list starting with `[' ended with `)'": "list starting with `(' ended with `]'", UNDEFINED); break; } if (NIL == a) a = m; else a = cdr(a); car(a) = n; new = cons3(NIL, NIL, flags); cdr(a) = new; c++; } Level--; if (a != NIL) cdr(a) = NIL; unsave(1); return c? m: NIL; } cell quote(cell n, cell quotation) { cell q; q = cons(n, NIL); return cons(quotation, q); } cell read_character(void) { char buf[10], msg[50]; int i, c = 0; /*LINT*/ for (i=0; i<sizeof(buf)-1; i++) { if (Intr) return NIL; c = readc(); if (i > 0 && !isalpha(c)) break; buf[i] = c; } rejectc(c); buf[i] = 0; if (0 == i) c = ' '; else if (1 == i) c = buf[0]; else if (!strcmp_ci(buf, "space")) c = ' '; else if (!strcmp_ci(buf, "newline")) c = '\n'; else { sprintf(msg, "unknown character: #\\%s", buf); error(msg, UNDEFINED); c = 0; } return make_char(c); } cell read_string(void) { char s[TOKEN_LENGTH+1]; cell n; int c, i, q; int inv; i = 0; q = 0; c = readc(); inv = 0; while (q || c != '"') { if (Intr) return NIL; if ('\n' == c) Line_no++; if (EOF == c) error("missing '\"' in string literal", UNDEFINED); if (i >= TOKEN_LENGTH-2) { error("string literal too long", UNDEFINED); i--; } if (q && c != '"' && c != '\\' && c != 'n') { s[i++] = '\\'; inv = 1; } s[i] = q && 'n' == c? '\n': c; q = !q && '\\' == c; if (!q) i++; c = readc(); } s[i] = 0; n = make_string(s, i); Tag[n] |= S9_CONST_TAG; if (inv) error("invalid escape sequence in string", n); return n; } #define separator(c) \ (' ' == (c) || '\t' == (c) || '\n' == (c) || \ '\r' == (c) || '(' == (c) || ')' == (c) || \ ';' == (c) || '\'' == (c) || '`' == (c) || \ ',' == (c) || '"' == (c) || '[' == (c) || \ ']' == (c) || EOF == (c)) #define SYM_CHARS "!@$%^&*-/_+=~.?<>:" #define is_symbolic(c) \ (isalpha(c) || \ isdigit(c) || \ strchr(SYM_CHARS, (c))) void funny_char(char *msg, int c) { char buf[128]; if (isprint(c)) error(msg, make_char(c)); sprintf(buf, "%s, code", msg); error(buf, make_integer(c)); } #define readc_ci() tolower(readc()) cell read_symbol_or_number(int c) { char s[TOKEN_LENGTH]; int i, funny = 0; i = 0; while (!separator(c)) { if (!is_symbolic(c)) funny = c; if (i >= TOKEN_LENGTH-2) { error("symbol too long", UNDEFINED); i--; } s[i] = c; i++; c = readc_ci(); } s[i] = 0; rejectc(c); if (funny) funny_char("funny character in symbol", funny); if (string_numeric_p(s)) return string_to_number(s); if (!strcmp(s, "define-macro")) return S_define_syntax; return symbol_ref(s); } cell read_vector(void) { cell n; n = read_list(0, RPAREN); save(n); n = list_to_vector(n, "invalid vector syntax", S9_CONST_TAG); unsave(1); return n; } cell meta_command(void) { int c, cmd, i; cell n, cmdsym; char s[128]; cmd = readc_ci(); c = readc(); while (' ' == c) c = readc(); i = 0; while (c != '\n' && c != EOF) { if (i < sizeof(s) - 2) s[i++] = c; c = readc(); } rejectc(c); s[i] = 0; n = make_string(s, strlen(s)); n = 0 == i? NIL: cons(n, NIL); save(n); switch (cmd) { case 'a': cmdsym = symbol_ref("apropos"); break; case 'h': cmdsym = symbol_ref("help"); break; case 'l': cmdsym = symbol_ref("load-from-library"); break; case 'q': cmdsym = symbol_ref("quit"); break; default: prints(",a = apropos"); nl(); prints(",h = help"); nl(); prints(",l = load-from-library"); nl(); prints(",q = quit"); nl(); return UNSPECIFIC; } unsave(1); return cons(cmdsym, n); } int block_comment(void) { int n, c, state = 0; for (n=1; n; ) { c = readc_ci(); switch (c) { case EOF: error("missing |#", UNDEFINED); return 0; case '|': switch (state) { case 1: n++; state = 0; break; default: state = -1; break; } break; case '#': switch (state) { case -1: n--; state = 0; break; default: state = 1; break; } break; case '\n': Line_no++; state = 0; break; default: state = 0; break; } } return readc_ci(); } int closing_paren(void) { int c = readc_ci(); rejectc(c); return ')' == c || ']' == c; } cell bignum_read(char *pre, int radix) { char digits[] = "0123456789abcdef"; char buf[100]; cell base, num; int c, s, p, nd; base = make_integer(radix); save(base); num = Zero; save(num); c = readc_ci(); s = 0; if ('-' == c) { s = 1; c = readc_ci(); } else if ('+' == c) { c = readc_ci(); } nd = 0; while (!separator(c)) { p = 0; while (digits[p] && digits[p] != c) p++; if (p >= radix) { sprintf(buf, "invalid digit in %s number", pre); unsave(2); funny_char(buf, c); } num = bignum_multiply(num, base); car(Stack) = num; num = bignum_add(num, make_integer(p)); car(Stack) = num; nd++; c = readc_ci(); } unsave(2); if (!nd) { sprintf(buf, "digits expected after %s", pre); error(buf, UNDEFINED); } rejectc(c); return s? bignum_negate(num): num; } cell read_real_number(int inexact) { cell n, m; int flags; char buf[50]; n = read_form(0); if (integer_p(n)) { if (!inexact) return n; flags = bignum_negative_p(n)? REAL_NEGATIVE: 0; m = bignum_abs(n); return Make_real(flags, 0, cdr(m)); } else if (real_p(n)) { if (inexact) return n; m = real_to_bignum(n); if (UNDEFINED == m) error("#e: no exact representation for", n); return m; } sprintf(buf, "number expected after #%c, got", inexact? 'i': 'e'); error(buf, n); return UNDEFINED; } cell unreadable(void) { int c, i; char buf[TOKEN_LENGTH]; int d; strcpy(buf, "#<"); i = 2; while (1) { c = readc_ci(); if ('>' == c || '\n' == c) { if ('\n' == c) Line_no++; break; } if (i < TOKEN_LENGTH-2) buf[i++] = c; } buf[i++] = '>'; buf[i] = 0; d = Displaying; Displaying = 1; error("unreadable object", make_string(buf, i)); Displaying = d; return UNDEFINED; } cell read_form(int flags) { char buf[50]; int c, c2; c = readc_ci(); while (1) { while (' ' == c || '\t' == c || '\n' == c || '\r' == c) { if (c == '\n') Line_no++; if (Intr) return NIL; c = readc_ci(); } if ('#' == c) { c = readc_ci(); if ('!' == c) { /* skip rest of line */ } else if ('|' == c) { c = block_comment(); continue; } else { rejectc(c); c = '#'; break; } } else if (c != ';') { break; } while (0 == Intr && c != '\n' && c != EOF) c = readc_ci(); if (Intr) return NIL; } if (EOF == c) { return END_OF_FILE; } if (Intr) { return NIL; } if ('(' == c) { return read_list(flags, RPAREN); } else if ('[' == c) { return read_list(flags, RBRACK); } else if ('\'' == c || '`' == c) { cell n; if (closing_paren()) error("missing form after \"'\" or \"`\"", UNDEFINED); Level++; n = quote(read_form(S9_CONST_TAG), '`' == c? S_quasiquote: S_quote); Level--; return n; } else if (',' == c) { if (closing_paren()) error("missing form after \",\"", UNDEFINED); c = readc_ci(); if ('@' == c) { return quote(read_form(0), S_unquote_splicing); } else { rejectc(c); if (!Level) return meta_command(); return quote(read_form(0), S_unquote); } } else if ('#' == c) { c = readc_ci(); switch (c) { case 'f': return FALSE; case 't': return TRUE; case '\\': return read_character(); case '(': return read_vector(); case 'b': return bignum_read("#b", 2); case 'd': return bignum_read("#d", 10); case 'o': return bignum_read("#o", 8); case 'x': return bignum_read("#x", 16); case 'e': return read_real_number(0); case 'i': return read_real_number(1); case '<': return unreadable(); default: sprintf(buf, "unknown # syntax: #%c", c); error(buf, UNDEFINED); return UNDEFINED; } } else if ('"' == c) { return read_string(); } else if (')' == c) { if (!Level) error("unexpected ')'", UNDEFINED); return RPAREN; } else if (']' == c) { if (!Level) error("unexpected ']'", UNDEFINED); return RBRACK; } else if ('.' == c) { c2 = readc_ci(); rejectc(c2); if (separator(c2)) { if (!Level) error("unexpected '.'", UNDEFINED); return DOT; } return read_symbol_or_number(c); } else if (is_symbolic(c)) { return read_symbol_or_number(c); } else { funny_char("funny input character", c); return UNDEFINED; } } cell xread(void) { Level = 0; return read_form(0); } cell xsread(char *s) { cell n; open_input_string(s); n = read_form(0); close_input_string(); return n; } /* * Printer */ int print_integer(cell n) { if (!integer_p(n)) return 0; print_bignum(n); return 1; } int print_realnum(cell n) { if (!real_p(n)) return 0; print_real(n); return 1; } void print_form(cell x); int print_quoted(cell n) { if ( car(n) == S_quote && cdr(n) != NIL && cddr(n) == NIL ) { prints("'"); print_form(cadr(n)); return 1; } return 0; } int print_procedure(cell n) { if (function_p(n)) { prints("#<procedure>"); return 1; } return 0; } int print_catch_tag(cell n) { if (catch_tag_p(n)) { prints("#<catch tag>"); return 1; } return 0; } int print_continuation(cell n) { if (continuation_p(n)) { prints("#<continuation>"); return 1; } return 0; } int print_char(cell n) { char b[2]; int c; if (!char_p(n)) return 0; if (!Displaying) prints("#\\"); c = cadr(n); b[1] = 0; if (!Displaying && ' ' == c) prints("space"); else if (!Displaying && '\n' == c) prints("newline"); else { b[0] = c; prints(b); } return 1; } int print_string(cell n) { char b[2]; int k; char *s; if (!string_p(n)) return 0; if (!Displaying) prints("\""); s = string(n); k = string_len(n)-1; b[1] = 0; while (k) { b[0] = *s++; if (Displaying) { prints(b); } else if ('"' == b[0] || '\\' == b[0]) { prints("\\"); prints(b); } else if ('\n' == b[0]) { prints("\\n"); } else { prints(b); } k--; } if (!Displaying) prints("\""); return 1; } int print_symbol(cell n) { char *s; if (!symbol_p(n)) return 0; s = symbol_name(n); prints(s); return 1; } int print_primitive(cell n) { S9_PRIM *p; if (!primitive_p(n)) return 0; prints("#<primitive "); p = &Primitives[cadr(n)]; prints(p->name); prints(">"); return 1; } int print_vector(cell n) { cell *p; int k; if (!vector_p(n)) return 0; prints("#("); p = vector(n); k = vector_len(n); while (k--) { print_form(*p++); if (k) prints(" "); } prints(")"); return 1; } int print_port(cell n) { char buf[100]; if (!input_port_p(n) && !output_port_p(n)) return 0; sprintf(buf, "#<%s-port %d>", input_port_p(n)? "input": "output", (int) port_no(n)); prints(buf); return 1; } int print_fixnum(cell n) { char buf[100]; if (!fix_p(n)) return 0; sprintf(buf, "#<fix %d>", (int) fixval(n)); prints(buf); return 1; } void print_special(cell n) { char buf[100]; sprintf(buf, "#<unknown special value %d>", (int) n); prints(buf); } void x_print_form(cell n, int depth) { if (depth > MAX_IO_DEPTH) { error("printer: too many nested lists or vectors", UNDEFINED); return; } if (Intr) { Intr = 0; error("interrupted", UNDEFINED); } if (NIL == n) { prints("()"); } else if (eof_p(n)) { prints("#<eof>"); } else if (FALSE == n) { prints("#f"); } else if (TRUE == n) { prints("#t"); } else if (undefined_p(n)) { prints("#<undefined>"); } else if (unspecific_p(n)) { prints("#<unspecific>"); } else if (special_p(n)) { print_special(n); } else { if (print_char(n)) return; if (print_procedure(n)) return; if (print_catch_tag(n)) return; if (print_continuation(n)) return; if (print_realnum(n)) return; if (print_integer(n)) return; if (print_primitive(n)) return; if (print_quoted(n)) return; if (print_string(n)) return; if (print_symbol(n)) return; if (print_vector(n)) return; if (print_port(n)) return; if (print_fixnum(n)) return; prints("("); while (n != NIL) { if (printer_limit()) return; x_print_form(car(n), depth+1); n = cdr(n); if (n != NIL && atom_p(n)) { prints(" . "); x_print_form(n, depth+1); n = NIL; } if (n != NIL) prints(" "); } prints(")"); } } void print_form(cell n) { x_print_form(n, 0); } /* * Syntax checker */ void ckargs(cell x, char *who, int min, int max) { int k; char buf[100]; k = length(x)-1; if (k < min || (k > max && max >= 0)) { sprintf(buf, "%s: wrong number of arguments", who); error(buf, x); } } int syncheck(cell x, int top); int ckseq(cell x, int top) { for (; pair_p(x); x = cdr(x)) syncheck(car(x), top); return 0; } int ckapply(cell x) { ckargs(x, "apply", 2, -1); return 0; } int ckbegin(cell x, int top) { return ckseq(cdr(x), top); } int ckdefine(cell x, int top) { ckargs(x, "define", 2, 2); if (!symbol_p(cadr(x))) error("define: expected symbol", cadr(x)); if (0 == top) error("define: must be at top level", x); return ckseq(cddr(x), 0); } int ckif(cell x) { ckargs(x, "if", 2, 3); return ckseq(cdr(x), 0); } int ckifstar(cell x) { ckargs(x, "if*", 2, 2); return ckseq(cdr(x), 0); } int symlistp(cell x) { cell p; for (p = x; pair_p(p); p = cdr(p)) { if (!symbol_p(car(p))) return 0; } return symbol_p(p) || NIL == p; } int uniqlist(cell x) { if (NIL == x) return 1; while (cdr(x) != NIL) { if (memq(car(x), cdr(x)) != FALSE) return 0; x = cdr(x); } return 1; } int cklambda(cell x) { ckargs(x, "lambda", 2, -1); if ( !symbol_p(cadr(x)) && cadr(x) != NIL && !symlistp(cadr(x))) { error("lambda: invalid formals", cadr(x)); } if (!uniqlist(flatargs(cadr(x)))) error("lambda: duplicate formal", cadr(x)); return ckseq(cddr(x), 0); } int ckmacro(cell x, int top) { ckargs(x, "define-syntax", 2, 2); if (!symbol_p(cadr(x))) error("define-syntax: expected symbol", cadr(x)); if (0 == top) error("define-syntax: must be at top level", x); return ckseq(cddr(x), 0); } int ckquote(cell x) { ckargs(x, "quote", 1, 1); return 0; } int cksetb(cell x) { ckargs(x, "set!", 2, 2); if (!symbol_p(cadr(x))) error("set!: expected symbol", cadr(x)); return ckseq(cddr(x), 0); } int syncheck(cell x, int top) { cell p; if (atom_p(x)) return 0; for (p = x; pair_p(p); p = cdr(p)) ; if (p != NIL) error("improper list in program", x); if (car(x) == S_apply) return ckapply(x); if (car(x) == S_begin) return ckbegin(x, top); if (car(x) == S_define) return ckdefine(x, top); if (car(x) == S_define_syntax) return ckmacro(x, top); if (car(x) == S_if) return ckif(x); if (car(x) == S_ifstar) return ckifstar(x); if (car(x) == S_lambda) return cklambda(x); if (car(x) == S_quote) return ckquote(x); if (car(x) == S_set_b) return cksetb(x); return ckseq(x, 0); } /* * Bytecode compiler */ /* Closure conversion */ int subrp(cell x); cell free_vars(cell x, cell e) { cell n, u, a; int lam; lam = 0; if (memq(x, e) != FALSE) { return NIL; } else if (symbol_p(x)) { return cons(x, NIL); } else if (!pair_p(x)) { return NIL; } else if (car(x) == S_quote) { return NIL; } else if (car(x) == S_apply || car(x) == S_begin || car(x) == S_if || car(x) == S_ifstar || car(x) == S_set_b ) { x = cdr(x); } else if (car(x) == S_define || car(x) == S_define_syntax ) { x = cddr(x); } else if (subrp(car(x))) { x = cdr(x); } else if (car(x) == S_lambda) { save(e); a = flatargs(cadr(x)); save(a); n = set_union(a, e); save(n); e = n; x = cddr(x); lam = 1; } save(u = NIL); while (pair_p(x)) { n = free_vars(car(x), e); save(n); u = set_union(u, n); unsave(1); car(Stack) = u; x = cdr(x); } n = unsave(1); if (lam) unsave(3); return n; } cell cconv(cell x, cell e, cell a); cell mapconv(cell x, cell e, cell a) { cell n, new; save(n = NIL); while (pair_p(x)) { new = cconv(car(x), e, a); n = cons(new, n); car(Stack) = n; x = cdr(x); } return nreverse(unsave(1)); } cell initmap(cell fv, cell e, cell a) { cell m, n, p; int i, j; save(m = NIL); i = 0; while (fv != NIL) { p = cons(car(fv), NIL); save(p); n = mkfix(i); p = cons(n, p); car(Stack) = p; if ((j = posq(car(fv), a)) != FALSE) { n = mkfix(j); p = cons(n, p); unsave(1); p = cons(I_a, p); } else if ((j = hashq(car(fv), e)) != FALSE) { n = mkfix(j); p = cons(n, p); unsave(1); p = cons(I_e, p); } else { error("undefined symbol", car(fv)); } m = cons(p, m); car(Stack) = m; i++; fv = cdr(fv); } return nreverse(unsave(1)); } void newvar(cell x) { cell n; if (memq(x, Env) != FALSE) return; if (NIL == Envp) Envp = lastpair(Env); n = cons(x, NIL); cdr(Envp) = n; Envp = n; addhash(x); } void newvars(cell x) { while (x != NIL) { newvar(car(x)); x = cdr(x); } } cell lamconv(cell x, cell e, cell a) { cell cl, fv, args, m; fv = free_vars(x, NIL); save(fv); newvars(fv); args = flatargs(cadr(x)); save(args); m = initmap(fv, e, a); save(m); cl = mapconv(cddr(x), fv, args); cl = cons(m, cl); cl = cons(cadr(x), cl); cl = cons(I_closure, cl); unsave(3); return cl; } int contains(cell a, cell x) { if (a == x) return 1; if (pair_p(a) && (contains(car(a), x) || contains(cdr(a), x))) return 1; return 0; } int liftable(cell x) { return !contains(x, S_set_b); } cell liftargs(cell m) { #define source cadr cell a, n; save(a = NIL); while (m != NIL) { if (caar(m) == I_a) { n = source(car(m)); n = cons(n, NIL); n = cons(I_arg, n); a = cons(n, a); car(Stack) = a; } m = cdr(m); } return nreverse(unsave(1)); #undef source } cell liftnames(cell m) { #define name cadddr cell a, n; save(a = NIL); while (m != NIL) { if (caar(m) == I_a) { n = name(car(m)); a = cons(n, a); car(Stack) = a; } m = cdr(m); } return nreverse(unsave(1)); #undef name } /* * The following function is a mess. Here is what it does in * more readable Scheme: * * (define (app-conv x e a) * (let ((fv (free (car x))) * (fn (car x)) * (args (cdr x))) * (for-each new-symbol! fv) * (let ((m (initmap fv e a))) * `((%closure ,(append (pick-vars m) (cadr fn)) * #f * ,@(let ((ee (append (lift-names m) * (flatten (cadr fn))))) * (map (lambda (x) (conv x e ee)) * (cddr fn)))) * ,@(lift-args m) * ,@(map (lambda (x) (conv x e a)) args))))) */ cell appconv(cell x, cell e, cell a) { cell fv, fn, args, m, n, ce, vars, fnargs; fv = free_vars(car(x), NIL); save(fv); fn = car(x); args = cdr(x); fnargs = flatargs(cadr(fn)); save(fnargs); newvars(fv); m = initmap(fv, e, a); save(m); args = mapconv(args, e, a); save(args); n = liftargs(m); args = nconc(n, args); car(Stack) = args; ce = liftnames(m); save(ce); vars = conc(ce, cadr(fn)); save(vars); ce = set_union(ce, fnargs); cadr(Stack) = ce; fn = mapconv(cddr(fn), e, ce); fn = cons(NIL, fn); fn = cons(vars, fn); fn = cons(I_closure, fn); unsave(6); return cons(fn, args); } cell defconv(cell x, cell e, cell a) { cell n, m; newvar(cadr(x)); n = mapconv(cddr(x), e, a); save(n); m = mkfix(hashq(cadr(x), e)); save(m); m = cons(I_ref, cons(m, cons(cadr(x), NIL))); unsave(2); return cons(S_set_b, cons(m, n)); } cell cconv(cell x, cell e, cell a) { int n, p; if ( pair_p(x) && (S_apply == car(x) || S_if == car(x) || S_ifstar == car(x) || S_begin == car(x) || S_set_b == car(x) || subrp(car(x)))) { return cons(car(x), mapconv(cdr(x), e, a)); } if ((n = posq(x, a)) != FALSE) { return cons(I_arg, cons(mkfix(n), NIL)); } if ((n = hashq(x, e)) != FALSE) { p = cons(x, NIL); n = cons(I_ref, cons(mkfix(n), p)); return n; } if (symbol_p(x)) { error("undefined symbol", x); return NIL; } if (atom_p(x)) { return x; } if (S_quote == car(x)) { return x; } if ( pair_p(car(x)) && caar(x) == S_lambda && liftable(car(x))) { return appconv(x, e, a); } if (S_lambda == car(x)) { return lamconv(x, e, a); } if (S_define == car(x)) { return defconv(x, e, a); } if (S_define_syntax == car(x)) { return cons(car(x), cons(cadr(x), mapconv(cddr(x), e, a))); } return mapconv(x, e, a); } cell zipenv(cell vs, cell oe) { cell n, b; save(n = NIL); while (vs != NIL) { if (NIL == oe) { b = cons(car(vs), cons(UNDEFINED, NIL)); } else { b = cons(car(vs), cdar(oe)); oe = cdr(oe); } n = cons(b, n); car(Stack) = n; vs = cdr(vs); } return nreverse(unsave(1)); } cell clsconv(cell x) { cell n; Env = Envp = NIL; Env = carof(Glob); if (NIL == Env) Env = cons(UNDEFINED, NIL); n = cconv(x, Env, NIL); save(n); Glob = zipenv(Env, Glob); return unsave(1); } /* Bytecode generation */ void emit(cell x) { cell n, *vp, *vn; int i, k; if (Here >= vector_len(Emitbuf)) { save(x); k = vector_len(Emitbuf); n = make_vector(CHUNK_SIZE + k); vp = vector(Emitbuf); vn = vector(n); for (i = 0; i < k; i++) vn[i] = vp[i]; Emitbuf = n; unsave(1); } vector(Emitbuf)[Here] = x; Here++; } void emitop(cell op) { emit(mkfix(op)); } void emitq(cell x) { emitop(OP_QUOTE); emit(x); } void patch(int a, cell x) { vector(Emitbuf)[a] = x; } cell cpop(void) { cell n; if (NIL == Cts) error("oops: compile stack underflow", UNDEFINED); n = car(Cts); Cts = cdr(Cts); return n; } #define cpushval(x) (Cts = cons(mkfix(x), Cts)) #define cpopval() fixval(cpop()) void swap(void) { cell x; if (NIL == Cts || NIL == cdr(Cts)) error("oops: compile stack underflow", UNDEFINED); x = car(Cts); car(Cts) = cadr(Cts); cadr(Cts) = x; } int subr0p(cell x) { if (x == P_command_line) return OP_COMMAND_LINE; if (x == P_current_error_port) return OP_CURRENT_ERROR_PORT; if (x == P_current_input_port) return OP_CURRENT_INPUT_PORT; if (x == P_current_output_port) return OP_CURRENT_OUTPUT_PORT; if (x == P_gensym) return OP_GENSYM; if (x == P_quit) return OP_QUIT; if (x == P_symbols) return OP_SYMBOLS; return -1; } int subr1p(cell x) { if (x == P_abs) return OP_ABS; if (x == P_boolean_p) return OP_BOOLEAN_P; if (x == P_caaaar) return OP_CAAAAR; if (x == P_caaadr) return OP_CAAADR; if (x == P_caaar) return OP_CAAAR; if (x == P_caadar) return OP_CAADAR; if (x == P_caaddr) return OP_CAADDR; if (x == P_caadr) return OP_CAADR; if (x == P_caar) return OP_CAAR; if (x == P_cadaar) return OP_CADAAR; if (x == P_cadadr) return OP_CADADR; if (x == P_cadar) return OP_CADAR; if (x == P_caddar) return OP_CADDAR; if (x == P_cadddr) return OP_CADDDR; if (x == P_caddr) return OP_CADDR; if (x == P_cadr) return OP_CADR; if (x == P_call_cc) return OP_CALL_CC; if (x == P_call_with_current_continuation) return OP_CALL_CC; if (x == P_car) return OP_CAR; if (x == P_catch) return OP_CATCH; if (x == P_catch_tag_p) return OP_CATCH_TAG_P; if (x == P_cdaaar) return OP_CDAAAR; if (x == P_cdaadr) return OP_CDAADR; if (x == P_cdaar) return OP_CDAAR; if (x == P_cdadar) return OP_CDADAR; if (x == P_cdaddr) return OP_CDADDR; if (x == P_cdadr) return OP_CDADR; if (x == P_cdar) return OP_CDAR; if (x == P_cddaar) return OP_CDDAAR; if (x == P_cddadr) return OP_CDDADR; if (x == P_cddar) return OP_CDDAR; if (x == P_cdddar) return OP_CDDDAR; if (x == P_cddddr) return OP_CDDDDR; if (x == P_cdddr) return OP_CDDDR; if (x == P_cddr) return OP_CDDR; if (x == P_cdr) return OP_CDR; if (x == P_ceiling) return OP_CEILING; if (x == P_char_alphabetic_p) return OP_CHAR_ALPHABETIC_P; if (x == P_char_downcase) return OP_CHAR_DOWNCASE; if (x == P_char_lower_case_p) return OP_CHAR_LOWER_CASE_P; if (x == P_char_numeric_p) return OP_CHAR_NUMERIC_P; if (x == P_char_p) return OP_CHAR_P; if (x == P_char_to_integer) return OP_CHAR_TO_INTEGER; if (x == P_char_upcase) return OP_CHAR_UPCASE; if (x == P_char_upper_case_p) return OP_CHAR_UPPER_CASE_P; if (x == P_char_whitespace_p) return OP_CHAR_WHITESPACE_P; if (x == P_close_input_port) return OP_CLOSE_INPUT_PORT; if (x == P_close_output_port) return OP_CLOSE_OUTPUT_PORT; if (x == P_delete_file) return OP_DELETE_FILE; if (x == P_dump_image) return OP_DUMP_IMAGE; if (x == P_environment_variable) return OP_ENVIRONMENT_VARIABLE; if (x == P_eof_object_p) return OP_EOF_OBJECT_P; if (x == P_eval) return OP_EVAL; if (x == P_even_p) return OP_EVEN_P; if (x == P_exact_p) return OP_EXACT_P; if (x == P_exact_to_inexact) return OP_EXACT_TO_INEXACT; if (x == P_exponent) return OP_EXPONENT; if (x == P_file_exists_p) return OP_FILE_EXISTS_P; if (x == P_floor) return OP_FLOOR; if (x == P_inexact_p) return OP_INEXACT_P; if (x == P_inexact_to_exact) return OP_INEXACT_TO_EXACT; if (x == P_input_port_p) return OP_INPUT_PORT_P; if (x == P_integer_p) return OP_INTEGER_P; if (x == P_integer_to_char) return OP_INTEGER_TO_CHAR; if (x == P_length) return OP_LENGTH; if (x == P_list_to_string) return OP_LIST_TO_STRING; if (x == P_list_to_vector) return OP_LIST_TO_VECTOR; if (x == P_load) return OP_LOAD; if (x == P_macro_expand) return OP_MACRO_EXPAND; if (x == P_macro_expand_1) return OP_MACRO_EXPAND_1; if (x == P_mantissa) return OP_MANTISSA; if (x == P_negative_p) return OP_NEGATIVE_P; if (x == P_not) return OP_NOT; if (x == P_null_p) return OP_NULL_P; if (x == P_number_p) return OP_REAL_P; if (x == P_odd_p) return OP_ODD_P; if (x == P_open_append_file) return OP_OPEN_APPEND_FILE; if (x == P_open_input_file) return OP_OPEN_INPUT_FILE; if (x == P_open_output_file) return OP_OPEN_OUTPUT_FILE; if (x == P_output_port_p) return OP_OUTPUT_PORT_P; if (x == P_pair_p) return OP_PAIR_P; if (x == P_positive_p) return OP_POSITIVE_P; if (x == P_procedure_p) return OP_PROCEDURE_P; if (x == P_real_p) return OP_REAL_P; if (x == P_reverse) return OP_REVERSE; if (x == P_reverse_b) return OP_REVERSE_B; if (x == P_s9_bytecode) return OP_S9_BYTECODE; if (x == P_set_input_port_b) return OP_SET_INPUT_PORT_B; if (x == P_set_output_port_b) return OP_SET_OUTPUT_PORT_B; if (x == P_stats) return OP_STATS; if (x == P_string_copy) return OP_STRING_COPY; if (x == P_string_length) return OP_STRING_LENGTH; if (x == P_string_p) return OP_STRING_P; if (x == P_string_to_list) return OP_STRING_TO_LIST; if (x == P_string_to_symbol) return OP_STRING_TO_SYMBOL; if (x == P_symbol_p) return OP_SYMBOL_P; if (x == P_symbol_to_string) return OP_SYMBOL_TO_STRING; if (x == P_system_command) return OP_SYSTEM_COMMAND; if (x == P_truncate) return OP_TRUNCATE; if (x == P_vector_length) return OP_VECTOR_LENGTH; if (x == P_vector_p) return OP_VECTOR_P; if (x == P_vector_to_list) return OP_VECTOR_TO_LIST; if (x == P_zero_p) return OP_ZERO_P; return -1; } int subr2p(cell x) { if (x == P_assq) return OP_ASSQ; if (x == P_assv) return OP_ASSV; if (x == P_cons) return OP_CONS; if (x == P_eq_p) return OP_EQ_P; if (x == P_eqv_p) return OP_EQV_P; if (x == P_list_ref) return OP_LIST_REF; if (x == P_list_tail) return OP_LIST_TAIL; if (x == P_memq) return OP_MEMQ; if (x == P_memv) return OP_MEMV; if (x == P_quotient) return OP_QUOTIENT; if (x == P_remainder) return OP_REMAINDER; if (x == P_set_car_b) return OP_SET_CAR_B; if (x == P_set_cdr_b) return OP_SET_CDR_B; if (x == P_string_fill_b) return OP_STRING_FILL_B; if (x == P_string_ref) return OP_STRING_REF; if (x == P_throw) return OP_THROW; if (x == P_vector_fill_b) return OP_VECTOR_FILL_B; if (x == P_vector_ref) return OP_VECTOR_REF; return -1; } int subr3p(cell x) { if (x == P_string_set_b) return OP_STRING_SET_B; if (x == P_substring) return OP_SUBSTRING; if (x == P_vector_set_b) return OP_VECTOR_SET_B; return -1; } int osubr0p(cell x) { if (x == P_peek_char) return OP_PEEK_CHAR; if (x == P_read) return OP_READ; if (x == P_read_char) return OP_READ_CHAR; return -1; } int osubr1p(cell x) { if (x == P_display) return OP_DISPLAY; if (x == P_error) return OP_ERROR; if (x == P_make_string) return OP_MAKE_STRING; if (x == P_make_vector) return OP_MAKE_VECTOR; if (x == P_write) return OP_WRITE; if (x == P_write_char) return OP_WRITE_CHAR; return -1; } int osubr4p(cell x) { if (x == P_vector_copy) return OP_VECTOR_COPY; return -1; } int lsubr0p(cell x) { if (x == P_append) return OP_APPEND; if (x == P_bit_op) return OP_BIT_OP; if (x == P_plus) return OP_PLUS; if (x == P_string_append) return OP_STRING_APPEND; if (x == P_times) return OP_TIMES; if (x == P_vector_append) return OP_VECTOR_APPEND; return -1; } int lsubr1p(cell x) { if (x == P_divide) return OP_DIVIDE; if (x == P_max) return OP_MAX; if (x == P_min) return OP_MIN; if (x == P_minus) return OP_MINUS; return -1; } int lsubr2p(cell x) { if (x == P_char_ci_equal_p) return OP_CHAR_CI_EQUAL_P; if (x == P_char_ci_grtr_p) return OP_CHAR_CI_GRTR_P; if (x == P_char_ci_gteq_p) return OP_CHAR_CI_GTEQ_P; if (x == P_char_ci_less_p) return OP_CHAR_CI_LESS_P; if (x == P_char_ci_lteq_p) return OP_CHAR_CI_LTEQ_P; if (x == P_char_equal_p) return OP_CHAR_EQUAL_P; if (x == P_char_grtr_p) return OP_CHAR_GRTR_P; if (x == P_char_gteq_p) return OP_CHAR_GTEQ_P; if (x == P_char_less_p) return OP_CHAR_LESS_P; if (x == P_char_lteq_p) return OP_CHAR_LTEQ_P; if (x == P_equal) return OP_EQUAL; if (x == P_grtr) return OP_GRTR; if (x == P_gteq) return OP_GTEQ; if (x == P_less) return OP_LESS; if (x == P_lteq) return OP_LTEQ; if (x == P_string_ci_equal) return OP_STRING_CI_EQUAL_P; if (x == P_string_ci_grtr) return OP_STRING_CI_GRTR_P; if (x == P_string_ci_gteq) return OP_STRING_CI_GTEQ_P; if (x == P_string_ci_less) return OP_STRING_CI_LESS_P; if (x == P_string_ci_lteq) return OP_STRING_CI_LTEQ_P; if (x == P_string_equal) return OP_STRING_EQUAL_P; if (x == P_string_grtr) return OP_STRING_GRTR_P; if (x == P_string_gteq) return OP_STRING_GTEQ_P; if (x == P_string_less) return OP_STRING_LESS_P; if (x == P_string_lteq) return OP_STRING_LTEQ_P; return -1; } int subrp(cell x) { return subr0p(x) >= 0 || subr1p(x) >= 0 || subr2p(x) >= 0 || subr3p(x) >= 0 || osubr0p(x) >= 0 || osubr1p(x) >= 0 || osubr4p(x) >= 0 || lsubr0p(x) >= 0 || lsubr1p(x) >= 0 || lsubr2p(x) >= 0; } void compexpr(cell x, int t); void compbegin(cell x, int t) { x = cdr(x); if (NIL == x) { emitq(UNSPECIFIC); return; } while (cdr(x) != NIL) { compexpr(car(x), 0); x = cdr(x); } compexpr(car(x), t); } void compsetb(cell x) { compexpr(caddr(x), 0); if (caadr(x) == I_ref) { emitop(OP_SET_REF); emit(cadadr(x)); } else if (caadr(x) == I_arg) { emitop(OP_SET_ARG); emit(cadadr(x)); } else { error("oops: unknown location in set!", x); } } void compif(cell x, int t, int star) { compexpr(cadr(x), 0); emitop(star? OP_JMP_TRUE: OP_JMP_FALSE); cpushval(Here); emit(NIL); compexpr(caddr(x), t); if (cdddr(x) != NIL) { emitop(OP_JMP); cpushval(Here); emit(NIL); swap(); patch(cpopval(), mkfix(Here)); compexpr(cadddr(x), t); } patch(cpopval(), mkfix(Here)); } void setupenv(cell m) { while (m != NIL) { if (caar(m) == I_e) emitop(OP_COPY_REF); else if (caar(m) == I_a) emitop(OP_COPY_ARG); else error("oops: unknown location in closure", m); emit(cadar(m)); emit(caddar(m)); m = cdr(m); } } void compcls(cell x) { int a, na; cell b, m; emitop(OP_JMP); cpushval(Here); emit(NIL); a = Here; na = length(flatargs(cadr(x))); if (dotted_p(cadr(x))) { emitop(OP_ENTER_COLL); emit(mkfix(na-1)); } else { emitop(OP_ENTER); emit(mkfix(na)); } b = cons(S_begin, cdddr(x)); save(b); compexpr(b, 1); unsave(1); emitop(OP_RETURN); patch(cpopval(), mkfix(Here)); m = caddr(x); if (m != NIL) { emitop(OP_MAKE_ENV); emit(mkfix(length(m))); setupenv(m); } else { emitop(OP_PROP_ENV); } emitop(OP_CLOSURE); emit(mkfix(a)); } void compapply(cell x, int t) { cell xs; xs = reverse(cddr(x)); save(xs); compexpr(car(xs), 0); for (xs = cdr(xs); xs != NIL; xs = cdr(xs)) { emitop(OP_PUSH); compexpr(car(xs), 0); emitop(OP_CONS); } emitop(OP_PUSH); unsave(1); compexpr(cadr(x), 0); emitop(t? OP_TAIL_APPLIS: OP_APPLIS); } void compapp(cell x, int t) { cell xs; xs = reverse(cdr(x)); save(xs); while (xs != NIL) { compexpr(car(xs), 0); emitop(OP_PUSH); xs = cdr(xs); } unsave(1); emitop(OP_PUSH_VAL); emit(mkfix(length(cdr(x)))); compexpr(car(x), 0); emitop(t? OP_TAIL_APPLY: OP_APPLY); } void compsubr0(cell x, int op) { ckargs(x, symbol_name(car(x)), 0, 0); emitop(op); } void compsubr1(cell x, int op) { ckargs(x, symbol_name(car(x)), 1, 1); compexpr(cadr(x), 0); emitop(op); if (OP_CALL_CC == op || OP_CATCH == op) emitop(OP_APPLY); } void compsubr2(cell x, int op) { ckargs(x, symbol_name(car(x)), 2, 2); compexpr(caddr(x), 0); emitop(OP_PUSH); compexpr(cadr(x), 0); emitop(op); } void compsubr3(cell x, int op) { ckargs(x, symbol_name(car(x)), 3, 3); compexpr(cadddr(x), 0); emitop(OP_PUSH); compexpr(caddr(x), 0); emitop(OP_PUSH); compexpr(cadr(x), 0); emitop(op); } void composubr0(cell x, int op) { ckargs(x, symbol_name(car(x)), 0, 1); if (NIL == cdr(x)) emitop(OP_CURRENT_INPUT_PORT); else compexpr(cadr(x), 0); emitop(op); } void composubr1(cell x, int op) { ckargs(x, symbol_name(car(x)), 1, 2); if (NIL == cddr(x)) { if (OP_ERROR == op) { /**/ } if (OP_MAKE_STRING == op) { emitop(OP_QUOTE); emit(make_char(' ')); } if (OP_MAKE_VECTOR == op) { emitq(FALSE); } if ( OP_DISPLAY == op || OP_WRITE == op || OP_WRITE_CHAR == op) { emitop(OP_CURRENT_OUTPUT_PORT); } } else { if (OP_ERROR == op) op = OP_ERROR2; compexpr(caddr(x), 0); } emitop(OP_PUSH); compexpr(cadr(x), 0); emitop(op); } void composubr4(cell x, int op) { int k; ckargs(x, symbol_name(car(x)), 1, 4); x = cdr(x); k = length(x); if (k < 4) emitq(FALSE); else compexpr(cadddr(x), 0); emitop(OP_PUSH); if (k < 3) emitq(UNDEFINED); else compexpr(caddr(x), 0); emitop(OP_PUSH); if (k < 2) emitq(UNDEFINED); else compexpr(cadr(x), 0); emitop(OP_PUSH); compexpr(car(x), 0); emitop(op); } void complsubr0(cell x, int op) { cell bitop = 0; /*LINT*/ if (OP_BIT_OP == op && length(x) < 4) ckargs(x, "bit-op", 3, -1); if (NIL == cdr(x)) { if (OP_PLUS == op) { emitq(Zero); } else if (OP_TIMES == op) { emitq(One); } else if (OP_STRING_APPEND == op) { emitop(OP_QUOTE); emit(make_string("", 0)); } else if (OP_VECTOR_APPEND == op) { emitop(OP_QUOTE); emit(make_vector(0)); } else { /* OP_APPEND */ emitq(NIL); } } else if (NIL == cddr(x)) { /* * should catch wrong type */ compexpr(cadr(x), 0); } else if (OP_STRING_APPEND == op || OP_VECTOR_APPEND == op) { x = cdr(x); x = reverse(x); save(x); emitq(NIL); while (x != NIL) { emitop(OP_PUSH); compexpr(car(x), 0); emitop(OP_CONS); x = cdr(x); } unsave(1); emitop(op); } else { x = cdr(x); if (OP_BIT_OP == op) { bitop = car(x); x = cdr(x); } x = reverse(x); save(x); compexpr(car(x), 0); x = cdr(x); while (x != NIL) { emitop(OP_PUSH); compexpr(car(x), 0); if (OP_BIT_OP == op) { emitop(OP_PUSH); compexpr(bitop, 0); } emitop(op); x = cdr(x); } unsave(1); } } void complsubr1(cell x, int op) { ckargs(x, symbol_name(car(x)), 1, -1); if (NIL == cddr(x)) { if (OP_MINUS == op) { compexpr(cadr(x), 0); emitop(OP_NEGATE); } else if (OP_DIVIDE == op) { emitq(One); emitop(OP_PUSH); compexpr(cadr(x), 0); emitop(op); } else { /* OP_MIN, OP_MAX */ compexpr(cadr(x), 0); } } else { if (OP_MIN == op || OP_MAX == op) { emitop(OP_PUSH_VAL); emit(FALSE); } x = cdr(x); compexpr(car(x), 0); for (x = cdr(x); x != NIL; x = cdr(x)) { emitop(OP_PUSH); compexpr(car(x), 0); emitop(op); } if (OP_MIN == op || OP_MAX == op) { emitop(OP_FIX_EXACTNESS); } } } void complsubr2(cell x, int op) { ckargs(x, symbol_name(car(x)), 2, -1); emitop(OP_PUSH_VAL); emit(TRUE); x = cdr(x); compexpr(car(x), 0); for (x = cdr(x); x != NIL; x = cdr(x)) { emitop(OP_PUSH); compexpr(car(x), 0); emitop(op); } emitop(OP_POP); } void compexpr(cell x, int t) { int op; if (atom_p(x)) { emitq(x); } else if (car(x) == S_quote) { emitq(cadr(x)); } else if (car(x) == I_arg) { emitop(OP_ARG); emit(cadr(x)); } else if (car(x) == I_ref) { emitop(OP_REF); emit(cadr(x)); emit(caddr(x)); } else if (car(x) == S_if) { compif(x, t, 0); } else if (car(x) == S_ifstar) { compif(x, t, 1); } else if (car(x) == I_closure) { compcls(x); } else if (car(x) == S_begin) { compbegin(x, t); } else if (car(x) == S_set_b) { compsetb(x); } else if (car(x) == S_apply) { compapply(x, t); } else if (car(x) == S_define_syntax) { compexpr(caddr(x), 0); emitop(OP_DEF_MACRO); emit(cadr(x)); } else if ((op = subr0p(car(x))) >= 0) { compsubr0(x, op); } else if ((op = subr1p(car(x))) >= 0) { compsubr1(x, op); } else if ((op = subr2p(car(x))) >= 0) { compsubr2(x, op); } else if ((op = subr3p(car(x))) >= 0) { compsubr3(x, op); } else if ((op = osubr0p(car(x))) >= 0) { composubr0(x, op); } else if ((op = osubr1p(car(x))) >= 0) { composubr1(x, op); } else if ((op = osubr4p(car(x))) >= 0) { composubr4(x, op); } else if ((op = lsubr0p(car(x))) >= 0) { complsubr0(x, op); } else if ((op = lsubr1p(car(x))) >= 0) { complsubr1(x, op); } else if ((op = lsubr2p(car(x))) >= 0) { complsubr2(x, op); } else { /* application */ compapp(x, t); } } cell compile(cell x) { Emitbuf = make_vector(CHUNK_SIZE); Here = 0; Cts = NIL; compexpr(x, 0); emitop(OP_HALT); return subvector(Emitbuf, 0, Here); } /* * Macro expander */ cell expand(cell x, int all); cell mapexp(cell x, int all) { cell p, n, new; save(x); save(n = NIL); for (p = x; pair_p(p); p = cdr(p)) { new = expand(car(p), all); n = cons(new, n); car(Stack) = n; } if (p != NIL) error("improper list in program", x); n = nreverse(unsave(1)); unsave(1); return n; } cell expanddef(cell x) { cell n; save(x); n = cons(cdadr(x), cddr(x)); n = cons(S_lambda, n); n = cons(n, NIL); n = cons(caadr(x), n); n = cons(car(x), n); unsave(1); return n; } cell expandbody(cell x) { cell n, vs, as; save(x); save(vs = NIL); save(as = NIL); while ( pair_p(x) && pair_p(car(x)) && caar(x) == S_define) { n = car(x); if (pair_p(cadr(n))) n = expanddef(n); save(n); vs = cons(cadr(n), vs); caddr(Stack) = vs; n = cons(caddr(n), NIL); as = cons(n, as); cadr(Stack) = as; unsave(1); x = cdr(x); } if (NIL == vs) { unsave(3); return x; } as = nreverse(as); car(Stack) = as; vs = nreverse(vs); cadr(Stack) = vs; n = cons(zip(vs, as), x); n = cons(S_letrec, n); n = cons(n, NIL); unsave(3); return n; } cell expand(cell x, int all) { cell n, m; if (Expand_level < 0) error("interrupted", UNDEFINED); if (Expand_level > MAX_EXPAND) error("too many levels of macro expansion", UNDEFINED); Expand_level++; if (atom_p(x)) { Expand_level--; return x; } if (car(x) == S_quote) { Expand_level--; return x; } if (car(x) == S_lambda) { save(x); n = expandbody(cddr(x)); n = mapexp(n, all); n = cons(cadr(x), n); unsave(1); Expand_level--; return cons(car(x), n); } if ( car(x) == S_define || car(x) == S_define_syntax) { save(x); if (pair_p(cadr(x))) { n = expanddef(x); car(Stack) = n; n = expand(n, all); } else { n = expand(caddr(x), all); n = cons(n, NIL); n = cons(cadr(x), n); n = cons(car(x), n); } unsave(1); Expand_level--; return n; } if ((m = assq(car(x), Macros)) != FALSE) { save(x); n = cons(cdr(x), NIL); n = cons(S_quote, n); n = cons(n, NIL); n = cons(cdr(m), n); n = cons(S_apply, n); n = eval(n, 1); if (all) { save(n); n = expand(n, all); unsave(1); } unsave(1); Expand_level--; return n; } x = mapexp(x, all); Expand_level--; return x; } /* * Abstract machine */ #define ins() fixval(vector(Prog)[Ip]) #define op1() (vector(Prog)[Ip+1]) #define op2() (vector(Prog)[Ip+2]) #define skip(n) (Ip += (n)) #define box(x) cons((x), NIL) #define boxref(x) car(x) #define boxset(x,v) (car(x) = (v)) #define stackref(x) (vector(Rts)[x]) #define stackset(x,v) (vector(Rts)[x] = (v)) #define argbox(n) (stackref(Fp-fixval(n))) #define argref(n) boxref(argbox(n)) #define arg(n) boxref(stackref(Sp-(n))) #define clear(n) (Sp -= (n)) #define envbox(x) (vector(Ep)[fixval(x)]) void stkalloc(int k) { cell n, *vs, *vn; int i; if (Sp + k >= Sz) { /* allocate multiples of CHUNK_SIZE */ if (k >= CHUNK_SIZE) { k = Sp+k-Sz; k = CHUNK_SIZE * (1 + (k / CHUNK_SIZE)); } else { k = CHUNK_SIZE; } n = make_vector(Sz + k); vs = vector(Rts); vn = vector(n); for (i=0; i<Sz; i++) vn[i] = vs[i]; Sz += k; Rts = n; } } void push(cell x) { Tmp = x; stkalloc(1); Tmp = NIL; Sp++; stackset(Sp, x); } /* Opcodes */ cell apply_extproc(cell pfn) { cell x, a; int i, k; char *s; k = fixval(stackref(Sp)); s = typecheck(pfn); if (s != NULL) { save(a = NIL); for (i = k; i > 0; i--) { a = cons(car(stackref(Sp-i)), a); car(Stack) = a; } unsave(1); error(s, a); } x = apply_prim(pfn); Sp -= k+1; return x; } int apply(int tail) { int n, m, pn, pm, i; cell k, e; if (!function_p(Acc)) { if (primitive_p(Acc)) { Acc = apply_extproc(Acc); return Ip+1; } if (continuation_p(Acc)) { return call_cont(Acc, arg(1)); } error("application of non-function", Acc); } if (tail) { Ep = closure_env(Acc); Prog = closure_prog(Acc); m = fixval(stackref(Sp)); n = fixval(stackref(Sp-m-4)); pm = Sp-m; pn = Sp-m-n-4; if (n == m) { for (i=0; i<=m; i++) stackset(pn+i, stackref(pm+i)); Fp = fixval(stackref(Sp-m-1)); Sp -= n+2; } else { e = stackref(Sp-m-3); k = stackref(Sp-m-2); Fp = fixval(stackref(Sp-m-1)); for (i=0; i<=m; i++) stackset(pn+i, stackref(pm+i)); Sp -= n+2; stackset(Sp-1, e); stackset(Sp, k); } } else { push(Ep); push(cons(mkfix(Ip+1), Prog)); Ep = closure_env(Acc); Prog = closure_prog(Acc); } return fixval(closure_ip(Acc)); } int applis(int tail) { cell a, p, new; int k, i; a = arg(0); if (!list_p(a)) error("apply: expected list", a); k = conses(a); stkalloc(k); Sp += k; i = Sp-1; for (p = a; p != NIL; p = cdr(p)) { if (atom_p(p)) error("apply: improper list", a); new = box(car(p)); stackset(i, new); i--; } new = mkfix(k); stackset(Sp, new); return apply(tail); } int ret(void) { int r, k; cell *v; v = vector(Rts); Fp = fixval(v[Sp]); r = v[Sp-1]; Prog = cdr(r); Ep = v[Sp-2]; k = fixval(v[Sp-3]); Sp -= k+4; return fixval(car(r)); } void entcol(int fix) { int n, na, i, s, d; cell a, x, new; na = fixval(stackref(Sp-2)); if (na < fix) error("too few arguments", UNDEFINED); save(a = NIL); i = Sp-fix-3; for (n = na-fix; n; n--) { x = cons(boxref(stackref(i)), NIL); if (NIL == a) { a = x; car(Stack) = a; } else { cdr(a) = x; a = x; } i--; } a = unsave(1); if (na > fix) { new = box(a); stackset(Sp-fix-3, new); } else { push(NIL); s = Sp - na - 3; d = Sp - na - 2; for (i = na + 2; i >= 0; i--) stackset(d+i, stackref(s+i)); new = mkfix(1+fix); stackset(Sp-2, new); new = box(NIL); stackset(Sp-fix-3, new); } push(mkfix(Fp)); Fp = Sp-4; } void newmacro(cell name, cell fn) { cell n; n = assq(name, Macros); if (FALSE == n) { n = cons(name, fn); Macros = cons(n, Macros); } else { cdr(n) = fn; } } /* Inlined primitive procedures */ cell integer_value(char *who, cell x) { char msg[100]; if (!integer_p(x)) { sprintf(msg, "%s: expected integer, got", who); error(msg, x); return 0; } if (!small_int_p(x)) { sprintf(msg, "%s: integer argument too big", who); error(msg, x); return 0; } return small_int_value(x); } cell integer_argument(char *who, cell x) { cell n; char msg[100]; if (real_p(x)) { n = real_to_bignum(x); if (UNDEFINED == n) { sprintf(msg, "%s: expected integer, got", who); error(msg, x); return UNDEFINED; } return n; } return x; } cell gensym(void) { static int id = 0; char b[100]; cell p; if (0 == id) { for (p = Glob; p != NIL; p = cdr(p)) if ('G' == symbol_name(caar(p))[0]) id = asctol(&symbol_name(caar(p))[1]); } id++; sprintf(b, "G%d", id); return symbol_ref(b); } char *rev_cxr_name(char *s) { int i, k = strlen(s); static char buf[8]; for (i=0; i<k; i++) buf[i] = s[k-i-1]; buf[i] = 0; return buf; } cell cxr(char *op, cell x) { char *p; cell n = x; char buf[64]; for (p = op; *p; p++) { if (!pair_p(n)) { sprintf(buf, "c%sr: unsuitable type for operation", rev_cxr_name(op)); error(buf, x); } n = 'a' == *p? car(n): cdr(n); } return n; } cell append(cell a, cell b) { cell n, p, pn, new; if (NIL == a) return b; if (NIL == b) return a; save(n = cons(NIL, NIL)); pn = n; /*LINT*/ for (p = a; pair_p(p); p = cdr(p)) { car(n) = car(p); pn = n; if (pair_p(cdr(p))) { new = cons(NIL, NIL); cdr(n) = new; n = new; } } if (p != NIL) error("append: improper list", a); cdr(pn) = b; return unsave(1); } cell list_length(cell a) { cell p; int k; k = 0; for (p = a; pair_p(p); p = cdr(p)) k++; if (p != NIL) error("length: improper list", a); return make_integer(k); } int eqv_p(cell a, cell b) { if (a == b) return 1; if (char_p(a) && char_p(b) && char_value(a) == char_value(b)) return 1; return number_p(a) && number_p(b) && real_p(a) == real_p(b) && real_equal_p(a, b); } int assqv(char *who, int v, cell x, cell a) { cell p; char buf[64]; for (p = a; p != NIL; p = cdr(p)) { if (!pair_p(p)) { sprintf(buf, "%s: improper list", who); error(buf, a); } if (!pair_p(car(p))) { sprintf(buf, "%s: bad element in alist", who); error(buf, car(p)); } if (!v && x == caar(p)) return car(p); if (v && eqv_p(x, caar(p))) return car(p); } return FALSE; } int memqv(char *who, int v, cell x, cell a) { cell p; char buf[64]; for (p = a; p != NIL; p = cdr(p)) { if (!pair_p(p)) { sprintf(buf, "%s: improper list", who); error(buf, a); } if (!v && x == car(p)) return p; if (v && eqv_p(x, car(p))) return p; } return FALSE; } int nth(char *who, int ref, cell a, cell n) { cell p; char buf[64]; int k; k = integer_value(who, n); for (p = a; p != NIL; p = cdr(p)) { if (0 == k) break; if (!pair_p(p)) { sprintf(buf, "%s: improper list", who); error(buf, a); } k--; } if (0 == k) { if (0 == ref) return p; else if (pair_p(p)) return car(p); } sprintf(buf, "%s: index out of range", who); error(buf, n); return NIL; } cell bit_op(cell op, cell x, cell y) { char name[] = "bit-op"; cell a, b; static cell mask = 0; if (0 == mask) { mask = 1; while (mask < S9_INT_SEG_LIMIT) mask <<= 1; if (mask >= S9_INT_SEG_LIMIT) mask >>= 1; mask--; } op = integer_value(name, op); a = integer_value(name, x); b = integer_value(name, y); if ((a & ~mask) != 0) error("bit-op: range error", x); if ((b & ~mask) != 0) error("bit-op: range error", y); switch (op) { case 0: a = 0; break; case 1: a = a & b; break; case 2: a = a & ~b; break; case 3: /* a = a; */ break; case 4: a = ~a & b; break; case 5: a = b; break; case 6: a = a ^ b; break; case 7: a = a | b; break; case 8: a = ~(a | b); break; case 9: a = ~(a ^ b); break; case 10: a = ~b; break; case 11: a = a | ~b; break; case 12: a = ~a; break; case 13: a = ~a | b; break; case 14: a = ~(a & b); break; case 15: a = ~0; break; case 16: a = a << b; break; case 17: a = a >> b; break; default: error("bit-op: unknown opcode", op); break; } return make_integer(a & mask); } cell add(cell x, cell y) { if (!number_p(x)) expect("+", "number", x); if (!number_p(y)) expect("+", "number", y); return real_add(x, y); } cell xsub(cell x, cell y) { if (!number_p(x)) expect("-", "number", x); if (!number_p(y)) expect("-", "number", y); return real_subtract(y, x); } cell mul(cell x, cell y) { if (!number_p(x)) expect("*", "number", x); if (!number_p(y)) expect("*", "number", y); return real_multiply(x, y); } cell xdiv(cell x, cell y) { if (!number_p(x)) expect("/", "number", x); if (!number_p(y)) expect("/", "number", y); if (real_zero_p(x)) error("/: divide by zero", UNDEFINED); return real_divide(y, x); } cell intdiv(cell x, cell y) { x = integer_argument("quotient", x); save(x); y = integer_argument("quotient", y); unsave(1); if (bignum_zero_p(y)) error("quotient: divide by zero", UNDEFINED); x = bignum_divide(x, y); return car(x); } cell intrem(cell x, cell y) { x = integer_argument("remainder", x); save(x); y = integer_argument("remainder", y); unsave(1); if (bignum_zero_p(y)) error("remainder: divide by zero", UNDEFINED); x = bignum_divide(x, y); return cdr(x); } cell exact_to_inexact(cell x) { cell n; int flags; if (integer_p(x)) { flags = bignum_negative_p(x)? REAL_NEGATIVE: 0; n = bignum_abs(x); n = Make_real(flags, 0, cdr(n)); if (UNDEFINED == n) error("exact->inexact: overflow", x); return n; } return x; } cell inexact_to_exact(cell x) { cell n; if (integer_p(x)) return x; n = real_to_bignum(x); if (UNDEFINED == n) error("inexact->exact: no exact representation", x); return n; } void grtr(cell x, cell y) { if (!number_p(x)) expect(">", "number", x); if (!number_p(y)) expect(">", "number", y); if (!real_less_p(x, y)) stackset(Sp-1, FALSE); } void gteq(cell x, cell y) { if (!number_p(x)) expect(">=", "number", x); if (!number_p(y)) expect(">=", "number", y); if (real_less_p(y, x)) stackset(Sp-1, FALSE); } void less(cell x, cell y) { if (!number_p(x)) expect("<", "number", x); if (!number_p(y)) expect("<", "number", y); if (!real_less_p(y, x)) stackset(Sp-1, FALSE); } void lteq(cell x, cell y) { if (!number_p(x)) expect("<=", "number", x); if (!number_p(y)) expect("<=", "number", y); if (real_less_p(x, y)) stackset(Sp-1, FALSE); } void equal(cell x, cell y) { if (!number_p(x)) expect("=", "number", x); if (!number_p(y)) expect("=", "number", y); if (!real_equal_p(x, y)) stackset(Sp-1, FALSE); } void cless(cell x, cell y) { if (!char_p(x)) expect("char<?", "char", x); if (!char_p(y)) expect("char<?", "char", y); if (char_value(y) >= char_value(x)) stackset(Sp-1, FALSE); } void clteq(cell x, cell y) { if (!char_p(x)) expect("char<=?", "char", x); if (!char_p(y)) expect("char<=?", "char", y); if (char_value(y) > char_value(x)) stackset(Sp-1, FALSE); } void cequal(cell x, cell y) { if (!char_p(x)) expect("char=?", "char", x); if (!char_p(y)) expect("char=?", "char", y); if (char_value(y) != char_value(x)) stackset(Sp-1, FALSE); } void cgrtr(cell x, cell y) { if (!char_p(x)) expect("char>?", "char", x); if (!char_p(y)) expect("char>?", "char", y); if (char_value(y) <= char_value(x)) stackset(Sp-1, FALSE); } void cgteq(cell x, cell y) { if (!char_p(x)) expect("char>=?", "char", x); if (!char_p(y)) expect("char>=?", "char", y); if (char_value(y) < char_value(x)) stackset(Sp-1, FALSE); } void ciless(cell x, cell y) { if (!char_p(x)) expect("char<?", "char", x); if (!char_p(y)) expect("char<?", "char", y); if (tolower(char_value(y)) >= tolower(char_value(x))) stackset(Sp-1, FALSE); } void cilteq(cell x, cell y) { if (!char_p(x)) expect("char<=?", "char", x); if (!char_p(y)) expect("char<=?", "char", y); if (tolower(char_value(y)) > tolower(char_value(x))) stackset(Sp-1, FALSE); } void ciequal(cell x, cell y) { if (!char_p(x)) expect("char=?", "char", x); if (!char_p(y)) expect("char=?", "char", y); if (tolower(char_value(y)) != tolower(char_value(x))) stackset(Sp-1, FALSE); } void cigrtr(cell x, cell y) { if (!char_p(x)) expect("char>?", "char", x); if (!char_p(y)) expect("char>?", "char", y); if (tolower(char_value(y)) <= tolower(char_value(x))) stackset(Sp-1, FALSE); } void cigteq(cell x, cell y) { if (!char_p(x)) expect("char>=?", "char", x); if (!char_p(y)) expect("char>=?", "char", y); if (tolower(char_value(y)) < tolower(char_value(x))) stackset(Sp-1, FALSE); } void sless(cell x, cell y) { if (!string_p(x)) expect("string<?", "string", x); if (!string_p(y)) expect("string<?", "string", y); if (strcmp(string(y), string(x)) >= 0) stackset(Sp-1, FALSE); } void slteq(cell x, cell y) { if (!string_p(x)) expect("string<=?", "string", x); if (!string_p(y)) expect("string<=?", "string", y); if (strcmp(string(y), string(x)) > 0) stackset(Sp-1, FALSE); } void sequal(cell x, cell y) { if (!string_p(x)) expect("string=?", "string", x); if (!string_p(y)) expect("string=?", "string", y); if (string_len(x) != string_len(y)) { stackset(Sp-1, FALSE); return; } if (strcmp(string(y), string(x)) != 0) stackset(Sp-1, FALSE); } void sgrtr(cell x, cell y) { if (!string_p(x)) expect("string>?", "string", x); if (!string_p(y)) expect("string>?", "string", y); if (strcmp(string(y), string(x)) <= 0) stackset(Sp-1, FALSE); } void sgteq(cell x, cell y) { if (!string_p(x)) expect("string>=?", "string", x); if (!string_p(y)) expect("string>=?", "string", y); if (strcmp(string(y), string(x)) < 0) stackset(Sp-1, FALSE); } void siless(cell x, cell y) { if (!string(x)) expect("string-ci<?", "string", x); if (!string(y)) expect("string-ci<?", "string", y); if (strcmp_ci(string(y), string(x)) >= 0) stackset(Sp-1, FALSE); } void silteq(cell x, cell y) { if (!string_p(x)) expect("string-ci<=?", "string", x); if (!string_p(y)) expect("string-ci<=?", "string", y); if (strcmp_ci(string(y), string(x)) > 0) stackset(Sp-1, FALSE); } void siequal(cell x, cell y) { if (!string_p(x)) expect("string-ci=?", "string", x); if (!string_p(y)) expect("string-ci=?", "string", y); if (string_len(x) != string_len(y)) { stackset(Sp-1, FALSE); return; } if (strcmp_ci(string(y), string(x)) != 0) stackset(Sp-1, FALSE); } void sigrtr(cell x, cell y) { if (!string_p(x)) expect("string-ci>?", "string", x); if (!string_p(y)) expect("string-ci>?", "string", y); if (strcmp_ci(string(y), string(x)) <= 0) stackset(Sp-1, FALSE); } void sigteq(cell x, cell y) { if (!string_p(x)) expect("string-ci>=?", "string", x); if (!string_p(y)) expect("string-ci>=?", "string", y); if (strcmp_ci(string(y), string(x)) < 0) stackset(Sp-1, FALSE); } cell makestr(cell z, cell a) { cell n; int i, c, k; char *s; k = integer_value("make-string", z); if (!char_p(a)) expect("make-string", "char", a); c = char_value(a); n = make_string("", k); s = string(n); for (i=0; i<k; i++) s[i] = c; return n; } cell sref(cell s, cell n) { int i; if (!string_p(s)) expect("string-ref", "string", s); i = integer_value("string-ref", n); if (i < 0 || i >= string_len(s)-1) error("sref: index out of range", n); return make_char(string(s)[i]); } void sset(cell s, cell n, cell r) { int i; if (!string_p(s)) expect("string-set!", "string", s); if (constant_p(s)) error("string-set!: immutable", s); i = integer_value("string-set!", n); if (!char_p(r)) expect("string-set!", "char", r); if (i < 0 || i >= string_len(s)-1) error("string-set!: index out of range", n); string(s)[i] = char_value(r); } cell substring(cell s, cell n0, cell n1) { int k, k0, k1, i, j; cell n; char *s0, *s1; if (!string_p(s)) expect("substring", "string", s); k0 = integer_value("substring", n0); k1 = integer_value("substring", n1); if (k0 < 0 || k1 < 0 || k0 > k1 || k1 >= string_len(s)) error("substring: invalid range", cons(n0, cons(n1, NIL))); k = k1-k0; n = make_string("", k); j = 0; s0 = string(s); s1 = string(n); for (i=k0; i<k1; i++) { s1[j] = s0[i]; j++; } s1[j] = 0; return n; } void sfill(cell a, cell n) { int c, i, k; char *s; if (!string_p(a)) expect("string-fill!", "string", a); if (constant_p(a)) error("string-fill!: immutable", a); if (!char_p(n)) expect("sfill", "char", n); c = char_value(n); k = string_len(a)-1; s = string(a); for (i=0; i<k; i++) s[i] = c; } cell sconc(cell x) { cell p, n; int k, m; char *s; k = 0; for (p = x; p != NIL; p = cdr(p)) { if (!string_p(car(p))) expect("string-append", "string", car(p)); k += string_len(car(p))-1; } n = make_string("", k); s = string(n); k = 0; for (p = x; p != NIL; p = cdr(p)) { m = string_len(car(p)); memcpy(&s[k], string(car(p)), m); k += string_len(car(p))-1; } return n; } cell makevec(cell z, cell a) { cell n; int i, k; cell *v; k = integer_value("make-vector", z); n = make_vector(k); v = vector(n); for (i=0; i<k; i++) v[i] = a; return n; } cell vref(cell s, cell n) { int i; if (!vector_p(s)) expect("vector-ref", "vector", s); i = integer_value("vector-ref", n); if (i < 0 || i >= vector_len(s)) error("vector-ref: index out of range", n); return vector(s)[i]; } cell vconc(cell x) { cell n, p, *ov, *nv; int i, j, k, total; total = 0; for (p = x; p != NIL; p = cdr(p)) { if (vector_p(car(p))) total += vector_len(car(p)); else expect("vector-append", "vector", car(p)); } n = new_vec(T_VECTOR, total * sizeof(cell));; nv = vector(n); j = 0; for (p = x; p != NIL; p = cdr(p)) { ov = vector(car(p)); k = vector_len(car(p)); for (i = 0; i < k; i++) nv[j++] = ov[i]; } return n; } cell vcopy(cell v, cell n0, cell nn, cell fill) { cell n, *ov, *nv; int k0, kn, k; int i, j; k = vector_len(v); k0 = 0; kn = k; if (n0 != UNDEFINED) k0 = integer_value("vector-copy", n0); if (nn != UNDEFINED) kn = integer_value("vector-copy", nn); if (k0 > kn) error("vector-copy: bad range", UNDEFINED); n = make_vector(kn-k0); nv = vector(n); ov = vector(v); for (j = 0, i = k0; i < kn; i++, j++) nv[j] = i>=k? fill: ov[i]; return n; } void vfill(cell a, cell n) { int i, k; cell *v; if (!vector_p(a)) expect("vector-fill!", "vector", a); if (constant_p(a)) error("vector-fill!: immutable", a); k = vector_len(a); v = vector(a); for (i=0; i<k; i++) v[i] = n; } void vset(cell s, cell n, cell r) { int i; if (!vector_p(s)) expect("vector-set!", "vector", s); if (constant_p(s)) error("vector-set!: immutable", s); i = integer_value("vector-set!", n); if (i < 0 || i >= vector_len(s)) error("vector-set!: index out of range", n); vector(s)[i] = r; } cell openfile(cell x, int mode) { int p = 0; /*LINT*/ switch (mode) { case 0: p = open_input_port(string(x)); break; case 1: p = open_output_port(string(x), 0); break; case 2: p = open_output_port(string(x), 1); break; } if (p < 0) { if (0 == mode) error("open-input-file: cannot open", x); else if (1 == mode) error("open-output-file: cannot open", x); else error("open-append-file: cannot open", x); } return make_port(p, 0 == mode? T_INPUT_PORT: T_OUTPUT_PORT); } cell readchar(cell p, int rej) { int pp, c; pp = input_port(); if (p != pp) set_input_port(p); c = readc(); if (rej) rejectc(c); if (p != pp) set_input_port(pp); if (EOF == c) return END_OF_FILE; return make_char(c); } cell read_obj(cell p) { int pp; cell n; pp = input_port(); if (p != pp) set_input_port(p); n = xread(); if (p != pp) set_input_port(pp); return n; } void write_obj(cell x, int p, int disp) { int pp, odisp; pp = output_port(); if (p != pp) set_output_port(p); odisp = Displaying; Displaying = disp; print_form(x); Displaying = odisp; if (p != pp) set_output_port(pp); } void writechar(int c, cell p) { int pp; pp = output_port(); if (p != pp) set_output_port(p); writec(c); if (p != pp) set_output_port(pp); } #define whitespc(c) \ (' ' == (c) || \ '\t' == (c) || \ '\n' == (c) || \ '\r' == (c) || \ '\f' == (c)) void dump_image_file(cell s) { char *rc; rc = dump_image(string(s), S9magic); if (rc != NULL) { remove(string(s)); error(rc, s); } setbind(S_image_file, s); } void begin_rec(void); void end_rec(void); void loadfile(char *s) { int ldport, rdport; cell x, ld; cell oline; ldport = open_input_port(s); if (ldport < 0) error("load: cannot open file", make_string(s, strlen(s))); lock_port(ldport); rdport = input_port(); ld = getbind(S_loading); setbind(S_loading, TRUE); oline = Line_no; Line_no = 1; save(make_string(Srcfile, strlen(Srcfile))); strncpy(Srcfile, s, TOKEN_LENGTH); Srcfile[TOKEN_LENGTH] = 0; begin_rec(); for (;;) { set_input_port(ldport); x = xread(); set_input_port(rdport); if (END_OF_FILE == x) break; eval(x, 0); } end_rec(); strcpy(Srcfile, string(unsave(1))); Line_no = oline; setbind(S_loading, ld); close_port(ldport); } void load(cell x) { char path[TOKEN_LENGTH+1]; if (!string_p(x)) expect("load", "string", x); if (string_len(x) > TOKEN_LENGTH) error("load: path too long", x); strcpy(path, string(x)); loadfile(path); } cell stats(cell x) { counter *ncs, *ccs, *vcs, *gcs; cell n; gcv(); Stats = 1; x = eval(x, 1); Stats = 0; save(x); get_counters(&ncs, &ccs, &vcs, &gcs); n = cons(read_counter(gcs), NIL); n = cons(read_counter(vcs), n); n = cons(read_counter(ccs), n); n = cons(read_counter(ncs), n); n = cons(x, n); unsave(1); return n; } cell getenvvar(char *s) { char *p; p = getenv(s); if (NULL == p) return FALSE; return make_string(p, strlen(p)); } cell cvt_bytecode(cell x) { cell b, *v; int i, k; k = vector_len(x); b = subvector(x, 0, k); v = vector(b); for (i=0; i<k; i++) { if (fix_p(v[i])) car(v[i]) = T_INTEGER; } return b; } /* Main interpreter loop */ void reset_tty(void); void run(cell x) { Prog = x; if (setjmp(Error_tag) != 0) { Ip = throw(Error_handler, getbind(S_error_value)); if (Ip < 0) longjmp(Restart, 1); } for (Running = 1; Running;) switch (ins()) { case OP_APPLIS: Ip = applis(0); break; case OP_TAIL_APPLIS: Ip = applis(1); break; case OP_TAIL_APPLY: Ip = apply(1); break; case OP_APPLY: Ip = apply(0); break; case OP_QUOTE: Acc = op1(); skip(2); break; case OP_ARG: Acc = argref(op1()); skip(2); break; case OP_REF: Acc = boxref(envbox(op1())); if (UNDEFINED == Acc) error("undefined symbol", op2()); if (Tp >= MAX_REF_TRACE) Tp = 0; Trace[Tp++] = op2(); skip(3); break; case OP_POP: Acc = stackref(Sp); Sp--; skip(1); break; case OP_PUSH: push(cons(Acc, NIL)); skip(1); break; case OP_PUSH_VAL: push(op1()); skip(2); break; case OP_JMP: Ip = fixval(op1()); break; case OP_JMP_FALSE: if (FALSE == Acc) Ip = fixval(op1()); else skip(2); break; case OP_JMP_TRUE: if (FALSE == Acc) skip(2); else Ip = fixval(op1()); break; case OP_HALT: return; case OP_MAKE_ENV: Acc = make_vector(fixval(op1())); skip(2); break; case OP_PROP_ENV: Acc = Ep; skip(1); break; case OP_COPY_ARG: vector(Acc)[fixval(op2())] = argbox(op1()); skip(3); break; case OP_COPY_REF: vector(Acc)[fixval(op2())] = envbox(op1()); skip(3); break; case OP_CLOSURE: Acc = closure(op1(), Acc); skip(2); break; case OP_ENTER: if (fixval(stackref(Sp-2)) != fixval(op1())) error("wrong number of arguments", UNDEFINED); push(mkfix(Fp)); Fp = Sp-4; skip(2); break; case OP_ENTER_COLL: entcol(fixval(op1())); skip(2); break; case OP_RETURN: Ip = ret(); break; case OP_SET_ARG: boxset(argbox(op1()), Acc); Acc = UNSPECIFIC; skip(2); break; case OP_SET_REF: boxset(envbox(op1()), Acc); Acc = UNSPECIFIC; skip(2); break; case OP_DEF_MACRO: newmacro(op1(), Acc); Acc = UNSPECIFIC; skip(2); break; case OP_COMMAND_LINE: Acc = Argv; skip(1); break; case OP_CURRENT_ERROR_PORT: Acc = make_port(error_port(), T_OUTPUT_PORT); skip(1); break; case OP_CURRENT_INPUT_PORT: Acc = make_port(input_port(), T_INPUT_PORT); skip(1); break; case OP_CURRENT_OUTPUT_PORT: Acc = make_port(output_port(), T_OUTPUT_PORT); skip(1); break; case OP_GENSYM: Acc = gensym(); skip(1); break; case OP_QUIT: reset_tty(); bye(0); skip(1); break; case OP_SYMBOLS: Acc = carof(Glob); skip(1); break; case OP_ABS: if (!number_p(Acc)) expect("abs", "number", Acc); Acc = real_abs(Acc); skip(1); break; case OP_BOOLEAN_P: Acc = (TRUE == Acc || FALSE == Acc)? TRUE: FALSE; skip(1); break; case OP_CHAR_ALPHABETIC_P: if (!char_p(Acc)) expect("char-alphabetic?", "char", Acc); Acc = isalpha(char_value(Acc))? TRUE: FALSE; skip(1); break; case OP_CAR: if (!pair_p(Acc)) expect("car", "pair", Acc); Acc = car(Acc); skip(1); break; case OP_CATCH: push(box(catch())); push(mkfix(1)); skip(1); break; case OP_CATCH_TAG_P: Acc = catch_tag_p(Acc)? TRUE: FALSE; skip(1); break; case OP_CDR: if (!pair_p(Acc)) expect("cdr", "pair", Acc); Acc = cdr(Acc); skip(1); break; case OP_CAAR: if (!pair_p(Acc) || !pair_p(car(Acc))) expect("caar", "nested pair", Acc); Acc = caar(Acc); skip(1); break; case OP_CADR: if (!pair_p(Acc) || !pair_p(cdr(Acc))) expect("cadr", "nested pair", Acc); Acc = cadr(Acc); skip(1); break; case OP_CDAR: if (!pair_p(Acc) || !pair_p(car(Acc))) expect("cdar", "nested pair", Acc); Acc = cdar(Acc); skip(1); break; case OP_CDDR: if (!pair_p(Acc) || !pair_p(cdr(Acc))) expect("cddr", "nested pair", Acc); Acc = cddr(Acc); skip(1); break; case OP_CAAAR: Acc = cxr("aaa", Acc); skip(1); break; case OP_CAADR: Acc = cxr("daa", Acc); skip(1); break; case OP_CADAR: Acc = cxr("ada", Acc); skip(1); break; case OP_CADDR: Acc = cxr("dda", Acc); skip(1); break; case OP_CDAAR: Acc = cxr("aad", Acc); skip(1); break; case OP_CDADR: Acc = cxr("dad", Acc); skip(1); break; case OP_CDDAR: Acc = cxr("add", Acc); skip(1); break; case OP_CDDDR: Acc = cxr("ddd", Acc); skip(1); break; case OP_CAAAAR: Acc = cxr("aaaa", Acc); skip(1); break; case OP_CAAADR: Acc = cxr("daaa", Acc); skip(1); break; case OP_CAADAR: Acc = cxr("adaa", Acc); skip(1); break; case OP_CAADDR: Acc = cxr("ddaa", Acc); skip(1); break; case OP_CADAAR: Acc = cxr("aada", Acc); skip(1); break; case OP_CADADR: Acc = cxr("dada", Acc); skip(1); break; case OP_CADDAR: Acc = cxr("adda", Acc); skip(1); break; case OP_CADDDR: Acc = cxr("ddda", Acc); skip(1); break; case OP_CDAAAR: Acc = cxr("aaad", Acc); skip(1); break; case OP_CDAADR: Acc = cxr("daad", Acc); skip(1); break; case OP_CDADAR: Acc = cxr("adad", Acc); skip(1); break; case OP_CDADDR: Acc = cxr("ddad", Acc); skip(1); break; case OP_CDDAAR: Acc = cxr("aadd", Acc); skip(1); break; case OP_CDDADR: Acc = cxr("dadd", Acc); skip(1); break; case OP_CDDDAR: Acc = cxr("addd", Acc); skip(1); break; case OP_CDDDDR: Acc = cxr("dddd", Acc); skip(1); break; case OP_CALL_CC: push(box(capture_cont())); push(mkfix(1)); skip(1); break; case OP_ERROR: if (!string_p(Acc)) expect("error", "string", Acc); error(string(Acc), UNDEFINED); skip(1); break; case OP_ERROR2: if (!string_p(Acc)) expect("error", "string", Acc); error(string(Acc), arg(0)); clear(1); skip(1); break; case OP_CEILING: if (!number_p(Acc)) expect("ceiling", "number", Acc); Acc = real_ceil(Acc); skip(1); break; case OP_INTEGER_TO_CHAR: Acc = integer_value("integer->char", Acc); if (Acc < 0 || Acc > 126) error("integer->char: value out of range", Acc); Acc = make_char(Acc); skip(1); break; case OP_CHAR_P: Acc = char_p(Acc)? TRUE: FALSE; skip(1); break; case OP_CHAR_TO_INTEGER: if (!char_p(Acc)) expect("char->integer", "char", Acc); Acc = make_integer(char_value(Acc)); skip(1); break; case OP_CLOSE_INPUT_PORT: if (!input_port_p(Acc)) expect("close-input-port", "input port", Acc); close_port(port_no(Acc)); Acc = UNSPECIFIC; skip(1); break; case OP_CLOSE_OUTPUT_PORT: if (!output_port_p(Acc)) expect("close-output-port", "output port", Acc); close_port(port_no(Acc)); Acc = UNSPECIFIC; skip(1); break; case OP_DELETE_FILE: if (!string_p(Acc)) expect("delete-file", "string", Acc); if (remove(string(Acc)) < 0) error("delete-file: cannot delete", Acc); Acc = UNSPECIFIC; skip(1); break; case OP_CHAR_DOWNCASE: if (!char_p(Acc)) expect("char-downcase", "char", Acc); Acc = make_char(tolower(char_value(Acc))); skip(1); break; case OP_DUMP_IMAGE: if (!string_p(Acc)) expect("dump-image", "string", Acc); dump_image_file(Acc); Acc = UNSPECIFIC; skip(1); break; case OP_ENVIRONMENT_VARIABLE: if (!string_p(Acc)) expect("environment-variable", "string", Acc); Acc = getenvvar(string(Acc)); skip(1); break; case OP_EOF_OBJECT_P: Acc = (END_OF_FILE == Acc? TRUE: FALSE); skip(1); break; case OP_EVAL: Acc = eval(Acc, 1); skip(1); break; case OP_EVEN_P: Acc = integer_argument("even?", Acc); Acc = bignum_even_p(Acc)? TRUE: FALSE; skip(1); break; case OP_EXACT_TO_INEXACT: if (!number_p(Acc)) expect("exact->inexact", "number", Acc); Acc = exact_to_inexact(Acc); skip(1); break; case OP_EXACT_P: if (!number_p(Acc)) expect("exact?", "number", Acc); Acc = integer_p(Acc)? TRUE: FALSE; skip(1); break; case OP_EXPONENT: if (!number_p(Acc)) expect("exponent", "number", Acc); Acc = make_integer(real_exponent(Acc)); skip(1); break; case OP_FLOOR: if (!number_p(Acc)) expect("floor", "number", Acc); Acc = real_floor(Acc); skip(1); break; case OP_FILE_EXISTS_P: if (!string_p(Acc)) expect("file-exists?", "string", Acc); Acc = exists_p(string(Acc)); skip(1); break; case OP_FIX_EXACTNESS: if (TRUE == vector(Rts)[Sp--]) Acc = exact_to_inexact(Acc); skip(1); break; case OP_INEXACT_TO_EXACT: if (!number_p(Acc)) expect("inexact->exact", "number", Acc); Acc = inexact_to_exact(Acc); skip(1); break; case OP_INEXACT_P: if (!number_p(Acc)) expect("inexact?", "number", Acc); Acc = real_p(Acc)? TRUE: FALSE; skip(1); break; case OP_INTEGER_P: Acc = real_integer_p(Acc)? TRUE: FALSE; skip(1); break; case OP_MACRO_EXPAND: case OP_MACRO_EXPAND_1: Acc = expand(Acc, OP_MACRO_EXPAND == ins()); skip(1); break; case OP_MANTISSA: if (!number_p(Acc)) expect("exponent", "number", Acc); Acc = real_mantissa(Acc); skip(1); break; case OP_LOAD: load(Acc); Acc = UNSPECIFIC; skip(1); break; case OP_PROCEDURE_P: Acc = function_p(Acc) || continuation_p(Acc) || primitive_p(Acc)? TRUE: FALSE; skip(1); break; case OP_INPUT_PORT_P: Acc = input_port_p(Acc)? TRUE: FALSE; skip(1); break; case OP_LIST_TO_STRING: if (!list_p(Acc)) expect("list->string", "list", Acc); Acc = list_to_string(Acc); skip(1); break; case OP_LIST_TO_VECTOR: if (!list_p(Acc)) expect("list->vector", "list", Acc); Acc = list_to_vector(Acc, "list->vector: improper list", 0); skip(1); break; case OP_CHAR_LOWER_CASE_P: if (!char_p(Acc)) expect("char-lower-case?", "char", Acc); Acc = islower(char_value(Acc))? TRUE: FALSE; skip(1); break; case OP_NEGATE: if (!number_p(Acc)) expect("-", "number", Acc); Acc = real_negate(Acc); skip(1); break; case OP_LENGTH: if (!list_p(Acc)) expect("length", "list", Acc); Acc = list_length(Acc); skip(1); break; case OP_NOT: Acc = (FALSE == Acc? TRUE: FALSE); skip(1); break; case OP_NULL_P: Acc = (NIL == Acc? TRUE: FALSE); skip(1); break; case OP_CHAR_NUMERIC_P: if (!char_p(Acc)) expect("char-numeric?", "char", Acc); Acc = isdigit(char_value(Acc))? TRUE: FALSE; skip(1); break; case OP_NEGATIVE_P: if (!number_p(Acc)) expect("negative?", "number", Acc); Acc = real_negative_p(Acc)? TRUE: FALSE; skip(1); break; case OP_ODD_P: Acc = integer_argument("odd?", Acc); Acc = bignum_even_p(Acc)? FALSE: TRUE; skip(1); break; case OP_OPEN_APPEND_FILE: if (!string_p(Acc)) expect("open-append-file", "string", Acc); Acc = openfile(Acc, 2); skip(1); break; case OP_OPEN_INPUT_FILE: if (!string_p(Acc)) expect("open-input-file", "string", Acc); Acc = openfile(Acc, 0); skip(1); break; case OP_OPEN_OUTPUT_FILE: if (!string_p(Acc)) expect("open-output-file", "string", Acc); Acc = openfile(Acc, 1); skip(1); break; case OP_OUTPUT_PORT_P: Acc = output_port_p(Acc)? TRUE: FALSE; skip(1); break; case OP_PAIR_P: Acc = pair_p(Acc)? TRUE: FALSE; skip(1); break; case OP_POSITIVE_P: if (!number_p(Acc)) expect("positive?", "number", Acc); Acc = real_positive_p(Acc)? TRUE: FALSE; skip(1); break; case OP_PEEK_CHAR: if (!input_port_p(Acc)) expect("peek-char", "input port", Acc); Acc = readchar(port_no(Acc), 1); skip(1); break; case OP_READ: if (!input_port_p(Acc)) expect("read", "input port", Acc); Acc = read_obj(port_no(Acc)); skip(1); break; case OP_READ_CHAR: if (!input_port_p(Acc)) expect("read-char", "input port", Acc); Acc = readchar(port_no(Acc), 0); skip(1); break; case OP_REAL_P: Acc = number_p(Acc)? TRUE: FALSE; skip(1); break; case OP_REVERSE: if (!list_p(Acc)) expect("reverse", "list", Acc); Acc = reverse(Acc); skip(1); break; case OP_REVERSE_B: if (!list_p(Acc)) expect("reverse!", "list", Acc); if (constant_p(Acc)) error("reverse!: immutable", Acc); Acc = nreverse(Acc); skip(1); break; case OP_S9_BYTECODE: if (!function_p(Acc)) expect("s9:bytecode", "procedure", Acc); Acc = cvt_bytecode(closure_prog(Acc)); skip(1); break; case OP_STATS: Acc = stats(Acc); skip(1); break; case OP_SYSTEM_COMMAND: if (!string_p(Acc)) expect("system-command", "string", Acc); Acc = make_integer(system(string(Acc)) >> 8); skip(1); break; case OP_TRUNCATE: if (!number_p(Acc)) expect("truncate", "number", Acc); Acc = real_trunc(Acc); skip(1); break; case OP_ZERO_P: if (!number_p(Acc)) expect("zero?", "number", Acc); Acc = real_zero_p(Acc)? TRUE: FALSE; skip(1); break; case OP_APPEND: if (!list_p(Acc)) expect("append", "list", Acc); Acc = append(Acc, arg(0)); clear(1); skip(1); break; case OP_STRING_APPEND: Acc = sconc(Acc); skip(1); break; case OP_VECTOR_APPEND: Acc = vconc(Acc); skip(1); break; case OP_SET_INPUT_PORT_B: if (!input_port_p(Acc)) expect("set-input-port!", "input port", Acc); set_input_port(port_no(Acc)); Acc = UNSPECIFIC; skip(1); break; case OP_SET_OUTPUT_PORT_B: if (!output_port_p(Acc)) expect("set-output-port!", "output port", Acc); set_output_port(port_no(Acc)); Acc = UNSPECIFIC; skip(1); break; case OP_STRING_COPY: if (!string_p(Acc)) expect("string-copy", "string", Acc); Acc = copy_string(Acc); skip(1); break; case OP_STRING_LENGTH: if (!string_p(Acc)) expect("string-length", "string", Acc); Acc = make_integer(string_len(Acc)-1); skip(1); break; case OP_SYMBOL_P: Acc = symbol_p(Acc)? TRUE: FALSE; skip(1); break; case OP_STRING_TO_SYMBOL: if (!string_p(Acc)) expect("string->symbol", "string", Acc); Acc = string_to_symbol(Acc); skip(1); break; case OP_SYMBOL_TO_STRING: if (!symbol_p(Acc)) expect("symbol->string", "symbol", Acc); Acc = symbol_to_string(Acc); skip(1); break; case OP_STRING_P: Acc = string_p(Acc)? TRUE: FALSE; skip(1); break; case OP_STRING_TO_LIST: if (!string_p(Acc)) expect("string->list", "string", Acc); Acc = string_to_list(Acc); skip(1); break; case OP_CHAR_UPCASE: if (!char_p(Acc)) expect("char-upcase", "char", Acc); Acc = make_char(toupper(char_value(Acc))); skip(1); break; case OP_CHAR_UPPER_CASE_P: if (!char_p(Acc)) expect("char-upper-case?", "char", Acc); Acc = isupper(char_value(Acc))? TRUE: FALSE; skip(1); break; case OP_VECTOR_TO_LIST: if (!vector_p(Acc)) expect("vector->list", "vector", Acc); Acc = vector_to_list(Acc); skip(1); break; case OP_VECTOR_P: Acc = vector_p(Acc)? TRUE: FALSE; skip(1); break; case OP_VECTOR_LENGTH: if (!vector_p(Acc)) expect("vector-length", "vector", Acc); Acc = make_integer(vector_len(Acc)); skip(1); break; case OP_CHAR_WHITESPACE_P: if (!char_p(Acc)) expect("char-whitespace?", "char", Acc); Acc = whitespc(char_value(Acc))? TRUE: FALSE; skip(1); break; case OP_CHAR_LESS_P: cless(Acc, arg(0)); clear(1); skip(1); break; case OP_CHAR_LTEQ_P: clteq(Acc, arg(0)); clear(1); skip(1); break; case OP_CHAR_EQUAL_P: cequal(Acc, arg(0)); clear(1); skip(1); break; case OP_CHAR_GRTR_P: cgrtr(Acc, arg(0)); clear(1); skip(1); break; case OP_CHAR_GTEQ_P: cgteq(Acc, arg(0)); clear(1); skip(1); break; case OP_CHAR_CI_LESS_P: ciless(Acc, arg(0)); clear(1); skip(1); break; case OP_CHAR_CI_LTEQ_P: cilteq(Acc, arg(0)); clear(1); skip(1); break; case OP_CHAR_CI_EQUAL_P: ciequal(Acc, arg(0)); clear(1); skip(1); break; case OP_CHAR_CI_GRTR_P: cigrtr(Acc, arg(0)); clear(1); skip(1); break; case OP_CHAR_CI_GTEQ_P: cigteq(Acc, arg(0)); clear(1); skip(1); break; case OP_ASSQ: if (!list_p(arg(0))) expect("assq", "alist", arg(0)); Acc = assqv("assq", 0, Acc, arg(0)); clear(1); skip(1); break; case OP_ASSV: if (!list_p(arg(0))) expect("assv", "alist", arg(0)); Acc = assqv("assv", 1, Acc, arg(0)); clear(1); skip(1); break; case OP_CONS: Acc = cons(Acc, arg(0)); clear(1); skip(1); break; case OP_EQV_P: Acc = eqv_p(Acc, arg(0))? TRUE: FALSE; clear(1); skip(1); break; case OP_EQ_P: Acc = (Acc == arg(0))? TRUE: FALSE; clear(1); skip(1); break; case OP_EQUAL: equal(Acc, arg(0)); clear(1); skip(1); break; case OP_GRTR: grtr(Acc, arg(0)); clear(1); skip(1); break; case OP_GTEQ: gteq(Acc, arg(0)); clear(1); skip(1); break; case OP_LESS: less(Acc, arg(0)); clear(1); skip(1); break; case OP_LTEQ: lteq(Acc, arg(0)); clear(1); skip(1); break; case OP_LIST_REF: if (!list_p(Acc)) expect("list-ref", "list", Acc); Acc = nth("list-ref", 1, Acc, arg(0)); clear(1); skip(1); break; case OP_LIST_TAIL: if (!list_p(Acc)) expect("list-tail", "list", Acc); Acc = nth("list-tail", 0, Acc, arg(0)); clear(1); skip(1); break; case OP_MEMQ: if (!list_p(arg(0))) expect("memq", "list", arg(0)); Acc = memqv("memq", 0, Acc, arg(0)); clear(1); skip(1); break; case OP_MEMV: if (!list_p(arg(0))) expect("memv", "list", arg(0)); Acc = memqv("memv", 1, Acc, arg(0)); clear(1); skip(1); break; case OP_THROW: Ip = throw(Acc, arg(0)); break; case OP_MAX: if (real_p(Acc) || real_p(arg(0))) stackset(Sp-1, TRUE); Acc = real_less_p(arg(0), Acc)? Acc: arg(0); clear(1); skip(1); break; case OP_MIN: if (real_p(Acc) || real_p(arg(0))) stackset(Sp-1, TRUE); Acc = real_less_p(Acc, arg(0))? Acc: arg(0); clear(1); skip(1); break; case OP_MINUS: Acc = xsub(Acc, arg(0)); clear(1); skip(1); break; case OP_MAKE_STRING: Acc = makestr(Acc, arg(0)); clear(1); skip(1); break; case OP_MAKE_VECTOR: Acc = makevec(Acc, arg(0)); clear(1); skip(1); break; case OP_PLUS: Acc = add(Acc, arg(0)); clear(1); skip(1); break; case OP_BIT_OP: Acc = bit_op(Acc, arg(0), arg(1)); clear(2); skip(1); break; case OP_WRITE: if (!output_port_p(arg(0))) expect("write", "output port", arg(0)); write_obj(Acc, port_no(arg(0)), 0); Acc = UNSPECIFIC; clear(1); skip(1); break; case OP_DISPLAY: if (!output_port_p(arg(0))) expect("display", "output port", arg(0)); write_obj(Acc, port_no(arg(0)), 1); Acc = UNSPECIFIC; clear(1); skip(1); break; case OP_DIVIDE: Acc = xdiv(Acc, arg(0)); clear(1); skip(1); break; case OP_QUOTIENT: Acc = intdiv(Acc, arg(0)); clear(1); skip(1); break; case OP_REMAINDER: Acc = intrem(Acc, arg(0)); clear(1); skip(1); break; case OP_SET_CAR_B: if (!pair_p(Acc)) expect("set-car!", "pair", Acc); if (constant_p(Acc)) error("set-car!: immutable", Acc); car(Acc) = arg(0); Acc = UNSPECIFIC; clear(1); skip(1); break; case OP_SET_CDR_B: if (!pair_p(Acc)) expect("set-cdr!", "pair", Acc); if (constant_p(Acc)) error("set-cdr!: immutable", Acc); cdr(Acc) = arg(0); Acc = UNSPECIFIC; clear(1); skip(1); break; case OP_STRING_LESS_P: sless(Acc, arg(0)); clear(1); skip(1); break; case OP_STRING_LTEQ_P: slteq(Acc, arg(0)); clear(1); skip(1); break; case OP_STRING_EQUAL_P: sequal(Acc, arg(0)); clear(1); skip(1); break; case OP_STRING_GRTR_P: sgrtr(Acc, arg(0)); clear(1); skip(1); break; case OP_STRING_GTEQ_P: sgteq(Acc, arg(0)); clear(1); skip(1); break; case OP_STRING_CI_LESS_P: siless(Acc, arg(0)); clear(1); skip(1); break; case OP_STRING_CI_LTEQ_P: silteq(Acc, arg(0)); clear(1); skip(1); break; case OP_STRING_CI_EQUAL_P: siequal(Acc, arg(0)); clear(1); skip(1); break; case OP_STRING_CI_GRTR_P: sigrtr(Acc, arg(0)); clear(1); skip(1); break; case OP_STRING_CI_GTEQ_P: sigteq(Acc, arg(0)); clear(1); skip(1); break; case OP_STRING_FILL_B: sfill(Acc, arg(0)); Acc = UNSPECIFIC; clear(1); skip(1); break; case OP_STRING_REF: Acc = sref(Acc, arg(0)); clear(1); skip(1); break; case OP_STRING_SET_B: sset(Acc, arg(0), arg(1)); Acc = UNSPECIFIC; clear(2); skip(1); break; case OP_SUBSTRING: Acc = substring(Acc, arg(0), arg(1)); clear(2); skip(1); break; case OP_TIMES: Acc = mul(Acc, arg(0)); clear(1); skip(1); break; case OP_VECTOR_FILL_B: vfill(Acc, arg(0)); Acc = UNSPECIFIC; clear(1); skip(1); break; case OP_VECTOR_REF: Acc = vref(Acc, arg(0)); clear(1); skip(1); break; case OP_VECTOR_SET_B: vset(Acc, arg(0), arg(1)); Acc = UNSPECIFIC; clear(2); skip(1); break; case OP_WRITE_CHAR: if (!char_p(Acc)) expect("write-char", "char", Acc); if (!output_port_p(arg(0))) expect("write-char", "output port", arg(0)); writechar(char_value(Acc), port_no(arg(0))); Acc = UNSPECIFIC; clear(1); skip(1); break; case OP_VECTOR_COPY: if (!vector_p(Acc)) expect("vector-copy", "vector", Acc); Acc = vcopy(Acc, arg(0), arg(1), arg(2)); clear(3); skip(1); break; default: error("illegal instruction", make_integer(ins())); return; } error("interrupted", UNDEFINED); } /* * Evaluator */ cell interpret(cell x) { cell n, *v; int i; Ip = 0; E0 = make_vector(length(Glob)); i = 0; v = vector(E0); for (n = Glob; n != NIL; n = cdr(n)) { v[i] = cdar(n); i++; } Ep = E0; if (Stats) { run_stats(1); cons_stats(1); } run(x); if (Stats) { cons_stats(0); run_stats(0); } v = vector(E0); i = 0; for (n = Glob; n != NIL; n = cdr(n)) { cdar(n) = v[i]; i++; } return Acc; } void begin_rec(void) { save(Prog); save(Ep); save(mkfix(Ip)); save(mkfix(Sp)); save(mkfix(Fp)); } void end_rec(void) { Fp = fixval(unsave(1)); Sp = fixval(unsave(1)); Ip = fixval(unsave(1)); Ep = unsave(1); Prog = unsave(1); } cell eval(cell x, int r) { Tmp = x; if (r) begin_rec(); save(x); Tmp = NIL; x = expand(x, 1); car(Stack) = x; syncheck(x, 1); x = clsconv(x); car(Stack) = x; x = compile(x); car(Stack) = x; x = interpret(x); unsave(1); if (r) end_rec(); return x; } /* * REPL */ #ifdef unix void keyboard_interrupt(int sig) { reset_std_ports(); s9_abort(); Running = 0; Expand_level = -1; Intr = 1; } void keyboard_quit(int sig) { fatal("received QUIT signal, exiting"); } #endif /* unix */ #ifdef plan9 void keyboard_interrupt(void *dummy, char *note) { if (strstr(note, "interrupt") == NULL) noted(NDFLT); reset_std_ports(); s9_abort(); Running = 0; Expand_level = -1; Intr = 1; noted(NCONT); } #endif /* plan9 */ void mem_error(int src) { if (1 == src) error("node limit reached", UNDEFINED); else error("vector limit reached", UNDEFINED); } void reset_tty(void) { #ifdef CURSES_RESET cell pp_curs_endwin(cell x); pp_curs_endwin(NIL); #endif } void repl(void) { cell x; setjmp(Restart); if (!O_quiet) handle_sigint(); handle_sigquit(); mem_error_handler(mem_error); for (;;) { Running = 0; Expand_level = 0; reset_tty(); s9_reset(); reset_std_ports(); clear_trace(); Stack = NIL; init_rts(); if (!O_quiet) { prints("> "); flush(); } Intr = 0; x = xread(); if (END_OF_FILE == x && 0 == Intr) break; x = eval(x, 1); if (x != UNSPECIFIC) { setbind(S_starstar, x); print_form(x); nl(); } } if (!O_quiet) nl(); } /* * Command line interface */ void evalstr(char *s, int echo) { cell x; clear_trace(); x = xsread(s); if (UNDEFINED == x) return; x = eval(x, 1); if (echo) { print_form(x); nl(); } } void usage(void) { prints( "Usage: s9 [-i file | -] [-hv?] [-gqu] [-e expr] [-d file]\n" " [-k cells] [-l file] [-n nodes] [-r expr]\n" " [-- argument ... | [-f] file argument ...]\n"); } void longusage(void) { char b[100]; cell x; nl(); prints("Scheme 9 from Empty Space by Nils M Holm, "); prints(RELEASE_DATE); if (PATCHLEVEL) { prints(" p"); writec(PATCHLEVEL+'0'); } nl(); prints("This program is in the public domain"); nl(); x = getbind(S_extensions); if (pair_p(x)) { prints("Extensions:"); for (; x != NIL; x = cdr(x)) { writec(' '); print_form(car(x)); } nl(); } nl(); usage(); prints( "\n" "-h help (also -v, -?)\n" "-d file dump image to file, then exit\n" "-g print garbage collector messages (-gg = more)\n" "-e expr evaluate expression, print value, no REPL\n" "-i file load image from file (default: "); prints(IMAGE_FILE); prints(")\n"); prints( "-i - compile initial image from sources (s9.scm)\n" "-k n[m] set vector limit to nK (or nM) cells ("); prints(ntoa(b, S9_VECTOR_LIMIT, 0)); prints( "K)\n" "-l file load program from file\n" "-n n[m] set node limit to nK (or nM) nodes ("); prints(ntoa(b, S9_NODE_LIMIT, 0)); prints( "K)\n" "-q quiet: no banner, no prompt, exit on errors\n" "-r expr like -e, but don't print value (run for effect)\n" "-u use unlimited node and vector memory\n" "file args run program file with arguments, then exit\n" "-- args bind remaining arguments to (command-line)\n" "\n"); bye(0); } long get_size_k(char *s) { int c; long n; c = s[strlen(s)-1]; n = asctol(s); if ('M' == c || 'm' == c) return n * 1024L; else if (!isdigit(c)) { usage(); bye(1); } return n; } char *cmdarg(char *s) { if (NULL == s) { usage(); bye(1); } return s; } int main(int argc, char **argv) { int i, j, k, g, t, loop; char *s, *dump; cell libs, exprs, n; if (setjmp(Restart) != 0) bye(1); init(); i = 1; if (argc > 2 && strcmp(argv[1], "-i") == 0) { load_initial_image(argv[2]); i = 3; } else { load_initial_image(IMAGE_FILE); } setbind(S_library_path, make_library_path()); save(libs = NIL); save(exprs = NIL); dump = NULL; loop = 1; g = 0; for (; i<argc; i++) { if (argv[i][0] != '-') break; if ('-' == argv[i][1]) break; if ('f' == argv[i][1]) { i++; break; } k = strlen(argv[i]); for (j=1; j<k; j++) { switch (argv[i][j]) { case '?': case 'h': case 'v': longusage(); break; case 'd': i++; dump = cmdarg(argv[i]); j = strlen(argv[i]); break; case 'r': case 'e': loop = 0; t = 'e' == argv[i][j]; i++; s = cmdarg(argv[i]); n = cons(t? TRUE: FALSE, make_string(s, strlen(s))); exprs = cons(n, exprs); car(Stack) = exprs; j = strlen(argv[i]); break; case 'g': g++; break; case 'k': i++; s = cmdarg(argv[i]); set_vector_limit(get_size_k(s)); j = strlen(argv[i]); break; case 'l': i++; s = cmdarg(argv[i]); libs = cons(make_string(s, strlen(s)), libs); cadr(Stack) = libs; j = strlen(argv[i]); break; case 'n': i++; s = cmdarg(argv[i]); set_node_limit(get_size_k(s)); j = strlen(argv[i]); break; case 'q': O_quiet = 1; Report_to_stderr = 1; break; case 'u': set_node_limit(0); set_vector_limit(0); break; default: usage(); bye(1); } } } gc_verbosity(g); init_extensions(); if (libs != NIL) { if (setjmp(Restart) != 0) bye(1); libs = nreverse(libs); cadr(Stack) = libs; while (libs != NIL) { loadfile(string(car(libs))); libs = cdr(libs); } } if (exprs != NIL) { if (setjmp(Restart) != 0) bye(1); exprs = nreverse(exprs); car(Stack) = exprs; while (exprs != NIL) { evalstr(string(cdar(exprs)), TRUE == caar(exprs)); exprs = cdr(exprs); } } unsave(2); Argv = NULL == argv[i]? NIL: argv_to_list(&argv[i+1]); setbind(S_arguments, Argv); if (dump != NULL) { dump_image(dump, S9magic); bye(0); } if (argv[i] != NULL && strcmp(argv[i], "--")) { if (setjmp(Restart) != 0) bye(1); loadfile(argv[i]); bye(0); } if (loop) { if (!O_quiet) { prints("Scheme 9 from Empty Space (Reimagined)"); nl(); } repl(); } bye(0); return 0; }