[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/10: Add "mod" field to tree-il toplevel ref, set, def
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 02/10: Add "mod" field to tree-il toplevel ref, set, define |
|
Date: |
Sun, 18 Aug 2019 17:12:18 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 79a40cf717e62f45232979d1952f748ca42f8e8f
Author: Andy Wingo <address@hidden>
Date: Fri Aug 16 09:08:43 2019 +0200
Add "mod" field to tree-il toplevel ref, set, define
Add "mod" field to <toplevel-ref>, <toplevel-set>, and
<toplevel-define>, indicating the expander's idea of what the current
module is when a toplevel variable is accessed or created. This will
help in later optimizations.
* libguile/expand.c (TOPLEVEL_REF, TOPLEVEL_SET, TOPLEVEL_DEFINE)
(expand, expand_define, expand_set_x, convert_assignment):
* libguile/expand.h (SCM_EXPANDED_TOPLEVEL_REF_FIELD_NAMES):
(SCM_MAKE_EXPANDED_TOPLEVEL_REF, SCM_EXPANDED_TOPLEVEL_SET_FIELD_NAMES):
(SCM_MAKE_EXPANDED_TOPLEVEL_SET, SCM_EXPANDED_TOPLEVEL_DEFINE_FIELD_NAMES):
(SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE):
* module/ice-9/compile-psyntax.scm (translate-literal-syntax-objects):
* module/ice-9/psyntax-pp.scm:
* module/ice-9/psyntax.scm:
* module/language/tree-il.scm:
* module/language/tree-il.scm (parse-tree-il, make-tree-il-folder):
(pre-post-order):
* module/language/tree-il/analyze.scm (goops-toplevel-definition):
(macro-use-before-definition-analysis, proc-ref?, format-analysis):
* module/language/tree-il/compile-cps.scm (convert):
* module/language/tree-il/debug.scm (verify-tree-il):
* module/language/tree-il/effects.scm (make-effects-analyzer):
* module/language/tree-il/fix-letrec.scm (free-variables):
* module/language/tree-il/peval.scm (peval):
* test-suite/tests/tree-il.test: Adapt uses.
---
libguile/expand.c | 20 +++--
libguile/expand.h | 21 +++--
module/ice-9/compile-psyntax.scm | 3 +-
module/ice-9/psyntax-pp.scm | 153 +++++++++++++++++---------------
module/ice-9/psyntax.scm | 39 ++++----
module/language/tree-il.scm | 38 ++++----
module/language/tree-il/analyze.scm | 16 ++--
module/language/tree-il/compile-cps.scm | 8 +-
module/language/tree-il/debug.scm | 14 ++-
module/language/tree-il/effects.scm | 4 +-
module/language/tree-il/fix-letrec.scm | 4 +-
module/language/tree-il/peval.scm | 12 +--
test-suite/tests/tree-il.test | 6 +-
13 files changed, 182 insertions(+), 156 deletions(-)
diff --git a/libguile/expand.c b/libguile/expand.c
index dd6eab0..11e43c2 100644
--- a/libguile/expand.c
+++ b/libguile/expand.c
@@ -74,12 +74,12 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
SCM_MAKE_EXPANDED_MODULE_REF(src, mod, name, public)
#define MODULE_SET(src, mod, name, public, exp) \
SCM_MAKE_EXPANDED_MODULE_SET(src, mod, name, public, exp)
-#define TOPLEVEL_REF(src, name) \
- SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, name)
-#define TOPLEVEL_SET(src, name, exp) \
- SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, name, exp)
-#define TOPLEVEL_DEFINE(src, name, exp) \
- SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp)
+#define TOPLEVEL_REF(src, mod, name) \
+ SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, mod, name)
+#define TOPLEVEL_SET(src, mod, name, exp) \
+ SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, mod, name, exp)
+#define TOPLEVEL_DEFINE(src, mod, name, exp) \
+ SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, mod, name, exp)
#define CONDITIONAL(src, test, consequent, alternate) \
SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
#define PRIMCALL(src, name, exps) \
@@ -377,7 +377,7 @@ expand (SCM exp, SCM env)
if (scm_is_true (gensym))
return LEXICAL_REF (SCM_BOOL_F, exp, gensym);
else
- return TOPLEVEL_REF (SCM_BOOL_F, exp);
+ return TOPLEVEL_REF (SCM_BOOL_F, SCM_BOOL_F, exp);
}
else
return CONST_ (SCM_BOOL_F, exp);
@@ -552,13 +552,14 @@ expand_define (SCM expr, SCM env)
ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable,
variable, expr);
return TOPLEVEL_DEFINE
(scm_source_properties (expr),
+ SCM_BOOL_F,
CAR (variable),
expand_lambda (scm_cons (scm_sym_lambda, scm_cons (CDR (variable),
body)),
env));
}
ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
- return TOPLEVEL_DEFINE (scm_source_properties (expr), variable,
+ return TOPLEVEL_DEFINE (scm_source_properties (expr), SCM_BOOL_F, variable,
expand (CAR (body), env));
}
@@ -1143,6 +1144,7 @@ expand_set_x (SCM expr, SCM env)
expand (CADDR (expr), env));
case SCM_EXPANDED_TOPLEVEL_REF:
return TOPLEVEL_SET (scm_source_properties (expr),
+ SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, MOD),
SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, NAME),
expand (CADDR (expr), env));
case SCM_EXPANDED_MODULE_REF:
@@ -1371,12 +1373,14 @@ convert_assignment (SCM exp, SCM assigned)
case SCM_EXPANDED_TOPLEVEL_SET:
return TOPLEVEL_SET
(REF (exp, TOPLEVEL_SET, SRC),
+ REF (exp, TOPLEVEL_SET, MOD),
REF (exp, TOPLEVEL_SET, NAME),
convert_assignment (REF (exp, TOPLEVEL_SET, EXP), assigned));
case SCM_EXPANDED_TOPLEVEL_DEFINE:
return TOPLEVEL_DEFINE
(REF (exp, TOPLEVEL_DEFINE, SRC),
+ REF (exp, TOPLEVEL_DEFINE, MOD),
REF (exp, TOPLEVEL_DEFINE, NAME),
convert_assignment (REF (exp, TOPLEVEL_DEFINE, EXP),
assigned));
diff --git a/libguile/expand.h b/libguile/expand.h
index 86054a5..06abd9f 100644
--- a/libguile/expand.h
+++ b/libguile/expand.h
@@ -175,41 +175,44 @@ enum
#define SCM_EXPANDED_TOPLEVEL_REF_TYPE_NAME "toplevel-ref"
#define SCM_EXPANDED_TOPLEVEL_REF_FIELD_NAMES \
- { "src", "name", }
+ { "src", "mod", "name", }
enum
{
SCM_EXPANDED_TOPLEVEL_REF_SRC,
+ SCM_EXPANDED_TOPLEVEL_REF_MOD,
SCM_EXPANDED_TOPLEVEL_REF_NAME,
SCM_NUM_EXPANDED_TOPLEVEL_REF_FIELDS,
};
-#define SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, name) \
- scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_REF], 0,
SCM_NUM_EXPANDED_TOPLEVEL_REF_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name))
+#define SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, mod, name) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_REF], 0,
SCM_NUM_EXPANDED_TOPLEVEL_REF_FIELDS, SCM_UNPACK (src), SCM_UNPACK (mod),
SCM_UNPACK (name))
#define SCM_EXPANDED_TOPLEVEL_SET_TYPE_NAME "toplevel-set"
#define SCM_EXPANDED_TOPLEVEL_SET_FIELD_NAMES \
- { "src", "name", "exp", }
+ { "src", "mod", "name", "exp", }
enum
{
SCM_EXPANDED_TOPLEVEL_SET_SRC,
+ SCM_EXPANDED_TOPLEVEL_SET_MOD,
SCM_EXPANDED_TOPLEVEL_SET_NAME,
SCM_EXPANDED_TOPLEVEL_SET_EXP,
SCM_NUM_EXPANDED_TOPLEVEL_SET_FIELDS,
};
-#define SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, name, exp) \
- scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_SET], 0,
SCM_NUM_EXPANDED_TOPLEVEL_SET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name),
SCM_UNPACK (exp))
+#define SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, mod, name, exp) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_SET], 0,
SCM_NUM_EXPANDED_TOPLEVEL_SET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (mod),
SCM_UNPACK (name), SCM_UNPACK (exp))
#define SCM_EXPANDED_TOPLEVEL_DEFINE_TYPE_NAME "toplevel-define"
#define SCM_EXPANDED_TOPLEVEL_DEFINE_FIELD_NAMES \
- { "src", "name", "exp", }
+ { "src", "mod", "name", "exp", }
enum
{
SCM_EXPANDED_TOPLEVEL_DEFINE_SRC,
+ SCM_EXPANDED_TOPLEVEL_DEFINE_MOD,
SCM_EXPANDED_TOPLEVEL_DEFINE_NAME,
SCM_EXPANDED_TOPLEVEL_DEFINE_EXP,
SCM_NUM_EXPANDED_TOPLEVEL_DEFINE_FIELDS,
};
-#define SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp) \
- scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_DEFINE], 0,
SCM_NUM_EXPANDED_TOPLEVEL_DEFINE_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name),
SCM_UNPACK (exp))
+#define SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, mod, name, exp) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_DEFINE], 0,
SCM_NUM_EXPANDED_TOPLEVEL_DEFINE_FIELDS, SCM_UNPACK (src), SCM_UNPACK (mod),
SCM_UNPACK (name), SCM_UNPACK (exp))
#define SCM_EXPANDED_CONDITIONAL_TYPE_NAME "conditional"
#define SCM_EXPANDED_CONDITIONAL_FIELD_NAMES \
diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm
index 44cdbbe..8a0b5cc 100644
--- a/module/ice-9/compile-psyntax.scm
+++ b/module/ice-9/compile-psyntax.scm
@@ -139,11 +139,12 @@
(translate-literal-syntax-objects
(make-toplevel-define
(toplevel-define-src x)
+ (toplevel-define-mod x)
(toplevel-define-name x)
(make-let (toplevel-define-src x)
(list 'make-syntax)
(list (module-gensym))
- (list (make-toplevel-ref #f 'make-syntax))
+ (list (make-toplevel-ref #f #f 'make-syntax))
(toplevel-define-exp x))))))))
;; Avoid gratuitous churn in psyntax-pp.scm due to the marks and labels
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 151bf8e..6cd7676 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -45,14 +45,24 @@
public?
exp)))
(make-toplevel-ref
- (lambda (src name)
- (make-struct/simple (vector-ref %expanded-vtables 7) src name)))
+ (lambda (src mod name)
+ (make-struct/simple (vector-ref %expanded-vtables 7) src mod name)))
(make-toplevel-set
- (lambda (src name exp)
- (make-struct/simple (vector-ref %expanded-vtables 8) src name exp)))
+ (lambda (src mod name exp)
+ (make-struct/simple
+ (vector-ref %expanded-vtables 8)
+ src
+ mod
+ name
+ exp)))
(make-toplevel-define
- (lambda (src name exp)
- (make-struct/simple (vector-ref %expanded-vtables 9) src name exp)))
+ (lambda (src mod name exp)
+ (make-struct/simple
+ (vector-ref %expanded-vtables 9)
+ src
+ mod
+ name
+ exp)))
(make-conditional
(lambda (src test consequent alternate)
(make-struct/simple
@@ -143,20 +153,20 @@
(analyze-variable
(lambda (mod var modref-cont bare-cont)
(if (not mod)
- (bare-cont var)
+ (bare-cont #f var)
(let ((kind (car mod)) (mod (cdr mod)))
(let ((key kind))
(cond ((memv key '(public)) (modref-cont mod var #t))
((memv key '(private))
- (if (not (equal? mod (module-name (current-module))))
- (modref-cont mod var #f)
- (bare-cont var)))
+ (if (equal? mod (module-name (current-module)))
+ (bare-cont mod var)
+ (modref-cont mod var #f)))
((memv key '(bare)) (bare-cont var))
((memv key '(hygiene))
(if (and (not (equal? mod (module-name
(current-module))))
(module-variable (resolve-module mod) var))
(modref-cont mod var #f)
- (bare-cont var)))
+ (bare-cont mod var)))
((memv key '(primitive))
(syntax-violation #f "primitive not in operator
position" var))
(else (syntax-violation #f "bad module kind" var
mod))))))))
@@ -166,7 +176,7 @@
mod
var
(lambda (mod var public?) (make-module-ref source mod var public?))
- (lambda (var) (make-toplevel-ref source var)))))
+ (lambda (mod var) (make-toplevel-ref source mod var)))))
(build-global-assignment
(lambda (source var exp mod)
(maybe-name-value! var exp)
@@ -175,11 +185,11 @@
var
(lambda (mod var public?)
(make-module-set source mod var public? exp))
- (lambda (var) (make-toplevel-set source var exp)))))
+ (lambda (mod var) (make-toplevel-set source mod var exp)))))
(build-global-definition
- (lambda (source var exp)
+ (lambda (source mod var exp)
(maybe-name-value! var exp)
- (make-toplevel-define source var exp)))
+ (make-toplevel-define source (and mod (cdr mod)) var exp)))
(build-simple-lambda
(lambda (src req rest vars meta exp)
(make-lambda
@@ -583,7 +593,7 @@
(syntax-expression id))))
(record-definition! id var)
(list (if (eq? m 'c&e)
- (let ((x (build-global-definition s
var (expand e r w mod))))
+ (let ((x (build-global-definition s
mod var (expand e r w mod))))
(top-level-eval-hook x mod)
(lambda () x))
(call-with-values
@@ -591,9 +601,9 @@
(lambda (type* value* mod*)
(if (eq? type* 'macro)
(top-level-eval-hook
- (build-global-definition s
var (build-void s))
+ (build-global-definition s
mod var (build-void s))
mod))
- (lambda ()
(build-global-definition s var (expand e r w mod)))))))))
+ (lambda ()
(build-global-definition s mod var (expand e r w mod)))))))))
((memv key '(define-syntax-form
define-syntax-parameter-form))
(let* ((id (wrap value w mod))
(label (gen-label))
@@ -604,21 +614,21 @@
(let ((key m))
(cond ((memv key '(c))
(cond ((memq 'compile esew)
- (let ((e
(expand-install-global var type (expand e r w mod))))
+ (let ((e
(expand-install-global mod var type (expand e r w mod))))
(top-level-eval-hook e
mod)
(if (memq 'load esew)
(list (lambda () e)) '())))
((memq 'load esew)
(list (lambda ()
-
(expand-install-global var type (expand e r w mod)))))
+
(expand-install-global mod var type (expand e r w mod)))))
(else '())))
((memv key '(c&e))
- (let ((e (expand-install-global
var type (expand e r w mod))))
+ (let ((e (expand-install-global
mod var type (expand e r w mod))))
(top-level-eval-hook e mod)
(list (lambda () e))))
(else
(if (memq 'eval esew)
(top-level-eval-hook
- (expand-install-global var
type (expand e r w mod))
+ (expand-install-global mod var
type (expand e r w mod))
mod))
'())))))
((memv key '(begin-form))
@@ -683,9 +693,10 @@
(let ((exps (map (lambda (x) (x)) (reverse (parse body r w s m
esew mod)))))
(if (null? exps) (build-void s) (build-sequence s exps)))))))
(expand-install-global
- (lambda (name type e)
+ (lambda (mod name type e)
(build-global-definition
#f
+ mod
name
(build-primcall
#f
@@ -976,11 +987,11 @@
(source-wrap e w (cdr w) mod)
x))
(else (decorate-source x s))))))
- (let* ((t-680b775fb37a463-7b8 transformer-environment)
- (t-680b775fb37a463-7b9 (lambda (k) (k e r w s rib mod))))
+ (let* ((t-680b775fb37a463-7c8 transformer-environment)
+ (t-680b775fb37a463-7c9 (lambda (k) (k e r w s rib mod))))
(with-fluid*
- t-680b775fb37a463-7b8
- t-680b775fb37a463-7b9
+ t-680b775fb37a463-7c8
+ t-680b775fb37a463-7c9
(lambda ()
(rebuild-macro-output
(p (source-wrap e (anti-mark w) s mod))
@@ -1513,11 +1524,11 @@
s
mod
get-formals
- (map (lambda (tmp-680b775fb37a463-aa9
- tmp-680b775fb37a463-aa8
-
tmp-680b775fb37a463-aa7)
- (cons tmp-680b775fb37a463-aa7
- (cons
tmp-680b775fb37a463-aa8 tmp-680b775fb37a463-aa9)))
+ (map (lambda (tmp-680b775fb37a463-ab9
+ tmp-680b775fb37a463-ab8
+
tmp-680b775fb37a463-ab7)
+ (cons tmp-680b775fb37a463-ab7
+ (cons
tmp-680b775fb37a463-ab8 tmp-680b775fb37a463-ab9)))
e2*
e1*
args*)))
@@ -1815,11 +1826,11 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-c76
- tmp-680b775fb37a463-c75
- tmp-680b775fb37a463-c74)
- (cons tmp-680b775fb37a463-c74
- (cons tmp-680b775fb37a463-c75
tmp-680b775fb37a463-c76)))
+ (map (lambda (tmp-680b775fb37a463-c86
+ tmp-680b775fb37a463-c85
+ tmp-680b775fb37a463-c84)
+ (cons tmp-680b775fb37a463-c84
+ (cons tmp-680b775fb37a463-c85
tmp-680b775fb37a463-c86)))
e2
e1
args)))
@@ -1831,11 +1842,11 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation (syntax->datum
docstring)))
- (map (lambda (tmp-680b775fb37a463-c8c
- tmp-680b775fb37a463-c8b
- tmp-680b775fb37a463-c8a)
- (cons tmp-680b775fb37a463-c8a
- (cons tmp-680b775fb37a463-c8b
tmp-680b775fb37a463-c8c)))
+ (map (lambda (tmp-680b775fb37a463-c9c
+ tmp-680b775fb37a463-c9b
+ tmp-680b775fb37a463-c9a)
+ (cons tmp-680b775fb37a463-c9a
+ (cons tmp-680b775fb37a463-c9b
tmp-680b775fb37a463-c9c)))
e2
e1
args)))
@@ -1858,11 +1869,11 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-cac
- tmp-680b775fb37a463-cab
- tmp-680b775fb37a463-caa)
- (cons tmp-680b775fb37a463-caa
- (cons tmp-680b775fb37a463-cab
tmp-680b775fb37a463-cac)))
+ (map (lambda (tmp-680b775fb37a463-cbc
+ tmp-680b775fb37a463-cbb
+ tmp-680b775fb37a463-cba)
+ (cons tmp-680b775fb37a463-cba
+ (cons tmp-680b775fb37a463-cbb
tmp-680b775fb37a463-cbc)))
e2
e1
args)))
@@ -1874,11 +1885,11 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation (syntax->datum
docstring)))
- (map (lambda (tmp-680b775fb37a463-cc2
- tmp-680b775fb37a463-cc1
- tmp-680b775fb37a463-cc0)
- (cons tmp-680b775fb37a463-cc0
- (cons tmp-680b775fb37a463-cc1
tmp-680b775fb37a463-cc2)))
+ (map (lambda (tmp-680b775fb37a463-cd2
+ tmp-680b775fb37a463-cd1
+ tmp-680b775fb37a463-cd0)
+ (cons tmp-680b775fb37a463-cd0
+ (cons tmp-680b775fb37a463-cd1
tmp-680b775fb37a463-cd2)))
e2
e1
args)))
@@ -2803,9 +2814,9 @@
k
(list docstring)
(map (lambda (tmp-680b775fb37a463
- tmp-680b775fb37a463-112f
- tmp-680b775fb37a463-112e)
- (list (cons tmp-680b775fb37a463-112e
tmp-680b775fb37a463-112f)
+ tmp-680b775fb37a463-113f
+ tmp-680b775fb37a463-113e)
+ (list (cons tmp-680b775fb37a463-113e
tmp-680b775fb37a463-113f)
tmp-680b775fb37a463))
template
pattern
@@ -2989,8 +3000,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasilist*
- (map (lambda
(tmp-680b775fb37a463-11d3)
- (list
"value" tmp-680b775fb37a463-11d3))
+ (map (lambda
(tmp-680b775fb37a463-11e3)
+ (list
"value" tmp-680b775fb37a463-11e3))
p)
(quasi q lev))
(quasicons
@@ -3013,8 +3024,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda
(tmp-680b775fb37a463-11d8)
- (list
"value" tmp-680b775fb37a463-11d8))
+ (map (lambda
(tmp-680b775fb37a463-11e8)
+ (list
"value" tmp-680b775fb37a463-11e8))
p)
(quasi q lev))
(quasicons
@@ -3048,8 +3059,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasilist*
- (map (lambda
(tmp-680b775fb37a463-11ee)
- (list "value"
tmp-680b775fb37a463-11ee))
+ (map (lambda
(tmp-680b775fb37a463-11fe)
+ (list "value"
tmp-680b775fb37a463-11fe))
p)
(vquasi q lev))
(quasicons
@@ -3068,8 +3079,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda
(tmp-680b775fb37a463-11f3)
- (list "value"
tmp-680b775fb37a463-11f3))
+ (map (lambda
(tmp-680b775fb37a463)
+ (list "value"
tmp-680b775fb37a463))
p)
(vquasi q lev))
(quasicons
@@ -3159,8 +3170,8 @@
(let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply (lambda (t-680b775fb37a463-123c)
- (cons "vector"
t-680b775fb37a463-123c))
+ (apply (lambda (t-680b775fb37a463-124c)
+ (cons "vector"
t-680b775fb37a463-124c))
tmp)
(syntax-violation
#f
@@ -3213,9 +3224,9 @@
(let ((tmp-1 (list (emit (car x*))
(f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1
'(any any))))
(if tmp
- (apply (lambda
(t-680b775fb37a463-127a t-680b775fb37a463)
+ (apply (lambda
(t-680b775fb37a463-128a t-680b775fb37a463)
(list (make-syntax
'cons '((top)) '(hygiene guile))
-
t-680b775fb37a463-127a
+
t-680b775fb37a463-128a
t-680b775fb37a463))
tmp)
(syntax-violation
@@ -3244,9 +3255,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch
tmp-1 'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463)
+ (apply (lambda
(t-680b775fb37a463-12a2)
(cons
(make-syntax 'vector '((top)) '(hygiene guile))
-
t-680b775fb37a463))
+
t-680b775fb37a463-12a2))
tmp)
(syntax-violation
#f
@@ -3257,9 +3268,9 @@
(if tmp-1
(apply (lambda (x)
(let ((tmp (emit x)))
- (let
((t-680b775fb37a463-129e tmp))
+ (let
((t-680b775fb37a463-12ae tmp))
(list (make-syntax
'list->vector '((top)) '(hygiene guile))
-
t-680b775fb37a463-129e))))
+
t-680b775fb37a463-12ae))))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp
'(#(atom "value") any))))
(if tmp-1
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 0cad977..3cd87c8 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -329,19 +329,19 @@
(define (analyze-variable mod var modref-cont bare-cont)
(if (not mod)
- (bare-cont var)
+ (bare-cont #f var)
(let ((kind (car mod))
(mod (cdr mod)))
(case kind
((public) (modref-cont mod var #t))
- ((private) (if (not (equal? mod (module-name (current-module))))
- (modref-cont mod var #f)
- (bare-cont var)))
+ ((private) (if (equal? mod (module-name (current-module)))
+ (bare-cont mod var)
+ (modref-cont mod var #f)))
((bare) (bare-cont var))
((hygiene) (if (and (not (equal? mod (module-name
(current-module))))
(module-variable (resolve-module mod) var))
(modref-cont mod var #f)
- (bare-cont var)))
+ (bare-cont mod var)))
((primitive)
(syntax-violation #f "primitive not in operator position" var))
(else (syntax-violation #f "bad module kind" var mod))))))
@@ -352,8 +352,8 @@
mod var
(lambda (mod var public?)
(make-module-ref source mod var public?))
- (lambda (var)
- (make-toplevel-ref source var)))))
+ (lambda (mod var)
+ (make-toplevel-ref source mod var)))))
(define build-global-assignment
(lambda (source var exp mod)
@@ -362,13 +362,13 @@
mod var
(lambda (mod var public?)
(make-module-set source mod var public? exp))
- (lambda (var)
- (make-toplevel-set source var exp)))))
+ (lambda (mod var)
+ (make-toplevel-set source mod var exp)))))
(define build-global-definition
- (lambda (source var exp)
+ (lambda (source mod var exp)
(maybe-name-value! var exp)
- (make-toplevel-define source var exp)))
+ (make-toplevel-define source (and mod (cdr mod)) var exp)))
(define build-simple-lambda
(lambda (src req rest vars meta exp)
@@ -1142,7 +1142,7 @@
(record-definition! id var)
(list
(if (eq? m 'c&e)
- (let ((x (build-global-definition s var (expand e r
w mod))))
+ (let ((x (build-global-definition s mod var (expand
e r w mod))))
(top-level-eval-hook x mod)
(lambda () x))
(call-with-values
@@ -1152,10 +1152,10 @@
;; macro, then immediately discard that binding.
(if (eq? type* 'macro)
(top-level-eval-hook (build-global-definition
- s var (build-void s))
+ s mod var (build-void
s))
mod))
(lambda ()
- (build-global-definition s var (expand e r w
mod)))))))))
+ (build-global-definition s mod var (expand e r
w mod)))))))))
((define-syntax-form define-syntax-parameter-form)
(let* ((id (wrap value w mod))
(label (gen-label))
@@ -1167,23 +1167,23 @@
((c)
(cond
((memq 'compile esew)
- (let ((e (expand-install-global var type (expand e r
w mod))))
+ (let ((e (expand-install-global mod var type (expand
e r w mod))))
(top-level-eval-hook e mod)
(if (memq 'load esew)
(list (lambda () e))
'())))
((memq 'load esew)
(list (lambda ()
- (expand-install-global var type (expand e r
w mod)))))
+ (expand-install-global mod var type (expand
e r w mod)))))
(else '())))
((c&e)
- (let ((e (expand-install-global var type (expand e r w
mod))))
+ (let ((e (expand-install-global mod var type (expand e
r w mod))))
(top-level-eval-hook e mod)
(list (lambda () e))))
(else
(if (memq 'eval esew)
(top-level-eval-hook
- (expand-install-global var type (expand e r w
mod))
+ (expand-install-global mod var type (expand e r w
mod))
mod))
'()))))
((begin-form)
@@ -1244,9 +1244,10 @@
(build-sequence s exps))))))
(define expand-install-global
- (lambda (name type e)
+ (lambda (mod name type e)
(build-global-definition
no-source
+ mod
name
(build-primcall
no-source
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 5cb4710..77d6f23 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2009-2014, 2017-2018 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2014, 2017-2019 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -30,9 +30,9 @@
<lexical-set> lexical-set? make-lexical-set lexical-set-src
lexical-set-name lexical-set-gensym lexical-set-exp
<module-ref> module-ref? make-module-ref module-ref-src
module-ref-mod module-ref-name module-ref-public?
<module-set> module-set? make-module-set module-set-src
module-set-mod module-set-name module-set-public? module-set-exp
- <toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src
toplevel-ref-name
- <toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src
toplevel-set-name toplevel-set-exp
- <toplevel-define> toplevel-define? make-toplevel-define
toplevel-define-src toplevel-define-name toplevel-define-exp
+ <toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src
toplevel-ref-mod toplevel-ref-name
+ <toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src
toplevel-set-mod toplevel-set-name toplevel-set-exp
+ <toplevel-define> toplevel-define? make-toplevel-define
toplevel-define-src toplevel-define-mod toplevel-define-name toplevel-define-exp
<conditional> conditional? make-conditional conditional-src
conditional-test conditional-consequent conditional-alternate
<call> call? make-call call-src call-proc call-args
<primcall> primcall? make-primcall primcall-src primcall-name
primcall-args
@@ -117,9 +117,9 @@
;; (<lexical-set> name gensym exp)
;; (<module-ref> mod name public?)
;; (<module-set> mod name public? exp)
- ;; (<toplevel-ref> name)
- ;; (<toplevel-set> name exp)
- ;; (<toplevel-define> name exp)
+ ;; (<toplevel-ref> mod name)
+ ;; (<toplevel-set> mod name exp)
+ ;; (<toplevel-define> mod name exp)
;; (<conditional> test consequent alternate)
;; (<call> proc args)
;; (<primcall> name args)
@@ -197,13 +197,13 @@
(make-module-set loc mod name #f (retrans exp)))
(('toplevel (and name (? symbol?)))
- (make-toplevel-ref loc name))
+ (make-toplevel-ref loc #f name))
(('set! ('toplevel (and name (? symbol?))) exp)
- (make-toplevel-set loc name (retrans exp)))
+ (make-toplevel-set loc #f name (retrans exp)))
(('define (and name (? symbol?)) exp)
- (make-toplevel-define loc name (retrans exp)))
+ (make-toplevel-define loc #f name (retrans exp)))
(('lambda meta body)
(make-lambda loc meta (retrans body)))
@@ -286,13 +286,13 @@
(($ <module-set> src mod name public? exp)
`(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
- (($ <toplevel-ref> src name)
+ (($ <toplevel-ref> src mod name)
`(toplevel ,name))
- (($ <toplevel-set> src name exp)
+ (($ <toplevel-set> src mod name exp)
`(set! (toplevel ,name) ,(unparse-tree-il exp)))
- (($ <toplevel-define> src name exp)
+ (($ <toplevel-define> src mod name exp)
`(define ,name ,(unparse-tree-il exp)))
(($ <lambda> src meta body)
@@ -356,9 +356,9 @@
(foldts exp seed ...))
(($ <module-set> src mod name public? exp)
(foldts exp seed ...))
- (($ <toplevel-set> src name exp)
+ (($ <toplevel-set> src mod name exp)
(foldts exp seed ...))
- (($ <toplevel-define> src name exp)
+ (($ <toplevel-define> src mod name exp)
(foldts exp seed ...))
(($ <conditional> src test consequent alternate)
(let*-values (((seed ...) (foldts test seed ...))
@@ -449,17 +449,17 @@ This is an implementation of `foldts' as described by
Andy Wingo in
x
(make-module-set src mod name public? exp*))))
- (($ <toplevel-set> src name exp)
+ (($ <toplevel-set> src mod name exp)
(let ((exp* (lp exp)))
(if (eq? exp exp*)
x
- (make-toplevel-set src name exp*))))
+ (make-toplevel-set src mod name exp*))))
- (($ <toplevel-define> src name exp)
+ (($ <toplevel-define> src mod name exp)
(let ((exp* (lp exp)))
(if (eq? exp exp*)
x
- (make-toplevel-define src name exp*))))
+ (make-toplevel-define src mod name exp*))))
(($ <conditional> src test consequent alternate)
(let ((test* (lp test))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index 62632fd..eb83a8e 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -873,7 +873,7 @@ given `tree-il' element."
(match proc
(($ <module-ref> _ '(oop goops) 'toplevel-define! #f)
(toplevel-define-arg args))
- (($ <toplevel-ref> _ 'toplevel-define!)
+ (($ <toplevel-ref> _ _ 'toplevel-define!)
;; This may be the result of expanding one of the GOOPS macros within
;; `oop/goops.scm'.
(and (eq? env (resolve-module '(oop goops)))
@@ -972,11 +972,11 @@ given `tree-il' element."
(($ <primcall> _ 'make-syntax-transformer) #t)
(_ #f)))
(match x
- (($ <toplevel-ref> src name)
+ (($ <toplevel-ref> src mod name)
(add-use name (nearest-loc src)))
- (($ <toplevel-set> src name)
+ (($ <toplevel-set> src mod name)
(add-use name (nearest-loc src)))
- (($ <toplevel-define> src name (? macro?))
+ (($ <toplevel-define> src mod name (? macro?))
(add-def name (nearest-loc src)))
(_ info)))
@@ -1421,10 +1421,10 @@ resort, return #t when EXP refers to the global
variable SPECIAL-NAME."
(cut eq? <> special-name))
(match exp
- (($ <toplevel-ref> _ (? special?))
+ (($ <toplevel-ref> _ _ (? special?))
;; Allow top-levels like: (define _ (cut gettext <> "my-domain")).
#t)
- (($ <toplevel-ref> _ name)
+ (($ <toplevel-ref> _ _ name)
(let ((var (module-variable env name)))
(and var (variable-bound? var)
(eq? (variable-ref var) proc))))
@@ -1464,7 +1464,7 @@ resort, return #t when EXP refers to the global variable
SPECIAL-NAME."
(define format-analysis
;; Report arity mismatches in the given tree.
(make-tree-analysis
- (lambda (x _ env locs)
+ (lambda (x res env locs)
;; Down into X.
(define (check-format-args args loc)
(pmatch args
@@ -1539,7 +1539,7 @@ resort, return #t when EXP refers to the global variable
SPECIAL-NAME."
(false-if-exception (module-ref env name))))
(match x
- (($ <call> src ($ <toplevel-ref> _ name) args)
+ (($ <call> src ($ <toplevel-ref> _ _ name) args)
(let ((proc (resolve-toplevel name)))
(if (or (and (eq? proc (@ (guile) simple-format))
(check-simple-format-args args
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 6c8884a..d97ead9 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2015,2017-2019 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -1849,7 +1849,7 @@
($continue k src
($primcall 'scm-set!/immediate '(box . 1) (box val))))))))))
- (($ <toplevel-ref> src name)
+ (($ <toplevel-ref> src mod name)
(toplevel-box
cps src name #t
(lambda (cps box)
@@ -1859,7 +1859,7 @@
($continue k src
($primcall 'scm-ref/immediate '(box . 1) (box))))))))
- (($ <toplevel-set> src name exp)
+ (($ <toplevel-set> src mod name exp)
(convert-arg cps exp
(lambda (cps val)
(toplevel-box
@@ -1871,7 +1871,7 @@
($continue k src
($primcall 'scm-set!/immediate '(box . 1) (box val))))))))))
- (($ <toplevel-define> src name exp)
+ (($ <toplevel-define> src modname name exp)
(convert-arg cps exp
(lambda (cps val)
(with-cps cps
diff --git a/module/language/tree-il/debug.scm
b/module/language/tree-il/debug.scm
index 613dc2e..3878fb5 100644
--- a/module/language/tree-il/debug.scm
+++ b/module/language/tree-il/debug.scm
@@ -1,6 +1,6 @@
;;; Tree-IL verifier
-;; Copyright (C) 2011, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2013, 2019 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -170,8 +170,10 @@
(visit body env))))
(($ <const> src val) #t)
(($ <void> src) #t)
- (($ <toplevel-ref> src name)
+ (($ <toplevel-ref> src mod name)
(cond
+ ((and mod (not (and (list? mod) (and-map symbol? mod))))
+ (error "module name should be #f or list of symbols" mod))
((not (symbol? name))
(error "name should be a symbol" name))))
(($ <module-ref> src mod name public?)
@@ -184,14 +186,18 @@
(cond
((not (symbol? name))
(error "name should be symbol" exp))))
- (($ <toplevel-set> src name exp)
+ (($ <toplevel-set> src mod name exp)
(cond
+ ((and mod (not (and (list? mod) (and-map symbol? mod))))
+ (error "module name should be #f or list of symbols" mod))
((not (symbol? name))
(error "name should be a symbol" name))
(else
(visit exp env))))
- (($ <toplevel-define> src name exp)
+ (($ <toplevel-define> src mod name exp)
(cond
+ ((and mod (not (and (list? mod) (and-map symbol? mod))))
+ (error "module name should be #f or list of symbols" mod))
((not (symbol? name))
(error "name should be a symbol" name))
(else
diff --git a/module/language/tree-il/effects.scm
b/module/language/tree-il/effects.scm
index a133e32..05016a3 100644
--- a/module/language/tree-il/effects.scm
+++ b/module/language/tree-il/effects.scm
@@ -294,10 +294,10 @@ of an expression."
(logior (cause &toplevel)
(cause &type-check)
(compute-effects exp)))
- (($ <toplevel-define> _ name exp)
+ (($ <toplevel-define> _ _ name exp)
(logior (cause &toplevel)
(compute-effects exp)))
- (($ <toplevel-set> _ name exp)
+ (($ <toplevel-set> _ _ name exp)
(logior (cause &toplevel)
(compute-effects exp)))
(($ <primitive-ref>)
diff --git a/module/language/tree-il/fix-letrec.scm
b/module/language/tree-il/fix-letrec.scm
index 227bbfb..afc9b8e 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -87,9 +87,9 @@
(adjoin gensym (recurse exp)))
(($ <module-set> src mod name public? exp)
(recurse exp))
- (($ <toplevel-set> src name exp)
+ (($ <toplevel-set> src mod name exp)
(recurse exp))
- (($ <toplevel-define> src name exp)
+ (($ <toplevel-define> src mod name exp)
(recurse exp))
(($ <conditional> src test consequent alternate)
(union (recurse test)
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index e1938e6..f11640f 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -387,7 +387,7 @@ top-level bindings from ENV and return the resulting
expression."
(let ()
(define (env-folder x env)
(match x
- (($ <toplevel-define> _ name)
+ (($ <toplevel-define> _ _ name)
(vhash-consq name #t env))
(($ <seq> _ head tail)
(env-folder tail (env-folder head env)))
@@ -1020,7 +1020,7 @@ top-level bindings from ENV and return the resulting
expression."
(else #f))))
(_ #f))
(make-let-values lv-src producer (for-tail consumer)))))
- (($ <toplevel-ref> src (? effect-free-primitive? name))
+ (($ <toplevel-ref> src mod (? effect-free-primitive? name))
exp)
(($ <toplevel-ref>)
;; todo: open private local bindings.
@@ -1038,10 +1038,10 @@ top-level bindings from ENV and return the resulting
expression."
exp)
(($ <module-set> src mod name public? exp)
(make-module-set src mod name public? (for-value exp)))
- (($ <toplevel-define> src name exp)
- (make-toplevel-define src name (for-value exp)))
- (($ <toplevel-set> src name exp)
- (make-toplevel-set src name (for-value exp)))
+ (($ <toplevel-define> src mod name exp)
+ (make-toplevel-define src mod name (for-value exp)))
+ (($ <toplevel-set> src mod name exp)
+ (make-toplevel-set src mod name (for-value exp)))
(($ <primitive-ref>)
(case ctx
((effect) (make-void #f))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index bba2f6f..46729ef 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1,7 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <address@hidden> --- May 2009
;;;;
-;;;; Copyright (C) 2009-2014, 2018 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2014,2018-2019 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -188,11 +188,11 @@
x))
(and (= result 12)
(equal? (map strip-source (list-head (reverse ups) 3))
- (list (make-toplevel-ref #f '+)
+ (list (make-toplevel-ref #f #f '+)
(make-lexical-ref #f 'x 'x1)
(make-lexical-ref #f 'y 'y1)))
(equal? (map strip-source (reverse (list-head downs 3)))
- (list (make-toplevel-ref #f '+)
+ (list (make-toplevel-ref #f #f '+)
(make-lexical-ref #f 'x 'x1)
(make-lexical-ref #f 'y 'y1)))))))
- [Guile-commits] branch master updated (b16ad94 -> 2751096), Andy Wingo, 2019/08/18
- [Guile-commits] 01/10: Fix bug in which codegen accessed data beyond end of stack, Andy Wingo, 2019/08/18
- [Guile-commits] 03/10: Simplify the define-primitive-expander macro, Andy Wingo, 2019/08/18
- [Guile-commits] 09/10: Fix coverage test for top-level binding optimization, Andy Wingo, 2019/08/18
- [Guile-commits] 08/10: Skip tests that don't work under letrectification, Andy Wingo, 2019/08/18
- [Guile-commits] 10/10: Define missing shuffling assembler for string-set! et al, Andy Wingo, 2019/08/18
- [Guile-commits] 07/10: Enable letrectification, Andy Wingo, 2019/08/18
- [Guile-commits] 05/10: Add letrectify tree-il pass, Andy Wingo, 2019/08/18
- [Guile-commits] 06/10: Add notion of declarative modules, Andy Wingo, 2019/08/18
- [Guile-commits] 02/10: Add "mod" field to tree-il toplevel ref, set, define,
Andy Wingo <=
- [Guile-commits] 04/10: Add primitive support for working with module variables, Andy Wingo, 2019/08/18