|
1 "{ Package: 'stx:goodies/petitparser/parsers/smalltalk/tests' }" |
|
2 |
|
3 PPCompositeParserTest subclass:#PPSmalltalkClassesTests |
|
4 instanceVariableNames:'' |
|
5 classVariableNames:'' |
|
6 poolDictionaries:'' |
|
7 category:'PetitSmalltalk-Tests' |
|
8 ! |
|
9 |
|
10 PPSmalltalkClassesTests comment:'Evalaute the following code to verify the complete image.' |
|
11 ! |
|
12 |
|
13 !PPSmalltalkClassesTests class methodsFor:'accessing'! |
|
14 |
|
15 packageNamesUnderTest |
|
16 ^ #('PetitSmalltalk') |
|
17 ! ! |
|
18 |
|
19 !PPSmalltalkClassesTests class methodsFor:'utilities'! |
|
20 |
|
21 benchmark: aParser |
|
22 "self benchmark: PPSmalltalkGrammar new" |
|
23 "self benchmark: PPSmalltalkParser new" |
|
24 "self benchmark: RBParser" |
|
25 |
|
26 | sources | |
|
27 sources := OrderedCollection new. |
|
28 SequenceableCollection withAllSubclassesDo: [ :class | |
|
29 class selectorsDo: [ :selector | |
|
30 sources add: (class sourceCodeAt: selector) ] ]. |
|
31 ^ self benchmark: aParser sources: sources asArray |
|
32 ! |
|
33 |
|
34 benchmark: aParser sources: aCollection |
|
35 | count start | |
|
36 count := 0. |
|
37 start := Time millisecondClockValue. |
|
38 [ aCollection do: [ :each | aParser parseMethod: each ]. |
|
39 count := count + 1. |
|
40 (Time millisecondsSince: start) < 10000 ] whileTrue. |
|
41 ^ (1000 * count * (aCollection detectSum: [ :each | each size ]) |
|
42 / (Time millisecondsSince: start)) asInteger asString , ' characters/sec' |
|
43 ! |
|
44 |
|
45 verifySystem |
|
46 Smalltalk globals allClasses |
|
47 inject: self new |
|
48 into: [ :test :class | test verifyClass: class ] |
|
49 ! ! |
|
50 |
|
51 !PPSmalltalkClassesTests methodsFor:'accessing'! |
|
52 |
|
53 parserClass |
|
54 ^ PPSmalltalkParser |
|
55 ! ! |
|
56 |
|
57 !PPSmalltalkClassesTests methodsFor:'private'! |
|
58 |
|
59 assert: aBoolean description: aString |
|
60 self |
|
61 assert: aBoolean |
|
62 description: aString |
|
63 resumable: true |
|
64 ! |
|
65 |
|
66 verifyClass: aClass |
|
67 aClass selectors |
|
68 do: [ :selector | self verifyClass: aClass selector: selector ]. |
|
69 aClass isMeta |
|
70 ifFalse: [ self verifyClass: aClass class ] |
|
71 ! |
|
72 |
|
73 verifyClass: aClass selector: aSelector |
|
74 "Verifies that the method aSelector in aClass parses the same using the standard refactoring parser and the petit smalltalk parser. Also make sure that the position information of all tokens and comments is equal." |
|
75 |
|
76 | signature source original other checker | |
|
77 signature := aClass name , '>>#' , aSelector. |
|
78 source := aClass sourceCodeAt: aSelector. |
|
79 source isNil ifTrue: [ ^ self ]. |
|
80 original := aClass parseTreeFor: aSelector. |
|
81 original isNil ifTrue: [ ^ self ]. |
|
82 other := self parserInstance |
|
83 parseMethod: source |
|
84 onError: [ :err | self assert: false description: signature ]. |
|
85 self |
|
86 assert: original = other |
|
87 description: 'Code in ' , signature. |
|
88 checker := [ :node1 :node2 | |
|
89 self |
|
90 assert: node1 sourceInterval = node2 sourceInterval |
|
91 description: 'Source intervals in ' , signature. |
|
92 (node1 isArray or: [ node1 isBlock or: [ node1 isPragma ] ]) ifTrue: [ |
|
93 self |
|
94 assert: node1 left = node2 left |
|
95 description: 'Source position left in ' , signature. |
|
96 self |
|
97 assert: node1 right = node2 right |
|
98 description: 'Source position right in ' , signature ]. |
|
99 (node1 isSequence) ifTrue: [ |
|
100 self |
|
101 assert: node1 leftBar = node2 leftBar |
|
102 description: 'Source position leftBar in ' , signature. |
|
103 self |
|
104 assert: node1 rightBar = node2 rightBar |
|
105 description: 'Source position rightBar in ' , signature ]. |
|
106 (node1 isBlock) ifTrue: [ |
|
107 self |
|
108 assert: node1 bar = node2 bar |
|
109 description: 'Source position bar in ' , signature ]. |
|
110 (node1 isReturn) ifTrue: [ |
|
111 self |
|
112 assert: node1 return = node2 return |
|
113 description: 'Source position return in ' , signature ]. |
|
114 (node1 isAssignment) ifTrue: [ |
|
115 self |
|
116 assert: node1 assignment = node2 assignment |
|
117 description: 'Source position return in ' , signature ]. |
|
118 (node1 isCascade) ifTrue: [ |
|
119 self |
|
120 assert: node1 semicolons asArray = node2 semicolons asArray |
|
121 description: 'Source position semicolons in ' , signature ]. |
|
122 (node1 isArray or: [ node1 isSequence ]) ifTrue: [ |
|
123 self |
|
124 assert: node1 periods asArray = node2 periods asArray |
|
125 description: 'Source position periods in ' , signature ]. |
|
126 (node1 isMethod or: [ node1 isMessage or: [ node1 isPragma ] ]) ifTrue: [ |
|
127 node1 selectorParts with: node2 selectorParts do: [ :a :b | |
|
128 self |
|
129 assert: a start = b start |
|
130 description: 'Source position selector parts in ' , signature ] ]. |
|
131 node1 children with: node2 children do: checker ]. |
|
132 checker value: original value: other |
|
133 ! ! |
|
134 |
|
135 !PPSmalltalkClassesTests methodsFor:'testing'! |
|
136 |
|
137 testCollection |
|
138 self verifyClass: Collection. |
|
139 self verifyClass: Array. |
|
140 self verifyClass: Set. |
|
141 self verifyClass: Dictionary. |
|
142 self verifyClass: Bag. |
|
143 self verifyClass: OrderedCollection. |
|
144 self verifyClass: SortedCollection |
|
145 ! |
|
146 |
|
147 testException |
|
148 self verifyClass: Exception. |
|
149 self verifyClass: Notification. |
|
150 self verifyClass: Warning. |
|
151 self verifyClass: Error |
|
152 ! |
|
153 |
|
154 testFundamental |
|
155 self verifyClass: Object. |
|
156 self verifyClass: Boolean. |
|
157 self verifyClass: True. |
|
158 self verifyClass: False. |
|
159 self verifyClass: Character |
|
160 |
|
161 |
|
162 ! |
|
163 |
|
164 testMagnitude |
|
165 self verifyClass: Magnitude. |
|
166 self verifyClass: Number. |
|
167 self verifyClass: Integer. |
|
168 self verifyClass: Float. |
|
169 self verifyClass: Fraction |
|
170 ! |
|
171 |
|
172 testStream |
|
173 self verifyClass: Stream. |
|
174 self verifyClass: ReadStream. |
|
175 self verifyClass: WriteStream |
|
176 ! ! |
|
177 |
|
178 !PPSmalltalkClassesTests methodsFor:'testing-protocol'! |
|
179 |
|
180 testParseExpression |
|
181 result := self parserClass parseExpression: '1 + 2'. |
|
182 self assert: result isMessage. |
|
183 self assert: result source equals: '1 + 2'. |
|
184 result := self parserClass parseExpression: '| a | 1 + a'. |
|
185 self assert: result isSequence. |
|
186 self assert: result source equals: '| a | 1 + a'. |
|
187 result := self parserClass parseExpression: '1 + 2. ^ 3'. |
|
188 self assert: result isSequence. |
|
189 self assert: result source equals: '1 + 2. ^ 3'. |
|
190 result := self parserClass parseExpression: '1 + ' onError: [ :err | true ]. |
|
191 self assert: result. |
|
192 self should: [ self parserClass parseExpression: '1 + ' ] raise: Error |
|
193 ! |
|
194 |
|
195 testParseMethod |
|
196 result := self parserClass parseMethod: 'do 1 + 2'. |
|
197 self assert: result isMethod. |
|
198 self assert: result source equals: 'do 1 + 2'. |
|
199 result := self parserClass parseMethod: 'do 1 +' onError: [ :err | true ]. |
|
200 self assert: result. |
|
201 self should: [ self parserClass parseMethod: 'do 1 +' ] raise: Error |
|
202 ! ! |
|
203 |