Merge branch 'master', remote-tracking branch 'dale/master'

st/Compiler-Tests.st

@@ -0,0 +1,471 @@
+Smalltalk current createPackage: 'Compiler-Tests' properties: #{}!
+TestCase subclass: #ImporterTest
+	instanceVariableNames: ''
+	category: 'Compiler-Tests'!
+
+!ImporterTest methodsFor: 'private'!
+
+chunkString
+
+	^'!!Object methodsFor: ''importer test method''!!
+
+importerTestMethod
+
+	^''success''
+!! !!
+'
+!
+
+bigChunkString
+
+	^'Smalltalk current createPackage: ''Cypress-Definitions'' properties: #{}!!
+Object subclass: #CypressSnapshot
+	instanceVariableNames: ''definitions''
+	package: ''Cypress-Definitions''!!
+
+!!CypressSnapshot methodsFor: ''not yet classified''!!
+
+definitions: aDefinitions
+
+	definitions := aDefinitions
+!!
+
+definitions
+
+	^definitions
+!! !!
+
+!!CypressSnapshot class methodsFor: ''not yet classified''!!
+
+definitions: aDefinitions
+
+	^(self new) definitions: aDefinitions
+!! !!
+
+Object subclass: #CypressPackage
+	instanceVariableNames: ''name''
+	package: ''Cypress-Definitions''!!
+
+!!CypressPackage methodsFor: ''not yet classified''!!
+
+= other
+	^ other species = self species and: [other name sameAs: name]
+!!
+
+name
+	^ name
+!!
+
+name: aString
+	name := aString
+!!
+
+snapshot
+	| package definitions name  |
+	package := Package named: self name.
+	definitions := OrderedCollection new.
+	package sortedClasses do: [:cls |
+        	definitions add: cls asCypressClassDefinition.
+                cls methodDictionary values do: [:method |
+			(method category match: ''^\*'') ifFalse: [ 
+				definitions add: method asCypressMethodDefinition ]].
+                cls class methodDictionary values do: [:method |
+			(method category match: ''^\*'') ifFalse: [ 
+				definitions add: method asCypressMethodDefinition ]]].
+	name := package name.
+	Smalltalk current classes, (Smalltalk current classes collect: [:each | each class]) do: [:each |
+		each methodDictionary values do: [:method |
+			method category = (''*'', name) ifTrue: [
+				definitions add: method asCypressMethodDefinition ]]].
+	^ CypressSnapshot definitions: definitions
+!!
+
+printString
+	^super printString, ''('', name, '')''
+!! !!
+
+Object subclass: #CypressDefinition
+	instanceVariableNames: ''''
+	package: ''Cypress-Definitions''!!
+
+!!CypressDefinition methodsFor: ''not yet classified''!!
+
+= aDefinition
+	^(aDefinition isKindOf: CypressDefinition) and: [self isRevisionOf: aDefinition]
+!!
+
+isRevisionOf: aDefinition
+	^ (aDefinition isKindOf: CypressDefinition) and: [aDefinition description = self description]
+!!
+
+description
+	self subclassResponsibility
+!!
+
+isSameRevisionAs: aDefinition
+	^ self = aDefinition
+!! !!
+
+Object subclass: #CypressPatch
+	instanceVariableNames: ''operations''
+	package: ''Cypress-Definitions''!!
+
+!!CypressPatch methodsFor: ''not yet classified''!!
+
+fromBase: baseSnapshot toTarget: targetSnapshot
+	| base target |	
+	operations := OrderedCollection new.
+	base := CypressDefinitionIndex definitions: baseSnapshot definitions.
+	target := CypressDefinitionIndex definitions: targetSnapshot definitions.
+	
+	target definitions do:
+		[:t |
+		base
+			definitionLike: t
+			ifPresent: [:b | (b isSameRevisionAs: t) ifFalse: [operations add: (CypressModification of: b to: t)]]
+			ifAbsent: [operations add: (CypressAddition of: t)]].
+		
+	base definitions do:
+		[:b |
+		target
+			definitionLike: b
+			ifPresent: [:t | ]
+			ifAbsent: [operations add: (CypressRemoval of: b)]]
+!!
+
+operations
+
+	^operations
+!! !!
+
+!!CypressPatch class methodsFor: ''not yet classified''!!
+
+fromBase: baseSnapshot toTarget: targetSnapshot
+	^ (self new)
+		fromBase: baseSnapshot
+		toTarget: targetSnapshot
+!! !!
+
+Object subclass: #CypressDefinitionIndex
+	instanceVariableNames: ''definitionMap''
+	package: ''Cypress-Definitions''!!
+
+!!CypressDefinitionIndex methodsFor: ''not yet classified''!!
+
+add: aDefinition
+	^ self definitionMap at: aDefinition description put: aDefinition
+!!
+
+addAll: aCollection
+	aCollection do: [:ea | self add: ea]
+!!
+
+definitionLike: aDefinition ifPresent: foundBlock ifAbsent: errorBlock
+	| definition |
+	definition := self definitionMap at: aDefinition description ifAbsent: [].
+	^ definition
+		ifNil: errorBlock
+		ifNotNil: [foundBlock value: definition]
+!!
+
+definitions
+	^self definitionMap values
+!!
+
+definitionMap
+	definitionMap ifNil: [ definitionMap := Dictionary new ].
+	^ definitionMap
+!!
+
+remove: aDefinition
+	self definitionMap removeKey: aDefinition description ifAbsent: []
+!! !!
+
+!!CypressDefinitionIndex class methodsFor: ''not yet classified''!!
+
+definitions: aCollection
+	^ self new addAll: aCollection
+!! !!
+
+Object subclass: #CypressPatchOperation
+	instanceVariableNames: ''''
+	package: ''Cypress-Definitions''!!
+
+CypressDefinition subclass: #CypressClassDefinition
+	instanceVariableNames: ''name superclassName category comment instVarNames classInstVarNames''
+	package: ''Cypress-Definitions''!!
+
+!!CypressClassDefinition methodsFor: ''not yet classified''!!
+
+name: aClassName superclassName: aSuperclassName category: aCategory instVarNames: anInstanceVariableNames classInstVarNames: aClassInstanceVariableNames comment: aComment
+
+	name := aClassName.
+	superclassName := aSuperclassName.
+	category := aCategory.
+	instVarNames := anInstanceVariableNames.
+	classInstVarNames := aClassInstanceVariableNames.
+	comment := aComment
+!!
+
+= aDefinition
+	^(super = aDefinition)
+		and: [superclassName = aDefinition superclassName
+		and: [category = aDefinition category
+		and: [instVarNames = aDefinition instVarNames
+		and: [classInstVarNames = aDefinition classInstVarNames
+		and: [comment = aDefinition comment]]]]]
+!!
+
+superclassName
+
+	^superclassName
+!!
+
+name
+
+	^name
+!!
+
+category
+
+	^category
+!!
+
+comment
+
+	^comment
+!!
+
+description
+
+	^ Array with: name
+!!
+
+instVarNames
+
+	^instVarNames
+!!
+
+classInstVarNames
+
+	^classInstVarNames
+!! !!
+
+!!CypressClassDefinition class methodsFor: ''not yet classified''!!
+
+name: aClassName 
+superclassName: aSuperclassName
+category: aCategory
+instVarNames: anInstanceVariableNames
+classInstVarNames: aClassInstanceVariableNames
+comment: aComment
+
+	^(self new) 
+		name: aClassName 
+		superclassName: aSuperclassName
+		category: aCategory
+		instVarNames: anInstanceVariableNames
+		classInstVarNames: aClassInstanceVariableNames
+		comment: aComment
+!! !!
+
+CypressDefinition subclass: #CypressMethodDefinition
+	instanceVariableNames: ''classIsMeta source category selector className''
+	package: ''Cypress-Definitions''!!
+
+!!CypressMethodDefinition methodsFor: ''not yet classified''!!
+
+className: aName classIsMeta: isMetaclass selector: aSelector category: aCategory source: aSource
+
+	className := aName.
+	classIsMeta := isMetaclass.
+	selector := aSelector.
+	category := aCategory.
+	source := aSource.
+!!
+
+= aDefinition
+    ^ super = aDefinition
+        and: [ aDefinition source = self source
+                and: [ aDefinition category = self category ] ]
+!!
+
+source
+
+	^source
+!!
+
+category
+
+	^category
+!!
+
+description
+	^ Array	
+		with: className
+		with: selector
+		with: classIsMeta
+!! !!
+
+!!CypressMethodDefinition class methodsFor: ''not yet classified''!!
+
+className: aName
+classIsMeta: isMetaclass
+selector: aSelector
+category: aCategory
+source: aSource
+
+	^(self new)
+		className: aName
+		classIsMeta: isMetaclass
+		selector: aSelector
+		category: aCategory
+		source: aSource
+!! !!
+
+CypressPatchOperation subclass: #CypressAddition
+	instanceVariableNames: ''definition''
+	package: ''Cypress-Definitions''!!
+
+!!CypressAddition methodsFor: ''not yet classified''!!
+
+definition: aDefinition
+
+	definition := aDefinition
+!! !!
+
+!!CypressAddition class methodsFor: ''not yet classified''!!
+
+of: aDefinition
+	^ self new definition: aDefinition
+!! !!
+
+CypressPatchOperation subclass: #CypressModification
+	instanceVariableNames: ''obsoletion modification''
+	package: ''Cypress-Definitions''!!
+
+!!CypressModification methodsFor: ''not yet classified''!!
+
+base: base target: target
+
+	obsoletion := base.
+	modification := target.
+!! !!
+
+!!CypressModification class methodsFor: ''not yet classified''!!
+
+of: base to: target
+	^ self new base: base target: target
+!! !!
+
+CypressPatchOperation subclass: #CypressRemoval
+	instanceVariableNames: ''definition''
+	package: ''Cypress-Definitions''!!
+
+!!CypressRemoval methodsFor: ''not yet classified''!!
+
+definition: aDefinition
+
+	definition := aDefinition
+!! !!
+
+!!CypressRemoval class methodsFor: ''not yet classified''!!
+
+of: aDefinition
+	^ self new definition: aDefinition
+!! !!
+
+!!Object methodsFor: ''*Cypress-Definitions''!!
+
+species
+
+	^self class
+!! !!
+
+!!Class methodsFor: ''*Cypress-Definitions''!!
+
+asCypressClassDefinition
+	^CypressClassDefinition
+		name: self name
+		superclassName: self superclass name
+		category: self category 
+		instVarNames: self instanceVariableNames
+		classInstVarNames: self class instanceVariableNames
+		comment: self comment
+!! !!
+
+!!CompiledMethod methodsFor: ''*Cypress-Definitions''!!
+
+asCypressMethodDefinition
+
+	^CypressMethodDefinition 
+        	className: self methodClass name
+		classIsMeta: self methodClass isMetaclass
+		selector: self selector
+		category: self category
+		source: self source
+!! !!
+
+!!CharacterArray methodsFor: ''*Cypress-Definitions''!!
+
+sameAs: aString
+
+	^self asUppercase = aString asUppercase
+!! !!
+
+'
+! !
+
+!ImporterTest methodsFor: 'running'!
+
+setUp
+
+	super setUp.
+	self cleanUp
+!
+
+tearDown
+
+	super tearDown.
+	self cleanUp
+!
+
+cleanUp
+
+	(Object methodDictionary includesKey: #importerTestMethod)
+		ifTrue: [ Object removeCompiledMethod: (Object methodAt: #importerTestMethod)].
+! !
+
+!ImporterTest methodsFor: 'tests'!
+
+testBigChunkString
+	"importer does not correctly add extension methods.
+
+	 After loading in AmberProjectImporter, the following import fails...get a MNU from `CypressPackage new species`:
+
+    		AmberProjectImporter
+			importSTPackage: 'Cypress-Definitions' 
+			prefix: 'tests/'.
+
+		CypressPackage new species. 
+
+	WARNING this guy isn't cleaned up automatically"
+
+	Importer new import: self bigChunkString readStream.
+	CypressPackage new species.
+!
+
+testChunkString
+
+	Importer new import: self chunkString readStream.
+	self assert: (Object methodDictionary includesKey: 'importerTestMethod').
+	self assert: (Object new importerTestMethod = 'success').
+! !
+
+!Object methodsFor: '*Compiler-Tests'!
+
+importerLoadMethod
+
+	^'success'
+! !
+