diff --git a/builtin.c b/builtin.c index 0e7ab77..c9ecca7 100644 --- a/builtin.c +++ b/builtin.c @@ -12,9 +12,17 @@ static gc_root_t builtin_list; static gc_root_t lambda_type_root; static gc_root_t template_type_root; +static void bi_string_to_builtin(interp_state_t *state); +static void bi_builtin_to_string(interp_state_t *state); + +static void bi_values(interp_state_t *state); static void bi_freeze(interp_state_t *state); static void bi_immutable_p(interp_state_t *state); static void bi_string_to_number(interp_state_t *state); +static void bi_display(interp_state_t *state); +static void bi_register_finalizer(interp_state_t *state); +static void bi_current_context(interp_state_t *state); +static void bi_call_with_context(interp_state_t *state); void builtin_init(void) { @@ -37,10 +45,19 @@ void builtin_init(void) register_builtin(BI_NEG_INFINITY, make_float(-INFINITY)); #endif + register_builtin(BI_VALUES, make_builtin_fn(bi_values)); register_builtin(BI_FREEZE, make_builtin_fn(bi_freeze)); register_builtin(BI_IMMUTABLE_P, make_builtin_fn(bi_immutable_p)); + register_builtin(BI_DISPLAY, make_builtin_fn(bi_display)); - register_builtin(BI_STRING_TO_NUMBER, make_builtin_fn(bi_string_to_number)); + register_builtin(BI_STRING_TO_NUMBER, make_builtin_fn(bi_string_to_number)); + register_builtin(BI_REGISTER_FINALIZER, make_builtin_fn(bi_register_finalizer)); + + register_builtin(BI_STRING_TO_BUILTIN, make_builtin_fn(bi_string_to_builtin)); + register_builtin(BI_BUILTIN_TO_STRING, make_builtin_fn(bi_builtin_to_string)); + + register_builtin(BI_CURRENT_CONTEXT, make_builtin_fn(bi_current_context)); + register_builtin(BI_CALL_WITH_CONTEXT, make_builtin_fn(bi_call_with_context)); } void register_builtin(const char *name, value_t value) @@ -69,6 +86,20 @@ value_t lookup_builtin(const char *name) return FALSE_VALUE; } +value_t reverse_lookup_builtin(value_t value) +{ + for (value_t list = builtin_list.value; !is_nil(list); + list = _CDDR(list)) + { + if (_CADR(list) == value) + { + return _CAR(list); + } + } + + return FALSE_VALUE; +} + value_t get_template_type(void) { return template_type_root.value; @@ -79,6 +110,29 @@ value_t get_lambda_type(void) return lambda_type_root.value; } +static void bi_string_to_builtin(interp_state_t *state) +{ + char *str; + value_t rval; + + str = value_to_string(CAR(state->argv.value)); + rval = lookup_builtin(str); + free(str); + + interp_return_values(state, cons(rval, NIL)); +} + +static void bi_builtin_to_string(interp_state_t *state) +{ + value_t rval = reverse_lookup_builtin(CAR(state->argv.value)); + interp_return_values(state, cons(rval, NIL)); +} + +static void bi_values(interp_state_t *state) +{ + interp_return_values(state, state->argv.value); +} + static void bi_freeze(interp_state_t *state) { value_t val = CAR(state->argv.value); @@ -146,4 +200,31 @@ static void bi_string_to_number(interp_state_t *state) interp_return_values(state, cons(rval, NIL)); } +static void bi_display(interp_state_t *state) +{ + fprint_value(stdout, CAR(state->argv.value)); + fflush(stdout); + interp_return_values(state, NIL); +} + +static void bi_register_finalizer(interp_state_t *state) +{ + register_finalizer(CAR(state->argv.value), CAR(_CDR(state->argv.value))); + interp_return_values(state, NIL); +} + +static void bi_current_context(interp_state_t *state) +{ + interp_return_values(state, cons(state->ctx.value, NIL)); +} + +static void bi_call_with_context(interp_state_t *state) +{ + state->ctx.value = CAR(state->argv.value); + state->lambda.value = CAR(_CDR(state->argv.value)); + state->argv.value = NIL; + state->kw_args.value = NIL; + state->kw_vals.value = NIL; +} + /* vim:set sw=2 expandtab: */ diff --git a/builtin.h b/builtin.h index 47a7f7b..a3bc97c 100644 --- a/builtin.h +++ b/builtin.h @@ -18,9 +18,16 @@ #define BI_NEG_INFINITY "-infinity" /* Names of builtin functions */ -#define BI_FREEZE "freeze!" -#define BI_IMMUTABLE_P "immutable?" -#define BI_STRING_TO_NUMBER "string->number" +#define BI_VALUES "values" +#define BI_FREEZE "freeze!" +#define BI_IMMUTABLE_P "immutable?" +#define BI_REGISTER_FINALIZER "register-finalizer" +#define BI_STRING_TO_NUMBER "string->number" +#define BI_STRING_TO_BUILTIN "string->builtin" +#define BI_BUILTIN_TO_STRING "builtin->string" +#define BI_DISPLAY "display" +#define BI_CURRENT_CONTEXT "current-context" +#define BI_CALL_WITH_CONTEXT "call-with-context" /* Lambda: Instances of this structure are fundamental callable objects. */ #define LAMBDA_SLOT_GLOBAL_VARS 0 @@ -43,6 +50,7 @@ value_t get_template_type(void); void builtin_init(void); void register_builtin(const char *name, value_t value); value_t lookup_builtin(const char *name); +value_t reverse_lookup_builtin(value_t value); #endif /* vim:set sw=2 expandtab: */ diff --git a/doc/bytecode.txt b/doc/bytecode.txt index 7f27c4f..4beac74 100644 --- a/doc/bytecode.txt +++ b/doc/bytecode.txt @@ -7,6 +7,8 @@ expression: up to 256, 3 in, no prefix 21 (byte-string-set! in1 in2 in3) ; string n value, 0 <= n < nbytes; ==> in3 22 (struct-set! in1 in2 in3) ; struct n value, 0 <= n < nslots; ==> in3 + ff (vector-ref-immed in1 msb lsb) ; vector n n; ==> (vector-ref in1 (+ (* msb 256) lsb)) + binary-expr: up to 256, 2 in, prefix = 00 00 sub in: unary-expr @@ -53,20 +55,20 @@ binary-expr: up to 256, 2 in, prefix = 00 28 (remainder in1 in2) ; float float 29 (scalb in1 in2) ; float float - 30 (kind-of? in1 in2) ; value struct-type ==> boolean - 31 (byte-string= in1 in2) - 32 (byte-string< in1 in2) ; == (byte-string> in2 in1) - 33 (byte-string>= in1 in2) ; == (byte-string<= in2 in1) + 30 (kind-of? in1 in2) ; value struct-type ==> boolean + 31 (byte-string= in1 in2) + 32 (byte-string< in1 in2) ; == (byte-string> in2 in1) + 33 (byte-string>= in1 in2) ; == (byte-string<= in2 in1) - 50 (set-box! in1 in2) ; box value ==> in2 - 51 (set-car! in1 in2) ; pair value ==> in2 - 52 (set-cdr! in1 in2) ; pair value ==> in2 + 50 (set-box! in1 in2) ; box value ==> in2 + 51 (set-car! in1 in2) ; pair value ==> in2 + 52 (set-cdr! in1 in2) ; pair value ==> in2 - 70 (tail-call-if in1 in2) ; flag byte-string, perform tail call (in2) if in1 != #f + 70 (tail-call-if in1 in2) ; flag byte-string, perform tail call (in2) if in1 != #f + + ff (fatal-error-if in1 in2) ; signal fatal error (annotated with 'in2') if in1 != #f unary-expr: up to 256, 1 in, prefix = 00 00 - 00 (fatal-error in) ; signal fatal error; annotated with 'in' if non-nil - 01 (unbox in) 02 (weak-unbox in) 03 (car in) @@ -151,20 +153,21 @@ unary-expr: up to 256, 1 in, prefix = 00 00 74 (nan? in) in: - tN (0NNNNNNN) [transient, 0 <= N < 128, one for each prior expression] - gN (10NNNNNN) [global, 0 <= N < 64] - iN (110NNNNN) [instance, 0 <= N < 32] - iN (1110NNNN) [instance, 32 <= N < 48] - #f (11110000) [constant] - undef (11110001) [constant] - nil (11110010) [constant] - -- (1111xxxx) [reserved, 2 <= x < 10] - self (11111010) [current lambda] - argv (11111011) [argument list] - kw-args (11111100) [keyword arguments] (sorted) - kw-vals (11111101) [keyword values] (match kw-args) - ctx (11111110) [dynamic context] - k (11111111) [continuation] + tN 00-7f [transient, 0 <= N < 128, one for each prior expression] + gN 80-bf [global, 0 <= N < 64] + iN c0-ef [instance, 0 <= N < 48] + #f f0 [constant] + nil f1 [constant] + undef f2 [constant] + -- f3-f7 [reserved, 3 <= x < 8] + self f8 [current lambda] + globals f9 [current global value vector] + inst fa [current instance value vector] + argv fb [argument list] + kw-args fc [keyword arguments] (sorted) + kw-vals fd [keyword values] (match kw-args) + ctx fe [dynamic context] + k ff [continuation] lambda:[ global: vector of immutable values (g0..gN); shared between instances (lambdas) diff --git a/gc.c b/gc.c index bce64a2..99de0aa 100644 --- a/gc.c +++ b/gc.c @@ -13,6 +13,11 @@ #include "gc.h" #include "builtin.h" +#if 1 +#define ENABLE_BACKTRACE +#include +#endif + #if _CLOCK_MONOTONIC # define TIMING_CLOCK CLOCK_MONOTONIC #else @@ -21,6 +26,22 @@ gc_stats_t gc_stats; +#define GC_DEBUG_LEVEL_TRACE 3 +#define GC_DEBUG_LEVEL_INFO 2 +#define GC_DEBUG_LEVEL_WARN 1 +#define GC_DEBUG_LEVEL_QUIET 0 + +static int gc_debug_level = GC_DEBUG_LEVEL_QUIET; + +#define debug_warn(fmt, args...) \ + ((gc_debug_level >= GC_DEBUG_LEVEL_WARN) ? (void)(fprintf(stderr,fmt,##args)) : (void)0) + +#define debug_info(fmt, args...) \ + ((gc_debug_level >= GC_DEBUG_LEVEL_INFO) ? (void)(fprintf(stderr,fmt,##args)) : (void)0) + +#define debug_trace(fmt, args...) \ + ((gc_debug_level >= GC_DEBUG_LEVEL_TRACE) ? (void)(fprintf(stderr,fmt,##args)) : (void)0) + /* Helper macros to reduce duplication */ #define VECTOR_BYTES(nelem) (sizeof(vector_t) + (sizeof(value_t) * (nelem))) #define BYTESTR_BYTES(size) (sizeof(byte_string_t) + (size)) @@ -80,8 +101,11 @@ void unregister_gc_root(gc_root_t *root) static value_t make_hash_value(void) { - static fixnum_t hash_seed = 0x67f76bc8; + static fixnum_t hash_seed = (fixnum_t)0x5e1dd160053438c6uLL; hash_seed = (33 * hash_seed) ^ (fixnum_t)clock(); + hash_seed ^= hash_seed << 31; + hash_seed ^= hash_seed << 13; + hash_seed ^= hash_seed << 7; return fixnum_value(hash_seed); } @@ -537,7 +561,8 @@ static value_t _get_hash_value(value_t v, seen_value_t *seen) value_t get_hash_value(value_t v) { - return _get_hash_value(v, NULL); + value_t hv = _get_hash_value(v, NULL); + return fixnum_value(_get_fixnum(hv) & FIXNUM_MAX); } value_t combine_hash_values(value_t f1, value_t f2) @@ -600,6 +625,8 @@ static inline size_t gc_align(size_t nbytes) void gc_init(size_t gen0_size, size_t gen1_min_size, size_t gen1_max_size) { + const char *gc_debug_env; + gc_gen0_init(gen0_size); gc_gen1_init(gen1_min_size, gen1_max_size); @@ -609,6 +636,34 @@ void gc_init(size_t gen0_size, size_t gen1_min_size, size_t gen1_max_size) clear_gc_stats(); + if ((gc_debug_env = getenv("GC_DEBUG")) != NULL) + { + if (strcmp(gc_debug_env, "warn") == 0) + { + gc_debug_level = GC_DEBUG_LEVEL_WARN; + } + else if (strcmp(gc_debug_env, "info") == 0) + { + gc_debug_level = GC_DEBUG_LEVEL_INFO; + } + else if (strcmp(gc_debug_env, "trace") == 0) + { + gc_debug_level = GC_DEBUG_LEVEL_TRACE; + } + else + { + char *endp; + long val; + + val = strtol(gc_debug_env, &endp, 0); + + if (endp && (endp[0] == '\0')) + { + gc_debug_level = val; + } + } + } + gc_enabled = true; structure_init(); @@ -673,9 +728,7 @@ static void collect_gen0_garbage(void) { if (gc_enabled) { -#ifndef NDEBUG size_t initial_gen1_free_space; -#endif #ifndef NO_STATS size_t initial_free_space; @@ -686,14 +739,12 @@ static void collect_gen0_garbage(void) initial_free_space = gc_gen0_free_space() + gc_gen1_free_space(); #endif - debug(("Performing Gen-0 garbage collection pass...\n")); + debug_info("Performing Gen-0 garbage collection pass...\n"); assert(!gc_in_gen0_collection); assert(!gc_in_gen1_collection); -#ifndef NDEBUG initial_gen1_free_space = gc_gen1_free_space(); -#endif /* If we trigger a Gen-1 collection at any point then we are done. */ /* Full collection will pull in any current Gen-0 objects. */ @@ -776,7 +827,8 @@ static void collect_gen0_garbage(void) /* 4. Reset Gen-0 range to 'empty' state. */ gc_gen0_free_ptr = gc_gen0_range; - //debug(("Finished Gen-0 collection; added %d bytes to Gen-1 heap.\n", initial_gen1_free_space - gc_gen1_free_space())); + debug_info("Finished Gen-0 collection; added %ld bytes to Gen-1 heap.\n", + (long int)(initial_gen1_free_space - gc_gen1_free_space())); #ifndef NO_STATS #ifndef NO_TIMING_STATS @@ -815,7 +867,7 @@ void *gc_alloc(size_t nbytes) if (nbytes >= gc_gen0_size) { - //debug(("Allocating directly from Gen-0...\n")); + debug_warn("Allocating directly from Gen-1...\n"); return gc_alloc_gen1(nbytes); } else @@ -1305,7 +1357,7 @@ static void collect_gen1_garbage(size_t min_free) #endif #endif - debug(("Performing Gen-1 garbage collection pass...\n")); + debug_info("Performing Gen-1 garbage collection pass...\n"); gc_enabled = false; gc_in_gen0_collection = false; @@ -1362,7 +1414,8 @@ static void collect_gen1_garbage(size_t min_free) gc_gen0_free_ptr = gc_gen0_range; collected_garbage = true; - //debug(("Finished Gen-1 collection; active set is %d bytes.\n", gc_gen1_free_ptr - gc_gen1_ranges[gc_gen1_current_range])); + debug_info("Finished Gen-1 collection; active set is %ld bytes.\n", + (long int)(gc_gen1_free_ptr - gc_gen1_ranges[gc_gen1_current_range])); gc_in_gen1_collection = false; gc_enabled = true; @@ -1406,7 +1459,7 @@ static void collect_gen1_garbage(size_t min_free) * Try to get more memory from the C runtime. */ - debug(("Ran out of free memory; will try to allocate more...\n")); + debug_warn("Ran out of free memory; will try to allocate more...\n"); do { release_assert(gc_gen1_max_size < (SIZE_MAX/2)); @@ -1483,22 +1536,36 @@ void get_next_finalizer(value_t *value, value_t *finalizer) } } -void _release_assert(bool expr, const char *str, const char *file, int line) +void print_backtrace(void) { - if (!expr) - { - fprintf(stderr, "ERROR: Invalid state detected in %s, line %d.\n" - "Assertion failed: %s\n", - file, line, str); +#ifdef ENABLE_BACKTRACE + void *frames[32]; + backtrace(frames, 32); + backtrace_symbols_fd(frames, 32, 2); +#endif +} - abort(); - } +void _release_assert(const char *str, const char *file, int line) +{ + fprintf(stderr, "ERROR: Invalid state detected in %s, line %d.\n" + "Assertion failed: %s\n", + file, line, str); + + abort(); } static void _fprint_value(FILE *f, value_t v, seen_value_t *seen) { seen_value_t new_seen = { v, seen }; int depth = 0; + value_t builtin_name = reverse_lookup_builtin(v); + + if (is_byte_string(builtin_name)) + { + fputs("#=", f); + _fprint_value(f, builtin_name, NULL); + return; + } if (is_object(v) && !(is_float(v) || is_byte_string(v) || is_builtin_fn(v))) { @@ -1626,15 +1693,7 @@ static void _fprint_value(FILE *f, value_t v, seen_value_t *seen) fputs("#@", f); fputs("#S(", f); - - if (meta == get_structure_type()) - fputs("structure", f); - else if (meta == get_template_type()) - fputs("template", f); - else if (meta == get_lambda_type()) - fputs("lambda", f); - else - _fprint_value(f, meta, &new_seen); + _fprint_value(f, meta, &new_seen); for (size_t i = 0; i < _get_struct(v)->nslots; ++i) { diff --git a/gc.h b/gc.h index 81fcf7a..a3a401e 100644 --- a/gc.h +++ b/gc.h @@ -7,15 +7,9 @@ #include #include -#ifndef NDEBUG -# define debug(printf_args) ((void)printf printf_args) -#else -# define debug(printf_args) ((void)0) -#endif - /* Like assert(), but for things we want to check even in release builds. */ /* More informative than a simple "if (!x) abort();" statement. */ -#define release_assert(expr) ((void)_release_assert((expr), #expr, __FILE__, __LINE__)) +#define release_assert(expr) ((expr) ? (void)0 : (void)_release_assert(#expr, __FILE__, __LINE__)) /* Evaluates to false, but with an expression that conveys what went wrong. */ #define NOTREACHED(msg) 0 @@ -464,7 +458,7 @@ static inline void _gc_write_barrier(value_t v) } /* Implements the release_assert() macro */ -void _release_assert(bool expr, const char *str, const char *file, int line); +void _release_assert(const char *str, const char *file, int line); /* To be provided by the main application */ void out_of_memory(void); diff --git a/interp.c b/interp.c index 56d89d8..05fab5b 100644 --- a/interp.c +++ b/interp.c @@ -64,13 +64,6 @@ value_t run_interpreter(value_t lambda, value_t argv) /* Keep going until something attempts to tail-call END_PROGRAM, the original 'k', indicating completion. */ while (state.lambda.value != END_PROGRAM) { - /* 'lambda' may be a callable structure; if so, follow the 'callable' proxies and update argv. */ - translate_callable(&state); - - /* - * Now 'lambda' really is a lambda structure instance (or builtin). - */ - state.ntransients = 0; #if 0 @@ -83,6 +76,13 @@ value_t run_interpreter(value_t lambda, value_t argv) fflush(stderr); #endif + /* 'lambda' may be a callable structure; if so, follow the 'callable' proxies and update argv. */ + translate_callable(&state); + + /* + * Now 'lambda' really is a lambda structure instance (or builtin). + */ + if (is_builtin_fn(state.lambda.value)) { /* Builtin functions replace the byte-code and tail-call steps. */ @@ -323,6 +323,12 @@ static value_t eval_expression(interp_state_t *state, uint8_t code, uint8_t in1, { return eval_binary_expression(state, in1, in2, in3); } + else if (code == 0xff) + { + /* vector-ref-immed; in1 is vector, in2:in3 is index */ + value_t v1 = get_input(state, in1); + return vector_ref(v1, ((uint16_t)in2 << 8) | in3); + } else { value_t v1 = get_input(state, in1); @@ -446,6 +452,20 @@ static value_t eval_binary_expression(interp_state_t *state, uint8_t code, uint8 WRITE_BARRIER(v1); return UNDEFINED; + case 0xff: + if (_get_boolean(v1)) + { + if (_get_boolean(v2)) + { + fprint_value(stderr, v2); + fputc('\n', stderr); + } + + release_assert(NOTREACHED("Fatal error detected.")); + } + return UNDEFINED; + + default: release_assert(NOTREACHED("Invalid binary byte-code!")); return UNDEFINED; @@ -459,10 +479,6 @@ static value_t eval_unary_expression(interp_state_t *state, uint8_t code, uint8_ switch (code) { - case 0x00: - release_assert(NOTREACHED("Fatal error detected.")); - return UNDEFINED; - case 0x01: return get_box(v1)->value; case 0x02: return get_weak_box(v1)->value; case 0x03: return get_pair(v1)->car; @@ -590,8 +606,10 @@ static value_t get_input(const interp_state_t *state, fixnum_t var) case 0xf0: return FALSE_VALUE; case 0xf1: return NIL; case 0xf2: return UNDEFINED; - /* 0xf3 through 0xf9 are reserved */ - case 0xfa: return state->lambda.value; + /* 0xf3 through 0xf7 are reserved */ + case 0xf8: return state->lambda.value; + case 0xf9: return state->globals.value; + case 0xfa: return state->instances.value; case 0xfb: return state->argv.value; case 0xfc: return state->kw_args.value; case 0xfd: return state->kw_vals.value; diff --git a/interp.h b/interp.h index 5117404..7e07ef6 100644 --- a/interp.h +++ b/interp.h @@ -62,8 +62,8 @@ static inline void interp_return_values(interp_state_t *state, value_t values) { value_t old_k = state->k.value; - state->ctx.value = FALSE_VALUE; - state->k.value = FALSE_VALUE; + state->ctx.value = UNDEFINED; + state->k.value = UNDEFINED; interp_tail_call(state, old_k, values, NIL, NIL); } diff --git a/libcompiler/compiler.scm b/libcompiler/compiler.scm index e9975d7..93b0f10 100644 --- a/libcompiler/compiler.scm +++ b/libcompiler/compiler.scm @@ -6,18 +6,15 @@ (provide reduce-function compile-function - optimize? - box-free-variables?) + optimize?) (define optimize? (make-parameter #t)) -(define box-free-variables? (make-parameter #f)) (define (compile-function lambda-form) (map-variables (reduce-function lambda-form))) (define (reduce-function lambda-form) ((compose (if (optimize?) optimize-function values) - (if (box-free-variables?) promote-free-variables values) simplify-lambda) lambda-form)) diff --git a/libcompiler/mapper.scm b/libcompiler/mapper.scm index 9edc985..9dfb1f3 100644 --- a/libcompiler/mapper.scm +++ b/libcompiler/mapper.scm @@ -26,14 +26,38 @@ next) (end-fn)))) +(define-syntax values->list + (syntax-rules () + [(values->list expr) + (call-with-values (lambda () expr) list)])) + +(define n-global-variables (length global-variables)) +(define n-instance-variables (length instance-variables)) + (define (map-variables lambda/template-form (capture-map '())) - (let ([bind (fourth lambda/template-form)] + (let ([bind (fourth lambda/template-form)] + [next-t-var (from-list transient-variables (lambda () (error "Out of transient vars")))] [next-g-var (from-list global-variables)] [next-i-var (from-list instance-variables)] - [next-t-var (from-list transient-variables)] - [gvar-map '()] - [ivar-map '()] - [var-map '()]) + [g-var-idx n-global-variables] + [i-var-idx n-instance-variables] + [t-vars 0] + [gvar-map '()] + [ivar-map '()] + [var-map '()] + [exprs '()]) + + (define (extra-g-var) + (let ([mvar (add-expr #f `(#%vector-ref-immed #%globals + ,@(values->list (quotient/remainder g-var-idx 256))))]) + (set! g-var-idx (+ g-var-idx 1)) + mvar)) + + (define (extra-i-var) + (let ([mvar (add-expr #f `(#%vector-ref-immed #%inst + ,@(values->list (quotient/remainder i-var-idx 256))))]) + (set! i-var-idx (+ i-var-idx 1)) + mvar)) (define (add-g-var value) (cond @@ -42,65 +66,77 @@ [(equal? value '(quote ())) '#%nil] [else (let ([value (cond [(and (pair? value) (eq? (first value) 'quote)) (second value)] - [(symbol? value) `(#%builtin ,(symbol->string value))] + [(symbol? value) (error (string-append "Undefined symbol: " (symbol->string value)))] [else value])]) (or (lookup value gvar-map) - (let ([g-var (next-g-var)]) + (let ([g-var (or (next-g-var) (extra-g-var))]) (set! gvar-map (cons (list value g-var) gvar-map)) g-var)))])) (define (add-i-var source) (or (and (special-constant? source) source) (lookup source ivar-map) - (let ([i-var (next-i-var)]) + (let ([i-var (or (next-i-var) (extra-i-var))]) (set! ivar-map (cons (list source i-var) ivar-map)) i-var))) - (let ([exprs '()]) - (define (add-var var mvar) - (when var - (set! var-map - (cons (list var mvar) - (filter (lambda (x) (not (eq? (first x) var))) - var-map))))) + (define (add-var var mvar) + (when var + (set! var-map + (cons (list var mvar) + (filter (lambda (x) (not (eq? (first x) var))) + var-map)))) + mvar) - (define (add-expr var val) - (let ([tvar (next-t-var)]) - (set! exprs (cons `(#%set! ,tvar ,val) exprs)) - (add-var var tvar))) + (define (add-expr var val) + (let ([tvar (next-t-var)]) + (set! t-vars (+ 1 t-vars)) + (set! exprs (cons `(#%set! ,tvar ,val) exprs)) + (add-var var tvar))) - (for ([bound-var (in-list (second bind))]) - (add-var bound-var '#%undef)) + (for ([bound-var (in-list (second bind))]) + (add-var bound-var '#%undef)) - (for ([free-var (in-list (free-variables bind))]) - (let ([capt (lookup free-var capture-map)]) - (when capt (add-var free-var (add-i-var capt))))) + (for ([free-var (in-list (free-variables bind))]) + (let ([capt (lookup free-var capture-map)]) + (when capt (add-var free-var (add-i-var capt))))) - (for ([expr (in-list (cddr bind))]) - (let* ([setexpr? (and (pair? expr) (eq? (first expr) '#%set!))] - [var (if setexpr? (second expr) #f)] - [val (if setexpr? (third expr) expr)]) - (cond [(lambda-value? val) - (let ([newval (map-variables val var-map)]) - (if (eq? (first newval) '#%lambda) - (add-var var (add-g-var newval)) - (add-expr var `(#%make-lambda ,(add-g-var newval)))))] - [(literal-value? val) - (add-var var (add-g-var val))] - [(not (symbol? val)) - (add-expr var (map-form val - #:variable (lambda (recurse kind form) - (or (and (machine-variable? form) form) - (lookup form var-map) - (add-g-var form))) - #:literal (lambda (recurse kind form) - (add-g-var form))))] - [else - (add-var var (or (and (machine-variable? val) val) - (lookup val var-map) - (add-g-var val)))]))) + (let iter ([bind-exprs (cddr bind)]) + (cond + [(null? bind-exprs) + (void)] + [(>= t-vars 120) + (write-string "Too many expressions; splitting function.\n" (current-error-port)) + (let ([newval (map-variables `(#%lambda () () (#%bind () ,@bind-exprs)) var-map)]) + (add-expr #f + `(#%tail-call ,(add-g-var newval) #%argv #%kw-args #%kw-vals #%ctx #%k)))] + [else + (let* ([expr (car bind-exprs)] + [setexpr? (and (pair? expr) (eq? (first expr) '#%set!))] + [var (if setexpr? (second expr) #f)] + [val (if setexpr? (third expr) expr)]) + (cond [(lambda-value? val) + (let ([newval (map-variables val var-map)]) + (if (eq? (first newval) '#%lambda) + (add-var var (add-g-var newval)) + (add-expr var `(#%make-lambda ,(add-g-var newval)))))] + [(literal-value? val) + (add-var var (add-g-var val))] + [(not (symbol? val)) + (add-expr var (map-form val + #:variable (lambda (recurse kind form) + (or (and (machine-variable? form) form) + (lookup form var-map) + (add-g-var form))) + #:literal (lambda (recurse kind form) + (add-g-var form))))] + [else + (add-var var (or (and (machine-variable? val) val) + (lookup val var-map) + (add-g-var val)))])) + (iter (cdr bind-exprs))])) - (set! bind `(#%bind () ,@(reverse exprs)))) + (set! bind `(#%bind () ,@(reverse exprs))) `(,(if (null? ivar-map) '#%lambda '#%template) ,(map first (reverse gvar-map)) diff --git a/libcompiler/optimizer.scm b/libcompiler/optimizer.scm index 8b3ff13..898a7a1 100644 --- a/libcompiler/optimizer.scm +++ b/libcompiler/optimizer.scm @@ -2,6 +2,7 @@ (require scheme/list) (require scheme/match) +(require scheme/pretty) (require (file "utilities.scm")) (provide reduce-variables @@ -41,6 +42,11 @@ (map-form form #:bind bind-fn)) (define (propogate-value variable value invalidates? forms) + (if (invalidates? `(#%set! ,variable ,value)) + forms + (%propogate-value% variable value invalidates? forms))) + +(define (%propogate-value% variable value invalidates? forms) (if (null? forms) forms (let* ([form (car forms)] @@ -54,7 +60,7 @@ (eq? (second (car forms)) variable)) (invalidates? new-form)) (cons new-form after) - (cons new-form (propogate-value variable value invalidates? after)))))) + (cons new-form (%propogate-value% variable value invalidates? after)))))) ; Simple values (literals, variables) can replace arguments as well as #%set! values. (define (propogate-simple-value variable value invalidates? forms) diff --git a/libcompiler/primitives.scm b/libcompiler/primitives.scm index 16a4e8d..1b3100f 100644 --- a/libcompiler/primitives.scm +++ b/libcompiler/primitives.scm @@ -16,8 +16,7 @@ machine-variable?) (define unary-primitives - '((#%fatal-error #x00 fatal-error) - (#%unbox #x01 unbox) + '((#%unbox #x01 unbox) (#%weak-unbox #x02 weak-unbox) (#%car #x03 car) (#%cdr #x04 cdr) @@ -129,13 +128,15 @@ (#%set-box! #x50 set-box!) (#%set-car! #x51 set-car!) (#%set-cdr! #x52 set-cdr!) - (#%tail-call-if #x70 tail-call-if))) - + (#%tail-call-if #x70 (gensym)) + (#%fatal-error-if #xff fatal-error-if))) + (define ternary-primitives '((#%if #x10 if) (#%vector-set! #x20 vector-set!) (#%byte-string-set! #x21 byte-string-set!) - (#%struct-set! #x22 struct-set!))) + (#%struct-set! #x22 struct-set!) + (#%vector-ref-immed #xff (gensym)))) (define all-primitives (append unary-primitives @@ -143,23 +144,24 @@ ternary-primitives)) (define (side-effect-primitive? sym) - (memq sym '(#%byte-string-set! #%fatal-error #%set-box! #%set-car! - #%set-cdr! #%struct-set! #%tail-call-if #%vector-set!))) + (memq sym '(#%make-box #%make-struct #%make-lambda #%make-weak-box #%cons #%make-vector + #%make-byte-string #%set-box! #%set-car! #%set-cdr! #%tail-call-if + #%fatal-error-if #%struct-set! #%vector-set! #%byte-string-set!))) + +(define transient-variables + (for/list ([i (in-range 0 128)]) + (string->uninterned-symbol (string-append "#%t" (number->string i))))) (define global-variables (for/list ([i (in-range 0 64)]) (string->uninterned-symbol (string-append "#%g" (number->string i))))) (define instance-variables - (for/list ([i (in-range 0 64)]) + (for/list ([i (in-range 0 48)]) (string->uninterned-symbol (string-append "#%i" (number->string i))))) -(define transient-variables - (for/list ([i (in-range 0 128)]) - (string->uninterned-symbol (string-append "#%t" (number->string i))))) - (define special-variables - '(#%f #%nil #%undef #%self #%argv #%kw-args #%kw-vals #%ctx #%k)) + '(#%f #%nil #%undef #%self #%globals #%inst #%argv #%kw-args #%kw-vals #%ctx #%k)) (define (global-variable? var) (and (memq var global-variables) #t)) (define (instance-variable? var) (and (memq var instance-variables) #t)) diff --git a/libcompiler/reader.scm b/libcompiler/reader.scm index 8554911..d95c338 100644 --- a/libcompiler/reader.scm +++ b/libcompiler/reader.scm @@ -12,6 +12,7 @@ ,@(read-forms port))) (define (read-forms [port (current-input-port)]) + (port-count-lines! port) (let iter ([form (read port)] [forms '()]) (match form diff --git a/libcompiler/simplifier.scm b/libcompiler/simplifier.scm index d483f46..95f327d 100644 --- a/libcompiler/simplifier.scm +++ b/libcompiler/simplifier.scm @@ -2,16 +2,16 @@ (require scheme/list) (require scheme/match) +(require scheme/pretty) (require (file "utilities.scm")) (require (file "primitives.scm")) -(provide simplify-lambda - promote-free-variables) +(provide simplify-lambda) (define (simplify-form form) (define (same-form recurse . form) form) (define (reverse-args new-op args) - (simplify-form + (simplify-let (let ([a (gensym)] [b (gensym)]) `(let ([,a ,(first args)] [,b ,(second args)]) @@ -19,47 +19,45 @@ (define (simplify-complex-form recurse op . others) (case op - [(let) (simplify-let form)] - [(let*) (simplify-let* form)] - [(letrec) (simplify-letrec form)] - [(if) (simplify-if form)] - [(lambda) (simplify-lambda form)] - [(begin) (simplify-form `(let () ,@(cdr form)))] - [(set!) (simplify-set! form)] - [(let/cc) (simplify-form - `(call/cc (lambda (,(second form)) ,@(cddr form))))] - [(fix=) (simplify-form `(eq? ,@(cdr form)))] - [(fix>) (reverse-args 'fix< (cdr form))] - [(fix<=) (reverse-args 'fix>= (cdr form))] - [(float>) (reverse-args 'float< (cdr form))] - [(float<=) (reverse-args 'float>= (cdr form))] - [(byte-string>) (reverse-args 'byte-string< (cdr form))] - [(byte-string<=) (reverse-args 'byte-string>= (cdr form))] - [(value-list) (simplify-value-list form)] - [(values) (simplify-primitive '#%values (cdr form))] - [(list) (simplify-form `(value-list (values ,@(cdr form))))] - [(apply) (simplify-apply (second form) (cddr form))] - [(call/cc) (simplify-primitive '#%call/cc (cdr form))] + [(let) (simplify-let form)] + [(let*) (simplify-let* form)] + [(letrec) (simplify-letrec form)] + [(if) (simplify-if form)] + [(lambda) (simplify-lambda form)] + [(keyword-lambda) (simplify-keyword-lambda form)] + [(begin) (simplify-form `(let () ,@(cdr form)))] + [(set!) (simplify-set! form)] + [(let/cc) (simplify-form `(call/cc (lambda (,(second form)) ,@(cddr form))))] + [(fix=) (simplify-form `(eq? ,@(cdr form)))] + [(fix>) (reverse-args 'fix< (cdr form))] + [(fix<=) (reverse-args 'fix>= (cdr form))] + [(float>) (reverse-args 'float< (cdr form))] + [(float<=) (reverse-args 'float>= (cdr form))] + [(byte-string>) (reverse-args 'byte-string< (cdr form))] + [(byte-string<=) (reverse-args 'byte-string>= (cdr form))] + [(values->list) (simplify-values->list form)] + [(values) (simplify-primitive '#%values (cdr form))] + [(list) (simplify-form `(values->list (values ,@(cdr form))))] + [(apply) (simplify-apply (second form) (cddr form))] + [(call/cc) (simplify-primitive '#%call/cc (cdr form))] [(call-with-values) - (simplify-form - `(apply ,(third form) - (value-list (,(second form)))))] + (simplify-form `(apply ,(third form) (values->list (,(second form)))))] [(and) - (simplify-form - (cond - [(null? (cdr form)) '#t] - [(null? (cddr form)) (second form)] - [else (let ([x (gensym)]) - `(let ([,x ,(second form)]) - (if ,x (and ,@(cddr form)) ,x)))]))] + (cond + [(null? (cdr form)) '#t] + [(null? (cddr form)) (simplify-form (second form))] + [else (let ([x (gensym)]) + (simplify-form + `(let ([,x ,(second form)]) + (if ,x (and ,@(cddr form)) ,x))))])] [(or) - (simplify-form - (cond - [(null? (cdr form)) '#f] - [(null? (cddr form)) (second form)] - [else (let ([x (gensym)]) - `(let ([,x ,(second form)]) - (if ,x ,x (or ,@(cddr form)))))]))] + (cond + [(null? (cdr form)) '#f] + [(null? (cddr form)) (simplify-form (second form))] + [else (let ([x (gensym)]) + (simplify-form + `(let ([,x ,(second form)]) + (if ,x ,x (or ,@(cddr form))))))])] [(cond) (simplify-form (match (cdr form) @@ -77,14 +75,14 @@ (cdr form)) (simplify-apply (first form) (append (cdr form) '(#%nil)))))])) (map-form form - #:bind same-form - #:lambda same-form - #:set same-form - #:value-list same-form - #:primitive same-form - #:simple (lambda (recurse kind form) form) - #:literal (lambda (recurse kind form) form) - #:other simplify-complex-form)) + #:bind same-form + #:lambda same-form + #:set same-form + #:values->list same-form + #:primitive same-form + #:simple (lambda (recurse kind form) form) + #:literal (lambda (recurse kind form) form) + #:other simplify-complex-form)) (define (body->forms body) (let iter ([body body] @@ -117,13 +115,13 @@ (let ([tmp (gensym)]) `(#%bind (,tmp) ; guaranteed not to cause unbounded recursion: tmp is unique - ,(simplify-set! `(set! ,tmp ,value-form)) + ,(simplify-form `(set! ,tmp ,value-form)) (#%set! ,variable ,tmp))) `(#%bind ,bound-vars ,@(foldr (lambda (subform after) (if (pair? after) (cons subform after) - (list (simplify-set! `(set! ,variable ,subform))))) + (list (simplify-form `(set! ,variable ,subform))))) '() subforms)))] [`(#%values ,first-val . ,other-vals) @@ -135,7 +133,7 @@ [else (error "Attempted to set variable to void in:" form)]))) -(define (simplify-value-list form) +(define (simplify-values->list form) (let ([values-form (simplify-form (second form))]) (match values-form [`(#%bind ,bound-vars . ,subforms) @@ -143,23 +141,23 @@ ,@(foldr (lambda (subform after) (if (pair? after) (cons subform after) - (list (simplify-value-list `(value-list ,subform))))) + (list (simplify-form `(values->list ,subform))))) '() subforms))] [`(#%values) '#%nil] [`(#%values . ,simple-vals) - ; (#%value-list (#%values ...)) => (list ...) + ; (#%values->list (#%values ...)) => (list ...) (let ([tmp (gensym)]) `(#%bind (,tmp) (#%set! ,tmp #%nil) - ,@(map (lambda (x) (simplify-set! `(set! ,tmp (cons ,x ,tmp)))) + ,@(map (lambda (x) (simplify-form `(set! ,tmp (cons ,x ,tmp)))) (reverse simple-vals)) ,tmp))] [(or `(#%apply . ,_) `(#%call/cc . ,_)) - `(#%value-list ,values-form)] + `(#%values->list ,values-form)] [(? value-form?) - (simplify-value-list `(value-list (values ,values-form)))] + (simplify-form `(values->list (values ,values-form)))] [_ '#%nil]))) (define (simplify-primitive simple-op value-forms) @@ -168,7 +166,7 @@ (if (simple-value? simple-value-form) (list simple-value-form #f) (let ([tmp (gensym)]) - (list tmp (simplify-set! `(set! ,tmp ,simple-value-form))))))) + (list tmp (simplify-form `(set! ,tmp ,simple-value-form))))))) (define bindings (map value->binding value-forms)) @@ -218,7 +216,7 @@ (let ([temp-bindings (map (lambda (binding) (let ([tmp (gensym)]) (list tmp - (simplify-set! `(set! ,tmp ,(second binding))) + (simplify-form `(set! ,tmp ,(second binding))) `(#%set! ,(first binding) ,tmp)))) (filter has-value? bindings))]) `(#%bind ,(map first temp-bindings) @@ -229,7 +227,7 @@ ; Otherwise, just bind the real names directly. `(#%bind ,vars ,@(map (lambda (binding) - (simplify-set! `(set! ,@binding))) + (simplify-form `(set! ,@binding))) (filter has-value? bindings)) ,@(map simplify-form bodyexprs)))) @@ -311,78 +309,57 @@ ; (... ; (let ([rest argv-temp]) ; bodyexpr...)...)))...))) - -(define (promote-to-box variable form) +(define (promote-to-boxes variables form) (map-form form - #:bind (lambda (recurse op vars . subforms) - (flatten-binds - `(#%bind ,vars - ,@(if (memq variable vars) - `((#%set! ,variable (#%make-box ,variable))) - '()) - ,@(map recurse subforms)))) - #:set (lambda (recurse op var value) - (let ([new-value (recurse value)]) - (if (eq? var variable) - (if (simple-value? new-value) - `(#%set-box! ,variable ,new-value) - (let ([tmp (gensym)]) - `(#%bind (,tmp) - ,(simplify-set! `(set! ,tmp ,new-value)) - (#%set-box! ,variable ,tmp)))) - (simplify-set! `(set! ,var ,new-value))))) - #:value-list (lambda (recurse op values-form) - `(,op ,(recurse values-form))) - #:primitive (lambda (recurse op . simple-values) - (let ([new-args (map recurse simple-values)]) - ;; if any new-arg is not simple, must bind to a temp first - (let ([temps (map (lambda (x) - (if (simple-value? x) - (list x #f) - (let ([tmp (gensym)]) - (list tmp `(#%set! ,tmp ,x))))) - new-args)]) - (if (ormap second temps) - `(#%bind ,(map first (filter second temps)) - ,@(filter-map second temps) - (,op ,@(map first temps))) - `(,op ,@new-args))))) - #:variable (lambda (recurse op var) - (if (eq? var variable) `(#%unbox ,variable) var)))) + #:bind (lambda (recurse op vars . subforms) + (let ([unbound-vars (remove* vars variables)]) + (if (null? unbound-vars) + `(,op ,vars ,@subforms) + (flatten-binds + `(#%bind ,vars + ,@(map (lambda (f) (promote-to-boxes unbound-vars f)) + subforms)))))) + #:set (lambda (recurse op var value) + (let ([new-value (recurse value)]) + (if (memq var variables) + (simplify-form `(set-box! ,var ,new-value)) + (simplify-form `(set! ,var ,new-value))))) + #:values->list (lambda (recurse op values-form) + `(,op ,(recurse values-form))) + #:primitive (lambda (recurse op . simple-values) + (simplify-primitive op (map recurse simple-values))) + #:variable (lambda (recurse op var) + (if (memq var variables) + `(#%unbox ,var) + var)))) (define (is-shared-var? var forms) (define (set-after-first-capture?) (let/cc return (foldr (lambda (form set-after?) - (if (or set-after? (form-sets? form var #f)) - (if (form-captures-input? form var) - (return #t) - #t) - #f)) + (and (or set-after? (form-sets? form var #f)) + (if (form-captures-input? form var) + (return #t) + #t))) #f forms) #f)) (or (ormap (lambda (f) (form-captures-output? f var)) forms) (set-after-first-capture?))) -(define (promote-shared-variables nested-bind) - (define flat-bind (flatten-binds nested-bind)) - (foldl (lambda (var frm) - (if (is-shared-var? var (cddr frm)) - (promote-to-box var frm) - frm)) - flat-bind - (second flat-bind))) - -(define (promote-free-variables form) - (foldl promote-to-box form (free-variables form))) - -(define (narrow-binds+promote nested-bind) - (define flat-bind (flatten-binds nested-bind)) +(define (promote-shared-variables flat-bind) + (let* ([shared-vars (filter (lambda (v) (is-shared-var? v (cddr flat-bind))) + (second flat-bind))]) + (flatten-binds + `(#%bind ,(second flat-bind) + ,@(map (lambda (v) `(#%set! ,v (#%make-box #%undef))) shared-vars) + ,@(map (lambda (f) (promote-to-boxes shared-vars f)) (cddr flat-bind)))))) +(define (narrow-binds+promote flat-bind) (define (at-top-level? var) - (or (ormap (lambda (x) (form-uses? x var #f)) (cddr flat-bind)) - (ormap (lambda (x) (form-sets? x var #f)) (cddr flat-bind)))) + (ormap (lambda (x) (or (form-uses? x var #f) + (form-sets? x var #f))) + (cddr flat-bind))) (define (captured-twice? var) (let/cc return @@ -404,7 +381,8 @@ ,@(map (lambda (subform) (match subform [`(#%set! ,var (#%lambda ,g-vars ,i-vars ,bind)) - (define (free-var? v) (free-variable? v bind)) + (define free-vars (free-variables bind)) + (define (free-var? v) (memq v free-vars)) (define local-binds (filter free-var? extra-bindings)) (if (null? local-binds) subform @@ -425,8 +403,7 @@ (values reqs opts #f)] [_ (error "Invalid argument list:" arglist)])) -(define (add-return ctx k nested-bind) - (define flat-bind (flatten-binds nested-bind)) +(define (add-return ctx k flat-bind) (define argv (gensym)) `(#%bind (,@(second flat-bind) ,argv) ,@(foldr (lambda (subform after) @@ -435,9 +412,9 @@ (match subform [(? simple-value?) `((#%set! ,argv (#%cons ,subform #%nil)) - (#%tail-call ,k ,argv #%nil #%nil #f #f))] - [`(#%apply . ,sv) - `((#%tail-call ,@sv ,ctx ,k))] + (#%tail-call ,k ,argv #%nil #%nil #%undef #%undef))] + [`(#%apply ,fn ,av ,kw ,kv) + `((#%tail-call ,fn ,av ,kw ,kv ,ctx ,k))] [`(#%call/cc ,x) `((#%set! ,argv (#%cons ,k #%nil)) (#%tail-call ,x ,argv #%nil #%nil ,ctx ,k))] @@ -445,64 +422,71 @@ `((#%set! ,argv #%nil) ,@(map (lambda (sv) `(#%set! ,argv (#%cons ,sv ,argv))) (reverse simple-vals)) - (#%tail-call ,k ,argv #%nil #%nil #f #f))] + (#%tail-call ,k ,argv #%nil #%nil #%undef #%undef))] [(? value-form?) - `(,(simplify-set! `(set! ,argv ,subform)) + `((#%set! ,argv ,subform) (#%set! ,argv (#%cons ,argv #%nil)) - (#%tail-call ,k ,argv #%nil #%nil #f #f))] + (#%tail-call ,k ,argv #%nil #%nil #%undef #%undef))] [`(#%tail-call . ,_) `(,subform)] [_ `(,subform - (#%tail-call ,k #%nil #%nil #%nil #f #f))]))) + (#%tail-call ,k #%nil #%nil #%nil #%undef #%undef))]))) '() (cddr flat-bind)))) -(define (transform-to-cps ctx nested-bind) - (define flat-bind (flatten-binds nested-bind)) +(define (transform-to-cps ctx flat-bind) (define (cps-prepend subform after) (match subform - [`(#%set! ,v (#%value-list (#%apply . ,sv))) - (let ([k (gensym)]) + [`(#%set! ,v (#%values->list (#%apply ,fn ,av ,kw ,kv))) + (let ([k (gensym)] + [t (gensym)]) `((#%bind (,k) (#%set! ,k ,(simplify-form - `(lambda ,v + `(lambda ,t + (set! ,v ,t) ,@after))) - (#%tail-call ,@sv ,ctx ,k))))] - [`(#%set! ,v (#%apply . ,sv)) - (let ([k (gensym)]) + (#%tail-call ,fn ,av ,kw ,kv ,ctx ,k))))] + [`(#%set! ,v (#%apply ,fn ,av ,kw ,kv)) + (let ([k (gensym)] + [t (gensym)]) `((#%bind (,k) (#%set! ,k ,(simplify-form - `(lambda (,v . ,(gensym)) + `(lambda (,t . ,(gensym)) + (set! ,v ,t) ,@after))) - (#%tail-call ,@sv ,ctx ,k))))] - [(or `(#%value-list (#%apply . ,sv)) - `(#%apply . ,sv)) + (#%tail-call ,fn ,av ,kw ,kv ,ctx ,k))))] + [(or `(#%values->list (#%apply ,fn ,av ,kw ,kv)) + `(#%apply ,fn ,av ,kw ,kv)) (let ([k (gensym)]) `((#%bind (,k) (#%set! ,k ,(simplify-form `(lambda ,(gensym) ,@after))) - (#%tail-call ,@sv ,ctx ,k))))] - [`(#%set! ,v (#%value-list (#%call/cc ,x))) + (#%tail-call ,fn ,av ,kw ,kv ,ctx ,k))))] + [`(#%set! ,v (#%values->list (#%call/cc ,x))) (let ([k (gensym)] - [k-argv (gensym)]) + [k-argv (gensym)] + [t (gensym)]) `((#%bind (,k ,k-argv) (#%set! ,k ,(simplify-form - `(lambda ,v + `(lambda ,t + (set! ,v ,t) ,@after))) (#%set! ,k-argv (#%cons ,k #%nil)) (#%tail-call ,x ,k-argv #%nil #%nil ,ctx ,k))))] [`(#%set! ,v (#%call/cc ,x)) (let ([k (gensym)] - [k-argv (gensym)]) + [k-argv (gensym)] + [t (gensym)]) `((#%bind (,k ,k-argv) (#%set! ,k ,(simplify-form - `(lambda (,v . ,(gensym)) + `(lambda (,t . ,(gensym)) + (set! ,v ,t) ,@after))) (#%set! ,k-argv (#%cons ,k #%nil)) (#%tail-call ,x ,k-argv #%nil #%nil ,ctx ,k))))] - [(or `(#%value-list (#%call/cc ,x)) + [(or `(#%values->list (#%call/cc ,x)) `(#%call/cc ,x)) (let ([k (gensym)] [k-argv (gensym)]) @@ -519,23 +503,16 @@ `(#%bind ,(second flat-bind) ,@(foldr cps-prepend '() (cddr flat-bind)))) -(define (simplify-lambda form) - (define arglist (cadr form)) - (define bodyexprs (cddr form)) - +(define (arguments->lets arglist argv bodyexprs) (define-values (requireds optionals rest) (split-arglist arglist)) - (define argv (gensym)) - (define ctx (gensym)) - (define k (gensym)) - (define (add-req req inner) `(let ([,req (car ,argv)]) (set! ,argv (cdr ,argv)) ,inner)) (define (add-opt opt-list inner) - `(let (,(car opt-list)) + `(let (,(first opt-list)) (if (pair? ,argv) (begin (set! ,(first opt-list) (car ,argv)) @@ -548,19 +525,54 @@ `(let ([,rest ,argv]) ,@bodyexprs) `(begin ,@bodyexprs))) + (foldr add-req + (foldr add-opt + rest+bodyexprs + optionals) + requireds)) + +(define (simplify-lambda form) + (define arglist (cadr form)) + (define bodyexprs (cddr form)) + (define argv (gensym)) + (define ctx (gensym)) + (define k (gensym)) + `(#%lambda () () ,((compose narrow-binds+promote + flatten-binds (lambda (bind) (transform-to-cps ctx bind)) (lambda (bind) (add-return ctx k bind)) + flatten-binds simplify-form) `(let ([,argv #%argv] [,ctx #%ctx] [,k #%k]) - ,(foldr add-req - (foldr add-opt - rest+bodyexprs - optionals) - requireds))))) + ,(arguments->lets arglist argv bodyexprs))))) + +(define (simplify-keyword-lambda form) + (define arglist (cadr form)) + (define bodyexprs (cddr form)) + (define argv (gensym)) + (define kw-args (car arglist)) + (define kw-vals (cadr arglist)) + (define normal-args (cddr arglist)) + (define ctx (gensym)) + (define k (gensym)) + + `(#%lambda () () + ,((compose narrow-binds+promote + flatten-binds + (lambda (bind) (transform-to-cps ctx bind)) + (lambda (bind) (add-return ctx k bind)) + flatten-binds + simplify-form) + `(let ([,argv #%argv] + [,kw-args #%kw-args] + [,kw-vals #%kw-vals] + [,ctx #%ctx] + [,k #%k]) + ,(arguments->lets normal-args argv bodyexprs))))) ; (fn-expr arg-expr...) ; => (let ([fn-var fn-expr] arg-var... argv) @@ -587,7 +599,8 @@ [`(,expr . ,(and rst `(,_ . ,_))) (let-values ([(bnd args kws) (iter rst)] [(x) (gensym)]) - (values (cons `[,x ,expr] bnd) (cons x args) kws))]))) + (values (cons `[,x ,expr] bnd) (cons x args) kws))] + [_ (error "Malformed argument list")]))) (define sorted-kws (sort keywords keywordlist)) (or (simple-value? form) (memq (first form) complex-values) (memq (first form) (map first all-primitives)))) @@ -133,76 +133,76 @@ (and (pair? form) (eq? (first form) '#%bind))) (define (traverse-form form - #:bind [bind-fn (lambda (recurse op vars . subforms) - (for ([subform (in-list subforms)]) - (recurse subform)))] - #:lambda [lambda-fn (lambda (recurse op g-vars i-vars bind) - (recurse bind))] - #:set [set-fn (lambda (recurse op var value-form) - (recurse value-form))] - #:value-list [value-list-fn (lambda (recurse op values-form) - (recurse values-form))] - #:primitive [primitive-fn (lambda (recurse op . simple-values) - (for ([val (in-list simple-values)]) - (recurse val)))] - #:simple [simple-fn (lambda (recurse kind simple-value) (void))] - #:other [other-fn (lambda (recurse . form) - (error "Unsimplified form:" form))] - #:values [values-fn primitive-fn] - #:call [call-fn primitive-fn] - #:variable [variable-fn simple-fn] - #:literal [literal-fn simple-fn] - #:apply [apply-fn call-fn] - #:call/cc [call/cc-fn call-fn] - #:tail-call [tail-call-fn call-fn]) + #:bind [bind-fn (lambda (recurse op vars . subforms) + (for ([subform (in-list subforms)]) + (recurse subform)))] + #:lambda [lambda-fn (lambda (recurse op g-vars i-vars bind) + (recurse bind))] + #:set [set-fn (lambda (recurse op var value-form) + (recurse value-form))] + #:values->list [values->list-fn (lambda (recurse op values-form) + (recurse values-form))] + #:primitive [primitive-fn (lambda (recurse op . simple-values) + (for ([val (in-list simple-values)]) + (recurse val)))] + #:simple [simple-fn (lambda (recurse kind simple-value) (void))] + #:other [other-fn (lambda (recurse . form) + (error "Unsimplified form:" form))] + #:values [values-fn primitive-fn] + #:call [call-fn primitive-fn] + #:variable [variable-fn simple-fn] + #:literal [literal-fn simple-fn] + #:apply [apply-fn call-fn] + #:call/cc [call/cc-fn call-fn] + #:tail-call [tail-call-fn call-fn]) (define (recurse subform) (cond [(variable-value? subform) (variable-fn recurse 'variable subform)] [(literal-value? subform) (literal-fn recurse 'literal subform)] [else (let ([handler (case (first subform) - [(#%bind) bind-fn] - [(#%lambda) lambda-fn] - [(#%set!) set-fn] - [(#%value-list) value-list-fn] - [(#%values) values-fn] - [(#%apply) apply-fn] - [(#%call/cc) call/cc-fn] - [(#%tail-call) tail-call-fn] - [else (if (primitive-form? subform) - primitive-fn - other-fn)])]) + [(#%bind) bind-fn] + [(#%lambda) lambda-fn] + [(#%set!) set-fn] + [(#%values->list) values->list-fn] + [(#%values) values-fn] + [(#%apply) apply-fn] + [(#%call/cc) call/cc-fn] + [(#%tail-call) tail-call-fn] + [else (if (primitive-form? subform) + primitive-fn + other-fn)])]) (apply handler recurse subform))])) (recurse form)) (define map-form (curry-keywords traverse-form - #:bind (lambda (recurse op vars . subforms) - `(,op ,vars ,@(map recurse subforms))) - #:lambda (lambda (recurse op g-vars i-vars bind) - `(,op ,g-vars ,i-vars ,(recurse bind))) - #:set (lambda (recurse op var value-form) - `(,op ,var ,(recurse value-form))) - #:value-list (lambda (recurse op values-form) - `(,op ,(recurse values-form))) - #:primitive (lambda (recurse op . simple-values) - `(,op ,@(map recurse simple-values))) - #:simple (lambda (recurse kind form) form))) + #:bind (lambda (recurse op vars . subforms) + `(,op ,vars ,@(map recurse subforms))) + #:lambda (lambda (recurse op g-vars i-vars bind) + `(,op ,g-vars ,i-vars ,(recurse bind))) + #:set (lambda (recurse op var value-form) + `(,op ,var ,(recurse value-form))) + #:values->list (lambda (recurse op values-form) + `(,op ,(recurse values-form))) + #:primitive (lambda (recurse op . simple-values) + `(,op ,@(map recurse simple-values))) + #:simple (lambda (recurse kind form) form))) ; Like map-form, but intended for boolean results. (define search-form (curry-keywords traverse-form - #:bind (lambda (recurse op vars . subforms) - (ormap recurse subforms)) - #:lambda (lambda (recurse op g-vars i-vars bind) - (recurse bind)) - #:set (lambda (recurse op var value) - (recurse value)) - #:value-list (lambda (recurse op var values-form) - (recurse values-form)) - #:primitive (lambda (recurse op . simple-values) - (ormap recurse simple-values)) - #:simple (lambda (recurse kind form) #f))) + #:bind (lambda (recurse op vars . subforms) + (ormap recurse subforms)) + #:lambda (lambda (recurse op g-vars i-vars bind) + (recurse bind)) + #:set (lambda (recurse op var value) + (recurse value)) + #:values->list (lambda (recurse op var values-form) + (recurse values-form)) + #:primitive (lambda (recurse op . simple-values) + (ormap recurse simple-values)) + #:simple (lambda (recurse kind form) #f))) (define (form-sets? form variable [call-may-set? #t]) (search-form form @@ -281,12 +281,12 @@ (define (flatten-binds form) (define (make-bindings-unique bind rename-vars) (define (needs-rename? var) (memq var rename-vars)) - (define (make-binding-unique var bind) - (let* ([prefix (string-append (symbol->string var) "->g")] - [unique-var (gensym prefix)]) - `(#%bind ,(subst var unique-var (second bind)) - ,@(map (lambda (sf) (subst-var var unique-var sf)) (cddr bind))))) - (foldr make-binding-unique bind (filter needs-rename? (second bind)))) + (define (unique-var var) + (let ([prefix (string-append (symbol->string var) "->g")]) + (list var (gensym prefix)))) + (let ([var-map (map unique-var (filter needs-rename? (second bind)))]) + `(#%bind ,(subst* var-map (second bind)) + ,@(map (lambda (sf) (subst-var* var-map sf)) (cddr bind))))) (map-form form #:bind (lambda (recurse op bound-vars . original-subforms) diff --git a/libcompiler/writer.scm b/libcompiler/writer.scm index 714d370..4f17345 100644 --- a/libcompiler/writer.scm +++ b/libcompiler/writer.scm @@ -87,6 +87,8 @@ (cond [(and (eq? ch #\")) (write-string "\\\"")] + [(and (eq? ch #\\)) + (write-string "\\\\")] [(and (< (char->integer ch) 128) (char-graphic? ch)) (write-char ch)] [else @@ -215,6 +217,9 @@ [(and (pair? value) (memq (car value) '(#%builtin))) (write-string "#=") (write-rla-string (second value))] + [(and (pair? value) (memq (car value) '(#%include))) + (write-string "#i") + (write-rla-string (second value))] [(and (pair? value) (memq (car value) '(#%immutable))) (unless (number? (hash-ref (current-object-map) (second value) #f)) (write-string "#@")) @@ -258,8 +263,8 @@ (and index (+ #xc0 index))) (let ([index (find var '(#%f #%nil #%undef))]) (and index (+ #xf0 index))) - (let ([index (find var '(#%self #%argv #%kw-args #%kw-vals #%ctx #%k))]) - (and index (+ #xfa index))) + (let ([index (find var '(#%self #%globals #%inst #%argv #%kw-args #%kw-vals #%ctx #%k))]) + (and index (+ #xf8 index))) (error "No bytecode for variable:" var))) (define (statement->code form) @@ -279,10 +284,15 @@ (variable->code (third vform))))] [(3) (let ([item (assoc (first vform) ternary-primitives)]) (or item (error "Invalid ternary primitive:" vform)) - (list (second item) - (variable->code (second vform)) - (variable->code (third vform)) - (variable->code (fourth vform))))] + (if (eq? (first vform) '#%vector-ref-immed) + (list (second item) + (variable->code (second vform)) + (third vform) + (fourth vform)) + (list (second item) + (variable->code (second vform)) + (variable->code (third vform)) + (variable->code (fourth vform)))))] [else (error "Unsupported form:" vform)]))) ; vim:set sw=2 expandtab: diff --git a/mods/mod_io.c b/mods/mod_io.c index 1749a45..8c73876 100644 --- a/mods/mod_io.c +++ b/mods/mod_io.c @@ -9,6 +9,7 @@ #include #include #include +#include #include "gc.h" #include "builtin.h" @@ -24,12 +25,13 @@ static void bi_posix_read(interp_state_t *state); static void bi_posix_write(interp_state_t *state); static void bi_posix_lseek(interp_state_t *state); static void bi_posix_close(interp_state_t *state); +static void bi_posix_chdir(interp_state_t *state); +static void bi_posix_getcwd(interp_state_t *state); void mod_io_init(void) { register_builtin(BI_IO_POSIX_OPEN, make_builtin_fn(bi_posix_open)); //register_builtin(BI_IO_POSIX_OPENAT, make_builtin_fn(bi_posix_openat)); - register_builtin(BI_IO_POSIX_OPENAT, UNDEFINED); register_builtin(BI_IO_POSIX_DUP, make_builtin_fn(bi_posix_dup)); register_builtin(BI_IO_POSIX_DUP2, make_builtin_fn(bi_posix_dup2)); @@ -39,6 +41,9 @@ void mod_io_init(void) register_builtin(BI_IO_POSIX_LSEEK, make_builtin_fn(bi_posix_lseek)); register_builtin(BI_IO_POSIX_CLOSE, make_builtin_fn(bi_posix_close)); + + register_builtin(BI_IO_POSIX_CHDIR, make_builtin_fn(bi_posix_chdir)); + register_builtin(BI_IO_POSIX_GETCWD, make_builtin_fn(bi_posix_getcwd)); } static void bi_posix_open(interp_state_t *state) @@ -151,12 +156,22 @@ static void bi_posix_write(interp_state_t *state) { int fd = get_fixnum(CAR(state->argv.value)); value_t str = CAR(_CDR(state->argv.value)); - fixnum_t count = get_fixnum(CAR(_CDDR(state->argv.value))); + fixnum_t count; ssize_t result; int saved_errno; release_assert(is_byte_string(str)); - release_assert(is_nil(_CDR(_CDDR(state->argv.value)))); + + if (!is_nil(_CDDR(state->argv.value))) + { + count = get_fixnum(CAR(_CDDR(state->argv.value))); + release_assert(is_nil(_CDR(_CDDR(state->argv.value)))); + } + else + { + count = _get_byte_string(str)->size; + } + release_assert((0 <= count) && (count <= _get_byte_string(str)->size)); errno = 0; @@ -221,4 +236,48 @@ static void bi_posix_close(interp_state_t *state) NIL))); } +static void bi_posix_chdir(interp_state_t *state) +{ + char *pathname; + int saved_errno; + int result; + + pathname = value_to_string(CAR(state->argv.value)); + release_assert(is_nil(CDR(state->argv.value))); + + errno = 0; + result = chdir(pathname); + saved_errno = errno; + free(pathname); + + interp_return_values(state, + cons(boolean_value(!result), + cons(fixnum_value(saved_errno), + NIL))); +} + +static void bi_posix_getcwd(interp_state_t *state) +{ + static char buffer[PATH_MAX]; + value_t result_value = FALSE_VALUE; + char *result; + int saved_errno; + + release_assert(is_nil(state->argv.value)); + + errno = 0; + result = getcwd(buffer, sizeof buffer); + saved_errno = errno; + + if (result != NULL) + { + result_value = string_to_value(buffer); + } + + interp_return_values(state, + cons(result_value, + cons(fixnum_value(saved_errno), + NIL))); +} + /* vim:set sw=2 expandtab: */ diff --git a/mods/mod_io.h b/mods/mod_io.h index ce04dcd..1712f76 100644 --- a/mods/mod_io.h +++ b/mods/mod_io.h @@ -16,6 +16,9 @@ #define BI_IO_POSIX_CLOSE "posix-close" +#define BI_IO_POSIX_CHDIR "posix-chdir" +#define BI_IO_POSIX_GETCWD "posix-getcwd" + void mod_io_init(void); #endif diff --git a/reader.c b/reader.c index ec1a4fd..c9613d0 100644 --- a/reader.c +++ b/reader.c @@ -284,8 +284,8 @@ static value_t read_list(reader_state_t *state) gc_root_t list_root; bool done = false; - register_gc_root(&list_root, NIL); next_char(state); + register_gc_root(&list_root, NIL); while (!done) { @@ -738,12 +738,16 @@ static value_t read_struct(reader_state_t *state) static value_t read_weak_box(reader_state_t *state) { - value_t value; + gc_root_t value_root; next_char(state); - value = read_one_value(state); - state->weak_list.value = cons(value, state->weak_list.value); - return make_weak_box(value); + register_gc_root(&value_root, NIL); + + value_root.value = read_one_value(state); + state->weak_list.value = cons(value_root.value, state->weak_list.value); + + unregister_gc_root(&value_root); + return make_weak_box(value_root.value); } static value_t read_definition(reader_state_t *state) @@ -857,11 +861,10 @@ static void set_reference(reader_state_t *state, value_t ref, value_t value) static void finalize_references(reader_state_t *state) { - bool changed = true; + bool changed; /* We're done when no placeholders link to other placeholders. */ - while (changed) - { + do { changed = false; /* Resolve one level of placeholder-to-placeholder links. */ @@ -881,7 +884,7 @@ static void finalize_references(reader_state_t *state) changed = true; } } - } + } while (changed); } static value_t _patch_placeholders(reader_state_t *state, value_t in, void *seen) @@ -953,8 +956,8 @@ static value_t _patch_placeholders(reader_state_t *state, value_t in, void *seen for (int i = 0; i < _get_struct(in_root.value)->nslots; ++i) { - _get_struct(in_root.value)->slots[i] = - _patch_placeholders(state, _get_struct(in_root.value)->slots[i], &this_seen); + value_t val = _patch_placeholders(state, _get_struct(in_root.value)->slots[i], &this_seen); + _get_struct(in_root.value)->slots[i] = val; WRITE_BARRIER(in_root.value); } } @@ -963,19 +966,23 @@ static value_t _patch_placeholders(reader_state_t *state, value_t in, void *seen { value_t val = _patch_placeholders(state, _get_box(in_root.value)->value, &this_seen); _get_box(in_root.value)->value = val; + WRITE_BARRIER(in_root.value); } else if (is_weak_box(in_root.value)) { value_t val = _patch_placeholders(state, _get_weak_box(in_root.value)->value, &this_seen); _get_weak_box(in_root.value)->value = val; + WRITE_BARRIER(in_root.value); } else if (is_pair(in_root.value)) { value_t val; val = _patch_placeholders(state, _CAR(in_root.value), &this_seen); _CAR(in_root.value) = val; + WRITE_BARRIER(in_root.value); val = _patch_placeholders(state, _CDR(in_root.value), &this_seen); _CDR(in_root.value) = val; + WRITE_BARRIER(in_root.value); } else if (is_vector(in_root.value)) { @@ -984,6 +991,7 @@ static value_t _patch_placeholders(reader_state_t *state, value_t in, void *seen { value_t val = _patch_placeholders(state, _get_vector(in_root.value)->elements[i], &this_seen); _get_vector(in_root.value)->elements[i] = val; + WRITE_BARRIER(in_root.value); } } @@ -993,15 +1001,8 @@ static value_t _patch_placeholders(reader_state_t *state, value_t in, void *seen static value_t patch_placeholders(reader_state_t *state, value_t in) { - gc_root_t root; - register_gc_root(&root, in); - finalize_references(state); - - root.value = _patch_placeholders(state, root.value, NULL); - - unregister_gc_root(&root); - return root.value; + return _patch_placeholders(state, in, NULL); } static void skip_whitespace(reader_state_t *state) diff --git a/rosella.c b/rosella.c index b1ea08d..bf87383 100644 --- a/rosella.c +++ b/rosella.c @@ -47,7 +47,7 @@ int main(int argc, char **argv) } #endif - gc_init(1024*1024, 1024*1024, 4*1024*1024); + gc_init(8*1024*1024, 4*1024*1024, 64*1024*1024); builtin_init(); interpreter_init(); #ifdef HAVE_MOD_IO @@ -55,27 +55,28 @@ int main(int argc, char **argv) #endif reader_init(); - if (argc < 2 || (strcmp(argv[1], "-t") == 0) || (strcmp(argv[1], "--test") == 0)) + if ((argc >= 2) && ((strcmp(argv[1], "-t") == 0) || (strcmp(argv[1], "--test") == 0))) { test_builtins(); test_weak_boxes_and_wills(); test_garbage_collection(false); } - else if ((strcmp(argv[1], "-b") == 0) || (strcmp(argv[1], "--burn-in") == 0)) + else if ((argc >= 2) && ((strcmp(argv[1], "-b") == 0) || (strcmp(argv[1], "--burn-in") == 0))) { test_garbage_collection(true); } - else if ((strcmp(argv[1], "-r") == 0) || (strcmp(argv[1], "--reader") == 0)) + else if ((argc >= 2) && ((strcmp(argv[1], "-r") == 0) || (strcmp(argv[1], "--reader") == 0))) { test_reader(); } else { gc_root_t argv_root; - value_t program; + gc_root_t program_root; value_t results; - register_gc_root(&argv_root, NIL); + register_gc_root(&argv_root, NIL); + register_gc_root(&program_root, NIL); /* Construct list backward, so that we don't have to reverse it. */ for (int i = argc - 1; i >= 2; --i) @@ -84,10 +85,22 @@ int main(int argc, char **argv) argv_root.value = cons(temp, argv_root.value); } - program = read_value_from_path(argv[1]); + if (argc >= 2) + { + program_root.value = read_value_from_path(argv[1]); + } + else + { + program_root.value = read_value_from_file(stdin); + fflush(stdin); + } + + collect_garbage(4*1024*1024); unregister_gc_root(&argv_root); - results = run_interpreter(program, argv_root.value); + unregister_gc_root(&program_root); + + results = run_interpreter(program_root.value, argv_root.value); for (value_t result = results; !is_nil(result); result = _CDR(result)) { diff --git a/src/compiler.rls b/src/compiler.rls new file mode 100644 index 0000000..da21526 --- /dev/null +++ b/src/compiler.rls @@ -0,0 +1,1053 @@ +(load "lib/primitives.rls") +(load "lib/primitive/foldl.rls") +(load "lib/primitive/foldr.rls") +(load "lib/primitive/reverse.rls") +(load "lib/primitive/map.rls") +(load "lib/primitive/append.rls") +(load "lib/util.rls") +(load "lib/hash-table.rls") +(load "lib/symbols.rls") +(load "lib/keywords.rls") +(load "lib/parameters.rls") +(load "lib/abort.rls") +(load "lib/errors.rls") +(load "lib/port.rls") +(load "lib/display.rls") +(load "lib/reader.rls") + +(define s:evaluation-environment (make-structure '() 2)) + +(define (make-evaluation-environment parent-env n-vars) + (let ([env (make-struct s:evaluation-environment)]) + (struct-set! env 0 parent-env) + (struct-set! env 1 (make-vector n-vars undefined)) + (freeze! env))) + +(define (initialize-evaluation-environment eval-env val-list) + (let ([vec (evaluation-environment-local-variable-values eval-env)]) + (let iter ([i 0] [lst val-list]) + (when (pair? lst) + (vector-set! vec i (first lst)) + (iter (fix+ i 1) (rest lst)))))) + +(define (evaluation-environment-parent-environment env) (struct-ref env 0)) +(define (evaluation-environment-local-variable-values env) (struct-ref env 1)) + +(define s:compilation-environment (make-structure '() 5)) + +(define (make-compilation-environment + parent-env + variable-list + [syntax-transformer-list (if parent-env + (compilation-environment-syntax-transformers parent-env) + '())]) + (let ([env (make-struct s:compilation-environment)]) + (struct-set! env 0 parent-env) + (struct-set! env 1 (if variable-list + (freeze! (list->vector variable-list)) + (make-vector 0 #f))) + (struct-set! env 2 syntax-transformer-list) + (struct-set! env 3 (if (pair? variable-list) + (let ([n-vars (list-length variable-list)]) + (lambda (eval-env) (make-evaluation-environment eval-env n-vars))) + (lambda (eval-env) eval-env))) + (struct-set! env 4 (if (pair? variable-list) + evaluation-environment-parent-environment + values)) + (freeze! env))) + +(define (compilation-environment-parent-environment env) (struct-ref env 0)) +(define (compilation-environment-local-variables env) (struct-ref env 1)) +(define (compilation-environment-syntax-transformers env) (struct-ref env 2)) +(define (compilation-environment-eval-constructor env) (struct-ref env 3)) +(define (compilation-environment-eval-parent env) (struct-ref env 4)) + +(define current-compilation-environment (make-parameter #f)) +(define current-syntax-compilation-environment (make-parameter #f)) +(define current-syntax-evaluation-environment (make-parameter #f)) + +(define (lookup-syntax-transformer symbol [comp-env (current-compilation-environment)]) + (cond + [(not comp-env) #f] + [(vector-find (compilation-environment-local-variables comp-env) + (lambda (sym) (eq? sym symbol))) #f] + [else + (let iter ([transformers (compilation-environment-syntax-transformers comp-env)]) + (if (pair? transformers) + (let ([transformer (car transformers)]) + (if (eq? (car transformer) symbol) + (cdr transformer) + (iter (cdr transformers)))) + (lookup-syntax-transformer symbol + (compilation-environment-parent-environment comp-env))))])) + +(define (syntax-expand form [expanded-fn values] [final-fn values]) + (if (pair? form) + (let* ([first-form (first form)] + [transform-fn (lookup-syntax-transformer first-form)]) + (if transform-fn + (expanded-fn (apply transform-fn (rest form))) + (final-fn form))) + (final-fn form))) + +(define (syntax-expand/full form) + (syntax-expand form syntax-expand/full)) + +(define current-unbound-variable-handler (make-parameter (lambda (symbol) (abort)))) + +; fn: (lambda (get-fn set-fn) ...) => tail-value +; get-fn: (lambda (eval-env) ...) => value +; set-fn: (lambda (eval-env value) ...) [void] +(define (variable-accessors symbol) + (let iter ([env-values-op evaluation-environment-local-variable-values] + [comp-env (current-compilation-environment)]) + (if (not comp-env) + (call-with-values + (lambda () ((current-unbound-variable-handler) symbol)) + (lambda (get-fn set-fn) + (values (lambda (eval-env) (get-fn)) + (lambda (eval-env val) (set-fn val))))) + (let* ([syms (compilation-environment-local-variables comp-env)] + [idx (vector-find syms (lambda (x) (eq? x symbol)))]) + (if idx + (values (lambda (eval-env) (vector-ref (env-values-op eval-env) idx)) + (lambda (eval-env val) (vector-set! (env-values-op eval-env) idx val))) + (iter (let ([parent-op (compilation-environment-eval-parent comp-env)]) + (lambda (eval-env) + (env-values-op (parent-op eval-env)))) + (compilation-environment-parent-environment comp-env))))))) + +(define (variable-getter symbol) + (call-with-values + (lambda () (variable-accessors symbol)) + (lambda (get-fn set-fn) get-fn))) + +(define (variable-setter symbol) + (call-with-values + (lambda () (variable-accessors symbol)) + (lambda (get-fn set-fn) set-fn))) + +(define (compile form [top-level-bindings '()] [syntax-transformer-list '()]) + (let* ([bound-vars (map car top-level-bindings)] + [initial-vals (map cdr top-level-bindings)] + [comp-env (make-compilation-environment #f bound-vars syntax-transformer-list)] + [syn-comp-env (make-compilation-environment #f bound-vars syntax-transformer-list)] + [eval-env-op (compilation-environment-eval-constructor comp-env)] + [syn-eval-env ((compilation-environment-eval-constructor syn-comp-env) #f)]) + (call-with-parameters + (lambda () + (initialize-evaluation-environment syn-eval-env initial-vals) + (let ([form-op (compile-form form)]) + (lambda () + (let ([eval-env (eval-env-op #f)]) + (initialize-evaluation-environment eval-env initial-vals) + (form-op eval-env))))) + (list current-compilation-environment comp-env) + (list current-syntax-compilation-environment syn-comp-env) + (list current-syntax-evaluation-environment syn-eval-env)))) + +(define (compile-form form) + (let ([expanded-form (syntax-expand/full form)]) + (cond + [(symbol? expanded-form) (compile-symbol expanded-form)] + [(pair? expanded-form) (compile-list expanded-form)] + [else (lambda (eval-env) expanded-form)]))) + +(define (compile-symbol form) + (variable-getter form)) + +(define (compile-list form) + (let* ([first-form (first form)]) + ((cond + [(eq? first-form 'quote) compile-quote-form] + [(eq? first-form 'begin) compile-begin-form] + [(eq? first-form 'if) compile-if-form] + [(eq? first-form 'set!) compile-set!-form] + [(eq? first-form 'lambda) compile-lambda-form] + [(eq? first-form 'let) compile-let-form] + [(eq? first-form 'letrec) compile-letrec-form] + [(eq? first-form 'let-syntax) compile-let-syntax-form] + [(eq? first-form 'let-for-syntax) compile-let-for-syntax-form] + [(eq? first-form 'letrec-for-syntax) compile-letrec-for-syntax-form] + [else compile-function-call-form]) + form))) + +(define (compile-quote-form form) + (let ([vals (rest form)]) + (lambda (eval-env) (apply values vals)))) + +(define (compile-forms forms) + (if (null? forms) + void + (let ([first-op (compile-form (first forms))]) + (if (null? (rest forms)) + first-op + (let ([rest-op (compile-body-forms (rest forms))]) + (lambda (eval-env) (first-op eval-env) (rest-op eval-env))))))) + +; (letrec-for-syntax (deferred-for-syntax-defines... +; immediate-for-syntax-defines...) +; (let-syntax (syntax-defines...) +; (letrec (deferred-defines... +; immediate-defines...) +; non-define-forms...))) +(define (compile-body-forms forms) + (define (deferred-form? form) + (let ([expanded-form (syntax-expand/full form)]) + (and (pair? expanded-form) + (or (eq? (first expanded-form) 'lambda) + (and (eq? (first expanded-form) 'values) + (andmap deferred-form? (rest expanded-form))))))) + + (define (extract-for-syntax-defines all-forms) + (let iter ([deferred-bindings '()] + [other-bindings '()] + [other-forms '()] + [forms all-forms]) + (if (pair? forms) + (let ([form (syntax-expand/full (first forms))]) + (cond + [(not (pair? form)) + (iter deferred-bindings other-bindings (cons form other-forms) (rest forms))] + [(eq? (first form) 'begin) + (iter deferred-bindings other-bindings other-forms + (append (rest form) (rest forms)))] + [(eq? (first form) 'define-for-syntax) + (if (pair? (second form)) + (iter (cons (list (first (second form)) + (list* 'lambda (rest (second form)) + (rest (rest form)))) + deferred-bindings) + other-bindings other-forms (rest forms)) + (if (and (pair? (rest (rest form))) (deferred-form? (third form))) + (iter (cons (rest form) deferred-bindings) + other-bindings other-forms (rest forms)) + (iter deferred-bindings + (cons (rest form) other-bindings) + other-forms (rest forms))))] + [(eq? (first form) 'define-values-for-syntax) + (if (deferred-form? (third form)) + (iter (cons (rest form) deferred-bindings) + other-bindings other-forms (rest forms)) + (iter deferred-bindings + (cons (rest form) other-bindings) + other-forms (rest forms)))] + [else + (iter deferred-bindings other-bindings (cons form other-forms) (rest forms))])) + (values (reverse (append other-bindings deferred-bindings)) + (reverse other-forms))))) + + (define (extract-syntax-defines for-syntax-bindings remaining-forms) + (let iter ([syntax-bindings '()] + [other-forms '()] + [forms remaining-forms]) + (if (pair? forms) + (let ([form (syntax-expand/full (first forms))]) + (cond + [(not (pair? form)) + (iter syntax-bindings (cons form other-forms) (rest forms))] + [(eq? (first form) 'define-syntax) + (if (pair? (second form)) + (iter (cons (list (first (second form)) + (list* 'lambda (rest (second form)) + (rest (rest form)))) + syntax-bindings) + other-forms (rest forms)) + (iter (cons (rest form) syntax-bindings) + other-forms (rest forms)))] + [else + (iter syntax-bindings (cons form other-forms) (rest forms))])) + (values for-syntax-bindings + (reverse syntax-bindings) + (reverse other-forms))))) + + (define (extract-defines for-syntax-bindings syntax-bindings remaining-forms) + (let iter ([deferred-bindings '()] + [other-bindings '()] + [other-forms '()] + [forms remaining-forms]) + (if (pair? forms) + (let ([form (syntax-expand/full (first forms))]) + (cond + [(not (pair? form)) + (iter deferred-bindings + other-bindings + (cons form other-forms) + (rest forms))] + [(eq? (first form) 'define) + (if (pair? (second form)) + (iter (cons (list (first (second form)) + (list* 'lambda (rest (second form)) + (rest (rest form)))) + deferred-bindings) + other-bindings + other-forms + (rest forms)) + (if (and (pair? (rest (rest form))) (deferred-form? (third form))) + (iter (cons (rest form) deferred-bindings) + other-bindings + other-forms + (rest forms)) + (iter deferred-bindings + (cons (rest form) other-bindings) + other-forms + (rest forms))))] + [(eq? (first form) 'define-values) + (if (deferred-form? (third form)) + (iter (cons (rest form) deferred-bindings) + other-bindings + other-forms + (rest forms)) + (iter deferred-bindings + (cons (rest form) other-bindings) + other-forms + (rest forms)))] + [else + (iter deferred-bindings other-bindings (cons form other-forms) (rest forms))])) + (values for-syntax-bindings + syntax-bindings + (reverse (append other-bindings deferred-bindings)) + (reverse other-forms))))) + + (define (add-wrappers for-syntax-bindings syntax-bindings bindings other-forms) + (define (add-wrapper type binds forms) + (if (pair? binds) + (list (list* type binds forms)) + forms)) + (add-wrapper 'letrec-for-syntax for-syntax-bindings + (add-wrapper 'let-syntax syntax-bindings + (add-wrapper 'letrec bindings + other-forms)))) + + ((compose compile-forms + add-wrappers + extract-defines + extract-syntax-defines + extract-for-syntax-defines) forms)) + +(define (compile-begin-form form) + (compile-body-forms (rest form))) + +(define (compile-if-form form) + (let ([cond-op (compile-form (second form))] + [true-op (compile-form (third form))] + [false-op (compile-form (fourth form))]) + (lambda (eval-env) + (if (cond-op eval-env) + (true-op eval-env) + (false-op eval-env))))) + +(define (compile-set!-form form) + (let iter ([pairs (rest form)]) + (let* ([symbol (first pairs)] + [value-op (compile-form (second pairs))] + [set!-op (let ([setter (variable-setter symbol)]) + (lambda (eval-env) + (setter eval-env (value-op eval-env))))]) + (if (null? (rest (rest pairs))) + set!-op + (let ([next-op (iter (rest (rest pairs)))]) + (lambda (eval-env) + (set!-op eval-env) + (next-op eval-env))))))) + +(define (binding->symbols binding) + (cond + [(not (pair? binding)) (list binding)] + [(not (pair? (first binding))) (list (first binding))] + [else (first binding)])) + +(define (bindings->symbols bindings) + (foldr (lambda (binding base) + (foldr cons base (binding->symbols binding))) + '() + bindings)) + +(define (generate-init-function bind-vars next-bind-op) + (let iter ([setters (map variable-setter bind-vars)]) + (if (pair? setters) + (let ([set-fn (first setters)] + [next-op (iter (rest setters))]) + (lambda (var-eval-env value-eval-env vals) + (set-fn var-eval-env (first vals)) + (next-op var-eval-env value-eval-env (rest vals)))) + (lambda (var-eval-env value-eval-env vals) + (next-bind-op var-eval-env value-eval-env))))) + +(define (compile-bindings bindings var-comp-env value-comp-env) + (if (pair? bindings) + (let ([next-bind-op (compile-bindings (rest bindings) var-comp-env value-comp-env)] + [bind (first bindings)]) + (if (and (pair? bind) (pair? (rest bind))) + (let* ([bind-vars (binding->symbols bind)] + [values-op (call-with-parameters + (lambda () (compile-form (second bind))) + (list current-compilation-environment value-comp-env))] + [init-op (call-with-parameters + (lambda () (generate-init-function bind-vars next-bind-op)) + (list current-compilation-environment var-comp-env))]) + (lambda (var-eval-env value-eval-env) + (init-op var-eval-env + value-eval-env + (values->list (values-op value-eval-env))))) + next-bind-op)) + void)) + +(define (default-duplicate-binding-handler form-type symbol) + (call-with-parameters + (lambda () + (write-string "Duplicate binding in ") + (display form-type) + (write-string " form: ") + (display symbol) + (write-char #\Newline)) + (list current-output-port (current-error-port)))) + +(define current-duplicate-binding-handler (make-parameter default-duplicate-binding-handler)) + +(define (check-for-duplicates form-type symbols) + (let ([dup (has-duplicates? symbols)]) + (when dup + ((current-duplicate-binding-handler) form-type (first dup)) + (abort)))) + +(define (compile-let-form form) + (if (and (symbol? (second form)) (or (null? (third form)) (pair? (third form)))) + (let ([bound-vars (bindings->symbols (third form))]) + (check-for-duplicates 'let (cons (second form) bound-vars)) + (compile-let-form + (list 'let (third form) + (list 'letrec (list (list (second form) (list* 'lambda bound-vars + (rest (rest (rest form)))))) + (list* (second form) bound-vars))))) + (let* ([bindings (second form)] + [bound-vars (bindings->symbols bindings)] + [outer-comp-env (current-compilation-environment)] + [inner-comp-env (make-compilation-environment outer-comp-env bound-vars)] + [eval-env-op (compilation-environment-eval-constructor inner-comp-env)] + [init-op (compile-bindings bindings inner-comp-env outer-comp-env)] + [body-op (call-with-parameters + (lambda () (compile-body-forms (rest (rest form)))) + (list current-compilation-environment inner-comp-env))]) + (check-for-duplicates 'let bound-vars) + (lambda (outer-eval-env) + (let ([inner-eval-env (eval-env-op outer-eval-env)]) + (init-op inner-eval-env outer-eval-env) + (body-op inner-eval-env)))))) + +(define (compile-letrec-form form) + (if (and (symbol? (second form)) (or (null? (third form)) (pair? (third form)))) + (let ([bound-vars (bindings->symbols (third form))]) + (check-for-duplicates 'letrec (cons (second form) bound-vars)) + (compile-letrec-form + (list 'letrec (third form) + (list 'letrec (list (list (second form) (list* 'lambda bound-vars + (rest (rest (rest form)))))) + (list* (second form) bound-vars))))) + (let* ([bindings (second form)] + [bound-vars (bindings->symbols bindings)] + [outer-comp-env (current-compilation-environment)] + [inner-comp-env (make-compilation-environment outer-comp-env bound-vars)] + [eval-env-op (compilation-environment-eval-constructor inner-comp-env)] + [init-op (compile-bindings bindings inner-comp-env inner-comp-env)] + [body-op (call-with-parameters + (lambda () (compile-body-forms (rest (rest form)))) + (list current-compilation-environment inner-comp-env))]) + (check-for-duplicates 'letrec bound-vars) + (lambda (outer-eval-env) + (let ([inner-eval-env (eval-env-op outer-eval-env)]) + (init-op inner-eval-env inner-eval-env) + (body-op inner-eval-env)))))) + +(define (compile-let-syntax-form form) + (let* ([outer-comp-env (current-compilation-environment)] + [outer-syn-comp-env (current-syntax-compilation-environment)] + [syn-eval-env (current-syntax-evaluation-environment)] + [bound-syntax (call-with-parameters + (lambda () + (map (lambda (x) + (cons (first x) + ((compile-form (second x)) syn-eval-env))) + (second form))) + (list current-compilation-environment outer-syn-comp-env))] + [inner-comp-env (make-compilation-environment outer-comp-env #f bound-syntax)] + [inner-syn-comp-env (make-compilation-environment outer-syn-comp-env #f bound-syntax)]) + (check-for-duplicates 'let-syntax (map car bound-syntax)) + (call-with-parameters + (lambda () (compile-body-forms (rest (rest form)))) + (list current-compilation-environment inner-comp-env) + (list current-syntax-compilation-environment inner-syn-comp-env)))) + +(define (compile-let-for-syntax-form form) + (let* ([bindings (second form)] + [bound-vars (bindings->symbols bindings)] + [outer-comp-env (current-syntax-compilation-environment)] + [outer-eval-env (current-syntax-evaluation-environment)] + [inner-comp-env (make-compilation-environment outer-comp-env bound-vars)] + [eval-env-op (compilation-environment-eval-constructor inner-comp-env)] + [inner-eval-env ((eval-env-op) outer-eval-env)] + [init-op (compile-bindings bindings inner-comp-env outer-comp-env)]) + (check-for-duplicates 'let-for-syntax bound-vars) + (init-op inner-eval-env outer-eval-env) + (call-with-parameters + (lambda () (compile-body-forms (rest (rest form)))) + (list current-syntax-compilation-environment inner-comp-env) + (list current-syntax-evaluation-environment inner-eval-env)))) + +(define (compile-letrec-for-syntax-form form) + (let* ([bindings (second form)] + [bound-vars (bindings->symbols bindings)] + [outer-comp-env (current-syntax-compilation-environment)] + [outer-eval-env (current-syntax-evaluation-environment)] + [inner-comp-env (make-compilation-environment outer-comp-env bound-vars)] + [eval-env-op (compilation-environment-eval-constructor inner-comp-env)] + [inner-eval-env ((eval-env-op) outer-eval-env)] + [init-op (compile-bindings bindings inner-comp-env inner-comp-env)]) + (check-for-duplicates 'letrec-syntax bound-vars) + (init-op inner-eval-env inner-eval-env) + (call-with-parameters + (lambda () (compile-body-forms (rest (rest form)))) + (list current-syntax-compilation-environment inner-comp-env) + (list current-syntax-evaluation-environment inner-eval-env)))) + +(define (compile-args forms) + (if (null? forms) + (lambda (eval-env) '()) + (let ([arg-op (compile-form (first forms))]) + (if (null? (rest forms)) + (lambda (eval-env) (list (arg-op eval-env))) + (let ([rest-op (compile-args (rest forms))]) + (lambda (eval-env) + (let ([arg (arg-op eval-env)]) + (cons arg (rest-op eval-env))))))))) + +(define (compile-function-call-form form) + (let ([fn-op (compile-form (first form))] + [args-op (compile-args (rest form))]) + (lambda (eval-env) + (apply (fn-op eval-env) (args-op eval-env))))) + +(define (arguments->symbols arglist) + (let iter ([args arglist]) + (cond + [(null? args) '()] + [(symbol? args) (list args)] + [(pair? (first args)) + (let opt-iter ([opt-args args]) + (cond + [(null? opt-args) '()] + [(symbol? opt-args) (list opt-args)] + [else (cons (first (first opt-args)) + (opt-iter (rest opt-args)))]))] + [else (cons (first args) (iter (rest args)))]))) + +(define (default-missing-argument-handler next-symbol) + (call-with-parameters + (lambda () + (write-string "Expected value for argument: ") + (display next-symbol) + (write-char #\Newline)) + (list current-output-port (current-error-port)))) + +(define (default-extra-argument-handler extra-arguments) + (call-with-parameters + (lambda () + (write-string "Extra arguments in function call: ") + (display extra-arguments) + (write-char #\Newline)) + (list current-output-port (current-error-port)))) + +(define current-missing-argument-handler (make-parameter default-missing-argument-handler)) +(define current-extra-argument-handler (make-parameter default-extra-argument-handler)) + +(define (check-not-end-of-arglist next-sym rst) + (unless (pair? rst) + ((current-missing-argument-handler) next-sym) + (abort))) + +(define (check-end-of-arglist rst) + (unless (null? rst) + ((current-extra-argument-handler) rst) + (abort))) + +(define (compile-arguments arglist) + (cond + [(null? arglist) + (lambda (eval-env vals) + (check-end-of-arglist vals))] + [(symbol? arglist) + (let ([setter (variable-setter arglist)]) + (lambda (eval-env vals) + (setter eval-env vals)))] + [else + (let ([next-op (compile-arguments (rest arglist))] + [arg (first arglist)]) + (if (pair? arg) + (let ([setter (variable-setter (first arg))] + [default-op (compile-form (second arg))]) + (lambda (eval-env vals) + (setter eval-env (if (null? vals) + (default-op eval-env) + (first vals))) + (next-op eval-env (if (null? vals) '() (rest vals))))) + (let ([setter (variable-setter arg)]) + (lambda (eval-env vals) + (check-not-end-of-arglist arg vals) + (setter eval-env (first vals)) + (next-op eval-env (rest vals))))))])) + +(define (compile-lambda-form form) + (let* ([bound-vars (arguments->symbols (second form))] + [comp-env (make-compilation-environment (current-compilation-environment) bound-vars)] + [eval-env-op (compilation-environment-eval-constructor comp-env)]) + (check-for-duplicates 'lambda bound-vars) + (call-with-parameters + (lambda () + (let ([args-op (compile-arguments (second form))] + [body-op (compile-body-forms (rest (rest form)))]) + (lambda (eval-env) + (lambda argv + (let ([inner-eval-env (eval-env-op eval-env)]) + (args-op inner-eval-env argv) + (body-op inner-eval-env)))))) + (list current-compilation-environment comp-env)))) + +(define *top-level-bindings* '()) +(define *top-level-syntax-transformers* '()) + +(define (register-top-level-binding sym val) + (set! *top-level-bindings* + (cons (cons sym val) *top-level-bindings*))) + +(define (register-top-level-syntax symbol fn) + (set! *top-level-syntax-transformers* + (cons (cons symbol fn) *top-level-syntax-transformers*))) + +((lambda () +(register-top-level-binding 'unbox (lambda (x) (#%unbox x))) +(register-top-level-binding 'weak-unbox (lambda (x) (#%weak-unbox x))) +(register-top-level-binding 'car (lambda (x) (#%car x))) +(register-top-level-binding 'cdr (lambda (x) (#%cdr x))) +(register-top-level-binding 'null? (lambda (x) (eq? x '()))) +(register-top-level-binding 'boolean? (lambda (x) (#%boolean? x))) +(register-top-level-binding 'fixnum? (lambda (x) (#%fixnum? x))) +(register-top-level-binding 'box? (lambda (x) (#%box? x))) +(register-top-level-binding 'pair? (lambda (x) (#%pair? x))) +(register-top-level-binding 'vector? (lambda (x) (#%vector? x))) +(register-top-level-binding 'byte-string? (lambda (x) (#%byte-string? x))) +(register-top-level-binding 'struct? (lambda (x) (#%struct? x))) +(register-top-level-binding 'float? (lambda (x) (#%float? x))) +(register-top-level-binding 'builtin? (lambda (x) (#%builtin? x))) +(register-top-level-binding 'weak-box? (lambda (x) (#%weak-box? x))) +(register-top-level-binding 'make-box (lambda (x) (#%make-box x))) +(register-top-level-binding 'make-struct (lambda (x) (#%make-struct x))) +(register-top-level-binding 'make-float (lambda (x) (#%make-float x))) +(register-top-level-binding 'make-weak-box (lambda (x) (#%make-weak-box x))) +(register-top-level-binding 'not (lambda (x) (#%not x))) +(register-top-level-binding 'bit-not (lambda (x) (#%bit-not x))) +(register-top-level-binding 'fix-neg (lambda (x) (#%fix- x))) +(register-top-level-binding 'float-neg (lambda (x) (#%float- x))) +(register-top-level-binding 'vector-size (lambda (x) (#%vector-size x))) +(register-top-level-binding 'byte-string-size (lambda (x) (#%byte-string-size x))) +(register-top-level-binding 'struct-nslots (lambda (x) (#%struct-nslots x))) +(register-top-level-binding 'struct-type (lambda (x) (#%struct-type x))) +(register-top-level-binding 'hash-value (lambda (x) (#%hash-value x))) +(register-top-level-binding 'acos (lambda (x) (#%acos x))) +(register-top-level-binding 'asin (lambda (x) (#%asin x))) +(register-top-level-binding 'atan (lambda (x) (#%atan x))) +(register-top-level-binding 'cos (lambda (x) (#%cos x))) +(register-top-level-binding 'sin (lambda (x) (#%sin x))) +(register-top-level-binding 'tan (lambda (x) (#%tan x))) +(register-top-level-binding 'cosh (lambda (x) (#%cosh x))) +(register-top-level-binding 'sinh (lambda (x) (#%sinh x))) +(register-top-level-binding 'tanh (lambda (x) (#%tanh x))) +(register-top-level-binding 'exp (lambda (x) (#%exp x))) +(register-top-level-binding 'frexp (lambda (x) (#%frexp x))) +(register-top-level-binding 'log (lambda (x) (#%log x))) +(register-top-level-binding 'log10 (lambda (x) (#%log10 x))) +(register-top-level-binding 'modf (lambda (x) (#%modf x))) +(register-top-level-binding 'sqrt (lambda (x) (#%sqrt x))) +(register-top-level-binding 'ceil (lambda (x) (#%ceil x))) +(register-top-level-binding 'fabs (lambda (x) (#%fabs x))) +(register-top-level-binding 'floor (lambda (x) (#%floor x))) +(register-top-level-binding 'erf (lambda (x) (#%erf x))) +(register-top-level-binding 'erfc (lambda (x) (#%erfc x))) +(register-top-level-binding 'j0 (lambda (x) (#%j0 x))) +(register-top-level-binding 'j1 (lambda (x) (#%j1 x))) +(register-top-level-binding 'lgamma (lambda (x) (#%lgamma x))) +(register-top-level-binding 'y0 (lambda (x) (#%y0 x))) +(register-top-level-binding 'y1 (lambda (x) (#%y1 x))) +(register-top-level-binding 'asinh (lambda (x) (#%asinh x))) +(register-top-level-binding 'acosh (lambda (x) (#%acosh x))) +(register-top-level-binding 'atanh (lambda (x) (#%atanh x))) +(register-top-level-binding 'cbrt (lambda (x) (#%cbrt x))) +(register-top-level-binding 'logb (lambda (x) (#%logb x))) +(register-top-level-binding 'expm1 (lambda (x) (#%expm1 x))) +(register-top-level-binding 'ilogb (lambda (x) (#%ilogb x))) +(register-top-level-binding 'log1p (lambda (x) (#%log1p x))) +(register-top-level-binding 'normal? (lambda (x) (#%normal? x))) +(register-top-level-binding 'finite? (lambda (x) (#%finite? x))) +(register-top-level-binding 'subnormal? (lambda (x) (#%subnormal? x))) +(register-top-level-binding 'infinite? (lambda (x) (#%infinite? x))) +(register-top-level-binding 'nan? (lambda (x) (#%nan? x))) +)) + +((lambda () +(register-top-level-binding 'eq? (lambda (x y) (#%eq? x y))) +(register-top-level-binding 'cons (lambda (x y) (#%cons x y))) +(register-top-level-binding 'make-vector (lambda (x y) (#%make-vector x y))) +(register-top-level-binding 'make-byte-string (lambda (x y) (#%make-byte-string x y))) +(register-top-level-binding 'vector-ref (lambda (x y) (#%vector-ref x y))) +(register-top-level-binding 'byte-string-ref (lambda (x y) (#%byte-string-ref x y))) +(register-top-level-binding 'struct-ref (lambda (x y) (#%struct-ref x y))) +(register-top-level-binding 'fix+ (lambda (x y) (#%fix+ x y))) +(register-top-level-binding 'fix- (lambda (x y) (#%fix- x y))) +(register-top-level-binding 'fix* (lambda (x y) (#%fix* x y))) +(register-top-level-binding 'fix/ (lambda (x y) (#%fix/ x y))) +(register-top-level-binding 'fix% (lambda (x y) (#%fix% x y))) +(register-top-level-binding 'fix= (lambda (x y) (#%eq? x y))) +(register-top-level-binding 'fix< (lambda (x y) (#%fix< x y))) +(register-top-level-binding 'fix> (lambda (x y) (#%fix< y x))) +(register-top-level-binding 'fix>= (lambda (x y) (#%fix>= x y))) +(register-top-level-binding 'fix<= (lambda (x y) (#%fix>= y x))) +(register-top-level-binding 'bit-and (lambda (x y) (#%bit-and x y))) +(register-top-level-binding 'bit-or (lambda (x y) (#%bit-or x y))) +(register-top-level-binding 'bit-xor (lambda (x y) (#%bit-xor x y))) +(register-top-level-binding 'fix<< (lambda (x y) (#%fix<< x y))) +(register-top-level-binding 'fix>> (lambda (x y) (#%fix>> x y))) +(register-top-level-binding 'fix>>> (lambda (x y) (#%fix>>> x y))) +(register-top-level-binding 'float+ (lambda (x y) (#%float+ x y))) +(register-top-level-binding 'float- (lambda (x y) (#%float- x y))) +(register-top-level-binding 'float* (lambda (x y) (#%float* x y))) +(register-top-level-binding 'float/ (lambda (x y) (#%float/ x y))) +(register-top-level-binding 'float= (lambda (x y) (#%float= x y))) +(register-top-level-binding 'float< (lambda (x y) (#%float< x y))) +(register-top-level-binding 'float> (lambda (x y) (#%float< y x))) +(register-top-level-binding 'float>= (lambda (x y) (#%float>= x y))) +(register-top-level-binding 'float<= (lambda (x y) (#%float>= y x))) +(register-top-level-binding 'atan2 (lambda (x y) (#%atan2 x y))) +(register-top-level-binding 'pow (lambda (x y) (#%pow x y))) +(register-top-level-binding 'ldexp (lambda (x y) (#%ldexp x y))) +(register-top-level-binding 'fmod (lambda (x y) (#%fmod x y))) +(register-top-level-binding 'hypot (lambda (x y) (#%hypot x y))) +(register-top-level-binding 'jn (lambda (x y) (#%jn x y))) +(register-top-level-binding 'yn (lambda (x y) (#%yn x y))) +(register-top-level-binding 'nextafter (lambda (x y) (#%nextafter x y))) +(register-top-level-binding 'remainder (lambda (x y) (#%remainder x y))) +(register-top-level-binding 'scalb (lambda (x y) (#%scalb x y))) +(register-top-level-binding 'kind-of? (lambda (x y) (#%kind-of? x y))) +(register-top-level-binding 'byte-string= (lambda (x y) (#%byte-string= x y))) +(register-top-level-binding 'byte-string< (lambda (x y) (#%byte-string< x y))) +(register-top-level-binding 'byte-string> (lambda (x y) (#%byte-string< y x))) +(register-top-level-binding 'byte-string>= (lambda (x y) (#%byte-string>= x y))) +(register-top-level-binding 'byte-string<= (lambda (x y) (#%byte-string>= y x))) +(register-top-level-binding 'set-box! (lambda (x y) (#%set-box! x y))) +(register-top-level-binding 'set-car! (lambda (x y) (#%set-car! x y))) +(register-top-level-binding 'set-cdr! (lambda (x y) (#%set-cdr! x y))) +)) + +((lambda () +(register-top-level-binding 'if (lambda (x y z) (#%if x y z))) +(register-top-level-binding 'vector-set! (lambda (x y z) (#%vector-set! x y z))) +(register-top-level-binding 'byte-string-set! (lambda (x y z) (#%byte-string-set! x y z))) +(register-top-level-binding 'struct-set! (lambda (x y z) (#%struct-set! x y z))) +(register-top-level-binding 'fatal-error-if (lambda (x y) (#%fatal-error-if x y))) + +(register-top-level-binding 'undefined (#%builtin "undefined")) +(register-top-level-binding 's:structure (#%builtin "structure")) +(register-top-level-binding 's:lambda (#%builtin "lambda")) +(register-top-level-binding 's:template (#%builtin "template")) +(register-top-level-binding '+NaN (#%builtin "+NaN")) +(register-top-level-binding '-NaN (#%builtin "-NaN")) +(register-top-level-binding '+infinity (#%builtin "+infinity")) +(register-top-level-binding '-infinity (#%builtin "-infinity")) +(register-top-level-binding 'values (#%builtin "values")) +(register-top-level-binding 'freeze! (#%builtin "freeze!")) +(register-top-level-binding 'immutable? (#%builtin "immutable?")) +(register-top-level-binding 'string->number (#%builtin "string->number")) +(register-top-level-binding 'builtin-display (#%builtin "display")) +(register-top-level-binding 'register-finalizer (#%builtin "register-finalizer")) +(register-top-level-binding 'current-context (#%builtin "current-context")) +(register-top-level-binding 'call-with-context (#%builtin "call-with-context")) +(register-top-level-binding 'posix-open (#%builtin "posix-open")) +(register-top-level-binding 'posix-dup (#%builtin "posix-dup")) +(register-top-level-binding 'posix-dup2 (#%builtin "posix-dup2")) +(register-top-level-binding 'posix-read (#%builtin "posix-read")) +(register-top-level-binding 'posix-write (#%builtin "posix-write")) +(register-top-level-binding 'posix-lseek (#%builtin "posix-lseek")) +(register-top-level-binding 'posix-close (#%builtin "posix-close")) +)) + +((lambda () +(register-top-level-binding 'call/cc call/cc) +(register-top-level-binding 'call-with-values call-with-values) +(register-top-level-binding 'list list) +(register-top-level-binding 'foldl foldl) +(register-top-level-binding 'foldr foldr) +(register-top-level-binding 'reverse reverse) +(register-top-level-binding 'map map) +(register-top-level-binding 'append append) + +(register-top-level-binding 'copy-list copy-list) +(register-top-level-binding 'byte-substring byte-substring) +(register-top-level-binding 'copy-byte-string copy-byte-string) +(register-top-level-binding 'byte-string-find-first byte-string-find-first) +(register-top-level-binding 'byte-string-find-last byte-string-find-last) +(register-top-level-binding 'dirname/basename dirname/basename) +(register-top-level-binding 'dirname dirname) +(register-top-level-binding 'basename basename) +(register-top-level-binding 'make-structure make-structure) +(register-top-level-binding 'eqv? eqv?) +(register-top-level-binding 'trace trace) +(register-top-level-binding 'foreach-range foreach-range) +(register-top-level-binding 'findf findf) +(register-top-level-binding 'memq memq) +(register-top-level-binding 'memq? memq?) +(register-top-level-binding 'first first) +(register-top-level-binding 'rest rest) +(register-top-level-binding 'second second) +(register-top-level-binding 'third third) +(register-top-level-binding 'fourth fourth) +(register-top-level-binding 'void void) +(register-top-level-binding 'list* list*) +(register-top-level-binding 'apply apply) +(register-top-level-binding 'list-length list-length) +(register-top-level-binding 'repeat repeat) +(register-top-level-binding 'byte-string-append byte-string-append) +(register-top-level-binding 'list->string list->string) +(register-top-level-binding 'number->string number->string) +(register-top-level-binding 'andmap andmap) +(register-top-level-binding 'ormap ormap) +(register-top-level-binding 'list->vector list->vector) +(register-top-level-binding 'compose compose) +(register-top-level-binding 'vector-find vector-find) +(register-top-level-binding 'has-duplicates? has-duplicates?) +)) + +((lambda () +(register-top-level-binding 'hash-table? hash-table?) +(register-top-level-binding 'hash-table-hash-function hash-table-hash-function) +(register-top-level-binding 'hash-table-eq-function hash-table-eq-function) +(register-top-level-binding 'hash-table-entries hash-table-entries) +(register-top-level-binding 'hash-table-lookup hash-table-lookup) +(register-top-level-binding 'hash-table-insert hash-table-insert) +(register-top-level-binding 'hash-table-remove hash-table-remove) + +(register-top-level-binding 'make-symbol make-symbol) +(register-top-level-binding 'symbol? symbol?) +(register-top-level-binding 'symbol->string symbol->string) +(register-top-level-binding 'string->symbol string->symbol) +(register-top-level-binding 'gensym gensym) + +(register-top-level-binding 'make-keyword make-keyword) +(register-top-level-binding 'keyword? keyword?) +(register-top-level-binding 'keyword->string keyword->string) +(register-top-level-binding 'string->keyword string->keyword) + +(register-top-level-binding 'make-parameter make-parameter) +(register-top-level-binding 'parameter? parameter?) +(register-top-level-binding 'parameter-guard-function parameter-guard-function) +(register-top-level-binding 'call-with-parameters call-with-parameters) + +(register-top-level-binding 'current-abort-handler current-abort-handler) +(register-top-level-binding 'abort abort) +(register-top-level-binding 'call-with-abort-handler call-with-abort-handler) + +(register-top-level-binding 'current-argument-error-handler current-argument-error-handler) +(register-top-level-binding 'current-type-error-handler current-type-error-handler) +(register-top-level-binding 'type-check type-check) +)) + +((lambda () +(register-top-level-binding 'EOF EOF) +(register-top-level-binding 'eof? eof?) +(register-top-level-binding 'current-port-error-handler current-port-error-handler) +(register-top-level-binding 'current-port-eof-handler current-port-eof-handler) +(register-top-level-binding 'port? port?) +(register-top-level-binding 'make-port make-port) +(register-top-level-binding 'port-flags port-flags) +(register-top-level-binding 'port-data port-data) +(register-top-level-binding 'port-read port-read) +(register-top-level-binding 'port-unread port-unread) +(register-top-level-binding 'port-write port-write) +(register-top-level-binding 'port-seek port-seek) +(register-top-level-binding 'port-tell port-tell) +(register-top-level-binding 'port-flush port-flush) +(register-top-level-binding 'port-close port-close) +(register-top-level-binding 'port-closed? port-closed?) +(register-top-level-binding 'port-position port-position) +(register-top-level-binding 'input-port? input-port?) +(register-top-level-binding 'output-port? output-port?) +(register-top-level-binding 'binary-port? binary-port?) +(register-top-level-binding 'buffered-port? buffered-port?) +(register-top-level-binding 'posix-port? posix-port?) +(register-top-level-binding 'posix-port-file-descriptor posix-port-file-descriptor) +(register-top-level-binding 'make-posix-port make-posix-port) +(register-top-level-binding 'open-posix-input-port open-posix-input-port) +(register-top-level-binding 'open-posix-output-port open-posix-output-port) +(register-top-level-binding 'posix-standard-input-port posix-standard-input-port) +(register-top-level-binding 'posix-standard-output-port posix-standard-output-port) +(register-top-level-binding 'posix-standard-error-port posix-standard-error-port) +(register-top-level-binding 'current-input-port current-input-port) +(register-top-level-binding 'current-output-port current-output-port) +(register-top-level-binding 'current-error-port current-error-port) +(register-top-level-binding 'write-char write-char) +(register-top-level-binding 'write-string write-string) +(register-top-level-binding 'read-char read-char) +(register-top-level-binding 'peek-char peek-char) +(register-top-level-binding 'read-line read-line) + +(register-top-level-binding 'display display) +)) + +((lambda () +(register-top-level-binding 'current-read-eof-handler current-read-eof-handler) +(register-top-level-binding 'current-read-syntax-error-handler current-read-syntax-error-handler) +(register-top-level-binding 'read read) +(register-top-level-binding 'whitespace? whitespace?) +(register-top-level-binding 'octal-char? octal-char?) +(register-top-level-binding 'decimal-char? decimal-char?) +(register-top-level-binding 'hex-char? hex-char?) +(register-top-level-binding 'upcase-char? upcase-char?) +(register-top-level-binding 'downcase-char? downcase-char?) +(register-top-level-binding 'alphabetic-char? alphabetic-char?) +(register-top-level-binding 'alphanumeric-char? alphanumeric-char?) +(register-top-level-binding 'symbol-char? symbol-char?) +(register-top-level-binding 'digit->integer digit->integer) + +(register-top-level-binding 'compile compile) +(register-top-level-binding 'current-duplicate-binding-handler current-duplicate-binding-handler) +(register-top-level-binding 'current-missing-argument-handler current-missing-argument-handler) +(register-top-level-binding 'current-extra-argument-handler current-extra-argument-handler) +)) + +(define (%backquote-map% forms) + (let iter ([forms forms] + [result (list 'append)]) + (cond + [(null? forms) + (reverse result)] + [(not (pair? forms)) + (reverse (cons (list 'quote forms) result))] + [(eq? (first forms) 'unquote) + (reverse (cons (first forms) result))] + [(not (pair? (first forms))) + (iter (rest forms) (cons (list 'list (list 'quote (first forms))) result))] + [(eq? (first (first forms)) 'unquote-splicing) + (iter (rest forms) (cons (second (first forms)) result))] + [(eq? (first (first forms)) 'unquote) + (iter (rest forms) (cons (list 'list (second (first forms))) result))] + [else + (iter (rest forms) (cons (list 'list (%backquote% (first forms))) result))]))) + +(define (%backquote% form) + (cond + [(not (pair? form)) + (list 'quote form)] + [(eq? (first form) 'unquote) + (second form)] + [(eq? (first form) 'backquote) + (list 'quote (list 'quote form))] + ;(%backquote% (%backquote% (second form)))] + [else + (%backquote-map% form)])) + +(register-top-level-syntax 'backquote + (lambda subforms + (cons 'values (map %backquote% subforms)))) + +(define (read-module [label "(stdin)"]) + (define (syntax-error-handler line col char) + (call-with-parameters + (lambda () + (write-string "Syntax error at ") + (write-string label) + (write-string ":") + (display line) + (write-string ":") + (display col) + (write-string ": ") + (if char + (begin + (display (make-byte-string 1 char)) + (write-char #\Newline) + (when (eq? (current-input-port) posix-standard-input-port) + (let/cc return + (call-with-parameters + (lambda () + (port-seek (current-input-port) 0 'from-end) + (let iter () (port-read (current-input-port) 4096) (iter))) + (list current-port-eof-handler return))))) + (write-string "EOF\n"))) + (list current-output-port (current-error-port))) + (abort)) + + (define (read-rest) + (let/cc return + (define (done . _) (return '())) + (let ([first-form (call-with-parameters read + (list current-read-eof-handler done))]) + (if (and (pair? first-form) + (eq? (first first-form) 'load)) + (cons (read-module-from-path (second first-form)) (read-rest)) + (cons first-form (read-rest)))))) + + (cons 'begin + (call-with-parameters read-rest + (list current-read-syntax-error-handler syntax-error-handler)))) + +(define (read-module-from-path path) + (let ([oldcwd (posix-getcwd)] + [port (open-posix-input-port path)]) + (posix-chdir (dirname path)) + (call-with-parameters + (lambda () + (let ([mod (read-module (basename path))]) + (posix-chdir oldcwd) + mod)) + (list current-input-port port)))) + +(define *extra-variables* (make-hash-table)) + +(define (add-extra-variable symbol) + (let ([box (make-box undefined)]) + (hash-table-insert *extra-variables* symbol box) + box)) + +(define (extra-variable-accessors symbol) + (let ([box (hash-table-lookup *extra-variables* symbol + (lambda () (add-extra-variable symbol)))]) + (values (lambda () (unbox box)) + (lambda (val) (set-box! box val))))) + +(define (do-compile form) + (call-with-parameters + (lambda () (compile form *top-level-bindings* *top-level-syntax-transformers*)) + (list current-unbound-variable-handler extra-variable-accessors))) + +(register-symbols (map car *top-level-bindings*)) + +(register-symbols '(quote begin if set! lambda let letrec + let-syntax let-for-syntax letrec-for-syntax + define define-values define-syntax + define-for-syntax define-values-for-syntax + and or cond else nested backquote unquote + unquote-splicing load absolute relative from-end + input output binary buffered posix)) + +(call-with-abort-handler + (lambda () + (let* ([module-form (if (pair? *argv*) + (read-module-from-path (car *argv*)) + (read-module))] + [module-fn (do-compile module-form)]) + (let iter ([vals (values->list (module-fn))]) + (when (pair? vals) + (display (first vals)) + (write-char #\Newline) + (iter (rest vals)))))) + (lambda (abort-values-fn) + (write-string "Fatal error\b" (current-error-port)) + (values))) + +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/hash-table.rls b/src/hash-table.rls deleted file mode 100644 index f126c4d..0000000 --- a/src/hash-table.rls +++ /dev/null @@ -1,121 +0,0 @@ -;; Requires: make-structure equal? - -(define s:hash-table-node (make-structure '() 5)) -(define (make-hash-table-node hash key val [left #f] [right #f]) - (let ([node (make-struct s:hash-table-node)]) - (struct-set! node 0 hash) - (struct-set! node 1 key) - (struct-set! node 2 val) - (struct-set! node 3 left) - (struct-set! node 4 right) - node)) - -(define (hash-table-node-hash node) (struct-ref node 0)) -(define (hash-table-node-key node) (struct-ref node 1)) -(define (hash-table-node-value node) (struct-ref node 2)) -(define (hash-table-node-left-child node) (struct-ref node 3)) -(define (hash-table-node-right-child node) (struct-ref node 4)) - -(define (hash-table-node-hash-set! node v) (struct-set! node 0 v)) -(define (hash-table-node-key-set! node v) (struct-set! node 1 v)) -(define (hash-table-node-value-set! node v) (struct-set! node 2 v)) -(define (hash-table-node-left-child-set! node v) (struct-set! node 3 v)) -(define (hash-table-node-right-child-set! node v) (struct-set! node 4 v)) - -(define s:hash-table (make-structure '() 3)) -(define (make-hash-table [hash-fn (lambda (x) (hash-value x))] - [eq-fn (lambda (x y) (equal? x y))]) - (let ([ht (make-struct s:hash-table)]) - (struct-set! ht 0 hash-fn) - (struct-set! ht 1 eq-fn) - (struct-set! ht 2 #f) - ht)) - -(define (hash-table-hash-function ht) (struct-ref ht 0)) -(define (hash-table-eq-function ht) (struct-ref ht 1)) -(define (hash-table-root-node ht) (struct-ref ht 2)) - -(define (hash-table-hash-function-set! ht v) (struct-set! ht 0 v)) -(define (hash-table-eq-function-set! ht v) (struct-set! ht 1 v)) -(define (hash-table-root-node-set! ht v) (struct-set! ht 2 v)) - -(define (hash-table-lookup ht key [not-found (lambda () #f)]) - (let ([hash ((hash-table-hash-function ht) key)] - [eq-fn (hash-table-eq-function ht)]) - (let search ([node (hash-table-root-node ht)]) - (if node - (let ([node-hash (hash-table-node-hash node)]) - (cond - [(and (fix= hash node-hash) - (eq-fn (hash-table-node-key node) key)) - (hash-table-node-value node)] - [(fix<= hash node-hash) - (search (hash-table-node-left-child node))] - [else - (search (hash-table-node-right-child node))])) - (not-found))))) - -; TODO: Implement balancing -(define (hash-table-insert ht key val [collision (lambda (oldv) val)]) - (let ([hash ((hash-table-hash-function ht) key)] - [eq-fn (hash-table-eq-function ht)]) - (if (not (hash-table-root-node ht)) - (hash-table-root-node-set! ht - (make-hash-table-node hash key val)) - (let search ([node (hash-table-root-node ht)]) - (let ([node-hash (hash-table-node-hash node)]) - (cond - [(and (fix= hash node-hash) - (eq-fn (hash-table-node-key node) key)) - (hash-table-node-value-set! node - (collision (hash-table-node-value node)))] - [(fix<= hash node-hash) - (let ([child (hash-table-node-left-child node)]) - (if child - (search child) - (hash-table-node-left-child-set! node - (make-hash-table-node hash key val))))] - [else - (let ([child (hash-table-node-right-child node)]) - (if child - (search child) - (hash-table-node-right-child-set! node - (make-hash-table-node hash key val))))])))))) - -(define (hash-table-remove ht key [not-found (lambda () #f)]) - (let ([hash ((hash-table-hash-function ht) key)] - [eq-fn (hash-table-eq-function ht)]) - (let search ([node (hash-table-root-node ht)] - [replace-node! (lambda (n) (hash-table-root-node-set! ht n))]) - (if node - (let ([node-hash (hash-table-node-hash node)]) - (cond - [(and (fix= hash node-hash) - (eq-fn (hash-table-node-key node) key)) - (let ([oldval (hash-table-node-value node)] - [left (hash-table-node-left-child node)] - [right (hash-table-node-right-child node)]) - (cond - [(not left) (replace-node! right)] - [(not right) (replace-node! left)] - [else - (let find-leftmost ([parent node] [lnode right]) - (let ([lc (hash-table-node-left-child lnode)]) - (if lc - (find-leftmost lnode lc) - (let ([rc (hash-table-node-right-child lnode)]) - (hash-table-node-left-child-set! parent rc) - (hash-table-node-left-child-set! lnode left) - (unless (eq? lnode right) - (hash-table-node-right-child-set! lnode right)) - (replace-node! lnode)))))]) - oldval)] - [(fix<= hash node-hash) - (search (hash-table-node-left-child node) - (lambda (n) (hash-table-node-left-child-set! node n)))] - [else - (search (hash-table-node-right-child node) - (lambda (n) (hash-table-node-right-child-set! node n)))])) - (not-found))))) - -; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/abort.rls b/src/lib/abort.rls new file mode 100644 index 0000000..32bcd7e --- /dev/null +++ b/src/lib/abort.rls @@ -0,0 +1,17 @@ +(define (default-abort-handler fn) + (fatal-error-if #t (cons "abort" (values->list (fn))))) +(define current-abort-handler (make-parameter default-abort-handler)) + +(define (abort . rst) + ((current-abort-handler) (lambda () (apply values rst)))) + +(define (call-with-abort-handler fn [handler #f]) + ((let/cc abort-handler + (lambda () + (call-with-parameters fn + (list current-abort-handler + (if handler + (lambda (fn) (abort-handler (lambda () (handler fn)))) + abort-handler))))))) + +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/display.rls b/src/lib/display.rls new file mode 100644 index 0000000..dd6e250 --- /dev/null +++ b/src/lib/display.rls @@ -0,0 +1,51 @@ +(define (display-byte-string form [port (current-output-port)]) + (define (number->hexadecimal digit) (byte-string-ref "0123456789abcdef" digit)) + (write-char #\" port) + (let iter ([i 0]) + (when (fix< i (byte-string-size form)) + (let ([ch (byte-string-ref form i)]) + (if (or (and (fix>= ch 32) (fix<= ch 33)) + (and (fix>= ch 35) (fix<= ch 91)) + (and (fix>= ch 93) (fix<= ch 126))) + (write-char ch port) + (begin + (write-string "\\x" port) + (write-char (number->hexadecimal (fix/ ch 16)) port) + (write-char (number->hexadecimal (fix% ch 16)) port)))) + (iter (fix+ i 1)))) + (write-char #\" port) + (values)) + +(define (display form [port (current-output-port)]) + (define (finish-list lst) + (cond + [(pair? lst) + (write-char #\Space port) + (display (first lst) port) + (finish-list (rest lst))] + [(null? lst) + (write-char #\) port)] + [else + (write-string " . " port) + (display lst port) + (write-char #\) port)])) + (cond + [(pair? form) + (write-char #\( port) + (display (first form) port) + (finish-list (rest form))] + [(byte-string? form) (display-byte-string form port)] + [(symbol? form) (write-string (symbol->string form) port)] + [(keyword? form) (write-string "#:" port) + (write-string (keyword->string form) port)] + [(fixnum? form) (write-string (number->string form) port)] + [(eq? form #f) (write-string "#f" port)] + [(eq? form #t) (write-string "#t" port)] + [(eq? form undefined) (write-string "#" port)] + [(procedure? form) (write-string "#" port)] + [(struct? form) (write-string "#" port)] + [(vector? form) (write-string "#" port)] + [else (write-string "#" port)]) + (values)) + +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/errors.rls b/src/lib/errors.rls new file mode 100644 index 0000000..dc6c85a --- /dev/null +++ b/src/lib/errors.rls @@ -0,0 +1,12 @@ +(define (default-argument-error-handler name val) (abort)) +(define current-argument-error-handler (make-parameter default-argument-error-handler)) + +(define (default-type-error-handler type val) (abort)) +(define current-type-error-handler (make-parameter default-type-error-handler)) + +(define (type-check type val) + (if (kind-of? val type) + val + ((current-type-error-handler) type val))) + +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/hash-table.rls b/src/lib/hash-table.rls new file mode 100644 index 0000000..5d21ae8 --- /dev/null +++ b/src/lib/hash-table.rls @@ -0,0 +1,99 @@ +;; Requires: make-structure equal? + +(define (caar x) (car (car x))) +(define (cdar x) (cdr (car x))) + +(define @minimum-buckets@ 17) + +(define s:hash-table (make-structure '() 4)) +(define (make-hash-table [hash-fn (lambda (x) (hash-value x))] + [eq-fn (lambda (x y) (equal? x y))]) + (let ([ht (make-struct s:hash-table)]) + (struct-set! ht 0 hash-fn) + (struct-set! ht 1 eq-fn) + (struct-set! ht 2 0) + (struct-set! ht 3 (make-vector @minimum-buckets@ '())) + ht)) + +(define (hash-table? x) (kind-of? x s:hash-table)) + +(define (hash-table-hash-function ht) (struct-ref ht 0)) +(define (hash-table-eq-function ht) (struct-ref ht 1)) +(define (hash-table-entries ht) (struct-ref ht 2)) +(define (hash-table-buckets ht) (struct-ref ht 3)) + +(define (set-hash-table-entries! ht v) (struct-set! ht 2 v)) +(define (set-hash-table-buckets! ht v) (struct-set! ht 3 v)) + +(define (hash-table-key->index ht key) + (let* ([hash ((hash-table-hash-function ht) key)] + [limit (vector-size (hash-table-buckets ht))] + [mod (fix% hash limit)]) + (if (fix< mod 0) + (fix+ mod limit) + mod))) + +(define (hash-table-key->bucket ht key) + (let ([buckets (hash-table-buckets ht)] + [index (hash-table-key->index ht key)]) + (vector-ref buckets index))) + +(define (hash-table-lookup ht key [not-found (lambda () #f)]) + (let ([eq-fn (hash-table-eq-function ht)]) + (let search ([bucket (hash-table-key->bucket ht key)]) + (cond + [(eq? bucket '()) (not-found)] + [(eq-fn (caar bucket) key) (cdar bucket)] + [else (search (cdr bucket))])))) + +;; TODO: Halve buckets if entries/buckets < 3/4 and buckets >= 2*min_buckets +;; Double buckets if entries/buckets >= 2 +(define (rehash-if-needed ht)) + +(define (hash-table-insert ht key val [collision (lambda (oldv) val)]) + (let* ([eq-fn (hash-table-eq-function ht)] + [index (hash-table-key->index ht key)] + [buckets (hash-table-buckets ht)]) + (define (insert-new-entry) + (vector-set! buckets index + (cons (cons key val) + (vector-ref buckets index))) + (set-hash-table-entries! ht (fix+ 1 (hash-table-entries ht))) + (rehash-if-needed ht)) + (if (eq? (vector-ref buckets index) '()) + (insert-new-entry) + (let search ([bucket (vector-ref buckets index)]) + (cond + [(eq-fn (caar bucket) key) + (set-cdr! (car bucket) (collision (cdar bucket)))] + [(eq? (cdr bucket) '()) (insert-new-entry)] + [else (search (cdr bucket))])))) + (values)) + +(define (hash-table-remove ht key [not-found (lambda () #f)]) + (let* ([eq-fn (hash-table-eq-function ht)] + [index (hash-table-key->index ht key)] + [buckets (hash-table-buckets ht)] + [first-bucket (vector-ref buckets index)]) + (define (removed-entry) + (set-hash-table-entries! ht (fix- (hash-table-entries ht) 1)) + (rehash-if-needed ht)) + (cond + [(eq? first-bucket '()) (not-found)] + [(eq-fn (caar first-bucket) key) + (vector-set! buckets index (cdr first-bucket)) + (removed-entry) + (cdar first-bucket)] + [(eq? (cdr first-bucket) '()) (not-found)] + [else + (let search ([bucket first-bucket] + [next-bucket (cdr first-bucket)]) + (cond + [(eq-fn (caar next-bucket) key) + (set-cdr! bucket (cdr next-bucket)) + (removed-entry) + (cdar next-bucket)] + [(eq? (cdr next-bucket) '()) (not-found)] + [else (search next-bucket (cdr next-bucket))]))]))) + +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/hash-tree.rls b/src/lib/hash-tree.rls new file mode 100644 index 0000000..a7329d4 --- /dev/null +++ b/src/lib/hash-tree.rls @@ -0,0 +1,121 @@ +;; Requires: make-structure equal? + +(define s:hash-tree-node (make-structure '() 5)) +(define (make-hash-tree-node hash key val [left #f] [right #f]) + (let ([node (make-struct s:hash-tree-node)]) + (struct-set! node 0 hash) + (struct-set! node 1 key) + (struct-set! node 2 val) + (struct-set! node 3 left) + (struct-set! node 4 right) + node)) + +(define (hash-tree-node-hash node) (struct-ref node 0)) +(define (hash-tree-node-key node) (struct-ref node 1)) +(define (hash-tree-node-value node) (struct-ref node 2)) +(define (hash-tree-node-left-child node) (struct-ref node 3)) +(define (hash-tree-node-right-child node) (struct-ref node 4)) + +(define (hash-tree-node-hash-set! node v) (struct-set! node 0 v)) +(define (hash-tree-node-key-set! node v) (struct-set! node 1 v)) +(define (hash-tree-node-value-set! node v) (struct-set! node 2 v)) +(define (hash-tree-node-left-child-set! node v) (struct-set! node 3 v)) +(define (hash-tree-node-right-child-set! node v) (struct-set! node 4 v)) + +(define s:hash-tree (make-structure '() 3)) +(define (make-hash-tree [hash-fn (lambda (x) (hash-value x))] + [eq-fn (lambda (x y) (equal? x y))]) + (let ([ht (make-struct s:hash-tree)]) + (struct-set! ht 0 hash-fn) + (struct-set! ht 1 eq-fn) + (struct-set! ht 2 #f) + ht)) + +(define (hash-tree-hash-function ht) (struct-ref ht 0)) +(define (hash-tree-eq-function ht) (struct-ref ht 1)) +(define (hash-tree-root-node ht) (struct-ref ht 2)) + +(define (hash-tree-hash-function-set! ht v) (struct-set! ht 0 v)) +(define (hash-tree-eq-function-set! ht v) (struct-set! ht 1 v)) +(define (hash-tree-root-node-set! ht v) (struct-set! ht 2 v)) + +(define (hash-tree-lookup ht key [not-found (lambda () #f)]) + (let ([hash ((hash-tree-hash-function ht) key)] + [eq-fn (hash-tree-eq-function ht)]) + (let search ([node (hash-tree-root-node ht)]) + (if node + (let ([node-hash (hash-tree-node-hash node)]) + (cond + [(and (fix= hash node-hash) + (eq-fn (hash-tree-node-key node) key)) + (hash-tree-node-value node)] + [(fix<= hash node-hash) + (search (hash-tree-node-left-child node))] + [else + (search (hash-tree-node-right-child node))])) + (not-found))))) + +; TODO: Implement balancing +(define (hash-tree-insert ht key val [collision (lambda (oldv) val)]) + (let ([hash ((hash-tree-hash-function ht) key)] + [eq-fn (hash-tree-eq-function ht)]) + (if (not (hash-tree-root-node ht)) + (hash-tree-root-node-set! ht + (make-hash-tree-node hash key val)) + (let search ([node (hash-tree-root-node ht)]) + (let ([node-hash (hash-tree-node-hash node)]) + (cond + [(and (fix= hash node-hash) + (eq-fn (hash-tree-node-key node) key)) + (hash-tree-node-value-set! node + (collision (hash-tree-node-value node)))] + [(fix<= hash node-hash) + (let ([child (hash-tree-node-left-child node)]) + (if child + (search child) + (hash-tree-node-left-child-set! node + (make-hash-tree-node hash key val))))] + [else + (let ([child (hash-tree-node-right-child node)]) + (if child + (search child) + (hash-tree-node-right-child-set! node + (make-hash-tree-node hash key val))))])))))) + +(define (hash-tree-remove ht key [not-found (lambda () #f)]) + (let ([hash ((hash-tree-hash-function ht) key)] + [eq-fn (hash-tree-eq-function ht)]) + (let search ([node (hash-tree-root-node ht)] + [replace-node! (lambda (n) (hash-tree-root-node-set! ht n))]) + (if node + (let ([node-hash (hash-tree-node-hash node)]) + (cond + [(and (fix= hash node-hash) + (eq-fn (hash-tree-node-key node) key)) + (let ([oldval (hash-tree-node-value node)] + [left (hash-tree-node-left-child node)] + [right (hash-tree-node-right-child node)]) + (cond + [(not left) (replace-node! right)] + [(not right) (replace-node! left)] + [else + (let find-leftmost ([parent node] [lnode right]) + (let ([lc (hash-tree-node-left-child lnode)]) + (if lc + (find-leftmost lnode lc) + (let ([rc (hash-tree-node-right-child lnode)]) + (hash-tree-node-left-child-set! parent rc) + (hash-tree-node-left-child-set! lnode left) + (unless (eq? lnode right) + (hash-tree-node-right-child-set! lnode right)) + (replace-node! lnode)))))]) + oldval)] + [(fix<= hash node-hash) + (search (hash-tree-node-left-child node) + (lambda (n) (hash-tree-node-left-child-set! node n)))] + [else + (search (hash-tree-node-right-child node) + (lambda (n) (hash-tree-node-right-child-set! node n)))])) + (not-found))))) + +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/keywords.rls b/src/lib/keywords.rls new file mode 100644 index 0000000..afe0ab2 --- /dev/null +++ b/src/lib/keywords.rls @@ -0,0 +1,27 @@ +(define s:keyword (make-structure '() 1)) +(define *keywords* (make-hash-table)) + +(define (make-keyword name) + (let ([sym (make-struct s:keyword)]) + (struct-set! sym 0 (freeze! (copy-byte-string name))) + (freeze! sym))) + +(define (keyword? x) + (and (struct? x) (eq? (struct-type x) s:keyword))) + +(define (keyword->string sym) + (struct-ref sym 0)) + +(define (string->keyword name) + (or (hash-table-lookup *keywords* name) + (let ([sym (make-keyword name)]) + (hash-table-insert *keywords* name sym) + sym))) + +(define (register-keywords syms) + (when (pair? syms) + (let ([sym (car syms)]) + (hash-table-insert *keywords* (keyword->string sym) sym)) + (register-keywords (cdr syms)))) + +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/parameters.rls b/src/lib/parameters.rls new file mode 100644 index 0000000..16a16b6 --- /dev/null +++ b/src/lib/parameters.rls @@ -0,0 +1,90 @@ +(define s:dynamic-environment (make-structure '() 1)) + +(define top-level-dynamic-environment + (let ([new-env (make-struct s:dynamic-environment)]) + (struct-set! new-env 0 #f) + new-env)) + +(define (current-dynamic-environment) + (or (current-context) + top-level-dynamic-environment)) + +(define (copy-dynamic-environment [env (current-dynamic-environment)]) + (let ([new-env (make-struct s:dynamic-environment)]) + (struct-set! new-env 0 (struct-ref env 0)) + new-env)) + +(define (dynamic-environment-parameters env) (struct-ref env 0)) +(define (set-dynamic-environment-parameters! env lst) (struct-set! env 0 lst)) + +(define (parameter-callable param . rst) + (define param-hash (hash-value param)) + (let repeat-with ([bind (dynamic-environment-parameters (current-dynamic-environment))]) + (if bind + (let ([bind-param (parameter-binding-parameter bind)]) + (if (eq? bind-param param) + (if (pair? rst) + (set-parameter-binding-value! bind + (apply (parameter-guard-function param) rst)) + (parameter-binding-value bind)) + (if (fix<= param-hash (hash-value bind-param)) + (repeat-with (parameter-binding-left bind)) + (repeat-with (parameter-binding-right bind))))) + (if (pair? rst) + (set-parameter-value! param (apply (parameter-guard-function param) rst)) + (parameter-value param))))) + +(define s:parameter (make-structure '() 2 parameter-callable)) + +(define (make-parameter init [guard-fn values]) + (let ([param (make-struct s:parameter)]) + (struct-set! param 0 init) + (struct-set! param 1 guard-fn) + param)) + +(define (parameter? x) (kind-of? x s:parameter)) + +(define (parameter-value param) (struct-ref param 0)) +(define (set-parameter-value! param val) (struct-set! param 0 val)) +(define (parameter-guard-function param) (struct-ref param 1)) + +(define s:parameter-binding (make-structure '() 4)) + +(define (make-parameter-binding param val left right) + (let ([binding (make-struct s:parameter-binding)]) + (struct-set! binding 0 param) + (struct-set! binding 1 val) + (struct-set! binding 2 left) + (struct-set! binding 3 right) + binding)) + +(define (parameter-binding-parameter bind) (struct-ref bind 0)) +(define (parameter-binding-value bind) (struct-ref bind 1)) +(define (parameter-binding-left bind) (struct-ref bind 2)) +(define (parameter-binding-right bind) (struct-ref bind 3)) + +(define (set-parameter-binding-value! bind val) (struct-set! bind 1 val)) + +(define (call-with-parameters fn . param-forms) + (define (add-binding param+values to-bind) + (define param (if (pair? param+values) (first param+values) param+values)) + (define param-hash (hash-value param)) + (define (lookup-bind bind match-fn branch-fn) + (and bind (let ([bind-param (parameter-binding-parameter bind)]) + (cond + [(eq? bind-param param) (branch-fn bind)] + [(match-fn (hash-value bind-param) param-hash) bind] + [else (lookup-bind (branch-fn bind) match-fn branch-fn)])))) + (let ([left-bind (lookup-bind to-bind fix<= parameter-binding-left)] + [right-bind (lookup-bind to-bind fix> parameter-binding-right)] + [new-val (if (and (pair? param+values) (pair? (rest param+values))) + (apply (parameter-guard-function param) (rest param+values)) + (param))]) + (make-parameter-binding param new-val left-bind right-bind))) + + (let ([new-env (copy-dynamic-environment)]) + (set-dynamic-environment-parameters! new-env + (foldl add-binding (dynamic-environment-parameters new-env) param-forms)) + (call-with-context new-env fn))) + +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/port.rls b/src/lib/port.rls new file mode 100644 index 0000000..e7a996a --- /dev/null +++ b/src/lib/port.rls @@ -0,0 +1,281 @@ +;(load "lib/primitives.rls") +;(load "lib/util.rls") +;(load "lib/parameters.rls") +;(load "lib/abort.rls") + +(define EOF (make-marker "EOF")) +(define (eof? x) (eq? x EOF)) + +(define (default-port-error-handler p) (abort)) +(define (default-port-eof-handler p) EOF) + +(define current-port-error-handler (make-parameter default-port-error-handler)) +(define current-port-eof-handler (make-parameter default-port-eof-handler)) + +(define s:port (make-structure '() 11)) +(define (port? x) (kind-of? x s:port)) + +(define (make-port flags read unread write seek tell flush + close closed? position [auto-close close] [data undefined]) + (let ([p (make-struct s:port)]) + (struct-set! p 0 flags) + (struct-set! p 1 read) + (struct-set! p 2 unread) + (struct-set! p 3 write) + (struct-set! p 4 seek) + (struct-set! p 5 tell) + (struct-set! p 6 flush) + (struct-set! p 7 close) + (struct-set! p 8 closed?) + (struct-set! p 9 position) + (struct-set! p 10 data) + (when auto-close + (register-finalizer p + (lambda (p) (auto-close)))) + (freeze! p))) + +(define (port-flags p) (struct-ref (type-check s:port p) 0)) +(define (port-read-procedure p) (struct-ref (type-check s:port p) 1)) +(define (port-unread-procedure p) (struct-ref (type-check s:port p) 2)) +(define (port-write-procedure p) (struct-ref (type-check s:port p) 3)) +(define (port-seek-procedure p) (struct-ref (type-check s:port p) 4)) +(define (port-tell-procedure p) (struct-ref (type-check s:port p) 5)) +(define (port-flush-procedure p) (struct-ref (type-check s:port p) 6)) +(define (port-close-procedure p) (struct-ref (type-check s:port p) 7)) +(define (port-closed?-procedure p) (struct-ref (type-check s:port p) 8)) +(define (port-position-procedure p) (struct-ref (type-check s:port p) 9)) +(define (port-data p) (struct-ref (type-check s:port p) 10)) + +(define (port-read p [limit 1]) + (let ([fn (port-read-procedure p)]) + (if fn (fn limit) ((current-port-error-handler))))) + +(define (port-unread p data) + (let ([fn (port-unread-procedure p)]) + (if fn (fn data) ((current-port-error-handler))))) + +(define (port-write p data) + (let ([fn (port-write-procedure p)]) + (if fn (fn data) ((current-port-error-handler))))) + +(define (port-seek p offset [whence 'absolute]) + (let ([fn (port-seek-procedure p)]) + (if fn (fn offset whence) ((current-port-error-handler))))) + +(define (port-tell p) + (let ([fn (port-tell-procedure p)]) + (if fn (fn) ((current-port-error-handler))))) + +(define (port-flush p) + (let ([fn (port-flush-procedure p)]) + (if fn (fn) (values)))) + +(define (port-close p) + (let ([fn (port-close-procedure p)]) + (if fn (fn) (values)))) + +(define (port-closed? p) + (let ([fn (port-closed?-procedure p)]) + (if fn (fn) #f))) + +(define (port-position p) + (let ([fn (port-position-procedure p)]) + (if fn (fn) ((current-port-error-handler))))) + +(define (input-port? x) (and (port? x) (memq? 'input (port-flags x)))) +(define (output-port? x) (and (port? x) (memq? 'output (port-flags x)))) +(define (binary-port? x) (and (port? x) (memq? 'binary (port-flags x)))) +(define (buffered-port? x) (and (port? x) (memq? 'buffered (port-flags x)))) +(define (posix-port? x) (and (port? x) (memq? 'posix (port-flags x)))) + +(define (posix-port-file-descriptor p) + (and (posix-port? p) (port-data p))) + +; open() flags +(define O_RDONLY 00000000) +(define O_WRONLY 00000001) +(define O_RDWR 00000002) +(define O_CREAT 00000100) +(define O_EXCL 00000200) +(define O_NOCTTY 00000400) +(define O_TRUNC 00001000) +(define O_APPEND 00002000) +(define O_NONBLOCK 00004000) +(define O_DSYNC 00010000) +(define FASYNC 00020000) +(define O_DIRECT 00040000) +(define O_LARGEFILE 00100000) +(define O_DIRECTORY 00200000) +(define O_NOFOLLOW 00400000) +(define O_NOATIME 01000000) +(define O_CLOEXEC 02000000) + +; whence enumeration for lseek() +(define SEEK_SET 0) +(define SEEK_CUR 1) +(define SEEK_END 2) + +(define (make-posix-port fd [auto-close? #f] [input? #t] [output? #t]) + (let ([closed? #f] + [unread-list '()] + [line 1] + [column 0]) + (define (update-position str) + (let ([size (byte-string-size str)]) + (let iter ([i 0]) + (when (fix< i size) + (if (eq? (byte-string-ref str i) #\Newline) + (begin + (when line (set! line (fix+ line 1))) + (set! column 0)) + (when column (set! column (fix+ column 1)))) + (iter (fix+ i 1)))))) + + (define (posix-port-read limit) + (cond + [closed? + ((current-port-error-handler))] + [(pair? unread-list) + (let ([str (list->string (take limit unread-list))]) + (set! unread-list (drop limit unread-list)) + str)] + [else + (let* ([buffer (make-byte-string limit 0)] + [result (posix-read fd buffer limit)] + [str (cond [(fix= result limit) buffer] + [(fix> result 0) (byte-substring buffer 0 result)] + [(fix= result 0) ((current-port-eof-handler))] + [else ((current-port-error-handler))])]) + (update-position str) + str)])) + + (define (posix-port-unread str) + (let ([size (byte-string-size str)]) + (set! unread-list + (let iter ([i 0]) + (if (fix< i size) + (let ([ch (byte-string-ref str i)] + [rst (iter (fix+ i 1))]) + (if (eq? ch #\Newline) + (begin + (when line (set! line (fix- line 1))) + (set! column #f)) + (when column (set! column (fix- column 1)))) + (cons ch rst)) + unread-list))))) + + (define (posix-port-write str) + (if closed? + ((current-port-error-handler)) + (let ([result (posix-write fd str)] + [len (byte-string-size str)]) + (cond + [(fix= result len) (update-position str)] + [(fix> result 0) (update-position (byte-substring str 0 result)) + (posix-port-write (byte-substring str result))] + [else ((current-port-error-handler))])))) + + (define (posix-port-seek offset whence) + (if closed? + ((current-port-error-handler)) + (let* ([whence-idx (cond [(eq? whence 'absolute) SEEK_SET] + [(eq? whence 'relative) SEEK_CUR] + [(eq? whence 'from-end) SEEK_END] + [else ((current-argument-error-handler))])]) + (if (and (eq? whence 'absolute) (eq? offset 0)) + (set! line 1 column 0) + (set! line #f column #f)) + (or (posix-lseek fd offset whence-idx) + ((current-port-error-handler)))))) + + (define (posix-port-tell) + (if closed? + ((current-port-error-handler)) + (or (posix-lseek fd 0 SEEK_CUR) + ((current-port-error-handler))))) + + (define (posix-port-close) + (unless closed? + (let ([result (posix-close fd)]) + (if (fix= result 0) + (set! closed? #t) + ((current-port-error-handler)))))) + + (define (posix-port-closed?) + closed?) + + (define (posix-port-position) + (values (posix-port-tell) line column)) + + (make-port (cond [(and input? output?) '(input output binary posix)] + [input? '(input binary posix)] + [output? '(output binary posix)] + [else ((current-argument-error-handler))]) + (and input? posix-port-read) + (and input? posix-port-unread) + (and output? posix-port-write) + posix-port-seek + posix-port-tell + void ; flush + posix-port-close + posix-port-closed? + (and auto-close? posix-port-close) + posix-port-position + fd))) + +(define (open-posix-input-port path) + (let ([fd (posix-open path O_RDONLY)]) + (if (fix< fd 0) + ((current-port-error-handler)) + (make-posix-port fd #t #t #f)))) + +(define open-posix-output-port + (let ([default-output-bits (foldl bit-or 0 (list O_WRONLY O_CREAT O_TRUNC))]) + (lambda (path) + (let ([fd (posix-open path default-output-bits)]) + (if (fix< fd 0) + ((current-port-error-handler)) + (make-posix-port fd #t #f #t)))))) + +(define posix-standard-input-port (make-posix-port 0 #f #t #f)) +(define posix-standard-output-port (make-posix-port 1 #f #f #t)) +(define posix-standard-error-port (make-posix-port 2 #f #f #t)) + +(define current-input-port (make-parameter posix-standard-input-port)) +(define current-output-port (make-parameter posix-standard-output-port)) +(define current-error-port (make-parameter posix-standard-error-port)) + +(define (write-char ch [port (current-output-port)]) + (port-write port (make-byte-string 1 ch))) + +(define (write-string str [port (current-output-port)]) + (port-write port str)) + +(define (read-char [port (current-input-port)]) + (byte-string-ref (port-read port 1) 0)) + +(define (peek-char [port (current-input-port)]) + (let ([str (port-read port 1)]) + (port-unread port str) + (byte-string-ref str 0))) + +(define (read-line [port (current-input-port)]) + (list->string (let iter () + (let ([ch (read-char port)]) + (if (eq? ch #\Newline) + '() + (cons ch (iter))))))) + +(define (trace tag [val-fn #f] . rst) + (let ([error-port (current-error-port)]) + (write-string "before " error-port) + (write-string tag error-port) + (write-char #\Newline error-port) + (when val-fn + (let ([vals (values->list (apply val-fn rst))]) + (write-string "after " error-port) + (write-string tag error-port) + (write-char #\Newline error-port) + (apply values vals))))) + +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/primitive/append.rls b/src/lib/primitive/append.rls index d2b309e..4852443 100644 --- a/src/lib/primitive/append.rls +++ b/src/lib/primitive/append.rls @@ -1,11 +1,9 @@ ;; Concatenates the list argument(s) into a single new list. -(load "foldr.rls") - (define (append . lsts) (foldr (lambda (lst base) (foldr cons base lst)) '() lsts)) -; vim:set syntax= sw=2 expandtab: +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/primitive/foldl.rls b/src/lib/primitive/foldl.rls index d4b95ff..36aad77 100644 --- a/src/lib/primitive/foldl.rls +++ b/src/lib/primitive/foldl.rls @@ -7,4 +7,4 @@ (foldl fn (fn (car lst) init) (cdr lst)) init)) -; vim:set syntax= sw=2 expandtab: +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/primitive/foldr.rls b/src/lib/primitive/foldr.rls index 6cc885c..dd78131 100644 --- a/src/lib/primitive/foldr.rls +++ b/src/lib/primitive/foldr.rls @@ -8,4 +8,4 @@ (foldr fn init (cdr lst))) init)) -; vim:set syntax= sw=2 expandtab: +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/primitive/map.rls b/src/lib/primitive/map.rls index 174ac73..bed7e2d 100644 --- a/src/lib/primitive/map.rls +++ b/src/lib/primitive/map.rls @@ -1,10 +1,7 @@ -(load "reverse.rls") -(load "foldl.rls") - (define (map fn lst) (reverse (foldl (lambda (x lst) (cons (fn x) lst)) '() lst))) -; vim:set syntax= sw=2 expandtab: +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/primitive/reverse.rls b/src/lib/primitive/reverse.rls index da63251..282da49 100644 --- a/src/lib/primitive/reverse.rls +++ b/src/lib/primitive/reverse.rls @@ -1,8 +1,6 @@ ;; Returns a reversed copy of the given list -(load "foldl.rls") +(define (reverse lst [newcdr '()]) + (foldl cons newcdr lst)) -(define (reverse lst) - (foldl cons nil lst)) - -; vim:set syntax= sw=2 expandtab: +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/primitives.rls b/src/lib/primitives.rls index ad9b409..1c9a40c 100644 --- a/src/lib/primitives.rls +++ b/src/lib/primitives.rls @@ -1,145 +1,183 @@ ; Function forms of built-in primitives -(define (unbox x) (unbox x)) -(define (weak-unbox x) (weak-unbox x)) -(define (car x) (car x)) -(define (cdr x) (cdr x)) +(define (unbox x) (#%unbox x)) +(define (weak-unbox x) (#%weak-unbox x)) +(define (car x) (#%car x)) +(define (cdr x) (#%cdr x)) -(define (boolean? x) (boolean? x)) -(define (fixnum? x) (fixnum? x)) -(define (box? x) (box? x)) -(define (pair? x) (pair? x)) -(define (vector? x) (vector? x)) -(define (byte-string? x) (byte-string? x)) -(define (struct? x) (struct? x)) -(define (float? x) (float? x)) -(define (builtin? x) (builtin? x)) -(define (weak-box? x) (weak-box? x)) +(define (null? x) (#%eq? '() x)) +(define (boolean? x) (#%boolean? x)) +(define (fixnum? x) (#%fixnum? x)) +(define (box? x) (#%box? x)) +(define (pair? x) (#%pair? x)) +(define (vector? x) (#%vector? x)) +(define (byte-string? x) (#%byte-string? x)) +(define (struct? x) (#%struct? x)) +(define (float? x) (#%float? x)) +(define (builtin? x) (#%builtin? x)) +(define (weak-box? x) (#%weak-box? x)) -(define (make-box x) (make-box x)) -(define (make-struct x) (make-struct x)) -(define (make-float x) (make-float x)) -(define (make-weak-box x) (make-weak-box x)) +(define (make-box x) (#%make-box x)) +(define (make-struct x) (#%make-struct x)) +(define (make-float x) (#%make-float x)) +(define (make-weak-box x) (#%make-weak-box x)) -(define (not x) (not x)) -(define (bit-not x) (bit-not x)) -(define (fix- x) (fix- x)) -(define (float- x) (float- x)) +(define (not x) (#%not x)) +(define (bit-not x) (#%bit-not x)) +(define (fix-neg x) (#%fix- x)) +(define (float-neg x) (#%float- x)) -(define (vector-size x) (vector-size x)) -(define (byte-string-size x) (byte-string-size x)) -(define (struct-nslots x) (struct-nslots x)) -(define (struct-type x) (struct-type x)) +(define (vector-size x) (#%vector-size x)) +(define (byte-string-size x) (#%byte-string-size x)) +(define (struct-nslots x) (#%struct-nslots x)) +(define (struct-type x) (#%struct-type x)) -(define (hash-value x) (hash-value x)) +(define (hash-value x) (#%hash-value x)) -(define (acos x) (acos x)) -(define (asin x) (asin x)) -(define (atan x) (atan x)) -(define (cos x) (cos x)) -(define (sin x) (sin x)) -(define (tan x) (tan x)) -(define (cosh x) (cosh x)) -(define (sinh x) (sinh x)) -(define (tanh x) (tanh x)) -(define (exp x) (exp x)) -(define (frexp x) (frexp x)) -(define (log x) (log x)) -(define (log10 x) (log10 x)) -(define (modf x) (modf x)) -(define (sqrt x) (sqrt x)) -(define (ceil x) (ceil x)) -(define (fabs x) (fabs x)) -(define (floor x) (floor x)) -(define (erf x) (erf x)) -(define (erfc x) (erfc x)) -(define (j0 x) (j0 x)) -(define (j1 x) (j1 x)) -(define (lgamma x) (lgamma x)) -(define (y0 x) (y0 x)) -(define (y1 x) (y1 x)) -(define (asinh x) (asinh x)) -(define (acosh x) (acosh x)) -(define (atanh x) (atanh x)) -(define (cbrt x) (cbrt x)) -(define (logb x) (logb x)) -(define (expm1 x) (expm1 x)) -(define (ilogb x) (ilogb x)) -(define (log1p x) (log1p x)) +(define (acos x) (#%acos x)) +(define (asin x) (#%asin x)) +(define (atan x) (#%atan x)) +(define (cos x) (#%cos x)) +(define (sin x) (#%sin x)) +(define (tan x) (#%tan x)) +(define (cosh x) (#%cosh x)) +(define (sinh x) (#%sinh x)) +(define (tanh x) (#%tanh x)) +(define (exp x) (#%exp x)) +(define (frexp x) (#%frexp x)) +(define (log x) (#%log x)) +(define (log10 x) (#%log10 x)) +(define (modf x) (#%modf x)) +(define (sqrt x) (#%sqrt x)) +(define (ceil x) (#%ceil x)) +(define (fabs x) (#%fabs x)) +(define (floor x) (#%floor x)) +(define (erf x) (#%erf x)) +(define (erfc x) (#%erfc x)) +(define (j0 x) (#%j0 x)) +(define (j1 x) (#%j1 x)) +(define (lgamma x) (#%lgamma x)) +(define (y0 x) (#%y0 x)) +(define (y1 x) (#%y1 x)) +(define (asinh x) (#%asinh x)) +(define (acosh x) (#%acosh x)) +(define (atanh x) (#%atanh x)) +(define (cbrt x) (#%cbrt x)) +(define (logb x) (#%logb x)) +(define (expm1 x) (#%expm1 x)) +(define (ilogb x) (#%ilogb x)) +(define (log1p x) (#%log1p x)) -(define (normal? x) (normal? x)) -(define (finite? x) (finite? x)) -(define (subnormal? x) (subnormal? x)) -(define (infinite? x) (infinite? x)) -(define (nan? x) (nan? x)) +(define (normal? x) (#%normal? x)) +(define (finite? x) (#%finite? x)) +(define (subnormal? x) (#%subnormal? x)) +(define (infinite? x) (#%infinite? x)) +(define (nan? x) (#%nan? x)) -(define (eq? x y) (eq? x y)) +(define (eq? x y) (#%eq? x y)) -(define (cons x y) (cons x y)) -(define (make-vector x y) (make-vector x y)) -(define (make-byte-string x y) (make-byte-string x y)) +(define (cons x y) (#%cons x y)) +(define (make-vector x y) (#%make-vector x y)) +(define (make-byte-string x y) (#%make-byte-string x y)) -(define (vector-ref x y) (vector-ref x y)) -(define (byte-string-ref x y) (byte-string-ref x y)) -(define (struct-ref x y) (struct-ref x y)) +(define (vector-ref x y) (#%vector-ref x y)) +(define (byte-string-ref x y) (#%byte-string-ref x y)) +(define (struct-ref x y) (#%struct-ref x y)) -(define (fix+ x y) (fix+ x y)) -(define (fix- x y) (fix- x y)) -(define (fix* x y) (fix* x y)) -(define (fix/ x y) (fix/ x y)) -(define (fix% x y) (fix% x y)) -(define (fix= x y) (fix= x y)) -(define (fix< x y) (fix< x y)) -(define (fix> x y) (fix> x y)) -(define (fix>= x y) (fix>= x y)) -(define (fix<= x y) (fix<= x y)) +(define (fix+ x y) (#%fix+ x y)) +(define (fix- x y) (#%fix- x y)) +(define (fix* x y) (#%fix* x y)) +(define (fix/ x y) (#%fix/ x y)) +(define (fix% x y) (#%fix% x y)) +(define (fix= x y) (#%eq? x y)) +(define (fix< x y) (#%fix< x y)) +(define (fix> x y) (#%fix< y x)) +(define (fix>= x y) (#%fix>= x y)) +(define (fix<= x y) (#%fix>= y x)) -(define (bit-and x y) (bit-and x y)) -(define (bit-or x y) (bit-or x y)) -(define (bit-xor x y) (bit-xor x y)) -(define (fix<< x y) (fix<< x y)) -(define (fix>> x y) (fix>> x y)) -(define (fix>>> x y) (fix>>> x y)) +(define (bit-and x y) (#%bit-and x y)) +(define (bit-or x y) (#%bit-or x y)) +(define (bit-xor x y) (#%bit-xor x y)) +(define (fix<< x y) (#%fix<< x y)) +(define (fix>> x y) (#%fix>> x y)) +(define (fix>>> x y) (#%fix>>> x y)) -(define (float+ x y) (float+ x y)) -(define (float- x y) (float- x y)) -(define (float* x y) (float* x y)) -(define (float/ x y) (float/ x y)) -(define (float= x y) (float= x y)) -(define (float< x y) (float< x y)) -(define (float> x y) (float> x y)) -(define (float>= x y) (float>= x y)) -(define (float<= x y) (float<= x y)) +(define (float+ x y) (#%float+ x y)) +(define (float- x y) (#%float- x y)) +(define (float* x y) (#%float* x y)) +(define (float/ x y) (#%float/ x y)) +(define (float= x y) (#%float= x y)) +(define (float< x y) (#%float< x y)) +(define (float> x y) (#%float< y x)) +(define (float>= x y) (#%float>= x y)) +(define (float<= x y) (#%float>= y x)) -(define (atan2 x y) (atan2 x y)) -(define (pow x y) (pow x y)) -(define (ldexp x y) (ldexp x y)) -(define (fmod x y) (fmod x y)) -(define (hypot x y) (hypot x y)) -(define (jn x y) (jn x y)) -(define (yn x y) (yn x y)) -(define (nextafter x y) (nextafter x y)) -(define (remainder x y) (remainder x y)) -(define (scalb x y) (scalb x y)) +(define (atan2 x y) (#%atan2 x y)) +(define (pow x y) (#%pow x y)) +(define (ldexp x y) (#%ldexp x y)) +(define (fmod x y) (#%fmod x y)) +(define (hypot x y) (#%hypot x y)) +(define (jn x y) (#%jn x y)) +(define (yn x y) (#%yn x y)) +(define (nextafter x y) (#%nextafter x y)) +(define (remainder x y) (#%remainder x y)) +(define (scalb x y) (#%scalb x y)) -(define (kind-of? x y) (kind-of? x y)) +(define (kind-of? x y) (#%kind-of? x y)) -(define (byte-string= x y) (byte-string= x y)) -(define (byte-string< x y) (byte-string< x y)) -(define (byte-string> x y) (byte-string> x y)) -(define (byte-string>= x y) (byte-string>= x y)) -(define (byte-string<= x y) (byte-string<= x y)) +(define (byte-string= x y) (#%byte-string= x y)) +(define (byte-string< x y) (#%byte-string< x y)) +(define (byte-string> x y) (#%byte-string< y x)) +(define (byte-string>= x y) (#%byte-string>= x y)) +(define (byte-string<= x y) (#%byte-string>= y x)) -(define (set-box! x y) (set-box! x y)) -(define (set-car! x y) (set-car! x y)) -(define (set-cdr! x y) (set-cdr! x y)) +(define (set-box! x y) (#%set-box! x y)) +(define (set-car! x y) (#%set-car! x y)) +(define (set-cdr! x y) (#%set-cdr! x y)) -(define (if x y z) (if x y z)) +(define (fatal-error-if x y) (#%fatal-error-if x y)) -(define (vector-set! x y z) (vector-set! x y z)) -(define (byte-string-set! x y z) (byte-string-set! x y z)) -(define (struct-set! x y z) (struct-set! x y z)) +(define (if x y z) (#%if x y z)) + +(define (vector-set! x y z) (#%vector-set! x y z)) +(define (byte-string-set! x y z) (#%byte-string-set! x y z)) +(define (struct-set! x y z) (#%struct-set! x y z)) (define (list . lst) lst) +(define (call/cc fn) (call/cc fn)) +(define (call-with-values fn1 fn2) (call-with-values fn1 fn2)) + +(define undefined (#%builtin "undefined")) +(define s:structure (#%builtin "structure")) +(define s:lambda (#%builtin "lambda")) +(define s:template (#%builtin "template")) +(define +NaN (#%builtin "+NaN")) +(define -NaN (#%builtin "-NaN")) +(define +infinity (#%builtin "+infinity")) +(define -infinity (#%builtin "-infinity")) + +(define values (#%builtin "values")) +(define freeze! (#%builtin "freeze!")) +(define immutable? (#%builtin "immutable?")) +(define register-finalizer (#%builtin "register-finalizer")) +(define string->number (#%builtin "string->number")) +(define string->builtin (#%builtin "string->builtin")) +(define builtin->string (#%builtin "builtin->string")) +(define builtin-display (#%builtin "display")) + +(define current-context (#%builtin "current-context")) +(define call-with-context (#%builtin "call-with-context")) + +(define posix-open (#%builtin "posix-open")) +;(define posix-openat (#%builtin "posix-openat")) +(define posix-dup (#%builtin "posix-dup")) +(define posix-dup2 (#%builtin "posix-dup2")) +(define posix-read (#%builtin "posix-read")) +(define posix-write (#%builtin "posix-write")) +(define posix-lseek (#%builtin "posix-lseek")) +(define posix-close (#%builtin "posix-close")) + +(define posix-chdir (#%builtin "posix-chdir")) +(define posix-getcwd (#%builtin "posix-getcwd")) ; vim:set sw=2 expandtab: diff --git a/src/reader.rls b/src/lib/reader.rls similarity index 64% rename from src/reader.rls rename to src/lib/reader.rls index c605879..262c92f 100644 --- a/src/reader.rls +++ b/src/lib/reader.rls @@ -1,95 +1,72 @@ -(load "util.rls") -(load "hash-table.rls") +(define current-read-eof-handler + (make-parameter (lambda () "unexpected-eof"))) -(define s:symbol (struct-type 'a)) -(define *symbols* (make-hash-table)) +(define current-read-syntax-error-handler + (make-parameter (lambda (line col char) (values "syntax-error" line col char)))) -(define (make-symbol name) - (let ([sym (make-struct s:symbol)]) - (struct-set! sym 0 name) - sym)) - -(define (symbol-name sym) - (struct-ref sym 0)) - -(define (findf fn lst) - (if (pair? lst) - (let ([x (car lst)]) - (if (fn x) - x - (findf fn (cdr lst)))) - #f)) - -(define (memq val lst) - (if (pair? lst) - (if (eq? (car lst) val) - lst - (memq val (cdr lst))) - #f)) - -(define (memq? val lst) - (and (memq val lst) #t)) - -(define (intern name) - (or (hash-table-lookup *symbols* name) - (let ([sym (make-symbol name)]) - (hash-table-insert *symbols* name sym) - sym))) - -(define (read-from-fd fd) +(define (read [port (current-input-port)]) (let/cc toplevel-return (let ([weak-list '()] - [line 1] - [column 0] [eof? #f] current-char) (define (read-one-value) - (skip-whitespace) - (cond - [eof? (unexpected-eof)] - [(eq? current-char #\#) - (next-char) - (read-special)] - [(eq? current-char #\() - (next-char) - (read-list)] - [(or (eq? current-char #\-) - (eq? current-char #\+) - (decimal-char? current-char)) - (read-number)] - [(eq? current-char #\") - (read-string)] - [(eq? current-char #\|) - (next-char) - (read-symbol #t)] - [(eq? current-char #\') - (next-char) - (list 'quote (read-one-value))] - [(eq? current-char #\`) - (next-char) - (list 'backquote (read-one-value))] - [(eq? current-char #\,) - (next-char) - (if (eq? current-char #\@) - (begin - (next-char) - (list 'unquote-splicing (read-one-value))) - (list 'unquote (read-one-value)))] - [(symbol-char? current-char) - (read-symbol)] - [else - (unexpected-char)])) + (let ([eof-handler (current-read-eof-handler)]) + (call-with-parameters + (lambda () + (skip-whitespace) + (cond + [eof? (eof-handler)] + [(eq? current-char #\#) + (next-char) + (read-special)] + [(eq? current-char #\() + (next-char) + (read-list #\))] + [(eq? current-char #\[) + (next-char) + (read-list #\])] + [(or (eq? current-char #\-) + (eq? current-char #\+) + (decimal-char? current-char)) + (read-number)] + [(eq? current-char #\") + (read-string)] + [(eq? current-char #\|) + (next-char) + (read-symbol #t)] + [(eq? current-char #\') + (next-char) + (list 'quote (read-one-value))] + [(eq? current-char #\`) + (next-char) + (list 'backquote (read-one-value))] + [(eq? current-char #\,) + (next-char) + (if (eq? current-char #\@) + (begin + (next-char) + (list 'unquote-splicing (read-one-value))) + (list 'unquote (read-one-value)))] + [(symbol-char? current-char) + (read-symbol)] + [else + (syntax-error)])) + (list current-read-eof-handler (lambda () (syntax-error)))))) (define (read-special) (cond - [eof? (unexpected-eof)] + [eof? (syntax-error)] [(eq? current-char #\;) (next-char) (read-one-value) (read-one-value)] [(eq? current-char #\!) - (unless (and (eq? line 1) (eq? column 2)) (unexpected-char)) + (unless (call-with-values + (lambda () (port-position port)) + (lambda (byte line column) + (and (eq? line 1) (eq? column 2)))) + (syntax-error)) (let skip-until-newline () (next-char) (unless (or eof? (eq? current-char #\Newline)) @@ -97,11 +74,11 @@ (read-one-value)] [(memq? current-char '(#\F #\f)) (next-char) - (when (symbol-char? current-char) (unexpected-char)) + (when (symbol-char? current-char) (syntax-error)) #f] [(memq? current-char '(#\T #\t)) (next-char) - (when (symbol-char? current-char) (unexpected-char)) + (when (symbol-char? current-char) (syntax-error)) #t] [(eq? current-char #\&) (next-char) @@ -111,14 +88,20 @@ (read-vector)] [(memq? current-char '(#\S #\s)) (next-char) - (unless (eq? current-char #\() (unexpected-char)) + (unless (eq? current-char #\() (syntax-error)) (next-char) (read-struct)] [(memq? current-char '(#\W #\w)) (next-char) - (unless (eq? current-char #\&) (unexpected-char)) + (unless (eq? current-char #\&) (syntax-error)) (next-char) (read-weak-box)] + [(eq? current-char #\\) + (next-char) + (read-character)] + [(eq? current-char #\:) + (next-char) + (read-keyword)] [(memq? current-char '(#\X #\x)) (next-char) (read-fixnum 16)] @@ -134,21 +117,21 @@ [(eq? current-char #\@) (next-char) (freeze! (read-one-value))] - [else (unexpected-char)])) + [else (syntax-error)])) - (define (read-list) + (define (read-list [end-char #\)]) (define (read-rest) (skip-whitespace) (cond - [eof? (unexpected-eof)] + [eof? (syntax-error)] [(eq? current-char #\.) (next-char) (let ([lstcdr (read-one-value)]) (skip-whitespace) - (unless (eq? current-char #\)) (unexpected-char)) + (unless (eq? current-char end-char) (syntax-error)) (next-char) lstcdr)] - [(eq? current-char #\)) + [(eq? current-char end-char) (next-char) '()] [else @@ -156,8 +139,8 @@ (skip-whitespace) (cond - [eof? (unexpected-eof)] - [(eq? current-char #\)) + [eof? (syntax-error)] + [(eq? current-char end-char) (next-char) '()] [else @@ -165,15 +148,15 @@ (define (read-fixnum [radix #f]) (let/cc return - (when eof? (unexpected-eof)) + (when eof? (syntax-error)) (define neg? (eq? current-char #\-)) (when (or neg? (eq? current-char #\+)) (next-char) - (when eof? (unexpected-eof))) + (when eof? (syntax-error))) (unless radix - (unless (decimal-char? current-char) (unexpected-char)) + (unless (decimal-char? current-char) (syntax-error)) (if (eq? current-char #\0) (begin (next-char) @@ -189,14 +172,14 @@ (next-char) (set! radix 2)] [else - (unexpected-char)])) + (syntax-error)])) (set! radix 10))) ; Need at least one digit within this radix - (when eof? (unexpected-eof)) + (when eof? (syntax-error)) (unless (and (alphanumeric-char? current-char) (fix< (digit->integer current-char) radix)) - (unexpected-char)) + (syntax-error)) (let ([pos-val (let iter ([accum 0]) (if eof? @@ -213,7 +196,7 @@ (let ([negative (cond [(eq? current-char #\-) (next-char) #t] [(eq? current-char #\+) (next-char) #f] [else #f])]) - (unless (decimal-char? current-char) (unexpected-char)) + (unless (decimal-char? current-char) (syntax-error)) (let ([radix (if (eq? current-char #\0) (begin (next-char) @@ -261,60 +244,60 @@ (define (read-chars [accum '()] [len 0]) (define (read-one-char) (define (skip-ws skip-nl?) - (when eof? (unexpected-eof)) + (when eof? (syntax-error)) (when (whitespace? current-char) (let ([ch current-char]) (next-char) (if (eq? ch #\Newline) (when skip-nl? (skip-ws #f)) (skip-ws skip-nl?))))) - (when eof? (unexpected-eof)) + (when eof? (syntax-error)) (cond [(eq? current-char end-quote) (next-char) #f] [(eq? current-char #\\) (next-char) - (when eof? (unexpected-eof)) + (when eof? (syntax-error)) (cond [(or (eq? current-char #\o) (octal-char? current-char)) (when (eq? current-char #\o) (next-char) - (when eof? (unexpected-eof)) - (unless (octal-char? current-char) (unexpected-char))) + (when eof? (syntax-error)) + (unless (octal-char? current-char) (syntax-error))) (let ([total (digit->integer current-char)]) (next-char) - (when eof? (unexpected-eof)) + (when eof? (syntax-error)) (define (add-char) (set! total (fix+ (fix* total 8) (digit->integer current-char))) - (when (fix> total 255) (unexpected-char)) + (when (fix> total 255) (syntax-error)) (next-char) - (when eof? (unexpected-eof)) + (when eof? (syntax-error)) (octal-char? current-char)) (and (octal-char? current-char) (add-char) (add-char)) total)] [(memq? current-char '(#\X #\x)) (next-char) - (when eof? (unexpected-eof)) - (unless (hex-char? current-char) (unexpected-char)) + (when eof? (syntax-error)) + (unless (hex-char? current-char) (syntax-error)) (let ([total (digit->integer current-char)]) (next-char) - (when eof? (unexpected-eof)) + (when eof? (syntax-error)) (when (hex-char? current-char) (set! total (fix+ (fix* total 16) (digit->integer current-char))) - (when (fix> total 255) (unexpected-char)) + (when (fix> total 255) (syntax-error)) (next-char) - (when eof? (unexpected-eof))) + (when eof? (syntax-error))) total)] [(whitespace? current-char) (skip-ws #t) (read-one-char)] [(eq? current-char #\;) (let skip-to-nl+ws () - (when eof? (unexpected-eof)) + (when eof? (syntax-error)) (if (eq? current-char #\Newline) (skip-ws #t) (begin @@ -327,7 +310,7 @@ (#\a . 7) (#\b . 8) (#\t . 9) (#\n . 10) (#\v . 11) (#\f . 12) (#\r . 13)))]) - (unless item (unexpected-char)) + (unless item (syntax-error)) (next-char) (cdr item))])] [else @@ -371,19 +354,53 @@ (iter (fix+ n 1) (cdr rst)))) struct)) - (define (read-symbol [quoted? #f]) + (define (upcase-char ch) + (if (or (fix< ch #\a) (fix> ch #\z)) ch (fix- ch 32))) + + (define (read-character) + (define (read-chars) + (if (symbol-char? current-char) + (let ([ch current-char]) + (next-char) + (cons ch (read-chars))) + '())) + + (when eof? (syntax-error)) + (let ([ch current-char]) + (next-char) + (let* ([chars (cons ch (read-chars))] + [len (list-length chars)]) + (if (eq? len 1) + (car chars) + (let ([name (list->string (map upcase-char chars))]) + (cond + [(byte-string= name "NUL") 0] + [(byte-string= name "NULL") 0] + [(byte-string= name "BACKSPACE") 8] + [(byte-string= name "TAB") 9] + [(byte-string= name "NEWLINE") 10] + [(byte-string= name "LINEFEED") 10] + [(byte-string= name "VTAB") 11] + [(byte-string= name "PAGE") 12] + [(byte-string= name "RETURN") 13] + [(byte-string= name "SPACE") 32] + [(byte-string= name "DELETE") 127] + [(byte-string= name "RUBOUT") 127] + [else (syntax-error)])))))) + + (define (read-symbol [quoted? #f] [convert-fn string->symbol]) (define (read-chars) (cond [eof? (if quoted? - (unexpected-eof) + (syntax-error) '())] [(and quoted? (eq? current-char #\|)) (next-char) '()] [(eq? current-char #\\) (next-char) - (when eof? (unexpected-eof)) + (when eof? (syntax-error)) (let ([ch current-char]) (next-char) (cons ch (read-chars)))] @@ -393,14 +410,15 @@ (cons ch (read-chars)))] [else '()])) - (let* ([chars (read-chars)] - [len (list-length chars)] - [str (make-byte-string len #\Null)]) - (let iter ([n 0] [rst chars]) - (when (fix< n len) - (byte-string-set! str n (car rst)) - (iter (fix+ n 1) (cdr rst)))) - (intern str))) + (let* ([chars (read-chars)]) + (convert-fn (list->string chars)))) + + (define (read-keyword) + (if (eq? current-char #\|) + (begin + (next-char) + (read-symbol #t string->keyword)) + (read-symbol #f string->keyword))) (define (skip-whitespace) (unless eof? @@ -412,38 +430,36 @@ (let skip-until-newline () (let ([ch current-char]) (next-char) - (unless (eq? ch #\Newline) - (skip-until-newline))))]))) + (if (eq? ch #\Newline) + (skip-whitespace) + (skip-until-newline))))]))) (define (next-char) - (if eof? - #f - (let* ([str (make-byte-string 1 0)] - [res (posix-read fd str 1)]) - (if (eq? res 1) - (let ([ch (byte-string-ref str 0)]) - (set! current-char ch) - (if (fix= ch #\Newline) - (begin - (set! line (fix+ line 1)) - (set! column 0)) - (set! column (fix+ column 1))) - ch) - (begin - (set! current-char #f) - (set! eof? #t) - #f))))) + (unless eof? + (let/cc return + (call-with-parameters + (lambda () + (set! current-char (read-char port))) + (list current-port-eof-handler + (lambda () + (set! eof? #t) + (set! current-char #f) + (return))))))) - (define (unexpected-eof) - (toplevel-return "unexpected-eof")) - - (define (unexpected-char) - (toplevel-return "unexpected-char" current-char (list line column))) + (define (syntax-error) + (call-with-values + (lambda () + (call-with-values + (lambda () (port-position port)) + (lambda (byte line column) + ((current-read-syntax-error-handler) line column current-char)))) + toplevel-return)) (next-char) - (values - (read-one-value) - current-char)))) + (let ([val (read-one-value)]) + (unless eof? + (port-unread port (make-byte-string 1 current-char))) + val)))) (define (whitespace? ch) (memq? ch '(#\Space #\Tab #\VTab #\Page #\Newline))) @@ -474,19 +490,8 @@ (define (symbol-char? ch) (or (alphanumeric-char? ch) (memq? ch '(#\! #\$ #\% #\& #\* #\+ - #\- #\/ #\< #\= #\> #\? - #\@ #\^ #\_ #\~)))) - -(define (reverse lst [newcdr '()]) - (if (pair? lst) - (reverse (cdr lst) (cons (car lst) newcdr)) - newcdr)) - -(define (list-length lst) - (let iter ([n 0] [rst lst]) - (if (pair? rst) - (iter (fix+ n 1) (cdr rst)) - n))) + #\- #\/ #\: #\< #\= #\> + #\? #\@ #\^ #\_ #\~)))) (define (digit->integer ch) (cond @@ -495,6 +500,4 @@ [(downcase-char? ch) (fix+ 10 (fix- ch #\a))] [else #f])) -(read-from-fd 0) - ; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/symbols.rls b/src/lib/symbols.rls new file mode 100644 index 0000000..544b4c0 --- /dev/null +++ b/src/lib/symbols.rls @@ -0,0 +1,33 @@ +(define s:symbol (struct-type 'a)) +(define *symbols* (make-hash-table)) ; hash-value eq?)) + +(define (make-symbol name) + (let ([sym (make-struct s:symbol)]) + (struct-set! sym 0 (freeze! (copy-byte-string name))) + (freeze! sym))) + +(define (symbol? x) + (and (struct? x) (eq? (struct-type x) s:symbol))) + +(define (symbol->string sym) + (struct-ref sym 0)) + +(define (string->symbol name) + (or (hash-table-lookup *symbols* name) + (let ([sym (make-symbol name)]) + (hash-table-insert *symbols* name sym) + sym))) + +(define *gensym-counter* 0) + +(define (gensym [prefix "g"]) + (set! *gensym-counter* (fix+ *gensym-counter* 1)) + (make-symbol (byte-string-append prefix (number->string *gensym-counter*)))) + +(define (register-symbols syms) + (when (pair? syms) + (let ([sym (car syms)]) + (hash-table-insert *symbols* (symbol->string sym) sym)) + (register-symbols (cdr syms)))) + +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/syntax.rls b/src/lib/syntax.rls new file mode 100644 index 0000000..87b7aef --- /dev/null +++ b/src/lib/syntax.rls @@ -0,0 +1,72 @@ +(define-syntax (when expr . forms) `(if ,expr (begin ,@forms) (values))) +(define-syntax (unless expr . forms) `(if ,expr (values) (begin ,@forms))) + +(define-syntax (and . terms) + (if (pair? terms) + (if (pair? (rest terms)) + (let ([v1 (gensym)]) + `(let ([,v1 ,(first terms)]) + (if ,v1 (and ,@(rest terms)) ,v1))) + (first terms)) + #t)) + +(define-syntax (or . terms) + (if (pair? terms) + (if (pair? (rest terms)) + (let ([v1 (gensym)]) + `(let ([,v1 ,(first terms)]) + (if ,v1 ,v1 (or ,@(rest terms))))) + (first terms)) + #f)) + +(define-syntax (cond . terms) + (if (pair? terms) + (let ([term (first terms)]) + (if (memq? (first term) '(else #t)) + `(begin ,@(rest term)) + `(if ,(first term) + (begin ,@(rest term)) + (cond ,@(rest terms))))) + `(values))) + +(define-syntax (nested wrappers . body) + (if (eq? wrappers '()) + `(begin ,@body) + `(,@(first wrappers) + (nested ,(rest wrappers) + ,@body)))) + +(define-syntax (let* . rst) + (define (bindings->symbols bindings) + (if (pair? bindings) + (let ([binding (car bindings)] + [other-symbols (bindings->symbols (cdr bindings))]) + (if (pair? (car binding)) + (append (car binding) other-symbols) + (cons (car binding) other-symbols))) + '())) + (define (expand-let* bindings form) + (if (pair? bindings) + `(let (,(car bindings)) + ,(expand-let* (cdr bindings) form)) + form)) + (if (symbol? (first rst)) + (let ([vars (bindings->symbols (second rst))]) + (expand-let* (second rst) + `((lambda ,vars ,@(rest (rest rst))) ,@vars))) + (expand-let* (first rst) `(begin ,@(rest rst))))) + +(define-syntax (values->list form) + `(call-with-values + (lambda () ,form) + (lambda lst lst))) + +(define-syntax (parameterize parameters . forms) + `(call-with-parameters + (lambda () ,@forms) + ,@(map (lambda (bind) `(list ,@bind)) parameters))) + +(define-syntax (let/cc var . body) + `(call/cc (lambda (,var) ,@body))) + +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/lib/util.rls b/src/lib/util.rls new file mode 100644 index 0000000..4353e71 --- /dev/null +++ b/src/lib/util.rls @@ -0,0 +1,236 @@ +(define (copy-list lst) + (if (pair? lst) + (cons (car lst) (copy-list (cdr lst))) + lst)) + +(define (take n lst) + (if (and (pair? lst) (fix>= n 1)) + (cons (car lst) (take (fix- n 1) lst)) + '())) + +(define (drop n lst) + (if (and (pair? lst) (fix>= n 1)) + (drop (fix- n 1) (cdr lst)) + lst)) + +(define (byte-substring str start [end (byte-string-size str)]) + (let* ([real-end (if (fix> end (byte-string-size str)) + (byte-string-size str) + end)] + [len (if (fix> start real-end) 0 (fix- real-end start))] + [out (make-byte-string len 0)]) + (let iter ([i 0]) + (when (fix< i len) + (byte-string-set! out i (byte-string-ref str (fix+ i start))) + (iter (fix+ i 1)))) + out)) + +(define (copy-byte-string str) + (byte-substring str 0)) + +(define (byte-string-find-first str pred [start 0] [end (byte-string-size str)]) + (let* ([len (byte-string-size str)] + [real-start (if (fix< start 0) 0 start)] + [real-end (if (fix> end len) len end)]) + (let iter ([i real-start]) + (cond + [(fix>= i real-end) #f] + [(pred (byte-string-ref str i)) i] + [else (iter (fix+ i 1))])))) + +(define (byte-string-find-last str pred [start 0] [end (byte-string-size str)]) + (let* ([len (byte-string-size str)] + [real-start (if (fix< start 0) 0 start)] + [real-end (if (fix> end len) len end)]) + (let iter ([i real-end]) + (cond + [(fix<= i real-start) #f] + [(pred (byte-string-ref str (fix- i 1))) (fix- i 1)] + [else (iter (fix- i 1))])))) + +(define (dirname/basename str) + (define (slash? ch) (eq? ch #\/)) + (define (non-slash? ch) (not (slash? ch))) + (let ([last-non-slash (byte-string-find-last str non-slash?)]) + (if last-non-slash + (let ([last-slash (byte-string-find-last str slash? 0 last-non-slash)]) + (if last-slash + (let ([prev-non-slash (byte-string-find-last str non-slash? 0 last-slash)]) + (values (byte-substring str 0 (fix+ (or prev-non-slash 0) 1)) + (byte-substring str (fix+ last-slash 1) + (fix+ last-non-slash 1)))) + (values "." str))) + (if (fix> (byte-string-size str) 0) + (values "/" "/") + (values "." ""))))) + +(define (dirname str) + (call-with-values + (lambda () (dirname/basename str)) + (lambda (x _) x))) + +(define (basename str) + (call-with-values + (lambda () (dirname/basename str)) + (lambda (_ x) x))) + +(define (make-structure supers nslots [callable #f]) + (let ([s (make-struct s:structure)]) + (struct-set! s 0 (copy-list supers)) + (struct-set! s 1 nslots) + (struct-set! s 2 callable) + (freeze! s))) + +(define (eqv? x y) + (or (eq? x y) + (and (float? x) + (float? y) + (float= x y)) + (and (byte-string? x) + (byte-string? y) + (byte-string= x y)))) + +; Caveat: does not handle cyclic lists +(define (equal? x y) + (or (eqv? x y) + (and (pair? x) + (pair? y) + (equal? (car x) (car y)) + (equal? (cdr x) (cdr y))))) + +(define (foreach-range start end fn) + (when (fix<= start end) + (fn start) + (foreach-range (fix+ start 1) end fn))) + +(define (findf fn lst) + (if (pair? lst) + (let ([x (car lst)]) + (if (fn x) + x + (findf fn (cdr lst)))) + #f)) + +(define (memq val lst) + (if (pair? lst) + (if (eq? (car lst) val) + lst + (memq val (cdr lst))) + #f)) + +(define (memq? val lst) + (and (memq val lst) #t)) + +(define first car) +(define rest cdr) +(define (second x) (first (rest x))) +(define (third x) (first (rest (rest x)))) +(define (fourth x) (first (rest (rest (rest x))))) + +(define (void . _) (values)) + +(define (list* x . xs) + (if (pair? xs) + (cons x (apply list* xs)) + x)) + +(define (apply fn . rst) (apply fn (apply list* rst))) + +(define (list-length lst) + (let iter ([n 0] [rst lst]) + (if (pair? rst) + (iter (fix+ n 1) (cdr rst)) + n))) + +(define (repeat n x [base '()]) + (if (fix<= n 0) + base + (repeat (fix- n 1) x (cons x base)))) + +(define (byte-string-append . strings) + (let* ([total-size (foldr (lambda (str len) + (fix+ len (byte-string-size str))) + 0 strings)] + [out-str (make-byte-string total-size 0)]) + (let outer ([i 0] [strs strings]) + (when (pair? strs) + (let* ([str (car strs)] + [str-size (byte-string-size str)]) + (foreach-range 0 (fix- str-size 1) + (lambda (j) (byte-string-set! out-str (fix+ i j) (byte-string-ref str j)))) + (outer (fix+ i str-size) (cdr strs))))) + out-str)) + +(define (list->string lst) + (let* ([len (list-length lst)] + [out (make-byte-string len 0)]) + (let iter ([i 0] [lst lst]) + (when (pair? lst) + (byte-string-set! out i (car lst)) + (iter (fix+ i 1) (cdr lst)))) + out)) + +(define (number->string n) + (let iter ([n n] [digits '()]) + (let ([new-digits (cons (fix+ #\0 (fix% n 10)) digits)]) + (if (fix< n 10) + (list->string new-digits) + (iter (fix/ n 10) new-digits))))) + +(define (andmap fn lst) + (or (not (pair? lst)) + (let iter ([lst lst]) + (let ([val (fn (car lst))]) + (if (pair? (cdr lst)) + (and val (iter (cdr lst))) + val))))) + +(define (ormap fn lst) + (and (pair? lst) + (let iter ([lst lst]) + (let ([val (fn (car lst))]) + (if (pair? (cdr lst)) + (or val (iter (cdr lst))) + val))))) + +(define (list->vector from-list) + (let ([vec (make-vector (list-length from-list) undefined)]) + (let iter ([i 0] [lst from-list]) + (when (pair? lst) + (vector-set! vec i (first lst)) + (iter (fix+ i 1) (rest lst)))) + vec)) + +(define (compose [fst values] . rst) + (if (pair? rst) + (let ([rest-op (apply compose rst)]) + (lambda argv + (apply fst (values->list (apply rest-op argv))))) + fst)) + +(define (vector-find vec [pred values] [start 0] [end (vector-size vec)]) + (let ([real-start (if (fix< start 0) 0 start)] + [real-end (if (fix> end (vector-size vec)) + (vector-size vec) + end)]) + (let iter ([i real-start]) + (cond + [(fix>= i real-end) #f] + [(pred (vector-ref vec i)) i] + [else (iter (fix+ i 1))])))) + +(define (has-duplicates? lst) + (and (pair? lst) + (or (memq (car lst) (cdr lst)) + (has-duplicates? (cdr lst))))) + +(define s:marker (make-structure '() 1)) + +(define (make-marker name) + (let ([marker (make-struct s:marker)]) + (struct-set! marker 0 (freeze! (copy-byte-string name))) + (freeze! marker))) + +(define (procedure? x) (kind-of? x s:lambda)) + +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/test-abort.rls b/src/test-abort.rls new file mode 100644 index 0000000..c75d11f --- /dev/null +++ b/src/test-abort.rls @@ -0,0 +1,14 @@ +(load "lib/primitives.rls") +(load "lib/primitive/foldl.rls") +(load "lib/primitive/map.rls") +(load "lib/util.rls") +(load "lib/parameters.rls") +(load "lib/abort.rls") + +(define (display+nl . x) (apply display x) (posix-write 1 "\n")) + +(display+nl (call-with-abort-handler (lambda () (abort 7)))) +(display+nl (call-with-abort-handler (lambda () (abort)) (lambda (fn) #f))) +(display+nl (call-with-abort-handler (lambda () (abort)) (lambda (fn) 8))) + +(abort) diff --git a/src/test-compiler.rls b/src/test-compiler.rls new file mode 100644 index 0000000..d95a187 --- /dev/null +++ b/src/test-compiler.rls @@ -0,0 +1,19 @@ +(load "lib/syntax.rls") + +(define d (f)) +(define-values (a b c) (values 4 d 6)) +(define (f) 9) + +(define x (make-parameter #f)) + +(parameterize ([x 7]) + (display (x)) + (posix-write 1 "\n")) + +(letrec iter ([i 0]) + (unless (fix>= i 10) + (display (list a b c i)) + (posix-write 1 "\n") + (iter (fix+ i 1)))) + +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/test-hash-table.rls b/src/test-hash-table.rls index 2bc539c..0ef26fd 100644 --- a/src/test-hash-table.rls +++ b/src/test-hash-table.rls @@ -1,5 +1,8 @@ -(load "util.rls") -(load "hash-table.rls") +(load "lib/primitives.rls") +(load "lib/primitive/foldl.rls") +(load "lib/primitive/map.rls") +(load "lib/util.rls") +(load "lib/hash-table.rls") (define ht (make-hash-table)) @@ -8,24 +11,17 @@ (fn (car lst)) (foreach fn (cdr lst)))) -(let ([insert (lambda (x) (hash-table-insert ht x x))]) +(define (map fn lst) + (if (pair? lst) + (cons (fn (car lst)) + (map fn (cdr lst))) + '())) + +(let ([insert (lambda (x) (hash-table-insert ht x (fix+ 100 x)))]) (foreach insert '(47 32 18 90 46 38 21 93 49 10 92 34 71))) -(values - (hash-table-remove ht 92) - (hash-table-remove ht 71) - (hash-table-remove ht 49) - (hash-table-remove ht 46) - (hash-table-remove ht 47) - (hash-table-remove ht 21) - (hash-table-remove ht 30) - (hash-table-remove ht 34) - (hash-table-remove ht 18) - (hash-table-remove ht 32) - (hash-table-remove ht 90) - (hash-table-remove ht 10) - (hash-table-remove ht 38) - (hash-table-remove ht 93) - ) +(values->list + (map (lambda (x) (list x (hash-table-remove ht x))) + '(92 71 49 46 47 21 30 34 71 18 32 92 90 10 21 38 18 93))) ; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/test-parameters.rls b/src/test-parameters.rls new file mode 100644 index 0000000..d96bd79 --- /dev/null +++ b/src/test-parameters.rls @@ -0,0 +1,30 @@ +(load "lib/primitives.rls") +(load "lib/primitive/foldl.rls") +(load "lib/util.rls") +(load "lib/parameters.rls") + +(define (display+nl . rst) + (apply display rst) + (posix-write 1 "\n") + (values)) + +(define current-value (make-parameter #f)) + +(let (cc) + (let/cc exit + (display+nl (current-value)) + (current-value 2) + (display+nl (current-value)) + (call-with-parameters + (lambda () + (display+nl (current-value)) + (let/cc k2 + ((let/cc k (set! cc k) k2)) + (exit)) + (current-value 7) + (display+nl (current-value))) + (list current-value 5)) + (display+nl (current-value)) + (cc (lambda () (display+nl (current-value)))))) + +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/test-port.rls b/src/test-port.rls new file mode 100644 index 0000000..bbcb4c8 --- /dev/null +++ b/src/test-port.rls @@ -0,0 +1,23 @@ +;;(load "lib/primitives.rls") +;;(load "lib/primitive/foldl.rls") +;;(load "lib/primitive/foldr.rls") +;;(load "lib/primitive/reverse.rls") +;;(load "lib/primitive/map.rls") +;;(load "lib/primitive/append.rls") +(load "lib/syntax.rls") +;(load "lib/util.rls") +;(load "lib/hash-table.rls") +;(load "lib/symbols.rls") +;(load "lib/parameters.rls") +;(load "lib/abort.rls") +;(load "lib/errors.rls") +;(load "lib/port.rls") +;(load "lib/display.rls") +;(load "lib/reader.rls") + +(port-unread (current-input-port) "123...") +(port-unread (current-input-port) "test...") +(write-string (read-line)) +(write-char #\Newline) + +; vim:set syntax=scheme sw=2 expandtab: diff --git a/src/test-util.rls b/src/test-util.rls new file mode 100644 index 0000000..7d84600 --- /dev/null +++ b/src/test-util.rls @@ -0,0 +1,27 @@ +(load "lib/primitives.rls") +(load "lib/primitive/foldl.rls") +(load "lib/primitive/foldr.rls") +(load "lib/primitive/reverse.rls") +(load "lib/primitive/map.rls") +(load "lib/primitive/append.rls") +(load "lib/util.rls") + +(values + (basename "/") + (basename "///") + (basename "/abcd") + (basename "abcd") + (basename "///a/b/c/d/") + (basename "/a//b/c/d") + (basename "/a/b/c//d") + (basename "/a/b/c/d//") + (dirname "/") + (dirname "////") + (dirname "/abcd") + (dirname "abcd") + (dirname "/a/b//c//d") + (dirname "a//b/c/d") + (dirname "a/b/c/d/") + (dirname "a/b/c/d///") + ) + diff --git a/src/util.rls b/src/util.rls deleted file mode 100644 index 2c4e995..0000000 --- a/src/util.rls +++ /dev/null @@ -1,35 +0,0 @@ -(define (copy-list lst) - (if (pair? lst) - (cons (car lst) (copy-list (cdr lst))) - lst)) - -(define (make-structure supers nslots [callable #f]) - (let ([s (make-struct structure)]) - (struct-set! s 0 (copy-list supers)) - (struct-set! s 1 nslots) - (struct-set! s 2 callable) - (freeze! s))) - -(define (eqv? x y) - (or (eq? x y) - (and (float? x) - (float? y) - (float= x y)) - (and (byte-string? x) - (byte-string? y) - (byte-string= x y)))) - -; Caveat: does not handle cyclic lists -(define (equal? x y) - (or (eqv? x y) - (and (pair? x) - (pair? y) - (equal? (car x) (car y)) - (equal? (cdr x) (cdr y))))) - -(define (trace tag [val #f]) - (posix-write 1 tag (byte-string-size tag)) - (posix-write 1 "\n" 1) - val) - -; vim:set syntax=scheme sw=2 expandtab: