From a27fe20de9eb4e9a14e1961e080bbd00ce7774d7 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 2 Apr 2009 17:02:40 +0900 Subject: [PATCH] handling variadic comparison opcodes --- debug.c | 6 +- eval.c | 455 +++++++++++++++++++++++++++--------------------------- eval.h | 2 + init.scm | 17 +- opcodes.c | 1 + sexp.c | 4 + 6 files changed, 254 insertions(+), 231 deletions(-) diff --git a/debug.c b/debug.c index 50fa6cb7..6bdc8b01 100644 --- a/debug.c +++ b/debug.c @@ -7,14 +7,14 @@ static const char* reverse_opcode_names[] = "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "EVAL", "JUMP-UNLESS", "JUMP", "PUSH", "DROP", "STACK-REF", "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF", - "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "NULL?", - "FIXNUM?", "SYMBOL?", "CHAR?", + "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "AND", + "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?", "EOF?", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT", "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", "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) { diff --git a/eval.c b/eval.c index 0bcb1d7e..dd242cd6 100644 --- a/eval.c +++ b/eval.c @@ -21,33 +21,10 @@ static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol; #define disasm(...) #endif -/*************************** prototypes *******************************/ - 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 void sexp_context_patch_label (sexp context, sexp_sint_t label); 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_standard_env (sexp version); @@ -320,6 +297,145 @@ static sexp sexp_compile_error(char *message, sexp irritants) { analyze_check_exception(var); \ } 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) { sexp op, cell, res; loop: @@ -398,145 +514,6 @@ static sexp analyze (sexp x, sexp context) { 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) { sexp_sint_t label = sexp_context_pos(context); sexp_context_pos(context) += sizeof(sexp_uint_t); @@ -559,38 +536,6 @@ static sexp finalize_bytecode (sexp 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) { emit_push(value, context); } @@ -626,20 +571,6 @@ static void generate_cnd (sexp cnd, sexp context) { 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, sexp fv, sexp context, int unboxp) { sexp_uint_t i; @@ -662,6 +593,20 @@ static void generate_non_global_ref (sexp name, sexp cell, sexp lambda, 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) { sexp ref = sexp_set_var(set), lambda; /* compile the value */ @@ -686,13 +631,6 @@ static void generate_set (sexp set, sexp 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) { sexp ls, op = sexp_car(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) : sexp_opcode_code(op), context); 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_TYPE_PREDICATE: /* 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 */ - if (num_args > 2) { - if (sexp_opcode_class(op) == OPC_ARITHMETIC - || sexp_opcode_class(op) == OPC_ARITHMETIC_INV) { - for (i=num_args-2; i>0; i--) - emit(sexp_opcode_code(op), context); - } else if (sexp_opcode_class(op) == OPC_ARITHMETIC_CMP) { - /* XXXX handle folding of comparisons */ - } - } + if ((num_args > 2) + && (sexp_opcode_class(op) == OPC_ARITHMETIC + || sexp_opcode_class(op) == OPC_ARITHMETIC_INV)) + for (i=num_args-2; i>0; i--) + emit(sexp_opcode_code(op), context); 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; } +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) { sexp fv, ls, ctx, flags, bc, len, ref, vec, prev_lambda, prev_fv; 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) { sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), 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); top--; break; + case OP_AND: + _ARG2 = sexp_make_boolean((_ARG1 != SEXP_FALSE) && (_ARG2 != SEXP_FALSE)); + top--; + break; case OP_EOFP: _ARG1 = sexp_make_boolean(_ARG1 == SEXP_EOF); break; case OP_NULLP: @@ -1400,6 +1397,11 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { _ARG2 = SEXP_UNDEF; top--; break; + } else if (sexp_charp(_ARG1)) { + sexp_write_char(sexp_unbox_character(_ARG1), _ARG2); + _ARG2 = SEXP_UNDEF; + top--; + break; } /* ... FALLTHROUGH ... */ 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); _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i); 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: i = sexp_unbox_integer(stack[fp]); stack[fp-i] = _ARG1; diff --git a/eval.h b/eval.h index 8a7a791b..19c6e01a 100644 --- a/eval.h +++ b/eval.h @@ -82,6 +82,7 @@ enum opcode_names { OP_STRING_LENGTH, OP_MAKE_PROCEDURE, OP_MAKE_VECTOR, + OP_AND, OP_NULLP, OP_INTEGERP, OP_SYMBOLP, @@ -118,6 +119,7 @@ enum opcode_names { OP_FLUSH_OUTPUT, OP_READ, OP_READ_CHAR, + OP_PEEK_CHAR, OP_RET, OP_DONE, }; diff --git a/init.scm b/init.scm index 78332557..a06c5acc 100644 --- a/init.scm +++ b/init.scm @@ -3,8 +3,6 @@ ;; remainder modulo ;; number->string string->number ;; symbol->string string->symbol -;; char-alphabetic? char-numeric? char-whitespace? -;; char-upper-case? char-lower-case? ;; make-string ;; string=? string-ci=? string? ;; string<=? string>=? string-ci? string-ci<=? string-ci>=? @@ -12,7 +10,6 @@ ;; values call-with-values dynamic-wind ;; call-with-input-file call-with-output-file ;; with-input-from-file with-output-to-file -;; peek-char char-ready? ;; provide c[ad]{2,4}r @@ -298,6 +295,15 @@ ;; 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 (charinteger a) (char->integer b))) (define (char>? a b) (> (char->integer a) (char->integer b))) @@ -400,7 +406,10 @@ (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))) diff --git a/opcodes.c b/opcodes.c index 813c4d37..c8fb6d66 100644 --- a/opcodes.c +++ b/opcodes.c @@ -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_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_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), _FN2(0, 0, "equal?", sexp_equalp), _FN1(0, "list?", sexp_listp), diff --git a/sexp.c b/sexp.c index fd55200a..702afcc4 100644 --- a/sexp.c +++ b/sexp.c @@ -573,6 +573,10 @@ void sexp_write (sexp obj, sexp out) { sexp_write_string("#\\space", out); else if (obj == sexp_make_character('\n')) 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)) && (sexp_unbox_character(obj) < 127)) sexp_printf(out, "#\\%c", sexp_unbox_character(obj));