mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-08 13:37:35 +02:00
fixing silly macro expander bug (forgot to initialize the i index)
This commit is contained in:
parent
1ad276252f
commit
4ec2c98a58
2 changed files with 46 additions and 41 deletions
59
eval.c
59
eval.c
|
@ -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) {
|
||||
bytecode tmp;
|
||||
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->len = (*bc)->len*2;
|
||||
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 res, *stack = SEXP_ALLOC(sizeof(sexp)*INIT_STACK_SIZE);
|
||||
bytecode bc;
|
||||
unsigned int i;
|
||||
unsigned int i=0;
|
||||
fprintf(stderr, "expanding: ");
|
||||
sexp_write(form, cur_error_port);
|
||||
fprintf(stderr, "\n => ");
|
||||
bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+32);
|
||||
bc = (bytecode) SEXP_ALLOC(sizeof(struct bytecode)+64);
|
||||
bc->tag = SEXP_BYTECODE;
|
||||
bc->len = 32;
|
||||
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_word(&bc, &i, (sexp_uint_t) sexp_make_integer(3));
|
||||
emit(&bc, &i, OP_DONE);
|
||||
/* disasm(bc); */
|
||||
res = vm(bc, e, stack, 0);
|
||||
sexp_write(res, cur_error_port);
|
||||
fprintf(stderr, "\n");
|
||||
|
@ -194,6 +196,8 @@ void analyze(sexp obj, bytecode *bc, unsigned int *i, env e,
|
|||
case CORE_DEFINE_SYNTAX:
|
||||
env_define(e, SEXP_CADR(obj),
|
||||
sexp_make_macro((procedure) eval(SEXP_CADDR(obj), e), e));
|
||||
emit_push(bc, i, SEXP_UNDEF);
|
||||
(*d)++;
|
||||
break;
|
||||
case 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);
|
||||
}
|
||||
} else if (SEXP_PAIRP(SEXP_CAR(obj))) {
|
||||
o2 = env_cell(e, SEXP_CAAR(obj));
|
||||
if (o2
|
||||
&& SEXP_COREP(SEXP_CDR(o2))
|
||||
&& (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA)
|
||||
&& sexp_listp(SEXP_CADR(SEXP_CAR(obj)))) {
|
||||
/* let */
|
||||
tmp1 = sexp_length(SEXP_CADR(SEXP_CAR(obj)));
|
||||
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))
|
||||
analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0);
|
||||
params = sexp_append(SEXP_CADR(SEXP_CAR(obj)), params);
|
||||
for (o2=SEXP_CDDR(SEXP_CAR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) {
|
||||
if (SEXP_PAIRP(SEXP_CDR(o2))) {
|
||||
analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, 0);
|
||||
emit(bc, i, OP_DROP);
|
||||
} else {
|
||||
analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, tailp);
|
||||
}
|
||||
}
|
||||
emit(bc, i, OP_STACK_SET);
|
||||
emit_word(bc, i, tmp1+1);
|
||||
(*d) -= tmp1;
|
||||
for (tmp1; tmp1>0; tmp1--)
|
||||
emit(bc, i, OP_DROP);
|
||||
} else {
|
||||
/* o2 = env_cell(e, SEXP_CAAR(obj)); */
|
||||
/* if (o2 */
|
||||
/* && SEXP_COREP(SEXP_CDR(o2)) */
|
||||
/* && (((core_form)SEXP_CDR(o2))->code == CORE_LAMBDA) */
|
||||
/* && sexp_listp(SEXP_CADR(SEXP_CAR(obj)))) { */
|
||||
/* /\* let *\/ */
|
||||
/* tmp1 = sexp_length(SEXP_CADR(SEXP_CAR(obj))); */
|
||||
/* 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)) */
|
||||
/* analyze(SEXP_CAR(o2), bc, i, e, params, fv, sv, d, 0); */
|
||||
/* params = sexp_append(SEXP_CADR(SEXP_CAR(obj)), params); */
|
||||
/* for (o2=SEXP_CDDR(SEXP_CAR(obj)); SEXP_PAIRP(o2); o2=SEXP_CDR(o2)) { */
|
||||
/* if (SEXP_PAIRP(SEXP_CDR(o2))) { */
|
||||
/* analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, 0); */
|
||||
/* emit(bc, i, OP_DROP); */
|
||||
/* } else { */
|
||||
/* analyze(SEXP_CAR(o2), bc, i, e2, params, fv, sv, d, tailp); */
|
||||
/* } */
|
||||
/* } */
|
||||
/* emit(bc, i, OP_STACK_SET); */
|
||||
/* emit_word(bc, i, tmp1+1); */
|
||||
/* (*d) -= tmp1; */
|
||||
/* for (tmp1; tmp1>0; tmp1--) */
|
||||
/* emit(bc, i, OP_DROP); */
|
||||
/* } else */
|
||||
/* computed application */
|
||||
analyze_app(obj, bc, i, e, params, fv, sv, d, tailp);
|
||||
}
|
||||
} else {
|
||||
errx(1, "invalid operator: %s", SEXP_CAR(obj));
|
||||
}
|
||||
|
|
26
init.scm
26
init.scm
|
@ -62,9 +62,11 @@
|
|||
(reverse res)))
|
||||
|
||||
(define (mapn proc lol res)
|
||||
(if (null? lol)
|
||||
(if (null? (car lol))
|
||||
(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
|
||||
|
||||
|
@ -73,13 +75,13 @@
|
|||
(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))))))))
|
||||
;; (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