forked from bldl/magnolisp
-
Notifications
You must be signed in to change notification settings - Fork 0
/
modbeg.rkt
133 lines (117 loc) · 4.89 KB
/
modbeg.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
#lang racket/base
#|
Whatever we export should also have some location information, so we
do our best to preserve this information for any syntax objects we
include in our metadata. Should we discover errors only once we start
actual compilation or linking, then we need to be able to still report
errors properly.
To record metadata for the compiler, we use code that runs in phase
level 1, but concerns phase level 0. Since the recording code lives in
phase 1, the respective module's #%module-begin will be executed in
the same phase, and will hence have access to the information (via the
same variables at the same phase level).
|#
(provide module-begin
(for-syntax make-module-begin))
(require "core.rkt"
(for-syntax
racket/base racket/dict racket/list racket/pretty
syntax/id-table syntax/modresolve syntax/quote
syntax/strip-context
"app-util.rkt"
"ir-ast.rkt" "ast-serialize.rkt"
"parse.rkt" "util.rkt"))
(define-for-syntax (make-definfo-submodule
orig-mb-id modbeg-stx prelude-stx prelude-ids)
(define decl-name (current-module-declare-name))
(define rel-to-path-v
(cond
[decl-name (resolved-module-path-name decl-name)]
[else
(define src (syntax-source orig-mb-id))
(cond
[(path? src) src]
[else
(error 'make-definfo-submodule
"cannot determine module path for ~s"
orig-mb-id)])]))
;;(pretty-print (syntax->datum modbeg-stx))
;;(pretty-print (syntax->datum/binding modbeg-stx #:conv-id id->datum/phase))
(define defs
(parse-defs-from-module modbeg-stx))
;;(pretty-print defs) (exit)
;;(pretty-print (map (lambda (def) (cons def (ast-anno-maybe def 'export))) (dict-values defs)))
;;(displayln 'ast-before-marshaling) (for (((id def) (in-dict defs))) (ast-dump-loc-info def))
(define id->bind (make-free-id-table))
(define bind->binding (make-hasheq))
(define next-r #hasheq())
(define (rw-id id)
(define bind (dict-ref id->bind id #f))
(unless bind
(set!-values (next-r bind) (next-gensym1 next-r (syntax-e id)))
(dict-set! id->bind id bind))
(define b (identifier-binding id 0))
;;(writeln b)
(define bi
(if (not (list? b))
b
(let ([mpi (first b)]
[sym (second b)]
[ph (sixth b)])
;; Not bound as Magnolisp if the source phase level is not 0.
(and (eqv? ph 0)
(let ((r-mp (resolve-module-path-index mpi rel-to-path-v)))
;;(writeln (list r-mp sym))
(list r-mp sym))))))
(define old-bi (hash-ref bind->binding bind #f))
(when (and old-bi (not (equal? bi old-bi)))
(error 'make-definfo-submodule
"differing bindings for the same ID: ~s != ~s (~s)"
old-bi bi id))
(hash-set! bind->binding bind bi)
(identifier->Id id #:bind bind))
(define def-lst
(for/list ([(id def) (in-dict defs)])
(ast-rw-Ids rw-id def)))
(define core-syms (make-hasheq)) ;; sym -> local bind
(for ([id prelude-ids])
(define bind (dict-ref id->bind id #f))
(when bind
(hash-set! core-syms (syntax-e id) bind)))
;;(writeln (list (current-module-declare-source) (current-module-declare-name)))
(define mod-stx
#`(magnolisp-s2s
racket/base
(require magnolisp/ir-ast)
(define bind->binding #,(syntactifiable-mkstx bind->binding))
(define def-lst #,(syntactifiable-mkstx def-lst))
(define prelude-lst #,prelude-stx)
(define core->bind #,(syntactifiable-mkstx core-syms))
(provide bind->binding def-lst prelude-lst core->bind)))
#`(module . #,(strip-context mod-stx)))
(define-for-syntax (make-module-begin
stx
#:prelude-path [prelude-stx #''(magnolisp/prelude)]
#:prelude-ids [prelude-ids (list #'Bool #'Void)])
(syntax-case stx ()
[(orig-mb . bodies)
(let ()
(define ast (local-expand
#`(#%module-begin . bodies)
'module-begin null))
;;(pretty-print (syntax->datum/loc ast))
;;(pretty-print (syntax->datum/loc ast #:stx->datum stx->datum/source))
(define sm-stx
(make-definfo-submodule #'orig-mb ast prelude-stx prelude-ids))
(with-syntax ([(mb . bodies) ast]
[sm sm-stx])
(let ([mb-stx #'(mb sm . bodies)])
;;(pretty-print (syntax->datum sm-stx))
;;(pretty-print (syntax->datum mb-stx))
;;(pretty-print (syntax->datum/free-id mb-stx))
;;(pretty-print (syntax->datum/binding ast))
;;(pretty-print (syntax->datum/binding sm-stx #:conv-id id->datum/phase))
;;(pretty-print (syntax->datum/binding sm-stx #:pred (lambda (x) (memq x '(equal? r.equal?)))))
mb-stx)))]))
(define-syntax (module-begin stx)
(make-module-begin stx))