SystemOrganization addCategory: #'RoelTyper-Core'! SystemOrganization addCategory: #'RoelTyper-Tests'! 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: ' 7/9/05 23:28'! copied: list copied := list! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 7/9/05 23:28'! dupFirst stack add: stack last.! ! !InstvarInterfaceExtractor methodsFor: 'extracting' stamp: ' 7/9/05 23:28'! 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: ' 7/9/05 23:28'! input ^input! ! !InstvarInterfaceExtractor methodsFor: 'private' stamp: ' 7/9/05 23:28'! method: aMethod method := aMethod. copied := #()! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 7/9/05 23:28'! pop stack removeLast.! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 7/9/05 23:28'! pushConstant: value value class == BlockClosure ifTrue: [self readBlock: value method copied: 0] ifFalse: [stack addLast: value class]! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 7/9/05 23:28'! pushContext stack add: #context.! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 7/9/05 23:28'! pushInst: index stack add: index! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 7/9/05 23:28'! pushReceiver stack addLast: #self.! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 7/9/05 23:28'! 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: ' 7/9/05 23:28'! 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: ' 7/9/05 23:28'! 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: ' 7/9/05 23:28'! saveStacks saveStacks ifNil: [saveStacks := Dictionary new]. ^saveStacks! ! !InstvarInterfaceExtractor methodsFor: 'opcodes-control' stamp: ' 7/9/05 23:28'! 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-Core'! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 7/9/05 23:28'! blockReturnTop "Return Top Of Stack bytecode." ^self pop! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 7/9/05 23:28'! doDup "Duplicate Top Of Stack bytecode." self dupFirst! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 7/9/05 23:28'! doPop "Remove Top Of Stack bytecode." ^self pop! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 7/9/05 23:28'! jump: delta | currentPC | currentPC := self input pc. delta > 0 ifTrue: [self saveStacks at: currentPC+delta put: stack copy. stack := OrderedCollection new].! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 7/9/05 23:28'! jump: delta if: condition self pop. "receiver of ifTrue or ifFalse, according to condition" delta > 0 ifTrue: [self saveStacks at: self input pc+delta put: (stack copy add: #computed; yourself)].! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 7/9/05 23:28'! methodReturnConstant: value "Return Constant bytecode." ^self pushConstant: value; sqReturnTop! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 7/9/05 23:28'! methodReturnReceiver "Return Self bytecode." ^self pushReceiver; sqReturnTop! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 7/9/05 23:28'! methodReturnTop "Return Top Of Stack bytecode." ^self sqReturnTop! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 7/9/05 23:28'! popIntoLiteralVariable: anAssociation "Remove Top Of Stack And Store Into Literal Variable bytecode." ^self pop! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 7/9/05 23:28'! popIntoReceiverVariable: offset "Remove Top Of Stack And Store Into Instance Variable bytecode." collector handleAssignment: stack removeLast for: offset! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 7/9/05 23:28'! 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: ' 7/9/05 23:28'! pushActiveContext "Push Active Context On Top Of Its Own Stack bytecode." self pushContext! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 7/9/05 23:28'! pushLiteralVariable: anAssociation "Push Contents Of anAssociation On Top Of Stack bytecode." self pushStatic: anAssociation! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 7/9/05 23:28'! 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: ' 7/9/05 23:28'! 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: ' 7/9/05 23:28'! 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: ' 7/9/05 23:28'! sendSuper: selector numArgs: na stack removeLast: na + 1. stack add: #computed! ! !SqueakInstvarInterfaceExtractor methodsFor: 'private' stamp: ' 7/9/05 23:28'! sqReturnTop "In VW, method returnTop is inherited from instructionClient and does nothing."! ! !SqueakInstvarInterfaceExtractor methodsFor: 'instruction decoding' stamp: ' 7/9/05 23:28'! 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: ' 7/9/05 23:28'! 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: ' 7/9/05 23:28'! 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."! ! InstvarInterfaceExtractor subclass: #VWInstvarInterfaceExtractor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! !VWInstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 7/9/05 23:28'! dupLast stack removeLast.! ! !VWInstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 7/9/05 23:28'! dupNext stack removeLast; add: stack last.! ! !VWInstvarInterfaceExtractor methodsFor: 'opcodes-control' stamp: ' 7/9/05 23:28'! jump: delta | currentPC | currentPC := self input pc. delta > 0 ifTrue: [self saveStacks at: currentPC+delta put: (self saveStacks at:currentPC). self saveStacks removeKey: currentPC].! ! !VWInstvarInterfaceExtractor methodsFor: 'opcodes-control' stamp: ' 7/9/05 23:28'! jump: delta if: condition self pop. "receiver of ifTrue or ifFalse, according to condition" delta > 0 ifTrue: [self saveStacks at: self input pc+delta put: (stack copy add: #computed; yourself)].! ! !VWInstvarInterfaceExtractor methodsFor: 'opcodes-control' stamp: ' 7/9/05 23:28'! makeCopyingBlock: meth count: count self readBlock: meth copied: count! ! !VWInstvarInterfaceExtractor methodsFor: 'opcodes-control' stamp: ' 7/9/05 23:28'! makeFullBlock: meth self readBlock: meth copied: 0! ! !VWInstvarInterfaceExtractor methodsFor: 'opcodes-control' stamp: ' 7/9/05 23:28'! makeFullCopyingBlock: meth count: count self readBlock: meth copied: count! ! !VWInstvarInterfaceExtractor methodsFor: 'opcodes-control' stamp: ' 7/9/05 23:28'! methodPrimitive: index stack add: #errorCode.! ! !VWInstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 7/9/05 23:28'! pushCopiedValues: count copied size = count ifFalse: [self error: (#copiedMismatch << #dialogs >> 'copied mismatch')]. stack addAll: copied. initialStack addAll: copied! ! !VWInstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 7/9/05 23:28'! pushLocal: index stack add: (stack at: index+1).! ! !VWInstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 7/9/05 23:28'! pushLocalIndirect: majorIndex index: minorIndex stack add: ((stack at: majorIndex + 1) == #self ifTrue: [minorIndex] ifFalse: [#thing])! ! !VWInstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 7/9/05 23:28'! pushNewArray: size stack add: #array.! ! !VWInstvarInterfaceExtractor methodsFor: 'opcodes-control' stamp: ' 7/9/05 23:28'! sendNoCheck: selector numArgs: na self send: selector numArgs: na! ! !VWInstvarInterfaceExtractor methodsFor: 'opcodes-control' stamp: ' 7/9/05 23:28'! sendNonImmediate: selector numArgs: na self send: selector numArgs: na! ! !VWInstvarInterfaceExtractor methodsFor: 'opcodes-control' stamp: ' 7/9/05 23:28'! sendSuper: selector numArgs: na stack removeLast: na + 2. stack add: #computed! ! !VWInstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 7/9/05 23:28'! storePopInst: index collector handleAssignment: stack removeLast for: index! ! !VWInstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 7/9/05 23:28'! storePopLocal: index stack size = method numArgs ifTrue: [method primitiveNumber ifNil: [self error: (#BadMethod << #dialogs >> 'bad method')]] ifFalse: [self pop].! ! !VWInstvarInterfaceExtractor methodsFor: 'opcodes-data movement' stamp: ' 7/9/05 23:28'! storePopLocalIndirect: majorIndex index: minorIndex "Need to have a look at this, since an instance variable is being used (so I'd like to push its index on to the stack) bu I don't really know how. " self pop. " (stack at: majorIndex+1) == #self ifTrue: [instvarsInterface add: minorIndex]"! ! Object subclass: #AbstractType instanceVariableNames: 'ivarClass ivarName' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! !AbstractType class methodsFor: 'instance creation' stamp: ' 7/9/05 23:28'! forInstvar: iv inClass: aClass ^(self basicNew) initialize ivarName: iv; ivarClass: aClass; yourself! ! !AbstractType class methodsFor: 'instance creation' stamp: ' 7/9/05 23:28'! new ^self shouldNotImplement! ! !AbstractType methodsFor: 'private' stamp: ' 7/9/05 23:28'! conflictingAssignmentsWith: anExtractedType | conflictingAssignments | conflictingAssignments := anExtractedType assignments select: [:assignment | (self types includes: assignment) not]. ^conflictingAssignments! ! !AbstractType methodsFor: 'private' stamp: ' 7/9/05 23:28'! 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: 'comparing' stamp: ' 7/9/05 23:28'! conformsTo: anExtractedType "I am a type. Return whether my types conform to the interface and assignments from the argument." | conflictingSelectors conflictingAssignments | conflictingSelectors := self conflictingSelectorsWith: anExtractedType. conflictingAssignments := self conflictingAssignmentsWith: anExtractedType. ^(conflictingSelectors isEmpty and: [conflictingAssignments isEmpty]) ifTrue: [NoTypingConflict existingResult: self newResult: anExtractedType] ifFalse: [TypingConflict existingResult: self newResult: anExtractedType conflictingSelectors: conflictingSelectors conflictingAssignments: conflictingAssignments]! ! !AbstractType methodsFor: 'initialize-release' stamp: ' 7/9/05 23:28'! initialize "Do nothing, but give subclasses the chance to override."! ! !AbstractType methodsFor: 'testing' stamp: ' 7/9/05 23:28'! is: aClass ^self isSingularType and: [self types first = aClass]! ! !AbstractType methodsFor: 'comparing' stamp: ' 7/9/05 23:28'! isConformingTo: aType ^(self conformsTo: aType) notConflict! ! !AbstractType methodsFor: 'testing' stamp: ' 7/9/05 23:28'! isEditedResult ^self subclassResponsibility! ! !AbstractType methodsFor: 'testing' stamp: ' 7/9/05 23:28'! isExtractedResult ^self subclassResponsibility! ! !AbstractType methodsFor: 'testing' stamp: ' 7/9/05 23:28'! isObjectType ^self isSingularType and: [self types includes: Object]! ! !AbstractType methodsFor: 'testing' stamp: ' 7/9/05 23:28'! isSingularType ^self types size = 1! ! !AbstractType methodsFor: 'accessing' stamp: ' 7/9/05 23:28'! ivarClass ^ivarClass! ! !AbstractType methodsFor: 'accessing' stamp: ' 7/9/05 23:28'! ivarClass: aClass ivarClass := aClass. self triggerEvent: #changed! ! !AbstractType methodsFor: 'accessing' stamp: ' 7/9/05 23:28'! ivarName ^ivarName! ! !AbstractType methodsFor: 'accessing' stamp: ' 7/9/05 23:28'! ivarName: aSymbol ivarName := aSymbol. self triggerEvent: #changed! ! !AbstractType methodsFor: 'printing' stamp: ' 7/9/05 23:28'! printOn: aStream self printTypesOn: aStream! ! !AbstractType methodsFor: 'printing' stamp: ' 7/9/05 23:28'! printTypesOn: aStream self types do: [:each | aStream print: each] separatedBy: [aStream nextPutAll: ' , ']! ! !AbstractType methodsFor: 'comparing' stamp: ' 7/9/05 23:28'! sameAs: aTypingResult "Return whether the receiver and the arguments are the same e.g. whether they have the same values for the interfaces, sends and extracted types." ^self subclassResponsibility! ! !AbstractType methodsFor: 'comparing-private' stamp: ' 7/9/05 23:28'! sameAsEditedType: anEditedTypingResult "Return whether the receiver and the arguments are the same e.g. whether they have the same values for the interfaces, sends and extracted types." ^self subclassResponsibility! ! !AbstractType methodsFor: 'comparing-private' stamp: ' 7/9/05 23:28'! sameAsExtractedType: anExtractedTypingResult "Return whether the receiver and the arguments are the same e.g. whether they have the same values for the interfaces, sends and extracted types." ^self subclassResponsibility! ! !AbstractType methodsFor: 'accessing' stamp: ' 7/9/05 23:28'! types ^self subclassResponsibility! ! AbstractType subclass: #EditedType instanceVariableNames: 'editedTypes' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! !EditedType commentStamp: '' prior: 0! I represent a TypingResult in which the user has made changes.! !EditedType class methodsFor: 'instance creation' stamp: ' 7/9/05 23:28'! forInstvar: iv inClass: aClass types: aClassCollection ^(self forInstvar: iv inClass: aClass) editedTypes: aClassCollection! ! !EditedType methodsFor: 'private-accessing' stamp: ' 7/9/05 23:28'! editedTypes: aCollection editedTypes := aCollection. self triggerEvent: #changed! ! !EditedType methodsFor: 'testing' stamp: ' 7/9/05 23:28'! isEditedResult ^true! ! !EditedType methodsFor: 'testing' stamp: ' 7/9/05 23:28'! isExtractedResult ^false! ! !EditedType methodsFor: 'printing' stamp: ' 7/9/05 23:28'! printOn: aStream aStream nextPutAll: 'EditedType: '. self printTypesOn: aStream! ! !EditedType methodsFor: 'comparing' stamp: ' 7/9/05 23:28'! sameAs: aTypingResult "Return whether the receiver and the arguments are the same e.g. whether they have the same values for the interfaces, sends and extracted types." ^aTypingResult sameAsEditedType: self! ! !EditedType methodsFor: 'comparing-private' stamp: ' 7/9/05 23:28'! sameAsEditedType: anEditedTypingResult "Return whether the receiver and the arguments are the same e.g. whether they have the same values for the interfaces, sends and extracted types." ^self types sameElements: anEditedTypingResult types! ! !EditedType methodsFor: 'comparing-private' stamp: ' 7/9/05 23:28'! sameAsExtractedType: anExtractedTypingResult "Return whether the receiver and the arguments are the same e.g. whether they have the same values for the interfaces, sends and extracted types." ^self types sameElements: anExtractedTypingResult types! ! !EditedType methodsFor: 'accessing' stamp: ' 7/9/05 23:28'! types ^editedTypes! ! AbstractType subclass: #ExtractedType instanceVariableNames: 'interface assignments extractedTypes' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! !ExtractedType class methodsFor: 'instance creation' stamp: ' 7/9/05 23:28'! forInstvar: iv inClass: aClass interface: selectorCollection assignments: classCollection ^(self forInstvar: iv inClass: aClass) interface: selectorCollection assignments: classCollection! ! !ExtractedType methodsFor: 'private-accessing' stamp: ' 7/9/05 23:28'! addAssignment: anObject (self assignments includes: anObject) ifFalse: [self assignments add: anObject]! ! !ExtractedType methodsFor: 'private-accessing' stamp: ' 7/9/05 23:28'! addSend: anObject self interface add: anObject! ! !ExtractedType methodsFor: 'private-accessing' stamp: ' 7/9/05 23:28'! assignments ^assignments! ! !ExtractedType methodsFor: 'private-accessing' stamp: ' 7/9/05 23:28'! basicExtractedTypes ^extractedTypes! ! !ExtractedType methodsFor: 'private' stamp: ' 7/9/05 23:28'! 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: ' 7/9/05 23:28'! fold: interfaceClasses with: assignmentClasses | commonSuper | interfaceClasses remove: Object ifAbsent: []. "breaks constraint that all classes found are most abstract useful types!!" assignmentClasses do: [:each | commonSuper := interfaceClasses detect: [:sendResultClass | each includesBehavior: sendResultClass] ifNone: [nil]. commonSuper ifNotNil: [interfaceClasses remove: commonSuper; add: each ] ifNil: [ interfaceClasses copy detect: [:cl | cl includesBehavior: each] ifNone: [interfaceClasses add: each]]. ]. interfaceClasses isEmpty ifTrue: [interfaceClasses add: Object]. "Add again if nothing found" ^interfaceClasses asSortedCollection: [:cl1 :cl2 | cl1 name < cl2 name].! ! !ExtractedType methodsFor: 'testing' stamp: ' 7/9/05 23:28'! hasEmptyAssignments ^self assignments isEmpty! ! !ExtractedType methodsFor: 'testing' stamp: ' 7/9/05 23:28'! hasEmptyInterface ^self interface isEmpty! ! !ExtractedType methodsFor: 'initialize-release' stamp: ' 7/9/05 23:28'! initialize super initialize. self interface: IdentitySet new assignments: OrderedCollection new! ! !ExtractedType methodsFor: 'private-accessing' stamp: ' 7/9/05 23:28'! interface ^interface! ! !ExtractedType methodsFor: 'private-accessing' stamp: ' 7/9/05 23:28'! interface: selectorCollection assignments: classCollection interface := selectorCollection. assignments := classCollection! ! !ExtractedType methodsFor: 'testing' stamp: ' 7/9/05 23:28'! isEditedResult ^false! ! !ExtractedType methodsFor: 'testing' stamp: ' 7/9/05 23:28'! isEmpty ^self hasEmptyAssignments and: [self hasEmptyInterface]! ! !ExtractedType methodsFor: 'testing' stamp: ' 7/9/05 23:28'! isExtractedResult ^true! ! !ExtractedType methodsFor: 'printing' stamp: ' 7/9/05 23:28'! 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: ' 7/9/05 23:28'! printOn: aStream aStream nextPutAll: 'ExtractedType: '. self basicExtractedTypes ifNil: [self printInterfaceAndAssigmentsOn: aStream] ifNotNil: [self printTypesOn: aStream]! ! !ExtractedType methodsFor: 'private' stamp: ' 7/9/05 23:28'! rootsUnderstanding: selectors | initialClasses nextClasses traverseClassesStack next prototypeSet | 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: [traverseClassesStack := OrderedCollection with: initialClass. [traverseClassesStack isEmpty] whileFalse: [next := traverseClassesStack removeFirst. next nonMetaSubclassesDo: [:subcl | (subcl includesSelector: selector) ifTrue: [nextClasses add: subcl] ifFalse: [traverseClassesStack add: subcl]]]]]]. ^nextClasses! ! !ExtractedType methodsFor: 'comparing' stamp: ' 7/9/05 23:28'! sameAs: aTypingResult "Return whether the receiver and the arguments are the same e.g. whether they have the same values for the interfaces, sends and extracted types." ^aTypingResult sameAsExtractedType: self! ! !ExtractedType methodsFor: 'comparing-private' stamp: ' 7/9/05 23:28'! sameAsEditedType: anEditedTypingResult "Return whether the receiver and the arguments are the same e.g. whether they have the same values for the interfaces, sends and extracted types." ^self types sameElements: anEditedTypingResult types! ! !ExtractedType methodsFor: 'comparing-private' stamp: ' 7/9/05 23:28'! sameAsExtractedType: anExtractedTypingResult "Return whether the receiver and the arguments are the same e.g. whether they have the same values for the interfaces, sends and extracted types." ^(self assignments sameElements: anExtractedTypingResult assignments) and: [ (self interface sameElements: anExtractedTypingResult interface) and: [ (self basicExtractedTypes isNil and: [anExtractedTypingResult basicExtractedTypes isNil]) or: [self types sameElements: anExtractedTypingResult types]]]! ! !ExtractedType methodsFor: 'accessing' stamp: ' 7/9/05 23:28'! types ^extractedTypes ifNil: [extractedTypes := self fold: (self rootsUnderstanding: self interface) with: self cleanedAssignments] ifNotNil: [extractedTypes]! ! Object subclass: #AbstractTypeComparison instanceVariableNames: 'newResult existingResult' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! !AbstractTypeComparison class methodsFor: 'instance creation' stamp: ' 7/9/05 23:28'! existingResult: existingTypingResult newResult: newTypingResult ^self basicNew newResult: newTypingResult; existingResult: existingTypingResult; yourself! ! !AbstractTypeComparison class methodsFor: 'instance creation' stamp: ' 7/9/05 23:28'! new ^self shouldNotImplement! ! !AbstractTypeComparison methodsFor: 'accessing' stamp: ' 7/9/05 23:28'! existingResult ^existingResult! ! !AbstractTypeComparison methodsFor: 'accessing' stamp: ' 7/9/05 23:28'! existingResult: anObject existingResult := anObject! ! !AbstractTypeComparison methodsFor: 'printing' stamp: ' 7/9/05 23:28'! explanationString ^self subclassResponsibility! ! !AbstractTypeComparison methodsFor: 'testing' stamp: ' 7/9/05 23:28'! isConflict ^false! ! !AbstractTypeComparison methodsFor: 'accessing' stamp: ' 7/9/05 23:28'! ivarClass ^self newResult ivarClass! ! !AbstractTypeComparison methodsFor: 'accessing' stamp: ' 7/9/05 23:28'! ivarName ^self newResult ivarName! ! !AbstractTypeComparison methodsFor: 'accessing' stamp: ' 7/9/05 23:28'! newResult ^newResult! ! !AbstractTypeComparison methodsFor: 'accessing' stamp: ' 7/9/05 23:28'! newResult: anObject newResult := anObject! ! !AbstractTypeComparison methodsFor: 'testing' stamp: ' 7/9/05 23:28'! notConflict ^self isConflict not! ! AbstractTypeComparison subclass: #NoTypingConflict instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! !NoTypingConflict methodsFor: 'printing' stamp: ' 7/9/05 23:28'! explanationString ^'No conflict.'! ! !NoTypingConflict methodsFor: 'printing' stamp: ' 7/9/05 23:28'! printOn: aStream aStream nextPutAll: 'Type OK for '; nextPutAll: self ivarClass shortName; nextPutAll: ' - '; nextPutAll: self ivarName! ! AbstractTypeComparison subclass: #TypingConflict instanceVariableNames: 'conflictingSelectors conflictingAssignments' classVariableNames: '' poolDictionaries: '' category: 'RoelTyper-Core'! !TypingConflict class methodsFor: 'instance creation' stamp: ' 7/9/05 23:28'! existingResult: existingTypingResult newResult: newTypingResult conflictingSelectors: selectorsCollection conflictingAssignments: classCollection ^(self existingResult: existingTypingResult newResult: newTypingResult) conflictingSelectors: selectorsCollection conflictingAssignments: classCollection! ! !TypingConflict methodsFor: 'accessing' stamp: ' 7/9/05 23:28'! conflictingAssignments ^conflictingAssignments! ! !TypingConflict methodsFor: 'accessing' stamp: ' 7/9/05 23:28'! conflictingSelectors ^conflictingSelectors! ! !TypingConflict methodsFor: 'accessing' stamp: ' 7/9/05 23:28'! conflictingSelectors: selectorsCollection conflictingAssignments: classCollection conflictingSelectors := selectorsCollection. conflictingAssignments := classCollection! ! !TypingConflict methodsFor: 'printing' stamp: ' 7/9/05 23:28'! explanationString | str | str := WriteStream on: String new. self printSelectorsNotUnderstoodOn: str. self printAssignmentConflictsOn: str. ^str contents! ! !TypingConflict methodsFor: 'testing' stamp: ' 7/9/05 23:28'! isConflict ^true! ! !TypingConflict methodsFor: 'printing' stamp: ' 7/9/05 23:28'! printAssignmentConflictsOn: str self conflictingAssignments isEmpty ifFalse: [str nextPutAll: 'There are conflicts between assignments.']! ! !TypingConflict methodsFor: 'printing' stamp: ' 7/9/05 23:28'! printOn: aStream aStream nextPutAll: 'Type conflict for '; nextPutAll: self ivarClass shortName; nextPutAll: ' - '; nextPutAll: self ivarName! ! !TypingConflict methodsFor: 'printing' stamp: ' 7/9/05 23:28'! printSelectorsNotUnderstoodOn: str str nextPutAll: 'Following selector problems were found:'; crtab. self conflictingSelectors associations do: [:assoc | str print: assoc key; nextPutAll: ' not understood by: {'. assoc value do: [:cl | str print: cl] separatedBy: [str nextPut: $,]. str nextPut: $} ] separatedBy: [str nextPut: $,; crtab]. " | selectorsNotUnderstood | selectorsNotUnderstood := self conflictingSelectors keys. selectorsNotUnderstood isEmpty ifFalse: [str nextPutAll: 'Following selectors are not understood by existing type: '. selectorsNotUnderstood do: [:sel | str print: sel] separatedBy: [str nextPut: $,]. str nextPut: $.; cr]"! ! 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