summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/vm-engine.c4
-rw-r--r--libguile/vm-i-loader.c28
-rw-r--r--libguile/vm-i-system.c76
-rw-r--r--module/language/scheme/translate.scm24
-rw-r--r--module/system/il/compile.scm3
-rw-r--r--module/system/il/ghil.scm14
-rw-r--r--module/system/il/glil.scm6
-rw-r--r--module/system/vm/assemble.scm40
8 files changed, 164 insertions, 31 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 7a6e30e99..86b19de54 100644
--- 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 34d1cec92..72436f0d5 100644
--- 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 16899cc59..87d3a533a 100644
--- 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 87057d89e..0d313e9fd 100644
--- 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 261b936fc..838926f7a 100644
--- 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 b0bac0f9a..92f4df3c1 100644
--- 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))
@@ -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 48470a28f..75fca0621 100644
--- 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 c5ca46f39..bbbee35cb 100644
--- 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))))