mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-08 21:47:33 +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
61
eval.c
61
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) {
|
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
26
init.scm
|
@ -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))))))))
|
||||||
|
|
Loading…
Add table
Reference in a new issue