From fdcedea64332d39ae55b47c0b6d406cecd3b1ce7 Mon Sep 17 00:00:00 2001
From: Keisuke Nishida <kxn30@po.cwru.edu>
Date: Tue, 3 Apr 2001 22:14:41 +0000
Subject: [PATCH] Current module support hack.

---
 module/language/r5rs/expand.scm |  2 +-
 module/system/vm/assemble.scm   |  8 ++++----
 src/vm_loader.c                 | 13 +++++++++++++
 3 files changed, 18 insertions(+), 5 deletions(-)

diff --git a/module/language/r5rs/expand.scm b/module/language/r5rs/expand.scm
index 900c2a30a..610dc0974 100644
--- a/module/language/r5rs/expand.scm
+++ b/module/language/r5rs/expand.scm
@@ -18,7 +18,7 @@
 
 
 (define-module (language r5rs expand)
-  :export (expand
+  :export (expand void
 	   identifier? free-identifier=? bound-identifier=?
 	   generate-temporaries datum->syntax-object syntax-object->datum))
 
diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm
index dfddf5c28..84ff00d94 100644
--- a/module/system/vm/assemble.scm
+++ b/module/system/vm/assemble.scm
@@ -122,9 +122,9 @@
 	    (let ((mod (make-vmod module)))
 	      (if toplevel
 		  (begin
-		    (push-code! `(load-module ,module))
+		    ;; (push-code! `(load-module ,module))
 		    (push-code! `(load-symbol ,name))
-		    (push-code! `(link)))
+		    (push-code! `(link/current-module)))
 		  (let ((vlink (make-vlink mod name)))
 		    (push-code! `(object-ref ,(object-index vlink)))))
 	      (push-code! (list (symbol-append 'variable- op)))))
@@ -212,9 +212,9 @@
       (let dump! ((x (car obj+index)))
 	(cond
 	 ((vlink? x)
-	  (push-code! `(local-ref ,(object-index (vlink-module x))))
+	  ;; (push-code! `(local-ref ,(object-index (vlink-module x))))
 	  (push-code! `(load-symbol ,(vlink-name x)))
-	  (push-code! `(link)))
+	  (push-code! `(link/current-module)))
 	 ((vmod? x)
 	  (push-code! `(load-module ,(vmod-id x))))
 	 (else
diff --git a/src/vm_loader.c b/src/vm_loader.c
index 1dd3eb453..c83048438 100644
--- a/src/vm_loader.c
+++ b/src/vm_loader.c
@@ -126,6 +126,19 @@ VM_DEFINE_INSTRUCTION (link, "link", 0)
   NEXT;
 }
 
+VM_DEFINE_INSTRUCTION (link_current_module, "link/current-module", 0)
+{
+  SCM mod = scm_current_module ();
+  SCM var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
+				     *sp, SCM_BOOL_F);
+  if (SCM_FALSEP (var))
+    /* Create a new variable if not defined yet */
+    var = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
+				   *sp, SCM_BOOL_T);
+  *sp = SCM_VARVCELL (var);
+  NEXT;
+}
+
 /*
   Local Variables:
   c-file-style: "gnu"