Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-08 13:37:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

fixing silly macro expander bug (forgot to initialize the i index)

Browse source
This commit is contained in:
Alex Shinn 2009-03-14 11:33:54 +09:00
parent 1ad276252f
commit 4ec2c98a58
2 changed files with 46 additions and 41 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

61
eval.c
View file

@ -102,6 +102,7 @@ static void shrink_bcode(bytecode *bc, unsigned int i) {
static void expand_bcode(bytecode *bc, unsigned int *i, unsigned int size) { static void expand_bcode(bytecode *bc, unsigned int *i, unsigned int size) {
bytecode tmp; bytecode tmp;
if ((*bc)->len < (*i)+size) { if ((*bc)->len < (*i)+size) {
fprintf(stderr, "expanding bytecode %u < %u + %u = %u\n", (*bc)->len, (*i), size, (*i)+size);
tmp = (bytecode) SEXP_ALLOC(sizeof(unsigned int) + (*bc)->len*2); tmp = (bytecode) SEXP_ALLOC(sizeof(unsigned int) + (*bc)->len*2);
tmp->len = (*bc)->len*2; tmp->len = (*bc)->len*2;
memcpy(tmp->data, (*bc)->data, (*bc)->len); memcpy(tmp->data, (*bc)->data, (*bc)->len);
@ -148,11 +149,11 @@ static sexp sexp_make_macro (procedure p, env e) {
sexp sexp_expand_macro (macro mac, sexp form, env e) { sexp sexp_expand_macro (macro mac, sexp form, env e) {
sexp res, *stack = SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE); sexp res, *stack = SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE);
bytecode bc; bytecode bc;
unsigned int i; unsigned int i=0;
fprintf(stderr, "expanding: "); fprintf(stderr, "expanding: ");
sexp_write(form, cur_error_port); sexp_write(form, cur_error_port);
fprintf(stderr, "\n => "); fprintf(stderr, "\n => ");
bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+32); bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+64);
bc->tag = SEXP_BYTECODE; bc->tag = SEXP_BYTECODE;
bc->len = 32; bc->len = 32;
emit_push(&bc, &i, mac->e); emit_push(&bc, &i, mac->e);
@ -162,6 +163,7 @@ sexp sexp_expand_macro (macro mac, sexp form, env e) {
emit(&bc, &i, OP_CALL); emit(&bc, &i, OP_CALL);
emit_word(&bc, &i, (sexp_uint_t) sexp_make_integer(3)); emit_word(&bc, &i, (sexp_uint_t) sexp_make_integer(3));
emit(&bc, &i, OP_DONE); emit(&bc, &i, OP_DONE);
/* disasm(bc); */
res = vm(bc, e, stack, 0); res = vm(bc, e, stack, 0);
sexp_write(res, cur_error_port); sexp_write(res, cur_error_port);
fprintf(stderr, "\n"); fprintf(stderr, "\n");
@ -194,6 +196,8 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
case CORE_DEFINE_SYNTAX: case CORE_DEFINE_SYNTAX:
env_define(e, SEXP_CADR(obj), env_define(e, SEXP_CADR(obj),
sexp_make_macro((procedure) eval(SEXP_CADDR(obj), e), e)); sexp_make_macro((procedure) eval(SEXP_CADDR(obj), e), e));
emit_push(bc, i, SEXP_UNDEF);
(*d)++;
break; break;
case CORE_DEFINE: case CORE_DEFINE:
if ((((core_form)o1)->code == CORE_DEFINE) if ((((core_form)o1)->code == CORE_DEFINE)
@ -271,34 +275,33 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); analyze_app(obj, bc, i, e, params, fv, sv, d, tailp);
} }
} else if (SEXP_PAIRP(SEXP_CAR(obj))) { } else if (SEXP_PAIRP(SEXP_CAR(obj))) {
o2 = env_cell(e, SEXP_CAAR(obj)); /* o2 = env_cell(e, SEXP_CAAR(obj)); */
if (o2 /* if (o2 */
&& SEXP_COREP(SEXP_CDR(o2)) /* && SEXP_COREP(SEXP_CDR(o2)) */
&& (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA) /* && (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA) */
&& sexp_listp(SEXP_CADR(SEXP_CAR(obj)))) { /* && sexp_listp(SEXP_CADR(SEXP_CAR(obj)))) { */
/* let */ /* /\* let *\/ */
tmp1 = sexp_length(SEXP_CADR(SEXP_CAR(obj))); /* tmp1 = sexp_length(SEXP_CADR(SEXP_CAR(obj))); */
e2 = extend_env_closure(e, SEXP_CADR(SEXP_CAR(obj)), (*d)); /* e2 = extend_env_closure(e, SEXP_CADR(SEXP_CAR(obj)), (*d)); */
for (o2=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) /* for (o2=sexp_reverse(SEXP_CDR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) */
analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); /* analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); */
params = sexp_append(SEXP_CADR(SEXP_CAR(obj)), params); /* params = sexp_append(SEXP_CADR(SEXP_CAR(obj)), params); */
for (o2=SEXP_CDDR(SEXP_CAR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) { /* for (o2=SEXP_CDDR(SEXP_CAR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) { */
if (SEXP_PAIRP(SEXP_CDR(o2))) { /* if (SEXP_PAIRP(SEXP_CDR(o2))) { */
analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, 0); /* analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, 0); */
emit(bc, i, OP_DROP); /* emit(bc, i, OP_DROP); */
} else { /* } else { */
analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, tailp); /* analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, tailp); */
} /* } */
} /* } */
emit(bc, i, OP_STACK_SET); /* emit(bc, i, OP_STACK_SET); */
emit_word(bc, i, tmp1+1); /* emit_word(bc, i, tmp1+1); */
(*d) -= tmp1; /* (*d) -= tmp1; */
for (tmp1; tmp1>0; tmp1--) /* for (tmp1; tmp1>0; tmp1--) */
emit(bc, i, OP_DROP); /* emit(bc, i, OP_DROP); */
} else { /* } else */
/* computed application */ /* computed application */
analyze_app(obj, bc, i, e, params, fv, sv, d, tailp); analyze_app(obj, bc, i, e, params, fv, sv, d, tailp);
}
} else { } else {
errx(1, "invalid operator: %s", SEXP_CAR(obj)); errx(1, "invalid operator: %s", SEXP_CAR(obj));
} }

