blob: 913e905e8527c18555bdcd093572691a23fb5c50 (
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:}#)
:export (
macro-identifier
macro-body
macro-identifier-list
macro-variadic?
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 (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
(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)
(hash-remove! (cpp-variables environment) key)
environment)
(define (add-identifier! environment key value)
(unless (string? key)
(scm-error 'wrong-type-arg "add-identifier!"
"Key must be a string, got: ~s"
(list key) #f))
(unless (macro? value)
(scm-error 'wrong-type-arg "add-identifier!"
"Value must be a macro, got: ~s"
(list value) #f))
(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 macro?))
(let ((env (clone-environment environment)))
(fold (lambda (m env) (add-identifier! env (macro-identifier m) m))
env macros)))
(define (disjoin-macro environment name)
(typecheck name string?)
(let ((env (clone-environment environment)))
(remove-identifier! env name)
env))
(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 (variadic? x)
'("...") '()))
"," 'infix)
(unlex (macro-body x))))))
|
