diff --git a/gdbinit b/gdbinit index ad7881f2a..cd3add5fb 100644 --- a/gdbinit +++ b/gdbinit @@ -1,7 +1,13 @@ +# -*- GDB-Script -*- + define newline call (void)scm_newline (scm_current_error_port ()) end +define pp + call (void)scm_call_1 (scm_variable_ref (scm_c_module_lookup (scm_c_resolve_module ("ice-9 pretty-print"), "pretty-print")), $arg0) +end + define gdisplay call (void)scm_display ($arg0, scm_current_error_port ()) newline @@ -194,3 +200,7 @@ define vmstack nextframe end end + +define inst + p scm_instruction_table[$arg0] +end diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 43e5284b3..eae3ecde8 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -34,7 +34,7 @@ SOURCES = psyntax-pp.scm boot-9.scm \ and-let-star.scm calling.scm common-list.scm \ debug.scm debugger.scm documentation.scm emacs.scm expect.scm \ format.scm getopt-long.scm hcons.scm i18n.scm \ - lineio.scm ls.scm mapping.scm \ + lineio.scm ls.scm mapping.scm match.scm \ networking.scm null.scm optargs.scm poe.scm \ popen.scm posix.scm q.scm r4rs.scm r5rs.scm \ rdelim.scm receive.scm regex.scm runq.scm rw.scm \ @@ -45,17 +45,13 @@ SOURCES = psyntax-pp.scm boot-9.scm \ weak-vector.scm deprecated.scm list.scm serialize.scm \ gds-server.scm -# match.scm compiles, but then using it (via -# snarf-check-and-output-texi) fails. need to figure out what the -# problem is. -# # occam-channel and gds-client use goops, which is not yet vm-compatible # (it does some compilation-like optimizations for the interpreter), so # punt on them for the time being. # # psyntax.scm needs help. fortunately it's only needed when recompiling # psyntax-pp.scm. -NOCOMP_SOURCES = match.scm occam-channel.scm gds-client.scm psyntax.scm +NOCOMP_SOURCES = occam-channel.scm gds-client.scm psyntax.scm include $(top_srcdir)/guilec.mk diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 3956a389d..84af98c07 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -180,6 +180,12 @@ vm_run (SCM vm, SCM program, SCM args) err_msg = scm_from_locale_string ("VM: Attempt to unroll an improper list: tail is ~A"); goto vm_error; + vm_error_not_a_pair: + SYNC_ALL (); + scm_wrong_type_arg_msg (FUNC_NAME, 1, err_args, "pair"); + /* shouldn't get here */ + goto vm_error; + vm_error_no_values: err_msg = scm_from_locale_string ("VM: 0-valued return"); err_args = SCM_EOL; diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index ee724d633..d4dac80d3 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -134,24 +134,30 @@ VM_DEFINE_FUNCTION (cons, "cons", 2) RETURN (x); } +#define VM_VALIDATE_CONS(x) \ + if (SCM_UNLIKELY (!scm_is_pair (x))) \ + { err_args = x; \ + goto vm_error_not_a_pair; \ + } + VM_DEFINE_FUNCTION (car, "car", 1) { ARGS1 (x); - SCM_VALIDATE_CONS (1, x); + VM_VALIDATE_CONS (x); RETURN (SCM_CAR (x)); } VM_DEFINE_FUNCTION (cdr, "cdr", 1) { ARGS1 (x); - SCM_VALIDATE_CONS (1, x); + VM_VALIDATE_CONS (x); RETURN (SCM_CDR (x)); } VM_DEFINE_FUNCTION (set_car, "set-car!", 2) { ARGS2 (x, y); - SCM_VALIDATE_CONS (1, x); + VM_VALIDATE_CONS (x); SCM_SETCAR (x, y); RETURN (SCM_UNSPECIFIED); } @@ -159,7 +165,7 @@ VM_DEFINE_FUNCTION (set_car, "set-car!", 2) VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2) { ARGS2 (x, y); - SCM_VALIDATE_CONS (1, x); + VM_VALIDATE_CONS (x); SCM_SETCDR (x, y); RETURN (SCM_UNSPECIFIED); } diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index fbb94c89a..2da2d4249 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -621,7 +621,13 @@ VM_DEFINE_INSTRUCTION (goto_args, "goto/args", 1, -1, 1) /* Drop the first argument and the program itself. */ sp -= 2; - NULLSTACK (bp->nargs + 1) + NULLSTACK (bp->nargs + 1); + + /* Freshen the externals */ + external = bp->external; + for (i = 0; i < bp->nexts; i++) + CONS (external, SCM_UNDEFINED, external); + SCM_FRAME_DATA_ADDRESS (fp)[0] = external; /* Call itself */ ip = bp->base; diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm index 20ea7b5c1..26bc2727b 100644 --- a/module/system/vm/assemble.scm +++ b/module/system/vm/assemble.scm @@ -355,6 +355,11 @@ (push-code! `(make-int16 ,(ash x -8) ,(logand x (1- (ash 1 8))))))) (else ;; Other cases + (if (> (+ nargs nlocs) 255) + (error "too many locals" nargs nlocs)) + ;; really it should be a flag.. + (if (> nrest 1) (error "nrest should be 0 or 1" nrest)) + (if (> next 255) (error "too many externals" next)) (push-code! (object->code nargs)) (push-code! (object->code nrest)) (push-code! (object->code nlocs)) diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm index 5ec1c004b..efb8ae396 100644 --- a/module/system/vm/disasm.scm +++ b/module/system/vm/disasm.scm @@ -109,7 +109,7 @@ (do ((n 0 (1+ n)) (l exts (cdr l))) ((null? l) (newline)) - (print-info n (car l) #f)))) + (print-info n (car l) #f #f)))) (define-macro (unless test . body) `(if (not ,test) (begin ,@body))) diff --git a/oop/goops/dispatch.scm b/oop/goops/dispatch.scm index 73f413234..d8b97b6d1 100644 --- a/oop/goops/dispatch.scm +++ b/oop/goops/dispatch.scm @@ -179,6 +179,8 @@ ((not (struct? (car classes))) sum) (set! sum (+ sum (struct-ref (car classes) hashset-index)))))) +;;; FIXME: the throw probably is expensive, given that this function +;;; might be called an average of 3 or 4 times per rehash... (define (cache-try-hash! min-misses hashset cache entries) (let ((max-misses 0) (mask (- (vector-length cache) 1))) diff --git a/testsuite/Makefile.am b/testsuite/Makefile.am index 6ff48b5de..8545d86e4 100644 --- a/testsuite/Makefile.am +++ b/testsuite/Makefile.am @@ -11,6 +11,7 @@ vm_test_files = \ t-closure.scm \ t-closure2.scm \ t-closure3.scm \ + t-closure4.scm \ t-do-loop.scm \ t-macros.scm \ t-macros2.scm \ diff --git a/testsuite/t-closure4.scm b/testsuite/t-closure4.scm new file mode 100644 index 000000000..61258012f --- /dev/null +++ b/testsuite/t-closure4.scm @@ -0,0 +1,22 @@ +(define (extract-symbols exp) + (define (process x out cont) + (cond ((pair? x) + (process (car x) + out + (lambda (car-x out) + ;; used to have a bug here whereby `x' was + ;; modified in the self-tail-recursion to (process + ;; (cdr x) ...), because we didn't allocate fresh + ;; externals when doing self-tail-recursion. + (process (cdr x) + out + (lambda (cdr-x out) + (cont (cons car-x cdr-x) + out)))))) + ((symbol? x) + (cont x (cons x out))) + (else + (cont x out)))) + (process exp '() (lambda (x out) out))) + +(extract-symbols '(a b . c))