diff --git a/debug.c b/debug.c index 90d5c8db..f08e818a 100644 --- a/debug.c +++ b/debug.c @@ -3,16 +3,17 @@ /* BSD-style license: http://synthcode.com/license.txt */ static const char* reverse_opcode_names[] = - {"NOOP", "ERROR", "RESUMECC", "CALLCC", "APPLY1", "TAIL_CALL", "CALL", - "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", "NULLP", "INTEGERP", "SYMBOLP", "CHARP", - "EOFP", "TYPEP", "CAR", "CDR", "SET_CAR", "SET_CDR", "CONS", "ADD", "SUB", + {"NOOP", "ERROR", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", + "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", "NULLP", "INTEGERP", "SYMBOLP", "CHARP", + "EOFP", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB", "MUL", "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQV", "EQ", - "CHAR->INTEGER", "INTEGER->CHAR", "DISPLAY", "WRITE", "WRITE_CHAR", - "NEWLINE", "FLUSH_OUTPUT", "READ", "READ_CHAR", "RET", "DONE", + "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE", + "DISPLAY", "WRITE", "WRITE-CHAR", + "NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "RET", "DONE", }; void disasm (sexp bc, sexp out) { diff --git a/eval.c b/eval.c index d6b4c8e8..ea8f8625 100644 --- a/eval.c +++ b/eval.c @@ -1336,6 +1336,12 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) { case OP_INT2CHAR: _ARG1 = sexp_make_character(sexp_unbox_integer(_ARG1)); break; + case OP_CHAR_UPCASE: + _ARG1 = sexp_make_character(toupper(sexp_unbox_character(_ARG1))); + break; + case OP_CHAR_DOWNCASE: + _ARG1 = sexp_make_character(tolower(sexp_unbox_character(_ARG1))); + break; case OP_DISPLAY: if (sexp_stringp(_ARG1)) { sexp_write_string(sexp_string_data(_ARG1), _ARG2); @@ -1454,6 +1460,32 @@ define_math_op(sexp_ceiling, ceil) #endif +static sexp sexp_expt (sexp x, sexp e) { + double res, x1, e1; + if (sexp_integerp(x)) + x1 = (double)sexp_unbox_integer(x); +#if USE_FLONUMS + else if (sexp_flonump(x)) + x1 = sexp_flonum_value(x); +#endif + else + return sexp_math_exception("not a number", x); + if (sexp_integerp(e)) + e1 = (double)sexp_unbox_integer(e); +#if USE_FLONUMS + else if (sexp_flonump(e)) + e1 = sexp_flonum_value(e); +#endif + else + return sexp_math_exception("not a number", e); + res = pow(x1, e1); +#if USE_FLONUMS + if ((res > SEXP_MAX_INT) || sexp_flonump(x) || sexp_flonump(e)) + return sexp_make_flonum(res); +#endif + return sexp_make_integer((sexp_sint_t)round(res)); +} + /*********************** standard environment *************************/ static struct sexp_struct core_forms[] = { diff --git a/eval.h b/eval.h index 4c42af99..494c25fb 100644 --- a/eval.h +++ b/eval.h @@ -111,6 +111,8 @@ enum opcode_names { OP_EQ, OP_CHAR2INT, OP_INT2CHAR, + OP_CHAR_UPCASE, + OP_CHAR_DOWNCASE, OP_DISPLAY, OP_WRITE, OP_WRITE_CHAR, diff --git a/init.scm b/init.scm index 93393e02..3ab9d4f7 100644 --- a/init.scm +++ b/init.scm @@ -1,15 +1,12 @@ ;; let-syntax letrec-syntax syntax-rules ;; number? complex? real? rational? integer? exact? inexact? -;; positive? negative? max min remainder -;; modulo numerator denominator -;; rationalize expt -;; make-rectangular make-polar real-part imag-part magnitude angle +;; remainder modulo ;; exact->inexact inexact->exact number->string string->number ;; symbol->string string->symbol ;; char-alphabetic? char-numeric? char-whitespace? ;; char-upper-case? char-lower-case? -;; char-upcase char-downcase make-string +;; make-string ;; string=? string-ci=? string? ;; string<=? string>=? string-ci? string-ci<=? string-ci>=? ;; substring string-append string-copy @@ -345,19 +342,35 @@ (define (zero? x) (= x 0)) (define (positive? x) (> x 0)) (define (negative? x) (< x 0)) - (define (even? n) (= (remainder n 2) 0)) (define (odd? n) (= (remainder n 2) 1)) -;; (define (abs x) (if (< x 0) (- x) x)) +(define (abs x) (if (< x 0) (- x) x)) -;; (define (gcd a b) -;; (if (= b 0) -;; a -;; (gcd b (modulo a b)))) +(define (gcd a b) + (if (= b 0) + a + (gcd b (modulo a b)))) -;; (define (lcm a b) -;; (quotient (* a b) (gcd a b))) +(define (lcm a b) + (quotient (* a b) (gcd a b))) + +(define (max x . rest) + (let lp ((hi x) (ls rest)) + (if (null? ls) + hi + (lp (if (> (car ls) hi) (car ls) hi) (cdr ls))))) + +(define (min x . rest) + (let lp ((lo x) (ls rest)) + (if (null? ls) + lo + (lp (if (< (car ls) lo) (car ls) lo) (cdr ls))))) + +(define (real-part z) z) +(define (imag-part z) 0.0) +(define magnitude abs) +(define (angle z) (if (< z 0) 3.141592653589793 0)) ;; vector utils diff --git a/opcodes.c b/opcodes.c index 608a0d6f..1ada2e22 100644 --- a/opcodes.c +++ b/opcodes.c @@ -21,6 +21,8 @@ _OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", _OP(OPC_ACCESSOR, OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", NULL, NULL), _OP(OPC_GENERIC, OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", NULL, NULL), _OP(OPC_GENERIC, OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", NULL, NULL), +_OP(OPC_GENERIC, OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", NULL, NULL), +_OP(OPC_GENERIC, OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", NULL, NULL), _OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", NULL, NULL), _OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", NULL, NULL), _OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-", NULL, NULL), @@ -85,6 +87,7 @@ _FN1(0, "round", sexp_round), _FN1(0, "truncate", sexp_trunc), _FN1(0, "floor", sexp_floor), _FN1(0, "ceiling", sexp_ceiling), +_FN2(0, 0, "expt", sexp_expt), #endif _FN2(0, SEXP_PAIR, "memq", sexp_memq), _FN2(0, SEXP_PAIR, "assq", sexp_assq), diff --git a/sexp.h b/sexp.h index f51a5de5..04c67fd1 100644 --- a/sexp.h +++ b/sexp.h @@ -38,6 +38,9 @@ #define SEXP_CHAR_TAG 6 #define SEXP_EXTENDED_TAG 14 +#define SEXP_MAX_INT ((1<<29)-1) +#define SEXP_MIN_INT (-(1<<29)) + enum sexp_types { SEXP_OBJECT, SEXP_FIXNUM,