SystemOrganization addCategory: #'RoelTyper-Core'! SystemOrganization addCategory: #'RoelTyper-Pharo'! SystemOrganization addCategory: #'RoelTyper-Squeak'! SystemOrganization addCategory: #'RoelTyper-Tests'! TestCase subclass: #CommonCollectionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Tests'! !CommonCollectionTest methodsFor: 'as yet unclassified' stamp: 'PF 5/29/2009 11:36'! testFusionWith |c1 c2 cc | c1 := OrderedCollection with: 1 with: 2. c2 := OrderedCollection with: 3 with: 4. cc := CommonCollection on: (OrderedCollection with: 5 with: 6). self assert: ((c1 fusionWith: c2) difference: {1. 2. 3. 4}) isEmpty. self assert: c1 size = 4. self assert: c2 size = 2. self assert: (c1 fusionWith: cc) = cc. self assert: cc size = 6. self assert: c1 size = 4. self assert: (cc fusionWith: c1) = cc. self assert: cc size = 10. self assert: c1 size = 4. self assert: (cc fusionWith: cc) = cc. self assert: cc size = 20. ! ! !CommonCollectionTest methodsFor: 'as yet unclassified' stamp: 'PF 5/29/2009 11:28'! testRedirectionOfMessages |cc | cc := CommonCollection on: (OrderedCollection new). self assert: cc size = 0. cc add: 1. self assert: cc size = 1. cc addAll: {2. 3}. self assert: cc size = 3. cc remove: 2. self assert: cc size = 2. ! ! TestCase subclass: #ExtractedTypeTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Tests'! !ExtractedTypeTest methodsFor: 'as yet unclassified' stamp: 'PF 5/29/2009 13:17'! testFlattenLinks |et1 et2| et1 := ExtractedType basicNew initialize. et2 := ExtractedType basicNew initialize. et1 addReverseLinkedExtractedType: et2. et1 flattenLinks. et2 flattenLinks.! ! TestCase subclass: #RoelTypingTestRoot instanceVariableNames: 'dummyVariable for offsetTest' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Tests'! RoelTypingTestRoot subclass: #InstvarInterfaceExtractorTest instanceVariableNames: 'a b c u v w x y z' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Tests'! !InstvarInterfaceExtractorTest methodsFor: 'auxiliary' stamp: 'PF 5/26/2009 11:22'! assertAssignments: description in: collector | emptyIndexes ivarName ivarInterface extractedInterface ivarIndex anArray | anArray := collector typingResults. emptyIndexes := (1 to: self class allInstVarNames size) asOrderedCollection. description do: [:desc | ivarName := desc first. ivarInterface := desc at: 2. ivarIndex := collector absoluteIndexForVar: ivarName. extractedInterface := collector assignmentsTo: ivarName. self assert: extractedInterface size = ivarInterface size. self assert: (extractedInterface allSatisfy: [:each | ivarInterface includes: each name]). emptyIndexes remove: ivarIndex]. self emptyAssigment: anArray atIndexes: emptyIndexes! ! !InstvarInterfaceExtractorTest methodsFor: 'auxiliary' stamp: 'FredericPluquet 12/18/2009 17:31'! assertSends: description in: collector | emptyIndexes ivarName ivarInterface extractedInterface ivarIndex anArray | anArray := collector typingResults. emptyIndexes := (1 to: self class allInstVarNames size) asOrderedCollection. description do: [:desc | ivarName := desc first. ivarInterface := desc at: 2. ivarIndex := collector absoluteIndexForVar: ivarName. extractedInterface := collector sendsTo: ivarName. self assert: extractedInterface size = ivarInterface size. self assert: (extractedInterface allSatisfy: [:each | ivarInterface includes: each]). emptyIndexes remove: ivarIndex]. self emptyInterface: anArray atIndexes: emptyIndexes! ! !InstvarInterfaceExtractorTest methodsFor: 'auxiliary' stamp: 'FredericPluquet 12/18/2009 17:31'! denyAssignments: description in: collector | emptyIndexes ivarName ivarInterface extractedInterface ivarIndex anArray | anArray := collector typingResults. emptyIndexes := (1 to: self class allInstVarNames size) asOrderedCollection. description do: [:desc | ivarName := desc first. ivarInterface := desc at: 2. ivarIndex := collector absoluteIndexForVar: ivarName. extractedInterface := collector assignmentsTo: ivarName. ivarInterface do: [:each | self deny: (extractedInterface includes: each)]. emptyIndexes remove: ivarIndex]. self emptyAssigment: anArray atIndexes: emptyIndexes! ! !InstvarInterfaceExtractorTest methodsFor: 'auxiliary' stamp: ' 26/5/07 15:11'! empty: anArray atIndexes: indexCollection indexCollection do: [:index | self assert: (anArray at: index) isEmpty]! ! !InstvarInterfaceExtractorTest methodsFor: 'auxiliary' stamp: ' 26/5/07 15:11'! emptyAssigment: anArray atIndexes: indexCollection indexCollection do: [:index | self assert: (anArray at: index) hasEmptyAssignments]! ! !InstvarInterfaceExtractorTest methodsFor: 'auxiliary' stamp: ' 26/5/07 15:11'! emptyInterface: anArray atIndexes: indexCollection indexCollection do: [:index | self assert: (anArray at: index) hasEmptyInterface]! ! !InstvarInterfaceExtractorTest methodsFor: 'auxiliary' stamp: 'PF 5/20/2009 16:33'! processMethod: aCompiledMethod "Fail by default. Needs to be overridden by subclasses to trigger the base testing backbone." | collector | collector := TypeCollector onClass: self class. collector currentExtractedMethod: aCompiledMethod. TypeCollector new newExtractor extractInterfacesFrom: aCompiledMethod addTo: collector. ^collector! ! !InstvarInterfaceExtractorTest methodsFor: 'assignment tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testArithmetic "self run: #testArithmetic" | collector | collector := self doForSource: 'u := v \\ 3. a := b floor. b := c truncateTo: (x := 4 roundTo: 5)'. self assertSends: #(#(#v #(#\\)) #(#b #(#floor)) #(#c #(#truncateTo:))) in: collector. self assertAssignments: #(#(#u #(#Number)) #(#a #(#Number)) #(#b #(#Number)) #(#x #(#Number))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'combined tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testArithmeticValueSpecialisation | collector | collector := self doForSource: ' b := (Point x: 2 y: 4) - (1@1) '. self assertSends: #() in: collector. self assertAssignments: #(#(#b #(#Point))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'assignment tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testArrayAssignment | collector | collector := self doForSource: 'v := #(one two three)'. self assertAssignments: #(#(#v #(#Array))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testCascaded1 | collector | collector := self doForSource: 'x printString; size'. self assertSends: #(#(#x #(#printString #size))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testCascaded2 | collector | collector := self doForSource: 'x printString; size; yourself'. self assertSends: #(#(#x #(#printString #size #yourself))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'assignment tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testComplicated1 | collector | collector := self doForSource: ' b := Set new: 3 * (c collect: [:s | s])'. self assertSends: #(#(#c #(#collect:))) in: collector. self assertAssignments: #(#(#b #(#Set))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'non supported' stamp: 'FredericPluquet 12/18/2009 17:31'! testComplicated2 | collector | collector := self doForSource: ' | temp1 temp2 | temp1 := b := temp2 := 3.'. self denyAssignments: #(#(#b #(#SmallInteger))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'non supported' stamp: 'FredericPluquet 12/18/2009 17:31'! testComplicated3 "self run: #testComplicated3" "selfdebug: #testComplicated3" | collector | collector := self doForSource: ' | temp1 temp2 temp3 | temp2 := b := temp1 := 3.'. self denyAssignments: #(#(#b #(#SmallInteger))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'assignment tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testEquality | collector | collector := self doForSource: 'u := v = 3'. self assertSends: #(#(#v #(#=))) in: collector. self assertAssignments: #(#(#u #(#Boolean))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'assignment tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testIdentity | collector | collector := self doForSource: 'u := v == 3'. self assertSends: #(#(#v #(#==))) in: collector. self assertAssignments: #(#(#u #(#Boolean))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testIftrue | vSends collector | collector := self doForSource: 'u := v isNil ifTrue: [1] ifFalse: [2]'. vSends := collector sendsTo: #v. self assert: vSends size = 1. self assert: (vSends includes: #isNil)! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: 'PF 7/30/2009 19:21'! testIndirectAssignments (TypeCollector typeInstvar: #c ofClass: ASampleClass) types! ! !InstvarInterfaceExtractorTest methodsFor: 'assignment tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testInstanceAssignment | collector | collector := self doForSource: 'w := TypeCollector new'. self assertAssignments: #(#(#w #(#TypeCollector))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'assignment tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testInstanceAssignmentIndirect | collector | collector := self doForSource: 'self w: TypeCollector new'. self assertAssignments: #(#(#w #(#TypeCollector))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'assignment tests' stamp: 'PF 5/20/2009 16:40'! testInstvarAssignment1 | collector | collector := self doForSource: ' | temp1 temp2 temp3 | a := 3. b := a'. self assertAssignments: #(#(#b #(#SmallInteger)) #(#a #(#SmallInteger))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'assignment tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testInstvarAssignment2 | collector | collector := self doForSource: ' | temp1 temp2 temp3 | c := b := 3.'. self assertAssignments: #(#(#b #(#SmallInteger)) #(#c #(#SmallInteger))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'assignment tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testMetaClassAssignment | collector wAssignments wIndex wIndexRelative | collector := self doForSource: 'w := TypeCollector'. wIndex := collector absoluteIndexForVar: #w. "Absolute" wIndexRelative := wIndex - (self class allInstVarNames size - self class instVarNames size). wAssignments := collector assignmentsTo: #w. self assert: wAssignments size = 1. self assert: (wAssignments includes: TypeCollector class). self emptyAssigment: collector typingResults atIndexes: (((1 to: self class instVarNames size) asOrderedCollection) remove: wIndexRelative; yourself)! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testSuperivarAssignment | collector | collector := self doForSource: '^testSelector := testSelector'. self assertSends: #() in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testSuperivarSend | collector | collector := self doForSource: '^testSelector printString'. self assertSends: #(#(#testSelector #(#printString))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testblockindirectxy | collector | collector := self doForSource: '^self testu ifTrue: [self x] ifFalse: [self y asString]'. self assertSends: #(#(#y #(#asString))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testblockuwx | collector | collector := self doForSource: '^[u + w] on: Error do: [:exc | x printString]'. self assertSends: #(#(#u #(#+)) #(#x #(#printString))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testblockwithargs | collector | collector := self doForSource: '^[:s | s + 1] value: 1'. self assertSends: #() in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testblockxy | collector | collector := self doForSource: '^self xyw ifTrue: [x] ifFalse: [y]'. self assertSends: #() in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testblockyab " #'ifTrue:ifFalse: is sent to a, but is not Captured by the extractor" | collector | collector := self doForSource: '^self a ifTrue: [b] ifFalse: [y]'. self assertSends: #() in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testindirectx | collector | collector := self doForSource: '^self x printString'. self assertSends: #(#(#x #(#printString))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testu | collector | collector := self doForSource: '^u'. self assertSends: #() in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testuxyw | collector | collector := self doForSource: ' u := (x asString ~= y printString). ^u = w'. self assertSends: #(#(#y #(#printString)) #(#x #(#asString)) #(#u #(#=))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testxyw | collector | collector := self doForSource: ' | t | t := (x = y). ^t = w'. self assertSends: #(#(#x #(#=))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: 'FredericPluquet 12/18/2009 17:31'! testzuv | collector | collector := self doForSource: '^u ~= z or: [u = v]'. self assertSends: #(#(#u #(#= #~=))) in: collector! ! !RoelTypingTestRoot methodsFor: 'auxiliary' stamp: 'FredericPluquet 12/18/2009 17:31'! doForSource: src | m | m := (Compiler new compile: 'gen ' , src in: self class notifying: nil ifFail: [self error: 'Error during compilation of generated method.']) generate. ^self processMethod: m! ! !RoelTypingTestRoot methodsFor: 'auxiliary' stamp: ' 26/5/07 15:11'! processMethod: aCompiledMethod "Fail by default. Needs to be overridden by subclasses to trigger the base testing backbone." self assert: false! ! RoelTypingTestRoot subclass: #TypeMergerTestsRoot instanceVariableNames: 'mergeResult' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Tests'! TypeMergerTestsRoot subclass: #AbstractMergerTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Tests'! !AbstractMergerTests methodsFor: 'auxiliary' stamp: ' 26/5/07 15:11'! mergeClass ^AbstractMerger! ! !AbstractMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test1 self mergeInterfaceTypes: (OrderedCollection with: Collection) assignmentTypes: (OrderedCollection with: Array). self assert: mergeResult size = 1. self assert: mergeResult first = Collection! ! !AbstractMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test10 "Dictionary and Array are in unrelated hierarchies -> keep both." self mergeInterfaceTypes: (OrderedCollection with: Dictionary) assignmentTypes: (OrderedCollection with: Array with: Collection). self assert: mergeResult size = 3. self assert: (mergeResult includes: Dictionary). self assert: (mergeResult includes: Array). self assert: (mergeResult includes: Collection)! ! !AbstractMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test11 "Dictionary and Array are in unrelated hierarchies -> keep both." self mergeInterfaceTypes: (OrderedCollection with: Dictionary) assignmentTypes: (OrderedCollection with: Collection with: Array). self assert: mergeResult size = 3. self assert: (mergeResult includes: Dictionary). self assert: (mergeResult includes: Array). self assert: (mergeResult includes: Collection)! ! !AbstractMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test12 "Dictionary and Array are in unrelated hierarchies -> keep both. Collection bites the dust because it is superclass." self mergeInterfaceTypes: (OrderedCollection with: Collection) assignmentTypes: (OrderedCollection with: Dictionary with: Array). self assert: mergeResult size = 1. self assert: (mergeResult includes: Collection)! ! !AbstractMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test13 "Dictionary and Array are in unrelated hierarchies -> keep both. Collection bites the dust because it is superclass." self mergeInterfaceTypes: (OrderedCollection with: Collection) assignmentTypes: (OrderedCollection with: Array with: Dictionary). self assert: mergeResult size = 1. self assert: (mergeResult includes: Collection)! ! !AbstractMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test14 self mergeInterfaceTypes: (OrderedCollection with: SequenceableCollection with: Bag) assignmentTypes: (OrderedCollection with: Array). self assert: mergeResult size = 2. self assert: (mergeResult includes: SequenceableCollection). self assert: (mergeResult includes: Bag)! ! !AbstractMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test2 self mergeInterfaceTypes: (OrderedCollection with: Array) assignmentTypes: (OrderedCollection with: Collection). self assert: mergeResult size = 2. self assert: (mergeResult includes: Array). self assert: (mergeResult includes: Collection)! ! !AbstractMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test3 self mergeInterfaceTypes: OrderedCollection new assignmentTypes: OrderedCollection new. self assert: mergeResult size = 1. self assert: mergeResult first = Object! ! !AbstractMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test4 self mergeInterfaceTypes: (OrderedCollection with: Object) assignmentTypes: OrderedCollection new. self assert: mergeResult size = 1. self assert: mergeResult first = Object! ! !AbstractMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test5 self mergeInterfaceTypes: OrderedCollection new assignmentTypes: (OrderedCollection with: Object). self assert: mergeResult size = 1. self assert: mergeResult first = Object! ! !AbstractMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test6 "Dictionary and Array are in unrelated hierarchies -> keep both" self mergeInterfaceTypes: (OrderedCollection with: Dictionary) assignmentTypes: (OrderedCollection with: Array). self assert: mergeResult size = 2. self assert: (mergeResult includes: Dictionary). self assert: (mergeResult includes: Array)! ! !AbstractMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test7 self mergeInterfaceTypes: OrderedCollection new assignmentTypes: (OrderedCollection with: Array). self assert: mergeResult size = 1. self assert: (mergeResult includes: Array)! ! !AbstractMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test8 "Dictionary and Array are in unrelated hierarchies -> keep both" self mergeInterfaceTypes: (OrderedCollection with: Dictionary) assignmentTypes: (OrderedCollection with: Array with: Object). self assert: mergeResult size = 3. self assert: (mergeResult includes: Dictionary). self assert: (mergeResult includes: Array). self assert: (mergeResult includes: Object)! ! TypeMergerTestsRoot subclass: #AssignmentsFirstMergerTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Tests'! !AssignmentsFirstMergerTests methodsFor: 'auxiliary' stamp: ' 26/5/07 15:11'! mergeClass ^AssignmentsFirstMerger! ! !AssignmentsFirstMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test1 self mergeInterfaceTypes: (OrderedCollection with: Collection) assignmentTypes: (OrderedCollection with: Array). self assert: mergeResult size = 1. self assert: mergeResult first = Array! ! !AssignmentsFirstMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test10 "Dictionary and Array are in unrelated hierarchies -> keep both." self mergeInterfaceTypes: (OrderedCollection with: Dictionary) assignmentTypes: (OrderedCollection with: Array with: Collection). self assert: mergeResult size = 2. self assert: (mergeResult includes: Array). self assert: (mergeResult includes: Collection)! ! !AssignmentsFirstMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test11 "Dictionary and Array are in unrelated hierarchies -> keep both." self mergeInterfaceTypes: (OrderedCollection with: Dictionary) assignmentTypes: (OrderedCollection with: Collection with: Array). self assert: mergeResult size = 2. self assert: (mergeResult includes: Array). self assert: (mergeResult includes: Collection)! ! !AssignmentsFirstMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test12 "Dictionary and Array are in unrelated hierarchies -> keep both. Collection bites the dust because it is superclass." self mergeInterfaceTypes: (OrderedCollection with: Collection) assignmentTypes: (OrderedCollection with: Dictionary with: Array). self assert: mergeResult size = 2. self assert: (mergeResult includes: Dictionary). self assert: (mergeResult includes: Array)! ! !AssignmentsFirstMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test13 "Dictionary and Array are in unrelated hierarchies -> keep both. Collection bites the dust because it is superclass." self mergeInterfaceTypes: (OrderedCollection with: Collection) assignmentTypes: (OrderedCollection with: Array with: Dictionary). self assert: mergeResult size = 2. self assert: (mergeResult includes: Array). self assert: (mergeResult includes: Dictionary)! ! !AssignmentsFirstMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test14 self mergeInterfaceTypes: (OrderedCollection with: SequenceableCollection with: Bag) assignmentTypes: (OrderedCollection with: Array). self assert: mergeResult size = 1. self assert: (mergeResult includes: Array)! ! !AssignmentsFirstMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test2 self mergeInterfaceTypes: (OrderedCollection with: Array) assignmentTypes: (OrderedCollection with: Collection). self assert: mergeResult size = 1. self assert: (mergeResult includes: Collection)! ! !AssignmentsFirstMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test3 self mergeInterfaceTypes: OrderedCollection new assignmentTypes: OrderedCollection new. self assert: mergeResult size = 1. self assert: mergeResult first = Object! ! !AssignmentsFirstMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test4 self mergeInterfaceTypes: (OrderedCollection with: Object) assignmentTypes: OrderedCollection new. self assert: mergeResult size = 1. self assert: mergeResult first = Object! ! !AssignmentsFirstMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test5 self mergeInterfaceTypes: OrderedCollection new assignmentTypes: (OrderedCollection with: Object). self assert: mergeResult size = 1. self assert: mergeResult first = Object! ! !AssignmentsFirstMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test6 "Dictionary and Array are in unrelated hierarchies -> keep both" self mergeInterfaceTypes: (OrderedCollection with: Dictionary) assignmentTypes: (OrderedCollection with: Array). self assert: mergeResult size = 2. self assert: (mergeResult includes: Dictionary). self assert: (mergeResult includes: Array)! ! !AssignmentsFirstMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test7 self mergeInterfaceTypes: OrderedCollection new assignmentTypes: (OrderedCollection with: Array). self assert: mergeResult size = 1. self assert: (mergeResult includes: Array)! ! !AssignmentsFirstMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test8 "Dictionary and Array are in unrelated hierarchies -> keep both" self mergeInterfaceTypes: (OrderedCollection with: Dictionary) assignmentTypes: (OrderedCollection with: Array with: Object). self assert: mergeResult size = 2. self assert: (mergeResult includes: Array). self assert: (mergeResult includes: Object)! ! TypeMergerTestsRoot subclass: #ConcreteMergerTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Tests'! !ConcreteMergerTests methodsFor: 'auxiliary' stamp: ' 26/5/07 15:11'! mergeClass ^ConcreteMerger! ! !ConcreteMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test1 "assignment type Array is subtype of interface type Collection -> folding keeps Array and loses Collection" self mergeInterfaceTypes: (OrderedCollection with: Collection) assignmentTypes: (OrderedCollection with: Array). self assert: mergeResult size = 1. self assert: mergeResult first = Array! ! !ConcreteMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test10 "Dictionary and Array are in unrelated hierarchies -> keep both." self mergeInterfaceTypes: (OrderedCollection with: Dictionary) assignmentTypes: (OrderedCollection with: Array with: Collection). self assert: mergeResult size = 3. self assert: (mergeResult includes: Dictionary). self assert: (mergeResult includes: Array). self assert: (mergeResult includes: Collection)! ! !ConcreteMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test11 "Dictionary and Array are in unrelated hierarchies -> keep both." self mergeInterfaceTypes: (OrderedCollection with: Dictionary) assignmentTypes: (OrderedCollection with: Collection with: Array). self assert: mergeResult size = 3. self assert: (mergeResult includes: Dictionary). self assert: (mergeResult includes: Array). self assert: (mergeResult includes: Collection)! ! !ConcreteMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test12 "Dictionary and Array are in unrelated hierarchies -> keep both. Collection bites the dust because it is superclass." self mergeInterfaceTypes: (OrderedCollection with: Collection) assignmentTypes: (OrderedCollection with: Dictionary with: Array). self assert: mergeResult size = 2. self assert: (mergeResult includes: Dictionary). self assert: (mergeResult includes: Array)! ! !ConcreteMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test13 "Dictionary and Array are in unrelated hierarchies -> keep both. Collection bites the dust because it is superclass." self mergeInterfaceTypes: (OrderedCollection with: Collection) assignmentTypes: (OrderedCollection with: Array with: Dictionary). self assert: mergeResult size = 2. self assert: (mergeResult includes: Dictionary). self assert: (mergeResult includes: Array)! ! !ConcreteMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test14 self mergeInterfaceTypes: (OrderedCollection with: SequenceableCollection with: Bag) assignmentTypes: (OrderedCollection with: Array). self assert: mergeResult size = 2. self assert: (mergeResult includes: Array). self assert: (mergeResult includes: Bag)! ! !ConcreteMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test2 "interface type Array is subclass of assignment type Collection -> folding keeps Array and loses Collection" self mergeInterfaceTypes: (OrderedCollection with: Array) assignmentTypes: (OrderedCollection with: Collection). self assert: mergeResult size = 2. self assert: (mergeResult includes: Array). self assert: (mergeResult includes: Collection)! ! !ConcreteMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test3 self mergeInterfaceTypes: OrderedCollection new assignmentTypes: OrderedCollection new. self assert: mergeResult size = 1. self assert: mergeResult first = Object! ! !ConcreteMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test4 self mergeInterfaceTypes: (OrderedCollection with: Object) assignmentTypes: OrderedCollection new. self assert: mergeResult size = 1. self assert: mergeResult first = Object! ! !ConcreteMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test5 self mergeInterfaceTypes: OrderedCollection new assignmentTypes: (OrderedCollection with: Object). self assert: mergeResult size = 1. self assert: mergeResult first = Object! ! !ConcreteMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test6 "Dictionary and Array are in unrelated hierarchies -> keep both" self mergeInterfaceTypes: (OrderedCollection with: Dictionary) assignmentTypes: (OrderedCollection with: Array). self assert: mergeResult size = 2. self assert: (mergeResult includes: Dictionary). self assert: (mergeResult includes: Array)! ! !ConcreteMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test7 self mergeInterfaceTypes: OrderedCollection new assignmentTypes: (OrderedCollection with: Array). self assert: mergeResult size = 1. self assert: (mergeResult includes: Array)! ! !ConcreteMergerTests methodsFor: 'folding tests' stamp: ' 26/5/07 15:11'! test8 "Dictionary and Array are in unrelated hierarchies -> keep both" self mergeInterfaceTypes: (OrderedCollection with: Dictionary) assignmentTypes: (OrderedCollection with: Array with: Object). self assert: mergeResult size = 3. self assert: (mergeResult includes: Dictionary). self assert: (mergeResult includes: Array). self assert: (mergeResult includes: Object)! ! !TypeMergerTestsRoot methodsFor: 'auxiliary' stamp: ' 26/5/07 15:11'! mergeClass ^self subclassResponsibility! ! !TypeMergerTestsRoot methodsFor: 'auxiliary' stamp: 'FredericPluquet 12/18/2009 17:31'! mergeInterfaceTypes: interfaceTypes assignmentTypes: assignmentTypes mergeResult := self mergeClass interfaceTypes: interfaceTypes assignmentTypes: assignmentTypes! ! TestCase subclass: #TypeCollectorTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Tests'! !TypeCollectorTests methodsFor: 'typing tests' stamp: 'PF 5/20/2009 16:30'! testPoint | types xTypes yTypes | types := TypeCollector typeInstvarsOfClass: Point. xTypes := types at: #x. self assert: ((xTypes is: Number) or: [xTypes is: Integer]). yTypes := types at: #y. self assert: ((yTypes is: Number) or: [yTypes is: Integer])! ! InstructionClient subclass: #InstvarInterfaceExtractor instanceVariableNames: 'stack copied initialStack method saveStacks input collector blockTraversal blockArgs' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! !InstvarInterfaceExtractor commentStamp: '' prior: 0! I am responsible for extracting the messages sent to an instance variable and the assignments done to an instance variable. I am supposed to work together with a TypeCollector. Instance Variables: collector description of collector copied description of copied initialStack description of initialStack input description of input method description of method saveStacks description of saveStacks stack <(OrderedCollection of: Object)> description of stack ! !InstvarInterfaceExtractor methodsFor: 'private' stamp: 'FredericPluquet 12/18/2009 17:31'! copied: list copied := list! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 29/5/07 18:39'! dupFirst stack add: stack last! ! !InstvarInterfaceExtractor methodsFor: 'extracting' stamp: 'PF 5/25/2009 16:53'! extractInterfacesFrom: m addTo: aTypeCollector method := m. saveStacks := Dictionary new. stack := OrderedCollection new. "0 to: method numTemps - 1 do: [:i | stack add: #temp -> i ]." initialStack := stack copy. collector := aTypeCollector. input := InstructionStream on: method. blockTraversal := false. blockArgs := 0. [input atEnd] whileFalse: [self reloadStack. input interpretNextInstructionFor: self]! ! !InstvarInterfaceExtractor methodsFor: 'private' stamp: 'PF 5/22/2009 11:53'! initialize super initialize. blockTraversal := false. blockArgs := 0.! ! !InstvarInterfaceExtractor methodsFor: 'private' stamp: ' 29/5/07 18:39'! input ^input! ! !InstvarInterfaceExtractor methodsFor: 'private' stamp: 'FredericPluquet 12/18/2009 17:31'! method: aMethod method := aMethod. copied := #()! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-control' stamp: 'PF 8/1/2009 11:51'! nativeSend: selector numArgs: na | receiver args | args := stack removeLast: na. receiver := stack removeLast. receiver isInteger ifTrue: [ collector addSend: selector to: receiver ] ifFalse: [ receiver isVariableBinding ifTrue: [ receiver key = #temp ifTrue: [ collector addSend: selector toTmp: receiver value ] ifFalse: [ receiver key = #return ifTrue: [ collector addSend: selector onReturnOfSelfMethod: receiver value ] ] ] ]. (receiver = #self and: [ collector theClass methodDict includesKey: selector ]) ifTrue: [ args doWithIndex: [ :arg :index | collector handleAssignment: arg forTmp: index - 1 in: collector theClass >> selector ] ]. stack add: (collector pushSendOf: selector to: receiver args: args)! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 29/5/07 18:39'! pop stack removeLast! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: 'PF 5/22/2009 11:52'! pushConstant: value value class == BlockClosure ifTrue: [self readBlock: value method copied: 0] ifFalse: [ blockArgs := value. stack addLast: value class]! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 29/5/07 18:39'! pushContext stack add: #context! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 29/5/07 18:39'! pushInst: index stack add: index! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 29/5/07 18:39'! pushReceiver stack addLast: #self! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 29/5/07 18:39'! pushStatic: assoc "assoc can be an association OR a variable binding. I just push the complete association, since it does not interest me for the moment." stack addLast: assoc! ! !InstvarInterfaceExtractor methodsFor: 'private' stamp: 'PF 5/22/2009 11:49'! readBlock: block copied: count | newCopied | newCopied := stack removeLast: count. stack add: #block. ^(self class new) copied: newCopied; extractInterfacesFrom: block addTo: collector! ! !InstvarInterfaceExtractor methodsFor: 'private' stamp: 'FredericPluquet 12/18/2009 17:31'! reloadStack stack isNil ifTrue: [stack := self saveStacks at: self input pc ifAbsent: [initialStack copy]. ^self]. stack := self saveStacks at: self input pc ifAbsent: [stack]! ! !InstvarInterfaceExtractor methodsFor: 'private' stamp: 'FredericPluquet 12/18/2009 17:31'! saveStacks saveStacks ifNil: [saveStacks := Dictionary new]. ^saveStacks! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-control' stamp: 'PF 8/1/2009 11:50'! send: selector numArgs: na ^self nativeSend: selector numArgs: na! ! InstvarInterfaceExtractor subclass: #SqueakInstvarInterfaceExtractor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Squeak'! SqueakInstvarInterfaceExtractor subclass: #PharoInstvarInterfaceExtractor instanceVariableNames: 'blockTempsMapping blocksLimits' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Pharo'! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'PF 7/30/2009 18:23'! blockMapping ^blockTempsMapping last! ! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'FredericPluquet 8/18/2010 22:27'! blockReturnTop "Return Top Of Stack bytecode." "self removeBlockMapping." ^self pop! ! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'FredericPluquet 8/18/2010 22:28'! blocksArgsBySize ^blocksLimits ifNil: [blocksLimits := OrderedCollection new]! ! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'FredericPluquet 8/18/2010 22:29'! blocksDecrement blocksLimits := blocksLimits select: [:e | (e = input pc) ifTrue: [self removeBlockMapping. false] ifFalse: [true] ] ! ! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'FredericPluquet 8/18/2010 22:28'! extractInterfacesFrom: m addTo: aTypeCollector method := m. saveStacks := Dictionary new. stack := OrderedCollection new. "0 to: method numTemps - 1 do: [:i | stack add: #temp -> i ]." initialStack := stack copy. collector := aTypeCollector. input := InstructionStream on: method. blockTraversal := false. blocksLimits := OrderedCollection new. blockTempsMapping := OrderedCollection new. blockArgs := 0. [input atEnd] whileFalse: [self reloadStack. input interpretNextInstructionFor: self. self blocksDecrement. ]! ! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'PF 7/30/2009 18:26'! inABlock ^blockTempsMapping isEmpty not! ! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'PF 7/30/2009 18:17'! initialize super initialize. blockTempsMapping := OrderedCollection new.! ! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'FredericPluquet 8/18/2010 22:08'! methodReturnTop ^self pop! ! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'PF 7/30/2009 18:18'! newBlockMapping blockTempsMapping add: OrderedCollection new. ! ! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'FredericPluquet 9/7/2009 10:11'! popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex "Remove Top Of Stack And Store Into Offset of Temp Vector bytecode." stack removeLast "collector handleAssignment: stack removeLast forTmp: (self blockMapping at: remoteTempIndex ) value "! ! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'PF 8/1/2009 11:43'! popIntoTemporaryVariable: offset "Remove Top Of Stack And Store Into Temporary Variable bytecode." "An empty stack => we are in a block" self inABlock ifFalse: [ collector handleAssignment: stack removeLast forTmp: offset] ifTrue: [ ]! ! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'FredericPluquet 8/18/2010 21:56'! pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize self newBlockMapping. self blocksArgsBySize add: blockSize + input pc - 1. 1 to: numArgs do: [:index | self blockMapping add: #blockArg->index.]. numCopied timesRepeat: [ self blockMapping add: stack removeLast afterIndex: numArgs]. stack addLast: #block. blockArgs := numArgs. ! ! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'FredericPluquet 9/7/2009 10:13'! pushConsArrayWithElements: anArray stack add: #instcreation->Array! ! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'PF 7/30/2009 20:31'! pushNewArrayOfSize: numElements "Push New Array of size numElements bytecode." stack addLast: #computed ! ! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'PF 7/30/2009 14:51'! pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex stack addLast: #computed! ! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'PF 7/30/2009 18:58'! pushTemporaryVariable: offset "Push Contents Of Temporary Variable Whose Index Is the argument, offset, On Top Of Stack bytecode." self inABlock ifTrue: [stack add: (self blockMapping at: offset + 1 ifAbsent: [#blockTemp -> (offset - self blockMapping size)])] ifFalse: [stack add: #temp -> offset]! ! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'PF 7/30/2009 18:18'! removeBlockMapping blockTempsMapping removeLast! ! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'FredericPluquet 8/18/2010 22:05'! send: selector numArgs: na "selector = #shapeBoundsAt:ifPresent: ifTrue: [self halt]". ^self nativeSend: selector numArgs: na ! ! !PharoInstvarInterfaceExtractor methodsFor: 'as yet unclassified' stamp: 'PF 8/1/2009 11:47'! storeIntoTemporaryVariable: offset "Store Top Of Stack Into Temporary Variable Of Method bytecode." "Nothing to do,since I do not treat temporary variables for the moment." | rvalue | collector handleAssignment: (rvalue := stack removeLast) forTmp: offset. stack add: rvalue! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 26/5/07 15:11'! blockReturnTop "Return Top Of Stack bytecode." ^self pop! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 26/5/07 15:11'! doDup "Duplicate Top Of Stack bytecode." self dupFirst! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 26/5/07 15:11'! doPop "Remove Top Of Stack bytecode." ^self pop! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: 'PF 5/25/2009 16:47'! jump: delta | currentPC | currentPC := self input pc. delta < 1 ifTrue: [^self]. self saveStacks at: currentPC + delta put: stack copy. stack := OrderedCollection new. ! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: 'PF 5/28/2009 10:02'! jump: delta if: condition |top| (top := stack last) isInteger ifTrue: [ collector addAssignment: Boolean to: top. ] ifFalse: [ (top isVariableBinding and: [top key = #temp]) ifTrue: [collector addAssignment: Boolean toTmp: top value] ifFalse: [ (top isVariableBinding and: [top key = #return]) ifTrue: [collector addAssignment: Boolean toReturnOf: top value] ] ]. self pop. "receiver of ifTrue or ifFalse, according to condition" delta < 1 ifTrue: [^self]. self saveStacks at: self input pc + delta put: (stack copy)! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: 'PF 5/19/2009 15:29'! methodReturnConstant: value "Return Constant bytecode." collector addAssignmentForReturn: value class. ^self pushConstant: value; sqReturnTop! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: 'PF 5/19/2009 15:33'! methodReturnReceiver "Return Self bytecode." collector addAssignmentForReturnSelf. ^self pushReceiver; sqReturnTop! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: 'PF 5/19/2009 15:37'! methodReturnTop "Return Top Of Stack bytecode." collector addAssignmentForReturn: stack last. ^self sqReturnTop! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 26/5/07 15:11'! popIntoLiteralVariable: anAssociation "Remove Top Of Stack And Store Into Literal Variable bytecode." ^self pop! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 26/5/07 15:11'! popIntoReceiverVariable: offset "Remove Top Of Stack And Store Into Instance Variable bytecode." collector handleAssignment: stack removeLast for: offset! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: 'PF 8/1/2009 11:43'! popIntoTemporaryVariable: offset "Remove Top Of Stack And Store Into Temporary Variable bytecode." "An empty stack => we are in a block" blockTraversal ifTrue: [blockArgs > 0 ifTrue: [stack addLast: #temp -> offset. collector transformAsBlockArgTheTmpOffset: offset]. blockArgs := blockArgs - 1. blockTraversal := (blockArgs > 0) ]. collector handleAssignment: stack removeLast forTmp: offset! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 26/5/07 15:11'! pushActiveContext "Push Active Context On Top Of Its Own Stack bytecode." self pushContext! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 26/5/07 15:11'! pushLiteralVariable: anAssociation "Push Contents Of anAssociation On Top Of Stack bytecode." self pushStatic: anAssociation! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 26/5/07 15:11'! pushReceiverVariable: offset "Push Contents Of the Receiver's Instance Variable Whose Index is the argument, offset, On Top Of Stack bytecode." self pushInst: offset! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: 'PF 5/19/2009 13:16'! pushTemporaryVariable: offset "Push Contents Of Temporary Variable Whose Index Is the argument, offset, On Top Of Stack bytecode." stack add: (#temp -> offset)! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: 'FredericPluquet 8/18/2010 22:04'! send: selector numArgs: na self nativeSend: selector numArgs: na. (stack last = #block and: [blockArgs > 0])ifTrue: [blockTraversal := true]! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 26/5/07 15:11'! send: selector super: supered numArgs: numberArguments "Send Message With Selector, selector, bytecode. The argument, supered, indicates whether the receiver of the message is specified with 'super' in the source method. The arguments of the message are found in the top numArguments locations on the stack and the receiver just below them." ^supered ifTrue: [self sendSuper: selector numArgs: numberArguments] ifFalse: [self send: selector numArgs: numberArguments]! ! !SqueakInstvarInterfaceExtractor methodsFor: 'opcodes-control' stamp: ' 26/5/07 15:11'! sendSuper: selector numArgs: na stack removeLast: na + 1. stack add: #computed! ! !SqueakInstvarInterfaceExtractor methodsFor: 'private' stamp: ' 26/5/07 15:11'! sqReturnTop "In VW, method returnTop is inherited from instructionClient and does nothing." ! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 26/5/07 15:11'! storeIntoLiteralVariable: anAssociation "Store Top Of Stack Into Literal Variable Of Method bytecode." "Nothing to do, since I do not do anything with literal variables. Just keep the right-hand side on the stack for further processing" ! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: 'FredericPluquet 12/18/2009 17:31'! storeIntoReceiverVariable: offset "Store Top Of Stack Into Instance Variable Of Method bytecode." | rvalue | collector handleAssignment: (rvalue := stack removeLast) for: offset. stack add: rvalue! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: 'PF 5/25/2009 18:23'! storeIntoTemporaryVariable: offset "Store Top Of Stack Into Temporary Variable Of Method bytecode." "Nothing to do,since I do not treat temporary variables for the moment." | rvalue | blockTraversal ifTrue: [blockArgs > 0 ifTrue: [stack addLast: #temp -> offset. collector transformAsBlockArgTheTmpOffset: offset]. blockArgs := blockArgs - 1. blockTraversal := (blockArgs > 0) ]. collector handleAssignment: (rvalue := stack removeLast) forTmp: offset. stack add: rvalue! ! !Behavior methodsFor: '*RoelTyper-enumerating' stamp: ' 29/5/07 18:39'! nonMetaSubclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's immediate non-meta subclasses." self subclasses do: aBlock! ! !Class methodsFor: '*RoelTyper-enumerating' stamp: ' 29/5/07 18:39'! nonMetaSubclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's immediate non-meta subclasses." "This one is here for the sake of Squeak (where it is Class and not Behavior that keeps the subclasses instance variable)." subclasses == nil ifFalse: [subclasses do: aBlock]! ! !OrderedCollection methodsFor: '*RoelTyper' stamp: 'PF 5/26/2009 13:22'! unsafeRemoveFirst "Remove the first element of the receiver and answer it. If the receiver is empty, create an error notification." | firstObject | firstObject := array at: firstIndex. array at: firstIndex put: nil. firstIndex := firstIndex + 1. ^ firstObject! ! Object subclass: #ASampleClass instanceVariableNames: 'a b c d e f g' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Tests'! !ASampleClass methodsFor: 'assignments links' stamp: 'PF 7/30/2009 19:19'! a a := 5! ! !ASampleClass methodsFor: 'assignments links' stamp: 'PF 7/30/2009 19:19'! b b := a! ! !ASampleClass methodsFor: 'blocks typing' stamp: 'FredericPluquet 8/18/2010 20:49'! blockReturn: arg "(TypeCollector typeTmpsIn: (self>>#blockReturn:) ofClass: self) " self byParam: [:bu | ^bu]. g := arg. ! ! !ASampleClass methodsFor: 'blocks typing' stamp: 'PF 8/1/2009 11:40'! blockTyping "(TypeCollector typeTmpsIn: (self>>#blockTyping) ofClass: self) " |t3 t t2| [:s | t2 + 1. t - 1.1] value: 5. ! ! !ASampleClass methodsFor: 'parameters links' stamp: 'PF 7/30/2009 19:25'! byParam e := 6. self byParam: e! ! !ASampleClass methodsFor: 'parameters links' stamp: 'PF 7/30/2009 19:25'! byParam: aTmp d := aTmp! ! !ASampleClass methodsFor: 'assignments links' stamp: 'PF 7/30/2009 19:19'! c c := b! ! !ASampleClass methodsFor: 'return links' stamp: 'PF 7/30/2009 19:32'! return "(TypeCollector typeTmpsIn: (self>>#return) ofClass: self)" ^5! ! !ASampleClass methodsFor: 'temporaries typing' stamp: 'PF 7/30/2009 19:33'! tmpTyping "(TypeCollector typeTmpsIn: (self>>#tmpTyping) ofClass: self) " |tmp1 tmp2| tmp1 := 1. tmp2 := tmp1.! ! !ASampleClass methodsFor: 'return links' stamp: 'PF 8/1/2009 11:38'! useReturn "(TypeCollector typeInstvar: #f ofClass: self) types" ^f := self return.! ! Object subclass: #AbstractType instanceVariableNames: 'ivarClass ivarName tag nbOfCorrectTypes nbOfIncorrectTypes' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! !AbstractType class methodsFor: 'instance creation' stamp: ' 29/5/07 18:39'! forInstvar: iv inClass: aClass ^(self basicNew initialize) ivarName: iv; ivarClass: aClass; yourself! ! !AbstractType class methodsFor: 'instance creation' stamp: ' 29/5/07 18:39'! new ^self shouldNotImplement! ! !AbstractType methodsFor: 'private' stamp: 'FredericPluquet 12/18/2009 17:31'! conflictingAssignmentsWith: anExtractedType | conflictingAssignments | conflictingAssignments := anExtractedType assignments select: [:assignment | (self types includes: assignment) not]. ^conflictingAssignments! ! !AbstractType methodsFor: 'private' stamp: 'FredericPluquet 12/18/2009 17:31'! conflictingSelectorsWith: anExtractedType | conflictingSelectors | conflictingSelectors := Dictionary new. anExtractedType interface do: [:selector | self types do: [:aType | (aType canUnderstand: selector) ifFalse: [(conflictingSelectors at: selector ifAbsentPut: [OrderedCollection new]) add: aType]]]. ^conflictingSelectors! ! !AbstractType methodsFor: 'initialize-release' stamp: ' 29/5/07 18:39'! initialize "Do nothing, but give subclasses the chance to override." ! ! !AbstractType methodsFor: 'testing' stamp: ' 29/5/07 18:39'! is: aClass ^self isSingularType and: [self types first = aClass]! ! !AbstractType methodsFor: 'testing' stamp: ' 29/5/07 18:39'! isExtractedResult ^self subclassResponsibility! ! !AbstractType methodsFor: 'testing' stamp: ' 29/5/07 18:39'! isObjectType ^self isSingularType and: [self types includes: Object]! ! !AbstractType methodsFor: 'testing' stamp: ' 29/5/07 18:39'! isSingularType ^self types size = 1! ! !AbstractType methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! ivarClass ^ivarClass! ! !AbstractType methodsFor: 'accessing' stamp: 'PF 5/19/2009 18:08'! ivarClass: aClass ivarClass := aClass. "self triggerEvent: #changed"! ! !AbstractType methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! ivarName ^ivarName! ! !AbstractType methodsFor: 'accessing' stamp: 'PF 5/19/2009 18:09'! ivarName: aSymbol ivarName := aSymbol. "self triggerEvent: #changed"! ! !AbstractType methodsFor: 'private' stamp: 'PF 5/25/2009 20:39'! liveExtractType ^self! ! !AbstractType methodsFor: 'printing' stamp: ' 29/5/07 18:39'! printOn: aStream self printTypesOn: aStream! ! !AbstractType methodsFor: 'printing' stamp: ' 29/5/07 18:39'! printTypesOn: aStream self types do: [:each | aStream print: each] separatedBy: [aStream nextPutAll: ' , ']! ! !AbstractType methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! types ^self subclassResponsibility! ! AbstractType subclass: #ExtractedType instanceVariableNames: 'interface assignments extractedTypes links' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! !ExtractedType class methodsFor: 'instance creation' stamp: ' 29/5/07 18:39'! forInstvar: iv inClass: aClass interface: selectorCollection assignments: classCollection ^(self forInstvar: iv inClass: aClass) interface: selectorCollection assignments: classCollection! ! !ExtractedType class methodsFor: 'private' stamp: 'FredericPluquet 9/7/2009 10:56'! mergerClass "Still experimenting with different mergers. So for the moment I uncomment things to experiment with." "^ConcreteMerger" "^AbstractMerger" ^AssignmentsFirstMerger! ! !ExtractedType methodsFor: 'private-accessing' stamp: ' 29/5/07 18:39'! addAssignment: anObject (self assignments includes: anObject) ifFalse: [self assignments add: anObject]! ! !ExtractedType methodsFor: 'private-accessing' stamp: 'PF 5/25/2009 20:40'! addLinkedExtractedType: anExtractedType links add: anExtractedType liveExtractType! ! !ExtractedType methodsFor: 'private-accessing' stamp: 'PF 5/25/2009 20:40'! addReverseLinkedExtractedType: anExtractedType links add: anExtractedType liveExtractType. anExtractedType liveExtractType addLinkedExtractedType: self! ! !ExtractedType methodsFor: 'private-accessing' stamp: ' 29/5/07 18:39'! addSend: anObject self interface add: anObject! ! !ExtractedType methodsFor: 'private-accessing' stamp: ' 29/5/07 18:39'! assignments ^assignments! ! !ExtractedType methodsFor: 'private-accessing' stamp: ' 29/5/07 18:39'! basicExtractedTypes ^extractedTypes! ! !ExtractedType methodsFor: 'private' stamp: 'PF 3/19/2009 13:26'! cleanedAssignments | assigns | assigns := self assignments copy. ((assigns includes: True) or: [assigns includes: False]) ifTrue: [assigns remove: True ifAbsent: []; remove: False ifAbsent: []; add: Boolean]. ^assigns! ! !ExtractedType methodsFor: 'RoelTyperValidation' stamp: 'PF 3/6/2009 09:47'! contents ^self types! ! !ExtractedType methodsFor: 'private' stamp: 'PF 5/29/2009 13:27'! flattenLinks [links isEmpty] whileFalse: [|link| link := links anyOne. links remove: link. link flattenLinks. link interface do: [:sel | self addSend: sel]. link assignments do: [:assign | self addAssignment: assign]]. ! ! !ExtractedType methodsFor: 'private' stamp: 'MarianoMartinezPeck 7/2/2010 15:08'! foldInterfaceTypes: interfaceClasses withAssignmentTypes: assignmentClasses | tmp | " ^interfaceClasses asOrderedCollection" "Only interface types" " ^assignmentClasses " "Only assignment types" assignmentClasses remove: UndefinedObject ifAbsent: []. tmp:=interfaceClasses. (assignmentClasses size=0 and: [ ((interface includes: #value) or: [interface includes: #value:]) and: [interfaceClasses includes: BlockContext]]) ifTrue: [tmp:=OrderedCollection with: BlockContext] ifFalse: [tmp:=interfaceClasses]. ^self class mergerClass interfaceTypes: tmp assignmentTypes: assignmentClasses! ! !ExtractedType methodsFor: 'testing' stamp: ' 29/5/07 18:39'! hasEmptyAssignments ^self assignments isEmpty! ! !ExtractedType methodsFor: 'testing' stamp: ' 29/5/07 18:39'! hasEmptyInterface ^self interface isEmpty! ! !ExtractedType methodsFor: 'initialize-release' stamp: 'PF 5/29/2009 13:27'! initialize super initialize. links := Set new. self interface: IdentitySet new assignments: OrderedCollection new.! ! !ExtractedType methodsFor: 'private-accessing' stamp: ' 29/5/07 18:39'! interface ^interface! ! !ExtractedType methodsFor: 'private-accessing' stamp: 'FredericPluquet 12/18/2009 17:31'! interface: selectorCollection assignments: classCollection interface := selectorCollection. assignments := classCollection! ! !ExtractedType methodsFor: 'testing' stamp: ' 29/5/07 18:39'! isEmpty ^self hasEmptyAssignments and: [self hasEmptyInterface]! ! !ExtractedType methodsFor: 'testing' stamp: ' 29/5/07 18:39'! isExtractedResult ^true! ! !ExtractedType methodsFor: 'private-accessing' stamp: 'PF 5/25/2009 18:03'! links ^links! ! !ExtractedType methodsFor: 'private' stamp: 'PF 5/19/2009 14:03'! mergeTypes self flattenLinks. ^self foldInterfaceTypes: (self rootsUnderstanding: self interface) withAssignmentTypes: self cleanedAssignments! ! !ExtractedType methodsFor: 'printing' stamp: 'PF 7/30/2009 19:12'! printInterfaceAndAssigments |s| s := WriteStream on: (String new). self printInterfaceAndAssigmentsOn: s. ^ s contents! ! !ExtractedType methodsFor: 'printing' stamp: ' 29/5/07 18:39'! printInterfaceAndAssigmentsOn: aStream aStream nextPutAll: 'Sends: {'. self interface do: [:symbol | aStream print: symbol] separatedBy: [aStream space]. aStream nextPutAll: '}'; cr; nextPutAll: 'Assignments: {'. self assignments do: [:symbol | aStream print: symbol] separatedBy: [aStream space]. aStream nextPutAll: '}'; cr! ! !ExtractedType methodsFor: 'printing' stamp: ' 29/5/07 18:39'! printOn: aStream aStream nextPutAll: 'ExtractedType: '. self basicExtractedTypes ifNil: [self printInterfaceAndAssigmentsOn: aStream] ifNotNil: [self printTypesOn: aStream]! ! !ExtractedType methodsFor: 'private' stamp: 'PF 5/26/2009 15:51'! rootsUnderstanding: selectors "When the set of selectors is not empty, answer a set of the highest possible classes in the system that implement all the selectors. When the set of selectors is empty, return the empty set." | initialClasses nextClasses traverseStack next | selectors isEmpty ifTrue: [^OrderedCollection new]. nextClasses := OrderedCollection with: Object. traverseStack := OrderedCollection new: 10000. selectors do: [:selector | initialClasses := nextClasses. nextClasses := OrderedCollection new. initialClasses do: [:initialClass | "inline canUnderstand: for performance" |cl| cl := initialClass. [(cl == nil) or: [(cl methodDict pointsTo: selector)]] whileFalse: [cl := cl superclass]. (cl == nil) ifFalse: [nextClasses addLast: initialClass] ifTrue: [|size| traverseStack reset. traverseStack addLast: initialClass. size := 1. "(traverseStack isEmpty) removed for performance" [size = 0] whileFalse: [ "(traverseStack removeFirst) removed for performance" next := traverseStack unsafeRemoveFirst. size := size -1. next subclassesDo: [:subcl | "(subcl includesSelector: selector) removed for performance" (subcl methodDict pointsTo: selector) ifTrue: [nextClasses addLast: subcl] ifFalse: [traverseStack addLast: subcl. size := size + 1]]]]]]. ^nextClasses! ! !ExtractedType methodsFor: 'accessing' stamp: 'FredericPluquet 12/18/2009 17:31'! types ^extractedTypes ifNil: [extractedTypes := self mergeTypes] ifNotNil: [extractedTypes]! ! ExtractedType subclass: #ExtractedTypeForTmp instanceVariableNames: 'compiledMethod' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! !ExtractedTypeForTmp class methodsFor: 'as yet unclassified' stamp: 'PF 5/24/2009 11:12'! forTmpOffset: offset ofCompiledMethod: aCompiledMethod inClass: aClass ^(self basicNew initialize) tempOffset: offset; ivarClass: aClass; compiledMethod: aCompiledMethod; yourself! ! !ExtractedTypeForTmp class methodsFor: 'as yet unclassified' stamp: 'PF 5/25/2009 18:24'! new ^self basicNew initialize! ! !ExtractedTypeForTmp methodsFor: 'accessing' stamp: 'PF 5/25/2009 18:13'! asBlockArgInTypeCollector: aTypeCollector aTypeCollector transformAsBlockArg: self ! ! !ExtractedTypeForTmp methodsFor: 'accessing' stamp: 'PF 5/24/2009 11:07'! compiledMethod ^ compiledMethod! ! !ExtractedTypeForTmp methodsFor: 'accessing' stamp: 'PF 5/24/2009 11:07'! compiledMethod: anObject compiledMethod := anObject! ! !ExtractedTypeForTmp methodsFor: 'accessing' stamp: 'PF 5/25/2009 18:15'! tempOffset ^ivarName "self triggerEvent: #changed"! ! !ExtractedTypeForTmp methodsFor: 'accessing' stamp: 'PF 5/24/2009 11:09'! tempOffset: anOffset ivarName := anOffset. "self triggerEvent: #changed"! ! AbstractType subclass: #ExtractedTypeForBlockArg instanceVariableNames: 'lives compiledMethod' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! !ExtractedTypeForBlockArg class methodsFor: 'as yet unclassified' stamp: 'PF 5/25/2009 18:17'! forOffset: offset ofCompiledMethod: aCompiledMethod inClass: aClass ^(self basicNew initialize) tempOffset: offset; ivarClass: aClass; compiledMethod: aCompiledMethod; yourself! ! !ExtractedTypeForBlockArg methodsFor: 'as yet unclassified' stamp: 'PF 5/25/2009 18:20'! asBlockArgInTypeCollector: aTypeCollector self newLive! ! !ExtractedTypeForBlockArg methodsFor: 'as yet unclassified' stamp: 'PF 5/25/2009 18:18'! compiledMethod: aCompiledMethod compiledMethod := aCompiledMethod! ! !ExtractedTypeForBlockArg methodsFor: 'as yet unclassified' stamp: 'PF 5/25/2009 18:05'! doesNotUnderstand: aMessage ^aMessage sendTo: self liveExtractType ! ! !ExtractedTypeForBlockArg methodsFor: 'as yet unclassified' stamp: 'PF 5/25/2009 18:20'! initialize super initialize. lives := OrderedCollection with: (ExtractedTypeForTmp new)! ! !ExtractedTypeForBlockArg methodsFor: 'as yet unclassified' stamp: 'PF 5/25/2009 18:30'! interface ^(lives inject: Set new into: [:ord :et | ord addAll: (et interface); yourself ]) asOrderedCollection! ! !ExtractedTypeForBlockArg methodsFor: 'as yet unclassified' stamp: 'PF 5/25/2009 18:01'! liveExtractType ^lives last! ! !ExtractedTypeForBlockArg methodsFor: 'as yet unclassified' stamp: 'PF 5/25/2009 18:02'! newLive ^lives addLast: (ExtractedTypeForTmp new)! ! !ExtractedTypeForBlockArg methodsFor: 'as yet unclassified' stamp: 'PF 5/27/2009 22:30'! printOn: aStream aStream nextPutAll: 'Block arg'; cr;cr. lives doWithIndex: [:et :index| aStream nextPutAll: 'Activation ', index printString, ': '. et printOn: aStream. aStream cr] ! ! !ExtractedTypeForBlockArg methodsFor: 'as yet unclassified' stamp: 'PF 5/25/2009 18:17'! tempOffset: anOffset ivarName := anOffset. "self triggerEvent: #changed"! ! !ExtractedTypeForBlockArg methodsFor: 'as yet unclassified' stamp: 'PF 5/26/2009 15:17'! types |types| types := IdentitySet new. lives do: [:et | types addAll: (et mergeTypes)]. ^types asOrderedCollection! ! Object subclass: #CommonCollection instanceVariableNames: 'collection' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! !CommonCollection class methodsFor: 'as yet unclassified' stamp: 'PF 5/29/2009 11:21'! on: aCollection ^self new collection: aCollection; yourself! ! !CommonCollection methodsFor: 'accessing' stamp: 'PF 5/29/2009 11:09'! collection ^ collection! ! !CommonCollection methodsFor: 'accessing' stamp: 'PF 5/29/2009 11:09'! collection: anObject collection := anObject! ! !CommonCollection methodsFor: 'as yet unclassified' stamp: 'PF 5/29/2009 11:49'! do: aBlock ^collection copy do: aBlock! ! !CommonCollection methodsFor: 'as yet unclassified' stamp: 'PF 5/29/2009 11:48'! doesNotUnderstand: aMessage ^aMessage sendTo: collection! ! !CommonCollection methodsFor: 'as yet unclassified' stamp: 'PF 5/29/2009 11:20'! fusionWith: aCollection collection addAll: aCollection. ^self! ! !CommonCollection methodsFor: 'as yet unclassified' stamp: 'PF 5/29/2009 11:24'! fusionWithCollection: aCollection ^self fusionWith: aCollection! ! !CommonCollection methodsFor: 'as yet unclassified' stamp: 'PF 5/29/2009 11:28'! size ^collection size! ! Object subclass: #TypeCollector instanceVariableNames: 'theClass instVars typingResults currentExtractedMethod localTypingResults' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! !TypeCollector commentStamp: '' prior: 0! I collect and assemble the types sent to instance variables for a certain class (I use the InterfaceExtractor for that), And use them to create and return TypingResults. Instance Variables: assignments description of assignments instVarOffset description of instVarOffset instVars <(Palette of: (ExceptionSet | GenericException | SequenceableCollection | Signal)) | (SequenceableCollection of: (ExceptionSet | GenericException | SequenceableCollection | Signal))> description of instVars sends description of sends theClass description of theClass ! TypeCollector subclass: #SqueakTypeCollector instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Squeak'! SqueakTypeCollector subclass: #PharoTypeCollector instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Pharo'! !PharoTypeCollector methodsFor: 'as yet unclassified' stamp: 'PF 7/30/2009 14:12'! langueSpecificPushSendOf: selector to: rec args: args (#(#// #quo: #rem: #\\ #ceiling #floor #rounded #roundTo: #truncated #truncateTo: #/ #+ #- #* #abs #negated #reciprocal) includes: selector) ifTrue: [^self tryUsing: rec for: selector ifNotUse: Number]. (selector = #yourself) ifTrue: [^rec]. (rec = #self and: [(theClass methodDict includesKey: selector)]) ifTrue: [^#return->selector]. ^#computed! ! !PharoTypeCollector methodsFor: 'as yet unclassified' stamp: 'PF 7/30/2009 14:12'! newExtractor ^PharoInstvarInterfaceExtractor new! ! !SqueakTypeCollector methodsFor: 'heuristics' stamp: ' 26/5/07 15:11'! assignmentTypeOf: val val isBehavior ifTrue: [^val]. val isVariableBinding ifTrue: [val key == #instcreation ifTrue: [^val value] ifFalse: [^val value class]]. ^nil! ! !SqueakTypeCollector methodsFor: 'heuristics' stamp: 'PF 5/25/2009 17:49'! langueSpecificPushSendOf: selector to: rec args: args selector == #blockCopy: ifTrue: [^#block]. (#(#// #quo: #rem: #\\ #ceiling #floor #rounded #roundTo: #truncated #truncateTo: #/ #+ #- #* #abs #negated #reciprocal) includes: selector) ifTrue: [^self tryUsing: rec for: selector ifNotUse: Number]. (selector = #yourself) ifTrue: [^rec]. (rec = #self and: [(theClass methodDict includesKey: selector)]) ifTrue: [^#return->selector]. ^#computed! ! !SqueakTypeCollector methodsFor: 'private' stamp: ' 26/5/07 15:11'! newExtractor ^SqueakInstvarInterfaceExtractor new! ! !TypeCollector class methodsFor: 'instance creation' stamp: 'PF 5/19/2009 13:12'! collectorAfterTypeInstvarsOfClass: aClass "self typeInstvarsOfClass: Point" ^self new typeInstvarsOfClass: aClass; yourself! ! !TypeCollector class methodsFor: 'instance creation' stamp: ' 29/5/07 18:39'! new "Override new to return either a VWTypeCollector or a SqueakTypeCollector" ^self newForPlatform! ! !TypeCollector class methodsFor: 'instance creation' stamp: 'PF 8/1/2009 12:12'! newForPlatform "Return either a VWTypeCollector or a SqueakTypeCollector, depending on the platform used." ^PharoTypeCollector basicNew! ! !TypeCollector class methodsFor: 'instance creation' stamp: ' 29/5/07 18:39'! onClass: aClass ^self new onClass: aClass! ! !TypeCollector class methodsFor: 'instance creation' stamp: ' 29/5/07 18:39'! typeInstvar: var ofClass: aClass "self typeInstvar: #x ofClass: Point " ^(self new typeInstvarsOfClass: aClass) at: var! ! !TypeCollector class methodsFor: 'instance creation' stamp: 'PF 7/30/2009 14:08'! typeInstvar: var ofClassWithLookup: aClass "self typeInstvar: #origin ofClassWithLookup: Quadrangle" | theClass | theClass := aClass. [theClass isNil not and: [theClass instVarNames includes: var]] whileFalse: [theClass := theClass superclass]. theClass isNil ifTrue: [^ ExtractedType new]. ^ self typeInstvar: var ofClass: theClass! ! !TypeCollector class methodsFor: 'instance creation' stamp: ' 29/5/07 18:39'! typeInstvarsOfClass: aClass "self typeInstvarsOfClass: Point" ^self new typeInstvarsOfClass: aClass! ! !TypeCollector class methodsFor: 'instance creation' stamp: 'PF 5/27/2009 18:05'! typeTmpsIn: aCompiledMethod ofClass: aClass "self typeInstvarsOfClass: Point" ^self new typeTmpsIn: aCompiledMethod ofClass: aClass! ! !TypeCollector class methodsFor: 'instance creation' stamp: ' 29/5/07 18:39'! versionString "Take the removal of the standard version method on Smalltalk into account for Squeak :-( " ^(Smalltalk at: #SystemVersion ifAbsent: [^Smalltalk version]) current version! ! !TypeCollector methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! absoluteIndexForVar: iVar "Note: works for Squeak and VisualWorks. If it would be only for VW, you could just use instVarIndexFor: instead." ^instVars indexOf: iVar! ! !TypeCollector methodsFor: 'adding' stamp: 'PF 3/19/2009 13:06'! addAssignment: value to: index self withTranslatedIndex: index do: [:i | (self typingResults at: i) addAssignment: value]! ! !TypeCollector methodsFor: 'adding' stamp: 'PF 5/28/2009 10:02'! addAssignment: val toReturnOf: aSelector | eT | eT := self extractedTypeForReturnInMethod: (theClass >> aSelector). eT addAssignment: val.! ! !TypeCollector methodsFor: 'adding' stamp: 'PF 5/19/2009 18:13'! addAssignment: value toTmp: index ((localTypingResults at: currentExtractedMethod) at: index + 1) addAssignment: value! ! !TypeCollector methodsFor: 'adding' stamp: 'PF 5/25/2009 12:06'! addAssignment: value toTmp: index in: aCompiledMethod ((localTypingResults at: aCompiledMethod) at: index + 1) addAssignment: value! ! !TypeCollector methodsFor: 'adding' stamp: 'FredericPluquet 8/18/2010 21:14'! addAssignmentForReturn: val | eT | eT := self extractedTypeForReturnInMethod: currentExtractedMethod. val isInteger ifTrue: [ self withTranslatedIndex: val do: [ :idx | eT addReverseLinkedExtractedType: (typingResults at: idx) ] ] ifFalse: [ (val isVariableBinding and: [ val key = #temp ]) ifTrue: [ eT addReverseLinkedExtractedType: ((localTypingResults at: currentExtractedMethod) at: val value + 1) ] ifFalse: [ (val isVariableBinding and: [ val key = #return ]) ifTrue: [ eT addReverseLinkedExtractedType: (self extractedTypeForReturnInMethod: theClass >> val value) ] ifFalse: [ (val isVariableBinding and: [ val key = #blockArg ]) ifTrue: [ ] ifFalse: [(self assignmentTypeOf: val) ifNotNilDo: [ :result | eT addAssignment: result ] ] ] ]]! ! !TypeCollector methodsFor: 'adding' stamp: 'PF 5/19/2009 15:33'! addAssignmentForReturnSelf (self extractedTypeForReturnInMethod: currentExtractedMethod) addAssignment: theClass! ! !TypeCollector methodsFor: 'adding' stamp: 'PF 5/25/2009 10:49'! addSend: selector onReturnOfSelfMethod: aSelfSelector "Add a range check to filter out sends to instvars defined in superclasses, etc." (self extractedTypeForReturnInMethod: theClass >> aSelfSelector) addSend: selector! ! !TypeCollector methodsFor: 'adding' stamp: ' 29/5/07 18:39'! addSend: selector to: index "Add a range check to filter out sends to instvars defined in superclasses, etc." self withTranslatedIndex: index do: [:i | (self typingResults at: i) addSend: selector]! ! !TypeCollector methodsFor: 'adding' stamp: 'PF 5/19/2009 18:13'! addSend: selector toTmp: index "Add a range check to filter out sends to instvars defined in superclasses, etc." ((localTypingResults at: currentExtractedMethod ) at: index + 1) addSend: selector! ! !TypeCollector methodsFor: 'accessing' stamp: 'PF 5/26/2009 13:20'! allInstVarTypes self typingResults do: [:each | each types]. "localTypingResults valuesDo: [:array | array do: [:et | et types]]"! ! !TypeCollector methodsFor: 'accessing' stamp: 'PF 5/26/2009 15:58'! allTmpTypes "self typingResults do: [:each | each types]." localTypingResults valuesDo: [:array | array do: [:et | et types]]! ! !TypeCollector methodsFor: 'accessing' stamp: 'PF 5/22/2009 12:19'! allTypes self typingResults do: [:each | each types]. localTypingResults valuesDo: [:array | array do: [:et | et types]]! ! !TypeCollector methodsFor: 'heuristics' stamp: ' 29/5/07 18:39'! assignmentTypeOf: val ^self subclassResponsibility! ! !TypeCollector methodsFor: 'accessing' stamp: 'PF 5/26/2009 11:22'! assignmentsTo: instVarName ^(self typingResultsFor: instVarName) flattenLinks; assignments! ! !TypeCollector methodsFor: 'accessing' stamp: 'PF 5/20/2009 16:33'! currentExtractedMethod ^ currentExtractedMethod! ! !TypeCollector methodsFor: 'accessing' stamp: 'PF 8/1/2009 12:09'! currentExtractedMethod: anObject currentExtractedMethod := anObject. localTypingResults at: anObject put: ((1 to: anObject numTemps + 1) collect: [:each | ExtractedTypeForTmp forTmpOffset: each ofCompiledMethod: anObject inClass: anObject methodClass ]) asArray ! ! !TypeCollector methodsFor: 'adding' stamp: 'PF 5/19/2009 18:13'! extractedTypeForReturnInMethod: aCompiledMethod ^(localTypingResults at: aCompiledMethod) last! ! !TypeCollector methodsFor: 'heuristics' stamp: 'FredericPluquet 8/18/2010 22:17'! handleAssignment: val for: index val isInteger ifTrue: [ self withTranslatedIndex: val do: [ :idx | (typingResults at: index + 1) addReverseLinkedExtractedType: (typingResults at: idx) ] ] ifFalse: [ (val isVariableBinding and: [ val key = #temp ]) ifTrue: [ (typingResults at: index + 1) addReverseLinkedExtractedType: ((localTypingResults at: currentExtractedMethod) at: val value + 1) ] ifFalse: [ (val isVariableBinding and: [ val key = #return ]) ifTrue: [ (typingResults at: index + 1) addReverseLinkedExtractedType: (self extractedTypeForReturnInMethod: theClass >> val value) ] ifFalse: [ (val isVariableBinding and: [ val key = #blockArg ]) ifFalse: [(self assignmentTypeOf: val) ifNotNilDo: [ :result | self addAssignment: result to: index ] ] ] ]]! ! !TypeCollector methodsFor: 'heuristics' stamp: 'FredericPluquet 8/18/2010 22:18'! handleAssignment: val forTmp: index "Cannot use ifNotNil: with argument in Squeak, so use a temporary instead." val isInteger ifTrue: [ self withTranslatedIndex: val do: [ :idx | ((localTypingResults at: currentExtractedMethod) at: index + 1) addReverseLinkedExtractedType: (typingResults at: idx) ] ] ifFalse: [ (val isVariableBinding and: [ val key = #temp ]) ifTrue: [ ((localTypingResults at: currentExtractedMethod ) at: index + 1) addReverseLinkedExtractedType: ((localTypingResults at: currentExtractedMethod) at: val value + 1) ] ifFalse: [ (val isVariableBinding and: [ val key = #return ]) ifTrue: [ ((localTypingResults at: currentExtractedMethod ) at: index + 1) addReverseLinkedExtractedType: (self extractedTypeForReturnInMethod: theClass >> val value) ] ifFalse: [ (val isVariableBinding and: [ val key = #blockArg ]) ifFalse: [(self assignmentTypeOf: val) ifNotNilDo: [ :result | self addAssignment: result toTmp: index ] ] ]]]! ! !TypeCollector methodsFor: 'heuristics' stamp: 'FredericPluquet 8/18/2010 22:18'! handleAssignment: val forTmp: index in: aCompiledMethod "Cannot use ifNotNil: with argument in Squeak, so use a temporary instead." val isInteger ifTrue: [ self withTranslatedIndex: val do: [ :idx | ((localTypingResults at: aCompiledMethod) at: index + 1) addReverseLinkedExtractedType: (typingResults at: idx). ] ] ifFalse: [ (val isVariableBinding and: [ val key = #temp ]) ifTrue: [ ((localTypingResults at: aCompiledMethod ) at: index + 1) addReverseLinkedExtractedType: ((localTypingResults at: currentExtractedMethod) at: val value + 1). ] ifFalse: [ (val isVariableBinding and: [ val key = #return ]) ifTrue: [ ((localTypingResults at: aCompiledMethod ) at: index + 1) addReverseLinkedExtractedType: (self extractedTypeForReturnInMethod: theClass >> val value) ] ifFalse: [ (val isVariableBinding and: [ val key = #blockArg ]) ifFalse: [(self assignmentTypeOf: val) ifNotNilDo: [ :result | self addAssignment: result toTmp: index in: aCompiledMethod ] ] ]]]! ! !TypeCollector methodsFor: 'heuristics' stamp: ' 29/5/07 18:39'! langueSpecificPushSendOf: selector to: rec args: args ^#computed! ! !TypeCollector methodsFor: 'private' stamp: 'FredericPluquet 12/18/2009 17:31'! lastAssignmentForIndex: anIndex | assignments | assignments := (self typingResults at: anIndex) assignments. ^assignments isEmpty ifTrue: [nil] ifFalse: [assignments last]! ! !TypeCollector methodsFor: 'private' stamp: 'PF 5/19/2009 14:42'! lastAssignmentForTmpIndex: anIndex | assignments | assignments := ((localTypingResults at: currentExtractedMethod) at: anIndex) assignments. ^ assignments isEmpty ifTrue: [ nil ] ifFalse: [ assignments last ]! ! !TypeCollector methodsFor: 'private' stamp: ' 29/5/07 18:39'! newExtractor "Return a new extractor class. This is typically Smalltalk dialect dependent, so subclasses have to override to choose the one they want." ^self subclassResponsibility! ! !TypeCollector methodsFor: 'initialize-release' stamp: 'PF 5/24/2009 11:15'! onClass: aClass theClass := aClass. instVars := aClass allInstVarNames collect: [ :e | e asSymbol]. typingResults := (instVars collect: [ :ivar | ExtractedType forInstvar: ivar inClass: aClass ]) asArray. localTypingResults := IdentityDictionary new. theClass selectorsAndMethodsDo: [:sel :cm | localTypingResults at: cm put: ((1 to: cm numTemps + 1) collect: "the last one is for the method returned object" [ :i | ExtractedTypeForTmp forTmpOffset: i ofCompiledMethod: cm inClass: theClass ]) asArray]! ! !TypeCollector methodsFor: 'accessing' stamp: 'PF 5/26/2009 13:55'! packagedResults | results | results := IdentityDictionary new. instVars size - theClass instVarNames size + 1 to: instVars size do: [:index | results at: (instVars at: index) put: (self typingResults at: index)]. localTypingResults keysAndValuesDo: [:cm :arr | | prefix prefixTmp| prefix := '_',cm selector,'>>'. prefixTmp := prefix, 'tmp'. 1 to: arr size - 1 do: [:i | results at: ( prefixTmp, i printString) put: (arr at: i)]. results at: (prefix, 'return') put: (arr last). ]. ^results! ! !TypeCollector methodsFor: 'accessing' stamp: 'PF 7/31/2009 07:54'! packagedResultsForCompiledMethod: aCompiledMethod | results arr tmpNames| results := IdentityDictionary new. arr := (localTypingResults at: aCompiledMethod). tmpNames := [aCompiledMethod methodNode tempNames] on: Error do: [aCompiledMethod tempNames]. 1 to: arr size - 1 do: [:i | results at: (tmpNames at: i) put: (arr at: i)]. results at: ('^') put: (arr last). ^results! ! !TypeCollector methodsFor: 'heuristics' stamp: 'PF 5/29/2009 13:42'! pushSendOf: selector to: rec args: args "Needs to be optimized" | index recValue | rec == #self ifTrue: [ (index := instVars indexOf: selector) > 0 ifTrue: [^index - 1]. (selector last == $: and: [(index := instVars indexOf: (selector copyFrom: 1 to: selector size - 1)) > 0]) ifTrue: [self handleAssignment: args first for: index - 1. ^#result->selector]. ]. (#(#= #== #< #> #<= #>= #~= #notNil #xor:) includes: selector) ifTrue: [^Boolean]. "('is*' match: selector ) replaced for performance" ((selector at: 1 ifAbsent: [$j] ) = $i and: [(selector at: 2 ifAbsent: [$j] ) = $s and: [(selector at: 3 ifAbsent: [$n]) isLowercase not]]) ifTrue: [^Boolean]. (rec isVariableBinding and: [(recValue := rec value) isBehavior and: [(recValue class categoryForSelector: selector) == #'instance creation']]) ifTrue: [^Association key: #instcreation value: recValue]. ^self langueSpecificPushSendOf: selector to: rec args: args! ! !TypeCollector methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! sendsTo: instVarName " ^self sends at: (self indexForVar: instVarName)" ^(self typingResultsFor: instVarName) interface! ! !TypeCollector methodsFor: 'initialize-release' stamp: 'PF 5/25/2009 11:46'! theClass ^theClass! ! !TypeCollector methodsFor: 'adding' stamp: 'PF 5/25/2009 18:19'! transformAsBlockArg: anExtractedTypeForTmp (localTypingResults at: anExtractedTypeForTmp compiledMethod) at: anExtractedTypeForTmp tempOffset put: (ExtractedTypeForBlockArg forOffset: anExtractedTypeForTmp tempOffset ofCompiledMethod: anExtractedTypeForTmp compiledMethod inClass: anExtractedTypeForTmp ivarClass)! ! !TypeCollector methodsFor: 'adding' stamp: 'PF 5/25/2009 18:24'! transformAsBlockArgTheTmpOffset: offset ((localTypingResults at: currentExtractedMethod ) at: (offset + 1)) asBlockArgInTypeCollector: self! ! !TypeCollector methodsFor: 'adding' stamp: 'PF 5/25/2009 18:23'! transformAsBlockArgTheTmpOffset: offset in: aCompiledMethod ((localTypingResults at: aCompiledMethod ) at: (offset + 1)) asBlockArgInTypeCollector: self! ! !TypeCollector methodsFor: 'private' stamp: 'PF 5/19/2009 18:28'! tryUsing: receiver for: selector ifNotUse: aClass "If receiver has a type, and the selector is understood by that type, pass that type. If not, use aClass as type." | cl | cl := self assignmentTypeOf: receiver. ^(cl notNil and: [cl methodDict includesKey: selector]) ifTrue: [cl] ifFalse: [aClass]! ! !TypeCollector methodsFor: 'public-typing' stamp: 'FredericPluquet 8/18/2010 22:09'! typeInstvarsOfClass: aClass | extractor| self onClass: aClass. extractor := self newExtractor. aClass selectorsAndMethodsDo: [:sel :method | currentExtractedMethod := method. "(method selector = #blockReturn:) ifTrue: [self halt]". extractor extractInterfacesFrom: method addTo: self]. ^self packagedResults! ! !TypeCollector methodsFor: 'public-typing' stamp: 'PF 5/27/2009 18:05'! typeTmpsIn: aCompiledMethod ofClass: aClass | extractor| self onClass: aClass. extractor := self newExtractor. aClass selectorsAndMethodsDo: [:sel :method | currentExtractedMethod := method. "(method selector = #cssClass:) ifTrue: [self halt]". extractor extractInterfacesFrom: method addTo: self]. ^self packagedResultsForCompiledMethod: aCompiledMethod! ! !TypeCollector methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! typingResults ^typingResults! ! !TypeCollector methodsFor: 'private' stamp: ' 29/5/07 18:39'! typingResultsFor: instVarName ^self typingResults at: (self absoluteIndexForVar: instVarName)! ! !TypeCollector methodsFor: 'private' stamp: ' 29/5/07 18:39'! withTranslatedIndex: index do: aBlock aBlock value: index + 1! ! Object subclass: #TypeMerger instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! TypeMerger subclass: #AbstractMerger instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! !AbstractMerger methodsFor: 'public' stamp: 'FredericPluquet 12/18/2009 17:31'! mergeInterfaceTypes: interfaceTypeCollection assignmentTypes: assignmentTypesCollection "interfaceTypes is a set of trees of types reconstructed by looking at the interfaces. assignmentTypes is a set of trees of types reconstructed by looking at the assignments. The receiver takes these sets as input and needs to return one set of trees of types that combines both." "This class does this by preferring abstract types over concrete types." | assignmentsToKeep chain | (interfaceTypeCollection isEmpty and: [assignmentTypesCollection notEmpty]) ifTrue: [^assignmentTypesCollection]. assignmentsToKeep := assignmentTypesCollection select: [:assignmentType | chain := assignmentType withAllSuperclasses. (interfaceTypeCollection contains: [:superType | chain includes: superType]) not]. assignmentsToKeep addAll: interfaceTypeCollection. ^assignmentsToKeep isEmpty ifTrue: [OrderedCollection with: Object] ifFalse: [assignmentsToKeep]! ! TypeMerger subclass: #AssignmentsFirstMerger instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! !AssignmentsFirstMerger methodsFor: 'public' stamp: 'PF 3/19/2009 15:10'! mergeInterfaceTypes: interfaceTypeCollection assignmentTypes: assignmentTypesCollection "interfaceTypes is a set of trees of types reconstructed by looking at the interfaces. assignmentTypes is a set of trees of types reconstructed by looking at the assignments. The receiver takes these sets as input and needs to return one set of trees of types that combines both." "This merger favors the assignment types over the interface types. It only considers the interface types when there is no assignment information, or when there is only one interface type that is not related to the assignment types." | interfaceType assignments | (assignmentTypesCollection size = 1 and: [assignmentTypesCollection first = UndefinedObject]) ifTrue: [assignmentTypesCollection removeFirst]. assignmentTypesCollection isEmpty ifTrue: [interfaceTypeCollection isEmpty ifTrue: [^OrderedCollection with: Object] ifFalse: [^self cleanBooleansIn: interfaceTypeCollection asOrderedCollection]]. assignments := assignmentTypesCollection asOrderedCollection. interfaceTypeCollection size == 1 ifFalse: [^self cleanBooleansIn: assignments]. interfaceType := interfaceTypeCollection asOrderedCollection first. ^((assignments anySatisfy: [:cl | cl includesBehavior: interfaceType]) or: [assignments anySatisfy: [:assignmentType | interfaceType includesBehavior: assignmentType]]) ifTrue: [self cleanBooleansIn: assignments] ifFalse: [self cleanBooleansIn: (assignments add: interfaceType; yourself)]! ! TypeMerger subclass: #ConcreteMerger instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! !ConcreteMerger methodsFor: 'public' stamp: 'FredericPluquet 12/18/2009 17:31'! mergeInterfaceTypes: interfaceTypeCollection assignmentTypes: assignmentTypesCollection "interfaceTypes is a set of trees of types reconstructed by looking at the interfaces. assignmentTypes is a set of trees of types reconstructed by looking at the assignments. The receiver takes these sets as input and needs to return one set of trees of types that combines both." "This class does this by preferring concrete types over abstract types." | toKeep chain | toKeep := interfaceTypeCollection copy. assignmentTypesCollection do: [:assignmentType | chain := assignmentType withAllSuperclasses. (interfaceTypeCollection select: [:type | chain includes: type]) do: [:each | toKeep remove: each ifAbsent: []]]. toKeep addAll: assignmentTypesCollection. ^toKeep isEmpty ifTrue: [OrderedCollection with: Object] ifFalse: [toKeep asOrderedCollection]! ! !TypeMerger class methodsFor: 'instance creation' stamp: ' 29/5/07 18:39'! interfaceTypes: interfaceTypeCollection assignmentTypes: assignmentTypesCollection ^self new mergeInterfaceTypes: interfaceTypeCollection assignmentTypes: assignmentTypesCollection! ! !TypeMerger methodsFor: 'private' stamp: 'FredericPluquet 12/18/2009 17:31'! cleanBooleansIn: collection "Remove all occurences of True, False and Boolean in the given collection. If any element was removed, add Boolean" "Note: removeAllSuchThat: in VisualWorks returns the elements removed, while in Squeak it returns the new set. Therefore I adopted a check on the sizes to see if any Boolean class was removed or not, instead of checking the result of removeAllSuchThat: " | oldSize | oldSize := collection size. collection removeAllSuchThat: [:type | type == True | (type == False) | (type == Boolean)]. ^oldSize == collection size ifFalse: [collection add: Boolean; yourself] ifTrue: [collection]! ! !TypeMerger methodsFor: 'public' stamp: ' 29/5/07 18:39'! mergeInterfaceTypes: interfaceTypeCollection assignmentTypes: assignmentTypesCollection "interfaceTypes is a set of trees of types reconstructed by looking at the interfaces. assignmentTypes is a set of trees of types reconstructed by looking at the assignments. The receiver takes these sets as input and needs to return one set of trees of types that combines both." ^self subclassResponsibility! ! Object subclass: #TypingResultKeeper instanceVariableNames: 'timeTaken typeResults' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! !TypingResultKeeper class methodsFor: 'instance creation' stamp: 'FredericPluquet 12/18/2009 17:31'! benchmarkImage "self benchmarkImage" | keeper | ^Time millisecondsToRun: [keeper := self forImage. keeper withAllInstvarResultsDo: [:cl :iv :result | result types]]! ! !TypingResultKeeper class methodsFor: 'instance creation' stamp: ' 29/5/07 18:39'! forImage ^self new forImage! ! !TypingResultKeeper class methodsFor: 'instance creation' stamp: 'FredericPluquet 12/18/2009 17:31'! forImageExpanded | keeper | keeper := self forImage. keeper withAllInstvarResultsDo: [:cl :iv :result | result types]. ^keeper! ! !TypingResultKeeper class methodsFor: 'instance creation' stamp: ' 29/5/07 18:39'! new ^super new initialize! ! !TypingResultKeeper methodsFor: 'private' stamp: ' 29/5/07 18:39'! addCollectorResult: collectorResult collectorResult isEmpty ifTrue: [^self]. typeResults at: collectorResult values first ivarClass put: collectorResult! ! !TypingResultKeeper methodsFor: 'private' stamp: 'FredericPluquet 12/18/2009 17:31'! addTypingResult: aTypeResult | typeResultsForClass | typeResultsForClass := self typeResults at: aTypeResult ivarClass ifAbsentPut: [Dictionary new]. typeResultsForClass at: aTypeResult ivarName put: aTypeResult! ! !TypingResultKeeper methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! calculateTypesForClass: aClass ^TypeCollector typeInstvarsOfClass: aClass! ! !TypingResultKeeper methodsFor: 'public' stamp: 'FredericPluquet 12/18/2009 17:31'! forClasses: aClassList | collector | collector := TypeCollector new. timeTaken := Time millisecondsToRun: [aClassList do: [:cl | cl isMeta ifFalse: [self addCollectorResult: (collector typeInstvarsOfClass: cl)]]]! ! !TypingResultKeeper methodsFor: 'public' stamp: ' 29/5/07 18:39'! forImage self forClasses: Object allSubclasses! ! !TypingResultKeeper methodsFor: 'initialize-release' stamp: 'FredericPluquet 12/18/2009 17:31'! initialize typeResults := IdentityDictionary new! ! !TypingResultKeeper methodsFor: 'accessing' stamp: 'FredericPluquet 12/18/2009 17:31'! nrObjectTypes | nr | nr := 0. self withAllInstvarResultsDo: [:cl :ivar :typeResult | (typeResult is: Object) ifTrue: [nr := nr + 1]]. ^nr! ! !TypingResultKeeper methodsFor: 'accessing' stamp: 'FredericPluquet 12/18/2009 17:31'! nrUniqueTypes | nr | nr := 0. self withAllInstvarResultsDo: [:cl :ivar :typeResult | typeResult isSingularType ifTrue: [nr := nr + 1]]. ^nr! ! !TypingResultKeeper methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! resetTypesForClass: aClass ^typeResults removeKey: aClass ifAbsent: []! ! !TypingResultKeeper methodsFor: 'private' stamp: 'FredericPluquet 12/18/2009 17:31'! resultsForClass: aClass instvar: instvar ifAbsent: absentBlock | ivars | ivars := typeResults at: aClass ifAbsent: absentBlock. ^ivars at: instvar ifAbsent: absentBlock! ! !TypingResultKeeper methodsFor: 'statistics' stamp: 'FredericPluquet 12/18/2009 17:31'! sameTypesAs: otherKeeper | result correspondingResult | result := OrderedCollection new. self withAllInstvarResultsDo: [:cl :iv :res | correspondingResult := otherKeeper typesForClass: cl instvar: iv. (res types sameElements: correspondingResult types) ifTrue: [result add: cl -> iv]]. ^result! ! !TypingResultKeeper methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! timeTaken ^timeTaken! ! !TypingResultKeeper methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! typeResults ^typeResults! ! !TypingResultKeeper methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! typesForClass: aClass ^typeResults at: aClass ifAbsentPut: [self calculateTypesForClass: aClass]! ! !TypingResultKeeper methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! typesForClass: aClass instvar: instvar ^(self typesForClass: aClass) at: instvar ifAbsent: [ExtractedType forInstvar: instvar inClass: aClass]! ! !TypingResultKeeper methodsFor: 'enumerating' stamp: ' 29/5/07 18:39'! withAllInstvarResultsDo: aBlock self typeResults keysAndValuesDo: [:cl :instvarDict | instvarDict keysAndValuesDo: [:ivar :typeResult | aBlock value: cl value: ivar value: typeResult]]! ! !Collection methodsFor: '*RoelTyper' stamp: 'PF 5/29/2009 11:21'! fusionWith: aCollection ^aCollection fusionWithCollection: self! ! !Collection methodsFor: '*RoelTyper' stamp: 'PF 5/29/2009 11:23'! fusionWithCollection: aCollection ^(CommonCollection on: aCollection) fusionWith: self! ! !Collection methodsFor: '*RoelTyper-testing' stamp: ' 29/5/07 18:39'! sameElements: aCollection ^(self allSatisfy: [:each | aCollection includes: each]) and: [aCollection allSatisfy: [:each | self includes: each]]! ! !ClassDescription methodsFor: '*RoelTyper-organization' stamp: 'DamienCassou 12/23/2009 16:25'! categoryForSelector: aSelector "Starting from the receiver, find the category for the given selector (if any). " "Works for Squeak as well,so do not use the fancy ifNil:ifNotNil: trick with arguments from VW, as Squeak does not digest it." | cat s | ^(cat := self whichCategoryIncludesSelector: aSelector) ifNil: [(s := self superclass) ifNil: [nil] ifNotNil: [s categoryForSelector: aSelector]] ifNotNil: [cat]! !