1#lang racket/base
2(require "../common/set.rkt"
3         "../syntax/syntax.rkt"
4         "../syntax/scope.rkt"
5         "../common/phase.rkt"
6         "../namespace/namespace.rkt"
7         "../expand/root-expand-context.rkt")
8
9(provide swap-top-level-scopes
10         extract-namespace-scopes
11         encode-namespace-scopes
12         namespace-scopes=?)
13
14;; In case a syntax object in compiled top-level code is from a
15;; different namespace or deserialized, swap the current namespace's
16;; scope for the original namespace's scope.
17;;
18;; To swap a namespace scopes, we partition the namespace scopes into
19;; two groups: the scope that's added after every expansion (and
20;; therefore appears on every binding form), and the other scopes that
21;; indicate being original to the namespace. We swap those groups
22;; separately.
23
24(struct namespace-scopes (post other) #:prefab)
25
26;; Swapping function, used at run time:
27(define (swap-top-level-scopes s original-scopes-s new-ns)
28  (define-values (old-scs-post old-scs-other)
29    (if (namespace-scopes? original-scopes-s)
30        (values (namespace-scopes-post original-scopes-s)
31                (namespace-scopes-other original-scopes-s))
32        (decode-namespace-scopes original-scopes-s)))
33  (define-values (new-scs-post new-scs-other) (extract-namespace-scopes/values new-ns))
34  (syntax-swap-scopes (syntax-swap-scopes s old-scs-post new-scs-post)
35                      old-scs-other new-scs-other))
36
37(define (extract-namespace-scopes/values ns)
38  (define root-ctx (namespace-get-root-expand-ctx ns))
39  (define post-expansion-sc (post-expansion-scope (root-expand-context-post-expansion root-ctx)))
40  (values (seteq post-expansion-sc)
41          (set-remove (list->seteq (root-expand-context-module-scopes root-ctx))
42                      post-expansion-sc)))
43
44(define (extract-namespace-scopes ns)
45  (define-values (scs-post scs-other) (extract-namespace-scopes/values ns))
46  (namespace-scopes scs-post scs-other))
47
48;; Extract namespace scopes to a syntax object, used at compile time:
49(define (encode-namespace-scopes ns)
50  (define-values (post-expansion-scs other-scs) (extract-namespace-scopes/values ns))
51  (define post-expansion-s (add-scopes (datum->syntax #f 'post)
52                                       (set->list post-expansion-scs)))
53  (define other-s (add-scopes (datum->syntax #f 'other)
54                              (set->list other-scs)))
55  (datum->syntax #f (vector post-expansion-s other-s)))
56
57;; Decoding, used at run time:
58(define (decode-namespace-scopes stx)
59  (define vec (syntax-e stx))
60  (values (syntax-scope-set (vector-ref vec 0) 0)
61          (syntax-scope-set (vector-ref vec 1) 0)))
62
63(define (namespace-scopes=? nss1 nss2)
64  (and (set=? (namespace-scopes-post nss1)
65              (namespace-scopes-post nss2))
66       (set=? (namespace-scopes-other nss1)
67              (namespace-scopes-other nss2))))
68