Add instructions for doing very late binding

Fixes the mutually-recursive toplevel definitions case. This could be
fixed by rewriting bodies as letrecs, as r6 does, but that's not really
repl-compatible.

* module/system/il/ghil.scm (ghil-lookup): Ok, if we can't locate a
  variable, mark it as unresolved.

* module/system/il/compile.scm (make-glil-var): Compile unresolved
  variables as <glil-late-bound> objects.

* module/system/il/glil.scm: Add <glil-late-bound> definition.

* module/system/vm/assemble.scm (codegen): And, finally, when we see a
  <vlate-bound> object, allocate a slot for it in the object vector,
  setting it to a symbol. Add a new pair of instructions to resolve that
  symbol to a variable at the last minute.

* src/vm_loader.c (load-number): Bugfix: the radix argument should be
  SCM_UNDEFINED in order to default to 10.
  (late-bind): Add an unresolved symbol to the object vector. Could be
  replaced with load-symbol I guess.

* src/vm_system.c (late-variable-ref, late-variable-set): New
  instructions to do late symbol binding.

* testsuite/Makefile.am (vm_test_files):
* testsuite/t-mutual-toplevel-defines.scm: New test, failing for some
  reason involving the core even? and odd? definitions.

diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm
index 51b914b..e963650 100644 (file)
--- a/module/system/il/compile.scm
+++ b/module/system/il/compile.scm
@@ -103,6 +103,8 @@
      (let ((env (ghil-var-env var)))
        (make-glil-module op (and env (ghil-mod-module (ghil-env-mod env)))
                          (ghil-var-name var))))
