nybble
/
rosella
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Implement simple self-hosting compiler (src/compiler.rls).

This commit is contained in:
Jesse D. McDonald 2011-12-07 15:11:53 -06:00
parent c3a4a0fc57
commit f3458173c4
46 changed files with 3263 additions and 880 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
builtin.c
View File

@ -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_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: */

8
builtin.h
View File

@ -18,9 +18,16 @@
#define BI_NEG_INFINITY "-infinity"
/* Names of builtin functions */
#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: */

35
doc/bytecode.txt
View File

@ -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
@ -64,9 +66,9 @@ binary-expr: up to 256, 2 in, prefix = 00
70 (tail-call-if in1 in2) ; flag byte-string, perform tail call (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
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
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)

105
gc.c
View File

@ -13,6 +13,11 @@
#include "gc.h"
#include "builtin.h"
#if 1
#define ENABLE_BACKTRACE
#include <execinfo.h>
#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,9 +1536,16 @@ 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)
#ifdef ENABLE_BACKTRACE
void *frames[32];
backtrace(frames, 32);
backtrace_symbols_fd(frames, 32, 2);
#endif
}
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",
@ -1493,12 +1553,19 @@ void _release_assert(bool expr, const char *str, const char *file, int line)
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,14 +1693,6 @@ 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);
for (size_t i = 0; i < _get_struct(v)->nslots; ++i)

10
gc.h
View File

@ -7,15 +7,9 @@
#include <stdio.h>
#include <time.h>
#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);

44
interp.c
View File

@ -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;

4
interp.h
View File

@ -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);
}

5
libcompiler/compiler.scm
View File

@ -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))

58
libcompiler/mapper.scm
View File

@ -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)]
[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)]
[g-var-idx n-global-variables]
[i-var-idx n-instance-variables]
[t-vars 0]
[gvar-map '()]
[ivar-map '()]
[var-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,30 +66,31 @@
[(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)))))
var-map))))
mvar)
(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)))
@ -76,8 +101,18 @@
(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!))]
(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)
@ -98,9 +133,10 @@
[else
(add-var var (or (and (machine-variable? val) val)
(lookup val var-map)
(add-g-var val)))])))
(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))

8
libcompiler/optimizer.scm
View File

@ -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)

26
libcompiler/primitives.scm
View File

@ -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))

1
libcompiler/reader.scm
View File

@ -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

255
libcompiler/simplifier.scm
View File

@ -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)])
@ -24,10 +24,10 @@
[(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))))]
[(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))]
@ -35,31 +35,29 @@
[(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->list) (simplify-values->list form)]
[(values) (simplify-primitive '#%values (cdr form))]
[(list) (simplify-form `(value-list (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)]
[(null? (cddr form)) (simplify-form (second form))]
[else (let ([x (gensym)])
`(let ([,x ,(second form)])
(if ,x (and ,@(cddr form)) ,x)))]))]
[(or)
(simplify-form
`(let ([,x ,(second form)])
(if ,x (and ,@(cddr form)) ,x))))])]
[(or)
(cond
[(null? (cdr form)) '#f]
[(null? (cddr form)) (second form)]
[(null? (cddr form)) (simplify-form (second form))]
[else (let ([x (gensym)])
(simplify-form
`(let ([,x ,(second form)])
(if ,x ,x (or ,@(cddr form)))))]))]
(if ,x ,x (or ,@(cddr form))))))])]
[(cond)
(simplify-form
(match (cdr form)
@ -80,7 +78,7 @@
#:bind same-form
#:lambda same-form
#:set same-form
#:value-list same-form
#:values->list same-form
#:primitive same-form
#:simple (lambda (recurse kind form) form)
#:literal (lambda (recurse kind form) form)
@ -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)
(let ([unbound-vars (remove* vars variables)])
(if (null? unbound-vars)
`(,op ,vars ,@subforms)
(flatten-binds
`(#%bind ,vars
,@(if (memq variable vars)
`((#%set! ,variable (#%make-box ,variable)))
'())
,@(map recurse subforms))))
,@(map (lambda (f) (promote-to-boxes unbound-vars f))
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)
(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)
(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)))))
(simplify-primitive op (map recurse simple-values)))
#:variable (lambda (recurse op var)
(if (eq? var variable) `(#%unbox ,variable) 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))
(and (or set-after? (form-sets? form var #f))
(if (form-captures-input? form var)
(return #t)
#t)
#f))
#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 keyword<? #:key car))

28
libcompiler/utilities.scm
View File

@ -37,9 +37,9 @@
value-used?)
(define (trace fn . args)
(let ([x (apply fn args)])
(let ([x (call-with-values (lambda () (time (apply fn args))) list)])
(pretty-print (list fn x))
x))
(apply values x)))
(define (subst old new lst)
(foldr (lambda (x rst)
@ -105,7 +105,7 @@
(and (not (variable-value? form))
(or (not (pair? form))
(eq? (first form) 'quote)
(memq (first form) '(#%builtin #%immutable #%struct #%template)))))
(memq (first form) '(#%builtin #%include #%immutable #%struct #%template)))))
(define (simple-value? form)
(or (variable-value? form)
@ -114,7 +114,7 @@
; A value-form is any simple form which can appear on the right-hand side of a (set! ...).
; If there are any side-effects they occur before the variable is updated.
(define (value-form? form)
(define complex-values '(#%bind #%lambda #%apply #%call/cc #%values #%value-list))
(define complex-values '(#%bind #%lambda #%apply #%call/cc #%values #%values->list))
(or (simple-value? form)
(memq (first form) complex-values)
(memq (first form) (map first all-primitives))))
@ -140,7 +140,7 @@
(recurse bind))]
#:set [set-fn (lambda (recurse op var value-form)
(recurse value-form))]
#:value-list [value-list-fn (lambda (recurse op values-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)])
@ -164,7 +164,7 @@
[(#%bind) bind-fn]
[(#%lambda) lambda-fn]
[(#%set!) set-fn]
[(#%value-list) value-list-fn]
[(#%values->list) values->list-fn]
[(#%values) values-fn]
[(#%apply) apply-fn]
[(#%call/cc) call/cc-fn]
@ -183,7 +183,7 @@
`(,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)
#:values->list (lambda (recurse op values-form)
`(,op ,(recurse values-form)))
#:primitive (lambda (recurse op . simple-values)
`(,op ,@(map recurse simple-values)))
@ -198,7 +198,7 @@
(recurse bind))
#:set (lambda (recurse op var value)
(recurse value))
#:value-list (lambda (recurse op var values-form)
#:values->list (lambda (recurse op var values-form)
(recurse values-form))
#:primitive (lambda (recurse op . simple-values)
(ormap recurse simple-values))
@ -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)

16
libcompiler/writer.scm
View File

@ -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))
(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))))]
(variable->code (fourth vform)))))]
[else (error "Unsupported form:" vform)])))
; vim:set sw=2 expandtab:

63
mods/mod_io.c
View File

@ -9,6 +9,7 @@
#include <sys/stat.h>
#include <fcntl.h>
#include <unistd.h>
#include <sys/param.h>
#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));
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: */

3
mods/mod_io.h
View File

@ -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

39
reader.c
View File

@ -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)

27
rosella.c
View File

@ -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(&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))
{

1053
src/compiler.rls Normal file
View File

File diff suppressed because it is too large Load Diff

121
src/hash-table.rls
View File

@ -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:

17
src/lib/abort.rls Normal file
View File

@ -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:

51
src/lib/display.rls Normal file
View File

@ -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 "#<undefined>" port)]
[(procedure? form) (write-string "#<procedure>" port)]
[(struct? form) (write-string "#<struct>" port)]
[(vector? form) (write-string "#<vector>" port)]
[else (write-string "#<other>" port)])
(values))
; vim:set syntax=scheme sw=2 expandtab:

12
src/lib/errors.rls Normal file
View File

@ -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:

99
src/lib/hash-table.rls Normal file
View File

@ -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:

121
src/lib/hash-tree.rls Normal file
View File

@ -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:

27
src/lib/keywords.rls Normal file
View File

@ -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:

90
src/lib/parameters.rls Normal file
View File

@ -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:

281
src/lib/port.rls Normal file
View File

@ -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:

4
src/lib/primitive/append.rls
View File

@ -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:

2
src/lib/primitive/foldl.rls
View File

@ -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:

2
src/lib/primitive/foldr.rls
View File

@ -8,4 +8,4 @@
(foldr fn init (cdr lst)))
init))
; vim:set syntax= sw=2 expandtab:
; vim:set syntax=scheme sw=2 expandtab:

5
src/lib/primitive/map.rls
View File

@ -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:

8
src/lib/primitive/reverse.rls
View File

@ -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:

278
src/lib/primitives.rls
View File

@ -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:

259
src/reader.rls → src/lib/reader.rls
View File

@ -1,59 +1,31 @@
(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)
(let ([eof-handler (current-read-eof-handler)])
(call-with-parameters
(lambda ()
(skip-whitespace)
(cond
[eof? (unexpected-eof)]
[eof? (eof-handler)]
[(eq? current-char #\#)
(next-char)
(read-special)]
[(eq? current-char #\()
(next-char)
(read-list)]
(read-list #\))]
[(eq? current-char #\[)
(next-char)
(read-list #\])]
[(or (eq? current-char #\-)
(eq? current-char #\+)
(decimal-char? current-char))
@ -79,17 +51,22 @@
[(symbol-char? current-char)
(read-symbol)]
[else
(unexpected-char)]))
(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)
(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)
(unless eof?
(let/cc return
(call-with-parameters
(lambda ()
(set! current-char (read-char port)))
(list current-port-eof-handler
(lambda ()
(set! eof? #t)
#f)))))
(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:

33
src/lib/symbols.rls Normal file
View File

@ -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:

72
src/lib/syntax.rls Normal file
View File

@ -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:

236
src/lib/util.rls Normal file
View File

@ -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:

14
src/test-abort.rls Normal file
View File

@ -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)

19
src/test-compiler.rls Normal file
View File

@ -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:

34
src/test-hash-table.rls
View File

@ -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:

30
src/test-parameters.rls Normal file
View File

@ -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:

23
src/test-port.rls Normal file
View File

@ -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:

27
src/test-util.rls Normal file
View File

@ -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///")
)

35
src/util.rls
View File

@ -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: