SystemOrganization addCategory: #'RoelTyper-Core'! SystemOrganization addCategory: #'RoelTyper-Squeak'! SystemOrganization addCategory: #'RoelTyper-Tests'! !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! ! Object subclass: #AbstractType instanceVariableNames: 'ivarClass ivarName' 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: ' 29/5/07 18:39'! conflictingAssignmentsWith: anExtractedType | conflictingAssignments | conflictingAssignments _ anExtractedType assignments select: [:assignment | (self types includes: assignment) not]. ^conflictingAssignments! ! !AbstractType methodsFor: 'private' stamp: ' 29/5/07 18:39'! 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: ' 29/5/07 18:39'! ivarClass: aClass ivarClass _ aClass. self triggerEvent: #changed! ! !AbstractType methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! ivarName ^ivarName! ! !AbstractType methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! ivarName: aSymbol ivarName _ aSymbol. self triggerEvent: #changed! ! !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' 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: ' 29/5/07 18:39'! 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: ' 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: ' 29/5/07 18:39'! cleanedAssignments | assigns | assigns _ self assignments copy. ((assigns includes: True) and: [assigns includes: False]) ifTrue: [assigns remove: True; remove: False; add: Boolean]. ^assigns! ! !ExtractedType methodsFor: 'private' stamp: ' 29/5/07 18:39'! foldInterfaceTypes: interfaceClasses withAssignmentTypes: assignmentClasses " ^interfaceClasses asOrderedCollection" "Only interface types" " ^assignmentClasses " "Only assignment types" ^self class mergerClass interfaceTypes: interfaceClasses 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: ' 29/5/07 18:39'! initialize super initialize. self interface: IdentitySet new assignments: OrderedCollection new! ! !ExtractedType methodsFor: 'private-accessing' stamp: ' 29/5/07 18:39'! interface ^interface! ! !ExtractedType methodsFor: 'private-accessing' stamp: ' 29/5/07 18:39'! 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' stamp: ' 29/5/07 18:39'! mergeTypes ^self foldInterfaceTypes: (self rootsUnderstanding: self interface) withAssignmentTypes: self cleanedAssignments! ! !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: ' 29/5/07 18:39'! 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 prototypeSet | selectors isEmpty ifTrue: [^IdentitySet new]. prototypeSet _ IdentitySet new: 20. nextClasses _ (prototypeSet copy) add: Object; yourself. selectors do: [:selector | initialClasses _ nextClasses. nextClasses _ prototypeSet copy. initialClasses do: [:initialClass | (initialClass canUnderstand: selector) ifTrue: [nextClasses add: initialClass] ifFalse: [traverseStack _ OrderedCollection with: initialClass. [traverseStack isEmpty] whileFalse: [next _ traverseStack removeFirst. next nonMetaSubclassesDo: [:subcl | (subcl includesSelector: selector) ifTrue: [nextClasses add: subcl] ifFalse: [traverseStack add: subcl]]]]]]. ^nextClasses! ! !ExtractedType methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! types ^extractedTypes ifNil: [extractedTypes _ self mergeTypes] ifNotNil: [extractedTypes]! ! Object subclass: #TypeCollector instanceVariableNames: 'theClass instVars typingResults' 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 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: ' 26/5/07 15:11'! 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]. ^#computed! ! !SqueakTypeCollector methodsFor: 'private' stamp: ' 26/5/07 15:11'! newExtractor ^SqueakInstvarInterfaceExtractor new! ! !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: ' 29/5/07 18:39'! newForPlatform "Return either a VWTypeCollector or a SqueakTypeCollector, depending on the platform used." "Generated during generation of Squeak files from within VisualWorks." ^SqueakTypeCollector 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: ' 29/5/07 18:39'! typeInstvarsOfClass: aClass "self typeInstvarsOfClass: Point" ^self new typeInstvarsOfClass: 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: ' 29/5/07 18:39'! addAssignment: value to: index self withTranslatedIndex: index do: [:i | (self typingResults at: i) addAssignment: value]! ! !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: 'heuristics' stamp: ' 29/5/07 18:39'! assignmentTypeOf: val ^self subclassResponsibility! ! !TypeCollector methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! assignmentsTo: instVarName ^(self typingResultsFor: instVarName) assignments! ! !TypeCollector methodsFor: 'heuristics' stamp: ' 29/5/07 18:39'! handleAssignment: val for: index "Cannot use ifNotNil: with argument in Squeak, so use a temporary instead." | result | result _ nil. val isInteger ifTrue: [self withTranslatedIndex: val do: [:idx | result _ self lastAssignmentForIndex: idx]] ifFalse: [result _ self assignmentTypeOf: val]. result ifNotNil: [self addAssignment: result to: index]! ! !TypeCollector methodsFor: 'heuristics' stamp: ' 29/5/07 18:39'! langueSpecificPushSendOf: selector to: rec args: args ^#computed! ! !TypeCollector methodsFor: 'private' stamp: ' 29/5/07 18:39'! lastAssignmentForIndex: anIndex | assignments | assignments _ (self typingResults 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: ' 29/5/07 18:39'! onClass: aClass theClass _ aClass. instVars _ aClass allInstVarNames collect: [:e | e asSymbol]. typingResults _ (instVars collect: [:ivar | ExtractedType forInstvar: ivar inClass: aClass]) asArray! ! !TypeCollector methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! packagedResults | results | results _ IdentityDictionary new: self typingResults size. instVars size - theClass instVarNames size + 1 to: instVars size do: [:index | results at: (instVars at: index) put: (self typingResults at: index)]. ^results! ! !TypeCollector methodsFor: 'heuristics' stamp: ' 29/5/07 18:39'! pushSendOf: selector to: rec args: args "Needs to be optimized" | recValue index | rec == #self ifTrue: [(index _ instVars indexOf: selector) > 0 ifTrue: [^index - 1]. (selector last == $: and: [(index _ instVars indexOf: (selector copyFrom: 1 to: selector size - 1) asSymbol) > 0]) ifTrue: [self handleAssignment: args first for: index - 1. ^#computed]]. (#(#= #== #< #> #<= #>= #~=) includes: selector) ifTrue: [^Boolean]. ('is*' match: selector) 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: 'private' stamp: ' 29/5/07 18:39'! 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 selectors includes: selector]) ifTrue: [cl] ifFalse: [aClass]! ! !TypeCollector methodsFor: 'public-typing' stamp: ' 29/5/07 18:39'! typeInstvarsOfClass: aClass | extractor | self onClass: aClass. extractor _ self newExtractor. aClass selectorsAndMethodsDo: [:sel :method | extractor extractInterfacesFrom: method addTo: self]. ^self packagedResults! ! !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: ' 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." "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: ' 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." "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 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: ' 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." "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: ' 29/5/07 18:39'! 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: ' 29/5/07 18:39'! 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: ' 29/5/07 18:39'! 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: ' 29/5/07 18:39'! 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: ' 29/5/07 18:39'! 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: ' 29/5/07 18:39'! initialize typeResults _ IdentityDictionary new! ! !TypingResultKeeper methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! nrObjectTypes | nr | nr _ 0. self withAllInstvarResultsDo: [:cl :ivar :typeResult | (typeResult is: Object) ifTrue: [nr _ nr + 1]]. ^nr! ! !TypingResultKeeper methodsFor: 'accessing' stamp: ' 29/5/07 18:39'! 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: ' 29/5/07 18:39'! resultsForClass: aClass instvar: instvar ifAbsent: absentBlock | ivars | ivars _ typeResults at: aClass ifAbsent: absentBlock. ^ivars at: instvar ifAbsent: absentBlock! ! !TypingResultKeeper methodsFor: 'statistics' stamp: ' 29/5/07 18:39'! 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]]! ! !ClassDescription methodsFor: '*RoelTyper-organization' stamp: ' 29/5/07 18:39'! 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]! ! InstructionClient subclass: #InstvarInterfaceExtractor instanceVariableNames: 'stack copied initialStack method saveStacks input collector' 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: ' 29/5/07 18:39'! copied: list copied _ list! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 29/5/07 18:39'! dupFirst stack add: stack last! ! !InstvarInterfaceExtractor methodsFor: 'extracting' stamp: ' 29/5/07 18:39'! extractInterfacesFrom: m addTo: aTypeCollector method _ m. saveStacks _ Dictionary new. stack _ OrderedCollection new. method numTemps timesRepeat: [stack add: #temp]. initialStack _ stack copy. collector _ aTypeCollector. input _ InstructionStream on: method. [input atEnd] whileFalse: [self reloadStack. input interpretNextInstructionFor: self]! ! !InstvarInterfaceExtractor methodsFor: 'private' stamp: ' 29/5/07 18:39'! input ^input! ! !InstvarInterfaceExtractor methodsFor: 'private' stamp: ' 29/5/07 18:39'! method: aMethod method _ aMethod. copied _ #()! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 29/5/07 18:39'! pop stack removeLast! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 29/5/07 18:39'! pushConstant: value value class == BlockClosure ifTrue: [self readBlock: value method copied: 0] ifFalse: [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: ' 29/5/07 18:39'! 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: ' 29/5/07 18:39'! 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: ' 29/5/07 18:39'! saveStacks saveStacks ifNil: [saveStacks _ Dictionary new]. ^saveStacks! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-control' stamp: ' 29/5/07 18:39'! send: selector numArgs: na | receiver args | args _ stack removeLast: na. receiver _ (stack removeLast: 1) first. receiver isInteger ifTrue: [collector addSend: selector to: receiver]. stack add: (collector pushSendOf: selector to: receiver args: args)! ! InstvarInterfaceExtractor subclass: #SqueakInstvarInterfaceExtractor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Squeak'! !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: ' 26/5/07 15:11'! 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: ' 26/5/07 15:11'! jump: delta if: condition self pop. "receiver of ifTrue or ifFalse, according to condition" delta < 1 ifTrue: [^self]. self saveStacks at: self input pc + delta put: ((stack copy) add: #computed; yourself)! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 26/5/07 15:11'! methodReturnConstant: value "Return Constant bytecode." ^self pushConstant: value; sqReturnTop! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 26/5/07 15:11'! methodReturnReceiver "Return Self bytecode." ^self pushReceiver; sqReturnTop! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 26/5/07 15:11'! methodReturnTop "Return Top Of Stack bytecode." ^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: ' 26/5/07 15:11'! popIntoTemporaryVariable: offset "Remove Top Of Stack And Store Into Temporary Variable bytecode." "Nothing to do,since I do not treat temporary variables for the moment." ! ! !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: ' 26/5/07 15:11'! pushTemporaryVariable: offset "Push Contents Of Temporary Variable Whose Index Is the argument, offset, On Top Of Stack bytecode." stack add: #tempVariable! ! !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: ' 26/5/07 15:11'! 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: ' 26/5/07 15:11'! 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." ! ! !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]]! ! !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]! ! 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: ' 26/5/07 15:11'! 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: ' 26/5/07 15:11'! 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: ' 26/5/07 15:11'! 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: ' 26/5/07 15:11'! processMethod: aCompiledMethod "Fail by default. Needs to be overridden by subclasses to trigger the base testing backbone." | collector | collector _ TypeCollector onClass: self class. TypeCollector new newExtractor extractInterfacesFrom: aCompiledMethod addTo: collector. ^collector! ! !InstvarInterfaceExtractorTest methodsFor: 'assignment tests' stamp: ' 26/5/07 15:11'! 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: ' 26/5/07 15:11'! 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: ' 26/5/07 15:11'! testArrayAssignment | collector | collector _ self doForSource: 'v := #(one two three)'. self assertAssignments: #(#(#v #(#Array))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: ' 26/5/07 15:11'! testCascaded1 | collector | collector _ self doForSource: 'x printString; size'. self assertSends: #(#(#x #(#printString #size))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: ' 26/5/07 15:11'! testCascaded2 | collector | collector _ self doForSource: 'x printString; size; yourself'. self assertSends: #(#(#x #(#printString #size #yourself))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'assignment tests' stamp: ' 26/5/07 15:11'! 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: ' 26/5/07 15:11'! testComplicated2 | collector | collector _ self doForSource: ' | temp1 temp2 | temp1 := b := temp2 := 3.'. self denyAssignments: #(#(#b #(#SmallInteger))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'non supported' stamp: ' 26/5/07 15:11'! 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: ' 26/5/07 15:11'! testEquality | collector | collector _ self doForSource: 'u := v = 3'. self assertSends: #(#(#v #(#=))) in: collector. self assertAssignments: #(#(#u #(#Boolean))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'assignment tests' stamp: ' 26/5/07 15:11'! testIdentity | collector | collector _ self doForSource: 'u := v == 3'. self assertSends: #(#(#v #(#==))) in: collector. self assertAssignments: #(#(#u #(#Boolean))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: ' 26/5/07 15:11'! 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: 'assignment tests' stamp: ' 26/5/07 15:11'! testInstanceAssignment | collector | collector _ self doForSource: 'w := TypeCollector new'. self assertAssignments: #(#(#w #(#TypeCollector))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'assignment tests' stamp: ' 26/5/07 15:11'! testInstanceAssignmentIndirect | collector | collector _ self doForSource: 'self w: TypeCollector new'. self assertAssignments: #(#(#w #(#TypeCollector))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'assignment tests' stamp: ' 26/5/07 15:11'! 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: ' 26/5/07 15:11'! testInstvarAssignment2 | collector | collector _ self doForSource: ' | temp1 temp2 temp3 | c := b := 3.'. self assertAssignments: #(#(#b #(#SmallInteger)) #(#c #(#SmallInteger))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'assignment tests' stamp: ' 26/5/07 15:11'! 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: ' 26/5/07 15:11'! testSuperivarAssignment | collector | collector _ self doForSource: '^testSelector := testSelector'. self assertSends: #() in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: ' 26/5/07 15:11'! testSuperivarSend | collector | collector _ self doForSource: '^testSelector printString'. self assertSends: #(#(#testSelector #(#printString))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: ' 26/5/07 15:11'! 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: ' 26/5/07 15:11'! 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: ' 26/5/07 15:11'! testblockxy | collector | collector _ self doForSource: '^self xyw ifTrue: [x] ifFalse: [y]'. self assertSends: #() in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: ' 26/5/07 15:11'! 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: ' 26/5/07 15:11'! testindirectx | collector | collector _ self doForSource: '^self x printString'. self assertSends: #(#(#x #(#printString))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: ' 26/5/07 15:11'! testu | collector | collector _ self doForSource: '^u'. self assertSends: #() in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: ' 26/5/07 15:11'! 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: ' 26/5/07 15:11'! testxyw | collector | collector _ self doForSource: ' | t | t := (x = y). ^t = w'. self assertSends: #(#(#x #(#=))) in: collector! ! !InstvarInterfaceExtractorTest methodsFor: 'send tests' stamp: ' 26/5/07 15:11'! testzuv | collector | collector _ self doForSource: '^u ~= z or: [u = v]'. self assertSends: #(#(#u #(#= #~=))) in: collector! ! !RoelTypingTestRoot methodsFor: 'auxiliary' stamp: ' 26/5/07 15:11'! 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: ' 26/5/07 15:11'! 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: ' 26/5/07 15:11'! 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])! !