Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 06:09:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

handling variadic comparison opcodes

Browse source
This commit is contained in:
Alex Shinn 2009-04-02 17:02:40 +09:00
parent 26eacabad9
commit a27fe20de9
6 changed files with 254 additions and 231 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
debug.c
View file

@ -7,14 +7,14 @@ static const char* reverse_opcode_names[] =
"FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "EVAL", "JUMP-UNLESS", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "EVAL", "JUMP-UNLESS",
"JUMP", "PUSH", "DROP", "STACK-REF", "LOCAL-REF", "LOCAL-SET", "JUMP", "PUSH", "DROP", "STACK-REF", "LOCAL-REF", "LOCAL-SET",
"CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF", "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF",
"STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "NULL?", "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "AND",
"FIXNUM?", "SYMBOL?", "CHAR?", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?",
"EOF?", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", "EOF?", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB",
"MUL", "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQN", "EQ", "MUL", "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQN", "EQ",
"EXACT->INEXACT", "INEXACT->EXACT", "EXACT->INEXACT", "INEXACT->EXACT",
"CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE",
"DISPLAY", "WRITE", "WRITE-CHAR", "DISPLAY", "WRITE", "WRITE-CHAR",
"NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "RET", "DONE", "NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "PEEK-CHAR", "RET", "DONE",
}; };
void disasm (sexp bc, sexp out) { void disasm (sexp bc, sexp out) {

455
eval.c
View file

@ -21,33 +21,10 @@ static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol;
#define disasm(...) #define disasm(...)
#endif #endif
/*************************** prototypes *******************************/
static sexp analyze (sexp x, sexp context); static sexp analyze (sexp x, sexp context);
static sexp analyze_lambda (sexp x, sexp context);
static sexp analyze_seq (sexp ls, sexp context);
static sexp analyze_if (sexp x, sexp context);
static sexp analyze_app (sexp x, sexp context);
static sexp analyze_define (sexp x, sexp context);
static sexp analyze_var_ref (sexp x, sexp context);
static sexp analyze_set (sexp x, sexp context);
static sexp analyze_define_syntax (sexp x, sexp context);
static sexp_sint_t sexp_context_make_label (sexp context); static sexp_sint_t sexp_context_make_label (sexp context);
static void sexp_context_patch_label (sexp context, sexp_sint_t label); static void sexp_context_patch_label (sexp context, sexp_sint_t label);
static void generate (sexp x, sexp context); static void generate (sexp x, sexp context);
static void generate_lit (sexp value, sexp context);
static void generate_seq (sexp app, sexp context);
static void generate_cnd (sexp cnd, sexp context);
static void generate_ref (sexp ref, sexp context, int unboxp);
static void generate_non_global_ref (sexp name, sexp loc, sexp lambda,
sexp fv, sexp context, int unboxp);
static void generate_set (sexp set, sexp context);
static void generate_app (sexp app, sexp context);
static void generate_opcode_app (sexp app, sexp context);
static void generate_general_app (sexp app, sexp context);
static void generate_lambda (sexp lambda, sexp context);
static sexp sexp_make_null_env (sexp version); static sexp sexp_make_null_env (sexp version);
static sexp sexp_make_standard_env (sexp version); static sexp sexp_make_standard_env (sexp version);
@ -320,6 +297,145 @@ static sexp sexp_compile_error(char *message, sexp irritants) {
analyze_check_exception(var); \ analyze_check_exception(var); \
} while (0) } while (0)
static sexp analyze_app (sexp x, sexp context) {
sexp res=SEXP_NULL, tmp;
for ( ; sexp_pairp(x); x=sexp_cdr(x)) {
analyze_bind(tmp, sexp_car(x), context);
sexp_push(res, tmp);
}
return sexp_nreverse(res);
}
static sexp analyze_seq (sexp ls, sexp context) {
sexp res, tmp;
if (sexp_nullp(ls))
res = SEXP_UNDEF;
else if (sexp_nullp(sexp_cdr(ls)))
res = analyze(sexp_car(ls), context);
else {
res = sexp_alloc_type(seq, SEXP_SEQ);
tmp = analyze_app(ls, context);
analyze_check_exception(tmp);
sexp_seq_ls(res) = tmp;
}
return res;
}
static sexp analyze_var_ref (sexp x, sexp context) {
sexp cell = env_cell(sexp_context_env(context), x);
if (! cell) {
if (sexp_synclop(x)) {
cell = env_cell_create(sexp_synclo_env(x),
sexp_synclo_expr(x),
SEXP_UNDEF);
x = sexp_synclo_expr(x);
} else {
cell = env_cell_create(sexp_context_env(context), x, SEXP_UNDEF);
}
}
return sexp_make_ref(x, cell);
}
static sexp analyze_set (sexp x, sexp context) {
sexp ref, value;
ref = analyze_var_ref(sexp_cadr(x), context);
if (sexp_lambdap(sexp_ref_loc(ref)))
sexp_insert(sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref));
analyze_check_exception(ref);
analyze_bind(value, sexp_caddr(x), context);
return sexp_make_set(ref, value);
}
static sexp analyze_lambda (sexp x, sexp context) {
sexp res, body, ls, tmp, name, value, defs=SEXP_NULL;
/* verify syntax */
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))))
return sexp_compile_error("bad lambda syntax", sexp_list1(x));
for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls))
if (! sexp_idp(sexp_car(ls)))
return sexp_compile_error("non-symbol parameter", sexp_list1(x));
else if (sexp_memq(sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE)
return sexp_compile_error("duplicate parameter", sexp_list1(x));
/* build lambda and analyze body */
res = sexp_make_lambda(sexp_cadr(x));
context = sexp_child_context(context, res);
sexp_context_env(context)
= extend_env(sexp_context_env(context),
sexp_flatten_dot(sexp_lambda_params(res)),
res);
sexp_env_lambda(sexp_context_env(context)) = res;
body = analyze_seq(sexp_cddr(x), context);
analyze_check_exception(body);
/* delayed analyze internal defines */
for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) {
tmp = sexp_car(ls);
if (sexp_pairp(sexp_cadr(tmp))) {
name = sexp_caadr(tmp);
value = analyze_lambda(sexp_cons(SEXP_UNDEF, sexp_cons(sexp_cdadr(tmp),
sexp_cddr(tmp))),
context);
} else {
name = sexp_cadr(tmp);
value = analyze(sexp_caddr(tmp), context);
}
analyze_check_exception(value);
sexp_push(defs, sexp_make_set(analyze_var_ref(name, context), value));
}
if (sexp_pairp(defs)) {
if (! sexp_seqp(body)) {
tmp = sexp_alloc_type(seq, SEXP_SEQ);
sexp_seq_ls(tmp) = sexp_list1(body);
body = tmp;
}
sexp_seq_ls(body) = sexp_append(defs, sexp_seq_ls(body));
}
sexp_lambda_body(res) = body;
return res;
}
static sexp analyze_if (sexp x, sexp context) {
sexp test, pass, fail, fail_expr;
analyze_bind(test, sexp_cadr(x), context);
analyze_bind(pass, sexp_caddr(x), context);
fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_UNDEF;
analyze_bind(fail, fail_expr, context);
return sexp_make_cnd(test, pass, fail);
}
static sexp analyze_define (sexp x, sexp context) {
sexp ref, name, value, env = sexp_context_env(context);
name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x));
if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) {
sexp_push(sexp_env_bindings(env),
sexp_cons(name, sexp_context_lambda(context)));
sexp_push(sexp_lambda_sv(sexp_env_lambda(env)), name);
sexp_push(sexp_lambda_locals(sexp_env_lambda(env)), name);
sexp_push(sexp_lambda_defs(sexp_env_lambda(env)), x);
return SEXP_UNDEF;
} else {
env_cell_create(env, name, SEXP_DEF);
}
if (sexp_pairp(sexp_cadr(x)))
value = analyze_lambda(sexp_cons(SEXP_UNDEF,
sexp_cons(sexp_cdadr(x), sexp_cddr(x))),
context);
else
value = analyze(sexp_caddr(x), context);
analyze_check_exception(value);
ref = analyze_var_ref(name, context);
analyze_check_exception(ref);
return sexp_make_set(ref, value);
}
static sexp analyze_define_syntax (sexp x, sexp context) {
sexp name = sexp_cadr(x), cell, proc;
proc = eval_in_context(sexp_caddr(x), context);
analyze_check_exception(proc);
cell = env_cell_create(sexp_context_env(context), name, SEXP_UNDEF);
sexp_cdr(cell) = sexp_make_macro(proc, sexp_context_env(context));
return SEXP_UNDEF;
}
static sexp analyze (sexp x, sexp context) { static sexp analyze (sexp x, sexp context) {
sexp op, cell, res; sexp op, cell, res;
loop: loop:
@ -398,145 +514,6 @@ static sexp analyze (sexp x, sexp context) {
return res; return res;
} }
static sexp analyze_lambda (sexp x, sexp context) {
sexp res, body, ls, tmp, name, value, defs=SEXP_NULL;
/* verify syntax */
if (! (sexp_pairp(sexp_cdr(x)) && sexp_pairp(sexp_cddr(x))))
return sexp_compile_error("bad lambda syntax", sexp_list1(x));
for (ls=sexp_cadr(x); sexp_pairp(ls); ls=sexp_cdr(ls))
if (! sexp_idp(sexp_car(ls)))
return sexp_compile_error("non-symbol parameter", sexp_list1(x));
else if (sexp_memq(sexp_car(ls), sexp_cdr(ls)) != SEXP_FALSE)
return sexp_compile_error("duplicate parameter", sexp_list1(x));
/* build lambda and analyze body */
res = sexp_make_lambda(sexp_cadr(x));
context = sexp_child_context(context, res);
sexp_context_env(context)
= extend_env(sexp_context_env(context),
sexp_flatten_dot(sexp_lambda_params(res)),
res);
sexp_env_lambda(sexp_context_env(context)) = res;
body = analyze_seq(sexp_cddr(x), context);
analyze_check_exception(body);
/* delayed analyze internal defines */
for (ls=sexp_lambda_defs(res); sexp_pairp(ls); ls=sexp_cdr(ls)) {
tmp = sexp_car(ls);
if (sexp_pairp(sexp_cadr(tmp))) {
name = sexp_caadr(tmp);
value = analyze_lambda(sexp_cons(SEXP_UNDEF, sexp_cons(sexp_cdadr(tmp),
sexp_cddr(tmp))),
context);
} else {
name = sexp_cadr(tmp);
value = analyze(sexp_caddr(tmp), context);
}
analyze_check_exception(value);
sexp_push(defs, sexp_make_set(analyze_var_ref(name, context), value));
}
if (sexp_pairp(defs)) {
if (! sexp_seqp(body)) {
tmp = sexp_alloc_type(seq, SEXP_SEQ);
sexp_seq_ls(tmp) = sexp_list1(body);
body = tmp;
}
sexp_seq_ls(body) = sexp_append(defs, sexp_seq_ls(body));
}
sexp_lambda_body(res) = body;
return res;
}
static sexp analyze_seq (sexp ls, sexp context) {
sexp res, tmp;
if (sexp_nullp(ls))
res = SEXP_UNDEF;
else if (sexp_nullp(sexp_cdr(ls)))
res = analyze(sexp_car(ls), context);
else {
res = sexp_alloc_type(seq, SEXP_SEQ);
tmp = analyze_app(ls, context);
analyze_check_exception(tmp);
sexp_seq_ls(res) = tmp;
}
return res;
}
static sexp analyze_if (sexp x, sexp context) {
sexp test, pass, fail, fail_expr;
analyze_bind(test, sexp_cadr(x), context);
analyze_bind(pass, sexp_caddr(x), context);
fail_expr = sexp_pairp(sexp_cdddr(x)) ? sexp_cadddr(x) : SEXP_UNDEF;
analyze_bind(fail, fail_expr, context);
return sexp_make_cnd(test, pass, fail);
}
static sexp analyze_app (sexp x, sexp context) {
sexp res=SEXP_NULL, tmp;
for ( ; sexp_pairp(x); x=sexp_cdr(x)) {
analyze_bind(tmp, sexp_car(x), context);
sexp_push(res, tmp);
}
return sexp_nreverse(res);
}
static sexp analyze_define (sexp x, sexp context) {
sexp ref, name, value, env = sexp_context_env(context);
name = (sexp_pairp(sexp_cadr(x)) ? sexp_caadr(x) : sexp_cadr(x));
if (sexp_env_lambda(env) && sexp_lambdap(sexp_env_lambda(env))) {
sexp_push(sexp_env_bindings(env),
sexp_cons(name, sexp_context_lambda(context)));
sexp_push(sexp_lambda_sv(sexp_env_lambda(env)), name);
sexp_push(sexp_lambda_locals(sexp_env_lambda(env)), name);
sexp_push(sexp_lambda_defs(sexp_env_lambda(env)), x);
return SEXP_UNDEF;
} else {
env_cell_create(env, name, SEXP_DEF);
}
if (sexp_pairp(sexp_cadr(x)))
value = analyze_lambda(sexp_cons(SEXP_UNDEF,
sexp_cons(sexp_cdadr(x), sexp_cddr(x))),
context);
else
value = analyze(sexp_caddr(x), context);
analyze_check_exception(value);
ref = analyze_var_ref(name, context);
analyze_check_exception(ref);
return sexp_make_set(ref, value);
}
static sexp analyze_var_ref (sexp x, sexp context) {
sexp cell = env_cell(sexp_context_env(context), x);
if (! cell) {
if (sexp_synclop(x)) {
cell = env_cell_create(sexp_synclo_env(x),
sexp_synclo_expr(x),
SEXP_UNDEF);
x = sexp_synclo_expr(x);
} else {
cell = env_cell_create(sexp_context_env(context), x, SEXP_UNDEF);
}
}
return sexp_make_ref(x, cell);
}
static sexp analyze_set (sexp x, sexp context) {
sexp ref, value;
ref = analyze_var_ref(sexp_cadr(x), context);
if (sexp_lambdap(sexp_ref_loc(ref)))
sexp_insert(sexp_lambda_sv(sexp_ref_loc(ref)), sexp_ref_name(ref));
analyze_check_exception(ref);
analyze_bind(value, sexp_caddr(x), context);
return sexp_make_set(ref, value);
}
static sexp analyze_define_syntax (sexp x, sexp context) {
sexp name = sexp_cadr(x), cell, proc;
proc = eval_in_context(sexp_caddr(x), context);
analyze_check_exception(proc);
cell = env_cell_create(sexp_context_env(context), name, SEXP_UNDEF);
sexp_cdr(cell) = sexp_make_macro(proc, sexp_context_env(context));
return SEXP_UNDEF;
}
static sexp_sint_t sexp_context_make_label (sexp context) { static sexp_sint_t sexp_context_make_label (sexp context) {
sexp_sint_t label = sexp_context_pos(context); sexp_sint_t label = sexp_context_pos(context);
sexp_context_pos(context) += sizeof(sexp_uint_t); sexp_context_pos(context) += sizeof(sexp_uint_t);
@ -559,38 +536,6 @@ static sexp finalize_bytecode (sexp context) {
return sexp_context_bc(context); return sexp_context_bc(context);
} }
static void generate (sexp x, sexp context) {
if (sexp_pointerp(x)) {
switch (sexp_pointer_tag(x)) {
case SEXP_PAIR:
generate_app(x, context);
break;
case SEXP_LAMBDA:
generate_lambda(x, context);
break;
case SEXP_CND:
generate_cnd(x, context);
break;
case SEXP_REF:
generate_ref(x, context, 1);
break;
case SEXP_SET:
generate_set(x, context);
break;
case SEXP_SEQ:
generate_seq(sexp_seq_ls(x), context);
break;
case SEXP_LIT:
generate_lit(sexp_lit_value(x), context);
break;
default:
generate_lit(x, context);
}
} else {
generate_lit(x, context);
}
}
static void generate_lit (sexp value, sexp context) { static void generate_lit (sexp value, sexp context) {
emit_push(value, context); emit_push(value, context);
} }
@ -626,20 +571,6 @@ static void generate_cnd (sexp cnd, sexp context) {
sexp_context_patch_label(context, label2); sexp_context_patch_label(context, label2);
} }
static void generate_ref (sexp ref, sexp context, int unboxp) {
sexp lam;
if (! sexp_lambdap(sexp_ref_loc(ref))) {
/* global ref */
emit_push(sexp_ref_cell(ref), context);
if (unboxp)
emit(OP_CDR, context);
} else {
lam = sexp_context_lambda(context);
generate_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), lam,
sexp_lambda_fv(lam), context, unboxp);
}
}
static void generate_non_global_ref (sexp name, sexp cell, sexp lambda, static void generate_non_global_ref (sexp name, sexp cell, sexp lambda,
sexp fv, sexp context, int unboxp) { sexp fv, sexp context, int unboxp) {
sexp_uint_t i; sexp_uint_t i;
@ -662,6 +593,20 @@ static void generate_non_global_ref (sexp name, sexp cell, sexp lambda,
sexp_context_depth(context)++; sexp_context_depth(context)++;
} }
static void generate_ref (sexp ref, sexp context, int unboxp) {
sexp lam;
if (! sexp_lambdap(sexp_ref_loc(ref))) {
/* global ref */
emit_push(sexp_ref_cell(ref), context);
if (unboxp)
emit(OP_CDR, context);
} else {
lam = sexp_context_lambda(context);
generate_non_global_ref(sexp_ref_name(ref), sexp_ref_cell(ref), lam,
sexp_lambda_fv(lam), context, unboxp);
}
}
static void generate_set (sexp set, sexp context) { static void generate_set (sexp set, sexp context) {
sexp ref = sexp_set_var(set), lambda; sexp ref = sexp_set_var(set), lambda;
/* compile the value */ /* compile the value */
@ -686,13 +631,6 @@ static void generate_set (sexp set, sexp context) {
sexp_context_depth(context)--; sexp_context_depth(context)--;
} }
static void generate_app (sexp app, sexp context) {
if (sexp_opcodep(sexp_car(app)))
generate_opcode_app(app, context);
else
generate_general_app(app, context);
}
static void generate_opcode_app (sexp app, sexp context) { static void generate_opcode_app (sexp app, sexp context) {
sexp ls, op = sexp_car(app); sexp ls, op = sexp_car(app);
sexp_sint_t i, num_args = sexp_unbox_integer(sexp_length(sexp_cdr(app))); sexp_sint_t i, num_args = sexp_unbox_integer(sexp_length(sexp_cdr(app)));
@ -722,6 +660,26 @@ static void generate_opcode_app (sexp app, sexp context) {
emit((num_args == 1) ? sexp_opcode_inverse(op) emit((num_args == 1) ? sexp_opcode_inverse(op)
: sexp_opcode_code(op), context); : sexp_opcode_code(op), context);
break; break;
case OPC_ARITHMETIC_CMP:
if (num_args > 2) {
emit(OP_STACK_REF, context);
emit_word(2, context);
emit(OP_STACK_REF, context);
emit_word(2, context);
emit(sexp_opcode_code(op), context);
emit(OP_AND, context);
for (i=num_args-2; i>0; i--) {
emit(OP_STACK_REF, context);
emit_word(3, context);
emit(OP_STACK_REF, context);
emit_word(3, context);
emit(sexp_opcode_code(op), context);
emit(OP_AND, context);
emit(OP_AND, context);
}
} else
emit(sexp_opcode_code(op), context);
break;
case OPC_FOREIGN: case OPC_FOREIGN:
case OPC_TYPE_PREDICATE: case OPC_TYPE_PREDICATE:
/* push the funtion pointer for foreign calls */ /* push the funtion pointer for foreign calls */
@ -737,15 +695,11 @@ static void generate_opcode_app (sexp app, sexp context) {
} }
/* emit optional folding of operator */ /* emit optional folding of operator */
if (num_args > 2) { if ((num_args > 2)
if (sexp_opcode_class(op) == OPC_ARITHMETIC && (sexp_opcode_class(op) == OPC_ARITHMETIC
|| sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { || sexp_opcode_class(op) == OPC_ARITHMETIC_INV))
for (i=num_args-2; i>0; i--) for (i=num_args-2; i>0; i--)
emit(sexp_opcode_code(op), context); emit(sexp_opcode_code(op), context);
} else if (sexp_opcode_class(op) == OPC_ARITHMETIC_CMP) {
/* XXXX handle folding of comparisons */
}
}
sexp_context_depth(context) -= (num_args-1); sexp_context_depth(context) -= (num_args-1);
} }
@ -770,6 +724,13 @@ static void generate_general_app (sexp app, sexp context) {
sexp_context_depth(context) -= len; sexp_context_depth(context) -= len;
} }
static void generate_app (sexp app, sexp context) {
if (sexp_opcodep(sexp_car(app)))
generate_opcode_app(app, context);
else
generate_general_app(app, context);
}
static void generate_lambda (sexp lambda, sexp context) { static void generate_lambda (sexp lambda, sexp context) {
sexp fv, ls, ctx, flags, bc, len, ref, vec, prev_lambda, prev_fv; sexp fv, ls, ctx, flags, bc, len, ref, vec, prev_lambda, prev_fv;
sexp_uint_t k; sexp_uint_t k;
@ -829,6 +790,38 @@ static void generate_lambda (sexp lambda, sexp context) {
} }
} }
static void generate (sexp x, sexp context) {
if (sexp_pointerp(x)) {
switch (sexp_pointer_tag(x)) {
case SEXP_PAIR:
generate_app(x, context);
break;
case SEXP_LAMBDA:
generate_lambda(x, context);
break;
case SEXP_CND:
generate_cnd(x, context);
break;
case SEXP_REF:
generate_ref(x, context, 1);
break;
case SEXP_SET:
generate_set(x, context);
break;
case SEXP_SEQ:
generate_seq(sexp_seq_ls(x), context);
break;
case SEXP_LIT:
generate_lit(sexp_lit_value(x), context);
break;
default:
generate_lit(x, context);
}
} else {
generate_lit(x, context);
}
}
static sexp insert_free_var (sexp x, sexp fv) { static sexp insert_free_var (sexp x, sexp fv) {
sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls; sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls;
for (ls=fv; sexp_pairp(ls); ls=sexp_cdr(ls)) for (ls=fv; sexp_pairp(ls); ls=sexp_cdr(ls))
@ -1186,6 +1179,10 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
_ARG2 = sexp_make_vector(_ARG1, _ARG2); _ARG2 = sexp_make_vector(_ARG1, _ARG2);
top--; top--;
break; break;
case OP_AND:
_ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE));
top--;
break;
case OP_EOFP: case OP_EOFP:
_ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break;
case OP_NULLP: case OP_NULLP:
@ -1400,6 +1397,11 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
_ARG2 = SEXP_UNDEF; _ARG2 = SEXP_UNDEF;
top--; top--;
break; break;
} else if (sexp_charp(_ARG1)) {
sexp_write_char(sexp_unbox_character(_ARG1), _ARG2);
_ARG2 = SEXP_UNDEF;
top--;
break;
} }
/* ... FALLTHROUGH ... */ /* ... FALLTHROUGH ... */
case OP_WRITE: case OP_WRITE:
@ -1428,6 +1430,11 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
i = sexp_read_char(_ARG1); i = sexp_read_char(_ARG1);
_ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i);
break; break;
case OP_PEEK_CHAR:
i = sexp_read_char(_ARG1);
sexp_push_char(i, _ARG1);
_ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i);
break;
case OP_RET: case OP_RET:
i = sexp_unbox_integer(stack[fp]); i = sexp_unbox_integer(stack[fp]);
stack[fp-i] = _ARG1; stack[fp-i] = _ARG1;

