*** empty log message ***

module/language/gscheme/spec.scm

@@ -26,23 +26,6 @@
   :use-module (ice-9 and-let-star)
   :export (gscheme))
 
-
-;;;
-;;; Macro expander
-;;;
-
-(define (expand x)
-  (expand-macro x (current-module)))
-
-(define (expand-macro x m)
-  (if (pair? x)
-      (let* ((s (car x))
-	     (v (and (symbol? s) (module-defined? m s) (module-ref m s))))
-	(if (defmacro? v)
-	    (expand-macro (apply (defmacro-transformer v) (cdr x)) m)
-	    (cons (expand-macro (car x) m) (expand-macro (cdr x) m))))
-      x))
-
 
 ;;;
 ;;; Translator
@@ -111,10 +94,22 @@
 					  (_loop ,@(map translate update)))))))
 		    (_loop ,@(map translate init))))))
       (else
-       (let ((prim (and (symbol? head) (symbol-append '@ head))))
+       (let ((e (expand x)))
-	 (if (and prim (ghil-primitive? prim))
+	 (if (eq? e x)
-	     (cons prim (map translate rest))
+	     (let ((prim (and (symbol? head) (symbol-append '@ head))))
-	     (cons (translate head) (map translate rest))))))))
+	       (if (and prim (ghil-primitive? prim))
+		   (cons prim (map translate rest))
+		   (cons (translate head) (map translate rest))))
+	     (translate e)))))))
+
+(define (expand x)
+  (if (and (symbol? (car x))
+	   (module-defined? (current-module) (car x)))
+      (let ((v (module-ref (current-module) (car x))))
+	(if (defmacro? v)
+	    (apply (defmacro-transformer v) (cdr x))
+	    x))
+      x))
 
 
 ;;;
@@ -125,7 +120,6 @@
   :title	"Guile Scheme"
   :version	"0.4"
   :reader	read
-  :expander	expand
   :translator	translate
   :printer	write
   )

module/system/il/compile.scm

@@ -136,14 +136,14 @@
 	 ;;     TEST
 	 ;;     (br-if-not L1)
 	 ;;     THEN
