blob: fa69e1fcb5dfc80f4409b18a820e53403e90095f (
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
|
(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
leave-if
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
make-environment in-environment?
remove-identifier! add-identifier!
get-identifier
extend-environment
disjoin-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 macro)
(define body-proc
(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))))
(body-proc macro))
(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))
(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))
(define (leave-if environment)
(modify environment cpp-if-status cdr))
(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))
|
