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

Convert tail-call parameters to a byte-string. 

Add special variables for keyword arguments & values.
Add support for keyword arguments to (simplify-apply).
Implement full string parsing in src/reader.rls.
TODO: Support keywords in (simplify-lambda) and writer.
This commit is contained in:
Jesse D. McDonald 2010-05-27 22:48:03 -05:00
parent a9427d2ec5
commit e1662ca4b8
31 changed files with 443 additions and 550 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
builtin.c
View File

@ -192,14 +192,11 @@ static void bi_string_to_number(interp_state_t *state)
free(str);
if ((*end == '\0') && (_get_fixnum(fixnum_value(num)) == num))
rval = cons(fixnum_value(num), NIL);
rval = fixnum_value(num);
else
rval = cons(FALSE_VALUE, NIL);
rval = FALSE_VALUE;
state->lambda.value = state->k.value;
state->argv.value = rval;
state->ctx.value = FALSE_VALUE;
state->k.value = FALSE_VALUE;
interp_return_values(state, cons(rval, NIL));
}
/* vim:set sw=2 expandtab: */

10
builtin.h
View File

@ -33,20 +33,14 @@
#define TEMPLATE_SLOT_FRAME_VARS 2
#define TEMPLATE_SLOT_BYTE_CODE 3
#define TEMPLATE_SLOT_TAIL_CALL 4
#define TEMPLATE_SLOT_ARG_LIST 5
#define TEMPLATE_SLOT_CONTEXT 6
#define TEMPLATE_SLOT_CONTINUATION 7
#define TEMPLATE_SLOTS 8
#define TEMPLATE_SLOTS 5
#define LAMBDA_SLOT_GLOBAL_VARS 0
#define LAMBDA_SLOT_INSTANCE_VARS 1
#define LAMBDA_SLOT_FRAME_VARS 2
#define LAMBDA_SLOT_BYTE_CODE 3
#define LAMBDA_SLOT_TAIL_CALL 4
#define LAMBDA_SLOT_ARG_LIST 5
#define LAMBDA_SLOT_CONTEXT 6
#define LAMBDA_SLOT_CONTINUATION 7
#define LAMBDA_SLOTS 8
#define LAMBDA_SLOTS 5
value_t get_structure_type(void);
value_t get_template_type(void);

18
doc/bytecode.txt
View File

