diff --git a/debug.c b/debug.c index 052d2412..90d5c8db 100644 --- a/debug.c +++ b/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", - "READ_CHAR", "RET", "DONE", + "CHAR->INTEGER", "INTEGER->CHAR", "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 62dfaa2f..d6b4c8e8 100644 --- a/eval.c +++ b/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 = analyze_app(sexp_cdr(x), context); - analyze_check_exception(res); - sexp_push(res, 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), - env_global_ref(sexp_context_env(context), - the_cur_err_symbol, - SEXP_FALSE)); +/* disasm(sexp_context_bc(context), */ +/* env_global_ref(sexp_context_env(context), */ +/* the_cur_err_symbol, */ +/* 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); */ - /* fprintf(stderr, "%s\n", (*ip<=71)?reverse_opcode_names[*ip]:"UNKNOWN"); */ +/* 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"); */ switch (*ip++) { case OP_NOOP: fprintf(stderr, "<<>>\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); diff --git a/eval.h b/eval.h index bf1e5375..4c42af99 100644 --- a/eval.h +++ b/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, diff --git a/init.scm b/init.scm index e3210566..93393e02 100644 --- a/init.scm +++ b/init.scm @@ -1,30 +1,26 @@ -;; cond case delay do -;; quasiquote let-syntax -;; letrec-syntax syntax-rules not boolean? number? -;; complex? real? rational? integer? exact? inexact? -;; positive? negative? odd? even? max min quotient remainder -;; modulo numerator denominator floor ceiling truncate round +;; 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 ;; 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-upcase char-downcase make-string string string-length +;; char-upper-case? char-lower-case? +;; char-upcase char-downcase make-string ;; string=? string-ci=? string? ;; string<=? string>=? string-ci? string-ci<=? string-ci>=? -;; substring string-append string->list list->string string-copy -;; string-fill! vector vector-length -;; vector->list list->vector vector-fill! procedure? apply -;; map for-each force call-with-current-continuation values -;; 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 +;; substring string-append string-copy +;; 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? +(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 - (member obj (cdr ls))))) + (car 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) + (define (map1 proc ls res) + (if (pair? ls) + (map1 proc (cdr ls) (cons (proc (car ls)) res)) + (reverse 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) '()))) -(define (map1 proc ls res) - (if (pair? ls) - (map1 proc (cdr ls) (cons (proc (car ls)) res)) - (reverse res))) - -(define (mapn proc lol res) - (if (null? (car lol)) - (reverse res) - (mapn proc - (map1 cdr lol '()) - (cons (apply1 proc (map1 car lol '())) res)))) - -;; math utilities - -(define (zero? x) (= x 0)) -(define (positive? x) (> x 0)) -(define (negative? x) (< x 0)) +(define for-each map) ;; 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,52 +172,134 @@ (lambda (expr rename compare) (if (null? (cdr expr)) #f - (let ((cl (cadr expr))) - (if (eq? 'else (car cl)) - (cons (rename 'begin) (cdr cl)) - (if (if (null? (cdr cl)) #t (eq? '=> (cadr cl))) - (list (rename 'let) - (list (list (rename 'tmp) (car cl))) - (list (rename 'if) (rename 'tmp) - (if (null? (cdr cl)) - (rename 'tmp) - (list (caddr cl) (rename 'tmp))))) - (list (rename 'if) - (car cl) - (cons (rename 'begin) (cdr cl)) - (cons (rename 'cond) (cddr expr)))))))))) + ((lambda (cl) + (if (compare 'else (car cl)) + (cons (rename 'begin) (cdr cl)) + (if (if (null? (cdr cl)) #t (compare '=> (cadr cl))) + (list (rename 'let) + (list (list (rename 'tmp) (car cl))) + (list (rename 'if) (rename 'tmp) + (if (null? (cdr cl)) + (rename 'tmp) + (list (caddr cl) (rename 'tmp))))) + (list (rename 'if) + (car cl) + (cons (rename 'begin) (cdr cl)) + (cons (rename 'cond) (cddr expr)))))) + (cadr expr)))))) (define-syntax quasiquote (er-macro-transformer (lambda (expr rename compare) (define (qq x d) - (if (pair? x) - (if (eq? 'unquote (car x)) - (if (<= d 0) - (cadr x) - (list (rename 'unquote) (qq (cadr x) (- d 1)))) - (if (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)))) - (if (eq? 'quasiquote (car x)) - (list (rename 'quasiquote) (qq (cadr x) (+ d 1))) - (if (and (<= d 0) - (pair? (car x)) - (eq? 'unquote-splicing (caar x))) - (list (rename 'append) - (cadar x) - (qq (cdr x) d)) - (list (rename 'cons) - (qq (car x) d) - (qq (cdr x) d)))))) - (if (vector? x) - (list (rename 'list->vector) (qq (vector->list x) d)) - (if (symbol? x) - (list (rename 'quote) x) - x)))) + (cond + ((pair? x) + (cond + ((eq? 'unquote (car x)) + (if (<= d 0) + (cadr x) + (list (rename 'unquote) (qq (cadr x) (- d 1))))) + ((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))))) + ((eq? 'quasiquote (car x)) + (list (rename 'quasiquote) (qq (cadr x) (+ d 1)))) + ((and (<= d 0) (pair? (car x)) (eq? 'unquote-splicing (caar x))) + (if (null? (cdr x)) + (cadar x) + (list (rename 'append) (cadar x) (qq (cdr x) d)))) + (else + (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))))) + ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d))) + ((symbol? x) (list (rename 'quote) x)) + (else 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) - (let ((vec (make-vector (length ls)))) +(define (list->string 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) - (let lp ((i (- (vector-length vec) 1)) (res '())) - (if (< i 0) - res - (lp (- i 1) (cons (vector-ref vec i) res))))) +(define (string->list str) + (let lp ((i (- (string-length str) 1)) (res '())) + (if (< i 0) res (lp (- i 1) (cons (string-ref str 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))) diff --git a/opcodes.c b/opcodes.c index faac6fb3..608a0d6f 100644 --- a/opcodes.c +++ b/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), diff --git a/sexp.c b/sexp.c index 65118d45..48d68cee 100644 --- a/sexp.c +++ b/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("."); diff --git a/sexp.h b/sexp.h index a8f13150..f51a5de5 100644 --- a/sexp.h +++ b/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)