|
1 "{ Package: 'stx:goodies/petitparser/compiler' }" |
|
2 |
|
3 "{ NameSpace: Smalltalk }" |
|
4 |
|
5 Object subclass:#PPCClass |
|
6 instanceVariableNames:'methodDictionary currentMethod constants idGen arguments |
|
7 methodStack returnVariable properties' |
|
8 classVariableNames:'' |
|
9 poolDictionaries:'' |
|
10 category:'PetitCompiler-Compiler-Codegen' |
|
11 ! |
|
12 |
|
13 !PPCClass methodsFor:'accessing'! |
|
14 |
|
15 arguments: args |
|
16 arguments := args |
|
17 ! |
|
18 |
|
19 constants |
|
20 ^ constants |
|
21 ! |
|
22 |
|
23 currentMethod |
|
24 ^ currentMethod |
|
25 ! |
|
26 |
|
27 currentNonInlineMethod |
|
28 ^ methodStack |
|
29 detect:[:m | m isInline not ] |
|
30 ifNone:[ self error: 'No non-inlined method'] |
|
31 |
|
32 "Created: / 23-04-2015 / 17:33:31 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
33 ! |
|
34 |
|
35 currentReturnVariable |
|
36 ^ currentMethod returnVariable |
|
37 ! |
|
38 |
|
39 idGen |
|
40 ^ idGen |
|
41 ! |
|
42 |
|
43 idGen: anObject |
|
44 idGen := anObject |
|
45 ! |
|
46 |
|
47 ids |
|
48 ^ idGen ids |
|
49 ! |
|
50 |
|
51 methodDictionary |
|
52 ^ methodDictionary |
|
53 ! |
|
54 |
|
55 name |
|
56 ^ self propertyAt: #name |
|
57 ! |
|
58 |
|
59 name: value |
|
60 ^ self propertyAt: #name put: value |
|
61 ! |
|
62 |
|
63 superclass |
|
64 ^ self propertyAt: #superclass |
|
65 ! |
|
66 |
|
67 superclass: value |
|
68 ^ self propertyAt: #superclass put: value |
|
69 ! ! |
|
70 |
|
71 !PPCClass methodsFor:'accessing-properties'! |
|
72 |
|
73 hasProperty: aKey |
|
74 "Test if the property aKey is present." |
|
75 |
|
76 ^ properties notNil and: [ properties includesKey: aKey ] |
|
77 ! |
|
78 |
|
79 properties |
|
80 ^ properties |
|
81 ! |
|
82 |
|
83 properties: aDictionary |
|
84 properties := aDictionary |
|
85 ! |
|
86 |
|
87 propertyAt: aKey |
|
88 ^ self propertyAt: aKey ifAbsent: [ nil ] |
|
89 ! |
|
90 |
|
91 propertyAt: aKey ifAbsent: aBlock |
|
92 "Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." |
|
93 |
|
94 ^ properties isNil |
|
95 ifTrue: [ aBlock value ] |
|
96 ifFalse: [ properties at: aKey ifAbsent: aBlock ] |
|
97 ! |
|
98 |
|
99 propertyAt: aKey ifAbsentPut: aBlock |
|
100 "Answer the property associated with aKey or, if aKey isn't found store the result of evaluating aBlock as new value." |
|
101 |
|
102 ^ self propertyAt: aKey ifAbsent: [ self propertyAt: aKey put: aBlock value ] |
|
103 ! |
|
104 |
|
105 propertyAt: aKey put: anObject |
|
106 "Set the property at aKey to be anObject. If aKey is not found, create a new entry for aKey and set is value to anObject. Answer anObject." |
|
107 |
|
108 ^ (properties ifNil: [ properties := Dictionary new: 1 ]) |
|
109 at: aKey put: anObject |
|
110 ! ! |
|
111 |
|
112 !PPCClass methodsFor:'constants'! |
|
113 |
|
114 addConstant: value as: name |
|
115 (constants includesKey: name) ifTrue:[ |
|
116 (constants at: name) ~= value ifTrue:[ |
|
117 self error:'Duplicate constant!!'. |
|
118 ]. |
|
119 ^ self. |
|
120 ]. |
|
121 constants at: name put: value |
|
122 |
|
123 "Modified: / 29-05-2015 / 07:22:39 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
124 ! ! |
|
125 |
|
126 !PPCClass methodsFor:'ids'! |
|
127 |
|
128 asSelector: string |
|
129 "e.g. '234znak 43 ) 2' asLegalSelector = #v234znak432" |
|
130 |
|
131 | toUse | |
|
132 |
|
133 toUse := string select: [:char | char isAlphaNumeric or: [ char = $_ ] ]. |
|
134 (toUse isEmpty or: [ toUse first isLetter not ]) |
|
135 ifTrue: [ toUse := 'v', toUse ]. |
|
136 toUse first isUppercase ifFalse:[ |
|
137 toUse := toUse copy. |
|
138 toUse at: 1 put: toUse first asLowercase |
|
139 ]. |
|
140 ^toUse |
|
141 |
|
142 "Modified: / 10-05-2015 / 07:29:57 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
143 ! |
|
144 |
|
145 idFor: anObject |
|
146 ^ idGen idFor: anObject |
|
147 ! |
|
148 |
|
149 idFor: anObject defaultName: defaultName |
|
150 ^ idGen idFor: anObject defaultName: defaultName |
|
151 ! |
|
152 |
|
153 numberIdFor: object |
|
154 ^ idGen numericIdFor: object |
|
155 ! ! |
|
156 |
|
157 !PPCClass methodsFor:'initialization'! |
|
158 |
|
159 initialize |
|
160 super initialize. |
|
161 |
|
162 methodStack := Stack new. |
|
163 methodDictionary := IdentityDictionary new. |
|
164 constants := Dictionary new. |
|
165 idGen := PPCIdGenerator new. |
|
166 ! ! |
|
167 |
|
168 !PPCClass methodsFor:'method cache'! |
|
169 |
|
170 cachedMethod: id |
|
171 ^ methodDictionary at: id ifAbsent: [ nil ] |
|
172 ! |
|
173 |
|
174 cachedMethod: id ifPresent: aBlock |
|
175 ^ methodDictionary at: id ifPresent: aBlock |
|
176 ! |
|
177 |
|
178 store: method as: id |
|
179 self assert: (method isKindOf: PPCMethod). |
|
180 methodDictionary at: id put: method. |
|
181 ! ! |
|
182 |
|
183 !PPCClass methodsFor:'support'! |
|
184 |
|
185 parsedValueOf: aBlock to: aString |
|
186 | tmpVarirable method | |
|
187 |
|
188 self assert:aBlock isBlock. |
|
189 self assert:aString isNil not. |
|
190 tmpVarirable := returnVariable. |
|
191 returnVariable := aString. |
|
192 method := [ |
|
193 aBlock value |
|
194 ] ensure:[ returnVariable := tmpVarirable ]. |
|
195 |
|
196 self assert: (method isMethod). |
|
197 ^ method |
|
198 ! |
|
199 |
|
200 pop |
|
201 | retval | |
|
202 retval := methodStack pop. |
|
203 currentMethod := methodStack isEmpty |
|
204 ifTrue: [ nil ] |
|
205 ifFalse: [ methodStack top ]. |
|
206 ^ retval |
|
207 |
|
208 "Modified: / 21-11-2014 / 12:27:25 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
209 ! |
|
210 |
|
211 push |
|
212 methodStack push: currentMethod. |
|
213 (methodStack size > 500 )ifTrue: [ self error: 'unless it is very complex grammar, there is an error somewhere' ] |
|
214 |
|
215 "Modified: / 21-11-2014 / 12:27:18 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
216 ! |
|
217 |
|
218 returnVariable |
|
219 self error: 'Should never be called and accessed outside this class'. |
|
220 ^ returnVariable |
|
221 ! |
|
222 |
|
223 startInline |
|
224 | indentationLevel | |
|
225 indentationLevel := currentMethod indentationLevel. |
|
226 |
|
227 currentMethod := PPCInlinedMethod new. |
|
228 currentMethod returnVariable: returnVariable. |
|
229 currentMethod indentationLevel: indentationLevel. |
|
230 self push. |
|
231 |
|
232 "Modified: / 01-06-2015 / 21:48:35 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
233 ! |
|
234 |
|
235 startInline: id |
|
236 | indentationLevel | |
|
237 (methodDictionary includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ]. |
|
238 indentationLevel := currentMethod indentationLevel. |
|
239 |
|
240 currentMethod := PPCInlinedMethod new. |
|
241 currentMethod id: id. |
|
242 currentMethod returnVariable: returnVariable. |
|
243 currentMethod indentationLevel: indentationLevel. |
|
244 self push. |
|
245 |
|
246 "Modified: / 01-06-2015 / 21:48:35 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
247 ! |
|
248 |
|
249 startMethod: id category: category |
|
250 (methodDictionary includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ]. |
|
251 |
|
252 currentMethod := PPCMethod new. |
|
253 currentMethod id: id. |
|
254 currentMethod category: category. |
|
255 |
|
256 self push. |
|
257 self store: currentMethod as: id. |
|
258 |
|
259 "Modified: / 01-06-2015 / 21:19:41 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
260 ! |
|
261 |
|
262 stopInline |
|
263 ^ self pop. |
|
264 |
|
265 "Modified: / 01-06-2015 / 21:37:59 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
266 ! |
|
267 |
|
268 stopMethod |
|
269 self store: currentMethod as: currentMethod methodName. |
|
270 ^ self pop. |
|
271 ! ! |
|
272 |
|
273 !PPCClass methodsFor:'variables'! |
|
274 |
|
275 allocateReturnVariable |
|
276 ^ self allocateReturnVariableNamed: 'retval' |
|
277 |
|
278 "Created: / 23-04-2015 / 18:03:40 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
279 "Modified: / 15-06-2015 / 17:52:56 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
280 ! |
|
281 |
|
282 allocateReturnVariableNamed: name |
|
283 "Allocate (or return previously allocated one) temporary variable used for |
|
284 storing a parser's return value (the parsed object)" |
|
285 ^ currentMethod allocateReturnVariableNamed: name |
|
286 |
|
287 "Created: / 15-06-2015 / 18:04:48 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
288 ! |
|
289 |
|
290 allocateTemporaryVariableNamed: preferredName |
|
291 "Allocate a new variable with (preferably) given name. |
|
292 Returns a real variable name that should be used." |
|
293 |
|
294 ^ self currentNonInlineMethod allocateTemporaryVariableNamed: preferredName |
|
295 |
|
296 "Created: / 23-04-2015 / 17:33:31 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
|
297 ! ! |
|
298 |