Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

fixing tail calls, now allowing variadic tail calls

Browse source
This commit is contained in:
Alex Shinn 2009-03-13 22:56:43 +09:00
parent 5caa12412e
commit 1ad276252f
2 changed files with 88 additions and 56 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

58
eval.c
View file

@ -373,7 +373,7 @@ void analyze_opcode (opcode op, sexp obj, bytecode *bc, unsigned int *i, env e,
} }
emit_push(bc, i, op->data); emit_push(bc, i, op->data);
emit(bc, i, op->op_name); emit(bc, i, op->op_name);
(*d) -= sexp_length(SEXP_CDR(obj)); (*d) -= (sexp_length(SEXP_CDR(obj))-1);
break; break;
default: default:
errx(1, "unknown opcode class: %d", op->op_class); errx(1, "unknown opcode class: %d", op->op_class);
@ -425,8 +425,10 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i, env e,
/* maybe overwrite the current frame */ /* maybe overwrite the current frame */
if (tailp) { if (tailp) {
fprintf(stderr, "compiling tail call: %d + %d + 3 = %d\n",
sexp_length(params), (*d), sexp_length(params)+(*d)+3);
emit(bc, i, OP_TAIL_CALL); emit(bc, i, OP_TAIL_CALL);
emit_word(bc, i, (sexp_uint_t) sexp_make_integer(sexp_length(params)+(*d))); emit_word(bc, i, (sexp_uint_t) sexp_make_integer(sexp_length(params)+(*d)+3));
emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len)); emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len));
} else { } else {
/* normal call */ /* normal call */
@ -613,7 +615,8 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) {
d--; d--;
} else { } else {
analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d,
(! done_p) && (! SEXP_PAIRP(internals))); (! done_p) && (! SEXP_PAIRP(internals))
);
} }
} }
if (SEXP_PAIRP(internals)) { if (SEXP_PAIRP(internals)) {
@ -667,6 +670,11 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
tmp1 = env_cell(e, ((sexp*)ip)[0]); tmp1 = env_cell(e, ((sexp*)ip)[0]);
if (! tmp1) if (! tmp1)
sexp_raise(sexp_intern("undefined-variable")); sexp_raise(sexp_intern("undefined-variable"));
/* fprintf(stderr, "global-ref: "); */
/* sexp_write(((sexp*)ip)[0], cur_error_port); */
/* fprintf(stderr, " => "); */
/* sexp_write(SEXP_CDR(tmp1), cur_error_port); */
/* fprintf(stderr, "\n"); */
stack[top++]=SEXP_CDR(tmp1); stack[top++]=SEXP_CDR(tmp1);
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
@ -745,7 +753,6 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
case OP_PAIRP: case OP_PAIRP:
/* print_stack(stack, top); */
stack[top-1]=SEXP_PAIRP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; stack[top-1]=SEXP_PAIRP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
case OP_NULLP: case OP_NULLP:
stack[top-1]=SEXP_NULLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break; stack[top-1]=SEXP_NULLP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
@ -832,36 +839,23 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
top--; top--;
break; break;
case OP_TAIL_CALL: case OP_TAIL_CALL:
/* old-args ... n ret-ip ret-cp new-args ... proc */
/* [================= j ===========================] */
/* [==== i =====] */
j = sexp_unbox_integer(((sexp*)ip)[0]); /* current depth */ j = sexp_unbox_integer(((sexp*)ip)[0]); /* current depth */
ip += sizeof(sexp); i = sexp_unbox_integer(((sexp*)ip)[1]); /* number of params */
i = sexp_unbox_integer(((sexp*)ip)[0]); /* number of params */
tmp1 = stack[top-1]; /* procedure to call */ tmp1 = stack[top-1]; /* procedure to call */
/* fprintf(stderr, "tail call: depth=%d, i=%d, top=%d\n", j, i, top); */
/* print_stack(stack, top); */
/* save frame info */ /* save frame info */
stack[top] = stack[top-j-2]; ip = ((unsigned char*) sexp_unbox_integer(stack[top-i-3])) - sizeof(sexp);
stack[top+1] = stack[top-j-1]; cp = stack[top-i-2];
/* copy new args into place */ /* copy new args into place */
for (k=top-i-1; k<top-1; k++) for (k=0; k<i; k++)
stack[k-j+1] = stack[k]; stack[top-j+k] = stack[top-i-1+k];
/* restore frame info */ top -= (j-i-1);
stack[top-(j-i)] = stack[top]; goto make_call;
stack[top-(j-i)+1] = stack[top+1];
top -= (j-i);
stack[top-1] = tmp1;
/* exit(0); */
/* sexp_debug("call proc: ", tmp1); */
/* sexp_debug("bc: ", sexp_procedure_code(tmp1)); */
/* fprintf(stderr, "data: %p\n", sexp_procedure_code(tmp1)->data); */
bc = sexp_procedure_code(tmp1);
ip = bc->data;
cp = sexp_procedure_vars(tmp1);
break;
case OP_CALL: case OP_CALL:
if (top >= INIT_STACK_SIZE) if (top >= INIT_STACK_SIZE)
errx(1, "out of stack space: %d", top); errx(1, "out of stack space: %d", top);
/* fprintf(stderr, "CALL\n"); */
/* print_stack(stack, top); */
i = sexp_unbox_integer(((sexp*)ip)[0]); i = sexp_unbox_integer(((sexp*)ip)[0]);
tmp1 = stack[top-1]; tmp1 = stack[top-1];
make_call: make_call:
@ -870,12 +864,18 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
tmp1 = make_opcode_procedure((opcode) tmp1, i, e); tmp1 = make_opcode_procedure((opcode) tmp1, i, e);
/* print_stack(stack, top); */ /* print_stack(stack, top); */
if (! SEXP_PROCEDUREP(tmp1)) { if (! SEXP_PROCEDUREP(tmp1)) {
fprintf(stderr, "error: non-procedure app\n"); fprintf(stderr, "error: non-procedure app: ");
sexp_write(tmp1, cur_error_port);
fprintf(stderr, "\n");
sexp_raise(sexp_intern("non-procedure-application")); sexp_raise(sexp_intern("non-procedure-application"));
} }
j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1)); j = i - sexp_unbox_integer(sexp_procedure_num_args(tmp1));
if (j < 0) if (j < 0) {
fprintf(stderr, "error: expected %d args but got %d\n",
sexp_unbox_integer(sexp_procedure_num_args(tmp1)),
i);
sexp_raise(sexp_intern("not-enough-args")); sexp_raise(sexp_intern("not-enough-args"));
}
if (j > 0) { if (j > 0) {
if (sexp_procedure_variadic_p(tmp1)) { if (sexp_procedure_variadic_p(tmp1)) {
stack[top-i-1] = sexp_cons(stack[top-i-1], SEXP_NULL); stack[top-i-1] = sexp_cons(stack[top-i-1], SEXP_NULL);

86
init.scm
View file

@ -6,31 +6,48 @@
(define (cdar x) (cdr (car x))) (define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x))) (define (cddr x) (cdr (cdr x)))
(define (caaar x) (car (car (car x)))) ;; (define (caaar x) (car (car (car x))))
(define (caadr x) (car (car (cdr x)))) ;; (define (caadr x) (car (car (cdr x))))
(define (cadar x) (car (cdr (car x)))) ;; (define (cadar x) (car (cdr (car x))))
(define (caddr x) (car (cdr (cdr x)))) ;; (define (caddr x) (car (cdr (cdr x))))
(define (cdaar x) (cdr (car (car x)))) ;; (define (cdaar x) (cdr (car (car x))))
(define (cdadr x) (cdr (car (cdr x)))) ;; (define (cdadr x) (cdr (car (cdr x))))
(define (cddar x) (cdr (cdr (car x)))) ;; (define (cddar x) (cdr (cdr (car x))))
(define (cdddr x) (cdr (cdr (cdr x)))) ;; (define (cdddr x) (cdr (cdr (cdr x))))
(define (caaaar x) (car (car (car (car x))))) ;; (define (caaaar x) (car (car (car (car x)))))
(define (caaadr x) (car (car (car (cdr x))))) ;; (define (caaadr x) (car (car (car (cdr x)))))
(define (caadar x) (car (car (cdr (car x))))) ;; (define (caadar x) (car (car (cdr (car x)))))
(define (caaddr x) (car (car (cdr (cdr x))))) ;; (define (caaddr x) (car (car (cdr (cdr x)))))
(define (cadaar x) (car (cdr (car (car x))))) ;; (define (cadaar x) (car (cdr (car (car x)))))
(define (cadadr x) (car (cdr (car (cdr x))))) ;; (define (cadadr x) (car (cdr (car (cdr x)))))
(define (caddar x) (car (cdr (cdr (car x))))) ;; (define (caddar x) (car (cdr (cdr (car x)))))
(define (cadddr x) (car (cdr (cdr (cdr x))))) ;; (define (cadddr x) (car (cdr (cdr (cdr x)))))
(define (cdaaar x) (cdr (car (car (car x))))) ;; (define (cdaaar x) (cdr (car (car (car x)))))
(define (cdaadr x) (cdr (car (car (cdr x))))) ;; (define (cdaadr x) (cdr (car (car (cdr x)))))
(define (cdadar x) (cdr (car (cdr (car x))))) ;; (define (cdadar x) (cdr (car (cdr (car x)))))
(define (cdaddr x) (cdr (car (cdr (cdr x))))) ;; (define (cdaddr x) (cdr (car (cdr (cdr x)))))
(define (cddaar x) (cdr (cdr (car (car x))))) ;; (define (cddaar x) (cdr (cdr (car (car x)))))
(define (cddadr x) (cdr (cdr (car (cdr x))))) ;; (define (cddadr x) (cdr (cdr (car (cdr x)))))
(define (cdddar x) (cdr (cdr (cdr (car x))))) ;; (define (cdddar x) (cdr (cdr (cdr (car x)))))
(define (cddddr x) (cdr (cdr (cdr (cdr x))))) ;; (define (cddddr x) (cdr (cdr (cdr (cdr x)))))
(define (list . args) args)
(define (append-reverse a b)
(if (pair? a)
(append-reverse (cdr a) (cons (car a) b))
b))
(define (append a b)
(append-reverse (reverse a) b))
(define (apply proc . args)
(if (null? args)
(proc)
((lambda (lol)
(apply1 proc (append (reverse (cdr lol)) (car lol))))
(reverse args))))
;; map with a fast-path for single lists ;; map with a fast-path for single lists
@ -40,8 +57,6 @@
(mapn proc (cons ls lol) '()))) (mapn proc (cons ls lol) '())))
(define (map1 proc ls res) (define (map1 proc ls res)
;; (write ls)
;; (newline)
(if (pair? ls) (if (pair? ls)
(map1 proc (cdr ls) (cons (proc (car ls)) res)) (map1 proc (cdr ls) (cons (proc (car ls)) res))
(reverse res))) (reverse res)))
@ -49,5 +64,22 @@
(define (mapn proc lol res) (define (mapn proc lol res)
(if (null? lol) (if (null? lol)
(reverse res) (reverse res)
(mapn proc (cdr lol) (cons (apply proc (map1 car lol)) res)))) (mapn proc (cdr lol) (cons (apply1 proc (map1 car lol '())) res))))
;; syntax
(define-syntax let
(lambda (expr use-env mac-env)
(cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr)))
(map cadr (cadr expr)))))
(define-syntax or
(lambda (expr use-env mac-env)
(if (null? (cdr expr))
#f
(if (null? (cddr expr))
(cadr expr)
(list 'let (list (list 'tmp (cadr expr)))
(list 'if 'tmp
'tmp
(cons 'or (cddr expr))))))))