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

83
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 lambda_type_root;
static gc_root_t template_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_freeze(interp_state_t *state);
static void bi_immutable_p(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_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) void builtin_init(void)
{ {
@ -37,10 +45,19 @@ void builtin_init(void)
register_builtin(BI_NEG_INFINITY, make_float(-INFINITY)); register_builtin(BI_NEG_INFINITY, make_float(-INFINITY));
#endif #endif
register_builtin(BI_VALUES, make_builtin_fn(bi_values));
register_builtin(BI_FREEZE, make_builtin_fn(bi_freeze)); register_builtin(BI_FREEZE, make_builtin_fn(bi_freeze));
register_builtin(BI_IMMUTABLE_P, make_builtin_fn(bi_immutable_p)); register_builtin(BI_IMMUTABLE_P, make_builtin_fn(bi_immutable_p));
register_builtin(BI_DISPLAY, make_builtin_fn(bi_display));
register_builtin(BI_STRING_TO_NUMBER, make_builtin_fn(bi_string_to_number)); register_builtin(BI_STRING_TO_NUMBER, make_builtin_fn(bi_string_to_number));
register_builtin(BI_REGISTER_FINALIZER, make_builtin_fn(bi_register_finalizer));
register_builtin(BI_STRING_TO_BUILTIN, make_builtin_fn(bi_string_to_builtin));
register_builtin(BI_BUILTIN_TO_STRING, make_builtin_fn(bi_builtin_to_string));
register_builtin(BI_CURRENT_CONTEXT, make_builtin_fn(bi_current_context));
register_builtin(BI_CALL_WITH_CONTEXT, make_builtin_fn(bi_call_with_context));
} }
void register_builtin(const char *name, value_t value) void register_builtin(const char *name, value_t value)
@ -69,6 +86,20 @@ value_t lookup_builtin(const char *name)
return FALSE_VALUE; 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) value_t get_template_type(void)
{ {
return template_type_root.value; return template_type_root.value;
@ -79,6 +110,29 @@ value_t get_lambda_type(void)
return lambda_type_root.value; 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) static void bi_freeze(interp_state_t *state)
{ {
value_t val = CAR(state->argv.value); 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)); 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: */ /* vim:set sw=2 expandtab: */

14
builtin.h
View File

@ -18,9 +18,16 @@
#define BI_NEG_INFINITY "-infinity" #define BI_NEG_INFINITY "-infinity"
/* Names of builtin functions */ /* Names of builtin functions */
#define BI_FREEZE "freeze!" #define BI_VALUES "values"
#define BI_IMMUTABLE_P "immutable?" #define BI_FREEZE "freeze!"
#define BI_STRING_TO_NUMBER "string->number" #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. */ /* Lambda: Instances of this structure are fundamental callable objects. */
#define LAMBDA_SLOT_GLOBAL_VARS 0 #define LAMBDA_SLOT_GLOBAL_VARS 0
@ -43,6 +50,7 @@ value_t get_template_type(void);
void builtin_init(void); void builtin_init(void);
void register_builtin(const char *name, value_t value); void register_builtin(const char *name, value_t value);
value_t lookup_builtin(const char *name); value_t lookup_builtin(const char *name);
value_t reverse_lookup_builtin(value_t value);
#endif #endif
/* vim:set sw=2 expandtab: */ /* vim:set sw=2 expandtab: */

51
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 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 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 binary-expr: up to 256, 2 in, prefix = 00
00 sub in: unary-expr 00 sub in: unary-expr
@ -53,20 +55,20 @@ binary-expr: up to 256, 2 in, prefix = 00
28 (remainder in1 in2) ; float float 28 (remainder in1 in2) ; float float
29 (scalb in1 in2) ; float float 29 (scalb in1 in2) ; float float
30 (kind-of? in1 in2) ; value struct-type ==> boolean 30 (kind-of? in1 in2) ; value struct-type ==> boolean
31 (byte-string= in1 in2) 31 (byte-string= in1 in2)
32 (byte-string< in1 in2) ; == (byte-string> in2 in1) 32 (byte-string< in1 in2) ; == (byte-string> in2 in1)
33 (byte-string>= in1 in2) ; == (byte-string<= in2 in1) 33 (byte-string>= in1 in2) ; == (byte-string<= in2 in1)
50 (set-box! in1 in2) ; box value ==> in2 50 (set-box! in1 in2) ; box value ==> in2
51 (set-car! in1 in2) ; pair value ==> in2 51 (set-car! in1 in2) ; pair value ==> in2
52 (set-cdr! in1 in2) ; pair value ==> in2 52 (set-cdr! in1 in2) ; pair value ==> in2
70 (tail-call-if in1 in2) ; flag byte-string, perform tail call (in2) if in1 != #f 70 (tail-call-if in1 in2) ; flag byte-string, perform tail call (in2) if in1 != #f
ff (fatal-error-if in1 in2) ; signal fatal error (annotated with 'in2') if in1 != #f
unary-expr: up to 256, 1 in, prefix = 00 00 unary-expr: up to 256, 1 in, prefix = 00 00
00 (fatal-error in) ; signal fatal error; annotated with 'in' if non-nil
01 (unbox in) 01 (unbox in)
02 (weak-unbox in) 02 (weak-unbox in)
03 (car in) 03 (car in)
@ -151,20 +153,21 @@ unary-expr: up to 256, 1 in, prefix = 00 00
74 (nan? in) 74 (nan? in)
in: in:
tN (0NNNNNNN) [transient, 0 <= N < 128, one for each prior expression] tN 00-7f [transient, 0 <= N < 128, one for each prior expression]
gN (10NNNNNN) [global, 0 <= N < 64] gN 80-bf [global, 0 <= N < 64]
iN (110NNNNN) [instance, 0 <= N < 32] iN c0-ef [instance, 0 <= N < 48]
iN (1110NNNN) [instance, 32 <= N < 48] #f f0 [constant]
#f (11110000) [constant] nil f1 [constant]
undef (11110001) [constant] undef f2 [constant]
nil (11110010) [constant] -- f3-f7 [reserved, 3 <= x < 8]
-- (1111xxxx) [reserved, 2 <= x < 10] self f8 [current lambda]
self (11111010) [current lambda] globals f9 [current global value vector]
argv (11111011) [argument list] inst fa [current instance value vector]
kw-args (11111100) [keyword arguments] (sorted) argv fb [argument list]
kw-vals (11111101) [keyword values] (match kw-args) kw-args fc [keyword arguments] (sorted)
ctx (11111110) [dynamic context] kw-vals fd [keyword values] (match kw-args)
k (11111111) [continuation] ctx fe [dynamic context]
k ff [continuation]
lambda:[ lambda:[
global: vector of immutable values (g0..gN); shared between instances (lambdas) global: vector of immutable values (g0..gN); shared between instances (lambdas)

117
gc.c
View File

@ -13,6 +13,11 @@
#include "gc.h" #include "gc.h"
#include "builtin.h" #include "builtin.h"
#if 1
#define ENABLE_BACKTRACE
#include <execinfo.h>
#endif
#if _CLOCK_MONOTONIC #if _CLOCK_MONOTONIC
# define TIMING_CLOCK CLOCK_MONOTONIC # define TIMING_CLOCK CLOCK_MONOTONIC
#else #else
@ -21,6 +26,22 @@
gc_stats_t gc_stats; 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 */ /* Helper macros to reduce duplication */
#define VECTOR_BYTES(nelem) (sizeof(vector_t) + (sizeof(value_t) * (nelem))) #define VECTOR_BYTES(nelem) (sizeof(vector_t) + (sizeof(value_t) * (nelem)))
#define BYTESTR_BYTES(size) (sizeof(byte_string_t) + (size)) #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 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 = (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); 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) 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) 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) 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_gen0_init(gen0_size);
gc_gen1_init(gen1_min_size, gen1_max_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(); 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; gc_enabled = true;
structure_init(); structure_init();
@ -673,9 +728,7 @@ static void collect_gen0_garbage(void)
{ {
if (gc_enabled) if (gc_enabled)
{ {
#ifndef NDEBUG
size_t initial_gen1_free_space; size_t initial_gen1_free_space;
#endif
#ifndef NO_STATS #ifndef NO_STATS
size_t initial_free_space; 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(); initial_free_space = gc_gen0_free_space() + gc_gen1_free_space();
#endif #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_gen0_collection);
assert(!gc_in_gen1_collection); assert(!gc_in_gen1_collection);
#ifndef NDEBUG
initial_gen1_free_space = gc_gen1_free_space(); initial_gen1_free_space = gc_gen1_free_space();
#endif
/* If we trigger a Gen-1 collection at any point then we are done. */ /* If we trigger a Gen-1 collection at any point then we are done. */
/* Full collection will pull in any current Gen-0 objects. */ /* 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. */ /* 4. Reset Gen-0 range to 'empty' state. */
gc_gen0_free_ptr = gc_gen0_range; 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_STATS
#ifndef NO_TIMING_STATS #ifndef NO_TIMING_STATS
@ -815,7 +867,7 @@ void *gc_alloc(size_t nbytes)
if (nbytes >= gc_gen0_size) 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); return gc_alloc_gen1(nbytes);
} }
else else
@ -1305,7 +1357,7 @@ static void collect_gen1_garbage(size_t min_free)
#endif #endif
#endif #endif
debug(("Performing Gen-1 garbage collection pass...\n")); debug_info("Performing Gen-1 garbage collection pass...\n");
gc_enabled = false; gc_enabled = false;
gc_in_gen0_collection = 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; gc_gen0_free_ptr = gc_gen0_range;
collected_garbage = true; 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_in_gen1_collection = false;
gc_enabled = true; 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. * 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 { do {
release_assert(gc_gen1_max_size < (SIZE_MAX/2)); release_assert(gc_gen1_max_size < (SIZE_MAX/2));
@ -1483,22 +1536,36 @@ void get_next_finalizer(value_t *value, value_t *finalizer)
} }
} }
void _release_assert(bool expr, const char *str, const char *file, int line) void print_backtrace(void)
{ {
if (!expr) #ifdef ENABLE_BACKTRACE
{ void *frames[32];
fprintf(stderr, "ERROR: Invalid state detected in %s, line %d.\n" backtrace(frames, 32);
"Assertion failed: %s\n", backtrace_symbols_fd(frames, 32, 2);
file, line, str); #endif
}
abort(); void _release_assert(const char *str, const char *file, int line)
} {
fprintf(stderr, "ERROR: Invalid state detected in %s, line %d.\n"
"Assertion failed: %s\n",
file, line, str);
abort();
} }
static void _fprint_value(FILE *f, value_t v, seen_value_t *seen) static void _fprint_value(FILE *f, value_t v, seen_value_t *seen)
{ {
seen_value_t new_seen = { v, seen }; seen_value_t new_seen = { v, seen };
int depth = 0; 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))) if (is_object(v) && !(is_float(v) || is_byte_string(v) || is_builtin_fn(v)))
{ {
@ -1626,15 +1693,7 @@ static void _fprint_value(FILE *f, value_t v, seen_value_t *seen)
fputs("#@", f); fputs("#@", f);
fputs("#S(", f); fputs("#S(", f);
_fprint_value(f, meta, &new_seen);
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) for (size_t i = 0; i < _get_struct(v)->nslots; ++i)
{ {

10
gc.h
View File

@ -7,15 +7,9 @@
#include <stdio.h> #include <stdio.h>
#include <time.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. */ /* Like assert(), but for things we want to check even in release builds. */
/* More informative than a simple "if (!x) abort();" statement. */ /* 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. */ /* Evaluates to false, but with an expression that conveys what went wrong. */
#define NOTREACHED(msg) 0 #define NOTREACHED(msg) 0
@ -464,7 +458,7 @@ static inline void _gc_write_barrier(value_t v)
} }
/* Implements the release_assert() macro */ /* 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 */ /* To be provided by the main application */
void out_of_memory(void); 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. */ /* Keep going until something attempts to tail-call END_PROGRAM, the original 'k', indicating completion. */
while (state.lambda.value != END_PROGRAM) 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; state.ntransients = 0;
#if 0 #if 0
@ -83,6 +76,13 @@ value_t run_interpreter(value_t lambda, value_t argv)
fflush(stderr); fflush(stderr);
#endif #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)) if (is_builtin_fn(state.lambda.value))
{ {
/* Builtin functions replace the byte-code and tail-call steps. */ /* 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); 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 else
{ {
value_t v1 = get_input(state, in1); 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); WRITE_BARRIER(v1);
return UNDEFINED; 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: default:
release_assert(NOTREACHED("Invalid binary byte-code!")); release_assert(NOTREACHED("Invalid binary byte-code!"));
return UNDEFINED; return UNDEFINED;
@ -459,10 +479,6 @@ static value_t eval_unary_expression(interp_state_t *state, uint8_t code, uint8_
switch (code) switch (code)
{ {
case 0x00:
release_assert(NOTREACHED("Fatal error detected."));
return UNDEFINED;
case 0x01: return get_box(v1)->value; case 0x01: return get_box(v1)->value;
case 0x02: return get_weak_box(v1)->value; case 0x02: return get_weak_box(v1)->value;
case 0x03: return get_pair(v1)->car; 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 0xf0: return FALSE_VALUE;
case 0xf1: return NIL; case 0xf1: return NIL;
case 0xf2: return UNDEFINED; case 0xf2: return UNDEFINED;
/* 0xf3 through 0xf9 are reserved */ /* 0xf3 through 0xf7 are reserved */
case 0xfa: return state->lambda.value; 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 0xfb: return state->argv.value;
case 0xfc: return state->kw_args.value; case 0xfc: return state->kw_args.value;
case 0xfd: return state->kw_vals.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; value_t old_k = state->k.value;
state->ctx.value = FALSE_VALUE; state->ctx.value = UNDEFINED;
state->k.value = FALSE_VALUE; state->k.value = UNDEFINED;
interp_tail_call(state, old_k, values, NIL, NIL); interp_tail_call(state, old_k, values, NIL, NIL);
} }

5
libcompiler/compiler.scm
View File

@ -6,18 +6,15 @@
(provide reduce-function (provide reduce-function
compile-function compile-function
optimize? optimize?)
box-free-variables?)
(define optimize? (make-parameter #t)) (define optimize? (make-parameter #t))
(define box-free-variables? (make-parameter #f))
(define (compile-function lambda-form) (define (compile-function lambda-form)
(map-variables (reduce-function lambda-form))) (map-variables (reduce-function lambda-form)))
(define (reduce-function lambda-form) (define (reduce-function lambda-form)
((compose (if (optimize?) optimize-function values) ((compose (if (optimize?) optimize-function values)
(if (box-free-variables?) promote-free-variables values)
simplify-lambda) simplify-lambda)
lambda-form)) lambda-form))

132
libcompiler/mapper.scm
View File

@ -26,14 +26,38 @@
next) next)
(end-fn)))) (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 '())) (define (map-variables lambda/template-form (capture-map '()))
(let ([bind (fourth lambda/template-form)] (let ([bind (fourth lambda/template-form)]
[next-t-var (from-list transient-variables (lambda () (error "Out of transient vars")))]
[next-g-var (from-list global-variables)] [next-g-var (from-list global-variables)]
[next-i-var (from-list instance-variables)] [next-i-var (from-list instance-variables)]
[next-t-var (from-list transient-variables)] [g-var-idx n-global-variables]
[gvar-map '()] [i-var-idx n-instance-variables]
[ivar-map '()] [t-vars 0]
[var-map '()]) [gvar-map '()]
[ivar-map '()]
[var-map '()]
[exprs '()])
(define (extra-g-var)
(let ([mvar (add-expr #f `(#%vector-ref-immed #%globals
,@(values->list (quotient/remainder g-var-idx 256))))])
(set! g-var-idx (+ g-var-idx 1))
mvar))
(define (extra-i-var)
(let ([mvar (add-expr #f `(#%vector-ref-immed #%inst
,@(values->list (quotient/remainder i-var-idx 256))))])
(set! i-var-idx (+ i-var-idx 1))
mvar))
(define (add-g-var value) (define (add-g-var value)
(cond (cond
@ -42,65 +66,77 @@
[(equal? value '(quote ())) '#%nil] [(equal? value '(quote ())) '#%nil]
[else [else
(let ([value (cond [(and (pair? value) (eq? (first value) 'quote)) (second value)] (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])]) [else value])])
(or (lookup value gvar-map) (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)) (set! gvar-map (cons (list value g-var) gvar-map))
g-var)))])) g-var)))]))
(define (add-i-var source) (define (add-i-var source)
(or (and (special-constant? source) source) (or (and (special-constant? source) source)
(lookup source ivar-map) (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)) (set! ivar-map (cons (list source i-var) ivar-map))
i-var))) i-var)))
(let ([exprs '()]) (define (add-var var mvar)
(define (add-var var mvar) (when var
(when var (set! var-map
(set! var-map (cons (list var mvar)
(cons (list var mvar) (filter (lambda (x) (not (eq? (first x) var)))
(filter (lambda (x) (not (eq? (first x) var))) var-map))))
var-map))))) mvar)
(define (add-expr var val) (define (add-expr var val)
(let ([tvar (next-t-var)]) (let ([tvar (next-t-var)])
(set! exprs (cons `(#%set! ,tvar ,val) exprs)) (set! t-vars (+ 1 t-vars))
(add-var var tvar))) (set! exprs (cons `(#%set! ,tvar ,val) exprs))
(add-var var tvar)))
(for ([bound-var (in-list (second bind))]) (for ([bound-var (in-list (second bind))])
(add-var bound-var '#%undef)) (add-var bound-var '#%undef))
(for ([free-var (in-list (free-variables bind))]) (for ([free-var (in-list (free-variables bind))])
(let ([capt (lookup free-var capture-map)]) (let ([capt (lookup free-var capture-map)])
(when capt (add-var free-var (add-i-var capt))))) (when capt (add-var free-var (add-i-var capt)))))
(for ([expr (in-list (cddr bind))]) (let iter ([bind-exprs (cddr bind)])
(let* ([setexpr? (and (pair? expr) (eq? (first expr) '#%set!))] (cond
[var (if setexpr? (second expr) #f)] [(null? bind-exprs)
[val (if setexpr? (third expr) expr)]) (void)]
(cond [(lambda-value? val) [(>= t-vars 120)
(let ([newval (map-variables val var-map)]) (write-string "Too many expressions; splitting function.\n" (current-error-port))
(if (eq? (first newval) '#%lambda) (let ([newval (map-variables `(#%lambda () () (#%bind () ,@bind-exprs)) var-map)])
(add-var var (add-g-var newval)) (add-expr #f
(add-expr var `(#%make-lambda ,(add-g-var newval)))))] `(#%tail-call ,(add-g-var newval) #%argv #%kw-args #%kw-vals #%ctx #%k)))]
[(literal-value? val) [else
(add-var var (add-g-var val))] (let* ([expr (car bind-exprs)]
[(not (symbol? val)) [setexpr? (and (pair? expr) (eq? (first expr) '#%set!))]
(add-expr var (map-form val [var (if setexpr? (second expr) #f)]
#:variable (lambda (recurse kind form) [val (if setexpr? (third expr) expr)])
(or (and (machine-variable? form) form) (cond [(lambda-value? val)
(lookup form var-map) (let ([newval (map-variables val var-map)])
(add-g-var form))) (if (eq? (first newval) '#%lambda)
#:literal (lambda (recurse kind form) (add-var var (add-g-var newval))
(add-g-var form))))] (add-expr var `(#%make-lambda ,(add-g-var newval)))))]
[else [(literal-value? val)
(add-var var (or (and (machine-variable? val) val) (add-var var (add-g-var val))]
(lookup val var-map) [(not (symbol? val))
(add-g-var val)))]))) (add-expr var (map-form val
#:variable (lambda (recurse kind form)
(or (and (machine-variable? form) form)
(lookup form var-map)
(add-g-var form)))
#:literal (lambda (recurse kind form)
(add-g-var form))))]
[else
(add-var var (or (and (machine-variable? val) val)
(lookup val var-map)
(add-g-var val)))]))
(iter (cdr bind-exprs))]))
(set! bind `(#%bind () ,@(reverse exprs)))) (set! bind `(#%bind () ,@(reverse exprs)))
`(,(if (null? ivar-map) '#%lambda '#%template) `(,(if (null? ivar-map) '#%lambda '#%template)
,(map first (reverse gvar-map)) ,(map first (reverse gvar-map))

8
libcompiler/optimizer.scm
View File

@ -2,6 +2,7 @@
(require scheme/list) (require scheme/list)
(require scheme/match) (require scheme/match)
(require scheme/pretty)
(require (file "utilities.scm")) (require (file "utilities.scm"))
(provide reduce-variables (provide reduce-variables
@ -41,6 +42,11 @@
(map-form form #:bind bind-fn)) (map-form form #:bind bind-fn))
(define (propogate-value variable value invalidates? forms) (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) (if (null? forms)
forms forms
(let* ([form (car forms)] (let* ([form (car forms)]
@ -54,7 +60,7 @@
(eq? (second (car forms)) variable)) (eq? (second (car forms)) variable))
(invalidates? new-form)) (invalidates? new-form))
(cons new-form after) (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. ; Simple values (literals, variables) can replace arguments as well as #%set! values.
(define (propogate-simple-value variable value invalidates? forms) (define (propogate-simple-value variable value invalidates? forms)

26
libcompiler/primitives.scm
View File

@ -16,8 +16,7 @@
machine-variable?) machine-variable?)
(define unary-primitives (define unary-primitives
'((#%fatal-error #x00 fatal-error) '((#%unbox #x01 unbox)
(#%unbox #x01 unbox)
(#%weak-unbox #x02 weak-unbox) (#%weak-unbox #x02 weak-unbox)
(#%car #x03 car) (#%car #x03 car)
(#%cdr #x04 cdr) (#%cdr #x04 cdr)
@ -129,13 +128,15 @@
(#%set-box! #x50 set-box!) (#%set-box! #x50 set-box!)
(#%set-car! #x51 set-car!) (#%set-car! #x51 set-car!)
(#%set-cdr! #x52 set-cdr!) (#%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 (define ternary-primitives
'((#%if #x10 if) '((#%if #x10 if)
(#%vector-set! #x20 vector-set!) (#%vector-set! #x20 vector-set!)
(#%byte-string-set! #x21 byte-string-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 (define all-primitives
(append unary-primitives (append unary-primitives
@ -143,23 +144,24 @@
ternary-primitives)) ternary-primitives))
(define (side-effect-primitive? sym) (define (side-effect-primitive? sym)
(memq sym '(#%byte-string-set! #%fatal-error #%set-box! #%set-car! (memq sym '(#%make-box #%make-struct #%make-lambda #%make-weak-box #%cons #%make-vector
#%set-cdr! #%struct-set! #%tail-call-if #%vector-set!))) #%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 (define global-variables
(for/list ([i (in-range 0 64)]) (for/list ([i (in-range 0 64)])
(string->uninterned-symbol (string-append "#%g" (number->string i))))) (string->uninterned-symbol (string-append "#%g" (number->string i)))))
(define instance-variables (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))))) (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 (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 (global-variable? var) (and (memq var global-variables) #t))
(define (instance-variable? var) (and (memq var instance-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))) ,@(read-forms port)))
(define (read-forms [port (current-input-port)]) (define (read-forms [port (current-input-port)])
(port-count-lines! port)
(let iter ([form (read port)] (let iter ([form (read port)]
[forms '()]) [forms '()])
(match form (match form

337
libcompiler/simplifier.scm
View File

@ -2,16 +2,16 @@
(require scheme/list) (require scheme/list)
(require scheme/match) (require scheme/match)
(require scheme/pretty)
(require (file "utilities.scm")) (require (file "utilities.scm"))
(require (file "primitives.scm")) (require (file "primitives.scm"))
(provide simplify-lambda (provide simplify-lambda)
promote-free-variables)
(define (simplify-form form) (define (simplify-form form)
(define (same-form recurse . form) form) (define (same-form recurse . form) form)
(define (reverse-args new-op args) (define (reverse-args new-op args)
(simplify-form (simplify-let
(let ([a (gensym)] [b (gensym)]) (let ([a (gensym)] [b (gensym)])
`(let ([,a ,(first args)] `(let ([,a ,(first args)]
[,b ,(second args)]) [,b ,(second args)])
@ -19,47 +19,45 @@
(define (simplify-complex-form recurse op . others) (define (simplify-complex-form recurse op . others)
(case op (case op
[(let) (simplify-let form)] [(let) (simplify-let form)]
[(let*) (simplify-let* form)] [(let*) (simplify-let* form)]
[(letrec) (simplify-letrec form)] [(letrec) (simplify-letrec form)]
[(if) (simplify-if form)] [(if) (simplify-if form)]
[(lambda) (simplify-lambda form)] [(lambda) (simplify-lambda form)]
[(begin) (simplify-form `(let () ,@(cdr form)))] [(keyword-lambda) (simplify-keyword-lambda form)]
[(set!) (simplify-set! form)] [(begin) (simplify-form `(let () ,@(cdr form)))]
[(let/cc) (simplify-form [(set!) (simplify-set! 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=) (simplify-form `(eq? ,@(cdr form)))]
[(fix>) (reverse-args 'fix< (cdr form))] [(fix>) (reverse-args 'fix< (cdr form))]
[(fix<=) (reverse-args 'fix>= (cdr form))] [(fix<=) (reverse-args 'fix>= (cdr form))]
[(float>) (reverse-args 'float< (cdr form))] [(float>) (reverse-args 'float< (cdr form))]
[(float<=) (reverse-args 'float>= (cdr form))] [(float<=) (reverse-args 'float>= (cdr form))]
[(byte-string>) (reverse-args 'byte-string< (cdr form))] [(byte-string>) (reverse-args 'byte-string< (cdr form))]
[(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))] [(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))] [(apply) (simplify-apply (second form) (cddr form))]
[(call/cc) (simplify-primitive '#%call/cc (cdr form))] [(call/cc) (simplify-primitive '#%call/cc (cdr form))]
[(call-with-values) [(call-with-values)
(simplify-form (simplify-form `(apply ,(third form) (values->list (,(second form)))))]
`(apply ,(third form)
(value-list (,(second form)))))]
[(and) [(and)
(simplify-form (cond
(cond [(null? (cdr form)) '#t]
[(null? (cdr form)) '#t] [(null? (cddr form)) (simplify-form (second form))]
[(null? (cddr form)) (second form)] [else (let ([x (gensym)])
[else (let ([x (gensym)]) (simplify-form
`(let ([,x ,(second form)]) `(let ([,x ,(second form)])
(if ,x (and ,@(cddr form)) ,x)))]))] (if ,x (and ,@(cddr form)) ,x))))])]
[(or) [(or)
(simplify-form (cond
(cond [(null? (cdr form)) '#f]
[(null? (cdr form)) '#f] [(null? (cddr form)) (simplify-form (second form))]
[(null? (cddr form)) (second form)] [else (let ([x (gensym)])
[else (let ([x (gensym)]) (simplify-form
`(let ([,x ,(second form)]) `(let ([,x ,(second form)])
(if ,x ,x (or ,@(cddr form)))))]))] (if ,x ,x (or ,@(cddr form))))))])]
[(cond) [(cond)
(simplify-form (simplify-form
(match (cdr form) (match (cdr form)
@ -77,14 +75,14 @@
(cdr form)) (cdr form))
(simplify-apply (first form) (append (cdr form) '(#%nil)))))])) (simplify-apply (first form) (append (cdr form) '(#%nil)))))]))
(map-form form (map-form form
#:bind same-form #:bind same-form
#:lambda same-form #:lambda same-form
#:set same-form #:set same-form
#:value-list same-form #:values->list same-form
#:primitive same-form #:primitive same-form
#:simple (lambda (recurse kind form) form) #:simple (lambda (recurse kind form) form)
#:literal (lambda (recurse kind form) form) #:literal (lambda (recurse kind form) form)
#:other simplify-complex-form)) #:other simplify-complex-form))
(define (body->forms body) (define (body->forms body)
(let iter ([body body] (let iter ([body body]
@ -117,13 +115,13 @@
(let ([tmp (gensym)]) (let ([tmp (gensym)])
`(#%bind (,tmp) `(#%bind (,tmp)
; guaranteed not to cause unbounded recursion: tmp is unique ; guaranteed not to cause unbounded recursion: tmp is unique
,(simplify-set! `(set! ,tmp ,value-form)) ,(simplify-form `(set! ,tmp ,value-form))
(#%set! ,variable ,tmp))) (#%set! ,variable ,tmp)))
`(#%bind ,bound-vars `(#%bind ,bound-vars
,@(foldr (lambda (subform after) ,@(foldr (lambda (subform after)
(if (pair? after) (if (pair? after)
(cons subform after) (cons subform after)
(list (simplify-set! `(set! ,variable ,subform))))) (list (simplify-form `(set! ,variable ,subform)))))
'() '()
subforms)))] subforms)))]
[`(#%values ,first-val . ,other-vals) [`(#%values ,first-val . ,other-vals)
@ -135,7 +133,7 @@
[else [else
(error "Attempted to set variable to void in:" form)]))) (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))]) (let ([values-form (simplify-form (second form))])
(match values-form (match values-form
[`(#%bind ,bound-vars . ,subforms) [`(#%bind ,bound-vars . ,subforms)
@ -143,23 +141,23 @@
,@(foldr (lambda (subform after) ,@(foldr (lambda (subform after)
(if (pair? after) (if (pair? after)
(cons subform after) (cons subform after)
(list (simplify-value-list `(value-list ,subform))))) (list (simplify-form `(values->list ,subform)))))
'() '()
subforms))] subforms))]
[`(#%values) '#%nil] [`(#%values) '#%nil]
[`(#%values . ,simple-vals) [`(#%values . ,simple-vals)
; (#%value-list (#%values ...)) => (list ...) ; (#%values->list (#%values ...)) => (list ...)
(let ([tmp (gensym)]) (let ([tmp (gensym)])
`(#%bind (,tmp) `(#%bind (,tmp)
(#%set! ,tmp #%nil) (#%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)) (reverse simple-vals))
,tmp))] ,tmp))]
[(or `(#%apply . ,_) [(or `(#%apply . ,_)
`(#%call/cc . ,_)) `(#%call/cc . ,_))
`(#%value-list ,values-form)] `(#%values->list ,values-form)]
[(? value-form?) [(? value-form?)
(simplify-value-list `(value-list (values ,values-form)))] (simplify-form `(values->list (values ,values-form)))]
[_ '#%nil]))) [_ '#%nil])))
(define (simplify-primitive simple-op value-forms) (define (simplify-primitive simple-op value-forms)
@ -168,7 +166,7 @@
(if (simple-value? simple-value-form) (if (simple-value? simple-value-form)
(list simple-value-form #f) (list simple-value-form #f)
(let ([tmp (gensym)]) (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)) (define bindings (map value->binding value-forms))
@ -218,7 +216,7 @@
(let ([temp-bindings (map (lambda (binding) (let ([temp-bindings (map (lambda (binding)
(let ([tmp (gensym)]) (let ([tmp (gensym)])
(list tmp (list tmp
(simplify-set! `(set! ,tmp ,(second binding))) (simplify-form `(set! ,tmp ,(second binding)))
`(#%set! ,(first binding) ,tmp)))) `(#%set! ,(first binding) ,tmp))))
(filter has-value? bindings))]) (filter has-value? bindings))])
`(#%bind ,(map first temp-bindings) `(#%bind ,(map first temp-bindings)
@ -229,7 +227,7 @@
; Otherwise, just bind the real names directly. ; Otherwise, just bind the real names directly.
`(#%bind ,vars `(#%bind ,vars
,@(map (lambda (binding) ,@(map (lambda (binding)
(simplify-set! `(set! ,@binding))) (simplify-form `(set! ,@binding)))
(filter has-value? bindings)) (filter has-value? bindings))
,@(map simplify-form bodyexprs)))) ,@(map simplify-form bodyexprs))))
@ -311,78 +309,57 @@
; (... ; (...
; (let ([rest argv-temp]) ; (let ([rest argv-temp])
; bodyexpr...)...)))...))) ; bodyexpr...)...)))...)))
(define (promote-to-boxes variables form)
(define (promote-to-box variable form)
(map-form form (map-form form
#:bind (lambda (recurse op vars . subforms) #:bind (lambda (recurse op vars . subforms)
(flatten-binds (let ([unbound-vars (remove* vars variables)])
`(#%bind ,vars (if (null? unbound-vars)
,@(if (memq variable vars) `(,op ,vars ,@subforms)
`((#%set! ,variable (#%make-box ,variable))) (flatten-binds
'()) `(#%bind ,vars
,@(map recurse subforms)))) ,@(map (lambda (f) (promote-to-boxes unbound-vars f))
#:set (lambda (recurse op var value) subforms))))))
(let ([new-value (recurse value)]) #:set (lambda (recurse op var value)
(if (eq? var variable) (let ([new-value (recurse value)])
(if (simple-value? new-value) (if (memq var variables)
`(#%set-box! ,variable ,new-value) (simplify-form `(set-box! ,var ,new-value))
(let ([tmp (gensym)]) (simplify-form `(set! ,var ,new-value)))))
`(#%bind (,tmp) #:values->list (lambda (recurse op values-form)
,(simplify-set! `(set! ,tmp ,new-value)) `(,op ,(recurse values-form)))
(#%set-box! ,variable ,tmp)))) #:primitive (lambda (recurse op . simple-values)
(simplify-set! `(set! ,var ,new-value))))) (simplify-primitive op (map recurse simple-values)))
#:value-list (lambda (recurse op values-form) #:variable (lambda (recurse op var)
`(,op ,(recurse values-form))) (if (memq var variables)
#:primitive (lambda (recurse op . simple-values) `(#%unbox ,var)
(let ([new-args (map recurse simple-values)]) var))))
;; if any new-arg is not simple, must bind to a temp first
(let ([temps (map (lambda (x)
(if (simple-value? x)
(list x #f)
(let ([tmp (gensym)])
(list tmp `(#%set! ,tmp ,x)))))
new-args)])
(if (ormap second temps)
`(#%bind ,(map first (filter second temps))
,@(filter-map second temps)
(,op ,@(map first temps)))
`(,op ,@new-args)))))
#:variable (lambda (recurse op var)
(if (eq? var variable) `(#%unbox ,variable) var))))
(define (is-shared-var? var forms) (define (is-shared-var? var forms)
(define (set-after-first-capture?) (define (set-after-first-capture?)
(let/cc return (let/cc return
(foldr (lambda (form set-after?) (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) (if (form-captures-input? form var)
(return #t) (return #t)
#t) #t)))
#f))
#f #f
forms) forms)
#f)) #f))
(or (ormap (lambda (f) (form-captures-output? f var)) forms) (or (ormap (lambda (f) (form-captures-output? f var)) forms)
(set-after-first-capture?))) (set-after-first-capture?)))
(define (promote-shared-variables nested-bind) (define (promote-shared-variables flat-bind)
(define flat-bind (flatten-binds nested-bind)) (let* ([shared-vars (filter (lambda (v) (is-shared-var? v (cddr flat-bind)))
(foldl (lambda (var frm) (second flat-bind))])
(if (is-shared-var? var (cddr frm)) (flatten-binds
(promote-to-box var frm) `(#%bind ,(second flat-bind)
frm)) ,@(map (lambda (v) `(#%set! ,v (#%make-box #%undef))) shared-vars)
flat-bind ,@(map (lambda (f) (promote-to-boxes shared-vars f)) (cddr 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 (narrow-binds+promote flat-bind)
(define (at-top-level? var) (define (at-top-level? var)
(or (ormap (lambda (x) (form-uses? x var #f)) (cddr flat-bind)) (ormap (lambda (x) (or (form-uses? x var #f)
(ormap (lambda (x) (form-sets? x var #f)) (cddr flat-bind)))) (form-sets? x var #f)))
(cddr flat-bind)))
(define (captured-twice? var) (define (captured-twice? var)
(let/cc return (let/cc return
@ -404,7 +381,8 @@
,@(map (lambda (subform) ,@(map (lambda (subform)
(match subform (match subform
[`(#%set! ,var (#%lambda ,g-vars ,i-vars ,bind)) [`(#%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)) (define local-binds (filter free-var? extra-bindings))
(if (null? local-binds) (if (null? local-binds)
subform subform
@ -425,8 +403,7 @@
(values reqs opts #f)] (values reqs opts #f)]
[_ (error "Invalid argument list:" arglist)])) [_ (error "Invalid argument list:" arglist)]))
(define (add-return ctx k nested-bind) (define (add-return ctx k flat-bind)
(define flat-bind (flatten-binds nested-bind))
(define argv (gensym)) (define argv (gensym))
`(#%bind (,@(second flat-bind) ,argv) `(#%bind (,@(second flat-bind) ,argv)
,@(foldr (lambda (subform after) ,@(foldr (lambda (subform after)
@ -435,9 +412,9 @@
(match subform (match subform
[(? simple-value?) [(? simple-value?)
`((#%set! ,argv (#%cons ,subform #%nil)) `((#%set! ,argv (#%cons ,subform #%nil))
(#%tail-call ,k ,argv #%nil #%nil #f #f))] (#%tail-call ,k ,argv #%nil #%nil #%undef #%undef))]
[`(#%apply . ,sv) [`(#%apply ,fn ,av ,kw ,kv)
`((#%tail-call ,@sv ,ctx ,k))] `((#%tail-call ,fn ,av ,kw ,kv ,ctx ,k))]
[`(#%call/cc ,x) [`(#%call/cc ,x)
`((#%set! ,argv (#%cons ,k #%nil)) `((#%set! ,argv (#%cons ,k #%nil))
(#%tail-call ,x ,argv #%nil #%nil ,ctx ,k))] (#%tail-call ,x ,argv #%nil #%nil ,ctx ,k))]
@ -445,64 +422,71 @@
`((#%set! ,argv #%nil) `((#%set! ,argv #%nil)
,@(map (lambda (sv) `(#%set! ,argv (#%cons ,sv ,argv))) ,@(map (lambda (sv) `(#%set! ,argv (#%cons ,sv ,argv)))
(reverse simple-vals)) (reverse simple-vals))
(#%tail-call ,k ,argv #%nil #%nil #f #f))] (#%tail-call ,k ,argv #%nil #%nil #%undef #%undef))]
[(? value-form?) [(? value-form?)
`(,(simplify-set! `(set! ,argv ,subform)) `((#%set! ,argv ,subform)
(#%set! ,argv (#%cons ,argv #%nil)) (#%set! ,argv (#%cons ,argv #%nil))
(#%tail-call ,k ,argv #%nil #%nil #f #f))] (#%tail-call ,k ,argv #%nil #%nil #%undef #%undef))]
[`(#%tail-call . ,_) [`(#%tail-call . ,_)
`(,subform)] `(,subform)]
[_ [_
`(,subform `(,subform
(#%tail-call ,k #%nil #%nil #%nil #f #f))]))) (#%tail-call ,k #%nil #%nil #%nil #%undef #%undef))])))
'() '()
(cddr flat-bind)))) (cddr flat-bind))))
(define (transform-to-cps ctx nested-bind) (define (transform-to-cps ctx flat-bind)
(define flat-bind (flatten-binds nested-bind))
(define (cps-prepend subform after) (define (cps-prepend subform after)
(match subform (match subform
[`(#%set! ,v (#%value-list (#%apply . ,sv))) [`(#%set! ,v (#%values->list (#%apply ,fn ,av ,kw ,kv)))
(let ([k (gensym)]) (let ([k (gensym)]
[t (gensym)])
`((#%bind (,k) `((#%bind (,k)
(#%set! ,k ,(simplify-form (#%set! ,k ,(simplify-form
`(lambda ,v `(lambda ,t
(set! ,v ,t)
,@after))) ,@after)))
(#%tail-call ,@sv ,ctx ,k))))] (#%tail-call ,fn ,av ,kw ,kv ,ctx ,k))))]
[`(#%set! ,v (#%apply . ,sv)) [`(#%set! ,v (#%apply ,fn ,av ,kw ,kv))
(let ([k (gensym)]) (let ([k (gensym)]
[t (gensym)])
`((#%bind (,k) `((#%bind (,k)
(#%set! ,k ,(simplify-form (#%set! ,k ,(simplify-form
`(lambda (,v . ,(gensym)) `(lambda (,t . ,(gensym))
(set! ,v ,t)
,@after))) ,@after)))
(#%tail-call ,@sv ,ctx ,k))))] (#%tail-call ,fn ,av ,kw ,kv ,ctx ,k))))]
[(or `(#%value-list (#%apply . ,sv)) [(or `(#%values->list (#%apply ,fn ,av ,kw ,kv))
`(#%apply . ,sv)) `(#%apply ,fn ,av ,kw ,kv))
(let ([k (gensym)]) (let ([k (gensym)])
`((#%bind (,k) `((#%bind (,k)
(#%set! ,k ,(simplify-form (#%set! ,k ,(simplify-form
`(lambda ,(gensym) `(lambda ,(gensym)
,@after))) ,@after)))
(#%tail-call ,@sv ,ctx ,k))))] (#%tail-call ,fn ,av ,kw ,kv ,ctx ,k))))]
[`(#%set! ,v (#%value-list (#%call/cc ,x))) [`(#%set! ,v (#%values->list (#%call/cc ,x)))
(let ([k (gensym)] (let ([k (gensym)]
[k-argv (gensym)]) [k-argv (gensym)]
[t (gensym)])
`((#%bind (,k ,k-argv) `((#%bind (,k ,k-argv)
(#%set! ,k ,(simplify-form (#%set! ,k ,(simplify-form
`(lambda ,v `(lambda ,t
(set! ,v ,t)
,@after))) ,@after)))
(#%set! ,k-argv (#%cons ,k #%nil)) (#%set! ,k-argv (#%cons ,k #%nil))
(#%tail-call ,x ,k-argv #%nil #%nil ,ctx ,k))))] (#%tail-call ,x ,k-argv #%nil #%nil ,ctx ,k))))]
[`(#%set! ,v (#%call/cc ,x)) [`(#%set! ,v (#%call/cc ,x))
(let ([k (gensym)] (let ([k (gensym)]
[k-argv (gensym)]) [k-argv (gensym)]
[t (gensym)])
`((#%bind (,k ,k-argv) `((#%bind (,k ,k-argv)
(#%set! ,k ,(simplify-form (#%set! ,k ,(simplify-form
`(lambda (,v . ,(gensym)) `(lambda (,t . ,(gensym))
(set! ,v ,t)
,@after))) ,@after)))
(#%set! ,k-argv (#%cons ,k #%nil)) (#%set! ,k-argv (#%cons ,k #%nil))
(#%tail-call ,x ,k-argv #%nil #%nil ,ctx ,k))))] (#%tail-call ,x ,k-argv #%nil #%nil ,ctx ,k))))]
[(or `(#%value-list (#%call/cc ,x)) [(or `(#%values->list (#%call/cc ,x))
`(#%call/cc ,x)) `(#%call/cc ,x))
(let ([k (gensym)] (let ([k (gensym)]
[k-argv (gensym)]) [k-argv (gensym)])
@ -519,23 +503,16 @@
`(#%bind ,(second flat-bind) `(#%bind ,(second flat-bind)
,@(foldr cps-prepend '() (cddr flat-bind)))) ,@(foldr cps-prepend '() (cddr flat-bind))))
(define (simplify-lambda form) (define (arguments->lets arglist argv bodyexprs)
(define arglist (cadr form))
(define bodyexprs (cddr form))
(define-values (requireds optionals rest) (split-arglist arglist)) (define-values (requireds optionals rest) (split-arglist arglist))
(define argv (gensym))
(define ctx (gensym))
(define k (gensym))
(define (add-req req inner) (define (add-req req inner)
`(let ([,req (car ,argv)]) `(let ([,req (car ,argv)])
(set! ,argv (cdr ,argv)) (set! ,argv (cdr ,argv))
,inner)) ,inner))
(define (add-opt opt-list inner) (define (add-opt opt-list inner)
`(let (,(car opt-list)) `(let (,(first opt-list))
(if (pair? ,argv) (if (pair? ,argv)
(begin (begin
(set! ,(first opt-list) (car ,argv)) (set! ,(first opt-list) (car ,argv))
@ -548,19 +525,54 @@
`(let ([,rest ,argv]) ,@bodyexprs) `(let ([,rest ,argv]) ,@bodyexprs)
`(begin ,@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 () () `(#%lambda () ()
,((compose narrow-binds+promote ,((compose narrow-binds+promote
flatten-binds
(lambda (bind) (transform-to-cps ctx bind)) (lambda (bind) (transform-to-cps ctx bind))
(lambda (bind) (add-return ctx k bind)) (lambda (bind) (add-return ctx k bind))
flatten-binds
simplify-form) simplify-form)
`(let ([,argv #%argv] `(let ([,argv #%argv]
[,ctx #%ctx] [,ctx #%ctx]
[,k #%k]) [,k #%k])
,(foldr add-req ,(arguments->lets arglist argv bodyexprs)))))
(foldr add-opt
rest+bodyexprs (define (simplify-keyword-lambda form)
optionals) (define arglist (cadr form))
requireds))))) (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...) ; (fn-expr arg-expr...)
; => (let ([fn-var fn-expr] arg-var... argv) ; => (let ([fn-var fn-expr] arg-var... argv)
@ -587,7 +599,8 @@
[`(,expr . ,(and rst `(,_ . ,_))) [`(,expr . ,(and rst `(,_ . ,_)))
(let-values ([(bnd args kws) (iter rst)] (let-values ([(bnd args kws) (iter rst)]
[(x) (gensym)]) [(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)) (define sorted-kws (sort keywords keyword<? #:key car))

130
libcompiler/utilities.scm
View File

@ -37,9 +37,9 @@
value-used?) value-used?)
(define (trace fn . args) (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)) (pretty-print (list fn x))
x)) (apply values x)))
(define (subst old new lst) (define (subst old new lst)
(foldr (lambda (x rst) (foldr (lambda (x rst)
@ -105,7 +105,7 @@
(and (not (variable-value? form)) (and (not (variable-value? form))
(or (not (pair? form)) (or (not (pair? form))
(eq? (first form) 'quote) (eq? (first form) 'quote)
(memq (first form) '(#%builtin #%immutable #%struct #%template))))) (memq (first form) '(#%builtin #%include #%immutable #%struct #%template)))))
(define (simple-value? form) (define (simple-value? form)
(or (variable-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! ...). ; 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. ; If there are any side-effects they occur before the variable is updated.
(define (value-form? form) (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) (or (simple-value? form)
(memq (first form) complex-values) (memq (first form) complex-values)
(memq (first form) (map first all-primitives)))) (memq (first form) (map first all-primitives))))
@ -133,76 +133,76 @@
(and (pair? form) (eq? (first form) '#%bind))) (and (pair? form) (eq? (first form) '#%bind)))
(define (traverse-form form (define (traverse-form form
#:bind [bind-fn (lambda (recurse op vars . subforms) #:bind [bind-fn (lambda (recurse op vars . subforms)
(for ([subform (in-list subforms)]) (for ([subform (in-list subforms)])
(recurse subform)))] (recurse subform)))]
#:lambda [lambda-fn (lambda (recurse op g-vars i-vars bind) #:lambda [lambda-fn (lambda (recurse op g-vars i-vars bind)
(recurse bind))] (recurse bind))]
#:set [set-fn (lambda (recurse op var value-form) #:set [set-fn (lambda (recurse op var value-form)
(recurse 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))] (recurse values-form))]
#:primitive [primitive-fn (lambda (recurse op . simple-values) #:primitive [primitive-fn (lambda (recurse op . simple-values)
(for ([val (in-list simple-values)]) (for ([val (in-list simple-values)])
(recurse val)))] (recurse val)))]
#:simple [simple-fn (lambda (recurse kind simple-value) (void))] #:simple [simple-fn (lambda (recurse kind simple-value) (void))]
#:other [other-fn (lambda (recurse . form) #:other [other-fn (lambda (recurse . form)
(error "Unsimplified form:" form))] (error "Unsimplified form:" form))]
#:values [values-fn primitive-fn] #:values [values-fn primitive-fn]
#:call [call-fn primitive-fn] #:call [call-fn primitive-fn]
#:variable [variable-fn simple-fn] #:variable [variable-fn simple-fn]
#:literal [literal-fn simple-fn] #:literal [literal-fn simple-fn]
#:apply [apply-fn call-fn] #:apply [apply-fn call-fn]
#:call/cc [call/cc-fn call-fn] #:call/cc [call/cc-fn call-fn]
#:tail-call [tail-call-fn call-fn]) #:tail-call [tail-call-fn call-fn])
(define (recurse subform) (define (recurse subform)
(cond (cond
[(variable-value? subform) (variable-fn recurse 'variable subform)] [(variable-value? subform) (variable-fn recurse 'variable subform)]
[(literal-value? subform) (literal-fn recurse 'literal subform)] [(literal-value? subform) (literal-fn recurse 'literal subform)]
[else [else
(let ([handler (case (first subform) (let ([handler (case (first subform)
[(#%bind) bind-fn] [(#%bind) bind-fn]
[(#%lambda) lambda-fn] [(#%lambda) lambda-fn]
[(#%set!) set-fn] [(#%set!) set-fn]
[(#%value-list) value-list-fn] [(#%values->list) values->list-fn]
[(#%values) values-fn] [(#%values) values-fn]
[(#%apply) apply-fn] [(#%apply) apply-fn]
[(#%call/cc) call/cc-fn] [(#%call/cc) call/cc-fn]
[(#%tail-call) tail-call-fn] [(#%tail-call) tail-call-fn]
[else (if (primitive-form? subform) [else (if (primitive-form? subform)
primitive-fn primitive-fn
other-fn)])]) other-fn)])])
(apply handler recurse subform))])) (apply handler recurse subform))]))
(recurse form)) (recurse form))
(define map-form (define map-form
(curry-keywords traverse-form (curry-keywords traverse-form
#:bind (lambda (recurse op vars . subforms) #:bind (lambda (recurse op vars . subforms)
`(,op ,vars ,@(map recurse subforms))) `(,op ,vars ,@(map recurse subforms)))
#:lambda (lambda (recurse op g-vars i-vars bind) #:lambda (lambda (recurse op g-vars i-vars bind)
`(,op ,g-vars ,i-vars ,(recurse bind))) `(,op ,g-vars ,i-vars ,(recurse bind)))
#:set (lambda (recurse op var value-form) #:set (lambda (recurse op var value-form)
`(,op ,var ,(recurse 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))) `(,op ,(recurse values-form)))
#:primitive (lambda (recurse op . simple-values) #:primitive (lambda (recurse op . simple-values)
`(,op ,@(map recurse simple-values))) `(,op ,@(map recurse simple-values)))
#:simple (lambda (recurse kind form) form))) #:simple (lambda (recurse kind form) form)))
; Like map-form, but intended for boolean results. ; Like map-form, but intended for boolean results.
(define search-form (define search-form
(curry-keywords traverse-form (curry-keywords traverse-form
#:bind (lambda (recurse op vars . subforms) #:bind (lambda (recurse op vars . subforms)
(ormap recurse subforms)) (ormap recurse subforms))
#:lambda (lambda (recurse op g-vars i-vars bind) #:lambda (lambda (recurse op g-vars i-vars bind)
(recurse bind)) (recurse bind))
#:set (lambda (recurse op var value) #:set (lambda (recurse op var value)
(recurse value)) (recurse value))
#:value-list (lambda (recurse op var values-form) #:values->list (lambda (recurse op var values-form)
(recurse values-form)) (recurse values-form))
#:primitive (lambda (recurse op . simple-values) #:primitive (lambda (recurse op . simple-values)
(ormap recurse simple-values)) (ormap recurse simple-values))
#:simple (lambda (recurse kind form) #f))) #:simple (lambda (recurse kind form) #f)))
(define (form-sets? form variable [call-may-set? #t]) (define (form-sets? form variable [call-may-set? #t])
(search-form form (search-form form
@ -281,12 +281,12 @@
(define (flatten-binds form) (define (flatten-binds form)
(define (make-bindings-unique bind rename-vars) (define (make-bindings-unique bind rename-vars)
(define (needs-rename? var) (memq var rename-vars)) (define (needs-rename? var) (memq var rename-vars))
(define (make-binding-unique var bind) (define (unique-var var)
(let* ([prefix (string-append (symbol->string var) "->g")] (let ([prefix (string-append (symbol->string var) "->g")])
[unique-var (gensym prefix)]) (list var (gensym prefix))))
`(#%bind ,(subst var unique-var (second bind)) (let ([var-map (map unique-var (filter needs-rename? (second bind)))])
,@(map (lambda (sf) (subst-var var unique-var sf)) (cddr bind))))) `(#%bind ,(subst* var-map (second bind))
(foldr make-binding-unique bind (filter needs-rename? (second bind)))) ,@(map (lambda (sf) (subst-var* var-map sf)) (cddr bind)))))
(map-form form (map-form form
#:bind (lambda (recurse op bound-vars . original-subforms) #:bind (lambda (recurse op bound-vars . original-subforms)

22
libcompiler/writer.scm
View File

@ -87,6 +87,8 @@
(cond (cond
[(and (eq? ch #\")) [(and (eq? ch #\"))
(write-string "\\\"")] (write-string "\\\"")]
[(and (eq? ch #\\))
(write-string "\\\\")]
[(and (< (char->integer ch) 128) (char-graphic? ch)) [(and (< (char->integer ch) 128) (char-graphic? ch))
(write-char ch)] (write-char ch)]
[else [else
@ -215,6 +217,9 @@
[(and (pair? value) (memq (car value) '(#%builtin))) [(and (pair? value) (memq (car value) '(#%builtin)))
(write-string "#=") (write-string "#=")
(write-rla-string (second value))] (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))) [(and (pair? value) (memq (car value) '(#%immutable)))
(unless (number? (hash-ref (current-object-map) (second value) #f)) (unless (number? (hash-ref (current-object-map) (second value) #f))
(write-string "#@")) (write-string "#@"))
@ -258,8 +263,8 @@
(and index (+ #xc0 index))) (and index (+ #xc0 index)))
(let ([index (find var '(#%f #%nil #%undef))]) (let ([index (find var '(#%f #%nil #%undef))])
(and index (+ #xf0 index))) (and index (+ #xf0 index)))
(let ([index (find var '(#%self #%argv #%kw-args #%kw-vals #%ctx #%k))]) (let ([index (find var '(#%self #%globals #%inst #%argv #%kw-args #%kw-vals #%ctx #%k))])
(and index (+ #xfa index))) (and index (+ #xf8 index)))
(error "No bytecode for variable:" var))) (error "No bytecode for variable:" var)))
(define (statement->code form) (define (statement->code form)
@ -279,10 +284,15 @@
(variable->code (third vform))))] (variable->code (third vform))))]
[(3) (let ([item (assoc (first vform) ternary-primitives)]) [(3) (let ([item (assoc (first vform) ternary-primitives)])
(or item (error "Invalid ternary primitive:" vform)) (or item (error "Invalid ternary primitive:" vform))
(list (second item) (if (eq? (first vform) '#%vector-ref-immed)
(variable->code (second vform)) (list (second item)
(variable->code (third vform)) (variable->code (second vform))
(variable->code (fourth vform))))] (third vform)
(fourth vform))
(list (second item)
(variable->code (second vform))
(variable->code (third vform))
(variable->code (fourth vform)))))]
[else (error "Unsupported form:" vform)]))) [else (error "Unsupported form:" vform)])))
; vim:set sw=2 expandtab: ; vim:set sw=2 expandtab:

65
mods/mod_io.c
View File

@ -9,6 +9,7 @@
#include <sys/stat.h> #include <sys/stat.h>
#include <fcntl.h> #include <fcntl.h>
#include <unistd.h> #include <unistd.h>
#include <sys/param.h>
#include "gc.h" #include "gc.h"
#include "builtin.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_write(interp_state_t *state);
static void bi_posix_lseek(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_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) void mod_io_init(void)
{ {
register_builtin(BI_IO_POSIX_OPEN, make_builtin_fn(bi_posix_open)); 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, 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_DUP, make_builtin_fn(bi_posix_dup));
register_builtin(BI_IO_POSIX_DUP2, make_builtin_fn(bi_posix_dup2)); 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_LSEEK, make_builtin_fn(bi_posix_lseek));
register_builtin(BI_IO_POSIX_CLOSE, make_builtin_fn(bi_posix_close)); 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) 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)); int fd = get_fixnum(CAR(state->argv.value));
value_t str = CAR(_CDR(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; ssize_t result;
int saved_errno; int saved_errno;
release_assert(is_byte_string(str)); release_assert(is_byte_string(str));
release_assert(is_nil(_CDR(_CDDR(state->argv.value))));
if (!is_nil(_CDDR(state->argv.value)))
{
count = get_fixnum(CAR(_CDDR(state->argv.value)));
release_assert(is_nil(_CDR(_CDDR(state->argv.value))));
}
else
{
count = _get_byte_string(str)->size;
}
release_assert((0 <= count) && (count <= _get_byte_string(str)->size)); release_assert((0 <= count) && (count <= _get_byte_string(str)->size));
errno = 0; errno = 0;
@ -221,4 +236,48 @@ static void bi_posix_close(interp_state_t *state)
NIL))); 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: */ /* 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_CLOSE "posix-close"
#define BI_IO_POSIX_CHDIR "posix-chdir"
#define BI_IO_POSIX_GETCWD "posix-getcwd"
void mod_io_init(void); void mod_io_init(void);
#endif #endif

39
reader.c
View File

@ -284,8 +284,8 @@ static value_t read_list(reader_state_t *state)
gc_root_t list_root; gc_root_t list_root;
bool done = false; bool done = false;
register_gc_root(&list_root, NIL);
next_char(state); next_char(state);
register_gc_root(&list_root, NIL);
while (!done) 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) static value_t read_weak_box(reader_state_t *state)
{ {
value_t value; gc_root_t value_root;
next_char(state); next_char(state);
value = read_one_value(state); register_gc_root(&value_root, NIL);
state->weak_list.value = cons(value, state->weak_list.value);
return make_weak_box(value); 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) 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) static void finalize_references(reader_state_t *state)
{ {
bool changed = true; bool changed;
/* We're done when no placeholders link to other placeholders. */ /* We're done when no placeholders link to other placeholders. */
while (changed) do {
{
changed = false; changed = false;
/* Resolve one level of placeholder-to-placeholder links. */ /* Resolve one level of placeholder-to-placeholder links. */
@ -881,7 +884,7 @@ static void finalize_references(reader_state_t *state)
changed = true; changed = true;
} }
} }
} } while (changed);
} }
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, 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) for (int i = 0; i < _get_struct(in_root.value)->nslots; ++i)
{ {
_get_struct(in_root.value)->slots[i] = value_t val = _patch_placeholders(state, _get_struct(in_root.value)->slots[i], &this_seen);
_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); 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); value_t val = _patch_placeholders(state, _get_box(in_root.value)->value, &this_seen);
_get_box(in_root.value)->value = val; _get_box(in_root.value)->value = val;
WRITE_BARRIER(in_root.value);
} }
else if (is_weak_box(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); value_t val = _patch_placeholders(state, _get_weak_box(in_root.value)->value, &this_seen);
_get_weak_box(in_root.value)->value = val; _get_weak_box(in_root.value)->value = val;
WRITE_BARRIER(in_root.value);
} }
else if (is_pair(in_root.value)) else if (is_pair(in_root.value))
{ {
value_t val; value_t val;
val = _patch_placeholders(state, _CAR(in_root.value), &this_seen); val = _patch_placeholders(state, _CAR(in_root.value), &this_seen);
_CAR(in_root.value) = val; _CAR(in_root.value) = val;
WRITE_BARRIER(in_root.value);
val = _patch_placeholders(state, _CDR(in_root.value), &this_seen); val = _patch_placeholders(state, _CDR(in_root.value), &this_seen);
_CDR(in_root.value) = val; _CDR(in_root.value) = val;
WRITE_BARRIER(in_root.value);
} }
else if (is_vector(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); value_t val = _patch_placeholders(state, _get_vector(in_root.value)->elements[i], &this_seen);
_get_vector(in_root.value)->elements[i] = val; _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) static value_t patch_placeholders(reader_state_t *state, value_t in)
{ {
gc_root_t root;
register_gc_root(&root, in);
finalize_references(state); finalize_references(state);
return _patch_placeholders(state, in, NULL);
root.value = _patch_placeholders(state, root.value, NULL);
unregister_gc_root(&root);
return root.value;
} }
static void skip_whitespace(reader_state_t *state) static void skip_whitespace(reader_state_t *state)

29
rosella.c
View File

@ -47,7 +47,7 @@ int main(int argc, char **argv)
} }
#endif #endif
gc_init(1024*1024, 1024*1024, 4*1024*1024); gc_init(8*1024*1024, 4*1024*1024, 64*1024*1024);
builtin_init(); builtin_init();
interpreter_init(); interpreter_init();
#ifdef HAVE_MOD_IO #ifdef HAVE_MOD_IO
@ -55,27 +55,28 @@ int main(int argc, char **argv)
#endif #endif
reader_init(); 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_builtins();
test_weak_boxes_and_wills(); test_weak_boxes_and_wills();
test_garbage_collection(false); 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); 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(); test_reader();
} }
else else
{ {
gc_root_t argv_root; gc_root_t argv_root;
value_t program; gc_root_t program_root;
value_t results; value_t results;
register_gc_root(&argv_root, NIL); register_gc_root(&argv_root, NIL);
register_gc_root(&program_root, NIL);
/* Construct list backward, so that we don't have to reverse it. */ /* Construct list backward, so that we don't have to reverse it. */
for (int i = argc - 1; i >= 2; --i) 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); 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); 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)) 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. ;; Concatenates the list argument(s) into a single new list.
(load "foldr.rls")
(define (append . lsts) (define (append . lsts)
(foldr (lambda (lst base) (foldr (lambda (lst base)
(foldr cons base lst)) (foldr cons base lst))
'() '()
lsts)) 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)) (foldl fn (fn (car lst) init) (cdr lst))
init)) 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))) (foldr fn init (cdr lst)))
init)) 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) (define (map fn lst)
(reverse (foldl (lambda (x lst) (reverse (foldl (lambda (x lst)
(cons (fn x) lst)) (cons (fn x) lst))
'() '()
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 ;; Returns a reversed copy of the given list
(load "foldl.rls") (define (reverse lst [newcdr '()])
(foldl cons newcdr lst))
(define (reverse lst) ; vim:set syntax=scheme sw=2 expandtab:
(foldl cons nil lst))
; vim:set syntax= sw=2 expandtab:

278
src/lib/primitives.rls
View File

@ -1,145 +1,183 @@
; Function forms of built-in primitives ; Function forms of built-in primitives
(define (unbox x) (unbox x)) (define (unbox x) (#%unbox x))
(define (weak-unbox x) (weak-unbox x)) (define (weak-unbox x) (#%weak-unbox x))
(define (car x) (car x)) (define (car x) (#%car x))
(define (cdr x) (cdr x)) (define (cdr x) (#%cdr x))
(define (boolean? x) (boolean? x)) (define (null? x) (#%eq? '() x))
(define (fixnum? x) (fixnum? x)) (define (boolean? x) (#%boolean? x))
(define (box? x) (box? x)) (define (fixnum? x) (#%fixnum? x))
(define (pair? x) (pair? x)) (define (box? x) (#%box? x))
(define (vector? x) (vector? x)) (define (pair? x) (#%pair? x))
(define (byte-string? x) (byte-string? x)) (define (vector? x) (#%vector? x))
(define (struct? x) (struct? x)) (define (byte-string? x) (#%byte-string? x))
(define (float? x) (float? x)) (define (struct? x) (#%struct? x))
(define (builtin? x) (builtin? x)) (define (float? x) (#%float? x))
(define (weak-box? x) (weak-box? x)) (define (builtin? x) (#%builtin? x))
(define (weak-box? x) (#%weak-box? x))
(define (make-box x) (make-box x)) (define (make-box x) (#%make-box x))
(define (make-struct x) (make-struct x)) (define (make-struct x) (#%make-struct x))
(define (make-float x) (make-float x)) (define (make-float x) (#%make-float x))
(define (make-weak-box x) (make-weak-box x)) (define (make-weak-box x) (#%make-weak-box x))
(define (not x) (not x)) (define (not x) (#%not x))
(define (bit-not x) (bit-not x)) (define (bit-not x) (#%bit-not x))
(define (fix- x) (fix- x)) (define (fix-neg x) (#%fix- x))
(define (float- x) (float- x)) (define (float-neg x) (#%float- x))
(define (vector-size x) (vector-size x)) (define (vector-size x) (#%vector-size x))
(define (byte-string-size x) (byte-string-size x)) (define (byte-string-size x) (#%byte-string-size x))
(define (struct-nslots x) (struct-nslots x)) (define (struct-nslots x) (#%struct-nslots x))
(define (struct-type x) (struct-type 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 (acos x) (#%acos x))
(define (asin x) (asin x)) (define (asin x) (#%asin x))
(define (atan x) (atan x)) (define (atan x) (#%atan x))
(define (cos x) (cos x)) (define (cos x) (#%cos x))
(define (sin x) (sin x)) (define (sin x) (#%sin x))
(define (tan x) (tan x)) (define (tan x) (#%tan x))
(define (cosh x) (cosh x)) (define (cosh x) (#%cosh x))
(define (sinh x) (sinh x)) (define (sinh x) (#%sinh x))
(define (tanh x) (tanh x)) (define (tanh x) (#%tanh x))
(define (exp x) (exp x)) (define (exp x) (#%exp x))
(define (frexp x) (frexp x)) (define (frexp x) (#%frexp x))
(define (log x) (log x)) (define (log x) (#%log x))
(define (log10 x) (log10 x)) (define (log10 x) (#%log10 x))
(define (modf x) (modf x)) (define (modf x) (#%modf x))
(define (sqrt x) (sqrt x)) (define (sqrt x) (#%sqrt x))
(define (ceil x) (ceil x)) (define (ceil x) (#%ceil x))
(define (fabs x) (fabs x)) (define (fabs x) (#%fabs x))
(define (floor x) (floor x)) (define (floor x) (#%floor x))
(define (erf x) (erf x)) (define (erf x) (#%erf x))
(define (erfc x) (erfc x)) (define (erfc x) (#%erfc x))
(define (j0 x) (j0 x)) (define (j0 x) (#%j0 x))
(define (j1 x) (j1 x)) (define (j1 x) (#%j1 x))
(define (lgamma x) (lgamma x)) (define (lgamma x) (#%lgamma x))
(define (y0 x) (y0 x)) (define (y0 x) (#%y0 x))
(define (y1 x) (y1 x)) (define (y1 x) (#%y1 x))
(define (asinh x) (asinh x)) (define (asinh x) (#%asinh x))
(define (acosh x) (acosh x)) (define (acosh x) (#%acosh x))
(define (atanh x) (atanh x)) (define (atanh x) (#%atanh x))
(define (cbrt x) (cbrt x)) (define (cbrt x) (#%cbrt x))
(define (logb x) (logb x)) (define (logb x) (#%logb x))
(define (expm1 x) (expm1 x)) (define (expm1 x) (#%expm1 x))
(define (ilogb x) (ilogb x)) (define (ilogb x) (#%ilogb x))
(define (log1p x) (log1p x)) (define (log1p x) (#%log1p x))
(define (normal? x) (normal? x)) (define (normal? x) (#%normal? x))
(define (finite? x) (finite? x)) (define (finite? x) (#%finite? x))
(define (subnormal? x) (subnormal? x)) (define (subnormal? x) (#%subnormal? x))
(define (infinite? x) (infinite? x)) (define (infinite? x) (#%infinite? x))
(define (nan? x) (nan? 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 (cons x y) (#%cons x y))
(define (make-vector x y) (make-vector x y)) (define (make-vector x y) (#%make-vector x y))
(define (make-byte-string x y) (make-byte-string x y)) (define (make-byte-string x y) (#%make-byte-string x y))
(define (vector-ref x y) (vector-ref x y)) (define (vector-ref x y) (#%vector-ref x y))
(define (byte-string-ref x y) (byte-string-ref x y)) (define (byte-string-ref x y) (#%byte-string-ref x y))
(define (struct-ref x y) (struct-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) (#%eq? 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< y x))
(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>= y x))
(define (bit-and x y) (bit-and x y)) (define (bit-and x y) (#%bit-and x y))
(define (bit-or x y) (bit-or x y)) (define (bit-or x y) (#%bit-or x y))
(define (bit-xor x y) (bit-xor 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 (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< y x))
(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 (atan2 x y) (atan2 x y)) (define (atan2 x y) (#%atan2 x y))
(define (pow x y) (pow x y)) (define (pow x y) (#%pow x y))
(define (ldexp x y) (ldexp x y)) (define (ldexp x y) (#%ldexp x y))
(define (fmod x y) (fmod x y)) (define (fmod x y) (#%fmod x y))
(define (hypot x y) (hypot x y)) (define (hypot x y) (#%hypot x y))
(define (jn x y) (jn x y)) (define (jn x y) (#%jn x y))
(define (yn x y) (yn x y)) (define (yn x y) (#%yn x y))
(define (nextafter x y) (nextafter x y)) (define (nextafter x y) (#%nextafter x y))
(define (remainder x y) (remainder x y)) (define (remainder x y) (#%remainder x y))
(define (scalb x y) (scalb 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< y x))
(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 (set-box! x y) (set-box! x y)) (define (set-box! x y) (#%set-box! x y))
(define (set-car! x y) (set-car! x y)) (define (set-car! x y) (#%set-car! x y))
(define (set-cdr! x y) (set-cdr! 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 (if x y z) (#%if 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 (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 (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: ; vim:set sw=2 expandtab:

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

@ -1,95 +1,72 @@
(load "util.rls") (define current-read-eof-handler
(load "hash-table.rls") (make-parameter (lambda () "unexpected-eof")))
(define s:symbol (struct-type 'a)) (define current-read-syntax-error-handler
(define *symbols* (make-hash-table)) (make-parameter (lambda (line col char) (values "syntax-error" line col char))))
(define (make-symbol name) (define (read [port (current-input-port)])
(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)
(let/cc toplevel-return (let/cc toplevel-return
(let ([weak-list '()] (let ([weak-list '()]
[line 1]
[column 0]
[eof? #f] [eof? #f]
current-char) current-char)
(define (read-one-value) (define (read-one-value)
(skip-whitespace) (let ([eof-handler (current-read-eof-handler)])
(cond (call-with-parameters
[eof? (unexpected-eof)] (lambda ()
[(eq? current-char #\#) (skip-whitespace)
(next-char) (cond
(read-special)] [eof? (eof-handler)]
[(eq? current-char #\() [(eq? current-char #\#)
(next-char) (next-char)
(read-list)] (read-special)]
[(or (eq? current-char #\-) [(eq? current-char #\()
(eq? current-char #\+) (next-char)
(decimal-char? current-char)) (read-list #\))]
(read-number)] [(eq? current-char #\[)
[(eq? current-char #\") (next-char)
(read-string)] (read-list #\])]
[(eq? current-char #\|) [(or (eq? current-char #\-)
(next-char) (eq? current-char #\+)
(read-symbol #t)] (decimal-char? current-char))
[(eq? current-char #\') (read-number)]
(next-char) [(eq? current-char #\")
(list 'quote (read-one-value))] (read-string)]
[(eq? current-char #\`) [(eq? current-char #\|)
(next-char) (next-char)
(list 'backquote (read-one-value))] (read-symbol #t)]
[(eq? current-char #\,) [(eq? current-char #\')
(next-char) (next-char)
(if (eq? current-char #\@) (list 'quote (read-one-value))]
(begin [(eq? current-char #\`)
(next-char) (next-char)
(list 'unquote-splicing (read-one-value))) (list 'backquote (read-one-value))]
(list 'unquote (read-one-value)))] [(eq? current-char #\,)
[(symbol-char? current-char) (next-char)
(read-symbol)] (if (eq? current-char #\@)
[else (begin
(unexpected-char)])) (next-char)
(list 'unquote-splicing (read-one-value)))
(list 'unquote (read-one-value)))]
[(symbol-char? current-char)
(read-symbol)]
[else
(syntax-error)]))
(list current-read-eof-handler (lambda () (syntax-error))))))
(define (read-special) (define (read-special)
(cond (cond
[eof? (unexpected-eof)] [eof? (syntax-error)]
[(eq? current-char #\;) [(eq? current-char #\;)
(next-char) (next-char)
(read-one-value) (read-one-value)
(read-one-value)] (read-one-value)]
[(eq? current-char #\!) [(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 () (let skip-until-newline ()
(next-char) (next-char)
(unless (or eof? (eq? current-char #\Newline)) (unless (or eof? (eq? current-char #\Newline))
@ -97,11 +74,11 @@
(read-one-value)] (read-one-value)]
[(memq? current-char '(#\F #\f)) [(memq? current-char '(#\F #\f))
(next-char) (next-char)
(when (symbol-char? current-char) (unexpected-char)) (when (symbol-char? current-char) (syntax-error))
#f] #f]
[(memq? current-char '(#\T #\t)) [(memq? current-char '(#\T #\t))
(next-char) (next-char)
(when (symbol-char? current-char) (unexpected-char)) (when (symbol-char? current-char) (syntax-error))
#t] #t]
[(eq? current-char #\&) [(eq? current-char #\&)
(next-char) (next-char)
@ -111,14 +88,20 @@
(read-vector)] (read-vector)]
[(memq? current-char '(#\S #\s)) [(memq? current-char '(#\S #\s))
(next-char) (next-char)
(unless (eq? current-char #\() (unexpected-char)) (unless (eq? current-char #\() (syntax-error))
(next-char) (next-char)
(read-struct)] (read-struct)]
[(memq? current-char '(#\W #\w)) [(memq? current-char '(#\W #\w))
(next-char) (next-char)
(unless (eq? current-char #\&) (unexpected-char)) (unless (eq? current-char #\&) (syntax-error))
(next-char) (next-char)
(read-weak-box)] (read-weak-box)]
[(eq? current-char #\\)
(next-char)
(read-character)]
[(eq? current-char #\:)
(next-char)
(read-keyword)]
[(memq? current-char '(#\X #\x)) [(memq? current-char '(#\X #\x))
(next-char) (next-char)
(read-fixnum 16)] (read-fixnum 16)]
@ -134,21 +117,21 @@
[(eq? current-char #\@) [(eq? current-char #\@)
(next-char) (next-char)
(freeze! (read-one-value))] (freeze! (read-one-value))]
[else (unexpected-char)])) [else (syntax-error)]))
(define (read-list) (define (read-list [end-char #\)])
(define (read-rest) (define (read-rest)
(skip-whitespace) (skip-whitespace)
(cond (cond
[eof? (unexpected-eof)] [eof? (syntax-error)]
[(eq? current-char #\.) [(eq? current-char #\.)
(next-char) (next-char)
(let ([lstcdr (read-one-value)]) (let ([lstcdr (read-one-value)])
(skip-whitespace) (skip-whitespace)
(unless (eq? current-char #\)) (unexpected-char)) (unless (eq? current-char end-char) (syntax-error))
(next-char) (next-char)
lstcdr)] lstcdr)]
[(eq? current-char #\)) [(eq? current-char end-char)
(next-char) (next-char)
'()] '()]
[else [else
@ -156,8 +139,8 @@
(skip-whitespace) (skip-whitespace)
(cond (cond
[eof? (unexpected-eof)] [eof? (syntax-error)]
[(eq? current-char #\)) [(eq? current-char end-char)
(next-char) (next-char)
'()] '()]
[else [else
@ -165,15 +148,15 @@
(define (read-fixnum [radix #f]) (define (read-fixnum [radix #f])
(let/cc return (let/cc return
(when eof? (unexpected-eof)) (when eof? (syntax-error))
(define neg? (eq? current-char #\-)) (define neg? (eq? current-char #\-))
(when (or neg? (eq? current-char #\+)) (when (or neg? (eq? current-char #\+))
(next-char) (next-char)
(when eof? (unexpected-eof))) (when eof? (syntax-error)))
(unless radix (unless radix
(unless (decimal-char? current-char) (unexpected-char)) (unless (decimal-char? current-char) (syntax-error))
(if (eq? current-char #\0) (if (eq? current-char #\0)
(begin (begin
(next-char) (next-char)
@ -189,14 +172,14 @@
(next-char) (next-char)
(set! radix 2)] (set! radix 2)]
[else [else
(unexpected-char)])) (syntax-error)]))
(set! radix 10))) (set! radix 10)))
; Need at least one digit within this radix ; Need at least one digit within this radix
(when eof? (unexpected-eof)) (when eof? (syntax-error))
(unless (and (alphanumeric-char? current-char) (unless (and (alphanumeric-char? current-char)
(fix< (digit->integer current-char) radix)) (fix< (digit->integer current-char) radix))
(unexpected-char)) (syntax-error))
(let ([pos-val (let iter ([accum 0]) (let ([pos-val (let iter ([accum 0])
(if eof? (if eof?
@ -213,7 +196,7 @@
(let ([negative (cond [(eq? current-char #\-) (next-char) #t] (let ([negative (cond [(eq? current-char #\-) (next-char) #t]
[(eq? current-char #\+) (next-char) #f] [(eq? current-char #\+) (next-char) #f]
[else #f])]) [else #f])])
(unless (decimal-char? current-char) (unexpected-char)) (unless (decimal-char? current-char) (syntax-error))
(let ([radix (if (eq? current-char #\0) (let ([radix (if (eq? current-char #\0)
(begin (begin
(next-char) (next-char)
@ -261,60 +244,60 @@
(define (read-chars [accum '()] [len 0]) (define (read-chars [accum '()] [len 0])
(define (read-one-char) (define (read-one-char)
(define (skip-ws skip-nl?) (define (skip-ws skip-nl?)
(when eof? (unexpected-eof)) (when eof? (syntax-error))
(when (whitespace? current-char) (when (whitespace? current-char)
(let ([ch current-char]) (let ([ch current-char])
(next-char) (next-char)
(if (eq? ch #\Newline) (if (eq? ch #\Newline)
(when skip-nl? (skip-ws #f)) (when skip-nl? (skip-ws #f))
(skip-ws skip-nl?))))) (skip-ws skip-nl?)))))
(when eof? (unexpected-eof)) (when eof? (syntax-error))
(cond (cond
[(eq? current-char end-quote) [(eq? current-char end-quote)
(next-char) (next-char)
#f] #f]
[(eq? current-char #\\) [(eq? current-char #\\)
(next-char) (next-char)
(when eof? (unexpected-eof)) (when eof? (syntax-error))
(cond (cond
[(or (eq? current-char #\o) [(or (eq? current-char #\o)
(octal-char? current-char)) (octal-char? current-char))
(when (eq? current-char #\o) (when (eq? current-char #\o)
(next-char) (next-char)
(when eof? (unexpected-eof)) (when eof? (syntax-error))
(unless (octal-char? current-char) (unexpected-char))) (unless (octal-char? current-char) (syntax-error)))
(let ([total (digit->integer current-char)]) (let ([total (digit->integer current-char)])
(next-char) (next-char)
(when eof? (unexpected-eof)) (when eof? (syntax-error))
(define (add-char) (define (add-char)
(set! total (fix+ (fix* total 8) (set! total (fix+ (fix* total 8)
(digit->integer current-char))) (digit->integer current-char)))
(when (fix> total 255) (unexpected-char)) (when (fix> total 255) (syntax-error))
(next-char) (next-char)
(when eof? (unexpected-eof)) (when eof? (syntax-error))
(octal-char? current-char)) (octal-char? current-char))
(and (octal-char? current-char) (add-char) (add-char)) (and (octal-char? current-char) (add-char) (add-char))
total)] total)]
[(memq? current-char '(#\X #\x)) [(memq? current-char '(#\X #\x))
(next-char) (next-char)
(when eof? (unexpected-eof)) (when eof? (syntax-error))
(unless (hex-char? current-char) (unexpected-char)) (unless (hex-char? current-char) (syntax-error))
(let ([total (digit->integer current-char)]) (let ([total (digit->integer current-char)])
(next-char) (next-char)
(when eof? (unexpected-eof)) (when eof? (syntax-error))
(when (hex-char? current-char) (when (hex-char? current-char)
(set! total (fix+ (fix* total 16) (set! total (fix+ (fix* total 16)
(digit->integer current-char))) (digit->integer current-char)))
(when (fix> total 255) (unexpected-char)) (when (fix> total 255) (syntax-error))
(next-char) (next-char)
(when eof? (unexpected-eof))) (when eof? (syntax-error)))
total)] total)]
[(whitespace? current-char) [(whitespace? current-char)
(skip-ws #t) (skip-ws #t)
(read-one-char)] (read-one-char)]
[(eq? current-char #\;) [(eq? current-char #\;)
(let skip-to-nl+ws () (let skip-to-nl+ws ()
(when eof? (unexpected-eof)) (when eof? (syntax-error))
(if (eq? current-char #\Newline) (if (eq? current-char #\Newline)
(skip-ws #t) (skip-ws #t)
(begin (begin
@ -327,7 +310,7 @@
(#\a . 7) (#\b . 8) (#\t . 9) (#\a . 7) (#\b . 8) (#\t . 9)
(#\n . 10) (#\v . 11) (#\f . 12) (#\n . 10) (#\v . 11) (#\f . 12)
(#\r . 13)))]) (#\r . 13)))])
(unless item (unexpected-char)) (unless item (syntax-error))
(next-char) (next-char)
(cdr item))])] (cdr item))])]
[else [else
@ -371,19 +354,53 @@
(iter (fix+ n 1) (cdr rst)))) (iter (fix+ n 1) (cdr rst))))
struct)) 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) (define (read-chars)
(cond (cond
[eof? [eof?
(if quoted? (if quoted?
(unexpected-eof) (syntax-error)
'())] '())]
[(and quoted? (eq? current-char #\|)) [(and quoted? (eq? current-char #\|))
(next-char) (next-char)
'()] '()]
[(eq? current-char #\\) [(eq? current-char #\\)
(next-char) (next-char)
(when eof? (unexpected-eof)) (when eof? (syntax-error))
(let ([ch current-char]) (let ([ch current-char])
(next-char) (next-char)
(cons ch (read-chars)))] (cons ch (read-chars)))]
@ -393,14 +410,15 @@
(cons ch (read-chars)))] (cons ch (read-chars)))]
[else '()])) [else '()]))
(let* ([chars (read-chars)] (let* ([chars (read-chars)])
[len (list-length chars)] (convert-fn (list->string chars))))
[str (make-byte-string len #\Null)])
(let iter ([n 0] [rst chars]) (define (read-keyword)
(when (fix< n len) (if (eq? current-char #\|)
(byte-string-set! str n (car rst)) (begin
(iter (fix+ n 1) (cdr rst)))) (next-char)
(intern str))) (read-symbol #t string->keyword))
(read-symbol #f string->keyword)))
(define (skip-whitespace) (define (skip-whitespace)
(unless eof? (unless eof?
@ -412,38 +430,36 @@
(let skip-until-newline () (let skip-until-newline ()
(let ([ch current-char]) (let ([ch current-char])
(next-char) (next-char)
(unless (eq? ch #\Newline) (if (eq? ch #\Newline)
(skip-until-newline))))]))) (skip-whitespace)
(skip-until-newline))))])))
(define (next-char) (define (next-char)
(if eof? (unless eof?
#f (let/cc return
(let* ([str (make-byte-string 1 0)] (call-with-parameters
[res (posix-read fd str 1)]) (lambda ()
(if (eq? res 1) (set! current-char (read-char port)))
(let ([ch (byte-string-ref str 0)]) (list current-port-eof-handler
(set! current-char ch) (lambda ()
(if (fix= ch #\Newline) (set! eof? #t)
(begin (set! current-char #f)
(set! line (fix+ line 1)) (return)))))))
(set! column 0))
(set! column (fix+ column 1)))
ch)
(begin
(set! current-char #f)
(set! eof? #t)
#f)))))
(define (unexpected-eof) (define (syntax-error)
(toplevel-return "unexpected-eof")) (call-with-values
(lambda ()
(define (unexpected-char) (call-with-values
(toplevel-return "unexpected-char" current-char (list line column))) (lambda () (port-position port))
(lambda (byte line column)
((current-read-syntax-error-handler) line column current-char))))
toplevel-return))
(next-char) (next-char)
(values (let ([val (read-one-value)])
(read-one-value) (unless eof?
current-char)))) (port-unread port (make-byte-string 1 current-char)))
val))))
(define (whitespace? ch) (define (whitespace? ch)
(memq? ch '(#\Space #\Tab #\VTab #\Page #\Newline))) (memq? ch '(#\Space #\Tab #\VTab #\Page #\Newline)))
@ -474,19 +490,8 @@
(define (symbol-char? ch) (define (symbol-char? ch)
(or (alphanumeric-char? ch) (or (alphanumeric-char? ch)
(memq? 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) (define (digit->integer ch)
(cond (cond
@ -495,6 +500,4 @@
[(downcase-char? ch) (fix+ 10 (fix- ch #\a))] [(downcase-char? ch) (fix+ 10 (fix- ch #\a))]
[else #f])) [else #f]))
(read-from-fd 0)
; vim:set syntax=scheme sw=2 expandtab: ; 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 "lib/primitives.rls")
(load "hash-table.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)) (define ht (make-hash-table))
@ -8,24 +11,17 @@
(fn (car lst)) (fn (car lst))
(foreach fn (cdr 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))) (foreach insert '(47 32 18 90 46 38 21 93 49 10 92 34 71)))
(values (values->list
(hash-table-remove ht 92) (map (lambda (x) (list x (hash-table-remove ht x)))
(hash-table-remove ht 71) '(92 71 49 46 47 21 30 34 71 18 32 92 90 10 21 38 18 93)))
(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)
)
; vim:set syntax=scheme sw=2 expandtab: ; 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: