/************** * Gales Scheme * * A Scheme interpreter for Unix striving for simplicity, soundness, minimal * artificial restrictions, and R5RS compliance with strict error checking. * * J. Welsh * January 2017 - April 2018 */ #include #include #include #include #include #include #include #include #include #include #include #include #ifndef MAP_ANON #define MAP_ANON MAP_ANONYMOUS #endif int snprintf(char *, size_t, const char *, ...); /* to be replaced */ void abort(void); size_t strlen(const char *); char *strerror(int); void *memcpy(void *, const void *, size_t); void *memset(void *, int, size_t); int memcmp(const void *, const void *, size_t); pid_t vfork(void); #include "gscm.h" /****************** * Memory structure */ /* The Scheme heap is an array of N-bit cells where N is the size of a machine * address. */ typedef size_t value; typedef value (*builtin_func_t)(value args); typedef unsigned char uchar; typedef unsigned long ulong; typedef unsigned int uint; /* Principal type tag: three most significant bits of cell */ #define TAG_BITS 3 #define T_SPECIAL 0 /* Special values listed below */ #define T_MOVED 1 /* "Broken heart" pointer to GC moved object */ #define T_IMMUT_PAIR 2 /* Pointer to car with cdr following */ #define T_PAIR 3 #define T_CHARACTER 4 /* Character in least significant byte */ #define T_FIXNUM 5 /* N-3 bit two's complement signed integer */ #define T_EXTENDED 6 /* Pointer to extended object */ #define T_EXT_HEADER 7 /* Extended type header */ /* Special values indicated by T_SPECIAL. Since that's zero, these can be * compared with values directly. */ #define SC_NULL 0 #define SC_TRUE 1 #define SC_FALSE 2 #define SC_EOF 3 #define SC_NULL_ENV 4 #define SC_REPORT_ENV 5 #define SC_GSCM_ENV 6 #define SC_INTERACT_ENV 7 #define SC_TOPLEVEL_ENV 8 /* Inaccessible from Scheme */ #define UNDEFINED 9 #define RD_CLOSEPAREN 10 /* Returned internally by reader subroutines */ #define RD_DOT 11 /* T_SPECIAL is also implicitly (ab)used for return addresses (EV_*, RD_* and * so on) and loop counters on the stack. GC doesn't have to know what they * really are as long as it treats them as immediate values. */ /* Extended objects consist of a header cell (T_EXT_HEADER) containing extended * type information followed by possibly untagged data cells, depending on * type. The four bits following the principal tag in the header are the * extended type tag: */ #define T_IMMUT_STRING 0x0 #define T_STRING 0x1 #define T_IMMUT_VECTOR 0x2 #define T_VECTOR 0x3 #define T_VARIABLE_REF 0x4 #define T_SYMBOL 0x5 #define T_BUILTIN 0x6 #define T_PROCEDURE 0x7 #define T_CONTINUATION 0x8 #define T_PROMISE 0x9 #define T_PORT 0xA #define T_FLONUM 0xB /* is_number assumes all numbers from here */ #define T_BIGNUM 0xC #define T_NEG_BIGNUM 0xD #define T_RATIONAL 0xE #define T_COMPLEX 0xF /* Tags for types with immutable variants, both principal and extended, must * be equal to the bitwise OR of 1 with the immutable variant. That is, the * least significant tag bit is the mutability flag, where applicable. */ /* Symbols, strings, vectors, and bignums store their length in the header as * an N-7 bit unsigned integer. For vectors and bignums, that many cells * follow. Strings and symbols are packed, so ceil(length/(N/8)) cells follow. * Lexical variable references store the argument index in this space. * * Example for 32-bit systems: * - Pointers/fixnums have 29 bits * - Max heap size is 2^29 = 512M cells of 4 bytes = 2 GiB (4 during GC) * - Longest string is 2^25 characters = 32 MiB * - Longest vector is 2^25 cells = 128 MiB (not counting any pointer targets) * - Longest bignum is 2^25 cells = 2^30 bits for a magnitute ~ 10^10^8 * * If the size limits are a problem, the length could be stored in an untagged * or fixnum cell after the header. */ #if __SIZEOF_POINTER__ == 8 #define VAL_BITS 61 #define EXT_VAL_BITS 57 #define FIXNUM_MAX 0x0FFFFFFFFFFFFFFF #define FIXNUM_MIN -0x1000000000000000 #define EXT_LENGTH_MAX 0x01FFFFFFFFFFFFFF #define packed_str_len(bytes) (((bytes) + 7) >> 3) #define FLONUM_CELLS 1 #elif __SIZEOF_POINTER__ == 4 #define VAL_BITS 29 #define EXT_VAL_BITS 25 #define FIXNUM_MAX 0x0FFFFFFF #define FIXNUM_MIN -0x10000000 #define EXT_LENGTH_MAX 0x01FFFFFF #define packed_str_len(bytes) (((bytes) + 3) >> 2) #define FLONUM_CELLS 2 #else #error Unsupported pointer size #endif #define tag(v) (((value)(v)) >> VAL_BITS) #define add_tag(v, t) ((v) | (((value)(t)) << VAL_BITS)) #define untag(v) ((((value)(v)) << 3) >> 3) #define untag_signed(v) (((long) (((value)(v)) << 3)) >> 3) #define ext_tag(v) (((v) >> EXT_VAL_BITS) & 0xF) #define ext_add_tag(v, t) ((v) | ((value)(t) << EXT_VAL_BITS) | \ (((value)T_EXT_HEADER) << VAL_BITS)) #define ext_untag(v) ((((value)(v)) << 7) >> 7) #define ext_untag_signed(v) (((long) (((value)(v)) << 7)) >> 7) /* WARNING: add_tag/ext_add_tag assume v's tag bits are zero */ static value car(value); static value cdr(value); /****************** * Scheme registers */ /* General purpose */ static value r0, r1, r2, r3, r4, r5, r6; /* Special purpose */ static value r_stack, r_spool, r_error_cont, r_signal_handler, r_compiler, r_compiler_expr, r_input_port, r_output_port, r_dump; static enum { f_none, f_compile, f_apply, f_force, f_call_with_values, f_values, } r_flag; /* Register aliases to make usage more readable. Some rules for validation: * - A subroutine may use a single register under different aliases, but before * it is read or used as an argument under one alias, it must have been: * - Assigned or declared as a parameter under the same alias, and * - Not meanwhile assigned under a different alias. * - Parameter registers must be distinct. */ #define R_EXPR r0 /* expression being evaluated */ #define R_ARGS r0 /* arguments to apply procedure to */ #define R_ENV r1 /* evaluation environment */ #define R_PROC r1 /* procedure to apply */ #define R_PORT r1 /* argument to I/O routines */ #define R_ARG r1 #define R_RESULT r2 /* subroutine return value */ #define R_LEXEME r2 #define R_FORMALS r2 #define R_WIND_TO r2 #define R_VARNAME r3 #define R_TAIL r3 /* last pair of a list being built */ #define R_LCA r3 #define R_OPERANDS r4 #define R_SECOND_LAST r4 #define R_CAR r5 /* argument to cons or push */ #define R_CDR r6 /* argument to cons */ #define R_ITER r6 /***************** * Syscall helpers */ static int open_cloexec(const char *path, int flags) { return open(path, flags | O_CLOEXEC, 0666); /* Non-atomic version for systems lacking O_CLOEXEC int fd = open(path, flags, 0666); if (fd != -1) fcntl(fd, F_SETFD, FD_CLOEXEC); return fd; */ } static int pipe_cloexec(int pipefd[2]) { return pipe2(pipefd, O_CLOEXEC); /* Non-atomic version for systems lacking pipe2 if (pipe(pipefd) == -1) return -1; fcntl(pipefd[0], F_SETFD, FD_CLOEXEC); fcntl(pipefd[1], F_SETFD, FD_CLOEXEC); return 0; */ } /* Reliably catching close errors is NOT POSSIBLE on Linux and others. The call * may block and be interrupted by a signal handler, yet cannot be retried as * the FD is deallocated early. HPUX at least has the atypical behavior of * leaving the FD open, so it would leak. Should figure out where exactly close * can block. */ static void blind_close(int fd) { int saved_errno = errno; close(fd); errno = saved_errno; } static int poll1(int fd, short events, int timeout) { int r; struct pollfd sp; sp.fd = fd; sp.events = events; while ((r = poll(&sp, 1, timeout)) == -1) if (errno != EAGAIN && errno != EINTR) sc_perror(); return r; } static int write_all(int fd, const char *buf, ssize_t len) { ssize_t n; while ((n = write(fd, buf, len)) < len) { if (n != -1) len -= n, buf += n; else if (errno == EAGAIN || errno == EWOULDBLOCK) poll1(fd, POLLOUT, -1); else if (errno != EINTR) return -1; } return 0; } void sc_write_error(const char *msg) { size_t len = strlen(msg); if (len) write_all(2, msg, len); } #define write_err sc_write_error static void flush_all(void); __attribute__((noreturn)) void sc_exit(int status) { flush_all(); _exit(status); } /**************** * Error handling */ /* Failsafe error handler */ __attribute__((noreturn)) static void fatal(const char *msg) { write_err("FATAL: "); write_err(msg); write_err("\n"); sc_exit(1); } __attribute__((noreturn)) static void fatal1(const char *msg, const char *detail) { write_err("FATAL: "); write_err(msg); write_err(": "); write_err(detail); write_err("\n"); sc_exit(1); } __attribute__((noreturn)) void sc_error(const char *msg) { sc_error1(msg, UNDEFINED); } __attribute__((noreturn)) void sc_perror(void) { sc_error(strerror(errno)); } __attribute__((noreturn)) void sc_perror1(value detail) { sc_error1(strerror(errno), detail); } static int chkp(int r) { if (r == -1) sc_perror(); return r; } static const char *fmt_ulong_dec(ulong); __attribute__((noreturn)) void sc_assert_fail(const char *file, ulong line, const char *func, const char *expr) { const char *sep = ": "; static int aborting = 0; if (!aborting) flush_all(); aborting = 1; write_err("Assertion failed: "); write_err(file); write_err(sep); write_err(fmt_ulong_dec(line)); write_err(sep); write_err(func); write_err(sep); write_err(expr); write_err("\n"); abort(); } /* various common errors */ __attribute__((noreturn)) static void not_a_number(value v) { sc_error1("not a number:", v); } /******************************* * Garbage collector & allocator */ /* Heap discipline: * * This garbage collector uses the stop-and-copy (Minsky-Fenichel-Yochelson) * method. Because it relocates values into a new heap and is triggered by * allocation, any function that directly or indirectly calls sc_malloc cannot * keep pointer types (T_PAIR, T_IMMUT_PAIR, T_EXTENDED) in local variables * across such calls, as the addresses may be invalidated. The Scheme stack, * registers, or otherwise statically stored variables registered as roots must * be used instead. * * Such functions will generally be constructors and take their arguments * through the stack or registers. Notably included are push and cons. * Specifically not included are pop, peek, drop, car, cdr, set_car and * set_cdr. * * The reward for this trouble is fast and compacting garbage collection. */ static value *heap, *new_heap; static value heap_size, free_ptr; #define ROOTS_ALLOC 48 static value *roots[ROOTS_ALLOC]; static value roots_fill; static void gc_root(value *handle) { if (roots_fill >= ROOTS_ALLOC) fatal("insufficient ROOTS_ALLOC"); roots[roots_fill] = handle; ++roots_fill; } static value ext_obj_size(value header) { switch (ext_tag(header)) { case T_IMMUT_STRING: case T_STRING: return 1 + packed_str_len(ext_untag(header)); case T_IMMUT_VECTOR: case T_VECTOR: return 1 + ext_untag(header); case T_VARIABLE_REF: return 2; case T_SYMBOL: return 1 + packed_str_len(ext_untag(header)); case T_BUILTIN: return 3; case T_PROCEDURE: return 4; case T_CONTINUATION: return 3; case T_PROMISE: return 3; case T_PORT: return 6; case T_FLONUM: return 1 + FLONUM_CELLS; case T_BIGNUM: case T_NEG_BIGNUM: return 1 + ext_untag(header); case T_RATIONAL: return 3; case T_COMPLEX: return 3; default: fatal("BUG: invalid extended tag"); } } /* Process one cell (in either a root or the new heap), returning number of * cells to advance */ static value scan_cell(value *scan_val) { int scan_tag = tag(*scan_val); value ptr, old_val, length; assert(scan_tag != T_MOVED); switch (scan_tag) { case T_IMMUT_PAIR: case T_PAIR: case T_EXTENDED: ptr = untag(*scan_val); old_val = heap[ptr]; if (tag(old_val) == T_MOVED) *scan_val = add_tag(untag(old_val), scan_tag); else { *scan_val = add_tag(free_ptr, scan_tag); length = (scan_tag == T_EXTENDED) ? ext_obj_size(old_val) : 2; memcpy(&new_heap[free_ptr], &heap[ptr], length*sizeof(value)); heap[ptr] = add_tag(free_ptr, T_MOVED); free_ptr += length; } return 1; case T_EXT_HEADER: switch (ext_tag(*scan_val)) { /* For compound types, skip the header and scan each element */ case T_IMMUT_VECTOR: case T_VECTOR: case T_VARIABLE_REF: case T_PROCEDURE: case T_CONTINUATION: case T_PROMISE: case T_PORT: case T_RATIONAL: case T_COMPLEX: return 1; /* Otherwise skip the whole blob */ default: return ext_obj_size(*scan_val); } default: /* All other principal types are immediate values */ return 1; } } uint sc_gc_verbose = 0, sc_gc_thrash_factor = 16; void sc_gc(void) { value root, scan_ptr, *tmp; if (sc_gc_verbose) { static ulong gc_count = 0; write_err("GC: cycle "); write_err(fmt_ulong_dec(++gc_count)); write_err(" | "); } free_ptr = 0; for (root = 0; root < roots_fill; ++root) scan_cell(roots[root]); for (scan_ptr = 0; scan_ptr < free_ptr; scan_ptr += scan_cell(&new_heap[scan_ptr])) assert(free_ptr <= heap_size); tmp = heap; heap = new_heap; new_heap = tmp; if (sc_gc_verbose) { /* using floating point to avoid overflow */ double live_bytes = free_ptr*sizeof(value); double live_pct = 100.*free_ptr/heap_size; write_err(fmt_ulong_dec(free_ptr)); write_err(" cells | "); write_err(fmt_ulong_dec((live_bytes+1023.)/1024.)); write_err("K | "); write_err(fmt_ulong_dec(live_pct)); write_err("."); write_err(fmt_ulong_dec(((unsigned)(10.*live_pct))%10)); write_err("% live\n"); } } static value sc_malloc(size_t cells) { value result = free_ptr; free_ptr += cells; if (free_ptr > heap_size) { sc_gc(); result = free_ptr; free_ptr += cells; if (free_ptr > (heap_size - heap_size/sc_gc_thrash_factor)) { /* Clear registers in hopes of freeing space. While not guaranteed, * this can help simple cases like recovering the REPL after a * runaway recursion. */ r0 = r1 = r2 = r3 = r4 = r5 = r6 = r_stack = SC_NULL; sc_error("out of memory"); } } return result; } /************************* * Scheme stack operations */ /* Push R_CAR onto the stack (no other side effects) */ static void push(void) { value new_stack = sc_malloc(2); heap[new_stack] = R_CAR; heap[new_stack+1] = r_stack; r_stack = add_tag(new_stack, T_PAIR); } /* Shorthand to push an arbitrary value */ #define PUSH(val) { R_CAR = (val); push(); } /* Remove the top of the stack */ static void drop(void) { r_stack = cdr(r_stack); } /* Return the top of the stack */ static value peek(void) { return car(r_stack); } /* Remove and return the top of the stack */ static value pop(void) { value v = car(r_stack); r_stack = cdr(r_stack); return v; } /*************************************************** * Builtin type constructors, predicates & accessors */ static int is_ext_type(value v, uint t) { return tag(v) == T_EXTENDED && ext_tag(heap[untag(v)]) == t; } static int is_mutable(value v) { int t = tag(v); if (t != T_EXTENDED) return t == T_PAIR; t = ext_tag(heap[untag(v)]); return t == T_STRING || t == T_VECTOR; } /* Booleans */ static value boolean(int b) { return b ? SC_TRUE : SC_FALSE; } static int is_boolean(value v) { return v == SC_TRUE || v == SC_FALSE; } /* Pairs & lists */ /* Return a new pair from the values of R_CAR and R_CDR */ static value cons(void) { value p = sc_malloc(2); heap[p] = R_CAR; heap[p+1] = R_CDR; return add_tag(p, T_PAIR); } static value cons_immutable(void) { value p = sc_malloc(2); heap[p] = R_CAR; heap[p+1] = R_CDR; return add_tag(p, T_IMMUT_PAIR); } static int is_pair(value v) { return (tag(v) | 1) == T_PAIR; } static value car(value p) { assert(is_pair(p)); return heap[untag(p)]; } static value cdr(value p) { assert(is_pair(p)); return heap[untag(p)+1]; } static void set_car(value p, value v) { assert(is_pair(p)); heap[untag(p)] = v; } static void set_cdr(value p, value v) { assert(is_pair(p)); heap[untag(p)+1] = v; } static value safe_car(value p) { if (!is_pair(p)) sc_error1("not a pair:", p); return car(p); } static value safe_cdr(value p) { if (!is_pair(p)) sc_error1("not a pair:", p); return cdr(p); } #define cadr(x) car(cdr(x)) /* Safely compute the length of a list, returning -1 if not a proper list */ static long safe_list_length(value v) { /* Floyd's cycle-finding algorithm */ value slow = v, fast = v, length = 0; while (is_pair(fast)) { slow = cdr(slow); fast = cdr(fast); length++; if (!is_pair(fast)) break; fast = cdr(fast); if (fast == slow) return -1; /* cycle */ length++; } if (fast != SC_NULL) return -1; /* improper list or not a pair */ return length; } static int is_list(value v) { return safe_list_length(v) >= 0; } /* Compute the length of a proper list */ static value list_length(value l) { value length = 0; for (; l != SC_NULL; l = cdr(l)) length++; return length; } /* Find the first node shared by two proper lists; that is, the LCA of two * nodes in the parent-pointer tree rooted at the empty list. */ static value lowest_common_ancestor(value a, value b) { value al = list_length(a), bl = list_length(b); if (al != bl) { if (al > bl) do a = cdr(a), --al; while (al > bl); else do b = cdr(b), --bl; while (bl > al); } while (a != b) a = cdr(a), b = cdr(b); return a; } /* Numbers */ static value fixnum_zero, fixnum_one; /* Not bounds checked! */ static value fixnum(long n) { return add_tag(untag(n), T_FIXNUM); } static int is_fixnum(value v) { return tag(v) == T_FIXNUM; } static long fixnum_val(value v) { assert(is_fixnum(v)); return untag_signed(v); } static ulong unsigned_fixnum_val(value v) { assert(is_fixnum(v)); return untag(v); } static long safe_fixnum_val(value v) { if (is_fixnum(v)) return untag_signed(v); sc_error1("not an integer or out of bounds:", v); } static value flonum(double x) { value f = sc_malloc(1 + FLONUM_CELLS); heap[f] = ext_add_tag(0, T_FLONUM); /* strict aliasing? *((double *)&heap[f+1]) = x; */ memcpy(&heap[f+1], &x, sizeof x); return add_tag(f, T_EXTENDED); } static int is_flonum(value v) { return is_ext_type(v, T_FLONUM); } static double flonum_val(value f) { /* strict aliasing? return *((double *)&heap[untag(f)+1]); */ double x; assert(is_flonum(f)); memcpy(&x, &heap[untag(f)+1], sizeof x); return x; } static value make_bignum_uninit(value len, int neg) { value ptr; if (len > EXT_LENGTH_MAX) sc_error("length too large for bignum"); ptr = sc_malloc(1 + len); heap[ptr] = ext_add_tag(len, T_BIGNUM | neg); return add_tag(ptr, T_EXTENDED); } static int is_bignum(value v) { return tag(v) == T_EXTENDED && (ext_tag(heap[untag(v)]) | 1) == T_NEG_BIGNUM; } static value bignum_len(value n) { assert(is_bignum(n)); return ext_untag(heap[untag(n)]); } static value bignum_ref(value n, value k) { assert(k < bignum_len(n)); return heap[untag(n)+k+1]; } static void bignum_set(value n, value k, value word) { assert(k < bignum_len(n)); assert(is_fixnum(word)); heap[untag(n)+k+1] = word; } static int is_bignum_negative(value n) { assert(is_bignum(n)); return ext_tag(heap[untag(n)]) & 1; } static value bignum_set_negative(value n) { assert(is_bignum(n)); heap[untag(n)] |= (1UL << EXT_VAL_BITS); return n; } /* Truncate bignum in place (consider carefully how GC works) */ static value bignum_truncate(value n, value len) { assert(len <= bignum_len(n)); value ptr = untag(n); heap[ptr] = ext_add_tag(len, ext_tag(heap[ptr])); return n; } static int is_rational(value v) { return is_ext_type(v, T_RATIONAL); } static int is_exact(value v) { return is_fixnum(v) || is_bignum(v) || is_rational(v); } static int is_number(value v) { return is_fixnum(v) || (tag(v) == T_EXTENDED && ext_tag(heap[untag(v)]) >= T_FLONUM); } static int is_integer(value v) { if (is_fixnum(v) || is_bignum(v)) return 1; if (is_flonum(v)) { double f = flonum_val(v); return f == nearbyint(f); } return 0; } /* Characters */ static value character(uchar c) { return add_tag(c, T_CHARACTER); } static int is_character(value v) { return tag(v) == T_CHARACTER; } static uchar safe_char_val(value c) { if (!is_character(c)) sc_error1("not a character:", c); return (uchar)c; } #define char_val(c) ((uchar)(c)) /* Convert ASCII characters to upper/lowercase */ static uchar uc(uchar c) { if (c >= 'a' && c <= 'z') return c - 0x20; return c; } static uchar lc(uchar c) { if (c >= 'A' && c <= 'Z') return c + 0x20; return c; } /* Strings */ static value alloc_string(value len) { if (len > EXT_LENGTH_MAX) sc_error("length negative or too large for string"); return sc_malloc(1 + packed_str_len(len)); } static value make_string_uninit(value len) { value ptr = alloc_string(len); heap[ptr] = ext_add_tag(len, T_STRING); return add_tag(ptr, T_EXTENDED); } static value make_immutable_string(value len) { value ptr = alloc_string(len); heap[ptr] = ext_add_tag(len, T_IMMUT_STRING); return add_tag(ptr, T_EXTENDED); } static int is_string(value v) { return tag(v) == T_EXTENDED && (ext_tag(heap[untag(v)]) | 1) == T_STRING; } static int is_mutable_string(value v) { return tag(v) == T_EXTENDED && ext_tag(heap[untag(v)]) == T_STRING; } static int is_symbol(value); static uchar * string_buf(value s) { assert(is_string(s) || is_symbol(s)); return (uchar *)&heap[untag(s)+1]; } /* C thinks strings are made of signed chars for some reason... */ static char * c_string_buf(value s) { assert(is_string(s) || is_symbol(s)); return (char *)string_buf(s); } static value string_len(value s) { assert(is_string(s) || is_symbol(s)); return ext_untag(heap[untag(s)]); } /* Construct string from null-terminated C string not on the Scheme heap */ static value string(const char *c_str) { value len = strlen(c_str); value str = make_string_uninit(len); memcpy(string_buf(str), c_str, len); return str; } static value make_string(value len, uchar fill) { value s = make_string_uninit(len); memset(string_buf(s), fill, len); return s; } /* Construct immutable copy of string or symbol in R_EXPR */ static value string_copy_immutable(void) { value len = string_len(R_EXPR), ptr = alloc_string(len); heap[ptr] = ext_add_tag(len, T_IMMUT_STRING); memcpy(heap+ptr+1, string_buf(R_EXPR), len); return add_tag(ptr, T_EXTENDED); } /* Construct copy of string in R_EXPR */ static value string_copy(void) { value len = string_len(R_EXPR); value result = make_string_uninit(len); memcpy(string_buf(result), string_buf(R_EXPR), len); return result; } /* Construct copy of string in R_EXPR with null byte appended */ static value string_append_null(void) { value len = string_len(R_EXPR); value result = make_string_uninit(len + 1); uchar *buf = string_buf(result); memcpy(buf, string_buf(R_EXPR), len); buf[len] = '\0'; return result; } /* Truncate string in place (consider carefully how GC works) */ static void string_truncate(value s, value len) { assert(len <= string_len(s)); value ptr = untag(s); heap[ptr] = ext_add_tag(len, ext_tag(heap[ptr])); } /* Symbols */ static value symbols; /* interning list */ /* Frequently used symbols */ static value s_lambda, s_quote, s_quasiquote, s_unquote, s_unquote_splicing, s_if, s_set, s_begin, s_letrec, s_define, s_delay, s_literal, s_open_paren, s_close_paren, s_dot, s_open_vector, s_identifier, s_named_char, s_abbrev, s_number, s_truncate, s_overwrite, s_append, s_sync, s_data_sync; static value find_symbol(const uchar *buf, value len) { value iter, sym; /* some type checks skipped because interning list is not (directly) user * modifiable */ for (iter = symbols; iter != SC_NULL; iter = cdr(iter)) { sym = car(iter); if (len == ext_untag(heap[untag(sym)]) && memcmp(buf, &heap[untag(sym)+1], len) == 0) return sym; } return SC_NULL; } /* Get symbol from a null-terminated C string not on the Scheme heap, not * converting case (side effects: R_CAR R_CDR) */ static value symbol(const char *c_str) { value len = strlen(c_str); value sym = find_symbol((uchar *)c_str, len); if (sym != SC_NULL) return sym; value sym_ptr = sc_malloc(1 + packed_str_len(len)); heap[sym_ptr] = ext_add_tag(len, T_SYMBOL); memcpy(&heap[sym_ptr+1], c_str, len); R_CAR = add_tag(sym_ptr, T_EXTENDED); R_CDR = symbols; symbols = cons(); return R_CAR; } /* Get symbol from a Scheme string in R_CAR, not converting case * (side effects: R_CAR R_CDR) */ static value string_to_symbol(void) { value len = string_len(R_CAR); value sym = find_symbol(string_buf(R_CAR), len); if (sym != SC_NULL) return sym; value sym_ptr = sc_malloc(1 + packed_str_len(len)); heap[sym_ptr] = ext_add_tag(len, T_SYMBOL); memcpy(&heap[sym_ptr+1], string_buf(R_CAR), len); R_CAR = add_tag(sym_ptr, T_EXTENDED); R_CDR = symbols; symbols = cons(); return R_CAR; } static int is_symbol(value v) { return is_ext_type(v, T_SYMBOL); } /* Vectors */ static value alloc_vector(value len) { if (len > EXT_LENGTH_MAX) sc_error("length negative or too large for vector"); return sc_malloc(1 + len); } /* Uninitialized constructors: caller must fill without further allocation */ static value make_vector_uninit(value len) { value vec = alloc_vector(len); heap[vec] = ext_add_tag(len, T_VECTOR); return add_tag(vec, T_EXTENDED); } static value make_immutable_vector(value len) { value vec = alloc_vector(len); heap[vec] = ext_add_tag(len, T_IMMUT_VECTOR); return add_tag(vec, T_EXTENDED); } /* Build a new vector with each element initialized to R_EXPR */ static value make_vector(value len) { value vec = make_vector_uninit(len), *p; for (p = heap+untag(vec)+1; len; --len, ++p) *p = R_EXPR; return vec; } /* Build a new vector by reversing the elements of proper list R_EXPR */ static value rev_list_to_vec(void) { value len = list_length(R_EXPR), vec = make_vector_uninit(len), *p = heap+untag(vec)+len; for (; R_EXPR != SC_NULL; --p, R_EXPR = cdr(R_EXPR)) *p = car(R_EXPR); return vec; } static int is_vector(value v) { return tag(v) == T_EXTENDED && (ext_tag(heap[untag(v)]) | 1) == T_VECTOR; } static int is_mutable_vector(value v) { return tag(v) == T_EXTENDED && ext_tag(heap[untag(v)]) == T_VECTOR; } static value vector_len(value v) { assert(is_vector(v)); return ext_untag(heap[untag(v)]); } static value vector_ref(value v, value k) { assert(k < vector_len(v)); return heap[untag(v)+k+1]; } static void vector_set(value v, value k, value obj) { assert(k < vector_len(v)); heap[untag(v)+k+1] = obj; } /* Builtin procedures */ static value builtin(const char *name, builtin_func_t func) { value b = sc_malloc(3); heap[b] = ext_add_tag(0, T_BUILTIN); heap[b+1] = (value)name; heap[b+2] = (value)func; return add_tag(b, T_EXTENDED); } static int is_builtin(value v) { return is_ext_type(v, T_BUILTIN); } static const char * builtin_name(value b) { return (char *)heap[untag(b)+1]; } static builtin_func_t builtin_func(value b) { return (builtin_func_t)heap[untag(b)+2]; } /* Compound procedures */ /* Return a new procedure object from lambda expression operands in R_OPERANDS * and environment in R_ENV. * Side effects: R_OPERANDS R_CAR R_CDR */ static value procedure(void) { value p, arity; arity = car(R_OPERANDS); if (is_fixnum(arity)) { /* Compiler annotated parameter list attributes to save a traversal */ R_OPERANDS = cdr(R_OPERANDS); } else { /* ...this traversal (still needed for bootstrapping), which in turn * saves traversing each time the procedure is applied */ p = arity; /* parameter list */ arity = 0; for (; is_pair(p); p = cdr(p)) arity++; if (p == SC_NULL) arity = fixnum(arity); else { /* improper (variadic) */ assert(is_symbol(p)); arity = (value)(-1L - (long)arity); } } p = sc_malloc(4); heap[p] = ext_add_tag(ext_untag(arity), T_PROCEDURE); heap[p+1] = car(R_OPERANDS); /* parameter list */ heap[p+2] = cdr(R_OPERANDS); /* body */ heap[p+3] = R_ENV; return add_tag(p, T_EXTENDED); } static int is_compound_proc(value v) { return is_ext_type(v, T_PROCEDURE); } static long proc_arity(value p) { return ext_untag_signed(heap[untag(p)]); } static value proc_params(value p) { return heap[untag(p)+1]; } static value proc_body(value p) { return heap[untag(p)+2]; } static value proc_env(value p) { return heap[untag(p)+3]; } /* Continuations */ static value current_continuation(void) { value cont = sc_malloc(3); heap[cont] = ext_add_tag(0, T_CONTINUATION); heap[cont+1] = r_stack; heap[cont+2] = r_spool; return add_tag(cont, T_EXTENDED); } static int is_continuation(value v) { return is_ext_type(v, T_CONTINUATION); } static value continuation_stack(value c) { return heap[untag(c)+1]; } static value continuation_spool(value c) { return heap[untag(c)+2]; } static int is_procedure(value v) { return is_builtin(v) || is_compound_proc(v) || is_continuation(v); } /* Promises */ /* Construct a promise from an expression in R_EXPR and environment in R_ENV */ static value promise(void) { value p = sc_malloc(3); heap[p] = ext_add_tag(0, T_PROMISE); heap[p+1] = R_EXPR; heap[p+2] = R_ENV; return add_tag(p, T_EXTENDED); } static int is_promise(value v) { return is_ext_type(v, T_PROMISE); } static int promise_done(value p) { return heap[untag(p)] & 1; } static value promise_value(value p) { return heap[untag(p)+1]; } static value promise_env(value p) { return heap[untag(p)+2]; } static void promise_memoize(value p, value v) { value ptr = untag(p); heap[ptr] = ext_add_tag(1, T_PROMISE); heap[ptr+1] = v; heap[ptr+2] = SC_NULL; /* release to GC */ } /* Ports */ static value stdin_port, stdout_port; #define DEFAULT_R_BUF 4096 #define DEFAULT_W_BUF 4096 /* Flags in header */ #define PORT_OUTPUT_BIT 1 #define PORT_SOCKET_BIT 2 #define PORT_EOF_BIT 4 /* Fields */ #define PORT_FD 1 #define PORT_START 2 #define PORT_FILL 3 #define PORT_BUF 4 #define PORT_COUNTERPART 5 /* Construct unidirectional port. Side effects: R_RESULT */ static value make_port(int fd, int is_output, long buf_size) { value port, *p; if (buf_size < 1) sc_error("buffer size must be at least one"); R_RESULT = make_string_uninit(buf_size); port = sc_malloc(6); p = heap+port; p[0] = ext_add_tag(is_output ? PORT_OUTPUT_BIT : 0, T_PORT); p[PORT_FD] = fixnum(fd); p[PORT_START] = fixnum(0); p[PORT_FILL] = fixnum(0); p[PORT_BUF] = R_RESULT; p[PORT_COUNTERPART] = SC_NULL; return add_tag(port, T_EXTENDED); } /* Construct input port in r0 and output port in r1 from socket file * descriptor. Side effects: R_RESULT */ static void make_socket_ports(int fd, value rbuf_size, value wbuf_size) { value *p; chkp(fcntl(fd, F_SETFL, O_NONBLOCK)); r0 = make_port(fd, 0, rbuf_size); r1 = make_port(fd, 1, wbuf_size); /* Cross-reference the two directions so the underlying FD can be closed * promptly when both ports are. */ p = heap+untag(r0); p[0] |= PORT_SOCKET_BIT; p[PORT_COUNTERPART] = r1; p = heap+untag(r1); p[0] |= PORT_SOCKET_BIT; p[PORT_COUNTERPART] = r0; } static int is_port(value v) { return is_ext_type(v, T_PORT); } static int is_input_port(value v) { value header; if (tag(v) != T_EXTENDED) return 0; header = heap[untag(v)]; return ext_tag(header) == T_PORT && (header & PORT_OUTPUT_BIT) == 0; } static int is_output_port(value v) { value header; if (tag(v) != T_EXTENDED) return 0; header = heap[untag(v)]; return ext_tag(header) == T_PORT && (header & PORT_OUTPUT_BIT) != 0; } static int set_port_closed(value *p) { int fd = fixnum_val(p[PORT_FD]); /* Set an invalid FD so writes to a closed port are caught by the kernel * with no extra cost in the normal case. Disable buffering so they're * caught immediately. */ p[PORT_FD] = fixnum(-1); p[PORT_START] = p[PORT_FILL] = fixnum(0); string_truncate(p[PORT_BUF], 1); if (p[PORT_COUNTERPART] == SC_NULL) return close(fd); heap[untag(p[PORT_COUNTERPART])+PORT_COUNTERPART] = SC_NULL; p[PORT_COUNTERPART] = SC_NULL; return 0; } static ssize_t fill_input_port(value *p, int nonblock) { int fd = fixnum_val(p[PORT_FD]); uchar *buf = string_buf(p[PORT_BUF]); value len = string_len(p[PORT_BUF]); ssize_t n; while ((n = read(fd, buf, len)) < 0) { if (errno == EINTR) continue; if (errno == EAGAIN || errno == EWOULDBLOCK) { if (nonblock) return -1; poll1(fd, POLLIN, -1); continue; } if (fd == -1) sc_error("input port closed"); sc_perror(); } p[PORT_START] = fixnum(0); p[PORT_FILL] = fixnum(n); return n; } static void flush_output_port(value *p) { int fd = fixnum_val(p[PORT_FD]); long fill = fixnum_val(p[PORT_FILL]); assert(fill > 0); /* zero-length write unspecified on non-regular files */ assert((ulong)fill <= string_len(p[PORT_BUF])); p[PORT_FILL] = fixnum(0); if (write_all(fd, c_string_buf(p[PORT_BUF]), fill) == -1) { int saved; if (fd == -1) sc_error("output port closed"); /* Probably no sensible way to recover from write errors, so force the * port closed. XXX Closing standard streams is a concern (i.e. a * subsequent open gets FD 1 or 2 and terminal output goes to the file * unexpectedly), except: 1) the interpreter writes to stdout through * the port object only; 2) the open-subprocess extension always pipes * the child's stdout; 3) there's no port for stderr. But these are * fragile assumptions. */ saved = errno; set_port_closed(p); errno = saved; sc_perror(); } } static void flush_if_needed(value port) { value *p = heap+untag(port); if (fixnum_val(p[PORT_FILL]) > 0) flush_output_port(p); } static void close_port(value port) { value *p = heap+untag(port), header = p[0]; int fd = fixnum_val(p[PORT_FD]); if (fd == -1) return; if (header & PORT_OUTPUT_BIT) flush_if_needed(port); if (header & PORT_SOCKET_BIT) shutdown(fd, header & PORT_OUTPUT_BIT ? SHUT_WR : SHUT_RD); chkp(set_port_closed(p)); } static value read_char(value port) { value *p = heap+untag(port), start = p[PORT_START]; uchar *buf = string_buf(p[PORT_BUF]); if (start == p[PORT_FILL]) { if (p[0] & PORT_EOF_BIT) { p[0] ^= PORT_EOF_BIT; return SC_EOF; } if (!fill_input_port(p, 0)) return SC_EOF; start = 0; } else start = untag(start); p[PORT_START] = fixnum(start+1); return character(buf[start]); } static value peek_char(value port) { value *p = heap+untag(port), start = p[PORT_START]; uchar *buf = string_buf(p[PORT_BUF]); if (start == p[PORT_FILL]) { /* EOF is not always permanent, e.g. on a tty, so the condition must be * saved specially for the next peek or read. */ if (p[0] & PORT_EOF_BIT) return SC_EOF; if (!fill_input_port(p, 0)) { p[0] |= PORT_EOF_BIT; return SC_EOF; } start = 0; } else start = untag(start); return character(buf[start]); } static value input_port_ready(value port) { value *p; int fd; p = heap+untag(port); fd = fixnum_val(p[PORT_FD]); if (p[PORT_START] < p[PORT_FILL]) return SC_TRUE; if (fd == -1) sc_error("input port closed"); if (!poll1(fd, POLLIN, 0)) return SC_FALSE; /* XXX Linux poll/select are broken and have false positives for * readability, at least for sockets, so we try a nonblocking read. But * this doesn't work for regular files! Seems marginally better to break * "the next READ-CHAR operation on the given PORT is guaranteed not to * hang" than have CHAR-READY? itself hang. Alternately, djb's SIGALARM * hack could be used. */ if (p[0] & PORT_SOCKET_BIT && fill_input_port(p, 1) == -1) return SC_FALSE; return SC_TRUE; } /* Barbarous relic from writing the lexer based on stdio/ungetc */ #define EOF (-1) static void put_back_char(int c) { value *p; assert(is_port(R_PORT)); p = heap+untag(R_PORT); if (c == EOF) p[0] |= PORT_EOF_BIT; else { value start = untag(p[PORT_START]); assert(start); --start; string_buf(p[PORT_BUF])[start] = c; p[PORT_START] = fixnum(start); } } static void write_char(uchar c) { value *p, fill, len; uchar *buf; assert(is_port(R_PORT)); p = heap+untag(R_PORT); fill = untag(p[PORT_FILL]); len = string_len(p[PORT_BUF]); assert(fill < len); buf = string_buf(p[PORT_BUF]); buf[fill] = c; ++fill; p[PORT_FILL] = fixnum(fill); if (fill == len) flush_output_port(p); } static int stdout_ready; static void flush_all(void) { /* TODO */ if (stdout_ready) flush_if_needed(stdout_port); } static void write_cstr(const char *s) { for (; *s; ++s) write_char(*s); } static void write_str(value s) { /* also for symbols */ value len = string_len(s); uchar *buf = string_buf(s); assert(is_string(s) || is_symbol(s)); for (; len; --len, ++buf) write_char(*buf); } static void write_str_quoted(value s) { value i, len = string_len(s); uchar *buf = string_buf(s); write_char('"'); for (i = 0; i < len; i++) { uchar c = buf[i]; if (c == '"' || c == '\\') write_char('\\'); write_char(c); } write_char('"'); } static void newline(void) { write_char('\n'); } /* Environments * * An environment is a list of lexical frames followed by global frames. * * A lexical frame is a vector of which the first element is the list of * symbols naming the variables (possibly improper, as in a lambda expression), * and the remaining elements are the corresponding values. * * A global frame is a list of (symbol . value) binding pairs. */ static value r5rs_env, gscm_env, interaction_env, toplevel_env; static void check_mutable_env(value env, value name) { if (env != interaction_env) { assert(env == r5rs_env || env == gscm_env || env == toplevel_env); sc_error1("variable in immutable environment:", name); } } /* Construct a new lexical frame for the application of the procedure in R_PROC * to the freshly allocated argument list in R_ARGS (no other side effects) */ static value make_lex_frame(void) { value k, frame, args, arity, fixed_arity; long encoded_arity = proc_arity(R_PROC); if (encoded_arity < 0) { arity = (value)(-encoded_arity); fixed_arity = arity - 1; } else { arity = (value)encoded_arity; fixed_arity = arity; } frame = make_vector_uninit(1 + arity); vector_set(frame, 0, proc_params(R_PROC)); args = R_ARGS; for (k = 1; k <= fixed_arity; k++) { if (args == SC_NULL) sc_error("too few arguments"); vector_set(frame, k, car(args)); args = cdr(args); } if (fixed_arity < arity) vector_set(frame, k, args); else if (args != SC_NULL) sc_error("too many arguments"); return frame; } /* Construct a new lexical frame for a LETREC binding list in r2, that is, bind * the given names to not-yet-defined values. The name list is constructed in * reverse order. * Side effects: r2 R_CAR R_CDR */ static value make_letrec_frame(void) { /* TODO optimize: transpose the binding list? */ value k, len, frame; R_CDR = SC_NULL; len = 1; for (; r2 != SC_NULL; r2 = cdr(r2)) { len++; R_CAR = car(car(r2)); R_CDR = cons(); } frame = make_vector_uninit(len); vector_set(frame, 0, R_CDR); for (k = 1; k < len; k++) vector_set(frame, k, UNDEFINED); return frame; } /* Add a new binding for R_CAR to R_CDR to the topmost frame of global R_ENV. * Side effects: R_CAR R_CDR */ static void extend_global_env(void) { R_CAR = cons(); /* new binding */ R_CDR = car(R_ENV); /* top frame */ assert(is_pair(R_CDR) || R_CDR == SC_NULL); R_CDR = cons(); set_car(R_ENV, R_CDR); } /* Construct a new global frame containing copies of the bindings in the frame * in R_EXPR. Side effects: R_CAR R_CDR R_EXPR R_TAIL R_RESULT */ static value copy_global_frame(void) { value temp; R_CAR = R_CDR = SC_NULL; R_TAIL = R_RESULT = cons(); for (; R_EXPR != SC_NULL; R_EXPR = cdr(R_EXPR)) { temp = car(R_EXPR); R_CAR = car(temp); R_CDR = cdr(temp); R_CAR = cons(); /* copied binding */ R_CDR = SC_NULL; temp = cons(); set_cdr(R_TAIL, temp); R_TAIL = temp; } return cdr(R_RESULT); } static value global_frame_lookup(value name, value frame) { value binding; for (; frame != SC_NULL; frame = cdr(frame)) { binding = car(frame); if (car(binding) == name) return binding; } return SC_FALSE; } static value lex_frame_lookup(value name, value frame) { value names, index; index = 1; for (names = vector_ref(frame, 0); is_pair(names); names = cdr(names)) { if (car(names) == name) goto found; index++; } if (names != name) return 0; found: if (vector_ref(frame, 1) == UNDEFINED) /* see LETREC */ sc_error1("undefined variable:", name); return index; } static value env_lookup(value name, value env) { value frame, binding, index; assert(is_symbol(name)); for (; env != SC_NULL; env = cdr(env)) { frame = car(env); if (is_vector(frame)) { index = lex_frame_lookup(name, frame); if (index) return vector_ref(frame, index); } else { binding = global_frame_lookup(name, frame); if (binding != SC_FALSE) return cdr(binding); } } sc_error1("unbound variable:", name); } static void env_lookup_set(value name, value env, value new) { value frame, binding, index; assert(is_symbol(name)); for (; env != SC_NULL; env = cdr(env)) { frame = car(env); if (is_vector(frame)) { index = lex_frame_lookup(name, frame); if (index) { vector_set(frame, index, new); return; } } else { binding = global_frame_lookup(name, frame); if (binding != SC_FALSE) { check_mutable_env(env, name); set_cdr(binding, new); return; } } } sc_error1("unbound variable:", name); } /* Variable references: created by compiler to memoize environment lookups */ static int is_variable_ref(value v) { return is_ext_type(v, T_VARIABLE_REF); } /* Return an unresolved variable reference for a symbol in R_CAR */ static value make_variable_ref() { assert(is_symbol(R_CAR)); value ref = sc_malloc(2); heap[ref] = ext_add_tag(0, T_VARIABLE_REF); heap[ref+1] = R_CAR; return add_tag(ref, T_EXTENDED); } /* Look up an unresolved variable reference and memoize */ static void resolve_variable_ref(value ref, value env, int mutable) { value ptr, name, frame, height, binding, index; ptr = untag(ref); name = heap[ptr+1]; assert(is_symbol(name)); height = 0; for (; env != SC_NULL; env = cdr(env)) { frame = car(env); if (is_vector(frame)) { index = lex_frame_lookup(name, frame); if (index) { if (height > FIXNUM_MAX) /* maybe possible on small architectures */ sc_error("environment too deep"); heap[ptr] = ext_add_tag(index, T_VARIABLE_REF); heap[ptr+1] = add_tag(height, T_FIXNUM); return; } } else { binding = global_frame_lookup(name, frame); if (binding != SC_FALSE) { if (mutable) check_mutable_env(env, name); heap[ptr+1] = binding; return; } } height++; } sc_error1("unbound variable:", name); } static value variable_ref_get(value ref, value env) { value ptr, contents, height; ptr = untag(ref); retry: contents = heap[ptr+1]; if (is_pair(contents)) /* global */ return cdr(contents); else if (is_fixnum(contents)) { /* lexical */ for (height = fixnum_val(contents); height; height--) env = cdr(env); return vector_ref(car(env), ext_untag(heap[ptr])); } else { /* unresolved */ resolve_variable_ref(ref, env, 0); goto retry; } } static void variable_ref_set(value ref, value env, value new) { value ptr, contents, height; ptr = untag(ref); retry: contents = heap[ptr+1]; if (is_pair(contents)) /* global */ set_cdr(contents, new); else if (is_fixnum(contents)) { /* lexical */ for (height = fixnum_val(contents); height; height--) env = cdr(env); vector_set(car(env), ext_untag(heap[ptr]), new); } else { /* unresolved */ resolve_variable_ref(ref, env, 1); goto retry; } } /*********** * Debugging */ static void shallow_print(void); void sc_dump(value v) { r_dump = v; PUSH(R_CAR); PUSH(R_EXPR); PUSH(R_PORT); R_EXPR = r_dump; R_PORT = stdout_port; shallow_print(); newline(); R_PORT = pop(); R_EXPR = pop(); R_CAR = pop(); r_dump = SC_NULL; } /**************** * Core evaluator * * The evaluator is a set of subroutines delimited by labels, with "switch" * cases serving as pushable return addresses. (Caution is needed in case of * nested switches or "break".) Properly tail recursive calls are where "goto" * is used rather than CALL, that is, a new return address is not pushed. * Nothing else may be left on the subroutine's stack frame in these cases! */ /* Shorthand for non-tail subroutine calls. Beware of the register side effects * or confusing RETURN with C return. */ #define CALL(subroutine_label, return_address) \ { R_CAR = return_address; push(); goto subroutine_label; } #define RETURN(val) { R_RESULT = (val); goto dispatch; } /* Return addresses */ #define EV_DONE 0 #define EV_COMPILE_RESULT 1 #define EV_CALL_OPERATOR 2 #define EV_CALL_LOOP 3 #define EV_UNWIND_LOOP 4 #define EV_REWIND_LOOP 5 #define EV_SEQ_LOOP 6 #define EV_IF_PREDICATE 7 #define EV_SET_RESULT 8 #define EV_LETREC_LOOP 9 #define EV_DEFINE_RESULT 10 #define EV_FORCE_RESULT 11 #define EV_CALL_WITH_VALUES 12 static const char *err_context; static jmp_buf err_longjmp_env; /* Takes expression in R_EXPR and environment in R_ENV */ static void evaluator(void) { value k; if (setjmp(err_longjmp_env)) goto APPLY; if (r_compiler) CALL(COMPILE, EV_DONE); CALL(EVAL, EV_DONE); dispatch: switch (pop()) { case EV_DONE: assert(r_stack == SC_NULL); r_error_cont = SC_NULL; break; COMPILE: /* Compile expression R_EXPR then evaluate in environment R_ENV */ PUSH(R_ENV); R_CAR = R_EXPR; R_CDR = SC_NULL; R_ARGS = cons(); R_PROC = r_compiler; CALL(APPLY, EV_COMPILE_RESULT); case EV_COMPILE_RESULT: R_EXPR = R_RESULT; R_ENV = pop(); goto EVAL; EVAL: /* Evaluate expression R_EXPR in environment R_ENV */ err_context = "eval"; if (is_pair(R_EXPR)) { /* Combination */ R_OPERANDS = cdr(R_EXPR); R_EXPR = car(R_EXPR); if (is_symbol(R_EXPR)) { if (R_EXPR == s_lambda) RETURN(procedure()); if (R_EXPR == s_if) goto IF; if (R_EXPR == s_set) goto SET; if (R_EXPR == s_begin) goto EVAL_BODY; if (R_EXPR == s_letrec) goto LETREC; if (R_EXPR == s_quote) RETURN(car(R_OPERANDS)); if (R_EXPR == s_define) goto DEFINE; if (R_EXPR == s_delay) goto DELAY; } goto EVAL_CALL; } if (is_variable_ref(R_EXPR)) /* Cacheable variable reference */ RETURN(variable_ref_get(R_EXPR, R_ENV)); if (is_symbol(R_EXPR)) /* Slow and stupid variable lookup: replacing symbols in the * expression tree with variable references is done by the * compiler, so this is needed to bootstrap */ RETURN(env_lookup(R_EXPR, R_ENV)); assert(is_number(R_EXPR) || is_boolean(R_EXPR) || is_character(R_EXPR) || is_string(R_EXPR) || /* not valid Scheme, but allowed in compiler output */ R_EXPR == SC_NULL || is_vector(R_EXPR)); RETURN(R_EXPR); /* Self-evaluating */ EVAL_CALL: /* Procedure call (operator operand ...) * Evaluate operator in R_EXPR and each operand in R_OPERANDS, build * argument list and apply in R_ENV. */ PUSH(R_OPERANDS); PUSH(R_ENV); CALL(EVAL, EV_CALL_OPERATOR); case EV_CALL_OPERATOR: R_ENV = pop(); R_CAR = R_RESULT; R_OPERANDS = pop(); push(); /* evaluated operator */ R_CAR = R_CDR = SC_NULL; R_TAIL = cons(); /* arg list tail pointer */ PUSH(R_TAIL); /* arg list head pointer */ PUSH(R_ENV); for (; R_OPERANDS != SC_NULL; R_OPERANDS = cdr(R_OPERANDS)) { PUSH(R_OPERANDS); PUSH(R_TAIL); R_EXPR = car(R_OPERANDS); CALL(EVAL, EV_CALL_LOOP); case EV_CALL_LOOP: R_CAR = R_RESULT; R_TAIL = pop(); R_OPERANDS = pop(); R_ENV = peek(); R_CDR = SC_NULL; R_CDR = cons(); set_cdr(R_TAIL, R_CDR); R_TAIL = R_CDR; } drop(); /* environment */ R_ARGS = cdr(pop()); /* arg list head pointer */ R_PROC = pop(); /* evaluated operator */ goto APPLY; APPLY: /* Extend the lexical environment of procedure R_PROC by binding its * formal parameters to arguments in the freshly allocated list R_ARGS, * then evaluate its body in the new environment. */ if (is_builtin(R_PROC)) { err_context = builtin_name(R_PROC); r_flag = f_none; R_RESULT = (builtin_func(R_PROC))(R_ARGS); /* Builtins cannot call back into the evaluator as that would break * tail recursion and enable unlimited recursion on the C stack. * Instead they can set a flag to signal a tail call to a given * subroutine. */ switch (r_flag) { case f_none: RETURN(R_RESULT); case f_compile: goto COMPILE; case f_apply: goto APPLY; case f_force: goto FORCE; case f_call_with_values: goto CALL_WITH_VALUES; /* optimization, see RETURN_VALUES */ case f_values: goto VALUES; } } err_context = "apply"; if (is_compound_proc(R_PROC)) { R_OPERANDS = proc_body(R_PROC); R_CAR = make_lex_frame(); R_CDR = proc_env(R_PROC); R_ENV = cons(); goto EVAL_BODY; } if (is_continuation(R_PROC)) goto APPLY_CONTINUATION; sc_error1("not a procedure:", R_PROC); APPLY_CONTINUATION: /* Return the value(s) R_ARGS to the continuation R_PROC, restoring its * stack and applying any thunks registered to exit the current dynamic * extent and re-enter the captured one. */ R_WIND_TO = continuation_spool(R_PROC); if (r_spool != R_WIND_TO) { R_LCA = lowest_common_ancestor(r_spool, R_WIND_TO); r_stack = SC_NULL; PUSH(R_ARGS); PUSH(R_PROC); /* Unwind: apply "after" thunks from the current extent up to (but * not including) the narrowest common extent */ while (r_spool != R_LCA) { assert(r_spool != SC_NULL); /* XXX ^ possible to violate if thunk escapes? */ R_PROC = cdr(car(r_spool)); r_spool = cdr(r_spool); R_ARGS = SC_NULL; PUSH(R_LCA); CALL(APPLY, EV_UNWIND_LOOP); case EV_UNWIND_LOOP: R_LCA = pop(); } /* Rewind: apply "before" thunks down to the captured extent * starting below the common extent */ R_WIND_TO = continuation_spool(peek()); for (r_spool = R_WIND_TO; r_spool != R_LCA; r_spool = cdr(r_spool)) PUSH(r_spool); while (r_spool != R_WIND_TO) { R_PROC = car(car(peek())); R_ARGS = SC_NULL; PUSH(R_WIND_TO); CALL(APPLY, EV_REWIND_LOOP); case EV_REWIND_LOOP: R_WIND_TO = pop(); r_spool = pop(); } R_PROC = pop(); R_ARGS = pop(); assert(r_stack == SC_NULL); } r_stack = continuation_stack(R_PROC); VALUES: if (peek() == EV_CALL_WITH_VALUES) { drop(); goto CALL_WITH_VALUES_CONT; } if (R_ARGS == SC_NULL) sc_error("no value for ordinary continuation"); if (cdr(R_ARGS) != SC_NULL) sc_error1("multiple values for ordinary continuation:", R_ARGS); RETURN(car(R_ARGS)); EVAL_BODY: /* Evaluate one or more commands/expressions. (No definitions; we don't * need to distinguish sequence from body, as internal definitions are * converted to letrec by the compiler.) * Paramters: R_OPERANDS R_ENV */ PUSH(R_ENV); assert(R_OPERANDS != SC_NULL); for (; cdr(R_OPERANDS) != SC_NULL; R_OPERANDS = cdr(R_OPERANDS)) { R_EXPR = car(R_OPERANDS); PUSH(R_OPERANDS); CALL(EVAL, EV_SEQ_LOOP); case EV_SEQ_LOOP: R_OPERANDS = pop(); R_ENV = peek(); } drop(); /* environment */ R_EXPR = car(R_OPERANDS); goto EVAL; IF: /* (if predicate consequent [alternate]) * Parameters: R_OPERANDS R_ENV */ R_EXPR = car(R_OPERANDS); /* predicate */ R_OPERANDS = cdr(R_OPERANDS); R_CAR = car(R_OPERANDS); /* consequent */ R_OPERANDS = cdr(R_OPERANDS); push(); /* consequent */ PUSH(R_OPERANDS); /* (alternate) */ PUSH(R_ENV); CALL(EVAL, EV_IF_PREDICATE); case EV_IF_PREDICATE: R_ENV = pop(); if (R_RESULT != SC_FALSE) { drop(); /* (alternate) */ R_EXPR = pop(); /* consequent */ goto EVAL; } R_EXPR = pop(); /* (alternate) */ drop(); /* consequent */ if (R_EXPR != SC_NULL) { R_EXPR = car(R_EXPR); /* alternate */ goto EVAL; } RETURN(SC_NULL); SET: /* (set! variable value) * Parameters: R_OPERANDS R_ENV */ err_context = "set!"; R_CAR = car(R_OPERANDS); /* variable name/ref */ R_EXPR = cadr(R_OPERANDS); /* value expression */ push(); PUSH(R_ENV); CALL(EVAL, EV_SET_RESULT); case EV_SET_RESULT: R_ENV = pop(); R_CAR = pop(); /* variable name/ref */ if (is_variable_ref(R_CAR)) variable_ref_set(R_CAR, R_ENV, R_RESULT); else /* Slow and stupid lookup for bootstrap, as in EVAL */ env_lookup_set(R_CAR, R_ENV, R_RESULT); RETURN(SC_NULL); LETREC: /* (letrec ((var init) ...) body) * Parameters: R_OPERANDS R_ENV */ r2 = R_ARGS = car(R_OPERANDS); /* binding specifiers */ PUSH(cdr(R_OPERANDS)); /* body */ R_CAR = make_letrec_frame(); /* new frame */ k = vector_len(R_CAR); R_CDR = R_ENV; R_ENV = cons(); /* new environment */ /* Evaluate initializers in the new environment */ PUSH(R_ENV); for (; R_ARGS != SC_NULL; R_ARGS = cdr(R_ARGS)) { k--; PUSH(k); PUSH(R_ARGS); R_EXPR = car(cdr(car(R_ARGS))); CALL(EVAL, EV_LETREC_LOOP); case EV_LETREC_LOOP: R_ARGS = pop(); k = pop(); R_ENV = peek(); vector_set(car(R_ENV), k, R_RESULT); /* Trick: all variables in a frame are considered UNDEFINED if the * first one is. (Checking this is cheap due to memoized variable * refs.) Since we're filling in the frame backwards, to match the * reversed name list from make_letrec_frame, we catch uses of * undefined variables in the initializers without needing to store * their results in a temporary list here and then copy. */ } drop(); assert(k == 1); /* Evaluate body in the now populated environment */ R_OPERANDS = pop(); /* body */ goto EVAL_BODY; DEFINE: /* (define variable value) * Paramters: R_OPERANDS R_ENV */ if (R_ENV != interaction_env) { err_context = "define"; sc_error("not allowed in this environment"); } PUSH(car(R_OPERANDS)); /* variable name */ R_EXPR = car(cdr(R_OPERANDS)); /* value expression */ CALL(EVAL, EV_DEFINE_RESULT); case EV_DEFINE_RESULT: /* XXX is this supposed to not handle variable refs? */ R_ENV = interaction_env; R_CAR = pop(); /* variable name */ R_EXPR = global_frame_lookup(R_CAR, car(R_ENV)); if (R_EXPR == SC_FALSE) { R_CDR = R_RESULT; extend_global_env(); } else set_cdr(R_EXPR, R_RESULT); RETURN(SC_NULL); DELAY: /* (delay expr) * Parameters: R_OPERANDS R_ENV */ R_EXPR = car(R_OPERANDS); RETURN(promise()); FORCE: /* Parameters: R_EXPR: promise */ if (!is_promise(R_EXPR)) sc_error1("not a promise:", R_EXPR); if (promise_done(R_EXPR)) RETURN(promise_value(R_EXPR)); PUSH(R_EXPR); R_ENV = promise_env(R_EXPR); R_EXPR = promise_value(R_EXPR); CALL(EVAL, EV_FORCE_RESULT); case EV_FORCE_RESULT: R_EXPR = pop(); /* If promise forces itself recursively, keep the first result */ if (promise_done(R_EXPR)) RETURN(promise_value(R_EXPR)); promise_memoize(R_EXPR, R_RESULT); RETURN(R_RESULT); CALL_WITH_VALUES: /* Parameters: R_PROC: producer, R_ARGS: consumer */ PUSH(R_ARGS); R_ARGS = SC_NULL; CALL(APPLY, EV_CALL_WITH_VALUES); case EV_CALL_WITH_VALUES: /* Producer returned a single value normally */ R_CAR = R_RESULT; R_CDR = SC_NULL; R_ARGS = cons(); CALL_WITH_VALUES_CONT: /* Producer returned by calling a continuation */ R_PROC = pop(); goto APPLY; } } /* Internal error signaller: similar in form to an evaluator subroutine, but * callable from downstack C functions. */ __attribute__((noreturn)) void sc_error1(const char *msg, value detail) { static int in_handler = 0; const char *sep = ": "; if (r_error_cont != SC_NULL) { /* Hook installed by toplevel. As it's a captured continuation, * unwinding from where the error occurred happens in the usual way. */ R_PROC = r_error_cont; /* Mirroring toplevel, fall back to the default if an error is * recursively raised in the handler (or the allocations here). If a * handler is restored using SET-ERROR-HANDLER!, r_error_cont is * restored alongside. */ r_error_cont = SC_NULL; R_CDR = SC_NULL; if (detail != UNDEFINED) { R_CAR = detail; R_CDR = cons(); } if (err_context) { value cl = strlen(err_context), sl = strlen(sep), ml = strlen(msg); uchar *buf = string_buf(R_CAR = make_string_uninit(cl + sl + ml)); memcpy(buf, err_context, cl); buf += cl; memcpy(buf, sep, sl); buf += sl; memcpy(buf, msg, ml); } else R_CAR = string(msg); R_CAR = cons(); R_CDR = SC_NULL; R_ARGS = cons(); longjmp(err_longjmp_env, 1); } else if (stdout_port && !in_handler) { /* Default handler: print and halt */ in_handler = 1; /* fall back to fatal if this too raises an error */ R_PORT = stdout_port; write_cstr("ERROR [fallback]: "); if (err_context) { write_cstr(err_context); write_cstr(sep); } write_cstr(msg); if (detail != UNDEFINED) { write_char(' '); R_EXPR = detail; shallow_print(); } newline(); sc_exit(1); } else fatal(msg); /* Not initialized, or loop */ } /***************** * Lexical scanner */ /* Initial buffer allocation for token types that need it */ #define DEFAULT_LEXBUF_SIZE 32 static value lexeme_length; static void lexbuf_init(void) { lexeme_length = 0; R_LEXEME = make_string_uninit(DEFAULT_LEXBUF_SIZE); } static void lexbuf_append(uchar c) { value buf_length = string_len(R_LEXEME); if (lexeme_length == buf_length) { value new_length = buf_length * 2; if (new_length > EXT_LENGTH_MAX) { new_length = EXT_LENGTH_MAX; if (lexeme_length == new_length) sc_error("token too long"); } value new_buf = make_string_uninit(new_length); memcpy(string_buf(new_buf), string_buf(R_LEXEME), buf_length); R_LEXEME = new_buf; } string_buf(R_LEXEME)[lexeme_length] = c; lexeme_length++; } static void lexbuf_done(void) { string_truncate(R_LEXEME, lexeme_length); } static int is_letter(int c) { return (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z'); } static int is_digit(int c) { return (c >= '0' && c <= '9'); } static int in_str(int c, const char *s) { for (; *s; s++) if (*s == c) return 1; return 0; } static int is_whitespace(int c) { return in_str(c, " \t\n\f\r"); } static int is_delimiter(int c) { return c == EOF || in_str(c, " \t\n\f\r()\";"); } static int is_special_initial(int c) { return in_str(c, "!$%&*/:<=>?^_~"); } static int is_special_subsequent(int c) { return in_str(c, "+-.@"); } typedef enum { tok_eof, tok_literal, tok_open_paren, tok_close_paren, tok_dot, tok_open_vector, tok_identifier, tok_named_char, tok_abbrev, tok_number, } token_type; typedef enum { lex_start, lex_comment, lex_sharp, lex_bool, lex_comma, lex_dot, lex_dot2, lex_dot3, lex_ident, lex_string, lex_string_escape, lex_char, lex_char2, lex_named_char, lex_plus, lex_minus, lex_number, } lexer_state; /* Finite state machine to read a token from R_PORT. Returns the token type and * sets R_LEXEME to the value, if applicable: the expanded symbol for the * quoting abbreviations, and a string for identifiers, named characters, and * numbers. */ static token_type read_token(void) { lexer_state state = lex_start; uchar saved_char = 0; R_LEXEME = SC_NULL; #define TRANSITION(s) { state = s; continue; } #define PUT_BACK put_back_char(c) for (;;) { int c; value cv = read_char(R_PORT); c = (cv == SC_EOF) ? EOF : char_val(cv); switch (state) { case lex_start: switch (c) { case EOF: return tok_eof; case '(': return tok_open_paren; case ')': return tok_close_paren; case '\'': R_LEXEME = s_quote; return tok_abbrev; case '`': R_LEXEME = s_quasiquote; return tok_abbrev; case '#': TRANSITION(lex_sharp); case ',': TRANSITION(lex_comma); case '.': TRANSITION(lex_dot); case ';': TRANSITION(lex_comment); case '"': lexbuf_init(); TRANSITION(lex_string); case '+': TRANSITION(lex_plus); case '-': TRANSITION(lex_minus); default: if (is_whitespace(c)) continue; lexbuf_init(); if (is_letter(c) || is_special_initial(c)) { lexbuf_append(lc(c)); TRANSITION(lex_ident); } if (is_digit(c)) { lexbuf_append(c); TRANSITION(lex_number); } sc_error1("bad character at start of token:", character(c)); } case lex_comment: if (c == '\n') TRANSITION(lex_start); if (c == EOF) return tok_eof; continue; case lex_sharp: switch (lc(c)) { case '(': return tok_open_vector; case 't': R_LEXEME = SC_TRUE; TRANSITION(lex_bool); case 'f': R_LEXEME = SC_FALSE; TRANSITION(lex_bool); case 'e': case 'i': case 'b': case 'o': case 'd': case 'x': lexbuf_init(); lexbuf_append('#'); lexbuf_append(c); TRANSITION(lex_number); case '\\': TRANSITION(lex_char); default: sc_error("bad # sequence"); } case lex_bool: PUT_BACK; if (!is_delimiter(c)) sc_error("bad # sequence"); return tok_literal; case lex_comma: if (c == '@') { R_LEXEME = s_unquote_splicing; return tok_abbrev; } PUT_BACK; R_LEXEME = s_unquote; return tok_abbrev; case lex_dot: if (is_delimiter(c)) { PUT_BACK; return tok_dot; } if (c == '.') TRANSITION(lex_dot2); lexbuf_init(); lexbuf_append('.'); lexbuf_append(c); TRANSITION(lex_number); case lex_dot2: if (c != '.') { PUT_BACK; sc_error("bad . sequence"); } TRANSITION(lex_dot3); case lex_dot3: PUT_BACK; if (is_delimiter(c)) { R_LEXEME = string("..."); return tok_identifier; } sc_error("bad . sequence"); case lex_ident: if (is_letter(c) || is_special_initial(c) || is_digit(c) || is_special_subsequent(c)) { lexbuf_append(lc(c)); continue; } PUT_BACK; if (is_delimiter(c)) { lexbuf_done(); return tok_identifier; } sc_error("bad identifier"); case lex_string: switch (c) { case EOF: sc_error("unexpected end-of-file in string"); case '"': lexbuf_done(); return tok_literal; case '\\': TRANSITION(lex_string_escape); default: lexbuf_append(c); continue; } case lex_string_escape: switch (c) { case EOF: sc_error("unexpected end-of-file in string"); case '"': case '\\': lexbuf_append(c); TRANSITION(lex_string); default: sc_error("bad escape in string"); } case lex_char: if (c == EOF) sc_error("unexpected end-of-file in character"); saved_char = c; TRANSITION(lex_char2); case lex_char2: if (is_delimiter(c)) { PUT_BACK; R_LEXEME = character(saved_char); return tok_literal; } lexbuf_init(); lexbuf_append(lc(saved_char)); lexbuf_append(lc(c)); TRANSITION(lex_named_char); case lex_named_char: if (is_delimiter(c)) { PUT_BACK; lexbuf_done(); return tok_named_char; } lexbuf_append(lc(c)); continue; case lex_plus: if (is_delimiter(c)) { PUT_BACK; R_LEXEME = string("+"); return tok_identifier; } lexbuf_init(); lexbuf_append('+'); lexbuf_append(c); TRANSITION(lex_number); case lex_minus: if (is_delimiter(c)) { PUT_BACK; R_LEXEME = string("-"); return tok_identifier; } lexbuf_init(); lexbuf_append('-'); lexbuf_append(c); TRANSITION(lex_number); case lex_number: if (is_delimiter(c)) { PUT_BACK; lexbuf_done(); return tok_number; } lexbuf_append(c); continue; } } } /****************** * Bootstrap reader */ /* Read a value from R_PORT, using a predictive parser for Scheme's LL(1) * grammar (report section 7.1.2). The sole purpose is to parse the compiler * and library code at startup (though this started out as the only reader). * Does not handle named characters or any numeric syntax beyond plain decimal * fixnums. * * O(n) runtime except for symbols, as interning is currently proportional to * the symbol table size for each one. Implemented as subroutines calling on * the Scheme stack, much like the evaluator, so there is no overflow hazard or * nesting depth limit other than available heap space. */ /* Minimal base-10 fixnum decoder */ static value str_to_fixnum(value s) { uchar *p = string_buf(s); value len = string_len(s), neg = 0, acc = 0; if (!len) goto err; if (*p == '-') { neg = 1; --len; ++p; if (!len) goto err; } for (; len; --len, ++p) { if (!is_digit(*p)) goto err; if (acc > FIXNUM_MAX/10) goto err; acc = 10*acc + (*p - '0'); } if (acc > FIXNUM_MAX) goto err; return fixnum(neg ? -acc : acc); err: sc_error("bad number token"); } /* Return addresses */ #define RD_DONE 0 #define RD_LIST_FIRST 1 #define RD_LIST_LOOP 2 #define RD_LIST_DOT 3 #define RD_ABBREV 4 #define RD_VEC_LOOP 5 static value sc_read(void) { token_type t; CALL(datum, RD_DONE); dispatch: switch (pop()) { case RD_DONE: break; datum: t = read_token(); switch (t) { case tok_eof: RETURN(SC_EOF); case tok_literal: RETURN(R_LEXEME); case tok_open_paren: goto list; case tok_close_paren: RETURN(RD_CLOSEPAREN); case tok_dot: RETURN(RD_DOT); case tok_open_vector: goto vector; case tok_identifier: R_CAR = R_LEXEME; RETURN(string_to_symbol()); case tok_named_char: sc_error("named characters unsupported"); case tok_abbrev: goto abbrev; case tok_number: RETURN(str_to_fixnum(R_LEXEME)); } list: CALL(datum, RD_LIST_FIRST); case RD_LIST_FIRST: if (R_RESULT == RD_CLOSEPAREN) RETURN(SC_NULL); if (R_RESULT == RD_DOT) sc_error("dotted list without first item"); if (R_RESULT == SC_EOF) sc_error("unexpected end-of-file in list"); R_CAR = R_RESULT; R_CDR = SC_NULL; R_CAR = cons(); push(); /* list head */ for (;;) { push(); /* list tail */ CALL(datum, RD_LIST_LOOP); case RD_LIST_LOOP: if (R_RESULT == RD_CLOSEPAREN) { drop(); /* list tail */ RETURN(pop()); /* list head */ } if (R_RESULT == RD_DOT) { CALL(datum, RD_LIST_DOT); case RD_LIST_DOT: if (R_RESULT == RD_CLOSEPAREN) sc_error("dotted list without last item"); if (R_RESULT == RD_DOT) sc_error("extra dot in dotted list"); if (R_RESULT == SC_EOF) sc_error("unexpected end-of-file in list"); PUSH(R_RESULT) t = read_token(); R_RESULT = pop(); R_CAR = pop(); /* list tail */ if (t == tok_close_paren) { set_cdr(R_CAR, R_RESULT); RETURN(pop()); /* list head */ } if (t == tok_eof) sc_error("unexpected end-of-file in list"); sc_error("excess item in tail of dotted list"); } if (R_RESULT == SC_EOF) sc_error("unexpected end-of-file in list"); R_CAR = R_RESULT; R_CDR = SC_NULL; R_CAR = cons(); R_CDR = pop(); /* list tail */ set_cdr(R_CDR, R_CAR); } abbrev: /* 'x -> (quote x) etc. */ PUSH(R_LEXEME) /* expanded abbrev symbol */ CALL(datum, RD_ABBREV); case RD_ABBREV: if (R_RESULT == RD_CLOSEPAREN) sc_error("unexpected close-paren in abbreviation"); if (R_RESULT == RD_DOT) sc_error("unexpected dot in abbreviation"); if (R_RESULT == SC_EOF) sc_error("unexpected end-of-file in abbreviation"); R_CAR = R_RESULT; R_CDR = SC_NULL; R_CDR = cons(); R_CAR = pop(); /* expanded abbrev symbol */ RETURN(cons()); vector: /* First build a list */ R_CAR = SC_NULL; for (;;) { push(); /* list head */ CALL(datum, RD_VEC_LOOP); case RD_VEC_LOOP: if (R_RESULT == RD_CLOSEPAREN) { /* Then copy to a new vector while un-reversing */ R_EXPR = pop(); /* list head */ RETURN(rev_list_to_vec()); } if (R_RESULT == RD_DOT) sc_error("unexpected dot in vector"); if (R_RESULT == SC_EOF) sc_error("unexpected end-of-file in vector"); R_CAR = R_RESULT; R_CDR = pop(); /* list head */ R_CAR = cons(); } } if (R_RESULT == RD_CLOSEPAREN) sc_error("unexpected close-paren"); if (R_RESULT == RD_DOT) sc_error("unexpected dot"); return R_RESULT; } /***************** * Number printers */ static char fmt_buf[128]; /* TODO justify size */ static const char *fmt_fixnum_dec(long val) { int i = sizeof(fmt_buf) - 1, neg = 0; /* TODO null termination is convenient here but perhaps not ideal */ fmt_buf[i] = 0; if (val < 0) { neg = 1; val = -val; } do { --i; assert(i); fmt_buf[i] = '0' + (val % 10); val /= 10; } while (val); if (neg) fmt_buf[--i] = '-'; return fmt_buf+i; } static const char *fmt_ulong_dec(ulong val) { int i = sizeof(fmt_buf) - 1; fmt_buf[i] = 0; do { --i; assert(i >= 0); fmt_buf[i] = '0' + (val % 10); val /= 10; } while (val); return fmt_buf+i; } static const char *fmt_fixnum_hex(long val) { int i = sizeof(fmt_buf) - 1, neg = 0; fmt_buf[i] = 0; if (val < 0) { neg = 1; val = -val; } do { --i; assert(i); fmt_buf[i] = "0123456789abcdef"[val & 0xf]; val >>= 4; } while (val); if (neg) fmt_buf[--i] = '-'; return fmt_buf+i; } static const char *fmt_fixnum_oct(long val) { int i = sizeof(fmt_buf) - 1, neg = 0; fmt_buf[i] = 0; if (val < 0) { neg = 1; val = -val; } do { --i; assert(i); fmt_buf[i] = '0' + (val & 7); val >>= 3; } while (val); if (neg) fmt_buf[--i] = '-'; return fmt_buf+i; } static const char *fmt_fixnum_bin(long val) { int i = sizeof(fmt_buf) - 1, neg = 0; fmt_buf[i] = 0; if (val < 0) { neg = 1; val = -val; } do { --i; assert(i); fmt_buf[i] = '0' + (val & 1); val >>= 1; } while (val); if (neg) fmt_buf[--i] = '-'; return fmt_buf+i; } static const char *fmt_ulong_bin(ulong val) { int i = sizeof(fmt_buf) - 1; fmt_buf[i] = 0; do { --i; assert(i); fmt_buf[i] = '0' + (val & 1); val >>= 1; } while (val); return fmt_buf+i; } static const char *fmt_flonum_dec(double val) { /* TODO follow up on R5RS citations 3 and 5 */ if ((size_t)snprintf(fmt_buf, sizeof fmt_buf, "%.15g", val) >= sizeof fmt_buf) sc_error("BUG: flonum formatting truncated"); return fmt_buf; } /**************************** * Fallback (shallow) printer */ /* Print the value in R_EXPR to R_PORT, using "write" style (quoting strings * and characters) but not expanding named characters or looking inside * compound objects. (This used to be the real printer, implemented as * recursive subroutines on the Scheme stack like the reader and evaluator, but * is now just for low-level debug and fallback error handlers.) */ static void shallow_print(void) { int t = tag(R_EXPR); if (t == T_SPECIAL) { const char *s; if (R_EXPR == SC_NULL) s = "()"; else if (R_EXPR == SC_TRUE) s = "#t"; else if (R_EXPR == SC_FALSE) s = "#f"; else if (R_EXPR == SC_EOF) s = "#EOF"; else if (R_EXPR == SC_NULL_ENV) s = "#ENVSPEC:NULL"; else if (R_EXPR == SC_REPORT_ENV) s = "#ENVSPEC:SCHEME-REPORT"; else if (R_EXPR == SC_GSCM_ENV) s = "#ENVSPEC:GALES-SCHEME"; else if (R_EXPR == SC_INTERACT_ENV) s = "#ENVSPEC:INTERACTION"; else if (R_EXPR == SC_TOPLEVEL_ENV) s = "#ENVSPEC:TOPLEVEL"; else if (R_EXPR == UNDEFINED) s = "#UNDEFINED"; else if (R_EXPR == RD_CLOSEPAREN) s = "#RDSENTINEL:CLOSEPAREN"; else if (R_EXPR == RD_DOT) s = "#RDSENTINEL:DOT"; else fatal("BUG: invalid special in shallow_print"); write_cstr(s); } else if (t == T_IMMUT_PAIR) write_cstr("#IMMUTABLE-PAIR"); else if (t == T_PAIR) write_cstr("#PAIR"); else if (t == T_CHARACTER) { write_cstr("#\\"); write_char(R_EXPR); } else if (t == T_FIXNUM) write_cstr(fmt_fixnum_dec(fixnum_val(R_EXPR))); else if (t == T_EXTENDED) { t = ext_tag(heap[untag(R_EXPR)]); if ((t | 1) == T_STRING) write_str_quoted(R_EXPR); else if ((t | 1) == T_VECTOR) { if (t == T_VECTOR) write_cstr("#VECTOR:"); else write_cstr("#IMMUTABLE-VECTOR:"); write_cstr(fmt_fixnum_dec(vector_len(R_EXPR))); } else if (t == T_SYMBOL) write_str(R_EXPR); else if (t == T_BUILTIN) { write_cstr("#BUILTIN:"); write_cstr(builtin_name(R_EXPR)); } else if (t == T_PROCEDURE) write_cstr("#PROCEDURE"); else if (t == T_CONTINUATION) write_cstr("#CONTINUATION"); else if (t == T_PROMISE) write_cstr("#PROMISE"); else if (t == T_PORT) write_cstr("#PORT"); else if (t == T_FLONUM) write_cstr("#FLONUM"); else if (t == T_BIGNUM) write_cstr("#BIGNUM"); else if (t == T_RATIONAL) write_cstr("#RATIONAL"); else if (t == T_COMPLEX) write_cstr("#COMPLEX"); else if (t == T_VARIABLE_REF) write_cstr("#VARIABLE-REF"); else fatal("BUG: invalid extended tag in shallow_print"); } else fatal("BUG: invalid tag in shallow_print"); } /******************** * Builtin procedures */ /* Argument wrangling helpers for builtins */ static void require_args(value args) { if (args == SC_NULL) sc_error("too few arguments"); } static void no_args(value args) { if (args != SC_NULL) sc_error("too many arguments"); } static value extract_arg(value *args) { require_args(*args); value arg = car(*args); *args = cdr(*args); return arg; } static value final_arg(value args) { require_args(args); no_args(cdr(args)); return car(args); } static value require_input_port(value arg) { if (!is_input_port(arg)) sc_error("not an input port"); return arg; } static value require_output_port(value arg) { if (!is_output_port(arg)) sc_error("not an output port"); return arg; } static value opt_final_in_port_arg(value args) { return require_input_port(args == SC_NULL ? r_input_port : final_arg(args)); } static value opt_final_out_port_arg(value args) { return require_output_port(args == SC_NULL ? r_output_port : final_arg(args)); } static value require_symbol(value arg) { if (!is_symbol(arg)) sc_error1("not a symbol:", arg); return arg; } static value require_string(value arg) { if (!is_string(arg)) sc_error1("not a string:", arg); return arg; } static value require_mutable_string(value arg) { if (!is_mutable_string(arg)) { if (is_string(arg)) sc_error1("immutable string:", arg); sc_error1("not a string:", arg); } return arg; } static value require_stringlike(value arg) { if (!(is_string(arg) || is_symbol(arg))) sc_error1("not a string or symbol:", arg); return arg; } static value require_vector(value arg) { if (!is_vector(arg)) sc_error1("not a vector:", arg); return arg; } static value require_mutable_vector(value arg) { if (!is_mutable_vector(arg)) { if (is_vector(arg)) sc_error1("immutable vector:", arg); sc_error1("not a vector:", arg); } return arg; } static value require_fixnum(value arg) { if (!is_fixnum(arg)) sc_error1("not a fixnum:", arg); return arg; } static value require_procedure(value arg) { if (!is_procedure(arg)) sc_error1("not a procedure:", arg); return arg; } #define BUILTIN(name) static value name(value args) /* Mnemonic for multi-valued returns, i.e. passing multiple values to the * current continuation. f_values is strictly an optimization; we could just as * well set R_PROC to current_continuation() and r_flag to f_apply. * The arg list must be newly allocated! */ #define RETURN_VALUES(args) { \ R_ARGS = args; \ r_flag = f_values; \ return SC_NULL; \ } /* 6.1 Equivalence predicates */ BUILTIN(builtin_is_eq) { value a = extract_arg(&args); return boolean(a == final_arg(args)); } /* 6.2.5 Numerical operations */ BUILTIN(builtin_is_number) { return boolean(is_number(final_arg(args))); } BUILTIN(builtin_is_integer) { return boolean(is_integer(final_arg(args))); } BUILTIN(builtin_is_exact) { return boolean(is_exact(final_arg(args))); } BUILTIN(builtin_is_inexact) { return boolean(is_flonum(final_arg(args))); } /* 6.3.1 Booleans */ BUILTIN(builtin_not) { return boolean(final_arg(args) == SC_FALSE); } BUILTIN(builtin_is_boolean) { return boolean(is_boolean(final_arg(args))); } /* 6.3.2 Pairs and lists */ BUILTIN(builtin_is_pair) { return boolean(is_pair(final_arg(args))); } BUILTIN(builtin_cons) { R_CAR = extract_arg(&args); R_CDR = final_arg(args); return cons(); } BUILTIN(builtin_car) { return safe_car(final_arg(args)); } BUILTIN(builtin_cdr) { return safe_cdr(final_arg(args)); } BUILTIN(builtin_caar) { return safe_car(builtin_car(args)); } BUILTIN(builtin_cadr) { return safe_car(builtin_cdr(args)); } BUILTIN(builtin_cdar) { return safe_cdr(builtin_car(args)); } BUILTIN(builtin_cddr) { return safe_cdr(builtin_cdr(args)); } BUILTIN(builtin_caaar) { return safe_car(builtin_caar(args)); } BUILTIN(builtin_caadr) { return safe_car(builtin_cadr(args)); } BUILTIN(builtin_cadar) { return safe_car(builtin_cdar(args)); } BUILTIN(builtin_caddr) { return safe_car(builtin_cddr(args)); } BUILTIN(builtin_cdaar) { return safe_cdr(builtin_caar(args)); } BUILTIN(builtin_cdadr) { return safe_cdr(builtin_cadr(args)); } BUILTIN(builtin_cddar) { return safe_cdr(builtin_cdar(args)); } BUILTIN(builtin_cdddr) { return safe_cdr(builtin_cddr(args)); } BUILTIN(builtin_caaaar) { return safe_car(builtin_caaar(args)); } BUILTIN(builtin_caaadr) { return safe_car(builtin_caadr(args)); } BUILTIN(builtin_caadar) { return safe_car(builtin_cadar(args)); } BUILTIN(builtin_caaddr) { return safe_car(builtin_caddr(args)); } BUILTIN(builtin_cadaar) { return safe_car(builtin_cdaar(args)); } BUILTIN(builtin_cadadr) { return safe_car(builtin_cdadr(args)); } BUILTIN(builtin_caddar) { return safe_car(builtin_cddar(args)); } BUILTIN(builtin_cadddr) { return safe_car(builtin_cdddr(args)); } BUILTIN(builtin_cdaaar) { return safe_cdr(builtin_caaar(args)); } BUILTIN(builtin_cdaadr) { return safe_cdr(builtin_caadr(args)); } BUILTIN(builtin_cdadar) { return safe_cdr(builtin_cadar(args)); } BUILTIN(builtin_cdaddr) { return safe_cdr(builtin_caddr(args)); } BUILTIN(builtin_cddaar) { return safe_cdr(builtin_cdaar(args)); } BUILTIN(builtin_cddadr) { return safe_cdr(builtin_cdadr(args)); } BUILTIN(builtin_cdddar) { return safe_cdr(builtin_cddar(args)); } BUILTIN(builtin_cddddr) { return safe_cdr(builtin_cdddr(args)); } BUILTIN(builtin_set_car) { value p = extract_arg(&args); value val = final_arg(args); if (tag(p) != T_PAIR) { if (tag(p) == T_IMMUT_PAIR) sc_error("immutable pair"); sc_error("not a pair"); } set_car(p, val); return SC_NULL; } BUILTIN(builtin_set_cdr) { value p = extract_arg(&args); value val = final_arg(args); if (tag(p) != T_PAIR) { if (tag(p) == T_IMMUT_PAIR) sc_error("immutable pair"); sc_error("not a pair"); } set_cdr(p, val); return SC_NULL; } BUILTIN(builtin_is_null) { return boolean(final_arg(args) == SC_NULL); } BUILTIN(builtin_is_list) { return boolean(is_list(final_arg(args))); } BUILTIN(builtin_length) { long len = safe_list_length(final_arg(args)); if (len < 0) sc_error("not a list"); return fixnum(len); } /* 6.3.3 Symbols */ BUILTIN(builtin_is_symbol) { return boolean(is_symbol(final_arg(args))); } BUILTIN(builtin_sym_to_str) { /* TODO use immutability to avoid copying */ R_EXPR = require_symbol(final_arg(args)); return string_copy_immutable(); } BUILTIN(builtin_str_to_sym) { R_CAR = require_string(final_arg(args)); return string_to_symbol(); } /* 6.3.4 Characters */ BUILTIN(builtin_is_char) { return boolean(is_character(final_arg(args))); } #define CHAR1 uchar a = safe_char_val(final_arg(args)); #define CHAR2 uchar a = safe_char_val(extract_arg(&args)); \ uchar b = safe_char_val(final_arg(args)); BUILTIN(builtin_char_eq) { CHAR2 return boolean(a == b); } BUILTIN(builtin_char_lt) { CHAR2 return boolean(a < b); } BUILTIN(builtin_char_gt) { CHAR2 return boolean(a > b); } BUILTIN(builtin_char_le) { CHAR2 return boolean(a <= b); } BUILTIN(builtin_char_ge) { CHAR2 return boolean(a >= b); } BUILTIN(builtin_char_ci_eq) { CHAR2 return boolean(lc(a) == lc(b)); } BUILTIN(builtin_char_ci_lt) { CHAR2 return boolean(lc(a) < lc(b)); } BUILTIN(builtin_char_ci_gt) { CHAR2 return boolean(lc(a) > lc(b)); } BUILTIN(builtin_char_ci_le) { CHAR2 return boolean(lc(a) <= lc(b)); } BUILTIN(builtin_char_ci_ge) { CHAR2 return boolean(lc(a) >= lc(b)); } BUILTIN(builtin_char_is_alpha) { CHAR1 return boolean((a >= 'A' && a <= 'Z') || (a >= 'a' && a <= 'z')); } BUILTIN(builtin_char_is_num) { CHAR1 return boolean(a >= '0' && a <= '9'); } BUILTIN(builtin_char_is_white) { CHAR1 return boolean(is_whitespace(a)); } BUILTIN(builtin_char_is_upper) { CHAR1 return boolean(a >= 'A' && a <= 'Z'); } BUILTIN(builtin_char_is_lower) { CHAR1 return boolean(a >= 'a' && a <= 'z'); } BUILTIN(builtin_char_to_int) { CHAR1 return fixnum(a); } BUILTIN(builtin_int_to_char) { long n = safe_fixnum_val(final_arg(args)); if (n < 0 || n > 255) sc_error1("out of bounds:", fixnum(n)); return character(n); } BUILTIN(builtin_char_upcase) { CHAR1 return character(uc(a)); } BUILTIN(builtin_char_downcase) { CHAR1 return character(lc(a)); } /* 6.3.5 Strings */ BUILTIN(builtin_is_str) { return boolean(is_string(final_arg(args))); } BUILTIN(builtin_make_str) { long len = safe_fixnum_val(extract_arg(&args)); uchar fill = (args == SC_NULL) ? ' ' : safe_char_val(final_arg(args)); return make_string(len, fill); } BUILTIN(builtin_str_length) { return fixnum(string_len(require_string(final_arg(args)))); } BUILTIN(builtin_str_ref) { value s = require_string(extract_arg(&args)); value k = final_arg(args); value k_unsigned = safe_fixnum_val(k); /* see builtin_vec_ref comments */ if (k_unsigned >= string_len(s)) sc_error1("out of bounds:", k); return character(string_buf(s)[k_unsigned]); } BUILTIN(builtin_str_set) { value s = require_mutable_string(extract_arg(&args)); value k = extract_arg(&args); uchar new_char = safe_char_val(final_arg(args)); value k_unsigned = safe_fixnum_val(k); /* see builtin_vec_ref comments */ if (k_unsigned >= string_len(s)) sc_error1("out of bounds:", k); string_buf(s)[k_unsigned] = new_char; return SC_NULL; } #define STR2 value a = require_string(extract_arg(&args)); \ value b = require_string(final_arg(args)); \ size_t a_len = string_len(a), b_len = string_len(b); \ uchar *a_buf = string_buf(a), *b_buf = string_buf(b); BUILTIN(builtin_str_eq) { STR2 if (a_len != b_len) return SC_FALSE; return boolean(memcmp(a_buf, b_buf, a_len) == 0); } #define STRCMP \ STR2 int cmp = memcmp(a_buf, b_buf, (a_len < b_len) ? a_len : b_len); BUILTIN(builtin_str_lt) { STRCMP return boolean(cmp < 0 || (cmp == 0 && a_len < b_len)); } BUILTIN(builtin_str_gt) { STRCMP return boolean(cmp > 0 || (cmp == 0 && a_len > b_len)); } BUILTIN(builtin_str_le) { STRCMP return boolean(cmp < 0 || (cmp == 0 && a_len <= b_len)); } BUILTIN(builtin_str_ge) { STRCMP return boolean(cmp > 0 || (cmp == 0 && a_len >= b_len)); } static int memcmp_ci(const void *s1, const void *s2, size_t n) { const uchar *b1 = s1, *b2 = s2; uchar c1, c2; size_t i; for (i = 0; i < n; i++) { c1 = lc(b1[i]); c2 = lc(b2[i]); if (c1 < c2) return -1; if (c1 > c2) return 1; } return 0; } BUILTIN(builtin_str_ci_eq) { STR2 if (a_len != b_len) return SC_FALSE; return boolean(memcmp_ci(a_buf, b_buf, a_len) == 0); } #define STRCMP_CI STR2 \ int cmp = memcmp_ci(a_buf, b_buf, (a_len < b_len) ? a_len : b_len); BUILTIN(builtin_str_ci_lt) { STRCMP_CI return boolean(cmp < 0 || (cmp == 0 && a_len < b_len)); } BUILTIN(builtin_str_ci_gt) { STRCMP_CI return boolean(cmp > 0 || (cmp == 0 && a_len > b_len)); } BUILTIN(builtin_str_ci_le) { STRCMP_CI return boolean(cmp < 0 || (cmp == 0 && a_len <= b_len)); } BUILTIN(builtin_str_ci_ge) { STRCMP_CI return boolean(cmp > 0 || (cmp == 0 && a_len >= b_len)); } BUILTIN(builtin_substr) { value len = string_len(R_EXPR = require_string(extract_arg(&args))), start = extract_arg(&args), end = final_arg(args), start_unsigned = safe_fixnum_val(start), end_unsigned = safe_fixnum_val(end); if (start_unsigned > len) sc_error1("start out of bounds:", start); if (end_unsigned > len) sc_error1("end out of bounds:", end); if (end_unsigned < start_unsigned) sc_error("end less than start"); len = end_unsigned - start_unsigned; R_RESULT = make_string_uninit(len); memcpy(string_buf(R_RESULT), string_buf(R_EXPR)+start_unsigned, len); return R_RESULT; } BUILTIN(builtin_str_append) { value p, s, len = 0; uchar *buf; R_ARGS = args; for (p = R_ARGS; p != SC_NULL; p = cdr(p)) { len += string_len(require_string(car(p))); if (len > EXT_LENGTH_MAX) sc_error("length too large for string"); } R_RESULT = make_string_uninit(len); buf = string_buf(R_RESULT); for (p = R_ARGS; p != SC_NULL; p = cdr(p)) { s = car(p); len = string_len(s); memcpy(buf, string_buf(s), len); buf += len; } return R_RESULT; } BUILTIN(builtin_list_to_str) { long len, i; value s; uchar *buf; R_ARGS = final_arg(args); len = safe_list_length(R_ARGS); if (len < 0) sc_error("not a list"); s = make_string_uninit(len); buf = string_buf(s); for (i = 0; i < len; i++) { buf[i] = safe_char_val(car(R_ARGS)); R_ARGS = cdr(R_ARGS); } return s; } BUILTIN(builtin_str_copy) { R_EXPR = require_string(final_arg(args)); return string_copy(); } BUILTIN(builtin_str_fill) { value s = require_mutable_string(extract_arg(&args)); memset(string_buf(s), safe_char_val(final_arg(args)), string_len(s)); return SC_NULL; } /* 6.3.6 Vectors */ BUILTIN(builtin_is_vector) { return boolean(is_vector(final_arg(args))); } BUILTIN(builtin_make_vector) { long len = safe_fixnum_val(extract_arg(&args)); R_EXPR = (args == SC_NULL) ? SC_NULL : final_arg(args); return make_vector(len); } BUILTIN(builtin_vec_length) { value vec = require_vector(final_arg(args)); return fixnum(vector_len(vec)); } BUILTIN(builtin_vec_ref) { value vec = require_vector(extract_arg(&args)); value k = final_arg(args); value k_unsigned = safe_fixnum_val(k); if (k_unsigned >= vector_len(vec)) sc_error1("out of bounds:", k); /* We don't need to also check for negative k: as value is an unsigned * type, the assignment from long causes a negative to be seen as a * positive greater than the longest allowed vector length. * XXX: are there weird machines where this isn't true? */ return vector_ref(vec, k_unsigned); } BUILTIN(builtin_vec_set) { value vec = require_mutable_vector(extract_arg(&args)); value k = extract_arg(&args); value obj = final_arg(args); value k_unsigned = safe_fixnum_val(k); if (k_unsigned >= vector_len(vec)) sc_error1("out of bounds:", k); vector_set(vec, k_unsigned, obj); return SC_NULL; } BUILTIN(builtin_list_to_vec) { long len; value vec, *p; R_ARGS = final_arg(args); len = safe_list_length(R_ARGS); if (len < 0) sc_error("not a list"); vec = make_vector_uninit(len); p = heap + untag(vec) + 1; for (; len; --len, ++p, R_ARGS = cdr(R_ARGS)) *p = car(R_ARGS); return vec; } BUILTIN(builtin_vec_fill) { value vec = require_mutable_vector(extract_arg(&args)); value fill = final_arg(args); value len = vector_len(vec), i; for (i = 0; i < len; i++) vector_set(vec, i, fill); return SC_NULL; } /* 6.4 Control features */ BUILTIN(builtin_is_procedure) { return boolean(is_procedure(final_arg(args))); } BUILTIN(builtin_force) { R_EXPR = final_arg(args); r_flag = f_force; return SC_NULL; } BUILTIN(builtin_call_cc) { R_PROC = require_procedure(final_arg(args)); R_CAR = current_continuation(); R_CDR = SC_NULL; R_ARGS = cons(); r_flag = f_apply; return SC_NULL; } BUILTIN(builtin_values) RETURN_VALUES(args) BUILTIN(builtin_call_with_values) { R_PROC = extract_arg(&args); R_ARGS = final_arg(args); r_flag = f_call_with_values; return SC_NULL; } /* 6.5 Eval */ BUILTIN(builtin_eval) { R_EXPR = extract_arg(&args); value e = final_arg(args); switch (e) { case SC_NULL_ENV: R_ENV = SC_NULL; break; case SC_REPORT_ENV: R_ENV = r5rs_env; break; case SC_GSCM_ENV: R_ENV = gscm_env; break; case SC_INTERACT_ENV: R_ENV = interaction_env; break; case SC_TOPLEVEL_ENV: R_ENV = toplevel_env; break; default: sc_error1("not an environment specifier:", e); } r_flag = f_compile; return SC_NULL; } BUILTIN(builtin_report_env) { if (safe_fixnum_val(final_arg(args)) != 5) sc_error("unsupported version"); return SC_REPORT_ENV; } BUILTIN(builtin_null_env) { if (safe_fixnum_val(final_arg(args)) != 5) sc_error("unsupported version"); return SC_NULL_ENV; } BUILTIN(builtin_interaction_env) { no_args(args); return SC_INTERACT_ENV; } /* 6.6.1 Ports */ BUILTIN(builtin_is_port) { return boolean(is_port(final_arg(args))); } BUILTIN(builtin_is_in_port) { return boolean(is_input_port(final_arg(args))); } BUILTIN(builtin_is_out_port) { return boolean(is_output_port(final_arg(args))); } BUILTIN(builtin_current_in_port) { no_args(args); return r_input_port; } BUILTIN(builtin_current_out_port) { no_args(args); return r_output_port; } BUILTIN(builtin_open_in_file) { int fd; R_EXPR = require_string(final_arg(args)); fd = open_cloexec(c_string_buf(string_append_null()), O_RDONLY); if (fd == -1) sc_perror1(R_EXPR); return make_port(fd, 0, DEFAULT_R_BUF); } BUILTIN(builtin_open_out_file) { int fd, flags = O_WRONLY | O_CREAT; value if_exists; R_EXPR = require_string(extract_arg(&args)); if (args == SC_NULL) if_exists = s_truncate; else if_exists = final_arg(args); if (if_exists == s_truncate) flags |= O_TRUNC; else if (if_exists == s_overwrite) ; else if (if_exists == s_append) flags |= O_APPEND; else sc_error("invalid if-exists option"); fd = open_cloexec(c_string_buf(string_append_null()), flags); if (fd == -1) sc_perror1(R_EXPR); return make_port(fd, 1, DEFAULT_W_BUF); } BUILTIN(builtin_close_in_port) { close_port(require_input_port(final_arg(args))); return SC_NULL; } BUILTIN(builtin_close_out_port) { close_port(require_output_port(final_arg(args))); return SC_NULL; } /* 6.6.2 Input */ BUILTIN(builtin_read_char) { return read_char(opt_final_in_port_arg(args)); } BUILTIN(builtin_peek_char) { return peek_char(opt_final_in_port_arg(args)); } BUILTIN(builtin_is_eof) { return boolean(final_arg(args) == SC_EOF); } BUILTIN(builtin_is_char_ready) { return input_port_ready(opt_final_in_port_arg(args)); } /* 6.6.3 Output */ BUILTIN(builtin_write_char) { uchar c = safe_char_val(extract_arg(&args)); R_PORT = opt_final_out_port_arg(args); write_char(c); return SC_NULL; } /* Gales Scheme extensions */ BUILTIN(builtin_gscm_env) { no_args(args); return SC_GSCM_ENV; } BUILTIN(builtin_is_immutable) { return boolean(!is_mutable(final_arg(args))); } BUILTIN(builtin_cons_immutable) { R_CAR = extract_arg(&args); R_CDR = final_arg(args); return cons_immutable(); } BUILTIN(builtin_str_copy_immutable) { R_EXPR = require_string(final_arg(args)); return string_copy_immutable(); } BUILTIN(builtin_vec_copy_immutable) { value len; R_EXPR = require_vector(final_arg(args)); len = vector_len(R_EXPR); R_RESULT = make_immutable_vector(len); memcpy(heap+untag(R_RESULT)+1, heap+untag(R_EXPR)+1, len*sizeof(value)); return R_RESULT; } BUILTIN(builtin_flush_out_port) { value port = require_output_port(args == SC_NULL ? r_output_port : extract_arg(&args)), *p = heap+untag(port); int fd = fixnum_val(p[PORT_FD]); if (fd == -1) sc_error("output port closed"); flush_if_needed(port); if (args != SC_NULL) { value opt = final_arg(args); if (opt == s_sync) { if (fsync(fd)) goto sync_err; } else if (opt == s_data_sync) { if (fdatasync(fd)) goto sync_err; } else sc_error1("invalid option:", opt); } return SC_NULL; sync_err: if (errno == EINVAL) sc_error("synchronization not possible"); else { /* As in flush_output_port: no good way to recover from output errors, * but the kernel won't necessarily continue returning errors, so close * the port. In practice, the mistake of retrying a failed fsync has * caused data loss in PostgreSQL (broken durability guarantee). */ int saved = errno; set_port_closed(p); errno = saved; sc_perror(); } } BUILTIN(builtin_gc) { no_args(args); sc_gc(); return fixnum(free_ptr); } BUILTIN(builtin_is_fixnum) { return boolean(is_fixnum(final_arg(args))); } BUILTIN(builtin_fx_eq) { value a = require_fixnum(extract_arg(&args)); return boolean(a == require_fixnum(final_arg(args))); } BUILTIN(builtin_fx_lt) { long a = safe_fixnum_val(extract_arg(&args)); return boolean(a < safe_fixnum_val(final_arg(args))); } BUILTIN(builtin_fx_le) { long a = safe_fixnum_val(extract_arg(&args)); return boolean(a <= safe_fixnum_val(final_arg(args))); } BUILTIN(builtin_fx_lt_unsigned) { value a = require_fixnum(extract_arg(&args)); return boolean(a < require_fixnum(final_arg(args))); } BUILTIN(builtin_fx_le_unsigned) { value a = require_fixnum(extract_arg(&args)); return boolean(a <= require_fixnum(final_arg(args))); } /* inputs left tagged: valid for wrapping and bitwise ops */ #define FXFOLD(op, init) { \ ulong acc = init; \ for (; args != SC_NULL; args = cdr(args)) \ acc = acc op require_fixnum(car(args)); \ return fixnum(acc); \ } BUILTIN(builtin_fx_add_wrap) FXFOLD(+, 0) BUILTIN(builtin_fx_add_carry) { long acc = untag_signed(require_fixnum(extract_arg(&args))); acc += untag_signed(require_fixnum(extract_arg(&args))); if (args != SC_NULL) acc += untag_signed(require_fixnum(final_arg(args))); R_CDR = SC_NULL; R_CAR = fixnum(acc >> VAL_BITS); /* high word (carry) */ R_CDR = cons(); R_CAR = fixnum(acc); /* low word */ RETURN_VALUES(cons()); } BUILTIN(builtin_fx_add_carry_unsigned) { ulong acc = untag(require_fixnum(extract_arg(&args))); acc += untag(require_fixnum(extract_arg(&args))); if (args != SC_NULL) acc += untag(require_fixnum(final_arg(args))); R_CDR = SC_NULL; R_CAR = fixnum(acc >> VAL_BITS); /* high word (carry) */ R_CDR = cons(); R_CAR = fixnum(acc); /* low word */ RETURN_VALUES(cons()); } BUILTIN(builtin_fx_sub_wrap) { ulong acc = require_fixnum(extract_arg(&args)); if (args == SC_NULL) return fixnum(-acc); do { acc -= require_fixnum(car(args)); args = cdr(args); } while (args != SC_NULL); return fixnum(acc); } BUILTIN(builtin_fx_sub_borrow_unsigned) { ulong acc = untag(require_fixnum(extract_arg(&args))); acc -= untag(require_fixnum(extract_arg(&args))); if (args != SC_NULL) acc -= untag(require_fixnum(final_arg(args))); R_CDR = SC_NULL; R_CAR = fixnum(-(((long)acc) >> VAL_BITS)); R_CDR = cons(); R_CAR = fixnum(acc); RETURN_VALUES(cons()); } BUILTIN(builtin_fx_mul_wrap) FXFOLD(*, 1) BUILTIN(builtin_fx_mul_carry) { ulong a = untag_signed(require_fixnum(extract_arg(&args))); ulong b = untag_signed(require_fixnum(final_arg(args))); sc_wide_mul_signed(&a, &b); R_CDR = SC_NULL; R_CAR = fixnum(b << TAG_BITS | tag(a)); /* high word */ R_CDR = cons(); R_CAR = fixnum(a); /* low word */ RETURN_VALUES(cons()); } BUILTIN(builtin_fx_mul_carry_unsigned) { ulong a = untag(require_fixnum(extract_arg(&args))); ulong b = untag(require_fixnum(final_arg(args))); sc_wide_mul(&a, &b); R_CDR = SC_NULL; R_CAR = fixnum(b << TAG_BITS | tag(a)); /* high word */ R_CDR = cons(); R_CAR = fixnum(a); /* low word */ RETURN_VALUES(cons()); } BUILTIN(builtin_fxnot) { return fixnum(~require_fixnum(final_arg(args))); } BUILTIN(builtin_fxand) FXFOLD(&, -1) BUILTIN(builtin_fxior) FXFOLD(|, 0) BUILTIN(builtin_fxxor) FXFOLD(^, 0) BUILTIN(builtin_fxif) { ulong mask = require_fixnum(extract_arg(&args)); ulong a = require_fixnum(extract_arg(&args)); ulong b = require_fixnum(final_arg(args)); return fixnum(b ^ (mask & (a ^ b))); /* equivalent to (mask & a) | (~mask & b) */ } BUILTIN(builtin_fxmaj) { ulong a = require_fixnum(extract_arg(&args)); ulong b = require_fixnum(extract_arg(&args)); ulong c = require_fixnum(final_arg(args)); return fixnum((a & (b | c)) | (b & c)); /* equivalent to (a & b) | (a & c) | (b & c) */ } BUILTIN(builtin_fxshift) { long a = untag_signed(require_fixnum(extract_arg(&args))); long bits = untag_signed(require_fixnum(final_arg(args))); if (bits < 0) { if (bits <= -VAL_BITS) bits = -VAL_BITS+1; a >>= -bits; } else { if (bits >= VAL_BITS) a = 0; else a <<= bits; } return fixnum(a); } BUILTIN(builtin_fxshift_unsigned) { ulong a = require_fixnum(extract_arg(&args)); long bits = untag_signed(require_fixnum(final_arg(args))); if (bits < 0) { if (bits <= -VAL_BITS) a = 0; else a = untag(a) >> -bits; } else { if (bits >= VAL_BITS) a = 0; else a <<= bits; } return fixnum(a); } BUILTIN(builtin_fxlength_unsigned) { /* TODO check existing interface alternatives */ return fixnum(sc_bit_length(untag(require_fixnum(final_arg(args))))); } /** (open-subprocess PROGRAM . ARGS) -> (values PID IN-PORT OUT-PORT) * * Executes PROGRAM in a Unix subprocess with the given arguments, returning * its process ID along with input and output ports piped to its standard * output and input streams respectively. Does not redirect standard error. By * convention, the first ARG should be the executable filename. * * This is intended to be fast and hygienic: it does not invoke the system * shell, perform a PATH search, pass through environment variables, or leak * file descriptors associated with ports previously opened in Scheme. * * Signals an error if a system-defined limit is reached, per fork(2) (or any * argument is not a string). * * The type of the returned PID is not specified, but must be composed of * standard types with unambiguous external representation. * * See also: wait-subprocess */ BUILTIN(builtin_open_subprocess) { value n_args = 0, i; char *path, **argv, *envp[] = {NULL}; pid_t pid; int out_pipe[2], in_pipe[2]; require_args(args); r1 = args; /* begin allocation: null-terminated strings and argv */ for (r2 = r1; r2 != SC_NULL; r2 = cdr(r2)) { R_EXPR = require_string(car(r2)); R_EXPR = string_append_null(); set_car(r2, R_EXPR); n_args++; } n_args--; /* program path not counted as argument */ /* Caution: allocating C blob on the Scheme heap. Must not be reachable * from the roots, which in turn excludes further allocation while it's in * use. */ argv = (void*)&heap[sc_malloc(n_args+1)]; /* end allocation */ path = c_string_buf(car(r1)); r1 = cdr(r1); /* program args */ for (i = 0; i < n_args; i++) { argv[i] = c_string_buf(car(r1)); r1 = cdr(r1); } argv[i] = NULL; if (pipe_cloexec(out_pipe)) goto err1; if (pipe_cloexec(in_pipe)) goto err2; /* Use vfork so child creation can be fast, and possible on non-overcommit * systems, even when parent is large. Any signal handlers must not corrupt * the parent if invoked in the child. See http://ewontfix.com/7/. */ if ((pid = vfork()) == -1) goto err3; if (!pid) { /* child */ while (dup2(out_pipe[0], 0) == -1) if (errno != EINTR) _exit(errno); while (dup2(in_pipe[1], 1) == -1) if (errno != EINTR) _exit(errno); execve(path, argv, envp); _exit(errno); } blind_close(out_pipe[0]); blind_close(in_pipe[1]); /* resume allocation */ R_CDR = SC_NULL; R_CAR = make_port(out_pipe[1], 1, DEFAULT_W_BUF); R_CDR = cons(); R_CAR = make_port(in_pipe[0], 0, DEFAULT_R_BUF); R_CDR = cons(); R_CAR = string(fmt_ulong_dec(pid)); /* ^ pid_t can't be guaranteed to fit in a fixnum, so stringify. I can't * quite decipher POSIX here but it seems safe to assume it fits in a long * and is positive on success. */ RETURN_VALUES(cons()); err3: blind_close(in_pipe[0]); blind_close(in_pipe[1]); err2: blind_close(out_pipe[0]); blind_close(out_pipe[1]); err1: sc_perror(); } /** (wait-subprocess [PID]) -> STATUS * * Blocks until a subprocess has terminated, releases the associated resources, * and returns either the nonnegative integer exit status for normal exit or * the negative signal number for termination by signal. * * PID identifies the process to wait for; it must compare "equal?" to a PID * previously returned by open-subprocess for which status has not yet been * retrieved. If omitted, any subprocess is waited for. */ BUILTIN(builtin_wait_subprocess) { int status; pid_t pid; if (args == SC_NULL) pid = -1; else { /* dedicated parser for stringified PIDs (see above), yuck */ value s = require_string(final_arg(args)); value len = string_len(s), i; const uchar *b = string_buf(s); ulong acc = 0; if (!len) goto invalid; for (i = 0; i < len; i++) { uchar digit = b[i] - '0'; if (digit > 9) goto invalid; if (acc > ULONG_MAX/10) goto invalid; acc *= 10; if (acc + digit < acc) goto invalid; acc += digit; } pid = acc; if ((ulong)pid != acc || pid < 0) goto invalid; goto start; invalid: sc_error1("invalid PID:", s); } start: if (waitpid(pid, &status, 0) == -1) { if (errno == EINTR) goto start; sc_perror(); } if (WIFEXITED(status)) return fixnum(WEXITSTATUS(status)); if (WIFSIGNALED(status)) return fixnum(-WTERMSIG(status)); sc_error("unknown status type"); /* shouldn't happen */ } BUILTIN(builtin_read_token) { R_PORT = opt_final_in_port_arg(args); switch (read_token()) { case tok_eof: return SC_EOF; case tok_literal: R_CAR = s_literal; break; case tok_open_paren: R_CAR = s_open_paren; break; case tok_close_paren: R_CAR = s_close_paren; break; case tok_dot: R_CAR = s_dot; break; case tok_open_vector: R_CAR = s_open_vector; break; case tok_identifier: R_CAR = s_identifier; break; case tok_named_char: R_CAR = s_named_char; break; case tok_abbrev: R_CAR = s_abbrev; break; case tok_number: R_CAR = s_number; break; } R_CDR = R_LEXEME; return cons(); } BUILTIN(builtin_write_string) { value s = extract_arg(&args); R_PORT = opt_final_out_port_arg(args); write_str(require_stringlike(s)); return SC_NULL; } BUILTIN(builtin_write_string_quoted) { value s = extract_arg(&args); R_PORT = opt_final_out_port_arg(args); write_str_quoted(require_stringlike(s)); return SC_NULL; } /* Private builtins exposed to the toplevel and compiler only */ #define assert_args(n) (assert(list_length(args) == (n))) /* Debug access to the privileged environment */ BUILTIN(builtin_toplevel_env) { no_args(args); return SC_TOPLEVEL_ENV; } /* (define-r5rs symbol obj) * * Binds a variable in the otherwise immutable (scheme-report-environment 5) * as well as the interaction environment. */ BUILTIN(builtin_define_r5rs) { R_CAR = R_VARNAME = require_symbol(extract_arg(&args)); R_CDR = R_EXPR = final_arg(args); assert(global_frame_lookup(R_CAR, car(r5rs_env)) == SC_FALSE); assert(global_frame_lookup(R_CAR, car(interaction_env)) == SC_FALSE); R_ENV = r5rs_env; extend_global_env(); R_CAR = R_VARNAME; R_CDR = R_EXPR; R_ENV = interaction_env; extend_global_env(); return SC_NULL; } /* (define-gscm symbol obj) * * Binds a variable in the otherwise immutable (gales-scheme-environment) as * well as the interaction environment. */ BUILTIN(builtin_define_gscm) { value binding; R_VARNAME = require_symbol(extract_arg(&args)); R_EXPR = final_arg(args); assert(global_frame_lookup(R_VARNAME, car(r5rs_env)) == SC_FALSE); /* need to be able to upgrade ERROR on startup */ binding = global_frame_lookup(R_VARNAME, car(gscm_env)); if (binding == SC_FALSE) { R_CAR = R_VARNAME; R_CDR = R_EXPR; R_ENV = gscm_env; extend_global_env(); } else set_cdr(binding, R_EXPR); binding = global_frame_lookup(R_VARNAME, car(interaction_env)); if (binding == SC_FALSE) { R_CAR = R_VARNAME; R_CDR = R_EXPR; R_ENV = interaction_env; extend_global_env(); } else set_cdr(binding, R_EXPR); return SC_NULL; } BUILTIN(builtin_set_in_port) { r_input_port = require_input_port(final_arg(args)); return SC_NULL; } BUILTIN(builtin_set_out_port) { r_output_port = require_output_port(final_arg(args)); return SC_NULL; } BUILTIN(builtin_push_winding) { err_context = "dynamic-wind"; R_CAR = args; require_procedure(extract_arg(&args)); set_cdr(R_CAR, require_procedure(final_arg(args))); R_CDR = r_spool; r_spool = cons(); return SC_NULL; } BUILTIN(builtin_variable_ref) { R_CAR = car(args); assert(cdr(args) == SC_NULL); return make_variable_ref(); } BUILTIN(builtin_apply_unchecked) { assert_args(2); R_PROC = car(args); R_ARGS = cadr(args); r_flag = f_apply; return SC_NULL; } BUILTIN(builtin_car_unchecked) { assert_args(1); return car(car(args)); } BUILTIN(builtin_cdr_unchecked) { assert_args(1); return cdr(car(args)); } BUILTIN(builtin_set_car_unchecked) { assert_args(2); set_car(car(args), cadr(args)); return SC_NULL; } BUILTIN(builtin_set_cdr_unchecked) { assert_args(2); set_cdr(car(args), cadr(args)); return SC_NULL; } BUILTIN(builtin_str_ref_unchecked) { assert_args(2); return character( string_buf(car(args))[fixnum_val(cadr(args))]); } BUILTIN(builtin_vec_ref_unchecked) { assert_args(2); return vector_ref(car(args), fixnum_val(cadr(args))); } BUILTIN(builtin_fx_add_unchecked) { assert_args(2); return fixnum(unsigned_fixnum_val(car(args)) + unsigned_fixnum_val(cadr(args))); } BUILTIN(builtin_fx_sub_unchecked) { assert_args(2); return fixnum(unsigned_fixnum_val(car(args)) - unsigned_fixnum_val(cadr(args))); } BUILTIN(builtin_fx_eq_unchecked) { assert_args(2); assert(is_fixnum(car(args)) && is_fixnum(cadr(args))); return boolean(car(args) == cadr(args)); } BUILTIN(builtin_fx_lt_unchecked) { assert_args(2); return boolean(fixnum_val(car(args)) < fixnum_val(cadr(args))); } BUILTIN(builtin_fx_le_unchecked) { assert_args(2); return boolean(fixnum_val(car(args)) <= fixnum_val(cadr(args))); } BUILTIN(builtin_fx_neg_unchecked) { assert_args(1); return fixnum(-fixnum_val(car(args))); } BUILTIN(builtin_is_fx_neg_unchecked) { assert_args(1); return boolean(fixnum_val(car(args)) < 0); } BUILTIN(builtin_fx_div_unsigned_unchecked) { /* unsigned as / and % are implementation-defined on negatives */ ulong a, b, q; assert_args(2); a = unsigned_fixnum_val(car(args)); b = unsigned_fixnum_val(cadr(args)); assert(b != 0); /* the compiler had better recognize this as one division... */ q = a/b; a = a%b; R_CDR = SC_NULL; R_CAR = fixnum(a); R_CDR = cons(); R_CAR = fixnum(q); RETURN_VALUES(cons()); } BUILTIN(builtin_fx_div_ext_unsigned_unchecked) { /* unsigned as / and % are implementation-defined on negatives */ ulong a_lo, a_hi, b; assert_args(3); a_lo = unsigned_fixnum_val(car(args)); args = cdr(args); a_hi = unsigned_fixnum_val(car(args)); args = cdr(args); b = unsigned_fixnum_val(car(args)); assert(b > a_hi); /* so quotient fits in fixnum */ a_lo |= a_hi << VAL_BITS; a_hi >>= TAG_BITS; sc_div_extended(&a_lo, &a_hi, b); R_CDR = SC_NULL; R_CAR = fixnum(a_lo); /* remainder */ R_CDR = cons(); R_CAR = fixnum(a_hi); /* quotient */ RETURN_VALUES(cons()); } BUILTIN(builtin_fixnum_to_dec_unchecked) { assert_args(1); return string(fmt_fixnum_dec(fixnum_val(car(args)))); } BUILTIN(builtin_fixnum_to_hex_unchecked) { assert_args(1); return string(fmt_fixnum_hex(fixnum_val(car(args)))); } BUILTIN(builtin_fixnum_to_oct_unchecked) { assert_args(1); return string(fmt_fixnum_oct(fixnum_val(car(args)))); } BUILTIN(builtin_fixnum_to_bin_unchecked) { assert_args(1); return string(fmt_fixnum_bin(fixnum_val(car(args)))); } BUILTIN(builtin_fixnum_to_bin_unsigned_unchecked) { assert_args(1); return string(fmt_ulong_bin(unsigned_fixnum_val(car(args)))); } BUILTIN(builtin_flonum_to_dec_unchecked) { assert_args(1); return string(fmt_flonum_dec(flonum_val(car(args)))); } /* Minimal error builtin to be replaced on startup, e.g. in case of compile * errors in the toplevel */ BUILTIN(builtin_error) { value msg = require_string(extract_arg(&args)); R_PORT = stdout_port; write_cstr("ERROR [startup]: "); write_str(msg); if (args != SC_NULL) { write_char(' '); R_EXPR = car(args); shallow_print(); } newline(); sc_exit(1); } BUILTIN(builtin_set_err_cont) { value h = final_arg(args); if (!is_continuation(h)) sc_error("not a continuation"); r_error_cont = h; return SC_NULL; } BUILTIN(builtin_socket_ports) { make_socket_ports(safe_fixnum_val(final_arg(args)), DEFAULT_R_BUF, DEFAULT_W_BUF); R_CDR = SC_NULL; R_CAR = r1; R_CDR = cons(); R_CAR = r0; RETURN_VALUES(cons()); } static union { struct sockaddr sa; struct sockaddr_in sin; struct sockaddr_un sun; } sa; static socklen_t sa_len; /* Fill sa/sa_len from a Scheme IPv4 address structure */ static void build_sockaddr_in(value addr) { value ip = require_vector(safe_car(addr)), port = safe_fixnum_val(safe_car(cdr(addr))), i, byte; uchar *port_buf = (uchar *)&sa.sin.sin_port, *addr_buf = (uchar *)&sa.sin.sin_addr; if (port > 65535) sc_error1("port number out of range:", car(cdr(addr))); memset(&sa.sin, 0, sizeof sa.sin); sa.sin.sin_family = AF_INET; port_buf[0] = port >> 8; port_buf[1] = port & 0xFF; if (vector_len(ip) != 4) sc_error("bad address length"); for (i = 0; i < 4; ++i) { byte = safe_fixnum_val(vector_ref(ip, i)); if (byte > 255) sc_error1("address byte out of range:", vector_ref(ip, i)); addr_buf[i] = byte; } sa_len = sizeof sa.sin; } /* Fill sa/sa_len from a Scheme Unix-domain address structure (string) */ static void build_sockaddr_un(value addr) { value path = require_string(addr), len = string_len(path), i; uchar *buf = string_buf(path); if (len > sizeof sa.sun.sun_path) sc_error("oversize pathname"); /* initial NUL allowed for Linux abstract sockets */ if (len && buf[0]) for (i = 1; i < len; i++) if (!buf[i]) sc_error("NUL byte in pathname"); memset(&sa.sun, 0, sizeof sa.sun); sa.sun.sun_family = AF_UNIX; memcpy(&sa.sun.sun_path, string_buf(path), len); sa_len = offsetof(struct sockaddr_un, sun_path) + len; } /* Construct immutable Scheme address structure from a struct sockaddr_* in * sa/sa_len. Side effects: R_CAR R_CDR */ static value parse_sockaddr(void) { if (sa.sa.sa_family == AF_INET) { int i; uchar *port_buf = (uchar *)&sa.sin.sin_port, *addr_buf = (uchar *)&sa.sin.sin_addr; R_CDR = SC_NULL; R_CAR = fixnum((port_buf[0] << 8) + port_buf[1]); R_CDR = cons_immutable(); R_CAR = make_immutable_vector(4); for (i = 0; i < 4; ++i) vector_set(R_CAR, i, fixnum(addr_buf[i])); return cons_immutable(); } else if (sa.sa.sa_family == AF_UNIX) { value path, path_len; if (sa_len > sizeof sa.sun) sc_error("oversize pathname?!"); /* XXX Linuxism; the data returned for unnamed sockets is unspecified * in the standards */ if (sa_len == sizeof(sa_family_t)) return SC_FALSE; /* Possible somewhere? */ if (sa_len <= offsetof(struct sockaddr_un, sun_path)) return SC_FALSE; path_len = sa_len - offsetof(struct sockaddr_un, sun_path); /* Some implementations are so rude as to append a trailing NUL and * include it in the length. But a singular NUL is a valid abstract * socket name on Linux. */ if (path_len > 1 && sa.sun.sun_path[0] && !sa.sun.sun_path[path_len-1]) --path_len; path = make_immutable_string(path_len); memcpy(string_buf(path), sa.sun.sun_path, path_len); return path; } sc_error("unknown address family"); } static value unbound_socket(int domain, int type) { return fixnum(chkp(socket(domain, type, 0))); } static value bound_socket(int domain, int type, int reuse) { int fd = chkp(socket(domain, type, 0)); if (setsockopt(fd, SOL_SOCKET, SO_REUSEADDR, &reuse, sizeof reuse) || bind(fd, &sa.sa, sa_len)) { blind_close(fd); sc_perror(); } return fixnum(fd); } BUILTIN(builtin_inet_stream_sock) { if (args != SC_NULL) { build_sockaddr_in(final_arg(args)); return bound_socket(AF_INET, SOCK_STREAM, 0); } return unbound_socket(AF_INET, SOCK_STREAM); } BUILTIN(builtin_inet_dgram_sock) { if (args != SC_NULL) { build_sockaddr_in(final_arg(args)); return bound_socket(AF_INET, SOCK_DGRAM, 0); } return unbound_socket(AF_INET, SOCK_DGRAM); } BUILTIN(builtin_unix_stream_sock) { if (args != SC_NULL) { build_sockaddr_un(final_arg(args)); return bound_socket(AF_UNIX, SOCK_STREAM, 0); } return unbound_socket(AF_UNIX, SOCK_STREAM); } BUILTIN(builtin_unix_dgram_sock) { if (args != SC_NULL) { build_sockaddr_un(final_arg(args)); return bound_socket(AF_UNIX, SOCK_DGRAM, 0); } return unbound_socket(AF_UNIX, SOCK_DGRAM); } BUILTIN(builtin_getsockname) { uint fd = safe_fixnum_val(final_arg(args)); sa_len = sizeof sa; chkp(getsockname(fd, &sa.sa, &sa_len)); return parse_sockaddr(); } BUILTIN(builtin_getpeername) { uint fd = safe_fixnum_val(final_arg(args)); sa_len = sizeof sa; chkp(getpeername(fd, &sa.sa, &sa_len)); return parse_sockaddr(); } BUILTIN(builtin_connect_inet) { uint fd = safe_fixnum_val(extract_arg(&args)); build_sockaddr_in(final_arg(args)); chkp(connect(fd, &sa.sa, sa_len)); return SC_NULL; } BUILTIN(builtin_connect_unix) { uint fd = safe_fixnum_val(extract_arg(&args)); build_sockaddr_un(final_arg(args)); chkp(connect(fd, &sa.sa, sa_len)); return SC_NULL; } BUILTIN(builtin_listen) { uint fd = safe_fixnum_val(extract_arg(&args)); long backlog = safe_fixnum_val(final_arg(args)); if (backlog < 0) sc_error("negative backlog"); if (backlog > INT_MAX) backlog = INT_MAX; chkp(listen(fd, backlog)); return SC_NULL; } BUILTIN(builtin_accept) { uint fd = safe_fixnum_val(final_arg(args)); return fixnum(chkp(accept(fd, 0, 0))); } BUILTIN(builtin_close) { chkp(close(safe_fixnum_val(final_arg(args)))); return SC_NULL; } BUILTIN(builtin_is_flonum) { return boolean(is_flonum(final_arg(args))); } /* NB: "if the value being converted is in the range of values that can be * represented but cannot be represented exactly, the result is either the * nearest higher or nearest lower value, chosen in an implementation-defined * manner." -C89 */ BUILTIN(builtin_flonum_unchecked) { assert_args(1); return flonum(fixnum_val(car(args))); } BUILTIN(builtin_flonum_unsigned_unchecked) { assert_args(1); return flonum(unsigned_fixnum_val(car(args))); } BUILTIN(builtin_flo_eq_unchecked) { assert_args(2); return boolean(flonum_val(car(args)) == flonum_val(cadr(args))); } BUILTIN(builtin_flo_lt_unchecked) { assert_args(2); return boolean(flonum_val(car(args)) < flonum_val(cadr(args))); } BUILTIN(builtin_flo_le_unchecked) { assert_args(2); return boolean(flonum_val(car(args)) <= flonum_val(cadr(args))); } BUILTIN(builtin_flo_neg_unchecked) { assert_args(1); return flonum(-flonum_val(car(args))); } BUILTIN(builtin_is_flo_neg_unchecked) { assert_args(1); return boolean(flonum_val(car(args)) < 0); } #define FLONUM_OP2(op) { \ assert_args(2); \ return flonum(flonum_val(car(args)) op flonum_val(cadr(args))); \ } BUILTIN(builtin_flo_add_unchecked) FLONUM_OP2(+) BUILTIN(builtin_flo_sub_unchecked) FLONUM_OP2(-) BUILTIN(builtin_flo_mul_unchecked) FLONUM_OP2(*) BUILTIN(builtin_flo_div_unchecked) FLONUM_OP2(/) BUILTIN(builtin_flo_quotient_unchecked) { assert_args(2); return flonum(trunc(flonum_val(car(args)) / flonum_val(cadr(args)))); } BUILTIN(builtin_flo_remainder_unchecked) { double a, b; assert_args(2); a = flonum_val(car(args)); b = flonum_val(cadr(args)); return flonum(a < 0 ? -fmod(-a, fabs(b)) : fmod(a, fabs(b))); } BUILTIN(builtin_frac_exp_unchecked) { int e; double frac; assert_args(1); frac = frexp(flonum_val(car(args)), &e); R_CDR = SC_NULL; R_CAR = fixnum(e); R_CDR = cons(); R_CAR = flonum(frac); RETURN_VALUES(cons()); } BUILTIN(builtin_load_exp_unchecked) { assert_args(2); return flonum(ldexp(flonum_val(car(args)), fixnum_val(cadr(args)))); } BUILTIN(builtin_is_inf_unchecked) { double d; assert_args(1); d = flonum_val(car(args)); return boolean(d == HUGE_VAL || d == -HUGE_VAL); } BUILTIN(builtin_flo_to_fix_unchecked) { double d; assert_args(1); d = flonum_val(car(args)); assert(fabs(d) <= (double)(1L << VAL_BITS)); /* ^ Catches overflow of double to long conversion, which is UB, though * not of long to fixnum (how tight the check can be made is not yet clear * to me.) */ return fixnum(d); } #define MATH_FUNC(f) { \ assert_args(1); return flonum(f(flonum_val(car(args)))); \ } BUILTIN(builtin_floor) MATH_FUNC(floor) BUILTIN(builtin_ceiling) MATH_FUNC(ceil) BUILTIN(builtin_truncate) MATH_FUNC(trunc) BUILTIN(builtin_round) MATH_FUNC(nearbyint) BUILTIN(builtin_exp) MATH_FUNC(exp) BUILTIN(builtin_log) MATH_FUNC(log) BUILTIN(builtin_sin) MATH_FUNC(sin) BUILTIN(builtin_cos) MATH_FUNC(cos) BUILTIN(builtin_tan) MATH_FUNC(tan) BUILTIN(builtin_asin) MATH_FUNC(asin) BUILTIN(builtin_acos) MATH_FUNC(acos) BUILTIN(builtin_atan) MATH_FUNC(atan) BUILTIN(builtin_atan2) { assert_args(2); return flonum(atan2(flonum_val(car(args)), flonum_val(cadr(args)))); } BUILTIN(builtin_sqrt) MATH_FUNC(sqrt) BUILTIN(builtin_rev_list_to_vec_unchecked) { assert_args(1); R_EXPR = car(args); return rev_list_to_vec(); } BUILTIN(builtin_is_builtin) { return boolean(is_builtin(final_arg(args))); } BUILTIN(builtin_builtin_name) { value b = final_arg(args); if (!is_builtin(b)) sc_error("not a builtin"); return string(builtin_name(b)); } BUILTIN(builtin_is_promise) { return boolean(is_promise(final_arg(args))); } BUILTIN(builtin_is_continuation) { return boolean(is_continuation(final_arg(args))); } BUILTIN(builtin_make_bignum) { assert_args(1); /* Returning uninitialized is safe for the garbage collector: bignums are * not scanned internally, though the words do keep their fixnum tags. Of * course, used memory is still being exposed; the privileged bignum * library is responsible for fully initializing or truncating. */ return make_bignum_uninit(fixnum_val(car(args)), 0); } BUILTIN(builtin_is_bignum) { assert_args(1); return boolean(is_bignum(car(args))); } BUILTIN(builtin_is_bignum_negative) { assert_args(1); return boolean(is_bignum_negative(car(args))); } BUILTIN(builtin_bignum_set_negative) { assert_args(1); return bignum_set_negative(car(args)); } BUILTIN(builtin_bignum_ref) { assert_args(2); return bignum_ref(car(args), fixnum_val(cadr(args))); } BUILTIN(builtin_bignum_set) { value bn; assert_args(3); bn = car(args); args = cdr(args); bignum_set(bn, fixnum_val(car(args)), cadr(args)); return SC_NULL; } BUILTIN(builtin_bignum_length) { assert_args(1); return fixnum(bignum_len(car(args))); } BUILTIN(builtin_bignum_truncate) { assert_args(2); return bignum_truncate(car(args), fixnum_val(cadr(args))); } /* Construct bignum from signed fixnum, not demoting. */ BUILTIN(builtin_bignum) { value bn, word, word_sign_bit, word_sign_ext; assert_args(1); /* branch-free conversion from two's complement to sign-magnitude */ word = fixnum_val(car(args)); word_sign_bit = word >> ((8*sizeof word)-1); word_sign_ext = ((long)word) >> ((8*sizeof word)-1); word = (word ^ word_sign_ext) + word_sign_bit; bn = make_bignum_uninit(1, word_sign_bit); bignum_set(bn, 0, fixnum(word)); return bn; } /* Construct bignum from unsigned fixnum, not demoting. */ BUILTIN(builtin_bignum_unsigned) { value bn, word; assert_args(1); word = car(args); bn = make_bignum_uninit(1, 0); bignum_set(bn, 0, word); return bn; } /* Construct bignum from 2-word signed quantity, normalizing and demoting to * fixnum when possible. */ BUILTIN(builtin_bignum2) { value bn; long lo, hi; int neg = 0; assert_args(2); lo = fixnum_val(car(args)); hi = fixnum_val(cadr(args)); /* in signed fixnum range if high word is sign extension of low */ if (lo >> (VAL_BITS - 1) == hi) return fixnum(lo); if (hi < 0) { /* convert from two's complement to sign-magnitude */ neg = 1; /* capture carry bit in the tag by setting it to all ones prior to * complement */ lo = -(lo | (-1L << VAL_BITS)); hi = ~(ulong)hi + (((ulong)lo) >> VAL_BITS); } if (hi == 0) { /* need to drop high word to normalize */ bn = make_bignum_uninit(1, neg); bignum_set(bn, 0, fixnum(lo)); } else { /* both words significant */ bn = make_bignum_uninit(2, neg); bignum_set(bn, 0, fixnum(lo)); bignum_set(bn, 1, fixnum(hi)); } return bn; } /**************** * Initialization */ /* Construct a builtin and define it in the top frame of R_ENV. * Side effects: R_CAR R_CDR */ static void add_builtin(const char *name, builtin_func_t func) { R_CAR = symbol(name); R_CDR = builtin(name, func); assert(global_frame_lookup(R_CAR, car(R_ENV)) == SC_FALSE); extend_global_env(); } /* Define a variable in the top frame of R_ENV. * Side effects: R_EXPR R_CAR R_CDR */ static void add_variable(const char *name, value val) { R_EXPR = val; R_CAR = symbol(name); R_CDR = R_EXPR; assert(global_frame_lookup(R_CAR, car(R_ENV)) == SC_FALSE); extend_global_env(); } /* Side effects: R_RESULT */ static value open_lib_file(const char *filename) { int fd = open_cloexec(filename, O_RDONLY); if (fd == -1) fatal1(filename, strerror(errno)); return make_port(fd, 0, DEFAULT_R_BUF); } uint sc_hugepages; void sc_init(value heap_alloc) { int mflags; assert(sizeof(value) == __SIZEOF_POINTER__); assert(sizeof(value) == sizeof(ulong)); mflags = MAP_PRIVATE | MAP_ANON; if (sc_hugepages) { #ifdef MAP_HUGETLB mflags |= MAP_HUGETLB; #else fatal("huge pages not supported"); #endif } heap = mmap(NULL, heap_alloc, PROT_READ | PROT_WRITE, mflags, -1, 0); if (heap == MAP_FAILED) fatal1("failed to map heap", strerror(errno)); heap_size = heap_alloc / sizeof(value) / 2; new_heap = heap + heap_size; gc_root(&r0); gc_root(&r1); gc_root(&r2); gc_root(&r3); gc_root(&r4); gc_root(&r5); gc_root(&r6); gc_root(&r_stack); gc_root(&r_spool); gc_root(&r_error_cont); gc_root(&r_signal_handler); gc_root(&r_compiler); gc_root(&r_compiler_expr); gc_root(&r_input_port); gc_root(&r_output_port); gc_root(&r_dump); gc_root(&stdin_port); gc_root(&stdout_port); gc_root(&symbols); gc_root(&s_lambda); gc_root(&s_quote); gc_root(&s_quasiquote); gc_root(&s_unquote); gc_root(&s_unquote_splicing); gc_root(&s_if); gc_root(&s_set); gc_root(&s_begin); gc_root(&s_letrec); gc_root(&s_define); gc_root(&s_delay); gc_root(&s_literal); gc_root(&s_open_paren); gc_root(&s_close_paren); gc_root(&s_dot); gc_root(&s_open_vector); gc_root(&s_identifier); gc_root(&s_named_char); gc_root(&s_abbrev); gc_root(&s_number); gc_root(&s_truncate); gc_root(&s_overwrite); gc_root(&s_append); gc_root(&s_sync); gc_root(&s_data_sync); gc_root(&r5rs_env); gc_root(&gscm_env); gc_root(&interaction_env); gc_root(&toplevel_env); r_input_port = stdin_port = make_port(0, 0, DEFAULT_R_BUF); r_output_port = stdout_port = make_port(1, 1, DEFAULT_W_BUF); stdout_ready = 1; fixnum_zero = fixnum(0); fixnum_one = fixnum(1); s_lambda = symbol("lambda"); s_quote = symbol("quote"); s_quasiquote = symbol("quasiquote"); s_unquote = symbol("unquote"); s_unquote_splicing = symbol("unquote-splicing"); s_if = symbol("if"); s_set = symbol("set!"); s_begin = symbol("begin"); s_letrec = symbol("letrec"); s_define = symbol("define"); s_delay = symbol("delay"); s_literal = symbol("literal"); s_open_paren = symbol("open-paren"); s_close_paren = symbol("close-paren"); s_dot = symbol("dot"); s_open_vector = symbol("open-vector"); s_identifier = symbol("identifier"); s_named_char = symbol("named-char"); s_abbrev = symbol("abbrev"); s_number = symbol("number"); s_truncate = symbol("truncate"); s_overwrite = symbol("overwrite"); s_append = symbol("append"); s_sync = symbol("sync"); s_data_sync = symbol("data-sync"); R_CAR = R_CDR = SC_NULL; R_ENV = r5rs_env = cons(); add_builtin("eq?", builtin_is_eq); add_builtin("number?", builtin_is_number); add_builtin("complex?", builtin_is_number); add_builtin("real?", builtin_is_number); add_builtin("rational?", builtin_is_number); add_builtin("integer?", builtin_is_integer); add_builtin("exact?", builtin_is_exact); add_builtin("inexact?", builtin_is_inexact); add_builtin("not", builtin_not); add_builtin("boolean?", builtin_is_boolean); add_builtin("pair?", builtin_is_pair); add_builtin("cons", builtin_cons); add_builtin("car", builtin_car); add_builtin("cdr", builtin_cdr); add_builtin("caar", builtin_caar); add_builtin("cadr", builtin_cadr); add_builtin("cdar", builtin_cdar); add_builtin("cddr", builtin_cddr); add_builtin("caaar", builtin_caaar); add_builtin("caadr", builtin_caadr); add_builtin("cadar", builtin_cadar); add_builtin("caddr", builtin_caddr); add_builtin("cdaar", builtin_cdaar); add_builtin("cdadr", builtin_cdadr); add_builtin("cddar", builtin_cddar); add_builtin("cdddr", builtin_cdddr); add_builtin("caaaar", builtin_caaaar); add_builtin("caaadr", builtin_caaadr); add_builtin("caadar", builtin_caadar); add_builtin("caaddr", builtin_caaddr); add_builtin("cadaar", builtin_cadaar); add_builtin("cadadr", builtin_cadadr); add_builtin("caddar", builtin_caddar); add_builtin("cadddr", builtin_cadddr); add_builtin("cdaaar", builtin_cdaaar); add_builtin("cdaadr", builtin_cdaadr); add_builtin("cdadar", builtin_cdadar); add_builtin("cdaddr", builtin_cdaddr); add_builtin("cddaar", builtin_cddaar); add_builtin("cddadr", builtin_cddadr); add_builtin("cdddar", builtin_cdddar); add_builtin("cddddr", builtin_cddddr); add_builtin("set-car!", builtin_set_car); add_builtin("set-cdr!", builtin_set_cdr); add_builtin("null?", builtin_is_null); add_builtin("list?", builtin_is_list); add_builtin("length", builtin_length); add_builtin("symbol?", builtin_is_symbol); add_builtin("symbol->string", builtin_sym_to_str); add_builtin("string->symbol", builtin_str_to_sym); add_builtin("char?", builtin_is_char); add_builtin("char=?", builtin_char_eq); add_builtin("char?", builtin_char_gt); add_builtin("char<=?", builtin_char_le); add_builtin("char>=?", builtin_char_ge); add_builtin("char-ci=?", builtin_char_ci_eq); add_builtin("char-ci?", builtin_char_ci_gt); add_builtin("char-ci<=?", builtin_char_ci_le); add_builtin("char-ci>=?", builtin_char_ci_ge); add_builtin("char-alphabetic?", builtin_char_is_alpha); add_builtin("char-numeric?", builtin_char_is_num); add_builtin("char-whitespace?", builtin_char_is_white); add_builtin("char-upper-case?", builtin_char_is_upper); add_builtin("char-lower-case?", builtin_char_is_lower); add_builtin("char->integer", builtin_char_to_int); add_builtin("integer->char", builtin_int_to_char); add_builtin("char-upcase", builtin_char_upcase); add_builtin("char-downcase", builtin_char_downcase); add_builtin("string?", builtin_is_str); add_builtin("make-string", builtin_make_str); add_builtin("string-length",builtin_str_length); add_builtin("string-ref", builtin_str_ref); add_builtin("string-set!", builtin_str_set); add_builtin("string=?", builtin_str_eq); add_builtin("string?", builtin_str_gt); add_builtin("string<=?", builtin_str_le); add_builtin("string>=?", builtin_str_ge); add_builtin("string-ci=?", builtin_str_ci_eq); add_builtin("string-ci?", builtin_str_ci_gt); add_builtin("string-ci<=?", builtin_str_ci_le); add_builtin("string-ci>=?", builtin_str_ci_ge); add_builtin("substring", builtin_substr); add_builtin("string-append",builtin_str_append); add_builtin("list->string", builtin_list_to_str); add_builtin("string-copy", builtin_str_copy); add_builtin("string-fill!", builtin_str_fill); add_builtin("vector?", builtin_is_vector); add_builtin("make-vector", builtin_make_vector); add_builtin("vector-length",builtin_vec_length); add_builtin("vector-ref", builtin_vec_ref); add_builtin("vector-set!", builtin_vec_set); add_builtin("list->vector", builtin_list_to_vec); add_builtin("vector-fill!", builtin_vec_fill); add_builtin("procedure?", builtin_is_procedure); add_builtin("force", builtin_force); add_builtin("call-with-current-continuation", builtin_call_cc); add_builtin("call/cc", builtin_call_cc); add_builtin("values", builtin_values); add_builtin("call-with-values", builtin_call_with_values); add_builtin("eval", builtin_eval); add_builtin("scheme-report-environment", builtin_report_env); add_builtin("null-environment", builtin_null_env); add_builtin("interaction-environment", builtin_interaction_env); add_builtin("port?", builtin_is_port); add_builtin("input-port?", builtin_is_in_port); add_builtin("output-port?", builtin_is_out_port); add_builtin("current-input-port", builtin_current_in_port); add_builtin("current-output-port", builtin_current_out_port); add_builtin("open-input-file", builtin_open_in_file); add_builtin("open-output-file", builtin_open_out_file); add_builtin("close-input-port", builtin_close_in_port); add_builtin("close-output-port", builtin_close_out_port); add_builtin("read-char", builtin_read_char); add_builtin("peek-char", builtin_peek_char); add_builtin("eof-object?", builtin_is_eof); add_builtin("char-ready?", builtin_is_char_ready); add_builtin("write-char", builtin_write_char); /* Immutable environment for extensions */ R_CAR = SC_NULL; R_CDR = r5rs_env; R_ENV = gscm_env = cons(); add_builtin("gales-scheme-environment", builtin_gscm_env); add_builtin("immutable?", builtin_is_immutable); add_builtin("cons/immutable", builtin_cons_immutable); add_builtin("string-copy/immutable", builtin_str_copy_immutable); add_builtin("vector-copy/immutable", builtin_vec_copy_immutable); add_builtin("flush-output-port", builtin_flush_out_port); add_builtin("error", builtin_error); add_builtin("gc", builtin_gc); add_variable("*fixnum-width*", fixnum(VAL_BITS)); add_variable("*greatest-fixnum*", fixnum(FIXNUM_MAX)); add_variable("*least-fixnum*", fixnum(FIXNUM_MIN)); add_builtin("fixnum?", builtin_is_fixnum); add_builtin("fx=", builtin_fx_eq); add_builtin("fx<", builtin_fx_lt); add_builtin("fx<=", builtin_fx_le); add_builtin("fx> 1)); /* ^ sign-encoded arity must fit in procedure header; frame index must fit * in variable ref header */ add_builtin("define-r5rs", builtin_define_r5rs); add_builtin("define-gscm", builtin_define_gscm); add_builtin("set-input-port!", builtin_set_in_port); add_builtin("set-output-port!", builtin_set_out_port); add_builtin("push-winding!", builtin_push_winding); add_builtin("variable-ref", builtin_variable_ref); add_builtin("apply/unchecked", builtin_apply_unchecked); add_builtin("car/unchecked", builtin_car_unchecked); add_builtin("cdr/unchecked", builtin_cdr_unchecked); add_builtin("set-car/unchecked!", builtin_set_car_unchecked); add_builtin("set-cdr/unchecked!", builtin_set_cdr_unchecked); add_builtin("string-ref/unchecked", builtin_str_ref_unchecked); add_builtin("vector-ref/unchecked", builtin_vec_ref_unchecked); add_builtin("fx+/unchecked", builtin_fx_add_unchecked); add_builtin("fx-/unchecked", builtin_fx_sub_unchecked); add_builtin("fx=/unchecked", builtin_fx_eq_unchecked); add_builtin("fxdec/unchecked", builtin_fixnum_to_dec_unchecked); add_builtin("fixnum->hex/unchecked", builtin_fixnum_to_hex_unchecked); add_builtin("fixnum->oct/unchecked", builtin_fixnum_to_oct_unchecked); add_builtin("fixnum->bin/unchecked", builtin_fixnum_to_bin_unchecked); add_builtin("fixnum->bin/unsigned/unchecked", builtin_fixnum_to_bin_unsigned_unchecked); add_builtin("flonum->dec/unchecked", builtin_flonum_to_dec_unchecked); add_builtin("set-error-continuation!", builtin_set_err_cont); add_builtin("inet-stream-socket", builtin_inet_stream_sock); add_builtin("inet-dgram-socket", builtin_inet_dgram_sock); add_builtin("unix-stream-socket", builtin_unix_stream_sock); add_builtin("unix-dgram-socket", builtin_unix_dgram_sock); add_builtin("socket-ports", builtin_socket_ports); add_builtin("getsockname", builtin_getsockname); add_builtin("getpeername", builtin_getpeername); add_builtin("connect-inet", builtin_connect_inet); add_builtin("connect-unix", builtin_connect_unix); add_builtin("listen", builtin_listen); add_builtin("accept", builtin_accept); add_builtin("close", builtin_close); add_builtin("flonum?", builtin_is_flonum); add_builtin("flonum/unchecked", builtin_flonum_unchecked); add_builtin("flonum/unsigned/unchecked", builtin_flonum_unsigned_unchecked); add_builtin("flo=/unchecked", builtin_flo_eq_unchecked); add_builtin("flofixnum/unchecked", builtin_flo_to_fix_unchecked); add_builtin("floor/unchecked", builtin_floor); add_builtin("ceiling/unchecked", builtin_ceiling); add_builtin("truncate/unchecked", builtin_truncate); add_builtin("round/unchecked", builtin_round); add_builtin("exp/unchecked", builtin_exp); add_builtin("log/unchecked", builtin_log); add_builtin("sin/unchecked", builtin_sin); add_builtin("cos/unchecked", builtin_cos); add_builtin("tan/unchecked", builtin_tan); add_builtin("asin/unchecked", builtin_asin); add_builtin("acos/unchecked", builtin_acos); add_builtin("atan/unchecked", builtin_atan); add_builtin("atan2/unchecked", builtin_atan2); add_builtin("sqrt/unchecked", builtin_sqrt); add_builtin("reverse-list->vector/unchecked", builtin_rev_list_to_vec_unchecked); add_builtin("builtin?", builtin_is_builtin); add_builtin("builtin-name", builtin_builtin_name); add_builtin("promise?", builtin_is_promise); add_builtin("continuation?", builtin_is_continuation); add_builtin("make-bignum", builtin_make_bignum); add_builtin("bignum?", builtin_is_bignum); add_builtin("bignum-negative?", builtin_is_bignum_negative); add_builtin("bignum-set-negative!", builtin_bignum_set_negative); add_builtin("bignum-ref", builtin_bignum_ref); add_builtin("bignum-set!", builtin_bignum_set); add_builtin("bignum-length", builtin_bignum_length); add_builtin("bignum", builtin_bignum); add_builtin("bignum/unsigned", builtin_bignum_unsigned); add_builtin("bignum2", builtin_bignum2); add_builtin("bignum-truncate!", builtin_bignum_truncate); R_PORT = open_lib_file(GSCMLIB "/compiler.scm"); err_context = "compiler"; r_compiler_expr = sc_read(); if (r_compiler_expr == SC_EOF) fatal("EOF reading compiler code"); close_port(R_PORT); R_EXPR = r_compiler_expr; R_ENV = toplevel_env; evaluator(); r_compiler = R_RESULT; /* Self-compile, for the speed benefit of variable refs */ R_EXPR = r_compiler_expr; R_ENV = toplevel_env; r_compiler_expr = SC_NULL; evaluator(); r_compiler = R_RESULT; } int sc_toplevel(int argc, char **argv) { int i; R_CDR = SC_NULL; for (i=argc-1; i>=0; --i) { R_CAR = string(argv[i]); R_CDR = cons(); } R_ENV = interaction_env; add_variable("*args*", R_CDR); R_PORT = open_lib_file(GSCMLIB "/toplevel.scm"); err_context = "toplevel"; R_EXPR = sc_read(); if (R_EXPR == SC_EOF) fatal("EOF reading toplevel code"); close_port(R_PORT); R_ENV = toplevel_env; evaluator(); flush_all(); return fixnum_val(R_RESULT); }