blob: 76219edc340cf0c6c2ef7a6ed1f853e34f8adf02 (
plain)
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
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
|
(define-module (c cpp-environment)
:use-module (srfi srfi-1)
:use-module (srfi srfi-88)
:use-module (ice-9 hash-table)
:use-module (hnh util object)
:use-module (hnh util type)
:use-module (hnh util lens)
:use-module ((c cpp-environment function-like-macro) :prefix #{fun:}#)
:use-module ((c cpp-environment object-like-macro) :prefix #{obj:}#)
:use-module ((c cpp-environment internal-macro) :prefix #{int:}#)
:use-module ((c unlex) :select (unlex))
:export (
macro-identifier
macro-body
macro-identifier-list
macro-variadic?
cpp-macro?
;; pprint-macro
enter-active-if
enter-inactive-if
flip-flop-if
leave-if
in-comment-block?
enter-file
leave-file
bump-line
current-line
current-file
function-macro?
object-macro?
internal-macro?
cpp-environment
cpp-environment?
cpp-if-status
;; cpp-variables
cpp-file-stack
make-environment in-environment?
remove-identifier add-identifier
get-identifier
extend-environment
disjoin-macro
pprint-environment
pprint-macro
))
(define (macro-identifier x)
(define identifier
(cond ((obj:object-like-macro? x) obj:identifier)
((fun:function-like-macro? x) fun:identifier)
((int:internal-macro? x) int:identifier)
(else (scm-error 'wrong-type-arg "macro-identifier"
"Not a macro: ~s"
(list x) #f))))
(identifier x))
(define (macro-body-proc macro)
(cond ((obj:object-like-macro? macro) obj:body)
((fun:function-like-macro? macro) fun:body)
((int:internal-macro? macro) int:body)
(else (scm-error 'wrong-type-arg "macro-body"
"Not a macro: ~s"
(list macro) #f))))
(define macro-body
(case-lambda ((macro) ((macro-body-proc macro) macro))
((macro value) ((macro-body-proc macro) macro value))))
(define macro-identifier-list fun:identifier-list)
(define macro-variadic? fun:variadic?)
(define function-macro? fun:function-like-macro?)
(define object-macro? obj:object-like-macro?)
(define internal-macro? int:internal-macro?)
(define (cpp-macro? x)
(or (obj:object-like-macro? x)
(fun:function-like-macro? x)
(int:internal-macro? x)))
(define-type (cpp-environment)
(cpp-if-status type: (list-of (memv '(outside active-if inactive-if)))
default: '(outside))
;; not exported since type signatures don't hold inside the hash table
;; TODO replace hash table with something that doesn't require copying the
;; entire structure every time
(cpp-variables type: hash-table? default: (make-hash-table))
(cpp-file-stack type: (and (not null?)
(list-of (pair-of string? exact-integer?)))
default: '(("*outside*" . 1))))
(define (enter-active-if environment)
(modify environment cpp-if-status xcons 'active-if))
(define (enter-inactive-if environment)
(modify environment cpp-if-status xcons 'inactive-if))
;; for #else
(define (flip-flop-if environment)
((if (in-comment-block? environment)
enter-active-if
enter-inactive-if)
(leave-if environment)))
(define (leave-if environment)
(modify environment cpp-if-status cdr))
(define (in-comment-block? environment)
(eq? 'inactive-if (get environment cpp-if-status car*)))
(define (enter-file environment filename)
(modify environment cpp-file-stack xcons (cons filename 1)))
(define (leave-file environment)
(modify environment cpp-file-stack cdr))
(define current-line (compose-lenses cpp-file-stack car* cdr*))
(define current-file (compose-lenses cpp-file-stack car* car*))
(define* (bump-line environment optional: (count 1))
(modify environment current-line + count))
(define (make-environment) (cpp-environment))
(define (clone-hash-table ht)
(alist->hash-table (hash-map->list cons ht)))
(define (clone-environment environment)
(modify environment cpp-variables clone-hash-table))
(define (in-environment? environment key)
(hash-get-handle (cpp-variables environment) key))
(define (remove-identifier environment key)
(typecheck key string?)
(let ((environment (clone-environment environment)))
(hash-remove! (cpp-variables environment) key)
environment))
(define (add-identifier environment key value)
(typecheck key string?)
(typecheck value cpp-macro?)
(let ((environment (clone-environment environment)))
(hash-set! (cpp-variables environment) key value)
environment))
(define (get-identifier environment key)
(hash-ref (cpp-variables environment) key))
(define (extend-environment environment macros)
(typecheck macros (list-of cpp-macro?))
(fold (lambda (m env) (add-identifier env (macro-identifier m) m))
environment macros))
(define (disjoin-macro environment name)
(typecheck name string?)
(remove-identifier environment name))
(define* (pprint-environment environment optional: (port (current-error-port)))
(display "== Environment ==\n")
(hash-for-each (lambda (key macro)
(pprint-macro macro port)
(newline port))
(cpp-variables environment)))
(define* (pprint-macro x optional: (p (current-output-port)))
(cond ((internal-macro? x)
(format p "/* ~a INTERNAL MACRO */"
(macro-identifier x)))
((object-macro? x)
(format p "#define ~a ~a"
(macro-identifier x)
(unlex (macro-body x))))
((function-macro? x)
(format p "#define ~a(~a) ~a"
(macro-identifier x)
(string-join (append (macro-identifier-list x)
(if (macro-variadic? x)
'("...") '()))
"," 'infix)
(unlex (macro-body x))))))
|
