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