26
init.scm
View file

@ -62,9 +62,11 @@
(reverse res))) (reverse res)))
(define (mapn proc lol res) (define (mapn proc lol res)
(if (null? lol) (if (null? (car lol))
(reverse res) (reverse res)
(mapn proc (cdr lol) (cons (apply1 proc (map1 car lol '())) res)))) (mapn proc
(map1 cdr lol '())
(cons (apply1 proc (map1 car lol '())) res))))
;; syntax ;; syntax
@ -73,13 +75,13 @@
(cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr))) (cons (cons 'lambda (cons (map car (cadr expr)) (cddr expr)))
(map cadr (cadr expr))))) (map cadr (cadr expr)))))
(define-syntax or ;; (define-syntax or
(lambda (expr use-env mac-env) ;; (lambda (expr use-env mac-env)
(if (null? (cdr expr)) ;; (if (null? (cdr expr))
#f ;; #f
(if (null? (cddr expr)) ;; (if (null? (cddr expr))
(cadr expr) ;; (cadr expr)
(list 'let (list (list 'tmp (cadr expr))) ;; (list 'let (list (list 'tmp (cadr expr)))
(list 'if 'tmp ;; (list 'if 'tmp
'tmp ;; 'tmp
(cons 'or (cddr expr)))))))) ;; (cons 'or (cddr expr))))))))