flushing out library

debug.c

@@ -6,12 +6,13 @@ 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", "STRING_REF", "STRING_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",
-   "DISPLAY", "WRITE", "WRITE_CHAR", "NEWLINE", "FLUSH_OUTPUT", "READ",
+   "CHAR->INTEGER", "INTEGER->CHAR", "DISPLAY", "WRITE", "WRITE_CHAR",
-   "READ_CHAR", "RET", "DONE",
+   "NEWLINE", "FLUSH_OUTPUT", "READ", "READ_CHAR", "RET", "DONE",
   };
 
 void disasm (sexp bc, sexp out) {

eval.c

@@ -135,6 +135,8 @@ static void shrink_bcode(sexp context, sexp_uint_t i) {
   if (sexp_bytecode_length(sexp_context_bc(context)) != i) {
     tmp = sexp_alloc_tagged(sexp_sizeof(bytecode) + i, SEXP_BYTECODE);
     sexp_bytecode_length(tmp) = i;
+    sexp_bytecode_literals(tmp)
+      = sexp_bytecode_literals(sexp_context_bc(context));
     memcpy(sexp_bytecode_data(tmp),
            sexp_bytecode_data(sexp_context_bc(context)),
            i);
@@ -151,6 +153,8 @@ static void expand_bcode(sexp context, sexp_uint_t size) {
                             SEXP_BYTECODE);
     sexp_bytecode_length(tmp)
       = sexp_bytecode_length(sexp_context_bc(context))*2;
+    sexp_bytecode_literals(tmp)
+      = sexp_bytecode_literals(sexp_context_bc(context));
     memcpy(sexp_bytecode_data(tmp),
            sexp_bytecode_data(sexp_context_bc(context)),
            sexp_bytecode_length(sexp_context_bc(context)));
@@ -174,6 +178,8 @@ static void emit_word(sexp_uint_t val, sexp context)  {
 static void emit_push(sexp obj, sexp context) {
   emit(OP_PUSH, context);
   emit_word((sexp_uint_t)obj, context);
+  if (sexp_pointerp(obj))
+    sexp_push(sexp_bytecode_literals(sexp_context_bc(context)), obj);
 }
 
 static sexp sexp_make_procedure(sexp flags, sexp num_args,
@@ -253,6 +259,7 @@ static sexp sexp_make_context(sexp *stack, sexp env) {
   sexp_context_bc(res)
     = sexp_alloc_tagged(sexp_sizeof(bytecode)+INIT_BCODE_SIZE, SEXP_BYTECODE);
   sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE;
+  sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL;
   sexp_context_lambda(res) = SEXP_FALSE;
   sexp_context_stack(res) = stack;
   sexp_context_env(res) = env;
@@ -289,10 +296,10 @@ static sexp sexp_identifier_eq (sexp e1, sexp id1, sexp e2, sexp id2) {
     id2 = sexp_synclo_expr(id2);
   }
   cell = env_cell(e1, id1);
-  if (sexp_lambdap(sexp_cdr(cell)))
+  if (cell && sexp_lambdap(sexp_cdr(cell)))
     lam1 = sexp_cdr(cell);
   cell = env_cell(e2, id2);
-  if (sexp_lambdap(sexp_cdr(cell)))
+  if (cell && sexp_lambdap(sexp_cdr(cell)))
     lam2 = sexp_cdr(cell);
   return sexp_make_boolean((id1 == id2) && (lam1 == lam2));
 }
@@ -357,13 +364,21 @@ static sexp analyze (sexp x, sexp context) {
       } else if (sexp_macrop(op)) {
         x = apply(sexp_macro_proc(op),
                   sexp_list3(x, sexp_context_env(context), sexp_macro_env(op)),
-                  context);
+                  sexp_child_context(context, sexp_context_lambda(context)));
         /* sexp_debug("expand => ", x, context); */
         goto loop;
       } else if (sexp_opcodep(op)) {
+        res = sexp_length(sexp_cdr(x));
+        if (sexp_unbox_integer(res) < sexp_opcode_num_args(op)) {
+          res = sexp_compile_error("not enough args for opcode", sexp_list1(x));
+        } else if ((sexp_unbox_integer(res) > sexp_opcode_num_args(op))
+                   && (! sexp_opcode_variadic_p(op))) {
+          res = sexp_compile_error("too many args for opcode", sexp_list1(x));
+        } else {
           res = analyze_app(sexp_cdr(x), context);
           analyze_check_exception(res);
           sexp_push(res, op);
+        }
       } else {
         res = analyze_app(x, context);
       }
@@ -537,10 +552,10 @@ static void sexp_context_patch_label (sexp context, sexp_sint_t label) {
 static sexp finalize_bytecode (sexp context) {
   emit(OP_RET, context);
   shrink_bcode(context, sexp_context_pos(context));
-  disasm(sexp_context_bc(context),
+/*   disasm(sexp_context_bc(context), */
-         env_global_ref(sexp_context_env(context),
+/*          env_global_ref(sexp_context_env(context), */
-                        the_cur_err_symbol,
+/*                         the_cur_err_symbol, */
-                        SEXP_FALSE));
+/*                         SEXP_FALSE)); */
   return sexp_context_bc(context);
 }
 
@@ -950,8 +965,8 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
   sexp_sint_t i, j, k, fp=top-4;
 
  loop:
-  /* print_stack(stack, top, fp); */
+/*   print_stack(stack, top, fp, env_global_ref(env, the_cur_err_symbol, SEXP_FALSE)); */
-  /* fprintf(stderr, "%s\n", (*ip<=71)?reverse_opcode_names[*ip]:"UNKNOWN"); */
+/*   fprintf(stderr, "%s\n", (*ip<=71)?reverse_opcode_names[*ip]:"UNKNOWN"); */
   switch (*ip++) {
   case OP_NOOP:
     fprintf(stderr, "<<<NOOP>>>\n");
@@ -1089,6 +1104,12 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
     ip += sizeof(sexp);
     sexp_check_exception();
     break;
+  case OP_FCALL4:
+    _ARG4 =((sexp_proc4)_UWORD0)(_ARG1, _ARG2, _ARG3, _ARG4);
+    top -= 3;
+    ip += sizeof(sexp);
+    sexp_check_exception();
+    break;
   case OP_EVAL:
     sexp_context_top(context) = top;
     _ARG1 = eval_in_context(_ARG1, context);
@@ -1142,6 +1163,9 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
     _ARG3 = SEXP_UNDEF;
     top-=2;
     break;
+  case OP_VECTOR_LENGTH:
+    _ARG1 = sexp_make_integer(sexp_vector_length(_ARG1));
+    break;
   case OP_STRING_REF:
     _ARG2 = sexp_string_ref(_ARG1, _ARG2);
     top--;
@@ -1151,6 +1175,9 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
     _ARG3 = SEXP_UNDEF;
     top-=2;
     break;
+  case OP_STRING_LENGTH:
+    _ARG1 = sexp_make_integer(sexp_string_length(_ARG1));
+    break;
   case OP_MAKE_PROCEDURE:
     _ARG4 = sexp_make_procedure(_ARG1, _ARG2, _ARG3, _ARG4);
     top-=3;
@@ -1289,11 +1316,13 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
     else sexp_raise("/: not a number", sexp_list1(_ARG1));
     break;
   case OP_LT:
-    _ARG2 = sexp_make_boolean(_ARG1 < _ARG2);
+    _ARG2 = sexp_make_boolean(sexp_unbox_integer(_ARG1)
+                              < sexp_unbox_integer(_ARG2));
     top--;
     break;
   case OP_LE:
-    _ARG2 = sexp_make_boolean(_ARG1 <= _ARG2);
+    _ARG2 = sexp_make_boolean(sexp_unbox_integer(_ARG1)
+                              <= sexp_unbox_integer(_ARG2));
     top--;
     break;
   case OP_EQ:
@@ -1301,6 +1330,12 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
     _ARG2 = sexp_make_boolean(_ARG1 == _ARG2);
     top--;
     break;
+  case OP_CHAR2INT:
+    _ARG1 = sexp_make_integer(sexp_unbox_character(_ARG1));
+    break;
+  case OP_INT2CHAR:
+    _ARG1 = sexp_make_character(sexp_unbox_integer(_ARG1));
+    break;
   case OP_DISPLAY:
     if (sexp_stringp(_ARG1)) {
       sexp_write_string(sexp_string_data(_ARG1), _ARG2);
@@ -1412,6 +1447,10 @@ define_math_op(sexp_asin, asin)
 define_math_op(sexp_acos, acos)
 define_math_op(sexp_atan, atan)
 define_math_op(sexp_sqrt, sqrt)
+define_math_op(sexp_round, round)
+define_math_op(sexp_trunc, trunc)
+define_math_op(sexp_floor, floor)
+define_math_op(sexp_ceiling, ceil)
 
 #endif
 
@@ -1526,6 +1565,13 @@ void scheme_init () {
     the_cur_out_symbol = sexp_intern("*current-output-port*");
     the_cur_err_symbol = sexp_intern("*current-error-port*");
     the_interaction_env_symbol = sexp_intern("*interaction-environment*");
+#if USE_BOEHM
+    GC_add_roots((char*)&continuation_resumer,
+                 ((char*)&continuation_resumer)+sizeof(continuation_resumer)+1);
+    GC_add_roots((char*)&final_resumer,
+                 ((char*)&final_resumer)+sizeof(continuation_resumer)+1);
+    GC_add_roots((char*)&opcodes, ((char*)&opcodes)+sizeof(opcodes)+1);
+#endif
     context = sexp_make_context(NULL, NULL);
     emit(OP_RESUMECC, context);
     continuation_resumer = finalize_bytecode(context);

eval.h

@@ -80,8 +80,10 @@ enum opcode_names {
   OP_CLOSURE_REF,
   OP_VECTOR_REF,
   OP_VECTOR_SET,
+  OP_VECTOR_LENGTH,
   OP_STRING_REF,
   OP_STRING_SET,
+  OP_STRING_LENGTH,
   OP_MAKE_PROCEDURE,
   OP_MAKE_VECTOR,
   OP_NULLP,
@@ -107,6 +109,8 @@ enum opcode_names {
   OP_LE,
   OP_EQV,
   OP_EQ,
+  OP_CHAR2INT,
+  OP_INT2CHAR,
   OP_DISPLAY,
   OP_WRITE,
   OP_WRITE_CHAR,

init.scm

@@ -1,30 +1,26 @@
 
-;; cond case delay do
+;; let-syntax letrec-syntax syntax-rules
-;; quasiquote let-syntax
+;; number? complex? real? rational? integer? exact? inexact?
-;; letrec-syntax syntax-rules not boolean? number?
+;; positive? negative? max min remainder
-;; complex? real? rational? integer? exact? inexact?
+;; modulo numerator denominator
-;; positive? negative? odd? even? max min quotient remainder
-;; modulo numerator denominator floor ceiling truncate round
 ;; rationalize expt
 ;; make-rectangular make-polar real-part imag-part magnitude angle
 ;; 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->integer integer->char
+;; char-upper-case? char-lower-case?
-;; char-upcase char-downcase make-string string string-length
+;; char-upcase char-downcase make-string
 ;; string=? string-ci=? string<? string>?
 ;; string<=? string>=? string-ci<? string-ci>? string-ci<=? string-ci>=?
-;; substring string-append string->list list->string string-copy
+;; substring string-append string-copy
-;; string-fill! vector vector-length
+;; values call-with-values dynamic-wind
-;; vector->list list->vector vector-fill! procedure? apply
+;; call-with-input-file call-with-output-file
-;; map for-each force call-with-current-continuation values
+;; with-input-from-file with-output-to-file
-;; call-with-values dynamic-wind scheme-report-environment
-;; null-environment call-with-input-file call-with-output-file
-;; current-input-port current-output-port
-;; with-input-from-file with-output-to-file open-input-file
-;; open-output-file close-input-port close-output-port
 ;; peek-char char-ready?
 
+(define (not x) (if x #f #t))
+(define (boolean? x) (if (eq? x #t) #t (eq? x #f)))
+
 ;; provide c[ad]{2,4}r
 
 (define (caar x) (car (car x)))
@@ -61,7 +57,7 @@
 (define (list . args) args)
 
 (define (list-tail ls k)
-  (if (zero? k)
+  (if (eq? k 0)
       ls
       (list-tail (cdr ls) (- k 1))))
 
@@ -82,8 +78,8 @@
   (if (null? ls)
       #f
       (if (equal? obj (caar ls))
-          ls
+          (car ls)
-          (member obj (cdr ls)))))
+          (assoc obj (cdr ls)))))
 
 (define assv assoc)
 
@@ -105,27 +101,21 @@
 ;; map with a fast-path for single lists
 
 (define (map proc ls . lol)
-  (if (null? lol)
+  (define (map1 proc ls res)
-      (map1 proc ls '())
-      (mapn proc (cons ls lol) '())))
-
-(define (map1 proc ls res)
     (if (pair? ls)
         (map1 proc (cdr ls) (cons (proc (car ls)) res))
         (reverse res)))
-
+  (define (mapn proc lol res)
-(define (mapn proc lol res)
     (if (null? (car lol))
         (reverse res)
         (mapn proc
               (map1 cdr lol '())
               (cons (apply1 proc (map1 car lol '())) res))))
+  (if (null? lol)
+      (map1 proc ls '())
+      (mapn proc (cons ls lol) '())))
 
-;; math utilities
+(define for-each map)
-
-(define (zero? x) (= x 0))
-(define (positive? x) (> x 0))
-(define (negative? x) (< x 0))
 
 ;; syntax
 
@@ -156,37 +146,6 @@
         '())
        (lambda (x y) (identifier=? use-env x use-env y))))))
 
-(define-syntax letrec
-  (er-macro-transformer
-   (lambda (expr rename compare)
-     (list
-      (cons (rename 'lambda)
-            (cons '()
-                  (append (map (lambda (x) (cons (rename 'define) x)) (cadr expr))
-                          (cddr expr))))))))
-
-(define-syntax let
-  (er-macro-transformer
-   (lambda (expr rename compare)
-     (if (identifier? (cadr expr))
-         (list (rename 'letrec)
-               (list (list (cadr expr)
-                           (cons (rename 'lambda)
-                                 (cons (map car (caddr expr))
-                                       (cdddr expr)))))
-               (cons (cadr expr) (map cadr (caddr expr))))
-         (cons (cons (rename 'lambda) (cons (map car (cadr expr)) (cddr expr)))
-               (map cadr (cadr expr)))))))
-
-(define-syntax let*
-  (er-macro-transformer
-   (lambda (expr rename compare)
-     (if (null? (cadr expr))
-         (cons (rename 'begin) (cddr expr))
-         (list (rename 'let)
-               (list (caadr expr))
-               (cons (rename 'let*) (cons (cdadr expr) (cddr expr))))))))
-
 (define-syntax or
   (er-macro-transformer
    (lambda (expr rename compare)
@@ -213,10 +172,10 @@
    (lambda (expr rename compare)
      (if (null? (cdr expr))
          #f
-         (let ((cl (cadr expr)))
+         ((lambda (cl)
-           (if (eq? 'else (car cl))
+            (if (compare 'else (car cl))
                 (cons (rename 'begin) (cdr cl))
-               (if (if (null? (cdr cl)) #t (eq? '=> (cadr cl)))
+                (if (if (null? (cdr cl)) #t (compare '=> (cadr cl)))
                     (list (rename 'let)
                           (list (list (rename 'tmp) (car cl)))
                           (list (rename 'if) (rename 'tmp)
@@ -226,39 +185,121 @@
                     (list (rename 'if)
                           (car cl)
                           (cons (rename 'begin) (cdr cl))
-                         (cons (rename 'cond) (cddr expr))))))))))
+                          (cons (rename 'cond) (cddr expr))))))
+          (cadr expr))))))
 
 (define-syntax quasiquote
   (er-macro-transformer
    (lambda (expr rename compare)
      (define (qq x d)
-       (if (pair? x)
+       (cond
-           (if (eq? 'unquote (car x))
+        ((pair? x)
+         (cond
+          ((eq? 'unquote (car x))
            (if (<= d 0)
                (cadr x)
-                   (list (rename 'unquote) (qq (cadr x) (- d 1))))
+               (list (rename 'unquote) (qq (cadr x) (- d 1)))))
-               (if (eq? 'unquote-splicing (car x))
+          ((eq? 'unquote-splicing (car x))
            (if (<= d 0)
                (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))
-                       (list (rename 'unquote-splicing) (qq (cadr x) (- d 1))))
+               (list (rename 'unquote-splicing) (qq (cadr x) (- d 1)))))
-                   (if (eq? 'quasiquote (car x))
+          ((eq? 'quasiquote (car x))
-                       (list (rename 'quasiquote) (qq (cadr x) (+ d 1)))
+           (list (rename 'quasiquote) (qq (cadr x) (+ d 1))))
-                       (if (and (<= d 0)
+          ((and (<= d 0) (pair? (car x)) (eq? 'unquote-splicing (caar x)))
-                                (pair? (car x))
+           (if (null? (cdr x))
-                                (eq? 'unquote-splicing (caar x)))
-                           (list (rename 'append)
                (cadar x)
-                                 (qq (cdr x) d))
+               (list (rename 'append) (cadar x) (qq (cdr x) d))))
-                           (list (rename 'cons)
+          (else
-                                 (qq (car x) d)
+           (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)))))
-                                 (qq (cdr x) d))))))
+        ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d)))
-           (if (vector? x)
+        ((symbol? x) (list (rename 'quote) x))
-               (list (rename 'list->vector) (qq (vector->list x) d))
+        (else x)))
-               (if (symbol? x)
-                   (list (rename 'quote) x)
-                   x))))
      (qq (cadr expr) 0))))
 
+(define-syntax letrec
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     ((lambda (defs)
+        `((,(rename 'lambda) () ,@defs ,@(cddr expr))))
+      (map (lambda (x) (cons (rename 'define) x)) (cadr expr))))))
+
+(define-syntax let
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (if (identifier? (cadr expr))
+         `(,(rename 'letrec) ((,(cadr expr)
+                               (,(rename 'lambda) ,(map car (caddr expr))
+                                ,@(cdddr expr))))
+           ,(cons (cadr expr) (map cadr (caddr expr))))
+         `((,(rename 'lambda) ,(map car (cadr expr)) ,@(cddr expr))
+           ,@(map cadr (cadr expr)))))))
+
+(define-syntax let*
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (if (null? (cadr expr))
+         `(,(rename 'begin) ,@(cddr expr))
+         `(,(rename 'let) (,(caadr expr))
+           (,(rename 'let*) ,(cdadr expr) ,@(cddr expr)))))))
+
+(define-syntax case
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (define (clause ls)
+       (cond
+        ((null? ls) #f)
+        ((compare 'else (caar ls))
+         `(,(rename 'begin) ,@(cdar ls)))
+        (else
+         (if (and (pair? (caar ls)) (null? (cdaar ls)))
+             `(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp) ',(caaar ls))
+               (,(rename 'begin) ,@(cdar ls))
+               ,(clause (cdr ls)))
+             `(,(rename 'if) (,(rename 'memv) ,(rename 'tmp) ',(caar ls))
+               (,(rename 'begin) ,@(cdar ls))
+               ,(clause (cdr ls)))))))
+     `(let ((,(rename 'tmp) ,(cadr expr)))
+        ,(clause (cddr expr))))))
+
+(define-syntax do
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let* ((body
+             `(,(rename 'begin)
+               ,@(cdddr expr)
+               (,(rename 'lp)
+                ,@(map (lambda (x) (if (pair? (cddr x)) (caddr x) (car x)))
+                       (cadr expr)))))
+            (check (caddr expr))
+            (wrap
+             (if (null? (cdr check))
+                 `(,(rename 'let) ((,(rename 'tmp) ,(car check)))
+                   (,(rename 'if) ,(rename 'tmp)
+                    ,(rename 'tmp)
+                    ,body))
+                 `(,(rename 'if) ,(car check)
+                   (,(rename 'begin) ,@(cdr check))
+                   ,body))))
+       `(,(rename 'let) ,(rename 'lp)
+         ,(map (lambda (x) (list (car x) (cadr x))) (cadr expr))
+         ,wrap)))))
+
+(define-syntax delay
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     `(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr epr))))))
+
+(define (make-promise thunk)
+  (lambda ()
+    (let ((computed? #f) (result #f))
+      (if (not computed?)
+          (begin
+            (set! result (thunk))
+            (set! computed? #t)))
+      result)))
+
+(define (force x) (if (procedure? x) (x) x))
+
 ;; char utils
 
 ;; (define (char=? a b) (= (char->integer a) (char->integer b)))
@@ -278,24 +319,35 @@
 ;; (define (char-ci>=? a b)
 ;;   (>= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
 
-;; vector utils
+;; string utils
 
-(define (list->vector ls)
+(define (list->string ls)
-  (let ((vec (make-vector (length ls))))
+  (let ((str (make-string (length ls) #\space)))
     (let lp ((ls ls) (i 0))
       (if (pair? ls)
           (begin
-            (vector-set! vec i (car ls))
+            (string-set! str i (car ls))
             (lp (cdr ls) (+ i 1)))))
-    vec))
+    str))
 
-(define (vector->list vec)
+(define (string->list str)
-  (let lp ((i (- (vector-length vec) 1)) (res '()))
+  (let lp ((i (- (string-length str) 1)) (res '()))
-    (if (< i 0)
+    (if (< i 0) res (lp (- i 1) (cons (string-ref str i) res)))))
-        res
-        (lp (- i 1) (cons (vector-ref vec i) res)))))
 
-;; math
+(define (string-fill! str ch)
+  (let lp ((i (- (string-length str) 1)))
+    (if (>= i 0) (begin (string-set! str i ch) (lp (- i 1))))))
+
+(define (string . args) (list->string args))
+
+;; math utils
+
+(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))
 
@@ -307,5 +359,28 @@
 ;; (define (lcm a b)
 ;;   (quotient (* a b) (gcd a b)))
 
+;; vector utils
+
+(define (list->vector ls)
+  (let ((vec (make-vector (length ls) #f)))
+    (let lp ((ls ls) (i 0))
+      (if (pair? ls)
+          (begin
+            (vector-set! vec i (car ls))
+            (lp (cdr ls) (+ i 1)))))
+    vec))
+
+(define (vector->list vec)
+  (let lp ((i (- (vector-length vec) 1)) (res '()))
+    (if (< i 0) res (lp (- i 1) (cons (vector-ref vec i) res)))))
+
+(define (vector-fill! str ch)
+  (let lp ((i (- (vector-length str) 1)))
+    (if (>= i 0) (begin (vector-set! str i ch) (lp (- i 1))))))
+
+(define (vector . args) (list->vector args))
+
+;; miscellaneous
+
 (define (load file) (%load file (interaction-environment)))
 

opcodes.c

@@ -15,8 +15,12 @@ _OP(OPC_ACCESSOR, OP_CDR, 1, 0, SEXP_PAIR, 0, 0, "cdr", NULL, NULL),
 _OP(OPC_ACCESSOR, OP_SET_CDR, 2, 0, SEXP_PAIR, 0, 0, "set-cdr!", NULL, NULL),
 _OP(OPC_ACCESSOR, OP_VECTOR_REF,2,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-ref", NULL, NULL),
 _OP(OPC_ACCESSOR, OP_VECTOR_SET,3,0, SEXP_VECTOR, SEXP_FIXNUM, 0,"vector-set!", NULL, NULL),
+_OP(OPC_ACCESSOR, OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", NULL, NULL),
 _OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", NULL, NULL),
 _OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", NULL, NULL),
+_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_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),
@@ -77,6 +81,10 @@ _FN1(0, "asin", sexp_asin),
 _FN1(0, "acos", sexp_acos),
 _FN1(0, "atan", sexp_atan),
 _FN1(0, "sqrt", sexp_sqrt),
+_FN1(0, "round", sexp_round),
+_FN1(0, "truncate", sexp_trunc),
+_FN1(0, "floor", sexp_floor),
+_FN1(0, "ceiling", sexp_ceiling),
 #endif
 _FN2(0, SEXP_PAIR, "memq", sexp_memq),
 _FN2(0, SEXP_PAIR, "assq", sexp_assq),

sexp.c

@@ -47,7 +47,7 @@ static int is_separator(int c) {
 
 static sexp* symbol_table = NULL;
 static unsigned long symbol_table_primes[] = {
-  97, 389, 1543, 6151, 12289, 24593, 49157, 98317, 196613, 393241,
+  /* 97, 389, */ 1543, 6151, 12289, 24593, 49157, 98317, 196613, 393241,
   786433, 1572869, 3145739, 6291469, 12582917, 25165843, 50331653,
   100663319, 201326611, 402653189, 805306457, 1610612741};
 static int symbol_table_prime_index = 0;
@@ -934,6 +934,8 @@ void sexp_init() {
     sexp_initialized_p = 1;
 #if USE_BOEHM
     GC_init();
+    GC_add_roots((char*)&symbol_table,
+                 ((char*)&symbol_table)+sizeof(symbol_table)+1);
 #endif
     symbol_table = sexp_alloc(symbol_table_primes[0]*sizeof(sexp));
     the_dot_symbol = sexp_intern(".");

sexp.h

@@ -109,6 +109,7 @@ struct sexp_struct {
     } env;
     struct {
       sexp_uint_t length;
+      sexp literals;
       unsigned char data[];
     } bytecode;
     struct {
@@ -263,6 +264,7 @@ struct sexp_struct {
 
 #define sexp_bytecode_length(x)   ((x)->value.bytecode.length)
 #define sexp_bytecode_data(x)     ((x)->value.bytecode.data)
+#define sexp_bytecode_literals(x) ((x)->value.bytecode.literals)
 
 #define sexp_env_flags(x)         ((x)->value.env.flags)
 #define sexp_env_parent(x)        ((x)->value.env.parent)