@ -164,9 +164,11 @@ in:
gN (00NNNNNN) [global, N < 64]
iN (01NNNNNN) [instance, N < 64]
fN (1NNNNNNN) [frame, N < 120]
-- (11111NNN) [reserved, N < 4]
self (11111100) [current lambda]
argv (11111101) [argument list]
-- (1111100N) [reserved, N < 2]
self (11111010) [current lambda]
argv (11111011) [argument list]
kw-args (11111100) [keyword arguments] (sorted)
kw-vals (11111101) [keyword values] (match kw-args)
ctx (11111110) [dynamic context]
k (11111111) [continuation]
@ -178,10 +180,7 @@ lambda:[
instance: vector of immutable values (i0..iN); shared between frames (calls)
frame: number of frame variables; initially #<undefined>
code: byte-string containing sequence of 4-byte instruction words
tail-call: in-ref of lambda to tail-call
arguments: in-ref of argument list to pass to tail-call
context: in-ref of dynamic context to pass to tail-call
continuation: in-ref of continuation to pass to tail-call
tail-call: byte-string of in-refs: (target argv kw-args kw-vals ctx k)
]
template:[
@ -189,10 +188,7 @@ template:[
instance: byte-string of in-refs. to parent instance/frame slots
frame: copied verbatim
code: linked
tail-call: copied verbatim
arguments: copied verbatim
context: copied verbatim
continuation: copied verbatim
tail-call: linked
]
Protocol:

49
interp.c
View File

@ -226,9 +226,6 @@ static value_t make_lambda(interp_state_t *state, value_t templ)
ls->slots[LAMBDA_SLOT_FRAME_VARS] = ts->slots[TEMPLATE_SLOT_FRAME_VARS];
ls->slots[LAMBDA_SLOT_BYTE_CODE] = ts->slots[TEMPLATE_SLOT_BYTE_CODE];
ls->slots[LAMBDA_SLOT_TAIL_CALL] = ts->slots[TEMPLATE_SLOT_TAIL_CALL];
ls->slots[LAMBDA_SLOT_ARG_LIST] = ts->slots[TEMPLATE_SLOT_ARG_LIST];
ls->slots[LAMBDA_SLOT_CONTINUATION] = ts->slots[TEMPLATE_SLOT_CONTINUATION];
ls->slots[LAMBDA_SLOT_CONTEXT] = ts->slots[TEMPLATE_SLOT_CONTEXT];
WRITE_BARRIER(lambda_root.value);
l_inst = _get_vector(ls->slots[LAMBDA_SLOT_INSTANCE_VARS]);
@ -269,6 +266,10 @@ static void run_byte_code(interp_state_t *state)
register_gc_root(&bc_root, _LAMBDA_SLOT(state->lambda.value, BYTE_CODE));
if (bc_root.value != FALSE_VALUE)
{
release_assert((get_byte_string(bc_root.value)->size % 4) == 0);
for (size_t offset = 0; (offset+3) < _get_byte_string(bc_root.value)->size; offset += 4)
{
uint8_t bytes[4];
@ -298,19 +299,25 @@ static void run_byte_code(interp_state_t *state)
break;
}
}
break_for_loop:
break_for_loop:;
}
unregister_gc_root(&bc_root);
}
static void perform_tail_call(interp_state_t *state)
{
gc_root_t new_lambda, new_argv, new_ctx, new_k;
gc_root_t new_lambda, new_argv, new_kw_args, new_kw_vals, new_ctx, new_k;
value_t tail_call = _LAMBDA_SLOT(state->lambda.value, TAIL_CALL);
register_gc_root(&new_lambda, get_input(state, get_fixnum(_LAMBDA_SLOT(state->lambda.value, TAIL_CALL))));
register_gc_root(&new_argv, get_input(state, get_fixnum(_LAMBDA_SLOT(state->lambda.value, ARG_LIST))));
register_gc_root(&new_ctx, get_input(state, get_fixnum(_LAMBDA_SLOT(state->lambda.value, CONTEXT))));
register_gc_root(&new_k, get_input(state, get_fixnum(_LAMBDA_SLOT(state->lambda.value, CONTINUATION))));
release_assert(get_byte_string(tail_call)->size == 6);
register_gc_root(&new_lambda, get_input(state, _get_byte_string(tail_call)->bytes[0]));
register_gc_root(&new_argv, get_input(state, _get_byte_string(tail_call)->bytes[1]));
register_gc_root(&new_kw_args, get_input(state, _get_byte_string(tail_call)->bytes[2]));
register_gc_root(&new_kw_vals, get_input(state, _get_byte_string(tail_call)->bytes[3]));
register_gc_root(&new_ctx, get_input(state, _get_byte_string(tail_call)->bytes[4]));
register_gc_root(&new_k, get_input(state, _get_byte_string(tail_call)->bytes[5]));
/* If new lambda or continuation is a template, instantiate it here */
new_lambda.value = make_lambda(state, new_lambda.value);
@ -319,11 +326,15 @@ static void perform_tail_call(interp_state_t *state)
/* Transfer control to new function */
state->lambda.value = new_lambda.value;
state->argv.value = new_argv.value;
state->kw_args.value = new_kw_args.value;
state->kw_vals.value = new_kw_vals.value;
state->ctx.value = new_ctx.value;
state->k.value = new_k.value;
unregister_gc_root(&new_lambda);
unregister_gc_root(&new_argv);
unregister_gc_root(&new_kw_args);
unregister_gc_root(&new_kw_vals);
unregister_gc_root(&new_ctx);
unregister_gc_root(&new_k);
}
@ -547,11 +558,15 @@ static value_t get_input(const interp_state_t *state, fixnum_t var)
release_assert(var < state->nframe);
return vec->elements[var];
}
/* 248 ... 251 are reserved */
case 252:
/* 248 ... 249 are reserved */
case 250:
return state->lambda.value;
case 253:
case 251:
return state->argv.value;
case 252:
return state->kw_args.value;
case 253:
return state->kw_vals.value;
case 254:
return state->ctx.value;
case 255:
@ -578,9 +593,12 @@ static void register_state(interp_state_t *state, value_t lambda, value_t argv)
{
register_gc_root(&state->lambda, lambda);
register_gc_root(&state->argv, argv);
register_gc_root(&state->frame, make_vector(120, UNDEFINED));
register_gc_root(&state->kw_args, NIL);
register_gc_root(&state->kw_vals, NIL);
register_gc_root(&state->ctx, FALSE_VALUE);
register_gc_root(&state->k, FALSE_VALUE);
register_gc_root(&state->frame, make_vector(120, UNDEFINED));
register_gc_root(&state->in1, FALSE_VALUE);
register_gc_root(&state->in2, FALSE_VALUE);
register_gc_root(&state->in3, FALSE_VALUE);
@ -590,9 +608,12 @@ static void unregister_state(interp_state_t *state)
{
unregister_gc_root(&state->lambda);
unregister_gc_root(&state->argv);
unregister_gc_root(&state->frame);
unregister_gc_root(&state->kw_args);
unregister_gc_root(&state->kw_vals);
unregister_gc_root(&state->ctx);
unregister_gc_root(&state->k);
unregister_gc_root(&state->frame);
unregister_gc_root(&state->in1);
unregister_gc_root(&state->in2);
unregister_gc_root(&state->in3);

46
interp.h
View File

@ -8,6 +8,8 @@ typedef struct interp_state
gc_root_t lambda;
gc_root_t frame;
gc_root_t argv;
gc_root_t kw_args;
gc_root_t kw_vals;
gc_root_t ctx;
gc_root_t k;
gc_root_t in1;
@ -19,5 +21,49 @@ typedef struct interp_state
void interpreter_init(void);
value_t run_interpreter(value_t lambda, value_t argv);
static inline void interp_call
(
interp_state_t *state,
value_t lambda,
value_t argv,
value_t kw_args,
value_t kw_vals,
value_t k
)
{
state->lambda.value = lambda;
state->argv.value = argv;
state->kw_args.value = kw_args;
state->kw_vals.value = kw_vals;
/* ctx is unchanged by normal calls */
state->k.value = k;
}
static inline void interp_tail_call
(
interp_state_t *state,
value_t lambda,
value_t argv,
value_t kw_args,
value_t kw_vals
)
{
state->lambda.value = lambda;
state->argv.value = argv;
state->kw_args.value = kw_args;
state->kw_vals.value = kw_vals;
/* ctx and k are unchanged by tail-calls */
}
static inline void interp_return_values(interp_state_t *state, value_t values)
{
value_t old_k = state->k.value;
state->ctx.value = FALSE_VALUE;
state->k.value = FALSE_VALUE;
interp_tail_call(state, old_k, values, NIL, NIL);
}
#endif
/* vim:set sw=2 expandtab: */

2
libcompiler/primitives.scm
View File

@ -169,7 +169,7 @@
(string->uninterned-symbol (string-append "#%f" (number->string i)))))
(define special-variables
'(#%nil #%self #%argv #%ctx #%k))
'(#%nil #%self #%argv #%kw-args #%kw-vals #%ctx #%k))
(define (global-variable? var) (and (memq var global-variables) #t))
(define (instance-variable? var) (and (memq var instance-variables) #t))

70
libcompiler/simplifier.scm
View File

@ -264,7 +264,7 @@
[,true-fn (lambda () ,true-form)]
[,false-fn (lambda () ,false-form)])
(let ([,next-fn (#%if ,cond-val ,true-fn ,false-fn)])
(#%apply ,next-fn #%nil))))))))
(#%apply ,next-fn #%nil #%nil #%nil))))))))
; (lambda (required... [optional default-expr]... . rest) bodyexpr...)
; => (lambda argv
@ -412,26 +412,26 @@
(match subform
[(? simple-value?)
`((#%set! ,argv (#%cons ,subform #%nil))
(#%tail-call ,k ,argv #f #f))]
[`(#%apply ,x ,y)
`((#%tail-call ,x ,y ,ctx ,k))]
(#%tail-call ,k ,argv #%nil #%nil #f #f))]
[`(#%apply . ,sv)
`((#%tail-call ,@sv ,ctx ,k))]
[`(#%call/cc ,x)
`((#%set! ,argv (#%cons #%k #%nil))
(#%tail-call ,x ,argv ,ctx #%k))]
(#%tail-call ,x ,argv #%nil #%nil ,ctx #%k))]
[`(#%values . ,simple-vals)
`((#%set! ,argv #%nil)
,@(map (lambda (sv) `(#%set! ,argv (#%cons ,sv ,argv)))
(reverse simple-vals))
(#%tail-call ,k ,argv #f #f))]
(#%tail-call ,k ,argv #%nil #%nil #f #f))]
[(? value-form?)
`(,(simplify-set! `(set! ,argv ,subform))
(#%set! ,argv (#%cons ,argv #%nil))
(#%tail-call ,k ,argv #f #f))]
(#%tail-call ,k ,argv #%nil #%nil #f #f))]
[`(#%tail-call . ,_)
`(,subform)]
[_
`(,subform
(#%tail-call ,k #%nil #f #f))])))
(#%tail-call ,k #%nil #%nil #%nil #f #f))])))
'()
(cddr flat-bind))))
@ -439,28 +439,28 @@
(define flat-bind (flatten-binds nested-bind))
(define (cps-prepend subform after)
(match subform
[`(#%set! ,v (#%value-list (#%apply ,x ,y)))
[`(#%set! ,v (#%value-list (#%apply . ,sv)))
(let ([k (gensym)])
`((#%bind (,k)
(#%set! ,k ,(simplify-form
`(lambda ,v
,@after)))
(#%tail-call ,x ,y ,ctx ,k))))]
[`(#%set! ,v (#%apply ,x ,y))
(#%tail-call ,@sv ,ctx ,k))))]
[`(#%set! ,v (#%apply . ,sv))
(let ([k (gensym)])
`((#%bind (,k)
(#%set! ,k ,(simplify-form
`(lambda (,v . ,(gensym))
,@after)))
(#%tail-call ,x ,y ,ctx ,k))))]
[(or `(#%value-list (#%apply ,x ,y))
`(#%apply ,x ,y))
(#%tail-call ,@sv ,ctx ,k))))]
[(or `(#%value-list (#%apply . ,sv))
`(#%apply . ,sv))
(let ([k (gensym)])
`((#%bind (,k)
(#%set! ,k ,(simplify-form
`(lambda ,(gensym)
,@after)))
(#%tail-call ,x ,y ,ctx ,k))))]
(#%tail-call ,@sv ,ctx ,k))))]
[`(#%set! ,v (#%value-list (#%call/cc ,x)))
(let ([k (gensym)]
[k-argv (gensym)])
@ -469,7 +469,7 @@
`(lambda ,v
,@after)))
(#%set! ,k-argv (#%cons ,k #%nil))
(#%tail-call ,x ,k-argv ,ctx ,k))))]
(#%tail-call ,x ,k-argv #%nil #%nil ,ctx ,k))))]
[`(#%set! ,v (#%call/cc ,x))
(let ([k (gensym)]
[k-argv (gensym)])
@ -478,7 +478,7 @@
`(lambda (,v . ,(gensym))
,@after)))
(#%set! ,k-argv (#%cons ,k #%nil))
(#%tail-call ,x ,k-argv ,ctx ,k))))]
(#%tail-call ,x ,k-argv #%nil #%nil ,ctx ,k))))]
[(or `(#%value-list (#%call/cc ,x))
`(#%call/cc ,x))
(let ([k (gensym)]
@ -488,7 +488,7 @@
`(lambda ,(gensym)
,@after)))
(#%set! ,k-argv (#%cons ,k #%nil))
(#%tail-call ,x ,k-argv ,ctx ,k))))]
(#%tail-call ,x ,k-argv #%nil #%nil ,ctx ,k))))]
; keep all other forms with side-effects as-is
[(? statement-form?) (cons subform after)]
; discard any form without side-effects
@ -550,19 +550,29 @@
(define (simplify-apply fn-expr arg-exprs)
(define fn-var (gensym))
(define argv (gensym))
(define arguments
(foldr (lambda (expr args)
(if (null? args)
(cons (list argv expr) args)
(if (literal-value? expr)
(cons (list expr #f) args)
(cons (list (gensym) expr) args))))
'()
arg-exprs))
(define kw-vals (gensym))
(define-values (bindings plain-args keywords)
(let iter ([arg-exprs arg-exprs])
(match arg-exprs
[`(,base-expr)
(values `([,argv ,base-expr]) '() '())]
[`(,(? keyword? kw) ,expr . ,rst)
(let-values ([(bnd args kws) (iter rst)]
[(x) (gensym)])
(values (cons `[,x ,expr] bnd) args (cons (cons kw x) kws)))]
[`(,expr . ,(and rst `(,_ . ,_)))
(let-values ([(bnd args kws) (iter rst)]
[(x) (gensym)])
(values (cons `[,x ,expr] bnd) (cons x args) kws))])))
(define sorted-kws (sort keywords keyword<? #:key car))
(simplify-form
`(let ([,fn-var ,fn-expr] ,@(filter second arguments))
`(let ([,fn-var ,fn-expr] ,@bindings ,kw-vals)
,@(map (lambda (x) `(#%set! ,argv (#%cons ,x ,argv)))
(map first (reverse (drop-right arguments 1))))
(#%apply ,fn-var ,argv))))
(reverse plain-args))
,(simplify-form `(set! ,kw-vals (list ,@(map cdr sorted-kws))))
(#%apply ,fn-var ,argv ',(map car sorted-kws) ,kw-vals))))
; vim:set sw=2 expandtab:

21
libcompiler/writer.scm
View File

@ -59,10 +59,17 @@
(define (write-rla-bytecode+tail-call forms port)
(define (write-tail-call tc-form)
(req-new-line port) (write-hex-byte (variable->code (second tc-form)) port)
(req-new-line port) (write-hex-byte (variable->code (third tc-form)) port)
(req-new-line port) (write-hex-byte (variable->code (fourth tc-form)) port)
(req-new-line port) (write-hex-byte (variable->code (fifth tc-form)) port))
(req-new-line port)
(write-char #\" port)
(for ([var (in-list (cdr tc-form))])
(write-hex-char (variable->code var) port))
(write-char #\" port)
(when (verbose-rla?)
(write-char #\; port)
(for ([var (in-list (cdr tc-form))])
(write-char #\Space port)
(write var port))))
(let-values ([(line col pos) (port-next-location port)])
(parameterize ([current-indent col])
(write-char #\" port)
@ -146,7 +153,7 @@
(write (char->integer value) port)]
[(string? value)
(write-rla-string value port)]
[(and (pair? value) (memq (first value) '(#%lambda #%template)))
[(and (pair? value) (memq (car value) '(#%lambda #%template)))
(write-rla-function value port)]
[(vector? value)
(write-string "#(" port)
@ -182,8 +189,8 @@
(and index (+ #x40 index)))
(let ([index (find var frame-variables)])
(and index (+ #x80 index)))
(let ([index (find var '(#%self #%argv #%ctx #%k))])
(and index (+ #xfc index)))
(let ([index (find var '(#%self #%argv #%kw-args #%kw-vals #%ctx #%k))])
(and index (+ #xfa index)))
(error "No bytecode for variable:" var)))
(define (statement->code form)

56
mods/mod_io.c
View File

@ -41,19 +41,6 @@ void mod_io_init(void)
register_builtin(BI_IO_POSIX_CLOSE, make_builtin_fn(bi_posix_close));
}
static void simple_return(interp_state_t *state, value_t rval)
{
state->lambda.value = state->k.value;
state->argv.value = rval;
state->k.value = FALSE_VALUE;
state->ctx.value = FALSE_VALUE;
}
static void simple_return2(interp_state_t *state, value_t v1, value_t v2)
{
simple_return(state, cons(v1, cons(v2, NIL)));
}
static void bi_posix_open(interp_state_t *state)
{
char *pathname;
@ -85,8 +72,10 @@ static void bi_posix_open(interp_state_t *state)
release_assert(is_valid_fixnum(fd));
release_assert(is_valid_fixnum(saved_errno));
simple_return2(state, (fd >= 0) ? fixnum_value(fd) : FALSE_VALUE,
fixnum_value(saved_errno));
interp_return_values(state,
cons((fd >= 0) ? fixnum_value(fd) : FALSE_VALUE,
cons(fixnum_value(saved_errno),
NIL)));
}
//static void bi_posix_openat(interp_state_t *state) {}
@ -106,8 +95,10 @@ static void bi_posix_dup(interp_state_t *state)
release_assert(is_valid_fixnum(newfd));
release_assert(is_valid_fixnum(saved_errno));
simple_return2(state, (newfd >= 0) ? fixnum_value(newfd) : FALSE_VALUE,
fixnum_value(saved_errno));
interp_return_values(state,
cons((newfd >= 0) ? fixnum_value(newfd) : FALSE_VALUE,
cons(fixnum_value(saved_errno),
NIL)));
}
static void bi_posix_dup2(interp_state_t *state)
@ -125,8 +116,10 @@ static void bi_posix_dup2(interp_state_t *state)
release_assert(is_valid_fixnum(newfd));
release_assert(is_valid_fixnum(saved_errno));
simple_return2(state, (newfd >= 0) ? fixnum_value(newfd) : FALSE_VALUE,
fixnum_value(saved_errno));
interp_return_values(state,
cons((newfd >= 0) ? fixnum_value(newfd) : FALSE_VALUE,
cons(fixnum_value(saved_errno),
NIL)));
}
static void bi_posix_read(interp_state_t *state)
@ -148,8 +141,10 @@ static void bi_posix_read(interp_state_t *state)
release_assert(is_valid_fixnum(result));
release_assert(is_valid_fixnum(saved_errno));
simple_return2(state, (result >= 0) ? fixnum_value(result) : FALSE_VALUE,
fixnum_value(saved_errno));
interp_return_values(state,
cons((result >= 0) ? fixnum_value(result) : FALSE_VALUE,
cons(fixnum_value(saved_errno),
NIL)));
}
static void bi_posix_write(interp_state_t *state)
@ -171,8 +166,10 @@ static void bi_posix_write(interp_state_t *state)
release_assert(is_valid_fixnum(result));
release_assert(is_valid_fixnum(saved_errno));
simple_return2(state, (result >= 0) ? fixnum_value(result) : FALSE_VALUE,
fixnum_value(saved_errno));
interp_return_values(state,
cons((result >= 0) ? fixnum_value(result) : FALSE_VALUE,
cons(fixnum_value(saved_errno),
NIL)));
}
static void bi_posix_lseek(interp_state_t *state)
@ -193,12 +190,16 @@ static void bi_posix_lseek(interp_state_t *state)
if (result == (off_t)(-1))
{
simple_return2(state, FALSE_VALUE, fixnum_value(saved_errno));
interp_return_values(state, cons(FALSE_VALUE, cons(fixnum_value(saved_errno), NIL)));
}
else
{
release_assert((result >= 0) && (result <= FIXNUM_MAX));
simple_return2(state, fixnum_value(result), fixnum_value(saved_errno));
interp_return_values(state,
cons(fixnum_value(result),
cons(fixnum_value(saved_errno),
NIL)));
}
}
@ -214,7 +215,10 @@ static void bi_posix_close(interp_state_t *state)
result = close(fd);
saved_errno = errno;
simple_return2(state, boolean_value(!result), fixnum_value(saved_errno));
interp_return_values(state,
cons(boolean_value(!result),
cons(fixnum_value(saved_errno),
NIL)));
}
/* vim:set sw=2 expandtab: */

10
src/examples/annotated-structs.rla
View File

@ -41,18 +41,12 @@
#()
0
""
0xff
0x01
0x02
0x02
"\xff\x01\x00\x00\x02\x02"
)
)
#()
0
""
0x02
0xfd
0xfe
0xff
"\x02\xfd\xfe\xff"
)
; vim:set syntax= sw=3 expandtab:

10
src/examples/factorial.rla
View File

@ -21,18 +21,12 @@
"\xfe\xff" ; ctx k
0
""
0x01 ; g1
0xfd ; argv
0x40 ; i0
0x41 ; i1
"\x01\xfb\x00\x00\x40\x41"
)
)
#()
0
""
0x01 ; g1
0xfd ; argv
0xfe ; ctx
0x02 ; g2
"\x01\xfb\x00\x00\xfe\x02"
)
; vim:set syntax= sw=2 expandtab:

15
src/examples/test-and.rla
View File

@ -8,19 +8,16 @@
#(
#i"../lib/primitive/and.rla"
(
#S(#="lambda" #(( 3) #f) #() 0 "" 0xff 0x01 0x02 0x02)
#S(#="lambda" #((#t) #f) #() 0 "" 0xff 0x01 0x02 0x02)
#S(#="lambda" #(( 4) #f) #() 0 "" 0xff 0x01 0x02 0x02)
#S(#="lambda" #((#f) #f) #() 0 "" 0xff 0x01 0x02 0x02)
#S(#="lambda" #(( 5) #f) #() 0 "" 0xff 0x01 0x02 0x02)
#S(#="lambda" #(( 3) #f) #() 0 "" "\xff\x01\x00\x00\x02\x02")
#S(#="lambda" #((#t) #f) #() 0 "" "\xff\x01\x00\x00\x02\x02")
#S(#="lambda" #(( 4) #f) #() 0 "" "\xff\x01\x00\x00\x02\x02")
#S(#="lambda" #((#f) #f) #() 0 "" "\xff\x01\x00\x00\x02\x02")
#S(#="lambda" #(( 5) #f) #() 0 "" "\xff\x01\x00\x00\x02\x02")
)
)
#()
0
""
0x01 ; g1
0x02 ; g2
0xfe ; ctx
0xff ; k
"\x01\x02\x00\x00\xfe\xff"
)
; vim:set syntax= sw=2 expandtab:

5
src/examples/test-append.rla
View File

@ -8,9 +8,6 @@
#()
0
""
0x01 ; g1
0x02 ; g2
0xfe ; ctx
0xff ; k
"\x01\x02\x00\x00\xfe\xff"
)
; vim:set syntax= sw=2 expandtab:

14
src/examples/test-foldl.rla
View File

@ -10,15 +10,12 @@
#(#f)
#()
2
"\x00\x80\x03\xfd\; (set! f0 (car argv))
\x00\x81\x04\xfd\; (set! f1 (cdr argv))
"\x00\x80\x03\xfb\; (set! f0 (car argv))
\x00\x81\x04\xfb\; (set! f1 (cdr argv))
\x00\x81\x03\x81\; (set! f1 (car f1))
\x08\x80\x80\x81\; (set! f0 (fix+ f0 f1))
\x02\x80\x80\x00"; (set! f0 (cons f0 nil))
0xff ; k
0x80 ; f0
0x01 ; g1
0x01 ; g1
"\xff\x80\x00\x00\x01\x01"
)
0
(2 3 4 5)
@ -27,9 +24,6 @@
#()
0
""
0x01 ; g1
0x02 ; g2
0xfe ; ctx
0xff ; k
"\x01\x02\x00\x00\xfe\xff"
)
; vim:set syntax= sw=2 expandtab:

14
src/examples/test-foldr.rla
View File

@ -10,15 +10,12 @@
#(#f)
#()
2
"\x00\x80\x03\xfd\; (set! f0 (car argv))
\x00\x81\x04\xfd\; (set! f1 (cdr argv))
"\x00\x80\x03\xfb\; (set! f0 (car argv))
\x00\x81\x04\xfb\; (set! f1 (cdr argv))
\x00\x81\x03\x81\; (set! f1 (car f1))
\x08\x80\x80\x81\; (set! f0 (fix+ f0 f1))
\x02\x80\x80\x00"; (set! f0 (cons f0 nil))
0xff ; k
0x80 ; f0
0x01 ; g1
0x01 ; g1
"\xff\x80\x00\x00\x01\x01"
)
0
(2 3 4 5)
@ -27,9 +24,6 @@
#()
0
""
0x01 ; g1
0x02 ; g2
0xfe ; ctx
0xff ; k
"\x01\x02\x00\x00\xfe\xff"
)
; vim:set syntax= sw=2 expandtab:

5
src/examples/test-list.rla
View File

@ -8,9 +8,6 @@
#()
0
""
0x01 ; g1
0x02 ; g2
0xfe ; ctx
0xff ; k
"\x01\x02\x00\x00\xfe\xff"
)
; vim:set syntax= sw=2 expandtab:

5
src/examples/test-map.rla
View File

@ -11,9 +11,6 @@
#()
0
""
0x01 ; g1
0x02 ; g2
0xfe ; ctx
0xff ; k
"\x01\x02\x00\x00\xfe\xff"
)
; vim:set syntax= sw=2 expandtab:

15
src/examples/test-or.rla
View File

@ -8,19 +8,16 @@
#(
#i"../lib/primitive/or.rla"
(
#S(#="lambda" #((#f) #f) #() 0 "" 0xff 0x01 0x02 0x02)
#S(#="lambda" #(( 3) #f) #() 0 "" 0xff 0x01 0x02 0x02)
#S(#="lambda" #((#f) #f) #() 0 "" 0xff 0x01 0x02 0x02)
#S(#="lambda" #((#t) #f) #() 0 "" 0xff 0x01 0x02 0x02)
#S(#="lambda" #((#f) #f) #() 0 "" 0xff 0x01 0x02 0x02)
#S(#="lambda" #((#f) #f) #() 0 "" "\xff\x01\x00\x00\x02\x02")
#S(#="lambda" #(( 3) #f) #() 0 "" "\xff\x01\x00\x00\x02\x02")
#S(#="lambda" #((#f) #f) #() 0 "" "\xff\x01\x00\x00\x02\x02")
#S(#="lambda" #((#t) #f) #() 0 "" "\xff\x01\x00\x00\x02\x02")
#S(#="lambda" #((#f) #f) #() 0 "" "\xff\x01\x00\x00\x02\x02")
)
)
#()
0
""
0x01 ; g1
0x02 ; g2
0xfe ; ctx
0xff ; k
"\x01\x02\x00\x00\xfe\xff"
)
; vim:set syntax= sw=2 expandtab:

5
src/examples/test-reverse.rla
View File

@ -8,9 +8,6 @@
#()
0
""
0x01 ; g1
0x02 ; g2
0xfe ; ctx
0xff ; k
"\x01\x02\x00\x00\xfe\xff"
)
; vim:set syntax= sw=2 expandtab:

24
src/lib/math/fact.rla
View File

@ -17,10 +17,7 @@
#()
0
""
0xff ; k
0x01 ; g1
0x02 ; g2
0x02 ; g2
"\xff\x01\x00\x00\x02\x02"
)
#S(#="template"
; (let [n]
@ -39,13 +36,10 @@
#(#f)
"\x40\xff" ; i0 k
1
"\x00\x80\x03\xfd\; (set! f0 (car argv))
"\x00\x80\x03\xfb\; (set! f0 (car argv))
\x0a\x80\x40\x80\; (set! f0 (fix* i0 f0))
\x02\x80\x80\x00"; (set! f0 (cons f0 nil))
0x41 ; i1
0x80 ; f0
0x01 ; g1
0x01 ; g1
"\x41\x80\x00\x00\x01\x01"
)
#=0 ; fact
)
@ -53,20 +47,14 @@
1
"\x09\x80\x40\x01\; (set! f0 (fix- i0 g1))
\x02\x80\x80\x00"; (set! f0 (cons f0 nil))
0x03 ; g3
0x80 ; f0
0xfe ; ctx
0x02 ; g2
"\x03\x80\x00\x00\xfe\x02"
)
)
#()
2
"\x00\x80\x03\xfd\; (set! f0 (car argv))
"\x00\x80\x03\xfb\; (set! f0 (car argv))
\x0d\x81\x80\x01\; (set! f1 (fix< f0 g1))
\x81\x81\x02\x03"; (set! f1 (if f1 g2 g3))
0x81 ; f1
0x00 ; nil
0xfe ; ctx
0xff ; k
"\x81\x00\x00\x00\xfe\xff"
)
; vim:set syntax= sw=2 expandtab:

9
src/lib/primitive/acons.rla
View File

@ -4,17 +4,14 @@
#(#f)
#()
3
"\x00\x80\x03\xfd\; (set! f0 (car argv))
\x00\x82\x04\xfd\; (set! f2 (cdr argv))
"\x00\x80\x03\xfb\; (set! f0 (car argv))
\x00\x82\x04\xfb\; (set! f2 (cdr argv))
\x00\x81\x03\x82\; (set! f1 (car f2))
\x00\x82\x04\x82\; (set! f2 (cdr f2))
\x00\x82\x03\x82\; (set! f2 (car f2))
\x02\x81\x81\x82\; (set! f1 (cons f1 f2))
\x02\x80\x80\x81\; (set! f0 (cons f0 f1))
\x02\x80\x80\x00"; (set! f0 (cons f0 nil))
0xff ; k
0x80 ; f0
0x01 ; g1
0x01 ; g1
"\xff\x80\x00\x00\x01\x01"
)
; vim:set syntax= sw=2 expandtab:

21
src/lib/primitive/and.rla
View File

@ -27,33 +27,24 @@
#(#f)
"\x40\xff" ; i0 k
1
"\x00\x80\x03\xfd\; (set! f0 (car argv))
"\x00\x80\x03\xfb\; (set! f0 (car argv))
\x80\x80\x41\x40"; (set! f0 (if f0 i1 i0))
0x80 ; f0
0xfd ; argv
0x01 ; g1
0x01 ; g1
"\x80\xfb\x00\x00\x01\x01"
)
)
"\xff" ; k
1
"\x00\x80\x03\xfd"; (set! f0 (car argv))
0x80 ; f0
0x00 ; nil
0xfe ; ctx
0x01 ; g1
"\x00\x80\x03\xfb"; (set! f0 (car argv))
"\x80\x00\x00\x00\xfe\x01"
)
#t
)
#()
2
"\x02\x80\xfd\x00\; (set! f0 (cons argv nil))
"\x02\x80\xfb\x00\; (set! f0 (cons argv nil))
\x02\x80\x03\x80\; (set! f0 (cons g3 f0))
\x00\x81\x1b\x02\; (set! f1 (lambda g2))
\x02\x80\x81\x80"; (set! f0 (cons f1 f0))
0x01 ; g1
0x80 ; f0
0xfe ; ctx
0xff ; k
"\x01\x80\x00\x00\xfe\xff"
)
; vim:set syntax= sw=2 expandtab:

16
src/lib/primitive/append.rla
View File

@ -16,26 +16,20 @@
)
#()
2
"\x00\x80\x03\xfd\; (set! f0 (car argv))
"\x00\x80\x03\xfb\; (set! f0 (car argv))
\x02\x81\x80\x00\; (set! f1 (cons f0 nil))
\x00\x80\x04\xfd\; (set! f0 (cdr argv))
\x00\x80\x04\xfb\; (set! f0 (cdr argv))
\x00\x80\x03\x80\; (set! f0 (car f0))
\x02\x81\x80\x81\; (set! f1 (cons f0 f1))
\x02\x81\x02\x81"; (set! f1 (cons g2 f1))
0x01 ; g1
0x81 ; f1
0xfe ; ctx
0xff ; k
"\x01\x81\x00\x00\xfe\xff"
)
)
#()
1
"\x02\x80\xfd\x00\; (set! f0 (cons argv nil))
"\x02\x80\xfb\x00\; (set! f0 (cons argv nil))
\x02\x80\x00\x80\; (set! f0 (cons nil f0))
\x02\x80\x02\x80"; (set! f0 (cons g2 f0))
0x01 ; g1
0x80 ; f0
0xfe ; ctx
0xff ; k
"\x01\x80\x00\x00\xfe\xff"
)
; vim:set syntax= sw=2 expandtab:

9
src/lib/primitive/cons.rla
View File

@ -4,14 +4,11 @@
#(#f)
#()
2
"\x00\x80\x03\xfd\; (set! f0 (car argv))
\x00\x81\x04\xfd\; (set! f1 (cdr argv))
"\x00\x80\x03\xfb\; (set! f0 (car argv))
\x00\x81\x04\xfb\; (set! f1 (cdr argv))
\x00\x81\x03\x81\; (set! f1 (car f1))
\x02\x80\x80\x81\; (set! f0 (cons f0 f1))
\x02\x80\x80\x00"; (set! f0 (cons f0 nil))
0xff ; k
0x80 ; f0
0x01 ; g1
0x01 ; g1
"\xff\x80\x00\x00\x01\x01"
)
; vim:set syntax= sw=2 expandtab:

26
src/lib/primitive/foldl.rla
View File

@ -29,13 +29,10 @@
2
"\x00\x80\x04\x42\; (set! f0 (cdr i2))
\x02\x80\x80\x00\; (set! f0 (cons f0 nil))
\x00\x81\x03\xfd\; (set! f1 (car argv))
\x00\x81\x03\xfb\; (set! f1 (car argv))
\x02\x80\x81\x80\; (set! f0 (cons f1 f0))
\x02\x80\x40\x80"; (set! f0 (cons i0 f0))
0x01 ; g1
0x80 ; f0
0x43 ; i3
0x44 ; i4
"\x01\x80\x00\x00\x43\x44"
)
)
"\x80\x81\x82" ; f0=fn f1=init f2=lst
@ -43,10 +40,7 @@
"\x02\x80\x41\x00\; (set! f0 (cons i1 nil))
\x00\x81\x03\x42\; (set! f1 (car i2))
\x02\x80\x81\x80"; (set! f0 (cons f1 f0))
0x40 ; i0
0x80 ; f0
0xfe ; ctx
0x01 ; g1
"\x40\x80\x00\x00\xfe\x01"
)
#S(#="template"
; (lambda () init)
@ -54,16 +48,13 @@
"\x81" ; f1
1
"\x02\x80\x40\x00"; (set! f0 (cons i0 nil))
0xff ; k
0x80 ; f0
0x01 ; g1
0x01 ; g1
"\xff\x80\x00\x00\x01\x01"
)
)
#()
6
"\x00\x80\x03\xfd\; (set! f0 (car argv)) ; f0=fn
\x00\x82\x04\xfd\; (set! f2 (cdr argv))
"\x00\x80\x03\xfb\; (set! f0 (car argv)) ; f0=fn
\x00\x82\x04\xfb\; (set! f2 (cdr argv))
\x00\x81\x03\x82\; (set! f1 (car f2)) ; f1=init
\x00\x82\x04\x82\; (set! f2 (cdr f2))
\x00\x82\x03\x82\; (set! f2 (car f2)) ; f2=lst
@ -73,9 +64,6 @@
\x40\x83\x00\x00\; (goto-end-if f3)
\x00\x84\x01\xff\; (set! f4 k)
\x02\x85\x81\x00"; (set! f5 (cons f1 nil))
0x84 ; f4
0x85 ; f5
0xfe ; ctx
0xff ; k
"\x84\x85\x00\x00\xfe\xff"
)
; vim:set syntax= sw=2 expandtab:

21
src/lib/primitive/foldr.rla
View File

@ -28,13 +28,10 @@
#()
"\x40\x81\xfe\xff" ; i0 f1 ctx k
1
"\x00\x80\x03\xfd\; (set! f0 (car argv))
"\x00\x80\x03\xfb\; (set! f0 (car argv))
\x02\x80\x80\x00\; (set! f0 (cons f0 nil))
\x02\x80\x41\x80"; (set! f0 (cons i1 f0))
0x40 ; i0
0x80 ; f0
0x42 ; i2
0x43 ; i3
"\x40\x80\x00\x00\x42\x43"
)
#=0 ; foldr
)
@ -45,16 +42,13 @@
\x02\x82\x80\x00\; (set! f2 (cons f0 nil))
\x02\x82\x41\x82\; (set! f2 (cons i1 f2))
\x02\x82\x40\x82"; (set! f2 (cons i0 f2))
0x02 ; g2
0x82 ; f2
0xfe ; ctx
0x01 ; g1
"\x02\x82\x00\x00\xfe\x01"
)
)
#()
6
"\x00\x80\x03\xfd\; (set! f0 (car argv)) ; f0=fn
\x00\x82\x04\xfd\; (set! f2 (cdr argv))
"\x00\x80\x03\xfb\; (set! f0 (car argv)) ; f0=fn
\x00\x82\x04\xfb\; (set! f2 (cdr argv))
\x00\x81\x03\x82\; (set! f1 (car f2)) ; f1=init
\x00\x82\x04\x82\; (set! f2 (cdr f2))
\x00\x82\x03\x82\; (set! f2 (car f2)) ; f2=lst
@ -64,9 +58,6 @@
\x40\x83\x00\x00\; (goto-end-if f3)
\x00\x84\x01\xff\; (set! f4 k)
\x02\x85\x81\x00"; (set! f5 (cons f1 nil))
0x84 ; f4
0x85 ; f5
0xfe ; ctx
0xff ; k
"\x84\x85\x00\x00\xfe\xff"
)
; vim:set syntax= sw=2 expandtab:

7
src/lib/primitive/list.rla
View File

@ -8,12 +8,9 @@
)
#()
1
"\x02\x80\xfd\x00\; (set! f0 (cons argv nil))
"\x02\x80\xfb\x00\; (set! f0 (cons argv nil))
\x02\x80\x00\x80\; (set! f0 (cons nil f0))
\x02\x80\x02\x80"; (set! f0 (cons g2 f0))
0x01 ; g1
0x80 ; f0
0xfe ; ctx
0xff ; k
"\x01\x80\x00\x00\xfe\xff"
)
; vim:set syntax= sw=2 expandtab:

30
src/lib/primitive/map.rla
View File

@ -19,26 +19,20 @@
#(#f)
"\x81\xff" ; f1 k
1
"\x00\x80\x03\xfd\; (set! f0 (car argv))
"\x00\x80\x03\xfb\; (set! f0 (car argv))
\x02\x80\x80\x40\; (set! f0 (cons f0 i0))
\x02\x80\x80\x00"; (set! f0 (cons f0 nil))
0x41 ; i1
0x80 ; f0
0x01 ; g1
0x01 ; g1
"\x41\x80\x00\x00\x01\x01"
)
)
"\x80"
2
"\x00\x80\x03\xfd\; (set! f0 (car argv))
\x00\x81\x04\xfd\; (set! f1 (cdr argv))
"\x00\x80\x03\xfb\; (set! f0 (car argv))
\x00\x81\x04\xfb\; (set! f1 (cdr argv))
\x00\x81\x03\x81\; (set! f1 (car f1))
\x00\x81\x1b\x01\; (set! f1 (lambda g1))
\x02\x80\x80\x00"; (set! f0 (cons f0 nil))
0x40 ; i0
0x80 ; f0
0xfe ; ctx
0x81 ; f1
"\x40\x80\x00\x00\xfe\x81"
)
#S(#="template"
; (lambda (rlst)
@ -47,25 +41,19 @@
"\xfe\xff" ; ctx k
0
""
0x01 ; g1
0xfd ; argv
0x40 ; i0
0x41 ; i1
"\x01\xfb\x00\x00\x40\x41"
)
)
#()
4
"\x00\x80\x03\xfd\; (set! f0 (car argv))
\x00\x81\x04\xfd\; (set! f1 (cdr argv))
"\x00\x80\x03\xfb\; (set! f0 (car argv))
\x00\x81\x04\xfb\; (set! f1 (cdr argv))
\x00\x81\x03\x81\; (set! f1 (car f1))
\x02\x82\x81\x00\; (set! f2 (cons f1 nil))
\x02\x82\x00\x82\; (set! f2 (cons nil f2))
\x00\x83\x1b\x02\; (set! f3 (lambda g2))
\x02\x82\x83\x82\; (set! f2 (cons f3 f2))
\x00\x83\x1b\x03"; (set! f3 (lambda g3))
0x01 ; g1
0x82 ; f2
0xfe ; ctx
0x83 ; f3
"\x01\x82\x00\x00\xfe\x83"
)
; vim:set syntax= sw=2 expandtab:

21
src/lib/primitive/or.rla
View File

@ -27,34 +27,25 @@
#(#f)
"\x40\xff" ; i0 k
1
"\x00\x80\x03\xfd\; (set! f0 (car argv))
"\x00\x80\x03\xfb\; (set! f0 (car argv))
\x80\x80\x40\x41"; (set! f0 (if f0 i0 i1))
0x80 ; f0
0xfd ; argv
0x01 ; g1
0x01 ; g1
"\x80\xfb\x00\x00\x01\x01"
)
)
"\xff" ; k
2
"\x00\x80\x03\xfd\; (set! f0 (car argv))
"\x00\x80\x03\xfb\; (set! f0 (car argv))
\x00\x81\x1b\x01"; (set! f1 (lambda g1))
0x80 ; f0
0x00 ; nil
0xfe ; ctx
0x81 ; f1
"\x80\x00\x00\x00\xfe\x81"
)
#f
)
#()
2
"\x02\x80\xfd\x00\; (set! f0 (cons argv nil))
"\x02\x80\xfb\x00\; (set! f0 (cons argv nil))
\x02\x80\x03\x80\; (set! f0 (cons g3 f0))
\x00\x81\x1b\x02\; (set! f1 (lambda g2))
\x02\x80\x81\x80"; (set! f0 (cons f1 f0))
0x01 ; g1
0x80 ; f0
0xfe ; ctx
0xff ; k
"\x01\x80\x00\x00\xfe\xff"
)
; vim:set syntax= sw=2 expandtab:

7
src/lib/primitive/reverse.rla
View File

@ -8,13 +8,10 @@
)
#()
1
"\x00\x80\x03\xfd\; (set! f0 (car argv))
"\x00\x80\x03\xfb\; (set! f0 (car argv))
\x02\x80\x80\x00\; (set! f0 (cons f0 nil))
\x02\x80\x00\x80\; (set! f0 (cons nil f0))
\x02\x80\x02\x80"; (set! f0 (cons g2 f0))
0x01 ; g1
0x80 ; f0
0xfe ; ctx
0xff ; k
"\x01\x80\x00\x00\xfe\xff"
)
; vim:set syntax= sw=2 expandtab:

273
src/reader.rls
View File

@ -62,7 +62,7 @@
(read-list)]
[(or (eq? current-char #\-)
(eq? current-char #\+)
(numeric-char? current-char))
(decimal-char? current-char))
(read-number)]
[(eq? current-char #\")
(read-string)]
@ -143,31 +143,39 @@
(cons (read-one-value) (read-rest))))
(define (read-fixnum [radix #f])
(let/cc return
(when eof? (unexpected-eof))
(define neg? (eq? current-char #\-))
(when (or neg? (eq? current-char #\+))
(next-char))
(next-char)
(when eof? (unexpected-eof)))
(unless radix
(unless (numeric-char? current-char) (unexpected-char))
(unless (decimal-char? current-char) (unexpected-char))
(if (eq? current-char #\0)
(begin
(next-char)
(cond
[(or eof? (not (alphanumeric-char? current-char)))
(return 0)]
[(memq? current-char '(#\X #\x))
(next-char)
(set! radix 16)]
[(octal-char? current-char)
(set! radix 8)]
[(memq? current-char '(#\B #\b))
(next-char)
(set! radix 2)]
[else
(set! radix 8)])
(unless (or (eq? radix 8)
(and (alphanumeric-char? current-char)
(fix< (digit->integer current-char) radix)))
(unexpected-char)))
(unexpected-char)]))
(set! radix 10)))
; Need at least one digit within this radix
(unless (and (alphanumeric-char? current-char)
(fix< (digit->integer current-char) radix))
(unexpected-char))
(define (iter accum)
(let ([val (digit->integer current-char)])
(if (and val (fix< val radix))
@ -177,7 +185,7 @@
accum)))
(let ([pos-val (iter 0)])
(if neg? (fix- pos-val) pos-val)))
(if neg? (fix- pos-val) pos-val))))
(define (read-number)
(read-fixnum))
@ -195,19 +203,86 @@
(define (read-string)
(define (read-chars [accum '()] [len 0])
(define (read-one-char)
(when (eq? current-char #\\)
(define (skip-ws skip-nl?)
(when eof? (unexpected-eof))
(when (whitespace? current-char)
(let ([ch current-char])
(next-char)
(when eof? (unexpected-eof)))
current-char)
(if (eq? ch #\Newline)
(when skip-nl? (skip-ws #f))
(skip-ws skip-nl?)))))
(when eof? (unexpected-eof))
(cond
[(eq? current-char #\")
(next-char)
#f]
[(eq? current-char #\\)
(next-char)
(when eof? (unexpected-eof))
(if (eq? current-char #\")
(cond
[(or (eq? current-char #\o)
(octal-char? current-char))
(when (eq? current-char #\o)
(next-char)
(when eof? (unexpected-eof))
(unless (octal-char? current-char) (unexpected-char)))
(let ([total (digit->integer current-char)])
(next-char)
(when eof? (unexpected-eof))
(define (add-char)
(set! total (fix+ (fix* total 8)
(digit->integer current-char)))
(when (fix> total 255) (unexpected-char))
(next-char)
(when eof? (unexpected-eof))
(octal-char? current-char))
(and (octal-char? current-char) (add-char) (add-char))
total)]
[(memq? current-char '(#\X #\x))
(next-char)
(when eof? (unexpected-eof))
(unless (hex-char? current-char) (unexpected-char))
(let ([total (digit->integer current-char)])
(next-char)
(when eof? (unexpected-eof))
(when (hex-char? current-char)
(set! total (fix+ (fix* total 16)
(digit->integer current-char)))
(when (fix> total 255) (unexpected-char))
(next-char)
(when eof? (unexpected-eof)))
total)]
[(whitespace? current-char)
(skip-ws #t)
(read-one-char)]
[(eq? current-char #\;)
(define (skip-to-nl+ws)
(when eof? (unexpected-eof))
(if (eq? current-char #\Newline)
(skip-ws #t)
(begin
(next-char)
(values accum len))
(read-chars (cons (read-one-char) accum) (fix+ len 1))))
(skip-to-nl+ws))))
(skip-to-nl+ws)
(read-one-char)]
[else
(let ([item (findf (lambda (x) (eq? (car x) current-char))
'((#\\ . #\\) (#\' . #\') (#\" . #\")
(#\a . 7) (#\b . 8) (#\t . 9)
(#\n . 10) (#\v . 11) (#\f . 12)
(#\r . 13)))])
(unless item (unexpected-char))
(next-char)
(cdr item))])]
[else
current-char]))
(let ([ch (read-one-char)])
(if ch
(read-chars (cons ch accum) (fix+ len 1))
(values accum len))))
(next-char)
(call-with-values
read-chars
(lambda (revchars len)
@ -219,165 +294,23 @@
(iter (fix- len 1) revchars)
str))))
; static value_t read_string(reader_state_t *state)
; {
; char *buffer = (char*)malloc(128);
; size_t buffer_size = 128;
; size_t length = 0;
; value_t value;
;
; release_assert(buffer != NULL);
; release_assert(state->ch == '"');
;
; next_char(state);
;
; while (state->ch != '"')
; {
; bool skip_ws = false;
; char ch;
;
; release_assert(state->ch != EOF);
;
; if ((buffer_size - length) < 1)
; {
; release_assert(buffer_size <= INT32_MAX / 3);
; buffer_size = (3 * buffer_size) / 2;
; buffer = realloc(buffer, buffer_size);
; release_assert(buffer != NULL);
; }
;
; ch = state->ch;
; next_char(state);
;
; if (ch == '\\')
; {
; switch (state->ch)
; {
; case 'o':
; next_char(state);
; release_assert(('0' <= state->ch) && (state->ch <= '7'));
; /* fall through */
; case '0' ... '7':
; ch = 0;
;
; /* One to three octal digits */
; for (int i = 0; i < 3; ++i)
; {
; ch = 8 * ch + (state->ch - '0');
; next_char(state);
; if ((state->ch < '0') || (state->ch > '7'))
; break;
; }
; break;
; case 'X':
; case 'x':
; ch = 0;
;
; next_char(state);
; release_assert(isxdigit(state->ch));
;
; /* One or two hex digits */
; for (int i = 0; i < 2; ++i)
; {
; int n = isdigit(state->ch)
; ? (state->ch - '0')
; : (10 + toupper(state->ch) - 'A');
;
; ch = 16 * ch + n;
; next_char(state);
;
; if (!isxdigit(state->ch))
; break;
; }
; break;
; case ' ':
; case '\t':
; case '\v':
; case '\n':
; skip_ws = true;
; break;
; case ';':
; /* Treats everything that follows on the same line as a comment,
; * and additionally skips leading whitespace on the next line. */
; while (state->ch != '\n')
; {
; release_assert(state->ch != EOF);
; next_char(state);
; }
; skip_ws = true;
; break;
; case '\\': ch = '\\'; next_char(state); break;
; case '\'': ch = '\''; next_char(state); break;
; case '\"': ch = '\"'; next_char(state); break;
; case 'a': ch = '\a'; next_char(state); break;
; case 'b': ch = '\b'; next_char(state); break;
; case 'f': ch = '\f'; next_char(state); break;
; case 'n': ch = '\n'; next_char(state); break;
; case 'r': ch = '\r'; next_char(state); break;
; case 't': ch = '\t'; next_char(state); break;
; case 'v': ch = '\v'; next_char(state); break;
; default:
; release_assert(NOTREACHED("Invalid escape sequence in string."));
; ch = '#';
; next_char(state);
; break;
; }
; }
;
; if (skip_ws)
; {
; bool hit_eol = false;
;
; /* Slightly different from the normal skip_whitespace(); skips
; * whitespace through the _second_ EOL following the backslash. */
; do {
; if (state->ch == '\n')
; {
; if (!hit_eol)
; {
; hit_eol = true;
; }
; else
; {
; next_char(state);
; break;
; }
; }
;
; next_char(state);
; } while (isspace(state->ch));
; }
; else
; {
; buffer[length++] = ch;
; }
; }
;
; next_char(state);
;
; value = make_byte_string(length, '\0');
; memcpy(_get_byte_string(value)->bytes, buffer, length);
; free(buffer);
;
; return value;
; }
(define (read-vector) undefined)
(define (read-struct) undefined)
(define (read-symbol) undefined)
(define (skip-whitespace)
(unless eof?
(cond
[(whitespace? current-char)
(next-char)
(skip-whitespace)]
[(eq? current-char #\;)
(define (skip-until-newline)
(let ([ch current-char])
(next-char)
(if (eq? current-char #\Newline)
(next-char)
(unless eof? (skip-until-newline))))
(skip-until-newline)]))
(unless (eq? ch #\Newline)
(skip-until-newline))))
(skip-until-newline)])))
(define (next-char)
(if eof?
@ -412,9 +345,17 @@
(define (whitespace? ch)
(memq? ch '(#\Space #\Tab #\VTab #\Page #\Newline)))
(define (numeric-char? ch)
(define (octal-char? ch)
(and (fix>= ch #\0) (fix<= ch #\7)))
(define (decimal-char? ch)
(and (fix>= ch #\0) (fix<= ch #\9)))
(define (hex-char? ch)
(or (decimal-char? ch)
(and (fix>= ch #\A) (fix<= ch #\F))
(and (fix>= ch #\a) (fix<= ch #\f))))
(define (upcase-char? ch)
(and (fix>= ch #\A) (fix<= ch #\Z)))
@ -425,7 +366,7 @@
(or (upcase-char? ch) (downcase-char? ch)))
(define (alphanumeric-char? ch)
(or (numeric-char? ch) (alphabetic-char? ch)))
(or (decimal-char? ch) (alphabetic-char? ch)))
(define (symbol-char? ch)
(or (alphanumeric-char? ch)
@ -447,7 +388,7 @@
(define (digit->integer ch)
(cond
[(numeric-char? ch) (fix- ch #\0)]
[(decimal-char? ch) (fix- ch #\0)]
[(upcase-char? ch) (fix+ 10 (fix- ch #\A))]
[(downcase-char? ch) (fix+ 10 (fix- ch #\a))]
[else #f]))