mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
fixing tail calls, now allowing variadic tail calls
This commit is contained in:
Alex Shinn
parent
5caa12412e
commit
1ad276252f
2 changed files with 88 additions and 56 deletions
58
eval.c
58
eval.c
|
|
@ -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(bc, i, op->op_name);
|
||||
(*d) -= sexp_length(SEXP_CDR(obj));
|
||||
(*d) -= (sexp_length(SEXP_CDR(obj))-1);
|
||||
break;
|
||||
default:
|
||||
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 */
|
||||
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_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));
|
||||
} else {
|
||||
/* normal call */
|
||||
|
|
@ -613,7 +615,8 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) {
|
|||
d--;
|
||||
} else {
|
||||
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)) {
|
||||
|
|
@ -667,6 +670,11 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
|
|||
tmp1 = env_cell(e, ((sexp*)ip)[0]);
|
||||
if (! tmp1)
|
||||
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);
|
||||
ip += sizeof(sexp);
|
||||
break;
|
||||
|
|
@ -745,7 +753,6 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
|
|||
ip += sizeof(sexp);
|
||||
break;
|
||||
case OP_PAIRP:
|
||||
/* print_stack(stack, top); */
|
||||
stack[top-1]=SEXP_PAIRP(stack[top-1]) ? SEXP_TRUE : SEXP_FALSE; break;
|
||||
case OP_NULLP:
|
||||
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--;
|
||||
break;
|
||||
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 */
|
||||
ip += sizeof(sexp);
|
||||
i = sexp_unbox_integer(((sexp*)ip)[0]); /* number of params */
|
||||
i = sexp_unbox_integer(((sexp*)ip)[1]); /* number of params */
|
||||
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 */
|
||||
stack[top] = stack[top-j-2];
|
||||
stack[top+1] = stack[top-j-1];
|
||||
ip = ((unsigned char*) sexp_unbox_integer(stack[top-i-3])) - sizeof(sexp);
|
||||
cp = stack[top-i-2];
|
||||
/* copy new args into place */
|
||||
for (k=top-i-1; k<top-1; k++)
|
||||
stack[k-j+1] = stack[k];
|
||||
/* restore frame info */
|
||||
stack[top-(j-i)] = stack[top];
|
||||
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;
|
||||
for (k=0; k<i; k++)
|
||||
stack[top-j+k] = stack[top-i-1+k];
|
||||
top -= (j-i-1);
|
||||
goto make_call;
|
||||
case OP_CALL:
|
||||
if (top >= INIT_STACK_SIZE)
|
||||
errx(1, "out of stack space: %d", top);
|
||||
/* fprintf(stderr, "CALL\n"); */
|
||||
/* print_stack(stack, top); */
|
||||
i = sexp_unbox_integer(((sexp*)ip)[0]);
|
||||
tmp1 = stack[top-1];
|
||||
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);
|
||||
/* print_stack(stack, top); */
|
||||
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"));
|
||||
}
|
||||
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"));
|
||||
}
|
||||
if (j > 0) {
|
||||
if (sexp_procedure_variadic_p(tmp1)) {
|
||||
stack[top-i-1] = sexp_cons(stack[top-i-1], SEXP_NULL);
|
||||
|
|
|
|||
86
init.scm
86
init.scm
|
|
@ -6,31 +6,48 @@
|
|||
(define (cdar x) (cdr (car x)))
|
||||
(define (cddr x) (cdr (cdr x)))
|
||||
|
||||
(define (caaar x) (car (car (car x))))
|
||||
(define (caadr x) (car (car (cdr x))))
|
||||
(define (cadar x) (car (cdr (car x))))
|
||||
(define (caddr x) (car (cdr (cdr x))))
|
||||
(define (cdaar x) (cdr (car (car x))))
|
||||
(define (cdadr x) (cdr (car (cdr x))))
|
||||
(define (cddar x) (cdr (cdr (car x))))
|
||||
(define (cdddr x) (cdr (cdr (cdr x))))
|
||||
;; (define (caaar x) (car (car (car x))))
|
||||
;; (define (caadr x) (car (car (cdr x))))
|
||||
;; (define (cadar x) (car (cdr (car x))))
|
||||
;; (define (caddr x) (car (cdr (cdr x))))
|
||||
;; (define (cdaar x) (cdr (car (car x))))
|
||||
;; (define (cdadr x) (cdr (car (cdr x))))
|
||||
;; (define (cddar x) (cdr (cdr (car x))))
|
||||
;; (define (cdddr x) (cdr (cdr (cdr x))))
|
||||
|
||||
(define (caaaar x) (car (car (car (car x)))))
|
||||
(define (caaadr x) (car (car (car (cdr x)))))
|
||||
(define (caadar x) (car (car (cdr (car x)))))
|
||||
(define (caaddr x) (car (car (cdr (cdr x)))))
|
||||
(define (cadaar x) (car (cdr (car (car x)))))
|
||||
(define (cadadr x) (car (cdr (car (cdr x)))))
|
||||
(define (caddar x) (car (cdr (cdr (car x)))))
|
||||
(define (cadddr x) (car (cdr (cdr (cdr x)))))
|
||||
(define (cdaaar x) (cdr (car (car (car x)))))
|
||||
(define (cdaadr x) (cdr (car (car (cdr x)))))
|
||||
(define (cdadar x) (cdr (car (cdr (car x)))))
|
||||
(define (cdaddr x) (cdr (car (cdr (cdr x)))))
|
||||
(define (cddaar x) (cdr (cdr (car (car x)))))
|
||||
(define (cddadr x) (cdr (cdr (car (cdr x)))))
|
||||
(define (cdddar x) (cdr (cdr (cdr (car x)))))
|
||||
(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
|
||||
;; (define (caaaar x) (car (car (car (car x)))))
|
||||
;; (define (caaadr x) (car (car (car (cdr x)))))
|
||||
;; (define (caadar x) (car (car (cdr (car x)))))
|
||||
;; (define (caaddr x) (car (car (cdr (cdr x)))))
|
||||
;; (define (cadaar x) (car (cdr (car (car x)))))
|
||||
;; (define (cadadr x) (car (cdr (car (cdr x)))))
|
||||
;; (define (caddar x) (car (cdr (cdr (car x)))))
|
||||
;; (define (cadddr x) (car (cdr (cdr (cdr x)))))
|
||||
;; (define (cdaaar x) (cdr (car (car (car x)))))
|
||||
;; (define (cdaadr x) (cdr (car (car (cdr x)))))
|
||||
;; (define (cdadar x) (cdr (car (cdr (car x)))))
|
||||
;; (define (cdaddr x) (cdr (car (cdr (cdr x)))))
|
||||
;; (define (cddaar x) (cdr (cdr (car (car x)))))
|
||||
;; (define (cddadr x) (cdr (cdr (car (cdr x)))))
|
||||
;; (define (cdddar x) (cdr (cdr (cdr (car 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
|
||||
|
||||
|
|
@ -40,8 +57,6 @@
|
|||
(mapn proc (cons ls lol) '())))
|
||||
|
||||
(define (map1 proc ls res)
|
||||
;; (write ls)
|
||||
;; (newline)
|
||||
(if (pair? ls)
|
||||
(map1 proc (cdr ls) (cons (proc (car ls)) res))
|
||||
(reverse res)))
|
||||
|
|
@ -49,5 +64,22 @@
|
|||
(define (mapn proc lol res)
|
||||
(if (null? lol)
|
||||
(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))))))))
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue