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); free(str);
if ((*end == '\0') && (_get_fixnum(fixnum_value(num)) == num)) if ((*end == '\0') && (_get_fixnum(fixnum_value(num)) == num))
rval = cons(fixnum_value(num), NIL); rval = fixnum_value(num);
else else
rval = cons(FALSE_VALUE, NIL); rval = FALSE_VALUE;
state->lambda.value = state->k.value; interp_return_values(state, cons(rval, NIL));
state->argv.value = rval;
state->ctx.value = FALSE_VALUE;
state->k.value = FALSE_VALUE;
} }
/* vim:set sw=2 expandtab: */ /* vim:set sw=2 expandtab: */

10
builtin.h
View File

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

30
doc/bytecode.txt
View File

@ -160,15 +160,17 @@ statement: up to 64 (40..7f), 3 in
62 (struct-set! in1 in2 in3) ; struct n value, 0 <= n < nslots 62 (struct-set! in1 in2 in3) ; struct n value, 0 <= n < nslots
in: in:
nil (00000000) [g0, always NIL] nil (00000000) [g0, always NIL]
gN (00NNNNNN) [global, N < 64] gN (00NNNNNN) [global, N < 64]
iN (01NNNNNN) [instance, N < 64] iN (01NNNNNN) [instance, N < 64]
fN (1NNNNNNN) [frame, N < 120] fN (1NNNNNNN) [frame, N < 120]
-- (11111NNN) [reserved, N < 4] -- (1111100N) [reserved, N < 2]
self (11111100) [current lambda] self (11111010) [current lambda]
argv (11111101) [argument list] argv (11111011) [argument list]
ctx (11111110) [dynamic context] kw-args (11111100) [keyword arguments] (sorted)
k (11111111) [continuation] kw-vals (11111101) [keyword values] (match kw-args)
ctx (11111110) [dynamic context]
k (11111111) [continuation]
out: out:
fN (1NNNNNNN) [0 <= N < 120] fN (1NNNNNNN) [0 <= N < 120]
@ -178,10 +180,7 @@ lambda:[
instance: vector of immutable values (i0..iN); shared between frames (calls) instance: vector of immutable values (i0..iN); shared between frames (calls)
frame: number of frame variables; initially #<undefined> frame: number of frame variables; initially #<undefined>
code: byte-string containing sequence of 4-byte instruction words code: byte-string containing sequence of 4-byte instruction words
tail-call: in-ref of lambda to tail-call tail-call: byte-string of in-refs: (target argv kw-args kw-vals ctx k)
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
] ]
template:[ template:[
@ -189,10 +188,7 @@ template:[
instance: byte-string of in-refs. to parent instance/frame slots instance: byte-string of in-refs. to parent instance/frame slots
frame: copied verbatim frame: copied verbatim
code: linked code: linked
tail-call: copied verbatim tail-call: linked
arguments: copied verbatim
context: copied verbatim
continuation: copied verbatim
] ]
Protocol: Protocol:

119
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_FRAME_VARS] = ts->slots[TEMPLATE_SLOT_FRAME_VARS];
ls->slots[LAMBDA_SLOT_BYTE_CODE] = ts->slots[TEMPLATE_SLOT_BYTE_CODE]; 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_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); WRITE_BARRIER(lambda_root.value);
l_inst = _get_vector(ls->slots[LAMBDA_SLOT_INSTANCE_VARS]); l_inst = _get_vector(ls->slots[LAMBDA_SLOT_INSTANCE_VARS]);
@ -269,61 +266,75 @@ static void run_byte_code(interp_state_t *state)
register_gc_root(&bc_root, _LAMBDA_SLOT(state->lambda.value, BYTE_CODE)); register_gc_root(&bc_root, _LAMBDA_SLOT(state->lambda.value, BYTE_CODE));
for (size_t offset = 0; (offset+3) < _get_byte_string(bc_root.value)->size; offset += 4) if (bc_root.value != FALSE_VALUE)
{ {
uint8_t bytes[4]; release_assert((get_byte_string(bc_root.value)->size % 4) == 0);
memcpy(bytes, _get_byte_string(bc_root.value)->bytes + offset, 4); for (size_t offset = 0; (offset+3) < _get_byte_string(bc_root.value)->size; offset += 4)
switch (bytes[0])
{ {
bool cond; uint8_t bytes[4];
case 0x00 ... 0x3f: /* expression */
set_output(state, bytes[1], eval_expression(state, bytes[0], bytes[2], bytes[3])); memcpy(bytes, _get_byte_string(bc_root.value)->bytes + offset, 4);
break;
case 0x40 ... 0x41: /* goto-end-if, goto-end-unless */ switch (bytes[0])
cond = _get_boolean(get_input(state, bytes[1]));
if ((bytes[0] & 1) ? !cond : cond)
{ {
goto break_for_loop; bool cond;
case 0x00 ... 0x3f: /* expression */
set_output(state, bytes[1], eval_expression(state, bytes[0], bytes[2], bytes[3]));
break;
case 0x40 ... 0x41: /* goto-end-if, goto-end-unless */
cond = _get_boolean(get_input(state, bytes[1]));
if ((bytes[0] & 1) ? !cond : cond)
{
goto break_for_loop;
}
break;
case 0x42 ... 0x7f: /* statement */
run_statement(state, bytes[0], bytes[1], bytes[2], bytes[3]);
break;
case 0x80 ... 0xff: /* conditional */
set_output(state, bytes[0],
get_input(state, _get_boolean(get_input(state, bytes[1]))
? bytes[2] : bytes[3]));
break;
} }
break;
case 0x42 ... 0x7f: /* statement */
run_statement(state, bytes[0], bytes[1], bytes[2], bytes[3]);
break;
case 0x80 ... 0xff: /* conditional */
set_output(state, bytes[0],
get_input(state, _get_boolean(get_input(state, bytes[1]))
? bytes[2] : bytes[3]));
break;
} }
break_for_loop:;
} }
break_for_loop:
unregister_gc_root(&bc_root); unregister_gc_root(&bc_root);
} }
static void perform_tail_call(interp_state_t *state) 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)))); release_assert(get_byte_string(tail_call)->size == 6);
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_lambda, get_input(state, _get_byte_string(tail_call)->bytes[0]));
register_gc_root(&new_k, get_input(state, get_fixnum(_LAMBDA_SLOT(state->lambda.value, CONTINUATION)))); 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 */ /* If new lambda or continuation is a template, instantiate it here */
new_lambda.value = make_lambda(state, new_lambda.value); new_lambda.value = make_lambda(state, new_lambda.value);
new_k.value = make_lambda(state, new_k.value); new_k.value = make_lambda(state, new_k.value);
/* Transfer control to new function */ /* Transfer control to new function */
state->lambda.value = new_lambda.value; state->lambda.value = new_lambda.value;
state->argv.value = new_argv.value; state->argv.value = new_argv.value;
state->ctx.value = new_ctx.value; state->kw_args.value = new_kw_args.value;
state->k.value = new_k.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_lambda);
unregister_gc_root(&new_argv); 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_ctx);
unregister_gc_root(&new_k); 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); release_assert(var < state->nframe);
return vec->elements[var]; return vec->elements[var];
} }
/* 248 ... 251 are reserved */ /* 248 ... 249 are reserved */
case 252: case 250:
return state->lambda.value; return state->lambda.value;
case 253: case 251:
return state->argv.value; return state->argv.value;
case 252:
return state->kw_args.value;
case 253:
return state->kw_vals.value;
case 254: case 254:
return state->ctx.value; return state->ctx.value;
case 255: case 255:
@ -576,23 +591,29 @@ static void set_output(const interp_state_t *state, fixnum_t var, value_t val)
static void register_state(interp_state_t *state, value_t lambda, value_t argv) static void register_state(interp_state_t *state, value_t lambda, value_t argv)
{ {
register_gc_root(&state->lambda, lambda); register_gc_root(&state->lambda, lambda);
register_gc_root(&state->argv, argv); 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->ctx, FALSE_VALUE); register_gc_root(&state->kw_vals, NIL);
register_gc_root(&state->k, FALSE_VALUE); register_gc_root(&state->ctx, FALSE_VALUE);
register_gc_root(&state->in1, FALSE_VALUE); register_gc_root(&state->k, FALSE_VALUE);
register_gc_root(&state->in2, FALSE_VALUE);
register_gc_root(&state->in3, 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);
} }
static void unregister_state(interp_state_t *state) static void unregister_state(interp_state_t *state)
{ {
unregister_gc_root(&state->lambda); unregister_gc_root(&state->lambda);
unregister_gc_root(&state->argv); 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->ctx);
unregister_gc_root(&state->k); unregister_gc_root(&state->k);
unregister_gc_root(&state->frame);
unregister_gc_root(&state->in1); unregister_gc_root(&state->in1);
unregister_gc_root(&state->in2); unregister_gc_root(&state->in2);
unregister_gc_root(&state->in3); 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 lambda;
gc_root_t frame; gc_root_t frame;
gc_root_t argv; gc_root_t argv;
gc_root_t kw_args;
gc_root_t kw_vals;
gc_root_t ctx; gc_root_t ctx;
gc_root_t k; gc_root_t k;
gc_root_t in1; gc_root_t in1;
@ -19,5 +21,49 @@ typedef struct interp_state
void interpreter_init(void); void interpreter_init(void);
value_t run_interpreter(value_t lambda, value_t argv); 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 #endif
/* vim:set sw=2 expandtab: */ /* vim:set sw=2 expandtab: */

2
libcompiler/primitives.scm
View File

@ -169,7 +169,7 @@
(string->uninterned-symbol (string-append "#%f" (number->string i))))) (string->uninterned-symbol (string-append "#%f" (number->string i)))))
(define special-variables (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 (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))

70
libcompiler/simplifier.scm
View File

@ -264,7 +264,7 @@
[,true-fn (lambda () ,true-form)] [,true-fn (lambda () ,true-form)]
[,false-fn (lambda () ,false-form)]) [,false-fn (lambda () ,false-form)])
(let ([,next-fn (#%if ,cond-val ,true-fn ,false-fn)]) (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 (required... [optional default-expr]... . rest) bodyexpr...)
; => (lambda argv ; => (lambda argv
@ -412,26 +412,26 @@
(match subform (match subform
[(? simple-value?) [(? simple-value?)
`((#%set! ,argv (#%cons ,subform #%nil)) `((#%set! ,argv (#%cons ,subform #%nil))
(#%tail-call ,k ,argv #f #f))] (#%tail-call ,k ,argv #%nil #%nil #f #f))]
[`(#%apply ,x ,y) [`(#%apply . ,sv)
`((#%tail-call ,x ,y ,ctx ,k))] `((#%tail-call ,@sv ,ctx ,k))]
[`(#%call/cc ,x) [`(#%call/cc ,x)
`((#%set! ,argv (#%cons #%k #%nil)) `((#%set! ,argv (#%cons #%k #%nil))
(#%tail-call ,x ,argv ,ctx #%k))] (#%tail-call ,x ,argv #%nil #%nil ,ctx #%k))]
[`(#%values . ,simple-vals) [`(#%values . ,simple-vals)
`((#%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 #f #f))] (#%tail-call ,k ,argv #%nil #%nil #f #f))]
[(? value-form?) [(? value-form?)
`(,(simplify-set! `(set! ,argv ,subform)) `(,(simplify-set! `(set! ,argv ,subform))
(#%set! ,argv (#%cons ,argv #%nil)) (#%set! ,argv (#%cons ,argv #%nil))
(#%tail-call ,k ,argv #f #f))] (#%tail-call ,k ,argv #%nil #%nil #f #f))]
[`(#%tail-call . ,_) [`(#%tail-call . ,_)
`(,subform)] `(,subform)]
[_ [_
`(,subform `(,subform
(#%tail-call ,k #%nil #f #f))]))) (#%tail-call ,k #%nil #%nil #%nil #f #f))])))
'() '()
(cddr flat-bind)))) (cddr flat-bind))))
@ -439,28 +439,28 @@
(define flat-bind (flatten-binds nested-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 ,x ,y))) [`(#%set! ,v (#%value-list (#%apply . ,sv)))
(let ([k (gensym)]) (let ([k (gensym)])
`((#%bind (,k) `((#%bind (,k)
(#%set! ,k ,(simplify-form (#%set! ,k ,(simplify-form
`(lambda ,v `(lambda ,v
,@after))) ,@after)))
(#%tail-call ,x ,y ,ctx ,k))))] (#%tail-call ,@sv ,ctx ,k))))]
[`(#%set! ,v (#%apply ,x ,y)) [`(#%set! ,v (#%apply . ,sv))
(let ([k (gensym)]) (let ([k (gensym)])
`((#%bind (,k) `((#%bind (,k)
(#%set! ,k ,(simplify-form (#%set! ,k ,(simplify-form
`(lambda (,v . ,(gensym)) `(lambda (,v . ,(gensym))
,@after))) ,@after)))
(#%tail-call ,x ,y ,ctx ,k))))] (#%tail-call ,@sv ,ctx ,k))))]
[(or `(#%value-list (#%apply ,x ,y)) [(or `(#%value-list (#%apply . ,sv))
`(#%apply ,x ,y)) `(#%apply . ,sv))
(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 ,x ,y ,ctx ,k))))] (#%tail-call ,@sv ,ctx ,k))))]
[`(#%set! ,v (#%value-list (#%call/cc ,x))) [`(#%set! ,v (#%value-list (#%call/cc ,x)))
(let ([k (gensym)] (let ([k (gensym)]
[k-argv (gensym)]) [k-argv (gensym)])
@ -469,7 +469,7 @@
`(lambda ,v `(lambda ,v
,@after))) ,@after)))
(#%set! ,k-argv (#%cons ,k #%nil)) (#%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)) [`(#%set! ,v (#%call/cc ,x))
(let ([k (gensym)] (let ([k (gensym)]
[k-argv (gensym)]) [k-argv (gensym)])
@ -478,7 +478,7 @@
`(lambda (,v . ,(gensym)) `(lambda (,v . ,(gensym))
,@after))) ,@after)))
(#%set! ,k-argv (#%cons ,k #%nil)) (#%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)) [(or `(#%value-list (#%call/cc ,x))
`(#%call/cc ,x)) `(#%call/cc ,x))
(let ([k (gensym)] (let ([k (gensym)]
@ -488,7 +488,7 @@
`(lambda ,(gensym) `(lambda ,(gensym)
,@after))) ,@after)))
(#%set! ,k-argv (#%cons ,k #%nil)) (#%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 ; keep all other forms with side-effects as-is
[(? statement-form?) (cons subform after)] [(? statement-form?) (cons subform after)]
; discard any form without side-effects ; discard any form without side-effects
@ -550,19 +550,29 @@
(define (simplify-apply fn-expr arg-exprs) (define (simplify-apply fn-expr arg-exprs)
(define fn-var (gensym)) (define fn-var (gensym))
(define argv (gensym)) (define argv (gensym))
(define arguments (define kw-vals (gensym))
(foldr (lambda (expr args)
(if (null? args) (define-values (bindings plain-args keywords)
(cons (list argv expr) args) (let iter ([arg-exprs arg-exprs])
(if (literal-value? expr) (match arg-exprs
(cons (list expr #f) args) [`(,base-expr)
(cons (list (gensym) expr) args)))) (values `([,argv ,base-expr]) '() '())]
'() [`(,(? keyword? kw) ,expr . ,rst)
arg-exprs)) (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 (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 (lambda (x) `(#%set! ,argv (#%cons ,x ,argv)))
(map first (reverse (drop-right arguments 1)))) (reverse plain-args))
(#%apply ,fn-var ,argv)))) ,(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: ; 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-rla-bytecode+tail-call forms port)
(define (write-tail-call tc-form) (define (write-tail-call tc-form)
(req-new-line port) (write-hex-byte (variable->code (second tc-form)) port) (req-new-line port)
(req-new-line port) (write-hex-byte (variable->code (third tc-form)) port) (write-char #\" port)
(req-new-line port) (write-hex-byte (variable->code (fourth tc-form)) port) (for ([var (in-list (cdr tc-form))])
(req-new-line port) (write-hex-byte (variable->code (fifth tc-form)) port)) (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)]) (let-values ([(line col pos) (port-next-location port)])
(parameterize ([current-indent col]) (parameterize ([current-indent col])
(write-char #\" port) (write-char #\" port)
@ -146,7 +153,7 @@
(write (char->integer value) port)] (write (char->integer value) port)]
[(string? value) [(string? value)
(write-rla-string value port)] (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)] (write-rla-function value port)]
[(vector? value) [(vector? value)
(write-string "#(" port) (write-string "#(" port)
@ -182,8 +189,8 @@
(and index (+ #x40 index))) (and index (+ #x40 index)))
(let ([index (find var frame-variables)]) (let ([index (find var frame-variables)])
(and index (+ #x80 index))) (and index (+ #x80 index)))
(let ([index (find var '(#%self #%argv #%ctx #%k))]) (let ([index (find var '(#%self #%argv #%kw-args #%kw-vals #%ctx #%k))])
(and index (+ #xfc index))) (and index (+ #xfa index)))
(error "No bytecode for variable:" var))) (error "No bytecode for variable:" var)))
(define (statement->code form) (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)); 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) static void bi_posix_open(interp_state_t *state)
{ {
char *pathname; 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(fd));
release_assert(is_valid_fixnum(saved_errno)); release_assert(is_valid_fixnum(saved_errno));
simple_return2(state, (fd >= 0) ? fixnum_value(fd) : FALSE_VALUE, interp_return_values(state,
fixnum_value(saved_errno)); cons((fd >= 0) ? fixnum_value(fd) : FALSE_VALUE,
cons(fixnum_value(saved_errno),
NIL)));
} }
//static void bi_posix_openat(interp_state_t *state) {} //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(newfd));
release_assert(is_valid_fixnum(saved_errno)); release_assert(is_valid_fixnum(saved_errno));
simple_return2(state, (newfd >= 0) ? fixnum_value(newfd) : FALSE_VALUE, interp_return_values(state,
fixnum_value(saved_errno)); cons((newfd >= 0) ? fixnum_value(newfd) : FALSE_VALUE,
cons(fixnum_value(saved_errno),
NIL)));
} }
static void bi_posix_dup2(interp_state_t *state) 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(newfd));
release_assert(is_valid_fixnum(saved_errno)); release_assert(is_valid_fixnum(saved_errno));
simple_return2(state, (newfd >= 0) ? fixnum_value(newfd) : FALSE_VALUE, interp_return_values(state,
fixnum_value(saved_errno)); cons((newfd >= 0) ? fixnum_value(newfd) : FALSE_VALUE,
cons(fixnum_value(saved_errno),
NIL)));
} }
static void bi_posix_read(interp_state_t *state) 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(result));
release_assert(is_valid_fixnum(saved_errno)); release_assert(is_valid_fixnum(saved_errno));
simple_return2(state, (result >= 0) ? fixnum_value(result) : FALSE_VALUE, interp_return_values(state,
fixnum_value(saved_errno)); cons((result >= 0) ? fixnum_value(result) : FALSE_VALUE,
cons(fixnum_value(saved_errno),
NIL)));
} }
static void bi_posix_write(interp_state_t *state) 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(result));
release_assert(is_valid_fixnum(saved_errno)); release_assert(is_valid_fixnum(saved_errno));
simple_return2(state, (result >= 0) ? fixnum_value(result) : FALSE_VALUE, interp_return_values(state,
fixnum_value(saved_errno)); cons((result >= 0) ? fixnum_value(result) : FALSE_VALUE,
cons(fixnum_value(saved_errno),
NIL)));
} }
static void bi_posix_lseek(interp_state_t *state) 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)) 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 else
{ {
release_assert((result >= 0) && (result <= FIXNUM_MAX)); 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); result = close(fd);
saved_errno = errno; 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: */ /* vim:set sw=2 expandtab: */

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

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

10
src/examples/factorial.rla
View File

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -16,26 +16,20 @@
) )
#() #()
2 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)) \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)) \x00\x80\x03\x80\; (set! f0 (car f0))
\x02\x81\x80\x81\; (set! f1 (cons f0 f1)) \x02\x81\x80\x81\; (set! f1 (cons f0 f1))
\x02\x81\x02\x81"; (set! f1 (cons g2 f1)) \x02\x81\x02\x81"; (set! f1 (cons g2 f1))
0x01 ; g1 "\x01\x81\x00\x00\xfe\xff"
0x81 ; f1
0xfe ; ctx
0xff ; k
) )
) )
#() #()
1 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\x00\x80\; (set! f0 (cons nil f0))
\x02\x80\x02\x80"; (set! f0 (cons g2 f0)) \x02\x80\x02\x80"; (set! f0 (cons g2 f0))
0x01 ; g1 "\x01\x80\x00\x00\xfe\xff"
0x80 ; f0
0xfe ; ctx
0xff ; k
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

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

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

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

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

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

@ -8,12 +8,9 @@
) )
#() #()
1 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\x00\x80\; (set! f0 (cons nil f0))
\x02\x80\x02\x80"; (set! f0 (cons g2 f0)) \x02\x80\x02\x80"; (set! f0 (cons g2 f0))
0x01 ; g1 "\x01\x80\x00\x00\xfe\xff"
0x80 ; f0
0xfe ; ctx
0xff ; k
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

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

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

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

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

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

@ -8,13 +8,10 @@
) )
#() #()
1 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\x80\x00\; (set! f0 (cons f0 nil))
\x02\x80\x00\x80\; (set! f0 (cons nil f0)) \x02\x80\x00\x80\; (set! f0 (cons nil f0))
\x02\x80\x02\x80"; (set! f0 (cons g2 f0)) \x02\x80\x02\x80"; (set! f0 (cons g2 f0))
0x01 ; g1 "\x01\x80\x00\x00\xfe\xff"
0x80 ; f0
0xfe ; ctx
0xff ; k
) )
; vim:set syntax= sw=2 expandtab: ; vim:set syntax= sw=2 expandtab:

335
src/reader.rls
View File

@ -62,7 +62,7 @@
(read-list)] (read-list)]
[(or (eq? current-char #\-) [(or (eq? current-char #\-)
(eq? current-char #\+) (eq? current-char #\+)
(numeric-char? current-char)) (decimal-char? current-char))
(read-number)] (read-number)]
[(eq? current-char #\") [(eq? current-char #\")
(read-string)] (read-string)]
@ -143,41 +143,49 @@
(cons (read-one-value) (read-rest)))) (cons (read-one-value) (read-rest))))
(define (read-fixnum [radix #f]) (define (read-fixnum [radix #f])
(define neg? (eq? current-char #\-)) (let/cc return
(when eof? (unexpected-eof))
(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)))
(unless radix (unless radix
(unless (numeric-char? current-char) (unexpected-char)) (unless (decimal-char? current-char) (unexpected-char))
(if (eq? current-char #\0) (if (eq? current-char #\0)
(begin
(next-char)
(cond
[(memq? current-char '(#\X #\x))
(next-char)
(set! radix 16)]
[(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)))
(set! radix 10)))
(define (iter accum)
(let ([val (digit->integer current-char)])
(if (and val (fix< val radix))
(begin (begin
(next-char) (next-char)
(iter (fix+ (fix* accum radix) val))) (cond
accum))) [(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
(unexpected-char)]))
(set! radix 10)))
(let ([pos-val (iter 0)]) ; Need at least one digit within this radix
(if neg? (fix- pos-val) pos-val))) (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))
(begin
(next-char)
(iter (fix+ (fix* accum radix) val)))
accum)))
(let ([pos-val (iter 0)])
(if neg? (fix- pos-val) pos-val))))
(define (read-number) (define (read-number)
(read-fixnum)) (read-fixnum))
@ -195,19 +203,86 @@
(define (read-string) (define (read-string)
(define (read-chars [accum '()] [len 0]) (define (read-chars [accum '()] [len 0])
(define (read-one-char) (define (read-one-char)
(when (eq? current-char #\\) (define (skip-ws skip-nl?)
(next-char) (when eof? (unexpected-eof))
(when eof? (unexpected-eof))) (when (whitespace? current-char)
current-char) (let ([ch current-char])
(next-char)
(if (eq? ch #\Newline)
(when skip-nl? (skip-ws #f))
(skip-ws skip-nl?)))))
(when eof? (unexpected-eof))
(cond
[(eq? current-char #\")
(next-char)
#f]
[(eq? current-char #\\)
(next-char)
(when eof? (unexpected-eof))
(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)
(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]))
(next-char) (let ([ch (read-one-char)])
(when eof? (unexpected-eof)) (if ch
(if (eq? current-char #\") (read-chars (cons ch accum) (fix+ len 1))
(begin (values accum len))))
(next-char)
(values accum len))
(read-chars (cons (read-one-char) accum) (fix+ len 1))))
(next-char)
(call-with-values (call-with-values
read-chars read-chars
(lambda (revchars len) (lambda (revchars len)
@ -219,165 +294,23 @@
(iter (fix- len 1) revchars) (iter (fix- len 1) revchars)
str)))) 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-vector) undefined)
(define (read-struct) undefined) (define (read-struct) undefined)
(define (read-symbol) undefined) (define (read-symbol) undefined)
(define (skip-whitespace) (define (skip-whitespace)
(cond (unless eof?
[(whitespace? current-char) (cond
(next-char) [(whitespace? current-char)
(skip-whitespace)]
[(eq? current-char #\;)
(define (skip-until-newline)
(next-char) (next-char)
(if (eq? current-char #\Newline) (skip-whitespace)]
[(eq? current-char #\;)
(define (skip-until-newline)
(let ([ch current-char])
(next-char) (next-char)
(unless eof? (skip-until-newline)))) (unless (eq? ch #\Newline)
(skip-until-newline)])) (skip-until-newline))))
(skip-until-newline)])))
(define (next-char) (define (next-char)
(if eof? (if eof?
@ -412,9 +345,17 @@
(define (whitespace? ch) (define (whitespace? ch)
(memq? ch '(#\Space #\Tab #\VTab #\Page #\Newline))) (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))) (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) (define (upcase-char? ch)
(and (fix>= ch #\A) (fix<= ch #\Z))) (and (fix>= ch #\A) (fix<= ch #\Z)))
@ -425,7 +366,7 @@
(or (upcase-char? ch) (downcase-char? ch))) (or (upcase-char? ch) (downcase-char? ch)))
(define (alphanumeric-char? ch) (define (alphanumeric-char? ch)
(or (numeric-char? ch) (alphabetic-char? ch))) (or (decimal-char? ch) (alphabetic-char? ch)))
(define (symbol-char? ch) (define (symbol-char? ch)
(or (alphanumeric-char? ch) (or (alphanumeric-char? ch)
@ -447,7 +388,7 @@
(define (digit->integer ch) (define (digit->integer ch)
(cond (cond
[(numeric-char? ch) (fix- ch #\0)] [(decimal-char? ch) (fix- ch #\0)]
[(upcase-char? ch) (fix+ 10 (fix- ch #\A))] [(upcase-char? ch) (fix+ 10 (fix- ch #\A))]
[(downcase-char? ch) (fix+ 10 (fix- ch #\a))] [(downcase-char? ch) (fix+ 10 (fix- ch #\a))]
[else #f])) [else #f]))