1#lang racket/base
2(require "../common/promise.rkt"
3         "../common/phase.rkt"
4         "../common/small-hash.rkt"
5         "../syntax/bulk-binding.rkt"
6         "../common/module-path.rkt"
7         "../expand/root-expand-context.rkt"
8         "../host/linklet.rkt"
9         "registry.rkt")
10
11(provide make-namespace
12         new-namespace
13         namespace?
14         current-namespace
15         namespace-module-registry
16         namespace-phase
17         namespace-0-phase
18         namespace-root-namespace
19         namespace-get-root-expand-ctx
20         namespace-set-root-expand-ctx!
21         namespace-self-mpi
22         namespace-self-mpi/no-top-level
23         namespace->namespace-at-phase
24         namespace->module
25         namespace-mpi
26         namespace-source-name
27         namespace-bulk-binding-registry
28
29         namespace-set-variable!
30         namespace-set-consistent!
31         namespace-unset-variable!
32         namespace-set-transformer!
33         namespace-unset-transformer!
34         namespace-get-variable
35         namespace-get-transformer
36
37         namespace-declaration-inspector
38         namespace-inspector
39         set-namespace-inspector!
40
41         namespace->instance
42         namespace-same-instance?)
43
44(module+ for-module
45  (provide (struct-out namespace)
46           (struct-out module-registry)
47           (struct-out definitions)
48           namespace->definitions))
49
50(struct namespace (mpi                 ; module path index (that's already resolved); instance-specific for a module
51                   source-name         ; #f (top-level) or symbol or complete path; user-facing alternative to the mpi
52                   root-expand-ctx     ; delay of box of context for top-level expansion; set by module instantiation
53                   phase               ; phase (not phase level!) of this namespace
54                   0-phase             ; phase of module instance's phase-level 0
55                   phase-to-namespace  ; phase -> namespace for same module  [shared for the same module instance]
56                   phase-level-to-definitions ; phase-level -> definitions [shared for the same module instance]
57                   module-registry     ; module-registry of (resolved-module-path -> module) [shared among modules]
58                   bulk-binding-registry ; (resolved-module-path -> bulk-provide) for resolving bulk bindings on unmarshal
59                   submodule-declarations ; resolved-module-path -> module [shared during a module compilation]
60                   root-namespace      ; #f or namespace for #lang, #reader, and persistent instances [shared among modules]
61                   declaration-inspector ; declaration-time inspector
62                   [inspector #:mutable] ; instantiation-time inspector
63                   available-module-instances  ; phase -> list of module-instance [shared among modules]
64                   module-instances)   ; union resolved-module-path -> module-instance        [shared among modules]
65  ;;                                   ;       0-phase -> resolved-module-path -> module-instance
66  ;;                                   ; where the first option is for cross phase persistent modules
67  #:authentic
68  #:property prop:custom-write
69  (lambda (ns port mode)
70    (write-string "#<namespace" port)
71    (define n (namespace-source-name ns))
72    (when n
73      (fprintf port ":~a" (namespace->name ns)))
74    (define 0-phase (namespace-0-phase ns))
75    (define phase-level (phase- (namespace-phase ns)
76                                0-phase))
77    (unless (zero-phase? phase-level)
78      (fprintf port ":~s" phase-level))
79    (unless (zero-phase? 0-phase)
80      (fprintf port "~a~s" (if (positive? 0-phase) "+" "") 0-phase))
81    (write-string ">" port)))
82
83(struct definitions (variables      ; linklet instance
84                     transformers)  ; sym -> val
85  #:authentic)
86
87(define (make-namespace)
88  (new-namespace))
89
90(define (new-namespace [share-from-ns #f]
91                       #:root-expand-ctx [root-expand-ctx (make-root-expand-context
92                                                           #:self-mpi top-level-module-path-index)]
93                       #:register? [register? #t])
94  (define phase (if share-from-ns
95                    (namespace-phase share-from-ns)
96                    0))
97  (define ns
98    (namespace top-level-module-path-index
99               #f
100               (box root-expand-ctx)
101               phase
102               phase
103               (make-small-hasheqv)    ; phase-to-namespace
104               (make-small-hasheqv)    ; phase-level-to-definitions
105               (if share-from-ns
106                   (namespace-module-registry share-from-ns)
107                   (make-module-registry))
108               (if share-from-ns
109                   (namespace-bulk-binding-registry share-from-ns)
110                   (make-bulk-binding-registry))
111               (make-small-hasheq)     ; submodule-declarations
112               (and share-from-ns
113                    (or (namespace-root-namespace share-from-ns)
114                        share-from-ns))
115               #f ; no declaration-time inspector for a top-level namespace
116               (make-inspector (current-code-inspector))
117               (if share-from-ns
118                   (namespace-available-module-instances share-from-ns)
119                   (make-hasheqv))
120               (if share-from-ns
121                   (namespace-module-instances share-from-ns)
122                   (make-hasheqv))))
123  (when register?
124    (small-hash-set! (namespace-phase-to-namespace ns) phase ns))
125  ns)
126
127(define current-namespace (make-parameter (make-namespace)
128                                          (lambda (v)
129                                            (unless (namespace? v)
130                                              (raise-argument-error 'current-namespace
131                                                                    "namespace?"
132                                                                    v))
133                                            v)
134                                          'current-namespace))
135
136(define (namespace-get-root-expand-ctx ns)
137  (force (unbox (namespace-root-expand-ctx ns))))
138
139(define (namespace-set-root-expand-ctx! ns root-ctx)
140  (set-box! (namespace-root-expand-ctx ns) root-ctx))
141
142(define (namespace-self-mpi ns)
143  (root-expand-context-self-mpi (namespace-get-root-expand-ctx ns)))
144
145(define (namespace-self-mpi/no-top-level ns)
146  (define mpi (root-expand-context-self-mpi (namespace-get-root-expand-ctx ns)))
147  (if (and mpi (top-level-module-path-index? mpi))
148      #f
149      mpi))
150
151(define (namespace->module ns name)
152  (or (small-hash-ref (namespace-submodule-declarations ns) name #f)
153      (hash-ref (module-registry-declarations (namespace-module-registry ns)) name #f)))
154
155(define (namespace->namespace-at-phase ns phase)
156  (or (small-hash-ref (namespace-phase-to-namespace ns) phase #f)
157      (let ([p-ns (struct-copy namespace ns
158                               [phase phase]
159                               [root-namespace (or (namespace-root-namespace ns)
160                                                   ns)])])
161        (small-hash-set! (namespace-phase-to-namespace ns) phase p-ns)
162        p-ns)))
163
164(define (namespace->name ns)
165  (define n (namespace-source-name ns))
166  (define s
167    (cond
168     [(not n) 'top-level]
169     [(symbol? n) (format "'~s" n)]
170     [else (string-append "\"" (path->string n) "\"")]))
171  (define r (resolved-module-path-name (module-path-index-resolve (namespace-mpi ns))))
172  (if (pair? r)
173      (string-append "(submod " s " " (substring (format "~s" (cdr r)) 1))
174      s))
175
176(define (namespace->definitions ns phase-level)
177  (define d (small-hash-ref (namespace-phase-level-to-definitions ns) phase-level #f))
178  (or d
179      (let ()
180        (define p-ns (namespace->namespace-at-phase ns (phase+ (namespace-0-phase ns)
181                                                               phase-level)))
182        (define d (definitions (make-instance (namespace->name p-ns) p-ns) (make-hasheq)))
183        (small-hash-set! (namespace-phase-level-to-definitions ns) phase-level d)
184        d)))
185
186(define (namespace-set-variable! ns phase-level name val [as-constant? #f])
187  (define d (namespace->definitions ns phase-level))
188  (instance-set-variable-value! (definitions-variables d) name val (and as-constant? 'constant)))
189
190(define (namespace-set-consistent! ns phase-level name val)
191  (define d (namespace->definitions ns phase-level))
192  (instance-set-variable-value! (definitions-variables d) name val 'consistent))
193
194(define (namespace-unset-variable! ns phase-level name)
195  (define d (namespace->definitions ns phase-level))
196  (instance-unset-variable! (definitions-variables d) name))
197
198(define (namespace-set-transformer! ns phase-level name val)
199  (define d (namespace->definitions ns (add1 phase-level)))
200  (hash-set! (definitions-transformers d) name val))
201
202(define (namespace-unset-transformer! ns phase-level name)
203  (define d (namespace->definitions ns (add1 phase-level)))
204  (hash-remove! (definitions-transformers d) name))
205
206(define (namespace-get-variable ns phase-level name fail-k)
207  (define d (namespace->definitions ns phase-level))
208  (instance-variable-value (definitions-variables d) name fail-k))
209
210(define (namespace-get-transformer ns phase-level name fail-k)
211  (define d (namespace->definitions ns (add1 phase-level)))
212  (hash-ref (definitions-transformers d) name fail-k))
213
214(define (namespace->instance ns phase-shift)
215  (definitions-variables (namespace->definitions ns phase-shift)))
216
217(define (namespace-same-instance? a-ns b-ns)
218  (eq? (small-hash-ref (namespace-phase-level-to-definitions a-ns)
219                       0
220                       'no-a)
221       (small-hash-ref (namespace-phase-level-to-definitions b-ns)
222                       0
223                       'no-b)))
224