+    ((unresolved)
+     (make-glil-late-bound op (ghil-var-name var)))
     (else (error "Unknown kind of variable:" var))))
 
 (define (codegen ghil)

diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm
index 0a65f83..e5029e1 100644 (file)
--- a/module/system/il/ghil.scm
+++ b/module/system/il/ghil.scm
@@ -224,12 +224,10 @@
                        (make-ghil-var found-env sym 'module)))
                  (else
                   ;; a free variable that we have not resolved
-                  (if (not (module-locally-bound? module sym))
-                      ;; For the benefit of repl compilation, that
-                      ;; doesn't compile modules all-at-once, don't warn
-                      ;; if we find the symbol locally.
-                      (warn "unresolved variable during compilation:" sym))
-                  (make-ghil-var #f sym 'module))))
+                  (warn "unresolved variable during compilation:" sym)
+                  (let ((var (make-ghil-var #f sym 'unresolved)))
+                    (apush! sym var table)
+                    var))))
           ((<ghil-env> mod parent table variables)
            (let ((found (assq-ref table sym)))
              (if found

diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm
index 3ffb6a7..6a3ec4c 100644 (file)
--- a/module/system/il/glil.scm
+++ b/module/system/il/glil.scm
@@ -54,6 +54,9 @@
    <glil-module> make-glil-module glil-module?
    glil-module-op glil-module-module glil-module-index
 
+   <glil-late-bound> make-glil-late-bound glil-late-bound?
+   glil-late-bound-op glil-late-bound-name
+
    <glil-label> make-glil-label glil-label?
    glil-label-label
 
@@ -80,6 +83,7 @@
    (<glil-local> op index)
    (<glil-external> op depth index)
    (<glil-module> op module name)
+   (<glil-late-bound> op name)
    ;; Controls
    (<glil-label> label)
    (<glil-branch> inst label)

diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm
index cbb307b..3197f71 100644 (file)
--- a/module/system/vm/assemble.scm
+++ b/module/system/vm/assemble.scm
@@ -44,6 +44,7 @@
 (define-record (<venv> parent nexts closure?))
 (define-record (<vmod> id))
 (define-record (<vlink> module name))
+(define-record (<vlate-bound> name))
 (define-record (<vdefine> module name))
 (define-record (<bytespec> vars bytes meta objs closure?))
 
@@ -158,6 +159,20 @@
                (push-object! (make-vdefine :module module :name name))
                (push-code! '(variable-set)))))
 
+          ((<glil-late-bound> op name)
+            (let* ((var (make-vlate-bound :name name))
+                   (i (cond ((object-assoc var object-alist) => cdr)
+                            (else
+                             (let ((i (length object-alist)))
+                               (set! object-alist (acons var i object-alist))
+                               i)))))
+              (case op
+                ((ref)
+                 (push-code! `(late-variable-ref ,i)))
+                ((set)
+                 (push-code! `(late-variable-set ,i)))
+                (else (error "unknown late bound" op name)))))
+
           ((<glil-label> label)
            (set! label-alist (assq-set! label-alist label (current-address))))
 
@@ -263,6 +278,8 @@
        ((<vdefine> module name)
         ;; FIXME: dump module
         (push-code! `(define ,(symbol->string name))))
+       ((<vlate-bound> name)
+        (push-code! `(late-bind ,(symbol->string name))))
        ((<vmod> id)
         (push-code! `(load-module ,id)))
         (else

diff --git a/src/vm_loader.c b/src/vm_loader.c
index a28d44b..d8bf554 100644 (file)
--- a/src/vm_loader.c
+++ b/src/vm_loader.c
@@ -64,7 +64,7 @@ VM_DEFINE_LOADER (load_number, "load-number")
 
   FETCH_LENGTH (len);
   PUSH (scm_string_to_number (scm_from_locale_stringn ((char *)ip, len),
-                             SCM_UNSPECIFIED /* radix = 10 */));
+                             SCM_UNDEFINED /* radix = 10 */));
   /* Was: scm_istring2number (ip, len, 10)); */
   ip += len;
   NEXT;
@@ -215,6 +215,19 @@ VM_DEFINE_LOADER (define, "define")
   NEXT;
 }
 
+VM_DEFINE_LOADER (late_bind, "late-bind")
+{
+  SCM sym;
+  size_t len;
+
+  FETCH_LENGTH (len);
+  sym = scm_from_locale_symboln ((char *)ip, len);
+  ip += len;
+
+  PUSH (sym);
+  NEXT;
+}
+
 /*
   Local Variables:
   c-file-style: "gnu"

diff --git a/src/vm_system.c b/src/vm_system.c
index 4dcafb1..6daa818 100644 (file)
--- a/src/vm_system.c
+++ b/src/vm_system.c
@@ -257,6 +257,28 @@ VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1)
   NEXT;
 }
 
+VM_DEFINE_INSTRUCTION (late_variable_ref, "late-variable-ref", 1, 0, 1)
+{
+  register unsigned objnum = FETCH ();
+  SCM x;
+  CHECK_OBJECT (objnum);
+  x = OBJECT_REF (objnum);
+
+  if (!SCM_VARIABLEP (x)) 
+    {
+      x = scm_lookup (x); /* might longjmp */
+      OBJECT_SET (objnum, x);
+      if (!VARIABLE_BOUNDP (x))
+        {
+          err_args = SCM_LIST1 (x);
+          goto vm_error_unbound;
+        }
+    }
+
+  PUSH (VARIABLE_REF (x));
+  NEXT;
+}
+
 /* set */
 
 VM_DEFINE_INSTRUCTION (local_set, "local-set", 1, 1, 0)
@@ -289,6 +311,29 @@ VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
   NEXT;
 }
 
+VM_DEFINE_INSTRUCTION (late_variable_set, "late-variable-set", 1, 1, 0)
+{
+  register unsigned objnum = FETCH ();
+  SCM x;
+  CHECK_OBJECT (objnum);
+  x = OBJECT_REF (objnum);
+
+  if (!SCM_VARIABLEP (x)) 
+    {
+      x = scm_lookup (x); /* might longjmp */
+      OBJECT_SET (objnum, x);
+      if (!VARIABLE_BOUNDP (x))
+        {
+          err_args = SCM_LIST1 (x);
+          goto vm_error_unbound;
+        }
+    }
+
+  VARIABLE_SET (x, *sp);
+  DROP ();
+  NEXT;
+}
+
 \f
 /*
  * branch and jump

diff --git a/testsuite/Makefile.am b/testsuite/Makefile.am
index a3e8921..c12e516 100644 (file)
--- a/testsuite/Makefile.am
+++ b/testsuite/Makefile.am
@@ -15,7 +15,8 @@ vm_test_files =                                       \
       t-proc-with-setter.scm                   \
       t-values.scm                             \
       t-records.scm                            \
-      t-match.scm
+      t-match.scm                              \
+      t-mutual-toplevel-defines.scm
 
 EXTRA_DIST = run-vm-tests.scm $(vm_test_files)
 

diff --git a/testsuite/run-vm-tests.scm b/testsuite/run-vm-tests.scm
index 64568b1..19cb9e1 100644 (file)
--- a/testsuite/run-vm-tests.scm
+++ b/testsuite/run-vm-tests.scm
@@ -74,9 +74,9 @@ equal in the sense of @var{equal?}."
                     (format #t "running `~a'...  " file)
                     (if (catch #t
                                (lambda ()
-                                 (equal? (compile/run-test-from-file file)
-                                         (eval (fetch-sexp-from-file file)
-                                               (interaction-environment))))
+                                 (equal? (pk (compile/run-test-from-file file))
+                                         (pk (eval (fetch-sexp-from-file file)
+                                               (interaction-environment)))))
                                (lambda (key . args)
                                  (format #t "[~a/~a] " key args)
                                  #f))

diff --git a/testsuite/t-mutual-toplevel-defines.scm b/testsuite/t-mutual-toplevel-defines.scm
new file mode 100644 (file)
index 0000000..795c744
--- /dev/null
+++ b/testsuite/t-mutual-toplevel-defines.scm
@@ -0,0 +1,8 @@
+(define (even? x)
+  (or (zero? x)
+      (not (odd? (1- x)))))
+
+(define (odd? x)
+  (not (even? (1- x))))
+
+(even? 20)