-	 ;;     (jump L2)
+	 ;;     (br L2)
 	 ;; L1: ELSE
 	 ;; L2:
 	 (let ((L1 (make-label)) (L2 (make-label)))
 	   (comp-push test)
 	   (push-code! (make-<glil-branch> 'br-if-not L1))
 	   (comp-tail then)
-	   (if (not tail) (push-code! (make-<glil-branch> 'jump L2)))
+	   (if (not tail) (push-code! (make-<glil-branch> 'br L2)))
 	   (push-code! (make-<glil-label> L1))
 	   (comp-tail else)
 	   (if (not tail) (push-code! (make-<glil-label> L2)))))

module/system/il/glil.scm

@@ -156,7 +156,7 @@
     (($ <glil-module> op module name)
      `(,(symbol-append 'module- op) ,module ,name))
     ;; controls
-    (($ <glil-label> label) `(label ,label))
+    (($ <glil-label> label) label)
     (($ <glil-branch> inst label) `(,inst ,label))
     (($ <glil-call> inst nargs) `(,inst ,nargs))))
 
@@ -168,14 +168,13 @@
 (define (pprint-glil glil)
   (let print ((code (unparse glil)) (column 0))
     (display (make-string column #\space))
-    (case (car code)
+    (cond ((and (pair? code) (eq? (car code) '@asm))
-      ((@asm)
+	   (format #t "(@asm ~A\n" (cadr code))
-       (format #t "(@asm ~A\n" (cadr code))
+	   (let ((col (+ column 2)))
-       (let ((col (+ column 2)))
+	     (let loop ((l (cddr code)))
-	 (let loop ((l (cddr code)))
+	       (print (car l) col)
-	   (print (car l) col)
+	       (if (null? (cdr l))
-	   (if (null? (cdr l))
+		   (display ")")
-	       (display ")")
+		   (begin (newline) (loop (cdr l)))))))
-	       (begin (newline) (loop (cdr l)))))))
+	  (else (write code))))
-      (else (write code))))
   (newline))

module/system/vm/assemble.scm

@@ -41,7 +41,7 @@
 (define-structure (venv parent nexts closure?))
 (define-structure (vmod id))
 (define-structure (vlink module name))
-(define-structure (bytespec nargs nrest nlocs nexts bytes objs))
+(define-structure (bytespec nargs nrest nlocs nexts bytes objs closure?))
 
 
 ;;;
@@ -74,33 +74,17 @@
 	   (label-alist '())
 	   (object-alist '()))
        (define (push-code! code)
-	 (set! stack (optimizing-push code stack)))
+	 (set! stack (cons (code->bytes code) stack)))
        (define (push-object! x)
 	 (cond ((object->code x) => push-code!)
-	       (toplevel
+	       (toplevel (dump-object! push-code! x))
-		;; top-level object-dump
-		(cond ((object-assoc x object-alist) =>
-		       (lambda (obj+index)
-			 (cond ((not (cdr obj+index))
-				(set-cdr! obj+index nlocs)
-				(set! nlocs (+ nlocs 1))))
-			 (push-code! `(local-ref ,(cdr obj+index)))))
-		      (else
-		       (set! object-alist (acons x #f object-alist))
-		       (push-code! `(object-dump ,x)))))
 	       (else
-		;; local object-ref
 		(let ((i (cond ((object-assoc x object-alist) => cdr)
 			       (else
 				(let ((i (length object-alist)))
 				  (set! object-alist (acons x i object-alist))
 				  i)))))
 		  (push-code! `(object-ref ,i))))))
-       (define (label-ref key)
-	 (assq-ref label-alist key))
-       (define (label-set key)
-	 (let ((addr (apply + (map length stack))))
-	   (set! label-alist (assq-set! label-alist key addr))))
        (define (generate-code x)
 	 (match x
 	   (($ <vm-asm> venv)
@@ -108,7 +92,7 @@
 	    (if (venv-closure? venv) (push-code! `(make-closure))))
 
 	   (($ <glil-void>)
-	    (push-code! `(void)))
+	    (push-code! '(void)))
 
 	   (($ <glil-const> x)
 	    (push-object! x))
@@ -139,11 +123,14 @@
 		(push-code! '(variable-set))))
 
 	   (($ <glil-label> label)
-	    (label-set label))
+	    (define (byte-length x)
+	      (cond ((string? x) (string-length x))
+		    (else 3)))
+	    (let ((addr (apply + (map byte-length stack))))
+	      (set! label-alist (assq-set! label-alist label addr))))
 
 	   (($ <glil-branch> inst label)
-	    (let ((setter (lambda (addr) (- (label-ref label) addr))))
+	    (set! stack (cons (list inst label) stack)))
-	      (push-code! (list inst setter))))
 
 	   (($ <glil-call> inst nargs)
 	    (if (instruction? inst)
@@ -158,73 +145,31 @@
        ;;
        ;; main
        (for-each generate-code body)
-       (if toplevel
+       (let ((bytes (stack->bytes (reverse! stack) label-alist)))
-	   ;; top-level
+	 (if toplevel
-	   (let ((new '()))
+	     (make-dumpcode nlocs nexts bytes)
-	     (define (push-code! x)
+	     (let ((objs (map car (reverse! object-alist))))
-	       (set! new (cons x new)))
+	       (make-bytespec nargs nrest nlocs nexts bytes objs
-	     (do ((stack (reverse! stack) (cdr stack)))
+			      (venv-closure? venv)))))))))
-		 ((null? stack)
-		  (make-dumpcode nlocs nexts (stack->bytes (reverse! new))))
-	       (if (eq? (caar stack) 'object-dump)
-		   (let ((x (cadar stack)))
-		     (dump-object! push-code! x)
-		     (cond ((object-assoc x object-alist) =>
-			    (lambda (obj+index)
-			      (cond ((cdr obj+index) =>
-				     (lambda (n)
-				       (push-code! '(dup))
-				       (push-code! `(local-set ,n)))))))))
-		   (push-code! (car stack)))))
-	   ;; closures
-	   (let ((bytes (stack->bytes (reverse! stack)))
-		 (objs (map car (reverse! object-alist))))
-	     (make-bytespec nargs nrest nlocs nexts bytes objs)))))))
 
 (define (object-assoc x alist)
   (if (vlink? x) (assoc x alist) (assq x alist)))
 