2
eval.h
View file

@ -82,6 +82,7 @@ enum opcode_names {
OP_STRING_LENGTH, OP_STRING_LENGTH,
OP_MAKE_PROCEDURE, OP_MAKE_PROCEDURE,
OP_MAKE_VECTOR, OP_MAKE_VECTOR,
OP_AND,
OP_NULLP, OP_NULLP,
OP_INTEGERP, OP_INTEGERP,
OP_SYMBOLP, OP_SYMBOLP,
@ -118,6 +119,7 @@ enum opcode_names {
OP_FLUSH_OUTPUT, OP_FLUSH_OUTPUT,
OP_READ, OP_READ,
OP_READ_CHAR, OP_READ_CHAR,
OP_PEEK_CHAR,
OP_RET, OP_RET,
OP_DONE, OP_DONE,
}; };

17
init.scm
View file

@ -3,8 +3,6 @@
;; remainder modulo ;; remainder modulo
;; number->string string->number ;; number->string string->number
;; symbol->string string->symbol ;; symbol->string string->symbol
;; char-alphabetic? char-numeric? char-whitespace?
;; char-upper-case? char-lower-case?
;; make-string ;; make-string
;; string=? string-ci=? string<? string>? ;; string=? string-ci=? string<? string>?
;; string<=? string>=? string-ci<? string-ci>? string-ci<=? string-ci>=? ;; string<=? string>=? string-ci<? string-ci>? string-ci<=? string-ci>=?
@ -12,7 +10,6 @@
;; values call-with-values dynamic-wind ;; values call-with-values dynamic-wind
;; call-with-input-file call-with-output-file ;; call-with-input-file call-with-output-file
;; with-input-from-file with-output-to-file ;; with-input-from-file with-output-to-file
;; peek-char char-ready?
;; provide c[ad]{2,4}r ;; provide c[ad]{2,4}r
@ -298,6 +295,15 @@
;; char utils ;; char utils
(define (char-alphabetic? ch) (<= 65 (char->integer (char-upcase ch)) 90))
(define (char-numeric? ch) (<= 48 (char->integer ch) 57))
(define (char-whitespace? ch)
(if (eq? ch #\space)
#t
(if (eq? ch #\tab) #t (if (eq? ch #\newline) #t (eq? ch #\return)))))
(define (char-upper-case? ch) (<= 65 (char->integer ch) 90))
(define (char-lower-case? ch) (<= 97 (char->integer ch) 122))
(define (char=? a b) (= (char->integer a) (char->integer b))) (define (char=? a b) (= (char->integer a) (char->integer b)))
(define (char<? a b) (< (char->integer a) (char->integer b))) (define (char<? a b) (< (char->integer a) (char->integer b)))
(define (char>? a b) (> (char->integer a) (char->integer b))) (define (char>? a b) (> (char->integer a) (char->integer b)))
@ -400,7 +406,10 @@
(define (vector . args) (list->vector args)) (define (vector . args) (list->vector args))
;; miscellaneous ;; I/O utilities
(define (char-ready? . o)
(not (eof-object? (peek-char (if (pair? o) (car o) (current-input-port))))))
(define (load file) (%load file (interaction-environment))) (define (load file) (%load file (interaction-environment)))

1
opcodes.c
View file

@ -62,6 +62,7 @@ _OP(OPC_IO, OP_NEWLINE, 0, 3, 0, SEXP_OPORT, 0, "newline", (sexp)"*current-outpu
_OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)"*current-output-port*", NULL), _OP(OPC_IO, OP_FLUSH_OUTPUT, 0, 3, 0, SEXP_OPORT, 0, "flush-output", (sexp)"*current-output-port*", NULL),
_OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)"*current-input-port*", NULL), _OP(OPC_IO, OP_READ, 0, 3, 0, SEXP_IPORT, 0, "read", (sexp)"*current-input-port*", NULL),
_OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL), _OP(OPC_IO, OP_READ_CHAR, 0, 3, 0, SEXP_IPORT, 0, "read-char", (sexp)"*current-input-port*", NULL),
_OP(OPC_IO, OP_PEEK_CHAR, 0, 3, 0, SEXP_IPORT, 0, "peek-char", (sexp)"*current-input-port*", NULL),
_OP(OPC_GENERIC, OP_EVAL, 1, 3, 0, 0, 0, "eval", (sexp)"*interaction-environment*", NULL), _OP(OPC_GENERIC, OP_EVAL, 1, 3, 0, 0, 0, "eval", (sexp)"*interaction-environment*", NULL),
_FN2(0, 0, "equal?", sexp_equalp), _FN2(0, 0, "equal?", sexp_equalp),
_FN1(0, "list?", sexp_listp), _FN1(0, "list?", sexp_listp),

4
sexp.c
View file

@ -573,6 +573,10 @@ void sexp_write (sexp obj, sexp out) {
sexp_write_string("#\\space", out); sexp_write_string("#\\space", out);
else if (obj == sexp_make_character('\n')) else if (obj == sexp_make_character('\n'))
sexp_write_string("#\\newline", out); sexp_write_string("#\\newline", out);
else if (obj == sexp_make_character('\r'))
sexp_write_string("#\\return", out);
else if (obj == sexp_make_character('\t'))
sexp_write_string("#\\tab", out);
else if ((33 <= sexp_unbox_character(obj)) else if ((33 <= sexp_unbox_character(obj))
&& (sexp_unbox_character(obj) < 127)) && (sexp_unbox_character(obj) < 127))
sexp_printf(out, "#\\%c", sexp_unbox_character(obj)); sexp_printf(out, "#\\%c", sexp_unbox_character(obj));