mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-20 06:09:18 +02:00
flushing out library
This commit is contained in:
Alex Shinn
parent
51352245b2
commit
ee5f33c9fb
7 changed files with 274 additions and 136 deletions
7
debug.c
7
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) {
|
||||
|
|
|
|||
74
eval.c
74
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, "<<<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);
|
||||
|
|
|
|||
4
eval.h
4
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,
|
||||
|
|
|
|||
311
init.scm
311
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>=? string-ci<? 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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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),
|
||||
|
|
|
|||
4
sexp.c
4
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(".");
|
||||
|
|
|
|||
2
sexp.h
2
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)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue