compile @ and @@

* libguile/vm-engine.c (vm_run): Add new error case for resolving @ or @@
  references, but there is no such module. Possible if
  module-public-interface returns #f.

* libguile/vm-i-loader.c (link-now): Allow the stack arg to be a sym, as
  before, or a list, indicating an absolute reference. Could be two
  separate instructions, but I'm lazy.

* libguile/vm-i-system.c (late-variable-ref, late-variable-set): As in
  link-now, allow the lazy reference to be a list, for @ and @@.

* module/language/scheme/translate.scm (custom-transformer-table):
  Compile @ and @@, and set! forms for both of them. This will ease the
  non-hygienic pain for exported macros.

* module/system/il/compile.scm (make-glil-var): Translate public and
  private module variable references into glil-module variables.

* module/system/il/ghil.scm (ghil-var-at-module!): New function, resolves
  a variable for @ or @@.

* module/system/il/glil.scm (<glil-module>): Revival of <glil-module>,
  this time with the semantics that it really links to a particular
  module.

* module/system/vm/assemble.scm (<vlink-now>, <vlink-later>): Redefine as
  taking a "key" as the argument, which may be a sym or a list; see the
  notes on link-now for more details.
  (codegen): Compile <glil-module> appropriately. Some duplication here,
  probably could use some cleanup later.

diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 7a6e30e..86b19de 100644 (file)
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -182,6 +182,10 @@ vm_run (SCM vm, SCM program, SCM args)
     err_args = SCM_EOL;
     goto vm_error;
 
+  vm_error_no_such_module:
+    err_msg  = scm_from_locale_string ("VM: No such module: ~A");
+    goto vm_error;
+
 #if VM_CHECK_IP
   vm_error_invalid_address:
     err_msg  = scm_from_locale_string ("VM: Invalid program address");

diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c
index 34d1cec..72436f0 100644 (file)
--- a/libguile/vm-i-loader.c
+++ b/libguile/vm-i-loader.c
@@ -165,10 +165,32 @@ VM_DEFINE_LOADER (load_program, "load-program")
 
 VM_DEFINE_INSTRUCTION (link_now, "link-now", 0, 1, 1)
 {
-  SCM sym;
-  POP (sym);
+  SCM what;
+  POP (what);
   SYNC_REGISTER ();
-  PUSH (scm_lookup (sym)); /* might longjmp */
+  if (SCM_LIKELY (SCM_SYMBOLP (what)))
+    {
+      PUSH (scm_lookup (what)); /* might longjmp */
+    }
+  else
+    {
+      SCM mod;
+      /* compilation of @ or @@
+         `what' is a three-element list: (MODNAME SYM INTERFACE?)
+         INTERFACE? is #t if we compiled @ or #f if we compiled @@
+      */
+      mod = scm_resolve_module (SCM_CAR (what));
+      if (scm_is_true (SCM_CADDR (what)))
+        mod = scm_module_public_interface (mod);
+      if (SCM_FALSEP (mod))
+        {
+          err_args = SCM_LIST1 (SCM_CAR (what));
+          goto vm_error_no_such_module;
+        }
+      /* might longjmp */
+      PUSH (scm_module_lookup (mod, SCM_CADR (what)));
+    }
+      
   NEXT;
 }
 

diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 16899cc..87d3a53 100644 (file)
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -285,33 +285,51 @@ VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1)
 VM_DEFINE_INSTRUCTION (late_variable_ref, "late-variable-ref", 1, 0, 1)
 {
   unsigned objnum = FETCH ();
-  SCM sym_or_var;
+  SCM what;
   CHECK_OBJECT (objnum);
-  sym_or_var = OBJECT_REF (objnum);
+  what = OBJECT_REF (objnum);
 
-  if (!SCM_VARIABLEP (sym_or_var)) 
+  if (!SCM_VARIABLEP (what)) 
     {
       SYNC_REGISTER ();
-      if (SCM_LIKELY (scm_module_system_booted_p && SCM_NFALSEP (bp->module))) 
+      if (SCM_LIKELY (SCM_SYMBOLP (what))) 
         {
-          /* might longjmp */
-          sym_or_var = scm_module_lookup (bp->module, sym_or_var);
+          if (SCM_LIKELY (scm_module_system_booted_p
+                          && scm_is_true (bp->module)))
+            /* might longjmp */
+            what = scm_module_lookup (bp->module, what);
+          else
+            what = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
         }
       else
         {
-          sym_or_var = scm_sym2var (sym_or_var, SCM_BOOL_F, SCM_BOOL_F);
+          SCM mod;
+          /* compilation of @ or @@
+             `what' is a three-element list: (MODNAME SYM INTERFACE?)
+             INTERFACE? is #t if we compiled @ or #f if we compiled @@
+          */
+          mod = scm_resolve_module (SCM_CAR (what));
+          if (scm_is_true (SCM_CADDR (what)))
+            mod = scm_module_public_interface (mod);
+          if (SCM_FALSEP (mod))
+            {
+              err_args = SCM_LIST1 (mod);
+              goto vm_error_no_such_module;
+            }
+          /* might longjmp */
+          what = scm_module_lookup (mod, SCM_CADR (what));
         }
           
-      if (!VARIABLE_BOUNDP (sym_or_var))
+      if (!VARIABLE_BOUNDP (what))
         {
-          err_args = SCM_LIST1 (sym_or_var);
+          err_args = SCM_LIST1 (what);
           goto vm_error_unbound;
         }
 
-      OBJECT_SET (objnum, sym_or_var);
+      OBJECT_SET (objnum, what);
     }
 
-  PUSH (VARIABLE_REF (sym_or_var));
+  PUSH (VARIABLE_REF (what));
   NEXT;
 }
 
@@ -349,27 +367,45 @@ VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
 VM_DEFINE_INSTRUCTION (late_variable_set, "late-variable-set", 1, 1, 0)
 {
   unsigned objnum = FETCH ();
-  SCM sym_or_var;
+  SCM what;
   CHECK_OBJECT (objnum);
-  sym_or_var = OBJECT_REF (objnum);
+  what = OBJECT_REF (objnum);
 
-  if (!SCM_VARIABLEP (sym_or_var)) 
+  if (!SCM_VARIABLEP (what)) 
     {
       SYNC_BEFORE_GC ();
-      if (SCM_LIKELY (scm_module_system_booted_p && SCM_NFALSEP (bp->module))) 
+      if (SCM_LIKELY (SCM_SYMBOLP (what))) 
         {
-          /* might longjmp */
-          sym_or_var = scm_module_lookup (bp->module, sym_or_var);
+          if (SCM_LIKELY (scm_module_system_booted_p
+                          && scm_is_true (bp->module)))
+            /* might longjmp */
+            what = scm_module_lookup (bp->module, what);
+          else
+            what = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
         }
       else
         {
-          sym_or_var = scm_sym2var (sym_or_var, SCM_BOOL_F, SCM_BOOL_F);
+          SCM mod;
+          /* compilation of @ or @@
+             `what' is a three-element list: (MODNAME SYM INTERFACE?)
+             INTERFACE? is #t if we compiled @ or #f if we compiled @@
+          */
+          mod = scm_resolve_module (SCM_CAR (what));
+          if (scm_is_true (SCM_CADDR (what)))
+            mod = scm_module_public_interface (mod);
+          if (SCM_FALSEP (mod))
+            {
+              err_args = SCM_LIST1 (what);
+              goto vm_error_no_such_module;
+            }
+          /* might longjmp */
+          what = scm_module_lookup (mod, SCM_CADR (what));
         }
 
-      OBJECT_SET (objnum, sym_or_var);
+      OBJECT_SET (objnum, what);
     }
 
-  VARIABLE_SET (sym_or_var, *sp);
+  VARIABLE_SET (what, *sp);
   DROP ();
   NEXT;
 }

diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm
index 87057d8..0d313e9 100644 (file)
--- a/module/language/scheme/translate.scm
+++ b/module/language/scheme/translate.scm
@@ -158,6 +158,22 @@
     ((,name ,val) (guard (symbol? name))
      (make-ghil-set e l (ghil-var-for-set! e name) (retrans val)))
 
+    ;; FIXME: Would be nice to verify the values of @ and @@ relative
+    ;; to imported modules...
+    (((@ ,modname ,name) ,val) (guard (symbol? name)
+                                      (list? modname)
+                                      (and-map symbol? modname)
+                                      (not (ghil-var-is-bound? e '@)))
+     (make-ghil-set e l (ghil-var-at-module! e modname name #t)
+                    (retrans val)))
+
+    (((@@ ,modname ,name) ,val) (guard (symbol? name)
+                                      (list? modname)
+                                      (and-map symbol? modname)
+                                      (not (ghil-var-is-bound? e '@@)))
+     (make-ghil-set e l (ghil-var-at-module! e modname name #f)
+                    (retrans val)))
+
     ;; (set! (NAME ARGS...) VAL)
     (((,name . ,args) ,val) (guard (symbol? name))
      ;; -> ((setter NAME) ARGS... VAL)
@@ -272,6 +288,14 @@
      ((,expr)
       (retrans `(make-promise (lambda () ,expr)))))
 
+    (@
+     ((,modname ,sym)
+      (make-ghil-ref e l (ghil-var-at-module! e modname sym #t))))
+
+    (@@
+     ((,modname ,sym)
+      (make-ghil-ref e l (ghil-var-at-module! e modname sym #f))))
+
     (eval-case
      (,clauses
       (retrans

diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm
index 261b936..838926f 100644 (file)
--- a/module/system/il/compile.scm
+++ b/module/system/il/compile.scm
@@ -124,6 +124,9 @@
          (make-glil-external op depth (ghil-var-index var)))))
     ((toplevel)
      (make-glil-toplevel op (ghil-var-name var)))
+    ((public private)
+     (make-glil-module op (ghil-var-env var) (ghil-var-name var)
+                       (eq? (ghil-var-kind var) 'public)))
     (else (error "Unknown kind of variable:" var))))
 
 (define (constant? x)

diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm
index b0bac0f..92f4df3 100644 (file)
--- a/module/system/il/ghil.scm
+++ b/module/system/il/ghil.scm
@@ -95,6 +95,7 @@
 
    ghil-env-add!
    ghil-var-is-bound? ghil-var-for-ref! ghil-var-for-set! ghil-var-define!
+   ghil-var-at-module!
    call-with-ghil-environment call-with-ghil-bindings))
 
 \f
@@ -236,6 +237,19 @@
         (else
          (loop parent)))))))
 
+(define (ghil-var-at-module! env modname sym interface?)
+  (let loop ((e env))
+    (record-case e
+      ((<ghil-toplevel-env> table)
+       (let ((key (list modname sym interface?)))
+         (or (assoc-ref table key)
+             (let ((var (make-ghil-var modname sym
+                                       (if interface? 'public 'private))))
+               (apush! key var (ghil-toplevel-env-table e))
+               var))))
+      ((<ghil-env> parent table variables)
+       (loop parent)))))
+
 (define (ghil-var-define! toplevel sym)
   (let ((key (cons (module-name (current-module)) sym)))
     (or (assoc-ref (ghil-toplevel-env-table toplevel) key)

diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm
index 48470a2..75fca06 100644 (file)
--- a/module/system/il/glil.scm
+++ b/module/system/il/glil.scm
@@ -57,6 +57,9 @@
    <glil-toplevel> make-glil-toplevel glil-toplevel?
    glil-toplevel-op glil-toplevel-name
 
+   <glil-module> make-glil-module glil-module?
+   glil-module-op glil-module-mod glil-module-name glil-module-public?
+
    <glil-label> make-glil-label glil-label?
    glil-label-label
 
@@ -87,6 +90,7 @@
    (<glil-local> op index)
    (<glil-external> op depth index)
    (<glil-toplevel> op name)
+   (<glil-module> op mod name public?)
    ;; Controls
    (<glil-label> label)
    (<glil-branch> inst label)
@@ -190,6 +194,8 @@
      `(,(symbol-append 'external- op) ,depth ,index))
     ((<glil-toplevel> op name)
      `(,(symbol-append 'toplevel- op) ,name))
+    ((<glil-module> op mod name public?)
+     `(,(symbol-append (if public? 'public 'private) '- op) ,mod ,name))
     ;; controls
     ((<glil-label> label) label)
     ((<glil-branch> inst label) `(,inst ,label))

diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm
index c5ca46f..bbbee35 100644 (file)
--- a/module/system/vm/assemble.scm
+++ b/module/system/vm/assemble.scm
@@ -42,8 +42,9 @@
 
 (define-record (<vm-asm> venv glil body))
 (define-record (<venv> parent nexts closure?))
-(define-record (<vlink-now> name))
-(define-record (<vlink-later> name))
+;; key is either a symbol or the list (MODNAME SYM PUBLIC?)
+(define-record (<vlink-now> key))
+(define-record (<vlink-later> key))
 (define-record (<vdefine> name))
 (define-record (<bytespec> vars bytes meta objs closure?))
 
@@ -188,12 +189,12 @@
               ((ref set)
                (cond
                 (toplevel
-                 (push-object! (make-vlink-now #:name name))
+                 (push-object! (make-vlink-now #:key name))
                  (push-code! (case op
                                ((ref) '(variable-ref))
                                ((set) '(variable-set)))))
                 (else
-                 (let* ((var (make-vlink-later #:name name))
+                 (let* ((var (make-vlink-later #:key name))
                         (i (cond ((object-assoc var object-alist) => cdr)
                                  (else
                                   (let ((i (length object-alist)))
@@ -208,6 +209,29 @@
               (else
                (error "unknown toplevel var kind" op name))))
 
+          ((<glil-module> op mod name public?)
+            (let ((key (list mod name public?)))
+              (case op
+                ((ref set)
+                 (cond
+                  (toplevel
+                   (push-object! (make-vlink-now #:key key))
+                   (push-code! (case op
+                                 ((ref) '(variable-ref))
+                                 ((set) '(variable-set)))))
+                  (else
+                   (let* ((var (make-vlink-later #:key key))
+                          (i (cond ((object-assoc var object-alist) => cdr)
+                                   (else
+                                    (let ((i (length object-alist)))
+                                      (set! object-alist (acons var i object-alist))
+                                      i)))))
+                     (push-code! (case op
+                                   ((ref) `(late-variable-ref ,i))
+                                   ((set) `(late-variable-set ,i))))))))
+                (else
+                 (error "unknown module var kind" op key)))))
+
           ((<glil-label> label)
            (set! label-alist (assq-set! label-alist label (current-address))))
 
@@ -319,10 +343,10 @@
         (if meta (dump! meta))
         ;; dump bytecode
         (push-code! `(load-program ,bytes)))
-       ((<vlink-later> name)
-         (dump! name))
-       ((<vlink-now> name)
-         (dump! name)
+       ((<vlink-later> key)
+         (dump! key))
+       ((<vlink-now> key)
+         (dump! key)
         (push-code! '(link-now)))
        ((<vdefine> name)
         (push-code! `(define ,(symbol->string name))))