blob: 20589b8e0e477ab6a60544480d76debd1efae558 (
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
|
(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 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?
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-if-status cpp-variables
make-environment in-environment?
remove-identifier! add-identifier!
get-identifier
extend-environment
))
(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)))
(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)))
(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-variabes type: hash-table? default: (make-hash-table))
(cpp-file-stack type: list?
default: '()))
(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 (in-envirnoment? 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? key)
(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 (clone-hash-table ht)
(alist->hash-table (hash-map->list cons ht)))
(define (extend-environment environment macros)
(let ((env (modify environment cpp-variables clone-hash-table)))
(fold (lambda (pair m)
(add-identifier! env (macro-identifier m) m ))
env macros)))
|
