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

fixing jumps

Browse source
This commit is contained in:
Alex Shinn 2009-03-26 16:49:50 +09:00
parent 560cd92cec
commit f655930ce1
3 changed files with 45 additions and 46 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
debug.c
View file

@ -31,6 +31,8 @@ void disasm (sexp bc) {
case OP_LOCAL_SET: case OP_LOCAL_SET:
case OP_CLOSURE_REF: case OP_CLOSURE_REF:
case OP_PARAMETER: case OP_PARAMETER:
case OP_JUMP:
case OP_JUMP_UNLESS:
fprintf(stderr, "%ld", (long) ((sexp*)ip)[0]); fprintf(stderr, "%ld", (long) ((sexp*)ip)[0]);
ip += sizeof(sexp); ip += sizeof(sexp);
break; break;
@ -45,11 +47,6 @@ void disasm (sexp bc) {
ip += sizeof(sexp); ip += sizeof(sexp);
} }
break; break;
case OP_JUMP:
case OP_JUMP_UNLESS:
fprintf(stderr, "%d", ip[0]);
ip++;
break;
} }
fprintf(stderr, "\n"); fprintf(stderr, "\n");
if ((! (opcode == OP_RET) || (opcode == OP_DONE)) if ((! (opcode == OP_RET) || (opcode == OP_DONE))

42
eval.c
View file

@ -33,8 +33,8 @@ sexp analyze_define (sexp x, sexp env);
sexp analyze_var_ref (sexp x, sexp env); sexp analyze_var_ref (sexp x, sexp env);
sexp analyze_set (sexp x, sexp env); sexp analyze_set (sexp x, sexp env);
sexp_uint_t sexp_context_make_label (sexp context); sexp_sint_t sexp_context_make_label (sexp context);
void sexp_context_patch_label (sexp context, sexp_uint_t label); void sexp_context_patch_label (sexp context, sexp_sint_t label);
void compile_one (sexp x, sexp context); void compile_one (sexp x, sexp context);
void compile_lit (sexp value, sexp context); void compile_lit (sexp value, sexp context);
void compile_seq (sexp app, sexp context); void compile_seq (sexp app, sexp context);
@ -336,9 +336,9 @@ sexp analyze_seq (sexp ls, sexp env) {
sexp analyze_if (sexp x, sexp env) { sexp analyze_if (sexp x, sexp env) {
sexp test, pass, fail; sexp test, pass, fail;
analyze_bind(test, sexp_car(x), env); analyze_bind(test, sexp_cadr(x), env);
analyze_bind(pass, sexp_cadr(x), env); analyze_bind(pass, sexp_caddr(x), env);
analyze_bind(fail, sexp_pairp(sexp_cddr(x))?sexp_caddr(x):SEXP_UNDEF, env); analyze_bind(fail, sexp_pairp(sexp_cdddr(x))?sexp_cadddr(x):SEXP_UNDEF, env);
return sexp_make_cnd(test, pass, fail); return sexp_make_cnd(test, pass, fail);
} }
@ -386,16 +386,16 @@ sexp analyze_set (sexp x, sexp env) {
return sexp_make_set(ref, value); return sexp_make_set(ref, value);
} }
sexp_uint_t sexp_context_make_label (sexp context) { sexp_sint_t sexp_context_make_label (sexp context) {
sexp_uint_t label = sexp_context_pos(context); sexp_sint_t label = sexp_context_pos(context);
sexp_context_pos(context) += sizeof(sexp_uint_t); sexp_context_pos(context) += sizeof(sexp_uint_t);
return label; return label;
} }
void sexp_context_patch_label (sexp context, sexp_uint_t label) { void sexp_context_patch_label (sexp context, sexp_sint_t label) {
sexp bc = sexp_context_bc(context); sexp bc = sexp_context_bc(context);
((sexp_uint_t*) sexp_bytecode_data(bc))[label] unsigned char *data = sexp_bytecode_data(bc)+label;
= sexp_context_pos(context)-label; *((sexp_sint_t*)data) = sexp_context_pos(context)-label;
} }
static sexp finalize_bytecode (sexp context) { static sexp finalize_bytecode (sexp context) {
@ -452,7 +452,7 @@ void compile_seq (sexp app, sexp context) {
} }
void compile_cnd (sexp cnd, sexp context) { void compile_cnd (sexp cnd, sexp context) {
sexp_uint_t label1, label2; sexp_sint_t label1, label2;
compile_one(sexp_cnd_test(cnd), context); compile_one(sexp_cnd_test(cnd), context);
emit(OP_JUMP_UNLESS, context); emit(OP_JUMP_UNLESS, context);
sexp_context_depth(context)--; sexp_context_depth(context)--;
@ -1067,21 +1067,23 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) {
stack[top] = sexp_make_integer(1); stack[top] = sexp_make_integer(1);
stack[top+1] = sexp_make_integer(ip); stack[top+1] = sexp_make_integer(ip);
stack[top+2] = cp; stack[top+2] = cp;
stack[top+3] = (sexp) fp;
_ARG1 _ARG1
= sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(1), = sexp_make_procedure(sexp_make_integer(0), sexp_make_integer(1),
continuation_resumer, continuation_resumer,
sexp_vector(1, sexp_save_stack(stack, top+3))); sexp_vector(1, sexp_save_stack(stack, top+4)));
top++; top++;
ip -= sizeof(sexp); ip -= sizeof(sexp);
goto make_call; goto make_call;
break; break;
case OP_RESUMECC: case OP_RESUMECC:
tmp1 = _ARG4; tmp1 = _ARG5;
top = sexp_restore_stack(sexp_vector_ref(cp, 0), stack); top = sexp_restore_stack(sexp_vector_ref(cp, 0), stack);
cp = _ARG1; fp = (sexp_sint_t) _ARG1;
ip = (unsigned char*) sexp_unbox_integer(_ARG2); cp = _ARG2;
i = sexp_unbox_integer(_ARG3); ip = (unsigned char*) sexp_unbox_integer(_ARG3);
top -= 3; i = sexp_unbox_integer(_ARG4);
top -= 4;
_ARG1 = tmp1; _ARG1 = tmp1;
break; break;
case OP_ERROR: case OP_ERROR:
@ -1117,13 +1119,13 @@ sexp vm(sexp bc, sexp cp, sexp e, sexp* stack, sexp_sint_t top) {
break; break;
case OP_JUMP_UNLESS: case OP_JUMP_UNLESS:
if (stack[--top] == SEXP_FALSE) { if (stack[--top] == SEXP_FALSE) {
ip += ((sexp_uint_t*)ip)[0]; ip += ((sexp_sint_t*)ip)[0];
} else { } else {
ip++; ip += sizeof(sexp_sint_t);
} }
break; break;
case OP_JUMP: case OP_JUMP:
ip += ((sexp_uint_t*)ip)[0]; ip += ((sexp_sint_t*)ip)[0];
break; break;
case OP_DISPLAY: case OP_DISPLAY:
if (sexp_stringp(_ARG1)) { if (sexp_stringp(_ARG1)) {

42
init.scm
View file

@ -76,26 +76,26 @@
;; syntax ;; syntax
(define-syntax letrec ;; (define-syntax letrec
(lambda (expr use-env mac-env) ;; (lambda (expr use-env mac-env)
(list ;; (list
(cons 'lambda ;; (cons 'lambda
(cons '() ;; (cons '()
(append (map (lambda (x) (cons 'define x)) (cadr expr)) ;; (append (map (lambda (x) (cons 'define x)) (cadr expr))
(cddr expr))))))) ;; (cddr expr)))))))
(define-syntax let ;; (define-syntax let
(lambda (expr use-env mac-env) ;; (lambda (expr use-env mac-env)
(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))))))))