-(define (stack->bytes stack)
+(define (stack->bytes stack label-alist)
   (let loop ((result '()) (stack stack) (addr 0))
     (if (null? stack)
 	(apply string-append (reverse! result))
-	(let* ((orig (car stack))
+	(let ((bytes (car stack)))
-	       (addr (+ addr (length orig)))
+	  (if (pair? bytes)
-	       (code (if (and (pair? (cdr orig)) (procedure? (cadr orig)))
+	      (let* ((offset (- (assq-ref label-alist (cadr bytes))
-			 `(,(car orig) ,((cadr orig) addr))
+				(+ addr 3)))
-			 orig)))
+		     (n (if (< offset 0) (+ offset 65536) offset)))
-	  (loop (cons (code->bytes code) result) (cdr stack) addr)))))
+		(set! bytes (code->bytes (list (car bytes)
-
+					       (quotient n 256)
-
+					       (modulo n 256))))))
-;;;
+	  (loop (cons bytes result)
-;;; Bytecode optimization
+		(cdr stack)
-;;;
+		(+ addr (string-length bytes)))))))
-
-(define *optimization-table*
-  '((not       (not       . not-not)
-	       (eq?       . not-eq?)
-	       (null?     . not-null?)
-	       (not-not   . not)
-	       (not-eq?   . eq?)
-	       (not-null? . null?))
-    (br-if     (not       . br-if-not)
-	       (eq?       . br-if-eq)
-	       (null?     . br-if-null)
-	       (not-not   . br-if)
-	       (not-eq?   . br-if-not-eq)
-	       (not-null? . br-if-not-null))
-    (br-if-not (not       . br-if)
-	       (eq?       . br-if-not-eq)
-	       (null?     . br-if-not-null)
-	       (not-not   . br-if-not)
-	       (not-eq?   . br-if-eq)
-	       (not-null? . br-if-null))))
-
-(define (optimizing-push code stack)
-  (let ((alist (assq-ref *optimization-table* (car code))))
-    (cond ((and alist (pair? stack) (assq-ref alist (caar stack))) =>
-	   (lambda (inst) (cons (cons inst (cdr code)) (cdr stack))))
-	  (else (cons (code-pack code) stack)))))
 
 
 ;;;
@@ -239,7 +184,7 @@
      ((object->code x) => push-code!)
      ((bytespec? x)
       (match x
-	(($ bytespec nargs nrest nlocs nexts bytes objs)
+	(($ bytespec nargs nrest nlocs nexts bytes objs closure?)
 	 ;; dump parameters
 	 (cond
 	  ((and (< nargs 4) (< nlocs 8) (< nexts 4))
@@ -264,7 +209,7 @@
 	 ;; dump bytecode
 	 (push-code! `(load-program ,bytes)))))
      ((vlink? x)
-      (dump! (vlink-module x))
+      ;;; (dump! (vlink-module x))  ;; FIXME: no module support now
       (dump! (vlink-name x))
       (push-code! `(link)))
      ((vmod? x)

module/system/vm/conv.scm

@@ -36,11 +36,6 @@
      (cond ((< n 10)
 	    (let ((abbrev (string->symbol (format #f "~A:~A" inst n))))
 	      (if (instruction? abbrev) (list abbrev) code)))
-	   ((> n 255)
-	    (let ((double (string->symbol (format #f "~A*2" inst))))
-	      (if (instruction? double)
-		  (list double (quotient n 256) (modulo n 256))
-		  (apply error "Index out of range:" code))))
 	   (else code)))
     (else code)))
 
@@ -91,7 +86,8 @@
     (else #f)))
 
 (define (code->bytes code)
-  (let* ((inst (car code))
+  (let* ((code (code-pack code))
+	 (inst (car code))
 	 (rest (cdr code))
 	 (head (make-string 1 (integer->char (instruction->opcode inst))))
 	 (len (instruction-length inst)))

module/system/vm/disasm.scm

@@ -44,7 +44,8 @@
 	 (nlocs (caddr arity))
 	 (nexts (cadddr arity))
 	 (bytes (program-bytecode prog))
-	 (objs  (program-objects prog)))
+	 (objs  (program-objects prog))
+	 (exts  (program-external prog)))
     ;; Disassemble this bytecode
     (format #t "Disassembly of ~A:\n\n" prog)
     (format #t "nargs = ~A  nrest = ~A  nlocs = ~A  nexts = ~A\n\n"
@@ -53,6 +54,8 @@
     (disassemble-bytecode bytes objs)
     (if (> (vector-length objs) 0)
 	(disassemble-objects objs))
+    (if (pair? exts)
+	(disassemble-externals exts))
     ;; Disassemble other bytecode in it
     (for-each
      (lambda (x)
@@ -89,6 +92,15 @@
       (let ((info (object->string (vector-ref objs n))))
 	(print-info n info #f)))))
 
+(define (disassemble-externals exts)
+  (display "Externals:\n\n")
+  (let ((len (length exts)))
+    (do ((n 0 (1+ n))
+	 (l exts (cdr l)))
+	((null? l) (newline))
+      (let ((info (object->string (car l))))
+	(print-info n info #f)))))
+
 (define (disassemble-meta meta)
   (display "Meta info:\n\n")
   (for-each (lambda (data)
@@ -98,11 +110,12 @@
 
 (define (original-value addr code objs)
   (define (branch-code? code)
-    (string-match "^(br|jump)" (symbol->string (car code))))
+    (string-match "^br" (symbol->string (car code))))
   (let ((code (code-unpack code)))
     (cond ((code->object code) => object->string)
 	  ((branch-code? code)
-	   (format #f "-> ~A" (+ addr (cadr code) 2)))
+	   (let ((offset (+ (* (cadr code) 256) (caddr code))))
+	     (format #f "-> ~A" (+ addr offset 3))))
 	  (else
 	   (let ((inst (car code)) (args (cdr code)))
 	     (case inst

module/system/vm/load.scm

@@ -20,8 +20,8 @@
 ;;; Code:
 
 (define-module (system vm load)
-  :use-module (system vm core)
   :autoload (system base language) (compile-file-in lookup-language)
+  :use-module (system vm core)
   :use-module (ice-9 regex)
   :export (load/compile))
 

module/system/vm/trace.scm

@@ -20,6 +20,7 @@
 ;;; Code:
 
 (define-module (system vm trace)
+  :use-syntax (system base syntax)
   :use-module (system vm core)
   :use-module (system vm frame)
   :use-module (ice-9 format)
@@ -49,7 +50,7 @@
       (case (car opts)
 	((:s) (format #t "~20S" (vm-fetch-stack vm)))
 	((:v) (format #t "~20S" (frame-variables frame)))
-	((:e) (format #t "~20S" (program-external (frame-program frame))))))))
+	((:e) (format #t "~20A" (object->string (frame-external-link frame))))))))
 
 (define (trace-apply vm)
   (if (vm-option vm 'trace-first)

src/vm.c

@@ -64,10 +64,11 @@ make_vm_heap_frame (SCM *fp)
 {
   struct scm_vm_heap_frame *p =
     scm_must_malloc (sizeof (struct scm_vm_heap_frame), "make_vm_heap_frame");
-  p->fp           = fp;
+  p->fp            = fp;
-  p->program      = SCM_UNDEFINED;
+  p->program       = SCM_UNDEFINED;
-  p->variables    = SCM_UNDEFINED;
+  p->variables     = SCM_UNDEFINED;
-  p->dynamic_link = SCM_UNDEFINED;
+  p->dynamic_link  = SCM_UNDEFINED;
+  p->external_link = SCM_UNDEFINED;
   SCM_RETURN_NEWSMOB (scm_tc16_vm_heap_frame, p);
 }
 
@@ -77,7 +78,8 @@ vm_heap_frame_mark (SCM obj)
   struct scm_vm_heap_frame *p = SCM_VM_HEAP_FRAME_DATA (obj);
   scm_gc_mark (p->program);
   scm_gc_mark (p->variables);
-  return p->dynamic_link;
+  scm_gc_mark (p->dynamic_link);
+  return p->external_link;
 }
 
 /* Scheme interface */
@@ -146,6 +148,23 @@ SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0,
+	    (SCM frame),
+	    "")
+#define FUNC_NAME s_scm_frame_external_link
+{
+  struct scm_vm_heap_frame *p;
+
+  SCM_VALIDATE_VM_HEAP_FRAME (1, frame);
+  p = SCM_VM_HEAP_FRAME_DATA (frame);
+
+  if (SCM_UNBNDP (p->external_link))
+    p->external_link = SCM_VM_FRAME_EXTERNAL_LINK (p->fp);
+
+  return p->external_link;
+}
+#undef FUNC_NAME
+
 
 /*
  * VM Continuation
@@ -213,7 +232,7 @@ vm_cont_free (SCM obj)
  * VM Internal functions
  */
 
-SCM_SYMBOL (sym_vm_engine, "vm-engine");
+SCM_SYMBOL (sym_vm_run, "vm-run");
 SCM_SYMBOL (sym_vm_error, "vm-error");
 
 static scm_byte_t *
@@ -307,7 +326,7 @@ vm_mark (SCM obj)
       for (; sp >= upper; sp--)
 	if (SCM_NIMP (*sp))
 	  scm_gc_mark (*sp);
-      fp = SCM_VM_STACK_ADDRESS (*sp);		/* dynamic link */
+      fp = SCM_VM_STACK_ADDRESS (sp[-1]);	/* dynamic link */
       /* Mark frame variables + program */
       for (sp -= 2; sp >= lower; sp--)
 	if (SCM_NIMP (*sp))
@@ -337,7 +356,7 @@ scm_vm_apply (SCM vm, SCM program, SCM args)
 #define FUNC_NAME "scm_vm_apply"
 {
   SCM_VALIDATE_PROGRAM (1, program);
-  return vm_engine (vm, program, args);
+  return vm_run (vm, program, args);
 }
 #undef FUNC_NAME
 

src/vm.h

@@ -61,10 +61,11 @@
  */
 
 /*
-   |                  | <- fp + bp->nargs + bp->nlocs + 2
+   |                  | <- fp + bp->nargs + bp->nlocs + 3
    +------------------+    = SCM_VM_FRAME_UPPER_ADDRESS (fp)
+   | Return address   |
    | Dynamic link     |
-   | Return address   | <- fp + bp->nargs + bp->nlocs
+   | External link    | <- fp + bp->nargs + bp->nlocs
    | Local varialbe 1 |    = SCM_VM_FRAME_DATA_ADDRESS (fp)
    | Local variable 0 | <- fp + bp->nargs
    | Argument 1       |
@@ -74,15 +75,16 @@
    |                  |
 */
 
-#define SCM_VM_FRAME_LOWER_ADDRESS(fp)	(fp - 1)
 #define SCM_VM_FRAME_DATA_ADDRESS(fp)			\
   (fp + SCM_PROGRAM_NARGS (SCM_VM_FRAME_PROGRAM (fp))	\
       + SCM_PROGRAM_NLOCS (SCM_VM_FRAME_PROGRAM (fp)))
 #define SCM_VM_FRAME_UPPER_ADDRESS(fp)			\
-  (SCM_VM_FRAME_DATA_ADDRESS (fp) + 2)
+  (SCM_VM_FRAME_DATA_ADDRESS (fp) + 3)
+#define SCM_VM_FRAME_LOWER_ADDRESS(fp)	(fp - 1)
 
+#define SCM_VM_FRAME_RETURN_ADDRESS(fp)	SCM_VM_FRAME_DATA_ADDRESS (fp)[2]
 #define SCM_VM_FRAME_DYNAMIC_LINK(fp)	SCM_VM_FRAME_DATA_ADDRESS (fp)[1]
-#define SCM_VM_FRAME_RETURN_ADDRESS(fp)	SCM_VM_FRAME_DATA_ADDRESS (fp)[0]
+#define SCM_VM_FRAME_EXTERNAL_LINK(fp)	SCM_VM_FRAME_DATA_ADDRESS (fp)[0]
 #define SCM_VM_FRAME_VARIABLE(fp,i)	fp[i]
 #define SCM_VM_FRAME_PROGRAM(fp)	fp[-1]
 
@@ -95,6 +97,7 @@ struct scm_vm_heap_frame {
   SCM program;
   SCM variables;
   SCM dynamic_link;
+  SCM external_link;
 };
 
 extern scm_bits_t scm_tc16_vm_heap_frame;
@@ -106,6 +109,7 @@ extern scm_bits_t scm_tc16_vm_heap_frame;
 #define SCM_VM_HEAP_FRAME_PROGRAM(f)	SCM_VM_HEAP_FRAME_DATA (f)->program
 #define SCM_VM_HEAP_FRAME_VARIABLES(f)	SCM_VM_HEAP_FRAME_DATA (f)->variables
 #define SCM_VM_HEAP_FRAME_DYNAMIC_LINK(f) SCM_VM_HEAP_FRAME_DATA (f)->dynamic_link
+#define SCM_VM_HEAP_FRAME_EXTERNAL_LINK(f) SCM_VM_HEAP_FRAME_DATA (f)->external_link
 
 /*
  * VM

src/vm_engine.c

@@ -44,7 +44,7 @@
 #include "vm_engine.h"
 
 static SCM
-vm_engine (SCM vm, SCM program, SCM args)
+vm_run (SCM vm, SCM program, SCM args)
 #define FUNC_NAME "vm-engine"
 {
   /* VM registers */
@@ -55,7 +55,7 @@ vm_engine (SCM vm, SCM program, SCM args)
   /* Cache variables */
   struct scm_vm *vp = SCM_VM_DATA (vm);	/* VM data pointer */
   struct scm_program *bp = NULL;	/* program base pointer */
-  SCM external;				/* external environment */
+  SCM external = SCM_EOL;		/* external environment */
   SCM *objects = NULL;			/* constant objects */
   SCM *stack_base = vp->stack_base;	/* stack base address */
   SCM *stack_limit = vp->stack_limit;	/* stack limit address */
@@ -161,7 +161,7 @@ vm_engine (SCM vm, SCM program, SCM args)
   vm_error:
     SYNC_ALL ();
     scm_ithrow (sym_vm_error,
-		SCM_LIST4 (sym_vm_engine, err_msg, err_args,
+		SCM_LIST4 (sym_vm_run, err_msg, err_args,
 			   scm_vm_current_frame (vm)),
 		1);
   }

src/vm_engine.h

@@ -132,8 +132,17 @@
 #define CACHE_PROGRAM()				\
 {						\
   bp = SCM_PROGRAM_DATA (program);		\
-  objects  = SCM_VELTS (bp->objs);		\
+  objects = SCM_VELTS (bp->objs);		\
-  external = bp->external;			\
+}
+
+#define CACHE_EXTERNAL()			\
+{						\
+  external = fp[bp->nargs + bp->nlocs];		\
+}
+
+#define SYNC_EXTERNAL()				\
+{						\
+  fp[bp->nargs + bp->nlocs] = external;		\
 }
 
 #define SYNC_BEFORE_GC()			\
@@ -280,17 +289,18 @@ do {						\
   SCM dl = SCM_VM_MAKE_STACK_ADDRESS (fp);	\
   ip = bp->base;				\
   fp = sp - bp->nargs + 1;			\
-  sp = sp + bp->nlocs + 2;			\
+  sp = sp + bp->nlocs + 3;			\
   CHECK_OVERFLOW ();				\
-  sp[0]  = dl;					\
+  sp[0]  = ra;					\
-  sp[-1] = ra;					\
+  sp[-1] = dl;					\
+  sp[-2] = bp->external;			\
 }
 
 #define FREE_FRAME()				\
 {						\
   SCM *new_sp = fp - 2;				\
   sp = fp + bp->nargs + bp->nlocs;		\
-  ip = SCM_VM_BYTE_ADDRESS (sp[0]);		\
+  ip = SCM_VM_BYTE_ADDRESS (sp[2]);		\
   fp = SCM_VM_STACK_ADDRESS (sp[1]);		\
   sp = new_sp;					\
 }

src/vm_loader.c

@@ -159,25 +159,21 @@ VM_DEFINE_LOADER (load_program, "load-program")
   NEXT;
 }
 
-VM_DEFINE_INSTRUCTION (link, "link", 0, 2, 1)
+VM_DEFINE_INSTRUCTION (link, "link", 0, 1, 1)
 {
-  if (!SCM_FALSEP (sp[-1]))
+#if 0
-    {
+  sp[-1] = scm_c_env_vcell (sp[-1], sp[0], 1);
-      sp[-1] = scm_c_env_vcell (sp[-1], sp[0], 1);
+  sp--;
-      sp--;
+#endif
-    }
+  /* Temporary hack that supports the current module system */
-  else
+  SCM mod = scm_current_module ();
-    {
+  SCM var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
-      /* Temporary hack that supports the current module system */
+				     *sp, SCM_BOOL_F);
-      SCM mod = scm_current_module ();
+  if (SCM_FALSEP (var))
-      SCM var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
+    /* Create a new variable if not defined yet */
-					 *sp, SCM_BOOL_F);
+    var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
-      if (SCM_FALSEP (var))
+				   *sp, SCM_BOOL_T);
-	/* Create a new variable if not defined yet */
+  *sp = SCM_VARVCELL (var);
-	var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
-				       *sp, SCM_BOOL_T);
-      *--sp = SCM_VARVCELL (var);
-    }
   NEXT;
 }
 

src/vm_system.c

@@ -223,49 +223,53 @@ VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
 
 #define BR(p)					\
 {						\
-  signed char offset = FETCH ();		\
+  int h = FETCH ();				\
+  int l = FETCH ();				\
+  signed short offset = (h << 8) + l;		\
   if (p)					\
     ip += offset;				\
   DROP ();					\
   NEXT;						\
 }
 
-VM_DEFINE_INSTRUCTION (br_if, "br-if", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (br, "br", 2, 0, 0)
+{
+  int h = FETCH ();
+  int l = FETCH ();
+  ip += (signed short) (h << 8) + l;
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (br_if, "br-if", 2, 0, 0)
 {
   BR (!SCM_FALSEP (*sp));
 }
 
-VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 2, 0, 0)
 {
   BR (SCM_FALSEP (*sp));
 }
 
-VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 2, 0, 0)
 {
   BR (SCM_EQ_P (sp[0], sp--[1]));
 }
 
-VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 2, 0, 0)
 {
   BR (!SCM_EQ_P (sp[0], sp--[1]));
 }
 
-VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 2, 0, 0)
 {
   BR (SCM_NULLP (*sp));
 }
 
-VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 1, 0, 0)
+VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 2, 0, 0)
 {
   BR (!SCM_NULLP (*sp));
 }
 
-VM_DEFINE_INSTRUCTION (jump, "jump", 1, 0, 0)
-{
-  ip += (signed char) FETCH ();
-  NEXT;
-}
-
 
 /*
  * Subprogram call
@@ -305,8 +309,10 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
 	LOCAL_SET (i, SCM_UNDEFINED);
 
       /* Create external variables */
+      CACHE_EXTERNAL ();
       for (i = 0; i < bp->nexts; i++)
 	CONS (external, SCM_UNDEFINED, external);
+      SYNC_EXTERNAL ();
 
       ENTER_HOOK ();
       APPLY_HOOK ();
@@ -454,6 +460,7 @@ VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
   /* Restore the last program */
   program = SCM_VM_FRAME_PROGRAM (fp);
   CACHE_PROGRAM ();
+  CACHE_EXTERNAL ();
   PUSH (ret);
   NEXT;
 }