adding expt and char utils

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) {

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[] = {

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,

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>=? string-ci<? 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
 

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),

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,