From c4e7016743defdfecfb2f97d7a980ad11cdf4a06 Mon Sep 17 00:00:00 2001 From: Lionel Akue Date: Fri, 25 Jan 2019 14:28:08 +0100 Subject: [PATCH 0001/1076] Enhance queryLocal:For:in: --- src/Moose-Core/MooseEntity.class.st | 7 +++++++ src/Moose-Core/Trait.extension.st | 7 +++++++ src/Moose-Query/MooseQueryCalculator.class.st | 6 +++++- 3 files changed, 19 insertions(+), 1 deletion(-) diff --git a/src/Moose-Core/MooseEntity.class.st b/src/Moose-Core/MooseEntity.class.st index c46c3f2d8..c6e14f1ee 100644 --- a/src/Moose-Core/MooseEntity.class.st +++ b/src/Moose-Core/MooseEntity.class.st @@ -169,6 +169,13 @@ MooseEntity class >> implementingClassesIn: aMetamodel [ ^ { self } ] +{ #category : #'as yet unclassified' } +MooseEntity class >> inheritsFromType: aClassFAMIX [ + ^ ({self} , self usedStatefulTraits + flatCollect: #withAllSuperclasses + as: Set) includes: aClassFAMIX +] + { #category : #constants } MooseEntity class >> mooseDev [ "Answer the email address of the Moose mailinglist." diff --git a/src/Moose-Core/Trait.extension.st b/src/Moose-Core/Trait.extension.st index ec5a29edd..7390fe1e1 100644 --- a/src/Moose-Core/Trait.extension.st +++ b/src/Moose-Core/Trait.extension.st @@ -1,5 +1,12 @@ Extension { #name : #Trait } +{ #category : #'*Moose-Core' } +Trait >> inheritsFromType: aClassFAMIX [ + ^ ({self} , self traits + flatCollect: #withAllSuperclasses + as: Set) includes: aClassFAMIX +] + { #category : #'*Moose-Core' } Trait >> withMooseSubclasses [ diff --git a/src/Moose-Query/MooseQueryCalculator.class.st b/src/Moose-Query/MooseQueryCalculator.class.st index 1689408a8..8f62abcda 100644 --- a/src/Moose-Query/MooseQueryCalculator.class.st +++ b/src/Moose-Query/MooseQueryCalculator.class.st @@ -111,7 +111,11 @@ MooseQueryCalculator >> queryLocal: aFAMIXClassAssociation for: anEntity in: aCo | properties | "Instead of #to:do: we could just use #do: but this implementation is much faster. Maybe sista will remove the needs of the todo later." - 1 to: (properties := self strategy msePropertiesOf: anEntity) size do: [ :ind | (anEntity perform: (properties at: ind) name) ifNotNil: [ :coll | aCollection addAll: (coll asCollection select: [ :each | each isOfType: aFAMIXClassAssociation ]) ] ]. + + properties := (self strategy msePropertiesOf: anEntity) select: [:each | aFAMIXClassAssociation inheritsFromType: each type implementingClass]. + + + 1 to: properties size do: [ :ind | (anEntity perform: (properties at: ind) name) ifNotNil: [ :coll | aCollection addAll: (coll asCollection select: [ :each | each isOfType: aFAMIXClassAssociation ]) ] ]. ^ aCollection ] From 8d385cfebd035a2343c22e8cb6a51b8d860042da Mon Sep 17 00:00:00 2001 From: Lionel Akue Date: Fri, 25 Jan 2019 15:39:48 +0100 Subject: [PATCH 0002/1076] --- src/Moose-Query-Test/MooseQueryTest.class.st | 19 ++++++++++ ...oseQueryAbstractDirectionStrategy.class.st | 7 ++++ src/Moose-Query/MooseQueryCalculator.class.st | 35 +++++++++++++++++++ ...oseQueryIncomingDirectionStrategy.class.st | 7 ++++ ...oseQueryOutgoingDirectionStrategy.class.st | 7 ++++ src/Moose-Query/TDependencyQueries.trait.st | 24 +++++++++++++ 6 files changed, 99 insertions(+) diff --git a/src/Moose-Query-Test/MooseQueryTest.class.st b/src/Moose-Query-Test/MooseQueryTest.class.st index cc03b0e94..eac0346e4 100644 --- a/src/Moose-Query-Test/MooseQueryTest.class.st +++ b/src/Moose-Query-Test/MooseQueryTest.class.st @@ -333,6 +333,25 @@ MooseQueryTest >> testQueryWith [ self assert: (package1 query: #out with: FamixTInvocation) size equals: 1. ] +{ #category : #tests } +MooseQueryTest >> testSourceThroughInvocation [ + + self assertCollection: (method2 sourceThrough: FamixTInvocation) storage flattened hasSameElements: {method2 . method1 . method3}. + self assertCollection: (method2 sourceThrough: FamixTInvocation) hasSameElements: ((method2 queryIncoming: FamixTInvocation) collect: #from). + self assertCollection: (class2 sourceThrough: FamixTInvocation) storage flattened hasSameElements: {method2 . method1 . method3}. + +] + +{ #category : #tests } +MooseQueryTest >> testTargetThroughInvocation [ + + self assertCollection: (method1 targetThrough: FamixTInvocation) storage flattened hasSameElements: {method2}. + self assertCollection: (method1 targetThrough: FamixTInvocation) hasSameElements: ((method1 queryOutgoing: FamixTInvocation) collect: #to). + self assertCollection: (class2 targetThrough: FamixTInvocation) storage flattened hasSameElements: {method2}. + + +] + { #category : #tests } MooseQueryTest >> testToScope [ self assertCollection: (class1 toScope: FAMIXMethod) hasSameElements: {method1}. diff --git a/src/Moose-Query/MooseQueryAbstractDirectionStrategy.class.st b/src/Moose-Query/MooseQueryAbstractDirectionStrategy.class.st index 7e3709e2f..cf8773b93 100644 --- a/src/Moose-Query/MooseQueryAbstractDirectionStrategy.class.st +++ b/src/Moose-Query/MooseQueryAbstractDirectionStrategy.class.st @@ -52,3 +52,10 @@ MooseQueryAbstractDirectionStrategy class >> msePropertiesOf: anEntity [ MooseQueryAbstractDirectionStrategy class >> queryResultOn: anEntity with: aCollection [ ^ self subclassResponsibility ] + +{ #category : #accessing } +MooseQueryAbstractDirectionStrategy class >> symbolToCollectEntities [ + "I should return a Symbol to collect entities. For example an Incoming direction will have #source as symbol to collect entities." + + ^ self subclassResponsibility +] diff --git a/src/Moose-Query/MooseQueryCalculator.class.st b/src/Moose-Query/MooseQueryCalculator.class.st index 8f62abcda..10b397f94 100644 --- a/src/Moose-Query/MooseQueryCalculator.class.st +++ b/src/Moose-Query/MooseQueryCalculator.class.st @@ -128,3 +128,38 @@ MooseQueryCalculator >> strategy [ MooseQueryCalculator >> strategy: anObject [ strategy := anObject ] + +{ #category : #query } +MooseQueryCalculator >> through: aFAMIXClassAssociation for: anEntity [ + ^ self strategy + queryResultOn: anEntity + with: (self through: aFAMIXClassAssociation for: anEntity in: OrderedCollection new) asSet +] + +{ #category : #query } +MooseQueryCalculator >> through: aFAMIXClassAssociation for: anEntity in: aCollection [ + | selectors | + self throughLocal: aFAMIXClassAssociation for: anEntity in: aCollection. + 1 to: (selectors := anEntity childrenSelectors) size do: [ :index | + (anEntity perform: (selectors at: index)) + ifNotNil: [ :children | + | coll | + 1 to: (coll := children asCollection) size do: [ :i | self through: aFAMIXClassAssociation for: (coll at: i) in: aCollection ] ] ]. + ^ aCollection +] + +{ #category : #query } +MooseQueryCalculator >> throughLocal: aFAMIXClassAssociation for: anEntity in: aCollection [ + "The goal here is to get all the entity's direct associations of the class in parameter. This will not check the associations of the entity's children." + + "Note: Maybe adding a guard to check if the entity can have associations of this class could improve the perf. Currently it is not the case because there is not enough association. Maybe it could be the case in the futur, like with a PostgreSQL model." + + | properties | + "Instead of #to:do: we could just use #do: but this implementation is much faster. Maybe sista will remove the needs of the todo later." + + properties := (self strategy msePropertiesOf: anEntity) select: [:each | aFAMIXClassAssociation inheritsFromType: each type implementingClass]. + + + 1 to: properties size do: [ :ind | (anEntity perform: (properties at: ind) name) ifNotNil: [ :coll | aCollection addAll: (coll asCollection select: [ :each | each isOfType: aFAMIXClassAssociation ] thenCollect: [ :each | each perform: self strategy symbolToCollectEntities ] ) ] ]. + ^ aCollection +] diff --git a/src/Moose-Query/MooseQueryIncomingDirectionStrategy.class.st b/src/Moose-Query/MooseQueryIncomingDirectionStrategy.class.st index f8e88c667..219cbeb87 100644 --- a/src/Moose-Query/MooseQueryIncomingDirectionStrategy.class.st +++ b/src/Moose-Query/MooseQueryIncomingDirectionStrategy.class.st @@ -34,3 +34,10 @@ MooseQueryIncomingDirectionStrategy class >> msePropertiesOf: anEntity [ MooseQueryIncomingDirectionStrategy class >> queryResultOn: anEntity with: aCollection [ ^ anEntity createIncomingQueryResultWith: aCollection ] + +{ #category : #accessing } +MooseQueryIncomingDirectionStrategy class >> symbolToCollectEntities [ + "I should return a Symbol to collect entities. For example an Incoming direction will have #from as symbol to collect entities." + + ^ #from +] diff --git a/src/Moose-Query/MooseQueryOutgoingDirectionStrategy.class.st b/src/Moose-Query/MooseQueryOutgoingDirectionStrategy.class.st index ed835146f..f260d9222 100644 --- a/src/Moose-Query/MooseQueryOutgoingDirectionStrategy.class.st +++ b/src/Moose-Query/MooseQueryOutgoingDirectionStrategy.class.st @@ -34,3 +34,10 @@ MooseQueryOutgoingDirectionStrategy class >> msePropertiesOf: anEntity [ MooseQueryOutgoingDirectionStrategy class >> queryResultOn: anEntity with: aCollection [ ^ anEntity createOutgoingQueryResultWith: aCollection ] + +{ #category : #accessing } +MooseQueryOutgoingDirectionStrategy class >> symbolToCollectEntities [ + "I should return a Symbol to collect entities. For example an Incoming direction will have #from as symbol to collect entities." + + ^ #to +] diff --git a/src/Moose-Query/TDependencyQueries.trait.st b/src/Moose-Query/TDependencyQueries.trait.st index 01a03400f..c1b17a24a 100644 --- a/src/Moose-Query/TDependencyQueries.trait.st +++ b/src/Moose-Query/TDependencyQueries.trait.st @@ -343,3 +343,27 @@ TDependencyQueries >> queryOutgoingTypeDeclarationsIn: aCollection [ aCollection addAll: self outgoingTypeDeclarations. ^ aCollection ] + +{ #category : #'moosequery-queries-generic' } +TDependencyQueries >> sourceThrough: aFAMIXClassAssociation [ + "Collect the source of the FAMIXClassAssociation class for the receiver and its children. + + Example: + aFAMIXClass sourceThrough: FAMIXReference. + --> Will return a MooseIncomingQueryResult containing the methods having aFAMIXClass or its children as source + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) through: aFAMIXClassAssociation for: self +] + +{ #category : #'moosequery-queries-generic' } +TDependencyQueries >> targetThrough: aFAMIXClassAssociation [ + "Collect the target of the FAMIXClassAssociation class for the receiver and its children. + + Example: + aFAMIXMethod sourceThrough: FAMIXReference. + --> Will return a MooseIncomingQueryResult containing the class having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryOutgoingDirectionStrategy) through: aFAMIXClassAssociation for: self +] From 8ec2867ea16fbb1de17aee22264549be91a3d592 Mon Sep 17 00:00:00 2001 From: Lionel Akue Date: Fri, 25 Jan 2019 17:09:50 +0100 Subject: [PATCH 0003/1076] --- .../FAMIXAnnotationInstance.class.st | 24 +++++++++ .../FAMIXAnnotationInstanceAttribute.class.st | 12 +++++ .../FAMIXContainerEntity.class.st | 12 +++++ .../FAMIXNamedEntity.class.st | 12 +++++ .../FAMIXSourceAnchor.class.st | 12 +++++ .../FamixJavaAnnotationInstance.class.st | 12 +++++ ...ixJavaAnnotationInstanceAttribute.class.st | 12 +++++ .../FamixJavaContainerEntity.class.st | 12 +++++ .../FamixJavaNamedEntity.class.st | 12 +++++ .../FamixJavaSourceAnchor.class.st | 12 +++++ .../FamixStAnnotationInstance.class.st | 12 +++++ ...amixStAnnotationInstanceAttribute.class.st | 12 +++++ .../FamixStContainerEntity.class.st | 12 +++++ .../FamixStNamedEntity.class.st | 12 +++++ .../FamixStSourceAnchor.class.st | 12 +++++ .../FamixTest1NamedEntity.class.st | 12 +++++ .../FamixTest1SourceAnchor.class.st | 12 +++++ .../FamixTest2NamedEntity.class.st | 12 +++++ .../FamixTest2SourceAnchor.class.st | 12 +++++ .../FamixTest3NamedEntity.class.st | 12 +++++ .../FamixTest3SourceAnchor.class.st | 12 +++++ .../FamixTestComposed1CustomEntity5.class.st | 12 +++++ .../FamixTestComposed1NamedEntity.class.st | 12 +++++ .../FamixTestComposed1SourceAnchor.class.st | 12 +++++ .../FamixTestComposed2CustomEntity5.class.st | 12 +++++ .../FamixTestComposed2NamedEntity.class.st | 12 +++++ .../FamixTestComposed2SourceAnchor.class.st | 12 +++++ src/Moose-Query-Test/MooseQueryTest.class.st | 24 +++++++++ src/Moose-Query/MooseQueryCalculator.class.st | 51 +++++++++++++++++++ src/Moose-Query/TDependencyQueries.trait.st | 36 +++++++++++++ src/Moose-Query/TOODependencyQueries.trait.st | 12 +++++ 31 files changed, 459 insertions(+) diff --git a/src/Famix-Compatibility-Entities/FAMIXAnnotationInstance.class.st b/src/Famix-Compatibility-Entities/FAMIXAnnotationInstance.class.st index 12ef5e559..d049d7d27 100644 --- a/src/Famix-Compatibility-Entities/FAMIXAnnotationInstance.class.st +++ b/src/Famix-Compatibility-Entities/FAMIXAnnotationInstance.class.st @@ -80,3 +80,27 @@ FAMIXAnnotationInstance >> name [ << (self annotationType ifNil: [ super name ] ifNotNil: [ :type | type name ]) << ' on ' << (self annotatedEntity ifNotNil: #name ifNil: [ 'undefined' ]) ] ] + +{ #category : #'moosequery-queries-generic' } +FAMIXAnnotationInstance >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] + +{ #category : #'moosequery-queries-generic' } +FAMIXAnnotationInstance >> throughAllTo [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryOutgoingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-Compatibility-Entities/FAMIXAnnotationInstanceAttribute.class.st b/src/Famix-Compatibility-Entities/FAMIXAnnotationInstanceAttribute.class.st index 5faecfb2e..fc1409f8a 100644 --- a/src/Famix-Compatibility-Entities/FAMIXAnnotationInstanceAttribute.class.st +++ b/src/Famix-Compatibility-Entities/FAMIXAnnotationInstanceAttribute.class.st @@ -64,3 +64,15 @@ FAMIXAnnotationInstanceAttribute >> name [ ifTrue: [ self annotationTypeAttribute name ] ifFalse: [ nil ] ] + +{ #category : #'moosequery-queries-generic' } +FAMIXAnnotationInstanceAttribute >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-Compatibility-Entities/FAMIXContainerEntity.class.st b/src/Famix-Compatibility-Entities/FAMIXContainerEntity.class.st index fba9b218a..818179735 100644 --- a/src/Famix-Compatibility-Entities/FAMIXContainerEntity.class.st +++ b/src/Famix-Compatibility-Entities/FAMIXContainerEntity.class.st @@ -82,3 +82,15 @@ FAMIXContainerEntity >> numberOfChildren [ ^ self children size ] + +{ #category : #'moosequery-queries-generic' } +FAMIXContainerEntity >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-Compatibility-Entities/FAMIXNamedEntity.class.st b/src/Famix-Compatibility-Entities/FAMIXNamedEntity.class.st index b25047087..0e32151c0 100644 --- a/src/Famix-Compatibility-Entities/FAMIXNamedEntity.class.st +++ b/src/Famix-Compatibility-Entities/FAMIXNamedEntity.class.st @@ -107,6 +107,18 @@ FAMIXNamedEntity >> stubFormattedName [ ifFalse: [ Text fromString: self name ] ] +{ #category : #'moosequery-queries-generic' } +FAMIXNamedEntity >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] + { #category : #'moosechef-scoping-filtering' } FAMIXNamedEntity >> typeScope [ "Empty default scope" diff --git a/src/Famix-Compatibility-Entities/FAMIXSourceAnchor.class.st b/src/Famix-Compatibility-Entities/FAMIXSourceAnchor.class.st index 8d1b999b5..22eea63bd 100644 --- a/src/Famix-Compatibility-Entities/FAMIXSourceAnchor.class.st +++ b/src/Famix-Compatibility-Entities/FAMIXSourceAnchor.class.st @@ -172,3 +172,15 @@ FAMIXSourceAnchor >> querySureOutgoingInvocations [ FAMIXSourceAnchor >> sourceText [ ^ self subclassResponsibility ] + +{ #category : #'moosequery-queries-generic' } +FAMIXSourceAnchor >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-Java-Entities/FamixJavaAnnotationInstance.class.st b/src/Famix-Java-Entities/FamixJavaAnnotationInstance.class.st index aaf4ea70b..593b27056 100644 --- a/src/Famix-Java-Entities/FamixJavaAnnotationInstance.class.st +++ b/src/Famix-Java-Entities/FamixJavaAnnotationInstance.class.st @@ -80,3 +80,15 @@ FamixJavaAnnotationInstance >> name [ << (self annotationType ifNil: [ super name ] ifNotNil: [ :type | type name ]) << ' on ' << (self annotatedEntity ifNotNil: #name ifNil: [ 'undefined' ]) ] ] + +{ #category : #'moosequery-queries-generic' } +FamixJavaAnnotationInstance >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-Java-Entities/FamixJavaAnnotationInstanceAttribute.class.st b/src/Famix-Java-Entities/FamixJavaAnnotationInstanceAttribute.class.st index 49a5da1f6..5e7fb1a93 100644 --- a/src/Famix-Java-Entities/FamixJavaAnnotationInstanceAttribute.class.st +++ b/src/Famix-Java-Entities/FamixJavaAnnotationInstanceAttribute.class.st @@ -64,3 +64,15 @@ FamixJavaAnnotationInstanceAttribute >> name [ ifTrue: [ self annotationTypeAttribute name ] ifFalse: [ nil ] ] + +{ #category : #'moosequery-queries-generic' } +FamixJavaAnnotationInstanceAttribute >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-Java-Entities/FamixJavaContainerEntity.class.st b/src/Famix-Java-Entities/FamixJavaContainerEntity.class.st index fe4de2956..82078031e 100644 --- a/src/Famix-Java-Entities/FamixJavaContainerEntity.class.st +++ b/src/Famix-Java-Entities/FamixJavaContainerEntity.class.st @@ -77,3 +77,15 @@ FamixJavaContainerEntity >> numberOfChildren [ ^ self children size ] + +{ #category : #'moosequery-queries-generic' } +FamixJavaContainerEntity >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-Java-Entities/FamixJavaNamedEntity.class.st b/src/Famix-Java-Entities/FamixJavaNamedEntity.class.st index beb834515..f0aa4ee62 100644 --- a/src/Famix-Java-Entities/FamixJavaNamedEntity.class.st +++ b/src/Famix-Java-Entities/FamixJavaNamedEntity.class.st @@ -103,6 +103,18 @@ FamixJavaNamedEntity >> stubFormattedName [ ifFalse: [ Text fromString: self name ] ] +{ #category : #'moosequery-queries-generic' } +FamixJavaNamedEntity >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] + { #category : #'as yet unclassified' } FamixJavaNamedEntity >> typeScope [ "Empty default scope" diff --git a/src/Famix-Java-Entities/FamixJavaSourceAnchor.class.st b/src/Famix-Java-Entities/FamixJavaSourceAnchor.class.st index 75ed2a845..88bedff2c 100644 --- a/src/Famix-Java-Entities/FamixJavaSourceAnchor.class.st +++ b/src/Famix-Java-Entities/FamixJavaSourceAnchor.class.st @@ -157,3 +157,15 @@ FamixJavaSourceAnchor >> querySureOutgoingInvocations [ FamixJavaSourceAnchor >> sourceText [ ^ self subclassResponsibility ] + +{ #category : #'moosequery-queries-generic' } +FamixJavaSourceAnchor >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-PharoSmalltalk-Entities/FamixStAnnotationInstance.class.st b/src/Famix-PharoSmalltalk-Entities/FamixStAnnotationInstance.class.st index f805a385b..2e8119ddf 100644 --- a/src/Famix-PharoSmalltalk-Entities/FamixStAnnotationInstance.class.st +++ b/src/Famix-PharoSmalltalk-Entities/FamixStAnnotationInstance.class.st @@ -66,3 +66,15 @@ FamixStAnnotationInstance >> name [ << (self annotationType ifNil: [ super name ] ifNotNil: [ :type | type name ]) << ' on ' << (self annotatedEntity ifNotNil: #name ifNil: [ 'undefined' ]) ] ] + +{ #category : #'moosequery-queries-generic' } +FamixStAnnotationInstance >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-PharoSmalltalk-Entities/FamixStAnnotationInstanceAttribute.class.st b/src/Famix-PharoSmalltalk-Entities/FamixStAnnotationInstanceAttribute.class.st index 274c99c88..e6a7f1aa1 100644 --- a/src/Famix-PharoSmalltalk-Entities/FamixStAnnotationInstanceAttribute.class.st +++ b/src/Famix-PharoSmalltalk-Entities/FamixStAnnotationInstanceAttribute.class.st @@ -64,3 +64,15 @@ FamixStAnnotationInstanceAttribute >> name [ ifTrue: [ self annotationTypeAttribute name ] ifFalse: [ nil ] ] + +{ #category : #'moosequery-queries-generic' } +FamixStAnnotationInstanceAttribute >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-PharoSmalltalk-Entities/FamixStContainerEntity.class.st b/src/Famix-PharoSmalltalk-Entities/FamixStContainerEntity.class.st index 40886dfca..c2b81f389 100644 --- a/src/Famix-PharoSmalltalk-Entities/FamixStContainerEntity.class.st +++ b/src/Famix-PharoSmalltalk-Entities/FamixStContainerEntity.class.st @@ -43,3 +43,15 @@ FamixStContainerEntity >> numberOfChildren [ ^ self children size ] + +{ #category : #'moosequery-queries-generic' } +FamixStContainerEntity >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-PharoSmalltalk-Entities/FamixStNamedEntity.class.st b/src/Famix-PharoSmalltalk-Entities/FamixStNamedEntity.class.st index 03823040a..1c8934950 100644 --- a/src/Famix-PharoSmalltalk-Entities/FamixStNamedEntity.class.st +++ b/src/Famix-PharoSmalltalk-Entities/FamixStNamedEntity.class.st @@ -72,3 +72,15 @@ FamixStNamedEntity >> stubFormattedName [ attribute: TextEmphasis italic ] ifFalse: [ Text fromString: self name ] ] + +{ #category : #'moosequery-queries-generic' } +FamixStNamedEntity >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-PharoSmalltalk-Entities/FamixStSourceAnchor.class.st b/src/Famix-PharoSmalltalk-Entities/FamixStSourceAnchor.class.st index fd72e12cd..c750995ea 100644 --- a/src/Famix-PharoSmalltalk-Entities/FamixStSourceAnchor.class.st +++ b/src/Famix-PharoSmalltalk-Entities/FamixStSourceAnchor.class.st @@ -75,3 +75,15 @@ FamixStSourceAnchor >> pharoEntity: anObject [ FamixStSourceAnchor >> sourceText [ ^ self pharoEntity ifNotNil: #definition ] + +{ #category : #'moosequery-queries-generic' } +FamixStSourceAnchor >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-Test1-Entities/FamixTest1NamedEntity.class.st b/src/Famix-Test1-Entities/FamixTest1NamedEntity.class.st index fb85e4f1a..a93de73b5 100644 --- a/src/Famix-Test1-Entities/FamixTest1NamedEntity.class.st +++ b/src/Famix-Test1-Entities/FamixTest1NamedEntity.class.st @@ -42,3 +42,15 @@ FamixTest1NamedEntity class >> requirements [ ^ { } ] + +{ #category : #'moosequery-queries-generic' } +FamixTest1NamedEntity >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-Test1-Entities/FamixTest1SourceAnchor.class.st b/src/Famix-Test1-Entities/FamixTest1SourceAnchor.class.st index 1f096dca8..973bd3e71 100644 --- a/src/Famix-Test1-Entities/FamixTest1SourceAnchor.class.st +++ b/src/Famix-Test1-Entities/FamixTest1SourceAnchor.class.st @@ -34,3 +34,15 @@ FamixTest1SourceAnchor class >> requirements [ ^ { } ] + +{ #category : #'moosequery-queries-generic' } +FamixTest1SourceAnchor >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-Test2-Entities/FamixTest2NamedEntity.class.st b/src/Famix-Test2-Entities/FamixTest2NamedEntity.class.st index 418673d52..179457507 100644 --- a/src/Famix-Test2-Entities/FamixTest2NamedEntity.class.st +++ b/src/Famix-Test2-Entities/FamixTest2NamedEntity.class.st @@ -34,3 +34,15 @@ FamixTest2NamedEntity class >> requirements [ ^ { } ] + +{ #category : #'moosequery-queries-generic' } +FamixTest2NamedEntity >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-Test2-Entities/FamixTest2SourceAnchor.class.st b/src/Famix-Test2-Entities/FamixTest2SourceAnchor.class.st index d1509a968..72d663fdd 100644 --- a/src/Famix-Test2-Entities/FamixTest2SourceAnchor.class.st +++ b/src/Famix-Test2-Entities/FamixTest2SourceAnchor.class.st @@ -34,3 +34,15 @@ FamixTest2SourceAnchor class >> requirements [ ^ { } ] + +{ #category : #'moosequery-queries-generic' } +FamixTest2SourceAnchor >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-Test3-Entities/FamixTest3NamedEntity.class.st b/src/Famix-Test3-Entities/FamixTest3NamedEntity.class.st index 6e51dfff4..9754bf992 100644 --- a/src/Famix-Test3-Entities/FamixTest3NamedEntity.class.st +++ b/src/Famix-Test3-Entities/FamixTest3NamedEntity.class.st @@ -34,3 +34,15 @@ FamixTest3NamedEntity class >> requirements [ ^ { } ] + +{ #category : #'moosequery-queries-generic' } +FamixTest3NamedEntity >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-Test3-Entities/FamixTest3SourceAnchor.class.st b/src/Famix-Test3-Entities/FamixTest3SourceAnchor.class.st index 457316738..9b0f6c55c 100644 --- a/src/Famix-Test3-Entities/FamixTest3SourceAnchor.class.st +++ b/src/Famix-Test3-Entities/FamixTest3SourceAnchor.class.st @@ -34,3 +34,15 @@ FamixTest3SourceAnchor class >> requirements [ ^ { } ] + +{ #category : #'moosequery-queries-generic' } +FamixTest3SourceAnchor >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-TestComposedSubmetamodel1-Entities/FamixTestComposed1CustomEntity5.class.st b/src/Famix-TestComposedSubmetamodel1-Entities/FamixTestComposed1CustomEntity5.class.st index 08d655fc6..e6ea8bb20 100644 --- a/src/Famix-TestComposedSubmetamodel1-Entities/FamixTestComposed1CustomEntity5.class.st +++ b/src/Famix-TestComposedSubmetamodel1-Entities/FamixTestComposed1CustomEntity5.class.st @@ -34,3 +34,15 @@ FamixTestComposed1CustomEntity5 class >> requirements [ ^ { } ] + +{ #category : #'moosequery-queries-generic' } +FamixTestComposed1CustomEntity5 >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-TestComposedSubmetamodel1-Entities/FamixTestComposed1NamedEntity.class.st b/src/Famix-TestComposedSubmetamodel1-Entities/FamixTestComposed1NamedEntity.class.st index 9a18e6ba5..892e96b96 100644 --- a/src/Famix-TestComposedSubmetamodel1-Entities/FamixTestComposed1NamedEntity.class.st +++ b/src/Famix-TestComposedSubmetamodel1-Entities/FamixTestComposed1NamedEntity.class.st @@ -34,3 +34,15 @@ FamixTestComposed1NamedEntity class >> requirements [ ^ { } ] + +{ #category : #'moosequery-queries-generic' } +FamixTestComposed1NamedEntity >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-TestComposedSubmetamodel1-Entities/FamixTestComposed1SourceAnchor.class.st b/src/Famix-TestComposedSubmetamodel1-Entities/FamixTestComposed1SourceAnchor.class.st index 682c8941c..3e2204d2c 100644 --- a/src/Famix-TestComposedSubmetamodel1-Entities/FamixTestComposed1SourceAnchor.class.st +++ b/src/Famix-TestComposedSubmetamodel1-Entities/FamixTestComposed1SourceAnchor.class.st @@ -34,3 +34,15 @@ FamixTestComposed1SourceAnchor class >> requirements [ ^ { } ] + +{ #category : #'moosequery-queries-generic' } +FamixTestComposed1SourceAnchor >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-TestComposedSubmetamodel2-Entities/FamixTestComposed2CustomEntity5.class.st b/src/Famix-TestComposedSubmetamodel2-Entities/FamixTestComposed2CustomEntity5.class.st index d6ab206e2..5c2c725b2 100644 --- a/src/Famix-TestComposedSubmetamodel2-Entities/FamixTestComposed2CustomEntity5.class.st +++ b/src/Famix-TestComposedSubmetamodel2-Entities/FamixTestComposed2CustomEntity5.class.st @@ -34,3 +34,15 @@ FamixTestComposed2CustomEntity5 class >> requirements [ ^ { } ] + +{ #category : #'moosequery-queries-generic' } +FamixTestComposed2CustomEntity5 >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-TestComposedSubmetamodel2-Entities/FamixTestComposed2NamedEntity.class.st b/src/Famix-TestComposedSubmetamodel2-Entities/FamixTestComposed2NamedEntity.class.st index a229be776..cef360c21 100644 --- a/src/Famix-TestComposedSubmetamodel2-Entities/FamixTestComposed2NamedEntity.class.st +++ b/src/Famix-TestComposedSubmetamodel2-Entities/FamixTestComposed2NamedEntity.class.st @@ -34,3 +34,15 @@ FamixTestComposed2NamedEntity class >> requirements [ ^ { } ] + +{ #category : #'moosequery-queries-generic' } +FamixTestComposed2NamedEntity >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Famix-TestComposedSubmetamodel2-Entities/FamixTestComposed2SourceAnchor.class.st b/src/Famix-TestComposedSubmetamodel2-Entities/FamixTestComposed2SourceAnchor.class.st index ec6416713..07c5b4ba1 100644 --- a/src/Famix-TestComposedSubmetamodel2-Entities/FamixTestComposed2SourceAnchor.class.st +++ b/src/Famix-TestComposedSubmetamodel2-Entities/FamixTestComposed2SourceAnchor.class.st @@ -34,3 +34,15 @@ FamixTestComposed2SourceAnchor class >> requirements [ ^ { } ] + +{ #category : #'moosequery-queries-generic' } +FamixTestComposed2SourceAnchor >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] diff --git a/src/Moose-Query-Test/MooseQueryTest.class.st b/src/Moose-Query-Test/MooseQueryTest.class.st index eac0346e4..8dea6f13d 100644 --- a/src/Moose-Query-Test/MooseQueryTest.class.st +++ b/src/Moose-Query-Test/MooseQueryTest.class.st @@ -333,6 +333,12 @@ MooseQueryTest >> testQueryWith [ self assert: (package1 query: #out with: FamixTInvocation) size equals: 1. ] +{ #category : #tests } +MooseQueryTest >> testSourceThroughAll [ + self assertCollection: (method2 throughAllFrom) storage flattened hasSameElements: {method2 . method1 . method3}. + self assertCollection: (class2 throughAllFrom) storage flattened hasSameElements: {method2 . method1 . method3 . class1} +] + { #category : #tests } MooseQueryTest >> testSourceThroughInvocation [ @@ -342,6 +348,12 @@ MooseQueryTest >> testSourceThroughInvocation [ ] +{ #category : #tests } +MooseQueryTest >> testTargetThroughAll [ + self assertCollection: (method2 throughAllTo) storage flattened hasSameElements: { var1 . method2}. + self assertCollection: (class2 throughAllTo) storage flattened hasSameElements: { var1 . method2} +] + { #category : #tests } MooseQueryTest >> testTargetThroughInvocation [ @@ -352,6 +364,18 @@ MooseQueryTest >> testTargetThroughInvocation [ ] +{ #category : #tests } +MooseQueryTest >> testThrougAllIncoming [ + self assert: method2 queryAllIncoming size equals: 3. + self assert: class2 queryAllIncoming size equals: 7 +] + +{ #category : #tests } +MooseQueryTest >> testThroughAllFrom [ + self assert: method2 queryAllIncoming size equals: 3. + self assert: class2 queryAllIncoming size equals: 7 +] + { #category : #tests } MooseQueryTest >> testToScope [ self assertCollection: (class1 toScope: FAMIXMethod) hasSameElements: {method1}. diff --git a/src/Moose-Query/MooseQueryCalculator.class.st b/src/Moose-Query/MooseQueryCalculator.class.st index 10b397f94..5e0e5284d 100644 --- a/src/Moose-Query/MooseQueryCalculator.class.st +++ b/src/Moose-Query/MooseQueryCalculator.class.st @@ -119,6 +119,25 @@ MooseQueryCalculator >> queryLocal: aFAMIXClassAssociation for: anEntity in: aCo ^ aCollection ] +{ #category : #query } +MooseQueryCalculator >> source: aFAMIXClassAssociation for: anEntity [ + ^ self strategy + queryResultOn: anEntity + with: (self source: aFAMIXClassAssociation for: anEntity in: OrderedCollection new) asSet +] + +{ #category : #query } +MooseQueryCalculator >> source: aFAMIXClassAssociation for: anEntity in: aCollection [ + | selectors | + self sourceLocal: aFAMIXClassAssociation for: anEntity in: aCollection. + 1 to: (selectors := anEntity childrenSelectors) size do: [ :index | + (anEntity perform: (selectors at: index)) + ifNotNil: [ :children | + | coll | + 1 to: (coll := children asCollection) size do: [ :i | self through: aFAMIXClassAssociation for: (coll at: i) in: aCollection ] ] ]. + ^ aCollection +] + { #category : #accessing } MooseQueryCalculator >> strategy [ ^ strategy @@ -148,6 +167,38 @@ MooseQueryCalculator >> through: aFAMIXClassAssociation for: anEntity in: aColle ^ aCollection ] +{ #category : #query } +MooseQueryCalculator >> throughAllFor: anEntity [ + ^ self strategy queryResultOn: anEntity with: (self throughAllFor: anEntity in: OrderedCollection new) asSet +] + +{ #category : #query } +MooseQueryCalculator >> throughAllFor: anEntity in: aCollection [ + | selectors | + self throughAllLocalFor: anEntity in: aCollection. + "Instead of #to:do: we could just use #do: but this implementation is much faster. Maybe sista will remove the needs of the todo later." + 1 to: (selectors := anEntity childrenSelectors) size do: [ :index | + (anEntity perform: (selectors at: index)) + ifNotNil: [ :children | + | coll | + 1 to: (coll := children asCollection) size do: [ :i | self throughAllFor: (coll at: i) in: aCollection ] ] ]. + ^ aCollection +] + +{ #category : #query } +MooseQueryCalculator >> throughAllLocalFor: anEntity [ + + ^ self strategy queryResultOn: anEntity with: (self throughAllLocalFor: anEntity in: OrderedCollection new) asSet +] + +{ #category : #query } +MooseQueryCalculator >> throughAllLocalFor: anEntity in: aCollection [ + | properties | + "Instead of #to:do: we could just use #do: but this implementation is much faster. Maybe sista will remove the needs of the todo later." + 1 to: (properties := self strategy msePropertiesOf: anEntity) size do: [ :ind | (anEntity perform: (properties at: ind) name) ifNotNil: [ :coll | aCollection addAll: (coll asCollection collect: [ :each | each perform: self strategy symbolToCollectEntities ]) ] ]. + ^ aCollection +] + { #category : #query } MooseQueryCalculator >> throughLocal: aFAMIXClassAssociation for: anEntity in: aCollection [ "The goal here is to get all the entity's direct associations of the class in parameter. This will not check the associations of the entity's children." diff --git a/src/Moose-Query/TDependencyQueries.trait.st b/src/Moose-Query/TDependencyQueries.trait.st index c1b17a24a..cc7a4c45b 100644 --- a/src/Moose-Query/TDependencyQueries.trait.st +++ b/src/Moose-Query/TDependencyQueries.trait.st @@ -356,6 +356,18 @@ TDependencyQueries >> sourceThrough: aFAMIXClassAssociation [ ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) through: aFAMIXClassAssociation for: self ] +{ #category : #'moosequery-queries-generic' } +TDependencyQueries >> sourceThroughAll [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] + { #category : #'moosequery-queries-generic' } TDependencyQueries >> targetThrough: aFAMIXClassAssociation [ "Collect the target of the FAMIXClassAssociation class for the receiver and its children. @@ -367,3 +379,27 @@ TDependencyQueries >> targetThrough: aFAMIXClassAssociation [ ^ (MooseQueryCalculator strategy: MooseQueryOutgoingDirectionStrategy) through: aFAMIXClassAssociation for: self ] + +{ #category : #'moosequery-queries-generic' } +TDependencyQueries >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] + +{ #category : #'moosequery-queries-generic' } +TDependencyQueries >> throughAllTo [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryOutgoingDirectionStrategy) throughAllFor: self +] diff --git a/src/Moose-Query/TOODependencyQueries.trait.st b/src/Moose-Query/TOODependencyQueries.trait.st index 7c9830c05..2a6bf3b6e 100644 --- a/src/Moose-Query/TOODependencyQueries.trait.st +++ b/src/Moose-Query/TOODependencyQueries.trait.st @@ -31,3 +31,15 @@ TOODependencyQueries classSide >> generatedTraitNames [ ^ #(TDependencyQueries) ] + +{ #category : #'moosequery-queries-generic' } +TOODependencyQueries >> throughAllFrom [ + "Query all the incoming associations of the receiver and its children. + + Example: + aFAMIXClass queryAllIncoming. + --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self +] From bc0829373680a4ddaaed40698df85f3e895f7f09 Mon Sep 17 00:00:00 2001 From: Lionel Akue Date: Wed, 6 Feb 2019 13:50:32 +0100 Subject: [PATCH 0004/1076] - fixed comment #throughAllTo - fixed comment #throughAllFrom - fixed comment #targetThrough: These commits aim to add throughFrom:aFxAssociation query / throughTo: aFxAssociation and all the associated methods. These methods respectively return the source / target of all Associations pointing to / starting from self. self throughFrom: FamixInvocation equivalent to : (self queryIncoming: FamixInvocation) collect: #from --- .../FAMIXAnnotationInstance.class.st | 10 +++++----- src/Moose-Query/TDependencyQueries.trait.st | 12 ++++++------ 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Famix-Compatibility-Entities/FAMIXAnnotationInstance.class.st b/src/Famix-Compatibility-Entities/FAMIXAnnotationInstance.class.st index d049d7d27..0cca046b9 100644 --- a/src/Famix-Compatibility-Entities/FAMIXAnnotationInstance.class.st +++ b/src/Famix-Compatibility-Entities/FAMIXAnnotationInstance.class.st @@ -86,7 +86,7 @@ FAMIXAnnotationInstance >> throughAllFrom [ "Query all the incoming associations of the receiver and its children. Example: - aFAMIXClass queryAllIncoming. + aFAMIXClass throughAllFrom. --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target " @@ -95,11 +95,11 @@ FAMIXAnnotationInstance >> throughAllFrom [ { #category : #'moosequery-queries-generic' } FAMIXAnnotationInstance >> throughAllTo [ - "Query all the incoming associations of the receiver and its children. - + "Collect all the targets of the receiver and its children. + Example: - aFAMIXClass queryAllIncoming. - --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + aFAMIXMethod throughAllTo. + --> Will return a MooseOutgoingQueryResult containing the class having aFAMIXClass or its children as source " ^ (MooseQueryCalculator strategy: MooseQueryOutgoingDirectionStrategy) throughAllFor: self diff --git a/src/Moose-Query/TDependencyQueries.trait.st b/src/Moose-Query/TDependencyQueries.trait.st index cc7a4c45b..249767e2f 100644 --- a/src/Moose-Query/TDependencyQueries.trait.st +++ b/src/Moose-Query/TDependencyQueries.trait.st @@ -373,8 +373,8 @@ TDependencyQueries >> targetThrough: aFAMIXClassAssociation [ "Collect the target of the FAMIXClassAssociation class for the receiver and its children. Example: - aFAMIXMethod sourceThrough: FAMIXReference. - --> Will return a MooseIncomingQueryResult containing the class having aFAMIXClass or its children as target + aFAMIXMethod targetThrough: FAMIXReference. + --> Will return a MooseOutgoingQueryResult containing the class having aFAMIXClass or its children as target " ^ (MooseQueryCalculator strategy: MooseQueryOutgoingDirectionStrategy) through: aFAMIXClassAssociation for: self @@ -394,11 +394,11 @@ TDependencyQueries >> throughAllFrom [ { #category : #'moosequery-queries-generic' } TDependencyQueries >> throughAllTo [ - "Query all the incoming associations of the receiver and its children. - + "Collect all the targets of the receiver and its children. + Example: - aFAMIXClass queryAllIncoming. - --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + aFAMIXMethod throughAllTo. + --> Will return a MooseOutgoingQueryResult containing the class having aFAMIXClass or its children as source " ^ (MooseQueryCalculator strategy: MooseQueryOutgoingDirectionStrategy) throughAllFor: self From eee3b04e777c997f63178fb12549100de3f397d7 Mon Sep 17 00:00:00 2001 From: Lionel Akue Date: Fri, 22 Feb 2019 11:06:31 +0100 Subject: [PATCH 0005/1076] prepare to syncrhonize --- src/Moose-Query/MooseQueryCalculator.class.st | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/Moose-Query/MooseQueryCalculator.class.st b/src/Moose-Query/MooseQueryCalculator.class.st index 5e0e5284d..207752185 100644 --- a/src/Moose-Query/MooseQueryCalculator.class.st +++ b/src/Moose-Query/MooseQueryCalculator.class.st @@ -106,16 +106,14 @@ MooseQueryCalculator >> queryLocal: aFAMIXClassAssociation for: anEntity [ { #category : #query } MooseQueryCalculator >> queryLocal: aFAMIXClassAssociation for: anEntity in: aCollection [ "The goal here is to get all the entity's direct associations of the class in parameter. This will not check the associations of the entity's children." - + "Note: Maybe adding a guard to check if the entity can have associations of this class could improve the perf. Currently it is not the case because there is not enough association. Maybe it could be the case in the futur, like with a PostgreSQL model." - + | properties | "Instead of #to:do: we could just use #do: but this implementation is much faster. Maybe sista will remove the needs of the todo later." - - properties := (self strategy msePropertiesOf: anEntity) select: [:each | aFAMIXClassAssociation inheritsFromType: each type implementingClass]. - - - 1 to: properties size do: [ :ind | (anEntity perform: (properties at: ind) name) ifNotNil: [ :coll | aCollection addAll: (coll asCollection select: [ :each | each isOfType: aFAMIXClassAssociation ]) ] ]. + 1 to: (properties := self strategy msePropertiesOf: anEntity) size do: [ :ind | + (anEntity perform: (properties at: ind) name) + ifNotNil: [ :coll | aCollection addAll: (coll asCollection select: [ :each | each isKindOf: aFAMIXClassAssociation ]) ] ]. ^ aCollection ] From f9d87ef6364060fd4a9eef7e6b80dc68b362ae84 Mon Sep 17 00:00:00 2001 From: Lionel Akue Date: Fri, 22 Feb 2019 13:53:38 +0100 Subject: [PATCH 0006/1076] fixed MooseQueryLocator>>queryLocal: aFAMIXClassAssociation for: anEntity in: refactored back to previous version. avoiding optimisation --- src/Moose-Query/MooseQueryCalculator.class.st | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Moose-Query/MooseQueryCalculator.class.st b/src/Moose-Query/MooseQueryCalculator.class.st index 207752185..5ba00059b 100644 --- a/src/Moose-Query/MooseQueryCalculator.class.st +++ b/src/Moose-Query/MooseQueryCalculator.class.st @@ -113,7 +113,7 @@ MooseQueryCalculator >> queryLocal: aFAMIXClassAssociation for: anEntity in: aCo "Instead of #to:do: we could just use #do: but this implementation is much faster. Maybe sista will remove the needs of the todo later." 1 to: (properties := self strategy msePropertiesOf: anEntity) size do: [ :ind | (anEntity perform: (properties at: ind) name) - ifNotNil: [ :coll | aCollection addAll: (coll asCollection select: [ :each | each isKindOf: aFAMIXClassAssociation ]) ] ]. + ifNotNil: [ :coll | aCollection addAll: (coll asCollection select: [ :each | each isOfType: aFAMIXClassAssociation ]) ] ]. ^ aCollection ] From fb94d133c143252aeb2f3d70c775185493cb8861 Mon Sep 17 00:00:00 2001 From: mahugnon Date: Fri, 29 Mar 2019 14:34:21 +0100 Subject: [PATCH 0007/1076] reviewing previous commit --- .../FAMIXContainerEntity.class.st | 2 +- .../FamixJavaContainerEntity.class.st | 2 +- .../FamixStContainerEntity.class.st | 2 +- src/Moose-Query/TDependencyQueries.trait.st | 20 +++++++++++++++---- src/Moose-Query/TOODependencyQueries.trait.st | 12 ----------- 5 files changed, 19 insertions(+), 19 deletions(-) diff --git a/src/Famix-Compatibility-Entities/FAMIXContainerEntity.class.st b/src/Famix-Compatibility-Entities/FAMIXContainerEntity.class.st index 818179735..4cf51ce98 100644 --- a/src/Famix-Compatibility-Entities/FAMIXContainerEntity.class.st +++ b/src/Famix-Compatibility-Entities/FAMIXContainerEntity.class.st @@ -83,7 +83,7 @@ FAMIXContainerEntity >> numberOfChildren [ ^ self children size ] -{ #category : #'moosequery-queries-generic' } +{ #category : #'as yet unclassified' } FAMIXContainerEntity >> throughAllFrom [ "Query all the incoming associations of the receiver and its children. diff --git a/src/Famix-Java-Entities/FamixJavaContainerEntity.class.st b/src/Famix-Java-Entities/FamixJavaContainerEntity.class.st index 82078031e..a36ed4908 100644 --- a/src/Famix-Java-Entities/FamixJavaContainerEntity.class.st +++ b/src/Famix-Java-Entities/FamixJavaContainerEntity.class.st @@ -78,7 +78,7 @@ FamixJavaContainerEntity >> numberOfChildren [ ^ self children size ] -{ #category : #'moosequery-queries-generic' } +{ #category : #'as yet unclassified' } FamixJavaContainerEntity >> throughAllFrom [ "Query all the incoming associations of the receiver and its children. diff --git a/src/Famix-PharoSmalltalk-Entities/FamixStContainerEntity.class.st b/src/Famix-PharoSmalltalk-Entities/FamixStContainerEntity.class.st index c2b81f389..6e07a5dda 100644 --- a/src/Famix-PharoSmalltalk-Entities/FamixStContainerEntity.class.st +++ b/src/Famix-PharoSmalltalk-Entities/FamixStContainerEntity.class.st @@ -44,7 +44,7 @@ FamixStContainerEntity >> numberOfChildren [ ^ self children size ] -{ #category : #'moosequery-queries-generic' } +{ #category : #'as yet unclassified' } FamixStContainerEntity >> throughAllFrom [ "Query all the incoming associations of the receiver and its children. diff --git a/src/Moose-Query/TDependencyQueries.trait.st b/src/Moose-Query/TDependencyQueries.trait.st index 249767e2f..4bfbb0b03 100644 --- a/src/Moose-Query/TDependencyQueries.trait.st +++ b/src/Moose-Query/TDependencyQueries.trait.st @@ -358,11 +358,11 @@ TDependencyQueries >> sourceThrough: aFAMIXClassAssociation [ { #category : #'moosequery-queries-generic' } TDependencyQueries >> sourceThroughAll [ - "Query all the incoming associations of the receiver and its children. - + "Collect the source of all the FAMIXClassAssociation classes for the receiver and its children. + Example: - aFAMIXClass queryAllIncoming. - --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + aFAMIXClass sourceThroughAll. + --> Will return a MooseIncomingQueryResult containing the methods having aFAMIXClass or its children as source " ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self @@ -380,6 +380,18 @@ TDependencyQueries >> targetThrough: aFAMIXClassAssociation [ ^ (MooseQueryCalculator strategy: MooseQueryOutgoingDirectionStrategy) through: aFAMIXClassAssociation for: self ] +{ #category : #'moosequery-queries-generic' } +TDependencyQueries >> targetThroughAll [ + "Collect the target of the FAMIXClassAssociation class for the receiver and its children. + + Example: + aFAMIXMethod targetThroughAll. + --> Will return a MooseOutgoingQueryResult containing the class having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryOutgoingDirectionStrategy) throughAllFor: self +] + { #category : #'moosequery-queries-generic' } TDependencyQueries >> throughAllFrom [ "Query all the incoming associations of the receiver and its children. diff --git a/src/Moose-Query/TOODependencyQueries.trait.st b/src/Moose-Query/TOODependencyQueries.trait.st index 2a6bf3b6e..7c9830c05 100644 --- a/src/Moose-Query/TOODependencyQueries.trait.st +++ b/src/Moose-Query/TOODependencyQueries.trait.st @@ -31,15 +31,3 @@ TOODependencyQueries classSide >> generatedTraitNames [ ^ #(TDependencyQueries) ] - -{ #category : #'moosequery-queries-generic' } -TOODependencyQueries >> throughAllFrom [ - "Query all the incoming associations of the receiver and its children. - - Example: - aFAMIXClass queryAllIncoming. - --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target - " - - ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self -] From a89f34ce5e048387da0a39fe19a43df0464d1f6b Mon Sep 17 00:00:00 2001 From: mahugnon Date: Fri, 29 Mar 2019 15:09:41 +0100 Subject: [PATCH 0008/1076] reviewing commit number 170b76b4c3a13cf6018b860198c34237521e4fec --- .../FAMIXContainerEntity.class.st | 2 +- .../FamixJavaContainerEntity.class.st | 2 +- .../FamixStContainerEntity.class.st | 2 +- src/Moose-Query/TDependencyQueries.trait.st | 24 ++++++++++++++----- src/Moose-Query/TOODependencyQueries.trait.st | 12 ---------- 5 files changed, 21 insertions(+), 21 deletions(-) diff --git a/src/Famix-Compatibility-Entities/FAMIXContainerEntity.class.st b/src/Famix-Compatibility-Entities/FAMIXContainerEntity.class.st index 818179735..4cf51ce98 100644 --- a/src/Famix-Compatibility-Entities/FAMIXContainerEntity.class.st +++ b/src/Famix-Compatibility-Entities/FAMIXContainerEntity.class.st @@ -83,7 +83,7 @@ FAMIXContainerEntity >> numberOfChildren [ ^ self children size ] -{ #category : #'moosequery-queries-generic' } +{ #category : #'as yet unclassified' } FAMIXContainerEntity >> throughAllFrom [ "Query all the incoming associations of the receiver and its children. diff --git a/src/Famix-Java-Entities/FamixJavaContainerEntity.class.st b/src/Famix-Java-Entities/FamixJavaContainerEntity.class.st index 82078031e..a36ed4908 100644 --- a/src/Famix-Java-Entities/FamixJavaContainerEntity.class.st +++ b/src/Famix-Java-Entities/FamixJavaContainerEntity.class.st @@ -78,7 +78,7 @@ FamixJavaContainerEntity >> numberOfChildren [ ^ self children size ] -{ #category : #'moosequery-queries-generic' } +{ #category : #'as yet unclassified' } FamixJavaContainerEntity >> throughAllFrom [ "Query all the incoming associations of the receiver and its children. diff --git a/src/Famix-PharoSmalltalk-Entities/FamixStContainerEntity.class.st b/src/Famix-PharoSmalltalk-Entities/FamixStContainerEntity.class.st index c2b81f389..6e07a5dda 100644 --- a/src/Famix-PharoSmalltalk-Entities/FamixStContainerEntity.class.st +++ b/src/Famix-PharoSmalltalk-Entities/FamixStContainerEntity.class.st @@ -44,7 +44,7 @@ FamixStContainerEntity >> numberOfChildren [ ^ self children size ] -{ #category : #'moosequery-queries-generic' } +{ #category : #'as yet unclassified' } FamixStContainerEntity >> throughAllFrom [ "Query all the incoming associations of the receiver and its children. diff --git a/src/Moose-Query/TDependencyQueries.trait.st b/src/Moose-Query/TDependencyQueries.trait.st index 249767e2f..2075cb67c 100644 --- a/src/Moose-Query/TDependencyQueries.trait.st +++ b/src/Moose-Query/TDependencyQueries.trait.st @@ -358,11 +358,11 @@ TDependencyQueries >> sourceThrough: aFAMIXClassAssociation [ { #category : #'moosequery-queries-generic' } TDependencyQueries >> sourceThroughAll [ - "Query all the incoming associations of the receiver and its children. - + "Collect the source of all the FAMIXClassAssociation classes for the receiver and its children. + Example: - aFAMIXClass queryAllIncoming. - --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + aFAMIXClass sourceThroughAll. + --> Will return a MooseIncomingQueryResult containing the methods having aFAMIXClass or its children as source " ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self @@ -380,13 +380,25 @@ TDependencyQueries >> targetThrough: aFAMIXClassAssociation [ ^ (MooseQueryCalculator strategy: MooseQueryOutgoingDirectionStrategy) through: aFAMIXClassAssociation for: self ] +{ #category : #'moosequery-queries-generic' } +TDependencyQueries >> targetThroughAll [ + "Collect the target of the FAMIXClassAssociation class for the receiver and its children. + + Example: + aFAMIXMethod targetThroughAll. + --> Will return a MooseOutgoingQueryResult containing the class having aFAMIXClass or its children as target + " + + ^ (MooseQueryCalculator strategy: MooseQueryOutgoingDirectionStrategy) throughAllFor: self +] + { #category : #'moosequery-queries-generic' } TDependencyQueries >> throughAllFrom [ "Query all the incoming associations of the receiver and its children. Example: - aFAMIXClass queryAllIncoming. - --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target + aFAMIXClass throughAllFrom. + --> Will return a MooseIncomingQueryResult containing all the FAMIXAssociations having aFAMIXClass or its children as target " ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self diff --git a/src/Moose-Query/TOODependencyQueries.trait.st b/src/Moose-Query/TOODependencyQueries.trait.st index 2a6bf3b6e..7c9830c05 100644 --- a/src/Moose-Query/TOODependencyQueries.trait.st +++ b/src/Moose-Query/TOODependencyQueries.trait.st @@ -31,15 +31,3 @@ TOODependencyQueries classSide >> generatedTraitNames [ ^ #(TDependencyQueries) ] - -{ #category : #'moosequery-queries-generic' } -TOODependencyQueries >> throughAllFrom [ - "Query all the incoming associations of the receiver and its children. - - Example: - aFAMIXClass queryAllIncoming. - --> Will return a MooseIncomingQueryResult containing the FAMIXAssociation having aFAMIXClass or its children as target - " - - ^ (MooseQueryCalculator strategy: MooseQueryIncomingDirectionStrategy) throughAllFor: self -] From 57fe8d9d45f6b0e6d855a58649b5ac167e853a28 Mon Sep 17 00:00:00 2001 From: Anne Etien Date: Mon, 29 Apr 2019 09:52:34 +0200 Subject: [PATCH 0009/1076] Starting FamixNG refactoring Modifying the way numberOfLinesOfCode is computed in FAMIXBehaviouralEntity and FamixJavaPackage --- .../FAMIXBehaviouralEntity.class.st | 4 +--- src/Famix-Java-Entities/FamixJavaPackage.class.st | 2 +- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Famix-Compatibility-Entities/FAMIXBehaviouralEntity.class.st b/src/Famix-Compatibility-Entities/FAMIXBehaviouralEntity.class.st index 95b39fc82..74657320d 100644 --- a/src/Famix-Compatibility-Entities/FAMIXBehaviouralEntity.class.st +++ b/src/Famix-Compatibility-Entities/FAMIXBehaviouralEntity.class.st @@ -191,9 +191,7 @@ FAMIXBehaviouralEntity >> numberOfLinesOfCode [ ^ self lookUpPropertyNamed: #numberOfLinesOfCode - computedAs: [ self mooseModel isSmalltalk - ifTrue: [ self computeNumberOfLinesOfCodeIfSmalltalk ] - ifFalse: [ self computeNumberOfLinesOfCode ] ] + computedAs: [ self computeNumberOfLinesOfCode ] ] { #category : #'Famix-Extensions' } diff --git a/src/Famix-Java-Entities/FamixJavaPackage.class.st b/src/Famix-Java-Entities/FamixJavaPackage.class.st index 883c6886b..b37d69ea3 100644 --- a/src/Famix-Java-Entities/FamixJavaPackage.class.st +++ b/src/Famix-Java-Entities/FamixJavaPackage.class.st @@ -431,7 +431,7 @@ FamixJavaPackage >> numberOfLinesOfCode [ ^self lookUpPropertyNamed: #numberOfLinesOfCode computedAs: [ - self methods inject: 0 into: [ :sum :each | sum + each numberOfLinesOfCode ] ] + self childEntities inject: 0 into: [ :sum :each | sum + each numberOfLinesOfCode ] ] ] { #category : #'as yet unclassified' } From 599bc1b4071436bb4a86b74186e0d00f2bc210fb Mon Sep 17 00:00:00 2001 From: Anne Etien Date: Mon, 29 Apr 2019 11:16:40 +0200 Subject: [PATCH 0010/1076] Starting FamixNG Refactoring - removing category from general MM - putting protocol into Smalltalk MM - renaming hasClassScope to isClassSide - adding isAbstract - removing timeStamp - modifying tests consequently --- .../FAMIXMethod.class.st | 2 +- .../FamixJavaMethod.class.st | 2 +- .../FamixGenerator.class.st | 8 +- .../FamixStMethod.class.st | 22 +- .../FamixPharoSmalltalkGenerator.class.st | 443 +++++++++--------- src/Famix-PharoSmalltalk-Generator/package.st | 2 +- .../FamixTMethodTest.class.st | 34 +- .../FamixTWithMethodsTest.class.st | 10 - src/Famix-Traits/FamixTMethod.trait.st | 69 +-- .../SmalltalkImporter.class.st | 2 +- 10 files changed, 286 insertions(+), 308 deletions(-) diff --git a/src/Famix-Compatibility-Entities/FAMIXMethod.class.st b/src/Famix-Compatibility-Entities/FAMIXMethod.class.st index c98fc40e6..c52746831 100644 --- a/src/Famix-Compatibility-Entities/FAMIXMethod.class.st +++ b/src/Famix-Compatibility-Entities/FAMIXMethod.class.st @@ -453,7 +453,7 @@ FAMIXMethod >> smalltalkClass [ ^ ('*_class' match: self parentType name) ifTrue: [self parentType smalltalkClass] - ifFalse: [self hasClassScope + ifFalse: [self isClassSide ifTrue: [self parentType smalltalkClass class] ifFalse: [self parentType smalltalkClass]] ] diff --git a/src/Famix-Java-Entities/FamixJavaMethod.class.st b/src/Famix-Java-Entities/FamixJavaMethod.class.st index b03c49dc9..4c2a22bec 100644 --- a/src/Famix-Java-Entities/FamixJavaMethod.class.st +++ b/src/Famix-Java-Entities/FamixJavaMethod.class.st @@ -66,7 +66,7 @@ FamixJavaMethod >> belongsTo: anObject [ ] -{ #category : #accessing } +{ #category : #'as yet unclassified' } FamixJavaMethod >> category [ diff --git a/src/Famix-MetamodelGeneration/FamixGenerator.class.st b/src/Famix-MetamodelGeneration/FamixGenerator.class.st index 6f6b60841..7d52d55e4 100644 --- a/src/Famix-MetamodelGeneration/FamixGenerator.class.st +++ b/src/Famix-MetamodelGeneration/FamixGenerator.class.st @@ -950,14 +950,12 @@ FamixGenerator >> defineProperties [ comment: 'Generic container for language dependent modifiers.'; multivalued). - ((tMethod property: #timeStamp type: #String) - comment: 'TimeStamp of the method with author and time of the last change'). - ((tMethod property: #category type: #String) "FIX - custom, own trait?" - comment: 'Category of the method'). ((tMethod property: #kind type: #String) comment: 'Tag indicating a setter, getter, constant, constructor, or abstract method'). - ((tMethod property: #hasClassScope type: #Boolean) + ((tMethod property: #isClassSide type: #Boolean) comment: 'True if class-side method'). + ((tMethod property: #isAbstract type: #Boolean) + comment: 'True if abstract method'). ((tWithSignature property: #signature type: #String) comment: 'Signature of the message being sent'). diff --git a/src/Famix-PharoSmalltalk-Entities/FamixStMethod.class.st b/src/Famix-PharoSmalltalk-Entities/FamixStMethod.class.st index d45c6c116..ef6159b55 100644 --- a/src/Famix-PharoSmalltalk-Entities/FamixStMethod.class.st +++ b/src/Famix-PharoSmalltalk-Entities/FamixStMethod.class.st @@ -3,6 +3,9 @@ Class { #superclass : #FamixStContainerEntity, #traits : 'FamixTInvocable + FamixTMethod + FamixTTypedStructure + FamixTWithAccesses + FamixTWithClassScope + FamixTWithImplicitVariables + FamixTWithInvocations + FamixTWithLocalVariables + FamixTWithParameters + FamixTWithReferences + FamixTWithSignature', #classTraits : 'FamixTInvocable classTrait + FamixTMethod classTrait + FamixTTypedStructure classTrait + FamixTWithAccesses classTrait + FamixTWithClassScope classTrait + FamixTWithImplicitVariables classTrait + FamixTWithInvocations classTrait + FamixTWithLocalVariables classTrait + FamixTWithParameters classTrait + FamixTWithReferences classTrait + FamixTWithSignature classTrait', + #instVars : [ + '#protocol' + ], #category : #'Famix-PharoSmalltalk-Entities-Entities' } @@ -19,7 +22,7 @@ FamixStMethod class >> annotation [ FamixStMethod class >> generatedSlotNames [ 'FamixStMethod class>>#generatedSlotNames'. - ^ #() + ^ #(protocol) ] { #category : #generator } @@ -386,6 +389,23 @@ FamixStMethod >> packageScope [ ] ] +{ #category : #accessing } +FamixStMethod >> protocol [ + + + + + ^ protocol +] + +{ #category : #accessing } +FamixStMethod >> protocol: anObject [ + + + protocol := anObject + +] + { #category : #'Famix-Extensions-metrics-support' } FamixStMethod >> smalltalkClass [ "Return the smalltalk class associated with the receiver. Note that it may be different than doing self parentType because the class and metaclass can be merged." diff --git a/src/Famix-PharoSmalltalk-Generator/FamixPharoSmalltalkGenerator.class.st b/src/Famix-PharoSmalltalk-Generator/FamixPharoSmalltalkGenerator.class.st index 8858200b9..5c70de9e8 100644 --- a/src/Famix-PharoSmalltalk-Generator/FamixPharoSmalltalkGenerator.class.st +++ b/src/Famix-PharoSmalltalk-Generator/FamixPharoSmalltalkGenerator.class.st @@ -1,218 +1,225 @@ -Class { - #name : #FamixPharoSmalltalkGenerator, - #superclass : #FamixBasicInfrastructureGenerator, - #instVars : [ - 'access', - 'annotationInstance', - 'annotationInstanceAttribute', - 'annotationType', - 'annotationTypeAttribute', - 'attribute', - 'class', - 'containerEntity', - 'globalVariable', - 'implicitVariable', - 'inheritance', - 'invocation', - 'localVariable', - 'method', - 'namespace', - 'package', - 'parameter', - 'reference', - 'structuralEntity', - 'scopingEntity', - 'smalltalkSourceLanguage', - 'type', - 'unknownSourceLanguage', - 'unknownVariable' - ], - #category : #'Famix-PharoSmalltalk-Generator' -} - -{ #category : #accessing } -FamixPharoSmalltalkGenerator class >> packageName [ - - ^ #'Famix-PharoSmalltalk-Entities' -] - -{ #category : #accessing } -FamixPharoSmalltalkGenerator class >> prefix [ - - ^ #'FamixSt' -] - -{ #category : #accessing } -FamixPharoSmalltalkGenerator class >> submetamodels [ - ^ { FamixCompatibilityGenerator } -] - -{ #category : #accessing } -FamixPharoSmalltalkGenerator class >> wantsAllEntitiesNavigation [ - - ^ false -] - -{ #category : #initialization } -FamixPharoSmalltalkGenerator >> defineClasses [ - - super defineClasses. - - access := builder newClassNamed: #Access. - annotationInstance := builder newClassNamed: #AnnotationInstance. - annotationInstanceAttribute := builder newClassNamed: #AnnotationInstanceAttribute. - annotationType := builder newClassNamed: #AnnotationType. - annotationTypeAttribute := builder newClassNamed: #AnnotationTypeAttribute. - attribute := builder newClassNamed: #Attribute. - class := builder newClassNamed: #Class. - containerEntity := builder newClassNamed: #ContainerEntity. - globalVariable := builder newClassNamed: #GlobalVariable. - implicitVariable := builder newClassNamed: #ImplicitVariable. - inheritance := builder newClassNamed: #Inheritance. - invocation := builder newClassNamed: #Invocation. - localVariable := builder newClassNamed: #LocalVariable. - method := builder newClassNamed: #Method. - namespace := builder newClassNamed: #Namespace. - package := builder newClassNamed: #Package. - parameter := builder newClassNamed: #Parameter. - reference := builder newClassNamed: #Reference. - scopingEntity := builder newClassNamed: #ScopingEntity. - structuralEntity := builder newClassNamed: #StructuralEntity. - smalltalkSourceLanguage := builder newClassNamed: #SmalltalkSourceLanguage. - type := builder newClassNamed: #Type. - unknownSourceLanguage := builder newClassNamed: #UnknownSourceLanguage. - unknownVariable := builder newClassNamed: #UnknownVariable. - -] - -{ #category : #initialization } -FamixPharoSmalltalkGenerator >> defineHierarchy [ - - super defineHierarchy. - - access --|> association. - access --|> #TAccess. - - annotationInstance --|> sourcedEntity. - annotationInstance --|> #TAnnotationInstance. - annotationInstance --|> #TWithAnnotationInstanceAttributes. - annotationInstance --|> #TTypedAnnotationInstance. - annotationInstance --|> #TEntityMetaLevelDependency. - annotationInstance --|> #TDependencyQueries. - - annotationInstanceAttribute --|> sourcedEntity. - annotationInstanceAttribute --|> #TAnnotationInstanceAttribute. - annotationInstanceAttribute --|> #TTypedAnnotationInstanceAttribute. - annotationInstanceAttribute --|> #TEntityMetaLevelDependency. - annotationInstanceAttribute --|> #TDependencyQueries. - - annotationType --|> type. - annotationType --|> #TAnnotationType. - - annotationTypeAttribute --|> attribute. - annotationTypeAttribute --|> #TAnnotationTypeAttribute. - annotationTypeAttribute --|> #TTypedAnnotationInstanceAttribute. - - attribute --|> structuralEntity. - attribute --|> #TAttribute. - attribute --|> #TWithClassScope. - - class --|> type. - class --|> #TWithExceptions. - class --|> #TClass. - class --|> #TWithMethods. - class --|> #TWithSuperInheritances. - class --|> #TWithSubInheritances. - class --|> #TClassHierarchyNavigation. - - containerEntity --|> namedEntity. - containerEntity --|> #TWithTypes. - containerEntity --|> #TWithClasses. - containerEntity --|> #TWithAnnotationTypes. - containerEntity --|> #TOODependencyQueries. - - globalVariable --|> structuralEntity. - globalVariable --|> #TGlobalVariable. - - implicitVariable --|> structuralEntity. - implicitVariable --|> #TImplicitVariable. - - inheritance --|> association. - inheritance --|> #TSubInheritance. - inheritance --|> #TSuperInheritance. - - invocation --|> association. - invocation --|> #TInvocation. - invocation --|> #TWithSignature. - - localVariable --|> structuralEntity. - localVariable --|> #TLocalVariable. - - method --|> containerEntity. - method --|> #TWithParameters. - method --|> #TInvocable. - method --|> #TWithInvocations. - method --|> #TWithReferences. - method --|> #TWithAccesses. - method --|> #TWithLocalVariables. - method --|> #TWithImplicitVariables. - method --|> #TWithSignature. - method --|> #TMethod. - method --|> #TWithClassScope. - method --|> #TTypedStructure. - - namedEntity --|> #TPackageable. - namedEntity --|> #TInvocationsReceiver. - namedEntity --|> #TWithAnnotationInstances. - namedEntity --|> #TWithModifiers. - namedEntity --|> #TPossibleStub. - - namespace --|> scopingEntity. - namespace --|> #TNamespace. - - package --|> scopingEntity. - package --|> #TPackage. - - parameter --|> structuralEntity. - parameter --|> #TParameter. - - reference --|> association. - reference --|> #TReference. - - smalltalkSourceLanguage --|> sourceLanguage. - - scopingEntity --|> containerEntity. - scopingEntity --|> #TGlobalVariableScope. - scopingEntity --|> #TScopingEntity. - - structuralEntity --|> namedEntity. - structuralEntity --|> #TAccessible. - structuralEntity --|> #TTypedStructure. - - type --|> containerEntity. - type --|> #TType. - type --|> #TReferenceable. - type --|> #TWithAttributes. - type --|> #TWithTypedStructures. - - unknownSourceLanguage --|> sourceLanguage. - - unknownVariable --|> structuralEntity. - - sourceAnchor --|> #TWithImmediateSource. - - - - -] - -{ #category : #initialization } -FamixPharoSmalltalkGenerator >> newBuilder [ - - ^ self builderWithStandardTraits - withImportingContext; - yourself - - - -] +Class { + #name : #FamixPharoSmalltalkGenerator, + #superclass : #FamixBasicInfrastructureGenerator, + #instVars : [ + 'access', + 'annotationInstance', + 'annotationInstanceAttribute', + 'annotationType', + 'annotationTypeAttribute', + 'attribute', + 'class', + 'containerEntity', + 'globalVariable', + 'implicitVariable', + 'inheritance', + 'invocation', + 'localVariable', + 'method', + 'namespace', + 'package', + 'parameter', + 'reference', + 'structuralEntity', + 'scopingEntity', + 'smalltalkSourceLanguage', + 'type', + 'unknownSourceLanguage', + 'unknownVariable' + ], + #category : #'Famix-PharoSmalltalk-Generator' +} + +{ #category : #accessing } +FamixPharoSmalltalkGenerator class >> packageName [ + + ^ #'Famix-PharoSmalltalk-Entities' +] + +{ #category : #accessing } +FamixPharoSmalltalkGenerator class >> prefix [ + + ^ #'FamixSt' +] + +{ #category : #accessing } +FamixPharoSmalltalkGenerator class >> submetamodels [ + ^ { FamixCompatibilityGenerator } +] + +{ #category : #accessing } +FamixPharoSmalltalkGenerator class >> wantsAllEntitiesNavigation [ + + ^ false +] + +{ #category : #initialization } +FamixPharoSmalltalkGenerator >> defineClasses [ + + super defineClasses. + + access := builder newClassNamed: #Access. + annotationInstance := builder newClassNamed: #AnnotationInstance. + annotationInstanceAttribute := builder newClassNamed: #AnnotationInstanceAttribute. + annotationType := builder newClassNamed: #AnnotationType. + annotationTypeAttribute := builder newClassNamed: #AnnotationTypeAttribute. + attribute := builder newClassNamed: #Attribute. + class := builder newClassNamed: #Class. + containerEntity := builder newClassNamed: #ContainerEntity. + globalVariable := builder newClassNamed: #GlobalVariable. + implicitVariable := builder newClassNamed: #ImplicitVariable. + inheritance := builder newClassNamed: #Inheritance. + invocation := builder newClassNamed: #Invocation. + localVariable := builder newClassNamed: #LocalVariable. + method := builder newClassNamed: #Method. + namespace := builder newClassNamed: #Namespace. + package := builder newClassNamed: #Package. + parameter := builder newClassNamed: #Parameter. + reference := builder newClassNamed: #Reference. + scopingEntity := builder newClassNamed: #ScopingEntity. + structuralEntity := builder newClassNamed: #StructuralEntity. + smalltalkSourceLanguage := builder newClassNamed: #SmalltalkSourceLanguage. + type := builder newClassNamed: #Type. + unknownSourceLanguage := builder newClassNamed: #UnknownSourceLanguage. + unknownVariable := builder newClassNamed: #UnknownVariable. + +] + +{ #category : #initialization } +FamixPharoSmalltalkGenerator >> defineHierarchy [ + + super defineHierarchy. + + access --|> association. + access --|> #TAccess. + + annotationInstance --|> sourcedEntity. + annotationInstance --|> #TAnnotationInstance. + annotationInstance --|> #TWithAnnotationInstanceAttributes. + annotationInstance --|> #TTypedAnnotationInstance. + annotationInstance --|> #TEntityMetaLevelDependency. + annotationInstance --|> #TDependencyQueries. + + annotationInstanceAttribute --|> sourcedEntity. + annotationInstanceAttribute --|> #TAnnotationInstanceAttribute. + annotationInstanceAttribute --|> #TTypedAnnotationInstanceAttribute. + annotationInstanceAttribute --|> #TEntityMetaLevelDependency. + annotationInstanceAttribute --|> #TDependencyQueries. + + annotationType --|> type. + annotationType --|> #TAnnotationType. + + annotationTypeAttribute --|> attribute. + annotationTypeAttribute --|> #TAnnotationTypeAttribute. + annotationTypeAttribute --|> #TTypedAnnotationInstanceAttribute. + + attribute --|> structuralEntity. + attribute --|> #TAttribute. + attribute --|> #TWithClassScope. + + class --|> type. + class --|> #TWithExceptions. + class --|> #TClass. + class --|> #TWithMethods. + class --|> #TWithSuperInheritances. + class --|> #TWithSubInheritances. + class --|> #TClassHierarchyNavigation. + + containerEntity --|> namedEntity. + containerEntity --|> #TWithTypes. + containerEntity --|> #TWithClasses. + containerEntity --|> #TWithAnnotationTypes. + containerEntity --|> #TOODependencyQueries. + + globalVariable --|> structuralEntity. + globalVariable --|> #TGlobalVariable. + + implicitVariable --|> structuralEntity. + implicitVariable --|> #TImplicitVariable. + + inheritance --|> association. + inheritance --|> #TSubInheritance. + inheritance --|> #TSuperInheritance. + + invocation --|> association. + invocation --|> #TInvocation. + invocation --|> #TWithSignature. + + localVariable --|> structuralEntity. + localVariable --|> #TLocalVariable. + + method --|> containerEntity. + method --|> #TWithParameters. + method --|> #TInvocable. + method --|> #TWithInvocations. + method --|> #TWithReferences. + method --|> #TWithAccesses. + method --|> #TWithLocalVariables. + method --|> #TWithImplicitVariables. + method --|> #TWithSignature. + method --|> #TMethod. + method --|> #TWithClassScope. + method --|> #TTypedStructure. + + namedEntity --|> #TPackageable. + namedEntity --|> #TInvocationsReceiver. + namedEntity --|> #TWithAnnotationInstances. + namedEntity --|> #TWithModifiers. + namedEntity --|> #TPossibleStub. + + namespace --|> scopingEntity. + namespace --|> #TNamespace. + + package --|> scopingEntity. + package --|> #TPackage. + + parameter --|> structuralEntity. + parameter --|> #TParameter. + + reference --|> association. + reference --|> #TReference. + + smalltalkSourceLanguage --|> sourceLanguage. + + scopingEntity --|> containerEntity. + scopingEntity --|> #TGlobalVariableScope. + scopingEntity --|> #TScopingEntity. + + structuralEntity --|> namedEntity. + structuralEntity --|> #TAccessible. + structuralEntity --|> #TTypedStructure. + + type --|> containerEntity. + type --|> #TType. + type --|> #TReferenceable. + type --|> #TWithAttributes. + type --|> #TWithTypedStructures. + + unknownSourceLanguage --|> sourceLanguage. + + unknownVariable --|> structuralEntity. + + sourceAnchor --|> #TWithImmediateSource. + + + + +] + +{ #category : #definition } +FamixPharoSmalltalkGenerator >> defineProperties [ + super defineProperties. + ((method property: #protocol type: #String) + comment: 'Protocol of the method'). +] + +{ #category : #initialization } +FamixPharoSmalltalkGenerator >> newBuilder [ + + ^ self builderWithStandardTraits + withImportingContext; + yourself + + + +] diff --git a/src/Famix-PharoSmalltalk-Generator/package.st b/src/Famix-PharoSmalltalk-Generator/package.st index 47412e225..82711d05e 100644 --- a/src/Famix-PharoSmalltalk-Generator/package.st +++ b/src/Famix-PharoSmalltalk-Generator/package.st @@ -1 +1 @@ -Package { #name : #'Famix-PharoSmalltalk-Generator' } +Package { #name : #'Famix-PharoSmalltalk-Generator' } diff --git a/src/Famix-Test1-Tests/FamixTMethodTest.class.st b/src/Famix-Test1-Tests/FamixTMethodTest.class.st index 2f51c048a..0ef1f50a0 100644 --- a/src/Famix-Test1-Tests/FamixTMethodTest.class.st +++ b/src/Famix-Test1-Tests/FamixTMethodTest.class.st @@ -55,15 +55,6 @@ FamixTMethodTest >> testBelongsTo [ ] -{ #category : #tests } -FamixTMethodTest >> testCategory [ - - self assert: m1 category isNil. - m1 category: 'accessing'. - self assert: m1 category equals: 'accessing'. - -] - { #category : #tests } FamixTMethodTest >> testComputeNumberOfLinesOfCode [ @@ -85,14 +76,6 @@ FamixTMethodTest >> testCyclomaticComplexity [ ] -{ #category : #tests } -FamixTMethodTest >> testHasClassScope [ - - m1 hasClassScope: true. - self assert: m1 hasClassScope. - -] - { #category : #tests } FamixTMethodTest >> testIsClass [ @@ -104,6 +87,14 @@ FamixTMethodTest >> testIsClass [ self deny: anchor2 isClass. ] +{ #category : #tests } +FamixTMethodTest >> testIsClassSide [ + + m1 isClassSide: true. + self assert: m1 isClassSide . + +] + { #category : #tests } FamixTMethodTest >> testIsConstant [ @@ -211,12 +202,3 @@ FamixTMethodTest >> testRelations [ self assertCollection: m1 parentType equals: c1. self assertCollection: m2 parentType equals: c2. ] - -{ #category : #tests } -FamixTMethodTest >> testTimeStamp [ - - self assert: m1 timeStamp isNil. - m1 timeStamp: 'stamp'. - self assert: m1 timeStamp equals: 'stamp'. - -] diff --git a/src/Famix-Test1-Tests/FamixTWithMethodsTest.class.st b/src/Famix-Test1-Tests/FamixTWithMethodsTest.class.st index fc50bdf60..01badf728 100644 --- a/src/Famix-Test1-Tests/FamixTWithMethodsTest.class.st +++ b/src/Famix-Test1-Tests/FamixTWithMethodsTest.class.st @@ -126,16 +126,6 @@ FamixTWithMethodsTest >> testNumberOfMessageSends [ ] -{ #category : #tests } -FamixTWithMethodsTest >> testNumberOfMethodProtocols [ - - m1 category: #accessing. - self assert: c1 numberOfMethodProtocols equals: 1. - c1 numberOfMethodProtocols: 100. - self assert: c1 numberOfMethodProtocols equals: 100. - -] - { #category : #tests } FamixTWithMethodsTest >> testNumberOfMethods [ diff --git a/src/Famix-Traits/FamixTMethod.trait.st b/src/Famix-Traits/FamixTMethod.trait.st index 03f3f21ad..d819699eb 100644 --- a/src/Famix-Traits/FamixTMethod.trait.st +++ b/src/Famix-Traits/FamixTMethod.trait.st @@ -6,13 +6,11 @@ A FAMIXMethod is always contained in a parentType. Trait { #name : #FamixTMethod, #instVars : [ - '#category', - '#hasClassScope', '#isAbstract', + '#isClassSide', '#isPublic', '#kind', - '#parentType => FMOne type: #FamixTWithMethods opposite: #methods', - '#timeStamp' + '#parentType => FMOne type: #FamixTWithMethods opposite: #methods' ], #category : #'Famix-Traits-Method' } @@ -38,7 +36,7 @@ FamixTMethod classSide >> famixTMethodRelatedGroup [ FamixTMethod classSide >> generatedSlotNames [ 'FamixTMethod class>>#generatedSlotNames'. - ^ #(category hasClassScope kind parentType timeStamp) + ^ #(isAbstract isClassSide kind parentType) ] { #category : #generator } @@ -47,23 +45,6 @@ FamixTMethod classSide >> generatedTraitNames [ ^ #() ] -{ #category : #accessing } -FamixTMethod >> category [ - - - - - ^ category -] - -{ #category : #accessing } -FamixTMethod >> category: anObject [ - - - category := anObject - -] - { #category : #'Famix-Implementation' } FamixTMethod >> computeNumberOfLinesOfCode [ self hasSourceAnchor @@ -89,19 +70,36 @@ FamixTMethod >> cyclomaticComplexity: aNumber [ ] { #category : #accessing } -FamixTMethod >> hasClassScope [ +FamixTMethod >> isAbstract [ + + + + + ^ isAbstract +] + +{ #category : #accessing } +FamixTMethod >> isAbstract: anObject [ - + + isAbstract := anObject + +] + +{ #category : #accessing } +FamixTMethod >> isClassSide [ + + - ^ hasClassScope + ^ isClassSide ] { #category : #accessing } -FamixTMethod >> hasClassScope: anObject [ +FamixTMethod >> isClassSide: anObject [ - hasClassScope := anObject + isClassSide := anObject ] @@ -243,20 +241,3 @@ FamixTMethod >> parentTypeIsStub [ ^ self parentType ifNotNil: [ :e | e isStub ] ifNil: [ true ] ] - -{ #category : #accessing } -FamixTMethod >> timeStamp [ - - - - - ^ timeStamp -] - -{ #category : #accessing } -FamixTMethod >> timeStamp: anObject [ - - - timeStamp := anObject - -] diff --git a/src/Moose-SmalltalkImporter/SmalltalkImporter.class.st b/src/Moose-SmalltalkImporter/SmalltalkImporter.class.st index c001b70fd..b9699063b 100644 --- a/src/Moose-SmalltalkImporter/SmalltalkImporter.class.st +++ b/src/Moose-SmalltalkImporter/SmalltalkImporter.class.st @@ -207,7 +207,7 @@ SmalltalkImporter >> createMethod: aCompiledMethod [ do: [ :aRPackage | (aCompiledMethod isExtensionInPackage: aRPackage) ifTrue: [ method parentPackage: (self ensurePackage: aRPackage) ] ]. - method hasClassScope: aCompiledMethod methodClass isMeta. + method isClassSide: aCompiledMethod methodClass isMeta. method category: (aCompiledMethod methodClass organization From 146199b3b9900641ed344a40b1b5b683477bfada Mon Sep 17 00:00:00 2001 From: Anne Etien Date: Mon, 29 Apr 2019 11:30:21 +0200 Subject: [PATCH 0011/1076] Removing FamixTWithMethods >> methodsDo: and correcting its calls --- src/Famix-Test1-Tests/FamixTWithMethodsTest.class.st | 9 --------- src/Famix-Traits/FamixTClassHierarchyNavigation.trait.st | 6 +++--- src/Famix-Traits/FamixTWithMethods.trait.st | 5 ----- .../FamixTWithMethodsWithAccessesGlue.trait.st | 2 +- 4 files changed, 4 insertions(+), 18 deletions(-) diff --git a/src/Famix-Test1-Tests/FamixTWithMethodsTest.class.st b/src/Famix-Test1-Tests/FamixTWithMethodsTest.class.st index 01badf728..f78dc957d 100644 --- a/src/Famix-Test1-Tests/FamixTWithMethodsTest.class.st +++ b/src/Famix-Test1-Tests/FamixTWithMethodsTest.class.st @@ -70,15 +70,6 @@ FamixTWithMethodsTest >> testMethods [ ] -{ #category : #tests } -FamixTWithMethodsTest >> testMethodsDo [ - - | aCollection | - aCollection := Set new. - c2 methodsDo: [ :each | aCollection add: each ]. - self assertCollection: aCollection hasSameElements: { m2. m3 } -] - { #category : #tests } FamixTWithMethodsTest >> testMethodsGroup [ diff --git a/src/Famix-Traits/FamixTClassHierarchyNavigation.trait.st b/src/Famix-Traits/FamixTClassHierarchyNavigation.trait.st index 2125e2684..d16c43be4 100644 --- a/src/Famix-Traits/FamixTClassHierarchyNavigation.trait.st +++ b/src/Famix-Traits/FamixTClassHierarchyNavigation.trait.st @@ -125,7 +125,7 @@ FamixTClassHierarchyNavigation >> inheritedMethods [ | inheritedMethods | inheritedMethods := OrderedCollection new. self allSuperclassesDo: [:each | - each methodsDo: [:method | + each methods do: [:method | method isPrivate not ifTrue: [inheritedMethods add: method]]]. ^inheritedMethods ] @@ -135,7 +135,7 @@ FamixTClassHierarchyNavigation >> inheritedSignatures [ | inheritedSignatures | inheritedSignatures := Set new. self superclassHierarchy do: [:each | - each methodsDo: [:method | + each methods do: [:method | method isPrivate not ifTrue: [inheritedSignatures add: method signature]]]. ^ inheritedSignatures ] @@ -145,7 +145,7 @@ FamixTClassHierarchyNavigation >> inheritedSignaturesToMethod [ | inheritedSignaturesToMethod | inheritedSignaturesToMethod := Dictionary new. self allSuperclassesDo: [:each | - each methodsDo: [:method | + each methods do: [:method | method isPrivate ifFalse: [ inheritedSignaturesToMethod at: method signature ifAbsentPut: [method]]]]. ^ inheritedSignaturesToMethod diff --git a/src/Famix-Traits/FamixTWithMethods.trait.st b/src/Famix-Traits/FamixTWithMethods.trait.st index fe8840d93..49e615e0d 100644 --- a/src/Famix-Traits/FamixTWithMethods.trait.st +++ b/src/Famix-Traits/FamixTWithMethods.trait.st @@ -49,11 +49,6 @@ FamixTWithMethods >> methods: anObject [ ] -{ #category : #enumeration } -FamixTWithMethods >> methodsDo: aBlock [ - self methods do: aBlock -] - { #category : #accessing } FamixTWithMethods >> methodsGroup [ diff --git a/src/Famix-Traits/FamixTWithMethodsWithAccessesGlue.trait.st b/src/Famix-Traits/FamixTWithMethodsWithAccessesGlue.trait.st index ce0ff39d3..714fdf753 100644 --- a/src/Famix-Traits/FamixTWithMethodsWithAccessesGlue.trait.st +++ b/src/Famix-Traits/FamixTWithMethodsWithAccessesGlue.trait.st @@ -38,7 +38,7 @@ FamixTWithMethodsWithAccessesGlue >> tightClassCohesion [ tcc := 0. accessDictionary := Dictionary new. self - methodsDo: [ :eachMethod | + methods do: [ :eachMethod | eachMethod accesses do: [ :eachAccess | | var | From 2c86d171bc5ab3d4e49712a7021b424b9358fcf3 Mon Sep 17 00:00:00 2001 From: Anne Etien Date: Mon, 29 Apr 2019 12:05:52 +0200 Subject: [PATCH 0012/1076] Correcting tests related to hasClassScope -> isClassSide --- .../FamixStMethod.class.st | 2 +- src/Famix-Smalltalk-Utils/RBVisitorForFAMIX.class.st | 2 +- .../MooseMonticelloMethodPopulator.class.st | 2 +- .../FamixReferenceModelImporterTest.class.st | 10 +++++----- ...eModelMergingClassAndMetaclassImporterTest.class.st | 4 ++-- .../LANSmalltalkAccessTest.class.st | 8 ++++---- 6 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Famix-PharoSmalltalk-Entities/FamixStMethod.class.st b/src/Famix-PharoSmalltalk-Entities/FamixStMethod.class.st index ef6159b55..7c5300718 100644 --- a/src/Famix-PharoSmalltalk-Entities/FamixStMethod.class.st +++ b/src/Famix-PharoSmalltalk-Entities/FamixStMethod.class.st @@ -412,7 +412,7 @@ FamixStMethod >> smalltalkClass [ ^ ('*_class' match: self parentType name) ifTrue: [self parentType smalltalkClass] - ifFalse: [self hasClassScope + ifFalse: [self isClassSide ifTrue: [self parentType smalltalkClass class] ifFalse: [self parentType smalltalkClass]] ] diff --git a/src/Famix-Smalltalk-Utils/RBVisitorForFAMIX.class.st b/src/Famix-Smalltalk-Utils/RBVisitorForFAMIX.class.st index c6cda64c2..4be662eaa 100644 --- a/src/Famix-Smalltalk-Utils/RBVisitorForFAMIX.class.st +++ b/src/Famix-Smalltalk-Utils/RBVisitorForFAMIX.class.st @@ -31,7 +31,7 @@ RBVisitorForFAMIX >> compiledMethod [ | selector mooseEntity realSTClass | mooseEntity := self methodEntity. selector := mooseEntity name. - realSTClass := (mooseEntity hasClassScope and: [self stClass class ~= TraitedMetaclass]) + realSTClass := (mooseEntity isClassSide and: [self stClass class ~= TraitedMetaclass]) ifTrue: [self stClass class] ifFalse: [self stClass]. ^ realSTClass compiledMethodAt: selector ifAbsent:[ ] diff --git a/src/Moose-MonticelloImporter/MooseMonticelloMethodPopulator.class.st b/src/Moose-MonticelloImporter/MooseMonticelloMethodPopulator.class.st index b206b9078..c91b92ec4 100644 --- a/src/Moose-MonticelloImporter/MooseMonticelloMethodPopulator.class.st +++ b/src/Moose-MonticelloImporter/MooseMonticelloMethodPopulator.class.st @@ -122,7 +122,7 @@ MooseMonticelloMethodPopulator >> visitMethodDefinition: definition [ famixMethod := FAMIXMethod new. famixMethod name: definition selector. famixMethod signature: definition selector. - famixMethod hasClassScope: definition classIsMeta. + famixMethod isClassSide: definition classIsMeta. "note that maybe the class does not exist yet, this happens if the method is an extension" classOnWhichItIsDefined := importer ensureClassNamed: definition className. classOnWhichItIsDefined addMethod: famixMethod. diff --git a/src/Moose-Tests-SmalltalkImporter-Core/FamixReferenceModelImporterTest.class.st b/src/Moose-Tests-SmalltalkImporter-Core/FamixReferenceModelImporterTest.class.st index e07ca8614..eb1f13a88 100644 --- a/src/Moose-Tests-SmalltalkImporter-Core/FamixReferenceModelImporterTest.class.st +++ b/src/Moose-Tests-SmalltalkImporter-Core/FamixReferenceModelImporterTest.class.st @@ -48,7 +48,7 @@ FamixReferenceModelImporterTest >> testAbstractMethodAnnotation [ method := self model entityNamed: methodName. self assert: method isNil not. self assert: method belongsTo equals: (self model entityNamed: TheRoot mooseName). - self assert: method hasClassScope not. + self assert: method isClassSide not. self assert: method signature equals: (FamixSmalltalkNameResolver signatureFromSmalltalkSelectorOn: #sendingSubclassResponsibility). @@ -379,7 +379,7 @@ FamixReferenceModelImporterTest >> testConstantMethodAnnotation [ method := self model entityNamed: methodUniqueName. self assert: method isNil not. self assert: method belongsTo equals: (self model entityNamed: TheRoot mooseName). - self assert: method hasClassScope not. + self assert: method isClassSide not. self assert: method signature equals: (FamixSmalltalkNameResolver signatureFromSmalltalkSelectorOn: methodName). self assert: method isPublic. self assert: method isConstant @@ -533,7 +533,7 @@ FamixReferenceModelImporterTest >> testGetterMethod [ methodUniqueName := (TheRoot >> methodName) mooseName. method := self model entityNamed: methodUniqueName. self assert: method isNil not. - self assert: method hasClassScope not. + self assert: method isClassSide not. self assert: method signature equals: (FamixSmalltalkNameResolver signatureFromSmalltalkSelectorOn: methodName). self assert: method isPublic. self assert: method isPureAccessor. @@ -685,7 +685,7 @@ FamixReferenceModelImporterTest >> testMethodReification [ method := self model entityNamed: methodUniqueName. self assert: method isNil not. self assert: method belongsTo equals: (self model entityNamed: referenceModelSubRootLevelOneName). - self assert: method hasClassScope not. + self assert: method isClassSide not. self assert: method signature equals: (FamixSmalltalkNameResolver signatureFromSmalltalkSelectorOn: #accessSuperclassInstVar). self assert: method isPublic ] @@ -771,7 +771,7 @@ FamixReferenceModelImporterTest >> testSetterMethod [ method := self model entityNamed: methodUniqueName. self assert: method isNil not. self assert: method belongsTo equals: (self model entityNamed: TheRoot mooseName). - self assert: method hasClassScope not. + self assert: method isClassSide not. self assert: method signature equals: (FamixSmalltalkNameResolver signatureFromSmalltalkSelectorOn: methodName). self assert: method isPublic. self assert: method isPureAccessor. diff --git a/src/Moose-Tests-SmalltalkImporter-Core/FamixReferenceModelMergingClassAndMetaclassImporterTest.class.st b/src/Moose-Tests-SmalltalkImporter-Core/FamixReferenceModelMergingClassAndMetaclassImporterTest.class.st index d3456701a..b1fab237b 100644 --- a/src/Moose-Tests-SmalltalkImporter-Core/FamixReferenceModelMergingClassAndMetaclassImporterTest.class.st +++ b/src/Moose-Tests-SmalltalkImporter-Core/FamixReferenceModelMergingClassAndMetaclassImporterTest.class.st @@ -121,8 +121,8 @@ FamixReferenceModelMergingClassAndMetaclassImporterTest >> testMetaclassMethodHa theRoot := self model entityNamed: #Smalltalk::TheRoot. instanceMethod := self model entityNamed: #'Smalltalk::TheRoot.accessingClass()'. classMethod := self model entityNamed: #'Smalltalk::TheRoot.classSend()'. - self assert: instanceMethod hasClassScope not. - self assert: classMethod hasClassScope. + self assert: instanceMethod isClassSide not. + self assert: classMethod isClassSide. self assert: instanceMethod belongsTo equals: theRoot. self assert: classMethod belongsTo equals: theRoot ] diff --git a/src/Moose-Tests-SmalltalkImporter-LAN/LANSmalltalkAccessTest.class.st b/src/Moose-Tests-SmalltalkImporter-LAN/LANSmalltalkAccessTest.class.st index 29da0c0e2..7b064d094 100644 --- a/src/Moose-Tests-SmalltalkImporter-LAN/LANSmalltalkAccessTest.class.st +++ b/src/Moose-Tests-SmalltalkImporter-LAN/LANSmalltalkAccessTest.class.st @@ -24,8 +24,8 @@ LANSmalltalkAccessTest >> testWhenDistinguishingClassAndMetaclassAccessWorks [ self deny: (model entityNamed: LANNode class mooseName) isInstanceSide. self assert: (model entityNamed: (LANNode >> #accept:) mooseName) compiledMethod equals: LANNode >> #accept:. self assert: (model entityNamed: (LANNode class >> #new) mooseName) compiledMethod equals: LANNode class >> #new. - self deny: (model entityNamed: (LANNode >> #accept:) mooseName) hasClassScope. - self assert: (model entityNamed: (LANNode class >> #new) mooseName) hasClassScope. + self deny: (model entityNamed: (LANNode >> #accept:) mooseName) isClassSide. + self assert: (model entityNamed: (LANNode class >> #new) mooseName) isClassSide. self assert: (model entityNamed: (LANNode >> #accept:) mooseName) smalltalkClass equals: LANNode. self assert: (model entityNamed: (LANNode class >> #new) mooseName) smalltalkClass equals: LANNode class ] @@ -47,8 +47,8 @@ LANSmalltalkAccessTest >> testWhenMergingClassAndMetaclassAccessWorks [ self assert: (model entityNamed: LANNode mooseName) smalltalkClass equals: LANNode. self assert: (model entityNamed: (LANNode >> #accept:) mooseName) compiledMethod equals: LANNode >> #accept:. self assert: (model entityNamed: LANNode mooseName) isInstanceSide. - self deny: (model entityNamed: (LANNode >> #accept:) mooseName) hasClassScope. - self assert: (model entityNamed: #'Smalltalk::LANNode.new()') hasClassScope. + self deny: (model entityNamed: (LANNode >> #accept:) mooseName) isClassSide. + self assert: (model entityNamed: #'Smalltalk::LANNode.new()') isClassSide. self assert: (model entityNamed: (LANNode >> #accept:) mooseName) smalltalkClass equals: LANNode. self assert: (model entityNamed: #'Smalltalk::LANNode.new()') smalltalkClass equals: LANNode class. self assert: (model entityNamed: #'Smalltalk::LANNode.new()') compiledMethod equals: LANNode class >> #new From 97f156f4b8d6eef5d51b32a64034623fb8a2083d Mon Sep 17 00:00:00 2001 From: CyrilFerlicot Date: Mon, 29 Apr 2019 14:25:34 +0200 Subject: [PATCH 0013/1076] Remove useless pragma + remove ClassDescription from the basic metamodel classes Fixes #1501 --- .../FamixMetamodelGenerator.class.st | 2 +- src/Moose-Core/ClassDescription.extension.st | 10 +++------- 2 files changed, 4 insertions(+), 8 deletions(-) diff --git a/src/Famix-MetamodelBuilder-Core/FamixMetamodelGenerator.class.st b/src/Famix-MetamodelBuilder-Core/FamixMetamodelGenerator.class.st index 041df4556..c49d60504 100644 --- a/src/Famix-MetamodelBuilder-Core/FamixMetamodelGenerator.class.st +++ b/src/Famix-MetamodelBuilder-Core/FamixMetamodelGenerator.class.st @@ -24,7 +24,7 @@ FamixMetamodelGenerator class >> basicFamixTraits [ { #category : #accessing } FamixMetamodelGenerator class >> basicMetamodelClasses [ - ^ ({ Trait. Class. ClassDescription. Behavior. MooseEntity. FmxImportingContext. FamixTSourceLanguage. FamixTWithSourceLanguage}, MooseAbstractGroup withAllSubclasses) asOrderedCollection. + ^ ({ Trait. Class. Behavior. MooseEntity. FmxImportingContext. FamixTSourceLanguage. FamixTWithSourceLanguage}, MooseAbstractGroup withAllSubclasses) asOrderedCollection. ] { #category : #accessing } diff --git a/src/Moose-Core/ClassDescription.extension.st b/src/Moose-Core/ClassDescription.extension.st index 5d2eb3bf8..529bd9630 100644 --- a/src/Moose-Core/ClassDescription.extension.st +++ b/src/Moose-Core/ClassDescription.extension.st @@ -3,16 +3,12 @@ Extension { #name : #ClassDescription } { #category : #'*Moose-Core' } ClassDescription >> @ aSymbol [ "TheRoot@#TheRootSharedVariable" + "TheRoot class@#uniqueInstance" - - - "This method is supposed to be local in ClassDescription because in TClassDescription it - would cause conflict with TraitDescription>>@. We use this pragma to test if Trait does - not contain some accidental local selectors." ^ ((aSymbol first isUppercase - ifTrue: [self instanceSide] - ifFalse: [self]) mooseName, '.', aSymbol ) asSymbol + ifTrue: [ self instanceSide ] + ifFalse: [ self ]) mooseName , '.' , aSymbol) asSymbol ] { #category : #'*Moose-Core' } From ed8755c3f0dda26feb8441e8c38d33a9e8c4e50b Mon Sep 17 00:00:00 2001 From: CyrilFerlicot Date: Mon, 29 Apr 2019 14:32:09 +0200 Subject: [PATCH 0014/1076] Cannot remove ClassDescription from classes to check with pragma processor :( --- .../FamixMetamodelGenerator.class.st | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Famix-MetamodelBuilder-Core/FamixMetamodelGenerator.class.st b/src/Famix-MetamodelBuilder-Core/FamixMetamodelGenerator.class.st index c49d60504..041df4556 100644 --- a/src/Famix-MetamodelBuilder-Core/FamixMetamodelGenerator.class.st +++ b/src/Famix-MetamodelBuilder-Core/FamixMetamodelGenerator.class.st @@ -24,7 +24,7 @@ FamixMetamodelGenerator class >> basicFamixTraits [ { #category : #accessing } FamixMetamodelGenerator class >> basicMetamodelClasses [ - ^ ({ Trait. Class. Behavior. MooseEntity. FmxImportingContext. FamixTSourceLanguage. FamixTWithSourceLanguage}, MooseAbstractGroup withAllSubclasses) asOrderedCollection. + ^ ({ Trait. Class. ClassDescription. Behavior. MooseEntity. FmxImportingContext. FamixTSourceLanguage. FamixTWithSourceLanguage}, MooseAbstractGroup withAllSubclasses) asOrderedCollection. ] { #category : #accessing } From 22c235efb8bd5deb0bc3cb0072323ac688ff29ae Mon Sep 17 00:00:00 2001 From: CyrilFerlicot Date: Mon, 29 Apr 2019 15:38:08 +0200 Subject: [PATCH 0015/1076] Make Moose work with metalinks. Fixes #1503 --- .../FMPragmaProcessor.class.st | 45 ++++++++++--------- 1 file changed, 25 insertions(+), 20 deletions(-) diff --git a/src/Fame-SmalltalkBinding/FMPragmaProcessor.class.st b/src/Fame-SmalltalkBinding/FMPragmaProcessor.class.st index 9c1035938..279250bb1 100644 --- a/src/Fame-SmalltalkBinding/FMPragmaProcessor.class.st +++ b/src/Fame-SmalltalkBinding/FMPragmaProcessor.class.st @@ -225,37 +225,42 @@ FMPragmaProcessor >> processClass: aClass ifPragmaAbsent: anErrorBlock [ { #category : #private } FMPragmaProcessor >> processCompiledMethod: aMethod [ - | pragma prop | - aMethod isCompiledMethod should beTrue. - pragma := Pragma inMethod: aMethod named: #(#MSEProperty:type:opposite: #MSEProperty:type:). + | pragma prop method | + method := aMethod. + + "If the method is a reflective method we need to ensure it is compiled and use its compiled method. + A refelctive method is for exemple a method created via a metalink and that was never executed." + (aMethod isKindOf: ReflectiveMethod) + ifTrue: [ aMethod compileAndInstallCompiledMethod. + method := aMethod compiledMethod ]. + + method isCompiledMethod should beTrue. + pragma := Pragma inMethod: method named: #(#MSEProperty:type:opposite: #MSEProperty:type:). pragma ifNil: [ ^ self ]. prop := FM3PropertyDescription new. - (Pragma inMethod: aMethod named: #package:) + (Pragma inMethod: method named: #package:) ifNotNil: [ :p | | packageName | packageName := p argumentAt: 1. - (self allowPackageNamed: packageName) - ifFalse: [ ^ self ]. + (self allowPackageNamed: packageName) ifFalse: [ ^ self ]. packPropDict at: prop put: packageName ]. "we check the package first because if we do not want to load it, we ignore the whole property" prop name: (pragma argumentAt: 1) asString. typeDict at: prop put: (pragma argumentAt: 2). - mmClassDict at: prop put: aMethod methodClass. - prop setImplementingSelector: aMethod selector. - pragma keyword = #MSEProperty:type:opposite: - ifTrue: [ oppositeDict at: prop put: (pragma argumentAt: 3) ]. - (Pragma inMethod: aMethod named: #container) ifNotNil: [ prop isContainer: true ]. - (Pragma inMethod: aMethod named: #derived) ifNotNil: [ prop isDerived: true ]. - (Pragma inMethod: aMethod named: #source) ifNotNil: [ prop isSource: true ]. - (Pragma inMethod: aMethod named: #target) ifNotNil: [ prop isTarget: true ]. - (Pragma inMethod: aMethod named: #multivalued) - ifNotNil: [self - assert: prop isContainer not - description: 'It is not possible to have and on the same method. container represents a aggregation UML link that is incompatible with the multivalue kind of the link' . + mmClassDict at: prop put: method methodClass. + prop setImplementingSelector: method selector. + pragma keyword = #MSEProperty:type:opposite: ifTrue: [ oppositeDict at: prop put: (pragma argumentAt: 3) ]. + (Pragma inMethod: method named: #container) ifNotNil: [ prop isContainer: true ]. + (Pragma inMethod: method named: #derived) ifNotNil: [ prop isDerived: true ]. + (Pragma inMethod: method named: #source) ifNotNil: [ prop isSource: true ]. + (Pragma inMethod: method named: #target) ifNotNil: [ prop isTarget: true ]. + (Pragma inMethod: method named: #multivalued) + ifNotNil: [ self + assert: prop isContainer not + description: 'It is not possible to have and on the same method. container represents a aggregation UML link that is incompatible with the multivalue kind of the link'. prop isMultivalued: true ]. - (Pragma inMethod: aMethod named: #key:) - ifNotNil: [ prop key: ((Pragma inMethod: aMethod named: #key:) argumentAt: 1) ]. + (Pragma inMethod: method named: #key:) ifNotNil: [ prop key: ((Pragma inMethod: method named: #key:) argumentAt: 1) ]. elements add: prop ] From c5a14751f0bdf8a887975a19bd26ab68c4694218 Mon Sep 17 00:00:00 2001 From: CyrilFerlicot Date: Mon, 29 Apr 2019 15:40:18 +0200 Subject: [PATCH 0016/1076] Cleaning --- src/Fame-SmalltalkBinding/FMPragmaProcessor.class.st | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Fame-SmalltalkBinding/FMPragmaProcessor.class.st b/src/Fame-SmalltalkBinding/FMPragmaProcessor.class.st index 279250bb1..1a394be6e 100644 --- a/src/Fame-SmalltalkBinding/FMPragmaProcessor.class.st +++ b/src/Fame-SmalltalkBinding/FMPragmaProcessor.class.st @@ -227,13 +227,13 @@ FMPragmaProcessor >> processClass: aClass ifPragmaAbsent: anErrorBlock [ FMPragmaProcessor >> processCompiledMethod: aMethod [ | pragma prop method | method := aMethod. - + "If the method is a reflective method we need to ensure it is compiled and use its compiled method. A refelctive method is for exemple a method created via a metalink and that was never executed." (aMethod isKindOf: ReflectiveMethod) ifTrue: [ aMethod compileAndInstallCompiledMethod. method := aMethod compiledMethod ]. - + method isCompiledMethod should beTrue. pragma := Pragma inMethod: method named: #(#MSEProperty:type:opposite: #MSEProperty:type:). pragma ifNil: [ ^ self ]. @@ -260,7 +260,7 @@ FMPragmaProcessor >> processCompiledMethod: aMethod [ assert: prop isContainer not description: 'It is not possible to have and on the same method. container represents a aggregation UML link that is incompatible with the multivalue kind of the link'. prop isMultivalued: true ]. - (Pragma inMethod: method named: #key:) ifNotNil: [ prop key: ((Pragma inMethod: method named: #key:) argumentAt: 1) ]. + (Pragma inMethod: method named: #key:) ifNotNil: [ :p | prop key: (p argumentAt: 1) ]. elements add: prop ] From 500f520d5714ee8eae116531ac6d931ebe774d7e Mon Sep 17 00:00:00 2001 From: Anne Etien Date: Mon, 29 Apr 2019 18:34:44 +0200 Subject: [PATCH 0017/1076] Changing metamodels correcting bugs moving computeNumberOfLinesOfCodes to TWithSourceAnchor --- src/BaselineOfMoose/BaselineOfMoose.class.st | 1 + .../FAMIXMethod.class.st | 2 +- .../FAMIXTypeAliasTest.class.st | 2 + .../VerveineJModelTest.class.st | 5 +- .../FamixJavaMethod.class.st | 2 +- .../FamixStMethod.class.st | 19 +----- .../FamixSmalltalkMethodTest.class.st | 63 +++++++++++++++++++ src/Famix-PharoSmalltalk-Tests/package.st | 1 + .../FamixTClassHierarchyNavigation.trait.st | 8 ++- src/Famix-Traits/FamixTMethod.trait.st | 24 ------- src/Famix-Traits/FamixTWithMethods.trait.st | 2 +- .../FamixTWithSourceAnchor.trait.st | 29 +++++++++ src/Moose-Core/MooseGroup.class.st | 4 +- src/Moose-Finder/Object.extension.st | 10 ++- .../MooseMonticelloMethodPopulator.class.st | 2 +- .../AbstractSmalltalkMethodVisitor.class.st | 4 +- ...talkCompatibilityMetamodelFactory.class.st | 2 +- .../SmalltalkImporter.class.st | 4 +- .../MooseMonticelloImporterTest.class.st | 1 + .../FamixPropertiesTest.class.st | 1 + .../FamixReferenceModelImporterTest.class.st | 4 +- ...oseSmalltalkImporterRoelTyperTest.class.st | 4 +- ...eryTypeDeclarationAssociationTest.class.st | 2 + .../LANImporterTest.class.st | 4 +- 24 files changed, 136 insertions(+), 64 deletions(-) create mode 100644 src/Famix-PharoSmalltalk-Tests/FamixSmalltalkMethodTest.class.st create mode 100644 src/Famix-PharoSmalltalk-Tests/package.st diff --git a/src/BaselineOfMoose/BaselineOfMoose.class.st b/src/BaselineOfMoose/BaselineOfMoose.class.st index 3789d3810..1b0dfa3e6 100644 --- a/src/BaselineOfMoose/BaselineOfMoose.class.st +++ b/src/BaselineOfMoose/BaselineOfMoose.class.st @@ -206,6 +206,7 @@ BaselineOfMoose >> baselineFamixNG: spec [ package: 'Famix-PharoSmalltalk-Generator'; package: 'Famix-PharoSmalltalk-Entities'; package: 'Famix-PharoSmalltalk-Importer'; + package: 'Famix-PharoSmalltalk-Tests'; package: 'Famix-Java-Generator'; package: 'Famix-Java-Entities'; diff --git a/src/Famix-Compatibility-Entities/FAMIXMethod.class.st b/src/Famix-Compatibility-Entities/FAMIXMethod.class.st index c52746831..7f93e801b 100644 --- a/src/Famix-Compatibility-Entities/FAMIXMethod.class.st +++ b/src/Famix-Compatibility-Entities/FAMIXMethod.class.st @@ -135,7 +135,7 @@ FAMIXMethod >> copyFrom: anEntity within: aVisitor [ super copyFrom: anEntity within: aVisitor. self kind: anEntity kind copy. - self category: anEntity category copy. + self protocol: anEntity protocol copy. ] diff --git a/src/Famix-Compatibility-Tests-Core/FAMIXTypeAliasTest.class.st b/src/Famix-Compatibility-Tests-Core/FAMIXTypeAliasTest.class.st index 2c277ccf9..f08ddbc39 100644 --- a/src/Famix-Compatibility-Tests-Core/FAMIXTypeAliasTest.class.st +++ b/src/Famix-Compatibility-Tests-Core/FAMIXTypeAliasTest.class.st @@ -30,6 +30,8 @@ FAMIXTypeAliasTest >> testAliasOpposite [ { #category : #tests } FAMIXTypeAliasTest >> testAliasSubclasses [ | type subtype alias | + self skip. + self flag: 'Manage alias after FamixNG refactoring'. subtype := FAMIXType new name: 'SubType'. type := FAMIXType new name: 'Type'. diff --git a/src/Famix-Compatibility-Tests-Java/VerveineJModelTest.class.st b/src/Famix-Compatibility-Tests-Java/VerveineJModelTest.class.st index 59e85e2be..b3db29881 100644 --- a/src/Famix-Compatibility-Tests-Java/VerveineJModelTest.class.st +++ b/src/Famix-Compatibility-Tests-Java/VerveineJModelTest.class.st @@ -10,7 +10,10 @@ Class { { #category : #running } VerveineJModelTest >> setUp [ super setUp. - model := VerveineJTestResource current model + model := MooseModel new. + model metamodel: FamixCompatibilityGenerator metamodel. + model importFromMSEStream: VerveineJTestResource new mse readStream + ] { #category : #tests } diff --git a/src/Famix-Java-Entities/FamixJavaMethod.class.st b/src/Famix-Java-Entities/FamixJavaMethod.class.st index 4c2a22bec..02650a308 100644 --- a/src/Famix-Java-Entities/FamixJavaMethod.class.st +++ b/src/Famix-Java-Entities/FamixJavaMethod.class.st @@ -112,7 +112,7 @@ FamixJavaMethod >> copyFrom: anEntity within: aVisitor [ super copyFrom: anEntity within: aVisitor. self kind: anEntity kind copy. - self category: anEntity category copy. + "self category: anEntity category copy." ] diff --git a/src/Famix-PharoSmalltalk-Entities/FamixStMethod.class.st b/src/Famix-PharoSmalltalk-Entities/FamixStMethod.class.st index 7c5300718..567f43580 100644 --- a/src/Famix-PharoSmalltalk-Entities/FamixStMethod.class.st +++ b/src/Famix-PharoSmalltalk-Entities/FamixStMethod.class.st @@ -68,15 +68,6 @@ FamixStMethod >> belongsTo: anObject [ ] -{ #category : #'Famix-Extensions-metrics-support' } -FamixStMethod >> category [ - - - - - ^ self privateState attributeAt: #category ifAbsentPut: [ nil ] -] - { #category : #'Famix-Extensions-metrics-support' } FamixStMethod >> category: aString [ @@ -96,11 +87,7 @@ FamixStMethod >> compiledMethod [ { #category : #'Famix-Extensions-private' } FamixStMethod >> computeNumberOfLinesOfCodeIfSmalltalk [ - | parser | - - parser := RBVisitorForFAMIXMetrics new. - parser processMethod: self usingImporter: nil inModel: nil. - ^ parser numberOfLinesOfCode + ^self sourceText lineCount. ] { #category : #'Famix-Extensions-private' } @@ -155,7 +142,7 @@ FamixStMethod >> hierarchyNestingLevel: aNumber [ { #category : #'Famix-Extensions-metrics-support' } FamixStMethod >> initialize [ super initialize. - hasClassScope := false + isClassSide := false ] { #category : #'Famix-Extensions' } @@ -180,7 +167,7 @@ FamixStMethod >> isCalledInternally [ { #category : #'Famix-Extensions-metrics-support' } FamixStMethod >> isInitializer [ - ^ (('*initialize*' match: self category) or: [ '*initialize*' match: self name ]) or: [ self isConstructor ] + ^ (('*initialize*' match: self protocol) or: [ '*initialize*' match: self name ]) or: [ self isConstructor ] ] { #category : #'Famix-Extensions-metrics-support' } diff --git a/src/Famix-PharoSmalltalk-Tests/FamixSmalltalkMethodTest.class.st b/src/Famix-PharoSmalltalk-Tests/FamixSmalltalkMethodTest.class.st new file mode 100644 index 000000000..1316cd14b --- /dev/null +++ b/src/Famix-PharoSmalltalk-Tests/FamixSmalltalkMethodTest.class.st @@ -0,0 +1,63 @@ +Class { + #name : #FamixSmalltalkMethodTest, + #superclass : #TestCase, + #instVars : [ + 'model', + 'c1', + 'c2', + 'c3', + 'm1', + 'm2', + 'm3', + 'anchor1', + 'anchor2', + 'anchor3' + ], + #category : #'Famix-PharoSmalltalk-Tests' +} + +{ #category : #running } +FamixSmalltalkMethodTest >> setUp [ + + super setUp. + + model := MooseModel new. + model metamodel: FamixTest1Class metamodel. + c1 := FamixStClass named: 'Class1'. + c2 := FamixStClass named: 'Class2'. + m1 := FamixStMethod named: 'method1'. + m2 := FamixStMethod named: 'method2'. + m3 := FamixStMethod named: 'method3'. + anchor1 := FamixStSourceTextAnchor new source: 'method1\source1' withCRs . + anchor2 := FamixStSourceTextAnchor new source: 'method2\source2a\source2b' withCRs. + anchor3 := FamixStSourceTextAnchor new source: 'method3\source3a\source3b\source3c' withCRs. + + model addAll: { c1. c2. m1. m2. m3. anchor1. anchor2 }. + + c1 addMethod: m1. + m2 parentType: c2. "opposite way" + c2 addMethod: m3. + m1 sourceAnchor: anchor1. + m2 sourceAnchor: anchor2. + m3 sourceAnchor: anchor3. + +] + +{ #category : #tests } +FamixSmalltalkMethodTest >> testNumberOfMethodProtocols [ + + m1 protocol: #accessing. + self assert: c1 numberOfMethodProtocols equals: 1. + c1 numberOfMethodProtocols: 100. + self assert: c1 numberOfMethodProtocols equals: 100. + +] + +{ #category : #tests } +FamixSmalltalkMethodTest >> testProtocol [ + + self assert: m1 protocol isNil. + m1 protocol: 'accessing'. + self assert: m1 protocol equals: 'accessing'. + +] diff --git a/src/Famix-PharoSmalltalk-Tests/package.st b/src/Famix-PharoSmalltalk-Tests/package.st new file mode 100644 index 000000000..c0142f38d --- /dev/null +++ b/src/Famix-PharoSmalltalk-Tests/package.st @@ -0,0 +1 @@ +Package { #name : #'Famix-PharoSmalltalk-Tests' } diff --git a/src/Famix-Traits/FamixTClassHierarchyNavigation.trait.st b/src/Famix-Traits/FamixTClassHierarchyNavigation.trait.st index d16c43be4..824544322 100644 --- a/src/Famix-Traits/FamixTClassHierarchyNavigation.trait.st +++ b/src/Famix-Traits/FamixTClassHierarchyNavigation.trait.st @@ -37,7 +37,8 @@ FamixTClassHierarchyNavigation >> addedMethods [ { #category : #enumerating } FamixTClassHierarchyNavigation >> allSubclassesDo: aBlock [ self allSubclassesWithoutAliasesDo: aBlock. - self typeAliases do: [ :each | each allSubclassesWithoutAliasesDo: aBlock ] + self flag: 'Manage typeAlias in C metamodel' + "self typeAliases do: [ :each | each allSubclassesWithoutAliasesDo: aBlock ]" ] { #category : #enumerating } @@ -367,8 +368,9 @@ FamixTClassHierarchyNavigation >> totalNumberOfChildren: aNumber [ FamixTClassHierarchyNavigation >> withSubclassHierarchy [ ^ self subclassHierarchy addFirst: self realType; - addAll: self realType allTypeAliases; - yourself + flag: 'Manage TypeAlias for C metamodel'; + "addAll: self realType allTypeAliases;" + yourself. ] { #category : #'Famix-Implementation' } diff --git a/src/Famix-Traits/FamixTMethod.trait.st b/src/Famix-Traits/FamixTMethod.trait.st index d819699eb..fae89ea0b 100644 --- a/src/Famix-Traits/FamixTMethod.trait.st +++ b/src/Famix-Traits/FamixTMethod.trait.st @@ -45,15 +45,6 @@ FamixTMethod classSide >> generatedTraitNames [ ^ #() ] -{ #category : #'Famix-Implementation' } -FamixTMethod >> computeNumberOfLinesOfCode [ - self hasSourceAnchor - ifTrue: [ ^ self sourceAnchor lineCount ]. - ^ (self sourceText = '') - ifTrue: [ self notExistentMetricValue ] - ifFalse: [ self sourceText lineCount ] -] - { #category : #metrics } FamixTMethod >> cyclomaticComplexity [ @@ -178,21 +169,6 @@ FamixTMethod >> kind: anObject [ ] -{ #category : #'Famix-Implementation' } -FamixTMethod >> numberOfLinesOfCode [ - - - ^ self - lookUpPropertyNamed: #numberOfLinesOfCode - computedAs: [ self computeNumberOfLinesOfCode ] -] - -{ #category : #'Famix-Implementation' } -FamixTMethod >> numberOfLinesOfCode: aNumber [ - - self privateState propertyAt: #numberOfLinesOfCode put: aNumber -] - { #category : #metrics } FamixTMethod >> numberOfMessageSends [ diff --git a/src/Famix-Traits/FamixTWithMethods.trait.st b/src/Famix-Traits/FamixTWithMethods.trait.st index 49e615e0d..72711e75f 100644 --- a/src/Famix-Traits/FamixTWithMethods.trait.st +++ b/src/Famix-Traits/FamixTWithMethods.trait.st @@ -150,7 +150,7 @@ FamixTWithMethods >> numberOfMethodProtocols [ ^self lookUpPropertyNamed: #numberOfMethodProtocols - computedAs: [((self methods collect: [:each | each category]) reject: #isNil) asSet size] + computedAs: [((self methods collect: [:each | each protocol]) reject: #isNil) asSet size] ] { #category : #metrics } diff --git a/src/Famix-Traits/FamixTWithSourceAnchor.trait.st b/src/Famix-Traits/FamixTWithSourceAnchor.trait.st index 37cb99371..549ed5c62 100644 --- a/src/Famix-Traits/FamixTWithSourceAnchor.trait.st +++ b/src/Famix-Traits/FamixTWithSourceAnchor.trait.st @@ -28,11 +28,40 @@ FamixTWithSourceAnchor classSide >> generatedTraitNames [ ^ #() ] +{ #category : #'Famix-Implementation' } +FamixTWithSourceAnchor >> computeNumberOfLinesOfCode [ + self hasSourceAnchor + ifTrue: [ ^ self sourceAnchor lineCount ]. + ^ (self sourceText = '') + ifTrue: [ self notExistentMetricValue ] + ifFalse: [ self sourceText lineCount ] +] + { #category : #testing } FamixTWithSourceAnchor >> hasSourceAnchor [ ^ self sourceAnchor notNil ] +{ #category : #properties } +FamixTWithSourceAnchor >> notExistentMetricValue [ + ^ self explicitRequirement +] + +{ #category : #'Famix-Implementation' } +FamixTWithSourceAnchor >> numberOfLinesOfCode [ + + + ^ self + lookUpPropertyNamed: #numberOfLinesOfCode + computedAs: [ self computeNumberOfLinesOfCode ] +] + +{ #category : #'Famix-Implementation' } +FamixTWithSourceAnchor >> numberOfLinesOfCode: aNumber [ + + self privateState propertyAt: #numberOfLinesOfCode put: aNumber +] + { #category : #metrics } FamixTWithSourceAnchor >> numberOfLinesOfCodeWithMoreThanOneCharacter [ diff --git a/src/Moose-Core/MooseGroup.class.st b/src/Moose-Core/MooseGroup.class.st index 9ed5f3018..867bba6ae 100644 --- a/src/Moose-Core/MooseGroup.class.st +++ b/src/Moose-Core/MooseGroup.class.st @@ -388,10 +388,10 @@ MooseGroup >> sumOfPropertyNamed: aPropertyName [ MooseGroup >> updateTypeAccordingToEntities [ | common wantedType class | common := self commonEntitiesClass. - wantedType := (common name, 'Group') asSymbol. + wantedType := common relatedGroupType. self name = wantedType ifTrue: [ ^ self ]. class := MooseAbstractGroup allSubclasses - detect: [ :each | each name == wantedType ] + detect: [ :each | each name == wantedType name ] ifNone: [ ^ self changeTypeToDefaultType ]. self changeTypeTo: class ] diff --git a/src/Moose-Finder/Object.extension.st b/src/Moose-Finder/Object.extension.st index d5accb292..2e8b40af5 100644 --- a/src/Moose-Finder/Object.extension.st +++ b/src/Moose-Finder/Object.extension.st @@ -48,8 +48,14 @@ Object >> mooseFinderEvaluatorIn: composite [ entitled: 'Do it and go' with: [ :text :entity1 | text selectLine. - GTSnippets snippetAt: self mooseInterestingEntity class put: text text asString. - Smalltalk compiler evaluate: text selectedText for: self mooseInterestingEntity logged: false ] + GTSnippets + snippetAt: self mooseInterestingEntity class + put: text text asString. + Smalltalk compiler + source: text selectedText; + logged: false; + receiver: self mooseInterestingEntity; + evaluate ] ] { #category : #'*Moose-Finder' } diff --git a/src/Moose-MonticelloImporter/MooseMonticelloMethodPopulator.class.st b/src/Moose-MonticelloImporter/MooseMonticelloMethodPopulator.class.st index c91b92ec4..82100d403 100644 --- a/src/Moose-MonticelloImporter/MooseMonticelloMethodPopulator.class.st +++ b/src/Moose-MonticelloImporter/MooseMonticelloMethodPopulator.class.st @@ -119,7 +119,7 @@ MooseMonticelloMethodPopulator >> setInfoOn: famixMethod withSource: sourceAsStr { #category : #visiting } MooseMonticelloMethodPopulator >> visitMethodDefinition: definition [ | famixMethod classOnWhichItIsDefined | - famixMethod := FAMIXMethod new. + famixMethod := FamixStMethod new. famixMethod name: definition selector. famixMethod signature: definition selector. famixMethod isClassSide: definition classIsMeta. diff --git a/src/Moose-SmalltalkImporter/AbstractSmalltalkMethodVisitor.class.st b/src/Moose-SmalltalkImporter/AbstractSmalltalkMethodVisitor.class.st index 7f5fe7664..d2da9e964 100644 --- a/src/Moose-SmalltalkImporter/AbstractSmalltalkMethodVisitor.class.st +++ b/src/Moose-SmalltalkImporter/AbstractSmalltalkMethodVisitor.class.st @@ -100,9 +100,9 @@ AbstractSmalltalkMethodVisitor >> matchConstant: aMethodNode [ { #category : #'method-classifying' } AbstractSmalltalkMethodVisitor >> matchConstructor: aMethodNode [ - famixMethod category notNil + famixMethod protocol notNil ifTrue: - [('*instance*creation*' match: famixMethod category asLowercase) + [('*instance*creation*' match: famixMethod protocol asLowercase) ifTrue: [famixMethod kind: #constructor]] ] diff --git a/src/Moose-SmalltalkImporter/SmalltalkCompatibilityMetamodelFactory.class.st b/src/Moose-SmalltalkImporter/SmalltalkCompatibilityMetamodelFactory.class.st index 4a7ae7f77..065640925 100644 --- a/src/Moose-SmalltalkImporter/SmalltalkCompatibilityMetamodelFactory.class.st +++ b/src/Moose-SmalltalkImporter/SmalltalkCompatibilityMetamodelFactory.class.st @@ -13,7 +13,7 @@ SmalltalkCompatibilityMetamodelFactory >> anchor [ { #category : #'as yet unclassified' } SmalltalkCompatibilityMetamodelFactory >> defaultMetamodelClass [ - ^ FamixCompatibilityGenerator + ^ FamixPharoSmalltalkGenerator ] { #category : #'as yet unclassified' } diff --git a/src/Moose-SmalltalkImporter/SmalltalkImporter.class.st b/src/Moose-SmalltalkImporter/SmalltalkImporter.class.st index b9699063b..a18be7a2e 100644 --- a/src/Moose-SmalltalkImporter/SmalltalkImporter.class.st +++ b/src/Moose-SmalltalkImporter/SmalltalkImporter.class.st @@ -209,11 +209,10 @@ SmalltalkImporter >> createMethod: aCompiledMethod [ ifTrue: [ method parentPackage: (self ensurePackage: aRPackage) ] ]. method isClassSide: aCompiledMethod methodClass isMeta. method - category: + protocol: (aCompiledMethod methodClass organization categoryOfElement: aCompiledMethod selector). method isPublic: true. - method timeStamp: aCompiledMethod timeStamp. importingContext shouldImportMethodBody ifTrue: [ | visitor | visitor := SmalltalkMethodVisitor on: self. @@ -411,7 +410,6 @@ SmalltalkImporter >> factory [ { #category : #accessing } SmalltalkImporter >> factory: anObject [ - factory := anObject ] diff --git a/src/Moose-Tests-MonticelloImporter/MooseMonticelloImporterTest.class.st b/src/Moose-Tests-MonticelloImporter/MooseMonticelloImporterTest.class.st index ba9469448..6794f470e 100644 --- a/src/Moose-Tests-MonticelloImporter/MooseMonticelloImporterTest.class.st +++ b/src/Moose-Tests-MonticelloImporter/MooseMonticelloImporterTest.class.st @@ -85,6 +85,7 @@ MooseMonticelloImporterTest >> testAssertion [ MooseMonticelloImporterTest >> testImporting [ | mooseModel noStubClasses allClasses objectClass class1 classWithIncomingAccess | mooseModel := importer importLastVersionOf: self packageToTest. + mooseModel metamodel: FamixPharoSmalltalkGenerator metamodel. allClasses := mooseModel allClasses. self assert: mooseModel class == MooseModel. noStubClasses := allClasses reject: #isStub. diff --git a/src/Moose-Tests-SmalltalkImporter-Core/FamixPropertiesTest.class.st b/src/Moose-Tests-SmalltalkImporter-Core/FamixPropertiesTest.class.st index 744e1936a..8da8821db 100644 --- a/src/Moose-Tests-SmalltalkImporter-Core/FamixPropertiesTest.class.st +++ b/src/Moose-Tests-SmalltalkImporter-Core/FamixPropertiesTest.class.st @@ -73,6 +73,7 @@ FamixPropertiesTest >> testClassAttributes [ { #category : #testing } FamixPropertiesTest >> testClassCategories [ +"1halt." self assert: (self nodeClass propertyNamed: #numberOfMethodProtocols) equals: 6. self assert: self nodeClass numberOfMethodProtocols equals: 6 ] diff --git a/src/Moose-Tests-SmalltalkImporter-Core/FamixReferenceModelImporterTest.class.st b/src/Moose-Tests-SmalltalkImporter-Core/FamixReferenceModelImporterTest.class.st index eb1f13a88..ad5abc7db 100644 --- a/src/Moose-Tests-SmalltalkImporter-Core/FamixReferenceModelImporterTest.class.st +++ b/src/Moose-Tests-SmalltalkImporter-Core/FamixReferenceModelImporterTest.class.st @@ -305,7 +305,7 @@ FamixReferenceModelImporterTest >> testClassMethodAnnotation [ hasClassScope: false class: definingClassName. method := self model entityNamed: methodUniqueName. - self assert: method category equals: #'accessing superclassinstance on class side' + self assert: method protocol equals: #'accessing superclassinstance on class side' ] { #category : #'new tests' } @@ -667,7 +667,7 @@ FamixReferenceModelImporterTest >> testMethodAnnotation [ class: definingClassName. method := self model entityNamed: methodUniqueName ifAbsent: [ nil ]. self assert: method name equals: #accessSuperclassInstVar. - self assert: method category equals: #accessingSuperclassInstVar + self assert: method protocol equals: #accessingSuperclassInstVar ] { #category : #'reference model reification' } diff --git a/src/Moose-Tests-SmalltalkImporter-Core/MooseSmalltalkImporterRoelTyperTest.class.st b/src/Moose-Tests-SmalltalkImporter-Core/MooseSmalltalkImporterRoelTyperTest.class.st index a7860f934..3e7dc7538 100644 --- a/src/Moose-Tests-SmalltalkImporter-Core/MooseSmalltalkImporterRoelTyperTest.class.st +++ b/src/Moose-Tests-SmalltalkImporter-Core/MooseSmalltalkImporterRoelTyperTest.class.st @@ -11,8 +11,8 @@ MooseSmalltalkImporterRoelTyperTest >> testASTCore [ self timeLimit: 60 seconds. importer := self newPharoImporterTask. importer importingContext - mergeClassAndMetaclass; - computeTypeOfAttributes. + mergeClassAndMetaclass"; + computeTypeOfAttributes". importer runCandidateOperator. self shouldnt: [ importer diff --git a/src/Moose-Tests-SmalltalkImporter-KGB/MooseQueryTypeDeclarationAssociationTest.class.st b/src/Moose-Tests-SmalltalkImporter-KGB/MooseQueryTypeDeclarationAssociationTest.class.st index c11f2a828..1fe8ca8d0 100644 --- a/src/Moose-Tests-SmalltalkImporter-KGB/MooseQueryTypeDeclarationAssociationTest.class.st +++ b/src/Moose-Tests-SmalltalkImporter-KGB/MooseQueryTypeDeclarationAssociationTest.class.st @@ -192,6 +192,8 @@ MooseQueryTypeDeclarationAssociationTest >> setUp [ add: pr1 ; add: pr2 ; yourself). + + self model metamodel: FamixPharoSmalltalkGenerator metamodel. ] diff --git a/src/Moose-Tests-SmalltalkImporter-LAN/LANImporterTest.class.st b/src/Moose-Tests-SmalltalkImporter-LAN/LANImporterTest.class.st index 009d22c4c..be608aaaa 100644 --- a/src/Moose-Tests-SmalltalkImporter-LAN/LANImporterTest.class.st +++ b/src/Moose-Tests-SmalltalkImporter-LAN/LANImporterTest.class.st @@ -188,8 +188,8 @@ LANImporterTest >> testHierarchyRoot [ { #category : #tests } LANImporterTest >> testImportCategory [ - self assert: (self model entityNamed: #'Smalltalk::LANInterface.cancel()') category equals: #actions. - self assert: (self model entityNamed: #'Smalltalk::LANInterface.addressee()') category equals: #aspects + self assert: (self model entityNamed: #'Smalltalk::LANInterface.cancel()') protocol equals: #actions. + self assert: (self model entityNamed: #'Smalltalk::LANInterface.addressee()') protocol equals: #aspects ] { #category : #tests } From e95326dd15f8f0722672d82a7b2dc8bda3fc67ef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Beno=C3=AEt=20Verhaeghe?= Date: Mon, 29 Apr 2019 18:55:17 +0200 Subject: [PATCH 0018/1076] Update .travis.yml --- .travis.yml | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/.travis.yml b/.travis.yml index b2a71f15b..517210f37 100644 --- a/.travis.yml +++ b/.travis.yml @@ -14,3 +14,12 @@ smalltalk_config: matrix: allow_failures: - smalltalk_config: .withPharoTests.ston + - smalltalk: Pharo32-8.0 + smalltalk_config: .smalltalk.ston + - smalltalk: Pharo64-8.0 + smalltalk_config: .smalltalk.ston + include: + - smalltalk: Pharo32-8.0 + smalltalk_config: .smalltalk.ston + - smalltalk: Pharo64-8.0 + smalltalk_config: .smalltalk.ston From 8259c85193fa379ff756521ab495ca4b90d619ab Mon Sep 17 00:00:00 2001 From: Anne Etien Date: Tue, 30 Apr 2019 11:23:25 +0200 Subject: [PATCH 0019/1076] Moving cohesion coupling metrics to generic Metamodel (TPackage) --- src/BaselineOfMoose/BaselineOfMoose.class.st | 1 + .../FamixGenerator.class.st | 11 +++- ...FamixTCohesionCouplingMetrics.extension.st | 66 +++++++++++++++++++ src/Famix-Traits-Extensions/package.st | 1 + 4 files changed, 78 insertions(+), 1 deletion(-) create mode 100644 src/Famix-Traits-Extensions/FamixTCohesionCouplingMetrics.extension.st create mode 100644 src/Famix-Traits-Extensions/package.st diff --git a/src/BaselineOfMoose/BaselineOfMoose.class.st b/src/BaselineOfMoose/BaselineOfMoose.class.st index 1b0dfa3e6..b1aa7f9ba 100644 --- a/src/BaselineOfMoose/BaselineOfMoose.class.st +++ b/src/BaselineOfMoose/BaselineOfMoose.class.st @@ -202,6 +202,7 @@ BaselineOfMoose >> baselineFamixNG: spec [ spec package: 'Famix-Traits'; + package: 'Famix-Traits-Extensions' with: [ spec requires: #('Famix-Traits') ] ; package: 'Famix-PharoSmalltalk-Generator'; package: 'Famix-PharoSmalltalk-Entities'; diff --git a/src/Famix-MetamodelGeneration/FamixGenerator.class.st b/src/Famix-MetamodelGeneration/FamixGenerator.class.st index 7d52d55e4..12f496d21 100644 --- a/src/Famix-MetamodelGeneration/FamixGenerator.class.st +++ b/src/Famix-MetamodelGeneration/FamixGenerator.class.st @@ -126,7 +126,8 @@ Class { 'tContainingWithStatementsGlue', 'tContainingWithInvocationsGlue', 'tWithMethodsWithAccessesGlue', - 'tMultipleFileAnchor' + 'tMultipleFileAnchor', + 'tCohesionCouplingMetrics' ], #category : #'Famix-MetamodelGeneration' } @@ -927,6 +928,12 @@ FamixGenerator >> defineGlueingTraits [ ] +{ #category : #definition } +FamixGenerator >> defineHierarchy [ + super defineHierarchy. + tCohesionCouplingMetrics --|> tPackage. +] + { #category : #definition } FamixGenerator >> defineProperties [ @@ -1653,6 +1660,8 @@ FamixGenerator >> defineTraits [ tWithStatements := builder newTraitNamed: #TWithStatements. tMultipleFileAnchor := builder newTraitNamed: #TMultipleFileAnchor. + + tCohesionCouplingMetrics := builder newTraitNamed: #TCohesionCouplingMetrics. self defineGlueingTraits. diff --git a/src/Famix-Traits-Extensions/FamixTCohesionCouplingMetrics.extension.st b/src/Famix-Traits-Extensions/FamixTCohesionCouplingMetrics.extension.st new file mode 100644 index 000000000..2ae2212c7 --- /dev/null +++ b/src/Famix-Traits-Extensions/FamixTCohesionCouplingMetrics.extension.st @@ -0,0 +1,66 @@ +Extension { #name : #FamixTCohesionCouplingMetrics } + +{ #category : #'*Famix-Traits-Extensions' } +FamixTCohesionCouplingMetrics >> abstractness [ + "Abstractness is the ratio between the number of abstract classes and the total number of classes in a package, in the range [0, 1]. 0 means the package is fully concrete, 1 it is fully abstract." + + + + + | nsClasses | + nsClasses := self childEntities . + (nsClasses size == 0) ifTrue: [^nil]. + + ^ (nsClasses select: [:c | c isAbstract]) size / (nsClasses size) +] + +{ #category : #'*Famix-Traits-Extensions' } +FamixTCohesionCouplingMetrics >> afferentCoupling [ + + + + ^ (self queryAllIncoming atScope: FamixTPackageable) outOfMyPackage size +] + +{ #category : #'*Famix-Traits-Extensions' } +FamixTCohesionCouplingMetrics >> distance [ + "D = A + I - 1. A package should be balanced between abstractness and instability, i.e., somewhere between abstract and stable or concrete and unstable. This rule defines the main sequence by the equation A + I - 1 = 0. D is the distance to the main sequence." + + + + + + | abstractness instability | + abstractness := self abstractness. + instability := self instability. + + (abstractness isNil or: [instability isNil]) ifTrue: [^ nil]. + ^ abstractness + instability - 1 +] + +{ #category : #'*Famix-Traits-Extensions' } +FamixTCohesionCouplingMetrics >> efferentCoupling [ + "Efferent coupling for a package is the number of classes it depends upon" + + + + + ^ ((self queryAllOutgoing outOfMyPackage atScope: FamixTPackageable)) size +] + +{ #category : #'*Famix-Traits-Extensions' } +FamixTCohesionCouplingMetrics >> instability [ + "I = Ce(P)/(Ce(P)+Ca(P)), in the range [0, 1]. 0 means package is maximally stable (i.e., no dependency to other packages and can not change without big consequences), 1 means it is unstable." + + + + + + | efferentCoupling afferentCoupling | + + efferentCoupling := self efferentCoupling. + afferentCoupling := self afferentCoupling. + (efferentCoupling + afferentCoupling) == 0 ifTrue: [^ nil]. + ^ efferentCoupling / (efferentCoupling + afferentCoupling) +] diff --git a/src/Famix-Traits-Extensions/package.st b/src/Famix-Traits-Extensions/package.st new file mode 100644 index 000000000..a682a720d --- /dev/null +++ b/src/Famix-Traits-Extensions/package.st @@ -0,0 +1 @@ +Package { #name : #'Famix-Traits-Extensions' } From df87eefb0680876bc3bbf86a9efdb47ef586984a Mon Sep 17 00:00:00 2001 From: Anne Etien Date: Tue, 30 Apr 2019 12:06:04 +0200 Subject: [PATCH 0020/1076] Moving cohesion and coupling metrics to generic metamodel and consequently modifying the tests. BunchCohesion should by definition use Bunch tool. Tests are removed and the metric will be soon. --- .../FAMIXExtensionMetricTest.class.st | 248 ------------------ .../FamixStPackage.class.st | 6 +- .../FamixPharoSmalltalkGenerator.class.st | 1 + .../FamixTCohesionCouplingMetrics.trait.st | 28 ++ 4 files changed, 32 insertions(+), 251 deletions(-) create mode 100644 src/Famix-Traits/FamixTCohesionCouplingMetrics.trait.st diff --git a/src/Famix-Compatibility-Tests-Extensions/FAMIXExtensionMetricTest.class.st b/src/Famix-Compatibility-Tests-Extensions/FAMIXExtensionMetricTest.class.st index 56501d515..5b1da644b 100644 --- a/src/Famix-Compatibility-Tests-Extensions/FAMIXExtensionMetricTest.class.st +++ b/src/Famix-Compatibility-Tests-Extensions/FAMIXExtensionMetricTest.class.st @@ -25,11 +25,6 @@ Class { #category : #'Famix-Compatibility-Tests-Extensions' } -{ #category : #tests } -FAMIXExtensionMetricTest >> expectedFailures [ - ^ #(testBunchCouplingFAMIXPackage) -] - { #category : #setup } FAMIXExtensionMetricTest >> importClasses [ @@ -300,249 +295,6 @@ FAMIXExtensionMetricTest >> testAfferentCouplingFAMIXPackage [ self assert: p4m2 afferentCoupling equals: 1 ] -{ #category : #tests } -FAMIXExtensionMetricTest >> testBunchCohesionFAMIXClassGroup [ - | class1 class2 class3 class4 class5 class6 class7 class8 class9 class10 class11 class12 class13 class14 class15 class16 f | - class1 := p1m1 allClasses detect: [ :each | each name = #M1P1C1FullReferencerOutSide ]. - class2 := p2m1 allClasses detect: [ :each | each name = #M1P2C2ReferencerOutSideRefereeInSide ]. - class3 := p2m1 allClasses detect: [ :each | each name = #M1P2C3ReferencerInSideRefereeOutSide ]. - class4 := p2m1 allClasses detect: [ :each | each name = #M1P2C4FullRefereeInSide ]. - f := FAMIXTypeGroup new. - f add: class1. - self assert: f bunchCohesion equals: 1.0. - f := FAMIXTypeGroup new. - f - add: class2; - add: class3; - add: class4. - self assert: f bunchCohesion equals: (3 / 9) asFloat. - f := FAMIXTypeGroup new. - f - add: class1; - add: class2; - add: class3; - add: class4. - self assert: f bunchCohesion equals: (5 / 16) asFloat. - class1 := p1m2 allClasses detect: [ :each | each name = #A1 ]. - class2 := p1m2 allClasses detect: [ :each | each name = #B1 ]. - class3 := p1m2 allClasses detect: [ :each | each name = #C1 ]. - class4 := p1m2 allClasses detect: [ :each | each name = #D1 ]. - class5 := p1m2 allClasses detect: [ :each | each name = #E1 ]. - class6 := p1m2 allClasses detect: [ :each | each name = #F1 ]. - class7 := p1m2 allClasses detect: [ :each | each name = #G1 ]. - class8 := p1m2 allClasses detect: [ :each | each name = #H1 ]. - class9 := p1m2 allClasses detect: [ :each | each name = #I1 ]. - class10 := p2m2 allClasses detect: [ :each | each name = #A2 ]. - class11 := p2m2 allClasses detect: [ :each | each name = #B2 ]. - class12 := p3m2 allClasses detect: [ :each | each name = #A3 ]. - class13 := p3m2 allClasses detect: [ :each | each name = #B3 ]. - class14 := p3m2 allClasses detect: [ :each | each name = #C3 ]. - class15 := p4m2 allClasses detect: [ :each | each name = #A4 ]. - class16 := p4m2 allClasses detect: [ :each | each name = #B4 ]. - f := FAMIXTypeGroup new. - f - add: class1; - add: class2; - add: class3; - add: class4; - add: class5; - add: class6; - add: class7; - add: class8; - add: class9. - self assert: f bunchCohesion equals: (9 / 81) asFloat. - f := FAMIXTypeGroup new. - f - add: class10; - add: class11. - self assert: f bunchCohesion equals: 0.0. - f := FAMIXTypeGroup new. - f - add: class12; - add: class13; - add: class14. - self assert: f bunchCohesion equals: (2 / 9) asFloat. - f := FAMIXTypeGroup new. - f - add: class15; - add: class16. - self assert: f bunchCohesion equals: 0.0. - f := FAMIXTypeGroup new. - f - add: class1; - add: class2; - add: class3; - add: class4; - add: class5; - add: class6; - add: class7; - add: class8; - add: class9; - add: class10; - add: class11. - self assert: f bunchCohesion equals: (11 / 121) asFloat. - f := FAMIXTypeGroup new. - f - add: class12; - add: class13; - add: class14; - add: class15; - add: class16. - self assert: f bunchCohesion equals: (3 / 25) asFloat -] - -{ #category : #tests } -FAMIXExtensionMetricTest >> testBunchCohesionFAMIXPackage [ - self assert: p1m1 bunchCohesion equals: 1.0. - self assert: p2m1 bunchCohesion equals: (3 / 9) asFloat. - self assert: p1m2 bunchCohesion equals: (9 / 81) asFloat. - self assert: p2m2 bunchCohesion equals: 0.0. - self assert: p3m2 bunchCohesion equals: (2 / 9) asFloat. - self assert: p4m2 bunchCohesion equals: 0.0 -] - -{ #category : #tests } -FAMIXExtensionMetricTest >> testBunchCouplingFAMIXClassGroup [ - | class1 class2 class3 class4 class5 class6 class7 class8 class9 class10 class11 class12 class13 class14 class15 class16 f1 f2 | - class1 := p1m1 allClasses detect: [ :each | each name = #M1P1C1FullReferencerOutSide ]. - class2 := p2m1 allClasses detect: [ :each | each name = #M1P2C2ReferencerOutSideRefereeInSide ]. - class3 := p2m1 allClasses detect: [ :each | each name = #M1P2C3ReferencerInSideRefereeOutSide ]. - class4 := p2m1 allClasses detect: [ :each | each name = #M1P2C4FullRefereeInSide ]. - f1 := FAMIXTypeGroup new. - f1 add: class1. - f2 := FAMIXTypeGroup new. - f2 - add: class2; - add: class3; - add: class4. - self assert: (f1 bunchCouplingWith: f2) equals: (1 / 6) asFloat. - self assert: (f2 bunchCouplingWith: f1) equals: (1 / 6) asFloat. - f1 := FAMIXTypeGroup new. - f1 - add: class1; - add: class2. - f2 := FAMIXTypeGroup new. - f2 - add: class3; - add: class4. - self assert: (f1 bunchCouplingWith: f2) equals: (2 / 8) asFloat. - self assert: (f2 bunchCouplingWith: f1) equals: (2 / 8) asFloat. - class1 := p1m2 allClasses detect: [ :each | each name = #A1 ]. - class2 := p1m2 allClasses detect: [ :each | each name = #B1 ]. - class3 := p1m2 allClasses detect: [ :each | each name = #C1 ]. - class4 := p1m2 allClasses detect: [ :each | each name = #D1 ]. - class5 := p1m2 allClasses detect: [ :each | each name = #E1 ]. - class6 := p1m2 allClasses detect: [ :each | each name = #F1 ]. - class7 := p1m2 allClasses detect: [ :each | each name = #G1 ]. - class8 := p1m2 allClasses detect: [ :each | each name = #H1 ]. - class9 := p1m2 allClasses detect: [ :each | each name = #I1 ]. - class10 := p2m2 allClasses detect: [ :each | each name = #A2 ]. - class11 := p2m2 allClasses detect: [ :each | each name = #B2 ]. - class12 := p3m2 allClasses detect: [ :each | each name = #A3 ]. - class13 := p3m2 allClasses detect: [ :each | each name = #B3 ]. - class14 := p3m2 allClasses detect: [ :each | each name = #C3 ]. - class15 := p4m2 allClasses detect: [ :each | each name = #A4 ]. - class16 := p4m2 allClasses detect: [ :each | each name = #B4 ]. - f1 := FAMIXTypeGroup new. - f1 - add: class1; - add: class2; - add: class3; - add: class4; - add: class5; - add: class6; - add: class7; - add: class8; - add: class9. - f2 := FAMIXTypeGroup new. - f2 - add: class10; - add: class11. - self assert: (f1 bunchCouplingWith: f2) equals: (2 / 36) asFloat. - self assert: (f2 bunchCouplingWith: f1) equals: (2 / 36) asFloat. - f2 := FAMIXTypeGroup new. - f2 - add: class12; - add: class13; - add: class14. - self assert: (f1 bunchCouplingWith: f2) equals: (4 / 54) asFloat. - self assert: (f2 bunchCouplingWith: f1) equals: (4 / 54) asFloat. - f2 := FAMIXTypeGroup new. - f2 - add: class15; - add: class16. - self assert: (f1 bunchCouplingWith: f2) equals: (1 / 36) asFloat. - self assert: (f2 bunchCouplingWith: f1) equals: (1 / 36) asFloat. - f1 := FAMIXTypeGroup new. - f1 - add: class10; - add: class11. - f2 := FAMIXTypeGroup new. - f2 - add: class12; - add: class13; - add: class14. - self assert: (f1 bunchCouplingWith: f2) equals: 0.0. - self assert: (f2 bunchCouplingWith: f1) equals: 0.0. - f2 := FAMIXTypeGroup new. - f2 - add: class15; - add: class16. - self assert: (f1 bunchCouplingWith: f2) equals: 0.0. - self assert: (f2 bunchCouplingWith: f1) equals: 0.0. - f1 := FAMIXTypeGroup new. - f1 - add: class12; - add: class13; - add: class14. - f2 := FAMIXTypeGroup new. - f2 - add: class15; - add: class16. - self assert: (f1 bunchCouplingWith: f2) equals: (1 / 12) asFloat. - self assert: (f2 bunchCouplingWith: f1) equals: (1 / 12) asFloat. - f1 := FAMIXTypeGroup new. - f1 - add: class1; - add: class2; - add: class3; - add: class4; - add: class5; - add: class6; - add: class7; - add: class8; - add: class9; - add: class10; - add: class11. - f2 := FAMIXTypeGroup new. - f2 - add: class12; - add: class13; - add: class14; - add: class15; - add: class16. - self assert: (f1 bunchCouplingWith: f2) equals: (5 / 110) asFloat. - self assert: (f2 bunchCouplingWith: f1) equals: (5 / 110) asFloat -] - -{ #category : #tests } -FAMIXExtensionMetricTest >> testBunchCouplingFAMIXPackage [ - self assert: (p1m1 bunchCouplingWith: p2m1) equals: (1 / 6) asFloat. - self assert: (p2m1 bunchCouplingWith: p1m1) equals: (1 / 6) asFloat. - self assert: (p1m2 bunchCouplingWith: p2m2) equals: (2 / 36) asFloat. - self assert: (p2m2 bunchCouplingWith: p1m2) equals: (2 / 36) asFloat. - self assert: (p1m2 bunchCouplingWith: p3m2) equals: (4 / 54) asFloat. - self assert: (p3m2 bunchCouplingWith: p1m2) equals: (4 / 54) asFloat. - self assert: (p1m2 bunchCouplingWith: p4m2) equals: (1 / 36) asFloat. - self assert: (p4m2 bunchCouplingWith: p1m2) equals: (1 / 36) asFloat. - self assert: (p2m2 bunchCouplingWith: p3m2) equals: 0.0. - self assert: (p3m2 bunchCouplingWith: p2m2) equals: 0.0. - self assert: (p2m2 bunchCouplingWith: p4m2) equals: 0.0. - self assert: (p4m2 bunchCouplingWith: p2m2) equals: 0.0. - self assert: (p3m2 bunchCouplingWith: p4m2) equals: (1 / 12) asFloat. - self assert: (p4m2 bunchCouplingWith: p3m2) equals: (1 / 12) asFloat -] - { #category : #tests } FAMIXExtensionMetricTest >> testDistanceFAMIXClassGroup [ | class1 class2 class3 class4 class5 class6 class7 class8 class9 class10 class11 class12 class13 class14 class15 class16 f | diff --git a/src/Famix-PharoSmalltalk-Entities/FamixStPackage.class.st b/src/Famix-PharoSmalltalk-Entities/FamixStPackage.class.st index 4cdd74380..06040245f 100644 --- a/src/Famix-PharoSmalltalk-Entities/FamixStPackage.class.st +++ b/src/Famix-PharoSmalltalk-Entities/FamixStPackage.class.st @@ -1,8 +1,8 @@ Class { #name : #FamixStPackage, #superclass : #FamixStScopingEntity, - #traits : 'FamixTPackage + FamixTPackageWithClassesGlue', - #classTraits : 'FamixTPackage classTrait + FamixTPackageWithClassesGlue classTrait', + #traits : 'FamixTCohesionCouplingMetrics + FamixTPackage + FamixTPackageWithClassesGlue', + #classTraits : 'FamixTCohesionCouplingMetrics classTrait + FamixTPackage classTrait + FamixTPackageWithClassesGlue classTrait', #category : #'Famix-PharoSmalltalk-Entities-Entities' } @@ -25,7 +25,7 @@ FamixStPackage class >> generatedSlotNames [ { #category : #generator } FamixStPackage class >> generatedTraitNames [ - ^ #(FamixTPackage FamixTPackageWithClassesGlue) + ^ #(FamixTCohesionCouplingMetrics FamixTPackage FamixTPackageWithClassesGlue) ] { #category : #meta } diff --git a/src/Famix-PharoSmalltalk-Generator/FamixPharoSmalltalkGenerator.class.st b/src/Famix-PharoSmalltalk-Generator/FamixPharoSmalltalkGenerator.class.st index 5c70de9e8..54d0c2cec 100644 --- a/src/Famix-PharoSmalltalk-Generator/FamixPharoSmalltalkGenerator.class.st +++ b/src/Famix-PharoSmalltalk-Generator/FamixPharoSmalltalkGenerator.class.st @@ -172,6 +172,7 @@ FamixPharoSmalltalkGenerator >> defineHierarchy [ package --|> scopingEntity. package --|> #TPackage. + package --|> #TCohesionCouplingMetrics. parameter --|> structuralEntity. parameter --|> #TParameter. diff --git a/src/Famix-Traits/FamixTCohesionCouplingMetrics.trait.st b/src/Famix-Traits/FamixTCohesionCouplingMetrics.trait.st new file mode 100644 index 000000000..0e1bb8fc1 --- /dev/null +++ b/src/Famix-Traits/FamixTCohesionCouplingMetrics.trait.st @@ -0,0 +1,28 @@ +Trait { + #name : #FamixTCohesionCouplingMetrics, + #traits : 'FamixTPackage', + #classTraits : 'FamixTPackage classTrait', + #category : #'Famix-Traits-Package' +} + +{ #category : #meta } +FamixTCohesionCouplingMetrics classSide >> annotation [ + + + + + ^self +] + +{ #category : #generator } +FamixTCohesionCouplingMetrics classSide >> generatedSlotNames [ + + 'FamixTCohesionCouplingMetrics class>>#generatedSlotNames'. + ^ #() +] + +{ #category : #generator } +FamixTCohesionCouplingMetrics classSide >> generatedTraitNames [ + + ^ #(FamixTPackage) +] From 8a8228cd6a92c4528e3e88a92563987aae9dbf00 Mon Sep 17 00:00:00 2001 From: badetitou Date: Tue, 30 Apr 2019 15:18:29 +0200 Subject: [PATCH 0021/1076] extract MonticelloImporter --- src/BaselineOfMoose/BaselineOfMoose.class.st | 5 - .../MPImportMonticelloCommand.class.st | 31 --- ...SmalltalkMonticelloSourceLanguage.class.st | 14 -- .../MooseMonticelloCacheImporter.class.st | 19 -- .../MooseMonticelloClassPopulator.class.st | 13 -- .../MooseMonticelloHTTPImporter.class.st | 40 ---- .../MooseMonticelloImporter.class.st | 190 ------------------ .../MooseMonticelloMethodPopulator.class.st | 141 ------------- .../MooseMonticelloVisitor.class.st | 59 ------ src/Moose-MonticelloImporter/package.st | 1 - .../MooseMonticelloImporterTest.class.st | 123 ------------ src/Moose-Tests-MonticelloImporter/package.st | 1 - 12 files changed, 637 deletions(-) delete mode 100644 src/Moose-Finder/MPImportMonticelloCommand.class.st delete mode 100644 src/Moose-MonticelloImporter/FAMIXSmalltalkMonticelloSourceLanguage.class.st delete mode 100644 src/Moose-MonticelloImporter/MooseMonticelloCacheImporter.class.st delete mode 100644 src/Moose-MonticelloImporter/MooseMonticelloClassPopulator.class.st delete mode 100644 src/Moose-MonticelloImporter/MooseMonticelloHTTPImporter.class.st delete mode 100644 src/Moose-MonticelloImporter/MooseMonticelloImporter.class.st delete mode 100644 src/Moose-MonticelloImporter/MooseMonticelloMethodPopulator.class.st delete mode 100644 src/Moose-MonticelloImporter/MooseMonticelloVisitor.class.st delete mode 100644 src/Moose-MonticelloImporter/package.st delete mode 100644 src/Moose-Tests-MonticelloImporter/MooseMonticelloImporterTest.class.st delete mode 100644 src/Moose-Tests-MonticelloImporter/package.st diff --git a/src/BaselineOfMoose/BaselineOfMoose.class.st b/src/BaselineOfMoose/BaselineOfMoose.class.st index 3789d3810..8d72cb2b4 100644 --- a/src/BaselineOfMoose/BaselineOfMoose.class.st +++ b/src/BaselineOfMoose/BaselineOfMoose.class.st @@ -54,7 +54,6 @@ BaselineOfMoose >> baseline: spec [ package: 'Famix-Compatibility-Tests-C'; package: 'Moose-Query-Extensions'; package: 'Moose-SmalltalkImporter'; - package: 'Moose-MonticelloImporter'; package: 'Moose-Tests-Core'; package: 'Famix-Smalltalk-Utils-Tests'; package: 'Famix-Compatibility-Tests-Java'; @@ -88,7 +87,6 @@ BaselineOfMoose >> baseline: spec [ package: 'Moose-TestResources-PackageBlueprint-P2'; package: 'Moose-TestResources-PackageBlueprint-P3'; package: 'Moose-TestResources-PackageBlueprint-P4'; - package: 'Moose-Tests-MonticelloImporter'; package: 'Moose-Query-Test'. self baselineMetamodelBuilder: spec. @@ -656,9 +654,6 @@ BaselineOfMoose >> groups: spec [ 'Moose-Tests-Finder' 'Moose-Algos-Lattice-Tests' 'Moose-Algos-InformationRetrieval-Tests' - - 'Moose-MonticelloImporter' - 'Moose-Tests-MonticelloImporter' 'Famix-PharoSmalltalk-Generator' 'Famix-PharoSmalltalk-Entities' diff --git a/src/Moose-Finder/MPImportMonticelloCommand.class.st b/src/Moose-Finder/MPImportMonticelloCommand.class.st deleted file mode 100644 index 558d29aa0..000000000 --- a/src/Moose-Finder/MPImportMonticelloCommand.class.st +++ /dev/null @@ -1,31 +0,0 @@ -Class { - #name : #MPImportMonticelloCommand, - #superclass : #MPImportCommand, - #category : #'Moose-Finder' -} - -{ #category : #hooks } -MPImportMonticelloCommand >> execute [ - | model importer value fileNames | - - importer := MooseMonticelloCacheImporter new. - fileNames := importer fileNames asSortedCollection. - - fileNames ifEmpty: [ self inform: 'No Monticello package is available'. ^ self ]. - - "We choose the first package" - value := UIManager default - chooseFrom: fileNames values: fileNames title: 'Choose a Monticello package to import'. - value ifNil: [ ^ self ]. - - model := importer importFileNamed: value. - model name: value. - - model install. - self addModel: model -] - -{ #category : #hooks } -MPImportMonticelloCommand >> label [ - ^ 'Import FAMIX Smalltalk model from Monticello repository' -] diff --git a/src/Moose-MonticelloImporter/FAMIXSmalltalkMonticelloSourceLanguage.class.st b/src/Moose-MonticelloImporter/FAMIXSmalltalkMonticelloSourceLanguage.class.st deleted file mode 100644 index 511e27f82..000000000 --- a/src/Moose-MonticelloImporter/FAMIXSmalltalkMonticelloSourceLanguage.class.st +++ /dev/null @@ -1,14 +0,0 @@ -" -FAMIXSmalltalkMonticelloSourceLanguage represents the fact that the language is Smalltalk (extracted from Monticello). -" -Class { - #name : #FAMIXSmalltalkMonticelloSourceLanguage, - #superclass : #FAMIXSourceLanguage, - #category : #'Moose-MonticelloImporter' -} - -{ #category : #meta } -FAMIXSmalltalkMonticelloSourceLanguage class >> annotation [ - - -] diff --git a/src/Moose-MonticelloImporter/MooseMonticelloCacheImporter.class.st b/src/Moose-MonticelloImporter/MooseMonticelloCacheImporter.class.st deleted file mode 100644 index 325f9c535..000000000 --- a/src/Moose-MonticelloImporter/MooseMonticelloCacheImporter.class.st +++ /dev/null @@ -1,19 +0,0 @@ -" -MooseMonticelloCacheImporter supports the loading of files from a folder - -Instance Variables: - directoryString -" -Class { - #name : #MooseMonticelloCacheImporter, - #superclass : #MooseMonticelloImporter, - #instVars : [ - 'directoryString' - ], - #category : #'Moose-MonticelloImporter' -} - -{ #category : #'hook - private' } -MooseMonticelloCacheImporter >> setRepository [ - repositoryCache := MCCacheRepository uniqueInstance -] diff --git a/src/Moose-MonticelloImporter/MooseMonticelloClassPopulator.class.st b/src/Moose-MonticelloImporter/MooseMonticelloClassPopulator.class.st deleted file mode 100644 index 462a01c7a..000000000 --- a/src/Moose-MonticelloImporter/MooseMonticelloClassPopulator.class.st +++ /dev/null @@ -1,13 +0,0 @@ -Class { - #name : #MooseMonticelloClassPopulator, - #superclass : #MooseMonticelloVisitor, - #category : #'Moose-MonticelloImporter' -} - -{ #category : #accessing } -MooseMonticelloClassPopulator >> visitClassDefinition: def [ - importer - createClassNamed: def className asSymbol - ivs: (def variables collect: [:each | each name ]) - superclassName: def superclassName -] diff --git a/src/Moose-MonticelloImporter/MooseMonticelloHTTPImporter.class.st b/src/Moose-MonticelloImporter/MooseMonticelloHTTPImporter.class.st deleted file mode 100644 index e56aa9636..000000000 --- a/src/Moose-MonticelloImporter/MooseMonticelloHTTPImporter.class.st +++ /dev/null @@ -1,40 +0,0 @@ -" -MooseMonticelloHTTPImporter supports the handling of package via HTTP. - -Instance Variables: - httpUrl -" -Class { - #name : #MooseMonticelloHTTPImporter, - #superclass : #MooseMonticelloImporter, - #instVars : [ - 'httpUrl' - ], - #category : #'Moose-MonticelloImporter' -} - -{ #category : #'as yet unclassified' } -MooseMonticelloHTTPImporter class >> onURL: anHTTPURL [ - " - (self onURL: 'http://www.squeaksource.com/PersonalSetting') - " - ^ self new onURL: anHTTPURL; import -] - -{ #category : #accessing } -MooseMonticelloHTTPImporter >> onURL: url [ - httpUrl := url -] - -{ #category : #'hook - private' } -MooseMonticelloHTTPImporter >> setRepository [ - repositoryCache := MCHttpRepository - location: httpUrl - user: '' - password: '' -] - -{ #category : #'hook - private' } -MooseMonticelloHTTPImporter >> setRepositoryCache: aCache. [ - repositoryCache := aCache -] diff --git a/src/Moose-MonticelloImporter/MooseMonticelloImporter.class.st b/src/Moose-MonticelloImporter/MooseMonticelloImporter.class.st deleted file mode 100644 index 2208c81db..000000000 --- a/src/Moose-MonticelloImporter/MooseMonticelloImporter.class.st +++ /dev/null @@ -1,190 +0,0 @@ -" -MooseMonticelloImporter is a dedicated Smalltalk importer that extends the default Smalltalk importer to deal with classes and methods that are not loaded in memory but contained in Monticello packages. - -Instance Variables: - repositoryCache -" -Class { - #name : #MooseMonticelloImporter, - #superclass : #SmalltalkImporter, - #instVars : [ - 'repositoryCache' - ], - #category : #'Moose-MonticelloImporter' -} - -{ #category : #assertion } -MooseMonticelloImporter >> assertMCZFileName: mczFilename [ - "a mcz file name should ends with '.mcz' and include a $-" - - self assert: [ (mczFilename includes: $. ) ]. - self assert: [ mczFilename first isUppercase ]. - self assert: [ (mczFilename endsWith: '.mcz') ]. -] - -{ #category : #assertion } -MooseMonticelloImporter >> assertPackageName: packageName [ - "a package should not include a dot. It also should start with a capitalized letter" - - self assert: [ (packageName includes: $. ) not ]. - self assert: [ packageName first isUppercase ]. - self assert: [ (packageName endsWith: '.mcz') not ]. -] - -{ #category : #populating } -MooseMonticelloImporter >> createClassNamed: classNameSymbol ivs: varNameStrings superclassName: superclassName [ - "The superclass is not set here. This is done later" - | famixClass | - famixClass := self factory classEntity new name: classNameSymbol asSymbol. - varNameStrings do: [:varName | - famixClass addAttribute: (FAMIXAttribute new name: varName asSymbol)]. - self targetModel add: famixClass. - famixClass propertyNamed: #superclassName put: superclassName. - ^ famixClass -] - -{ #category : #populating } -MooseMonticelloImporter >> ensureClassNamed: classNameSymbol [ - | cls | - cls := self targetModel allClasses detect: [:each | each name == classNameSymbol] ifNone: [nil]. - cls ifNotNil: [ ^ cls ]. - - cls := self createClassNamed: classNameSymbol ivs: #() superclassName: nil. - cls isStub: true. - - ^ cls -] - -{ #category : #public } -MooseMonticelloImporter >> fileNames [ - ^ self repository readableFileNames -] - -{ #category : #'compatibility with visitor' } -MooseMonticelloImporter >> globals [ - ^ globals ifNil: [ globals := Dictionary new ] -] - -{ #category : #public } -MooseMonticelloImporter >> import [ - "Import all files found in the repository" - | names | - self setRepository. - self setMooseModel. - names := self fileNames. - names do: [ :name | self importFileNamed: name ]. - ^ targetModel -] - -{ #category : #public } -MooseMonticelloImporter >> importFileNamed: name [ - "This is a public method. It loads a particular package into the moose model" - - | version definitions visitor | - self setMooseModel. - - [ version := self repository versionFromFileNamed: name. ] - on: Error - do: [:ex | self inform: 'Package ', name, ' not accessible from the file system?'. ^ self targetModel]. - - definitions := version snapshot definitions. - - - MooseCustomTask runWithProgress: [:bar | - visitor := MooseMonticelloClassPopulator new importer: self. - definitions do: [ :def | def accept: visitor. - bar increment]. - ] description: 'Importing classes' length: (definitions size). - - self setSuperclassesAndCreateStubs. - - "create a scope, this is necessary for the method visitor which is VW aware" - self targetModel allClasses do: [:famixClass | - famixClass attributes do: [:famixAttribute | - (self scopeOfClass: famixClass) at: famixAttribute name bind: famixAttribute]]. - - - MooseCustomTask runWithProgress: [:bar | - "import methods" - definitions do: [ :def | - (def isKindOf: MCMethodDefinition) - ifTrue: [ - visitor := MooseMonticelloMethodPopulator new importer: self. - def accept: visitor. - self targetModel addAll: visitor entities]]. - bar increment. - ] description: 'Importing methods' length: (definitions size). - - - ^ self targetModel -] - -{ #category : #public } -MooseMonticelloImporter >> importLastVersionOf: projectName [ - ^ self importFileNamed: (self lastVersionOf: projectName) -] - -{ #category : #'initialize-release' } -MooseMonticelloImporter >> initialize [ - super initialize. - importingContext := MooseImportingContext new importMaximum; mergeClassAndMetaclass; yourself. -] - -{ #category : #public } -MooseMonticelloImporter >> lastVersionOf: packageName [ - "Return the most recent version of an .mcz file based on the packageName" - - | versions sortedNames | - - self assertPackageName: packageName. - - versions := self fileNames select: [ :f | f beginsWith: packageName , '-' ]. - - sortedNames := versions asSortedCollection: - [ :v1 :v2 | - (v1 - copyFrom: (v1 indexOf: $.) + 1 - to: (v1 lastIndexOf: $.)) asInteger < (v2 - copyFrom: (v2 indexOf: $.) + 1 - to: (v2 lastIndexOf: $.)) asInteger ]. - sortedNames ifEmpty: [ self error: 'No file was found for ', packageName ]. - - self assertMCZFileName: sortedNames last. - ^ sortedNames last -] - -{ #category : #public } -MooseMonticelloImporter >> repository [ - ^ repositoryCache ifNil: [ self setRepository. ^ repositoryCache ] -] - -{ #category : #'compatibility with visitor' } -MooseMonticelloImporter >> scope [ - - ^ nil -] - -{ #category : #public } -MooseMonticelloImporter >> setMooseModel [ - self targetModel: MooseModel new. - self targetModel sourceLanguage: FAMIXSmalltalkMonticelloSourceLanguage new -] - -{ #category : #'hook - private' } -MooseMonticelloImporter >> setRepository [ - "Must be called before importing" - self subclassResponsibility -] - -{ #category : #private } -MooseMonticelloImporter >> setSuperclassesAndCreateStubs [ - | famixInheritance superclass | - self targetModel allClasses do: - [ :famixClass | - superclass := self ensureClassNamed: (famixClass propertyNamed: #superclassName). - famixInheritance := FAMIXInheritance new - subclass: famixClass; - superclass: superclass. - famixClass addSuperInheritance: famixInheritance. - superclass addSubInheritance: famixInheritance ] -] diff --git a/src/Moose-MonticelloImporter/MooseMonticelloMethodPopulator.class.st b/src/Moose-MonticelloImporter/MooseMonticelloMethodPopulator.class.st deleted file mode 100644 index c91b92ec4..000000000 --- a/src/Moose-MonticelloImporter/MooseMonticelloMethodPopulator.class.st +++ /dev/null @@ -1,141 +0,0 @@ -Class { - #name : #MooseMonticelloMethodPopulator, - #superclass : #MooseMonticelloVisitor, - #instVars : [ - 'entities', - 'scope' - ], - #category : #'Moose-MonticelloImporter' -} - -{ #category : #accessing } -MooseMonticelloMethodPopulator >> addEntity: entity [ - entities add: entity -] - -{ #category : #'compatibility with visitor' } -MooseMonticelloMethodPopulator >> createGlobalVariable: name value: value [ - - | global | - global := self globals - at: name - put: FAMIXGlobalVariable new. - global name: name. - Smalltalk at: name ifPresent: [:each | global declaredType: each class mooseName]. - ^global -] - -{ #category : #'compatibility with visitor' } -MooseMonticelloMethodPopulator >> createSpecialVariable: name forClass: aClass [ - - | attribute | - attribute := (self scopeOfClass: aClass) at: name bind: FAMIXImplicitVariable new. - attribute name: name. - attribute container: aClass. - ^attribute -] - -{ #category : #'public-entity-creation' } -MooseMonticelloMethodPopulator >> ensureAnnotationType: aRBPragmaNode [ - ^self importer ensureAnnotationType: aRBPragmaNode. -] - -{ #category : #'compatibility with visitor' } -MooseMonticelloMethodPopulator >> ensureClass: classNameSymbol [ - - ^ importer ensureClassNamed: classNameSymbol -] - -{ #category : #'compatibility with visitor' } -MooseMonticelloMethodPopulator >> ensureGlobalVariable: name value: value [ - - ^ importer ensureGlobalVariable: name value: value -] - -{ #category : #'public-entity-creation' } -MooseMonticelloMethodPopulator >> ensureImplicitVariable: name inClass: aClass [ - - ^(self scopeOfClass: aClass) - at: name - ifAbsent: - [self - createSpecialVariable: name - forClass: aClass] -] - -{ #category : #'compatibility with visitor' } -MooseMonticelloMethodPopulator >> ensureImplicitVariable: aByteSymbol inFamixMethod: aFAMIXMethod [ - ^ importer ensureImplicitVariable: aByteSymbol inFamixMethod: aFAMIXMethod -] - -{ #category : #'compatibility with visitor' } -MooseMonticelloMethodPopulator >> ensureNamespace: aName [ - ^ nil -] - -{ #category : #'compatibility with visitor' } -MooseMonticelloMethodPopulator >> ensureUnknownVariable: name [ - ^ importer ensureUnknownVariable: name - -" ^globals - at: name - ifAbsent: [self createUnknownVariable: name] -" -] - -{ #category : #accessing } -MooseMonticelloMethodPopulator >> entities [ - ^ entities -] - -{ #category : #accessing } -MooseMonticelloMethodPopulator >> factory [ - - ^ importer factory -] - -{ #category : #initialization } -MooseMonticelloMethodPopulator >> initialize [ - super initialize. - entities := OrderedCollection new -] - -{ #category : #'private-entity-creation' } -MooseMonticelloMethodPopulator >> scopeOfClass: aClass [ - ^ importer scopeOfClass: aClass -] - -{ #category : #accessing } -MooseMonticelloMethodPopulator >> setInfoOn: famixMethod withSource: sourceAsString [ - "sourceAsString is the source code of famixMethod" - - | visitor | - visitor := MonticelloMethodVisitor on: self. - visitor - runWithSource: sourceAsString - and: famixMethod -] - -{ #category : #visiting } -MooseMonticelloMethodPopulator >> visitMethodDefinition: definition [ - | famixMethod classOnWhichItIsDefined | - famixMethod := FAMIXMethod new. - famixMethod name: definition selector. - famixMethod signature: definition selector. - famixMethod isClassSide: definition classIsMeta. - "note that maybe the class does not exist yet, this happens if the method is an extension" - classOnWhichItIsDefined := importer ensureClassNamed: definition className. - classOnWhichItIsDefined addMethod: famixMethod. - famixMethod parentType: classOnWhichItIsDefined. - famixMethod category: definition category asSymbol. - famixMethod isPublic: true. - famixMethod sourceAnchor: (FAMIXSourceTextAnchor new source: definition source). - famixMethod - propertyNamed: #timestamp - put: definition timeStamp. - importer targetModel add: famixMethod. - self - setInfoOn: famixMethod - withSource: definition source. - ^ famixMethod -] diff --git a/src/Moose-MonticelloImporter/MooseMonticelloVisitor.class.st b/src/Moose-MonticelloImporter/MooseMonticelloVisitor.class.st deleted file mode 100644 index 35fe9fe50..000000000 --- a/src/Moose-MonticelloImporter/MooseMonticelloVisitor.class.st +++ /dev/null @@ -1,59 +0,0 @@ -" -I run over a structure obtained from a Monticello package. - -Instance Variables: - importer the importer I should use to populate -" -Class { - #name : #MooseMonticelloVisitor, - #superclass : #Object, - #instVars : [ - 'importer' - ], - #category : #'Moose-MonticelloImporter' -} - -{ #category : #accessing } -MooseMonticelloVisitor >> importer [ - ^ importer -] - -{ #category : #accessing } -MooseMonticelloVisitor >> importer: anObject [ - - importer := anObject -] - -{ #category : #accessing } -MooseMonticelloVisitor >> importingContext [ - ^ importer importingContext -] - -{ #category : #visiting } -MooseMonticelloVisitor >> visitClassDefinition: def [ -] - -{ #category : #visiting } -MooseMonticelloVisitor >> visitClassTraitDefinition: definition [ -] - -{ #category : #visiting } -MooseMonticelloVisitor >> visitMetaclassDefinition: definition [ -] - -{ #category : #visiting } -MooseMonticelloVisitor >> visitMethodDefinition: definition [ -] - -{ #category : #visiting } -MooseMonticelloVisitor >> visitOrganizationDefinition: defintion [ -] - -{ #category : #visiting } -MooseMonticelloVisitor >> visitScriptDefinition: aMCPostscriptDefinition [ - "TODO" -] - -{ #category : #visiting } -MooseMonticelloVisitor >> visitTraitDefinition: definition [ -] diff --git a/src/Moose-MonticelloImporter/package.st b/src/Moose-MonticelloImporter/package.st deleted file mode 100644 index 7294e4fb2..000000000 --- a/src/Moose-MonticelloImporter/package.st +++ /dev/null @@ -1 +0,0 @@ -Package { #name : #'Moose-MonticelloImporter' } diff --git a/src/Moose-Tests-MonticelloImporter/MooseMonticelloImporterTest.class.st b/src/Moose-Tests-MonticelloImporter/MooseMonticelloImporterTest.class.st deleted file mode 100644 index ba9469448..000000000 --- a/src/Moose-Tests-MonticelloImporter/MooseMonticelloImporterTest.class.st +++ /dev/null @@ -1,123 +0,0 @@ -Class { - #name : #MooseMonticelloImporterTest, - #superclass : #MooseTestWithSmalltalkDependency, - #instVars : [ - 'importer' - ], - #category : #'Moose-Tests-MonticelloImporter' -} - -{ #category : #accessing } -MooseMonticelloImporterTest class >> resources [ - ^ Array with: GoferResource -] - -{ #category : #running } -MooseMonticelloImporterTest >> packageToTest [ - ^ 'MonticelloImporterResourcePackage' -] - -{ #category : #running } -MooseMonticelloImporterTest >> setUp [ - super setUp. - importer := MooseMonticelloCacheImporter new. - importer factory: self metamodelFactory new. - self settingUpTestPackageIfNecessary -] - -{ #category : #running } -MooseMonticelloImporterTest >> settingUpTestPackageIfNecessary [ - - (MooseMonticelloCacheImporter new fileNames includes: self packageToTest) - ifFalse: [ - | cls1 cls2 workingCopy | - cls1 := Object subclass: #Class1ForMonticelloCacheImporter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: self packageToTest. - cls1 compile: 'foo', String cr, ' "hello"', String cr, ' ^ 10'. - cls1 compile: 'bar', String cr, ' "hello"', String cr, ' ^ 10'. - - cls2 := Object subclass: #Class2ForMonticelloCacheImporter - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: self packageToTest. - cls2 compile: 'foo', String cr, ' Class1ForMonticelloCacheImporter new foo'. - - workingCopy := MCWorkingCopy forPackage: (MCPackage new name: self packageToTest). - workingCopy newVersionWithName: self packageToTest, '-FooBar-1' message: 'test' in: workingCopy repositoryGroup. - cls1 removeFromSystem. - cls2 removeFromSystem. - - ] -] - -{ #category : #running } -MooseMonticelloImporterTest >> tearDown [ - (self packageToTest asPackageIfAbsent: [ nil ]) ifNotNil: [ :aPackage | aPackage removeFromSystem ]. - super tearDown -] - -{ #category : #tests } -MooseMonticelloImporterTest >> testAssertion [ - - "Package names" - self shouldnt: [ importer assertPackageName: 'Mondrian' ] raise: AssertionFailure. - self shouldnt: [ importer assertPackageName: 'Mondrian-Core' ] raise: AssertionFailure. - - self should: [ importer assertPackageName: 'mondrian-Core' ] raise: AssertionFailure. - self should: [ importer assertPackageName: 'Mondrian-Core.mcz' ] raise: AssertionFailure. - - "MCZfile name" - - self should: [ importer assertMCZFileName: 'Mondrian' ] raise: AssertionFailure. - self should: [ importer assertMCZFileName: 'Mondrian-Core' ] raise: AssertionFailure. - self should: [ importer assertMCZFileName: 'mondrian-Core-ab.mcz' ] raise: AssertionFailure. - - self shouldnt: [ importer assertMCZFileName: 'Mondrian-Core-AB.mcz' ] raise: AssertionFailure. - self shouldnt: [ importer assertMCZFileName: 'Mondrian-AB.mcz' ] raise: AssertionFailure. - -] - -{ #category : #tests } -MooseMonticelloImporterTest >> testImporting [ - | mooseModel noStubClasses allClasses objectClass class1 classWithIncomingAccess | - mooseModel := importer importLastVersionOf: self packageToTest. - allClasses := mooseModel allClasses. - self assert: mooseModel class == MooseModel. - noStubClasses := allClasses reject: #isStub. - self assert: noStubClasses size equals: 2. - self assert: allClasses size equals: 3. - class1 := allClasses entityNamed: #Class1ForMonticelloCacheImporter. - self assert: class1 methods size > 0. - self assert: (class1 methods allSatisfy: [ :each | each parentType == class1 ]). "number of lines of code" - self assert: class1 numberOfLinesOfCode > 1. - objectClass := allClasses entityNamed: #Object. - self assert: objectClass isStub. - self assert: objectClass methods isEmpty. - self assert: (mooseModel allMethods allSatisfy: [ :each | each mooseModel == mooseModel ]). "incoming access group" - classWithIncomingAccess := mooseModel allClasses detect: [ :cls | cls outgoingInvocationsGroup notEmpty ] ifNone: nil. - self assert: classWithIncomingAccess notNil -] - -{ #category : #tests } -MooseMonticelloImporterTest >> testLastVersionOf [ - | file projectName mczFile | - - "We first check if there are some packages in the local repository. If none, then nothing can be tested" - importer fileNames ifEmpty: [ ^ self ]. - - file := importer fileNames first. - projectName := file copyUpToLast: $-. - mczFile := importer lastVersionOf: projectName. - self assert: (mczFile notEmpty). - - self should: [importer lastVersionOf: file] raise: Exception. -] - -{ #category : #utility } -MooseMonticelloImporterTest >> workingCopies [ - ^ MCWorkingCopy allManagers asSortedCollection: [ :a :b | a name <= b name] -] diff --git a/src/Moose-Tests-MonticelloImporter/package.st b/src/Moose-Tests-MonticelloImporter/package.st deleted file mode 100644 index 99199bbd7..000000000 --- a/src/Moose-Tests-MonticelloImporter/package.st +++ /dev/null @@ -1 +0,0 @@ -Package { #name : #'Moose-Tests-MonticelloImporter' } From 58cb77923fefc5ba8649ce6aab5b679cffc64d98 Mon Sep 17 00:00:00 2001 From: badetitou Date: Tue, 30 Apr 2019 15:37:22 +0200 Subject: [PATCH 0022/1076] use ring as an external project --- src/BaselineOfMoose/BaselineOfMoose.class.st | 30 +- .../ClyRing2Environment.class.st | 169 --- src/Calypso-Ring2/RGBehavior.extension.st | 120 -- src/Calypso-Ring2/RGByteLayout.extension.st | 8 - .../RGClassDefinitionCompiler.class.st | 79 -- src/Calypso-Ring2/RGComment.extension.st | 7 - .../RGCompiledMethodLayout.extension.st | 6 - src/Calypso-Ring2/RGEnvironment.extension.st | 60 - .../RGEphemeronLayout.extension.st | 6 - src/Calypso-Ring2/RGFixedLayout.extension.st | 6 - .../RGImmediateLayout.extension.st | 6 - src/Calypso-Ring2/RGMethod.extension.st | 136 -- .../RGPackageDefinition.extension.st | 93 -- src/Calypso-Ring2/RGSlot.extension.st | 11 - src/Calypso-Ring2/RGVariable.extension.st | 14 - .../RGVariableLayout.extension.st | 6 - src/Calypso-Ring2/RGWeakLayout.extension.st | 6 - src/Calypso-Ring2/RGWordLayout.extension.st | 8 - src/Calypso-Ring2/package.st | 1 - .../RGChunkImporter.class.st | 524 ------- src/Ring2-ChunkImporter/package.st | 1 - src/Ring2-Core/AbstractLayout.extension.st | 7 - src/Ring2-Core/BitsLayout.extension.st | 7 - src/Ring2-Core/ByteLayout.extension.st | 9 - src/Ring2-Core/Class.extension.st | 30 - src/Ring2-Core/ClassVariable.extension.st | 11 - src/Ring2-Core/CompiledMethod.extension.st | 25 - .../CompiledMethodLayout.extension.st | 9 - src/Ring2-Core/EmptyLayout.extension.st | 15 - src/Ring2-Core/EphemeronLayout.extension.st | 9 - src/Ring2-Core/FixedLayout.extension.st | 9 - src/Ring2-Core/GlobalVariable.extension.st | 8 - src/Ring2-Core/ImmediateLayout.extension.st | 9 - src/Ring2-Core/IndexedSlot.extension.st | 10 - .../InstanceVariableSlot.extension.st | 16 - src/Ring2-Core/Metaclass.extension.st | 8 - src/Ring2-Core/Object.extension.st | 43 - src/Ring2-Core/ObjectLayout.extension.st | 8 - src/Ring2-Core/PointerLayout.extension.st | 7 - src/Ring2-Core/Protocol.extension.st | 10 - .../RGBadInstantiationError.class.st | 8 - src/Ring2-Core/RGBehavior.class.st | 1205 ----------------- src/Ring2-Core/RGBehaviorFactory.class.st | 69 - src/Ring2-Core/RGBehaviorStrategy.class.st | 431 ------ .../RGBehaviorStrategyUser.class.st | 389 ------ src/Ring2-Core/RGBitsLayout.class.st | 23 - src/Ring2-Core/RGByteLayout.class.st | 17 - src/Ring2-Core/RGClass.class.st | 14 - .../RGClassDescriptionStrategy.class.st | 181 --- src/Ring2-Core/RGClassStrategy.class.st | 605 --------- src/Ring2-Core/RGClassVariable.class.st | 37 - src/Ring2-Core/RGComment.class.st | 200 --- .../RGCompiledMethodLayout.class.st | 35 - src/Ring2-Core/RGElement.class.st | 88 -- src/Ring2-Core/RGEmptyLayout.class.st | 17 - src/Ring2-Core/RGEnvironment.class.st | 959 ------------- .../RGEnvironmentAnnouncer.class.st | 161 --- src/Ring2-Core/RGEnvironmentBackend.class.st | 921 ------------- .../RGEnvironmentQueryInterface.class.st | 232 ---- src/Ring2-Core/RGEphemeronLayout.class.st | 17 - src/Ring2-Core/RGFixedLayout.class.st | 17 - src/Ring2-Core/RGGlobalVariable.class.st | 27 - src/Ring2-Core/RGImmediateLayout.class.st | 17 - .../RGIncompatibleBehaviorTypeError.class.st | 11 - src/Ring2-Core/RGIndexedSlot.class.st | 5 - .../RGInstanceVariableSlot.class.st | 11 - src/Ring2-Core/RGJoiningError.class.st | 5 - src/Ring2-Core/RGLayout.class.st | 108 -- src/Ring2-Core/RGMergeError.class.st | 51 - src/Ring2-Core/RGMetaclass.class.st | 14 - src/Ring2-Core/RGMetaclassStrategy.class.st | 234 ---- src/Ring2-Core/RGMetaclassTrait.class.st | 30 - .../RGMetaclassTraitStrategy.class.st | 152 --- .../RGMetaclassTraitV2Strategy.class.st | 213 --- src/Ring2-Core/RGMethod.class.st | 540 -------- src/Ring2-Core/RGNotFoundError.class.st | 5 - src/Ring2-Core/RGObject.class.st | 690 ---------- src/Ring2-Core/RGObjectLayout.class.st | 24 - src/Ring2-Core/RGPackageDefinition.class.st | 459 ------- src/Ring2-Core/RGPointerLayout.class.st | 145 -- src/Ring2-Core/RGPoolVariable.class.st | 28 - src/Ring2-Core/RGReadOnlyBackend.class.st | 487 ------- .../RGReadOnlyImageBackend.class.st | 436 ------ src/Ring2-Core/RGResolvingError.class.st | 10 - src/Ring2-Core/RGSlot.class.st | 49 - src/Ring2-Core/RGStampParser.class.st | 134 -- src/Ring2-Core/RGTrait.class.st | 30 - src/Ring2-Core/RGTraitAlias.class.st | 158 --- src/Ring2-Core/RGTraitComposition.class.st | 181 --- .../RGTraitCompositionVisitor.class.st | 127 -- .../RGTraitDescriptionStrategy.class.st | 72 - src/Ring2-Core/RGTraitExclusion.class.st | 159 --- src/Ring2-Core/RGTraitStrategy.class.st | 280 ---- src/Ring2-Core/RGTraitTransformation.class.st | 120 -- .../RGTraitV2DescriptionStrategy.class.st | 199 --- src/Ring2-Core/RGTraitV2Strategy.class.st | 595 -------- src/Ring2-Core/RGUnknownSlot.class.st | 84 -- src/Ring2-Core/RGUnresolvedValue.class.st | 70 - src/Ring2-Core/RGVariable.class.st | 56 - src/Ring2-Core/RGVariableLayout.class.st | 17 - src/Ring2-Core/RGWeakLayout.class.st | 23 - src/Ring2-Core/RGWordLayout.class.st | 17 - src/Ring2-Core/RGWrongEnvironment.class.st | 8 - src/Ring2-Core/RPackage.extension.st | 8 - src/Ring2-Core/Slot.extension.st | 16 - src/Ring2-Core/VariableLayout.extension.st | 9 - src/Ring2-Core/WeakLayout.extension.st | 9 - src/Ring2-Core/WordLayout.extension.st | 9 - src/Ring2-Core/package.st | 1 - .../MCClassDefinition.extension.st | 76 -- .../MCClassTraitDefinition.extension.st | 22 - .../MCDefinition.extension.st | 51 - .../MCFileTreeRepository.extension.st | 51 - .../MCMethodDefinition.extension.st | 63 - src/Ring2-Monticello/MCSnapshot.extension.st | 12 - .../MCTraitDefinition.extension.st | 26 - .../RGBehaviorStrategyUser.extension.st | 7 - .../RGByteLayout.extension.st | 7 - .../RGClassStrategy.extension.st | 49 - src/Ring2-Monticello/RGComment.extension.st | 8 - .../RGCompiledMethodLayout.extension.st | 7 - .../RGEnvironment.extension.st | 32 - .../RGEphemeronLayout.extension.st | 7 - .../RGFixedLayout.extension.st | 7 - .../RGImmediateLayout.extension.st | 7 - src/Ring2-Monticello/RGMethod.extension.st | 13 - .../RGPackageDefinition.extension.st | 14 - .../RGTraitV2Strategy.extension.st | 49 - .../RGVariableLayout.extension.st | 7 - .../RGWeakLayout.extension.st | 7 - .../RGWordLayout.extension.st | 7 - .../TonelRepository.extension.st | 34 - src/Ring2-Monticello/package.st | 1 - .../RGBehavior.extension.st | 148 -- .../RGEnvironment.extension.st | 30 - .../RGInstanceVariableSlot.extension.st | 21 - .../RGTraitComposition.extension.st | 10 - src/Ring2-RuntimeSupport/package.st | 1 - .../Ring2ChunkImporterTest.class.st | 861 ------------ src/Ring2-Tests-ChunkImporter/package.st | 1 - .../RGAnnouncementsTest.class.st | 211 --- src/Ring2-Tests-Core/RGBackendTest.class.st | 87 -- src/Ring2-Tests-Core/RGBehaviorTest.class.st | 120 -- .../RGClassDescripitonStrategyTest.class.st | 280 ---- .../RGClassDescriptionTest.class.st | 11 - .../RGClassStrategyTest.class.st | 164 --- src/Ring2-Tests-Core/RGClassTest.class.st | 370 ----- .../RGClassVariableTest.class.st | 51 - src/Ring2-Tests-Core/RGCommentTest.class.st | 125 -- .../RGEnsureTraitTest.class.st | 122 -- .../RGEnvironmentBackendTest.class.st | 182 --- .../RGEnvironmentQueryInterfaceTest.class.st | 40 - .../RGEnvironmentTest.class.st | 422 ------ .../RGGlobalVariableTest.class.st | 38 - .../RGLayoutDefinitionTest.class.st | 143 -- .../RGMCTraitCompositionVisitorTest.class.st | 211 --- .../RGMergeErrorTest.class.st | 5 - .../RGMetaclassStrategyTest.class.st | 129 -- .../RGMetaclassTraitStrategyTest.class.st | 36 - .../RGMetaclassTraitTest.class.st | 87 -- src/Ring2-Tests-Core/RGMethodTest.class.st | 256 ---- src/Ring2-Tests-Core/RGObjectTest.class.st | 191 --- .../RGPackageDefinitionTest.class.st | 328 ----- .../RGPoolVariableTest.class.st | 29 - .../RGReadOnlyBackendTest.class.st | 13 - .../RGReadOnlyImageBackendTest.class.st | 397 ------ src/Ring2-Tests-Core/RGSlotTest.class.st | 62 - .../RGStampParserTest.class.st | 23 - src/Ring2-Tests-Core/RGTest.class.st | 84 -- src/Ring2-Tests-Core/RGTestClass.class.st | 7 - src/Ring2-Tests-Core/RGTestTrait.trait.st | 4 - .../RGTraitAliasTest.class.st | 103 -- .../RGTraitCompositionTest.class.st | 135 -- .../RGTraitExclusionTest.class.st | 146 -- .../RGTraitStrategyTest.class.st | 115 -- src/Ring2-Tests-Core/RGTraitTest.class.st | 91 -- .../RGUnresolvedValueTest.class.st | 42 - src/Ring2-Tests-Core/TRGBehaviorTest.trait.st | 267 ---- .../TRGClassDescriptionTest.trait.st | 36 - src/Ring2-Tests-Core/TRGReadOnlyTest.trait.st | 18 - src/Ring2-Tests-Core/Trait.extension.st | 9 - src/Ring2-Tests-Core/package.st | 1 - .../RGMCClassTest.class.st | 44 - src/Ring2-Tests-Monticello/RGMCTest.class.st | 73 - src/Ring2-Tests-Monticello/package.st | 1 - .../MetaclassForTraits.extension.st | 22 - .../TaAbstractComposition.extension.st | 17 - .../TaAliasMethod.extension.st | 18 - .../TaCompositionElement.extension.st | 17 - .../TaRemoveMethod.extension.st | 17 - src/Ring2-TraitsV2Support/package.st | 1 - 191 files changed, 17 insertions(+), 20326 deletions(-) delete mode 100644 src/Calypso-Ring2/ClyRing2Environment.class.st delete mode 100644 src/Calypso-Ring2/RGBehavior.extension.st delete mode 100644 src/Calypso-Ring2/RGByteLayout.extension.st delete mode 100644 src/Calypso-Ring2/RGClassDefinitionCompiler.class.st delete mode 100644 src/Calypso-Ring2/RGComment.extension.st delete mode 100644 src/Calypso-Ring2/RGCompiledMethodLayout.extension.st delete mode 100644 src/Calypso-Ring2/RGEnvironment.extension.st delete mode 100644 src/Calypso-Ring2/RGEphemeronLayout.extension.st delete mode 100644 src/Calypso-Ring2/RGFixedLayout.extension.st delete mode 100644 src/Calypso-Ring2/RGImmediateLayout.extension.st delete mode 100644 src/Calypso-Ring2/RGMethod.extension.st delete mode 100644 src/Calypso-Ring2/RGPackageDefinition.extension.st delete mode 100644 src/Calypso-Ring2/RGSlot.extension.st delete mode 100644 src/Calypso-Ring2/RGVariable.extension.st delete mode 100644 src/Calypso-Ring2/RGVariableLayout.extension.st delete mode 100644 src/Calypso-Ring2/RGWeakLayout.extension.st delete mode 100644 src/Calypso-Ring2/RGWordLayout.extension.st delete mode 100644 src/Calypso-Ring2/package.st delete mode 100644 src/Ring2-ChunkImporter/RGChunkImporter.class.st delete mode 100644 src/Ring2-ChunkImporter/package.st delete mode 100644 src/Ring2-Core/AbstractLayout.extension.st delete mode 100644 src/Ring2-Core/BitsLayout.extension.st delete mode 100644 src/Ring2-Core/ByteLayout.extension.st delete mode 100644 src/Ring2-Core/Class.extension.st delete mode 100644 src/Ring2-Core/ClassVariable.extension.st delete mode 100644 src/Ring2-Core/CompiledMethod.extension.st delete mode 100644 src/Ring2-Core/CompiledMethodLayout.extension.st delete mode 100644 src/Ring2-Core/EmptyLayout.extension.st delete mode 100644 src/Ring2-Core/EphemeronLayout.extension.st delete mode 100644 src/Ring2-Core/FixedLayout.extension.st delete mode 100644 src/Ring2-Core/GlobalVariable.extension.st delete mode 100644 src/Ring2-Core/ImmediateLayout.extension.st delete mode 100644 src/Ring2-Core/IndexedSlot.extension.st delete mode 100644 src/Ring2-Core/InstanceVariableSlot.extension.st delete mode 100644 src/Ring2-Core/Metaclass.extension.st delete mode 100644 src/Ring2-Core/Object.extension.st delete mode 100644 src/Ring2-Core/ObjectLayout.extension.st delete mode 100644 src/Ring2-Core/PointerLayout.extension.st delete mode 100644 src/Ring2-Core/Protocol.extension.st delete mode 100644 src/Ring2-Core/RGBadInstantiationError.class.st delete mode 100644 src/Ring2-Core/RGBehavior.class.st delete mode 100644 src/Ring2-Core/RGBehaviorFactory.class.st delete mode 100644 src/Ring2-Core/RGBehaviorStrategy.class.st delete mode 100644 src/Ring2-Core/RGBehaviorStrategyUser.class.st delete mode 100644 src/Ring2-Core/RGBitsLayout.class.st delete mode 100644 src/Ring2-Core/RGByteLayout.class.st delete mode 100644 src/Ring2-Core/RGClass.class.st delete mode 100644 src/Ring2-Core/RGClassDescriptionStrategy.class.st delete mode 100644 src/Ring2-Core/RGClassStrategy.class.st delete mode 100644 src/Ring2-Core/RGClassVariable.class.st delete mode 100644 src/Ring2-Core/RGComment.class.st delete mode 100644 src/Ring2-Core/RGCompiledMethodLayout.class.st delete mode 100644 src/Ring2-Core/RGElement.class.st delete mode 100644 src/Ring2-Core/RGEmptyLayout.class.st delete mode 100644 src/Ring2-Core/RGEnvironment.class.st delete mode 100644 src/Ring2-Core/RGEnvironmentAnnouncer.class.st delete mode 100644 src/Ring2-Core/RGEnvironmentBackend.class.st delete mode 100644 src/Ring2-Core/RGEnvironmentQueryInterface.class.st delete mode 100644 src/Ring2-Core/RGEphemeronLayout.class.st delete mode 100644 src/Ring2-Core/RGFixedLayout.class.st delete mode 100644 src/Ring2-Core/RGGlobalVariable.class.st delete mode 100644 src/Ring2-Core/RGImmediateLayout.class.st delete mode 100644 src/Ring2-Core/RGIncompatibleBehaviorTypeError.class.st delete mode 100644 src/Ring2-Core/RGIndexedSlot.class.st delete mode 100644 src/Ring2-Core/RGInstanceVariableSlot.class.st delete mode 100644 src/Ring2-Core/RGJoiningError.class.st delete mode 100644 src/Ring2-Core/RGLayout.class.st delete mode 100644 src/Ring2-Core/RGMergeError.class.st delete mode 100644 src/Ring2-Core/RGMetaclass.class.st delete mode 100644 src/Ring2-Core/RGMetaclassStrategy.class.st delete mode 100644 src/Ring2-Core/RGMetaclassTrait.class.st delete mode 100644 src/Ring2-Core/RGMetaclassTraitStrategy.class.st delete mode 100644 src/Ring2-Core/RGMetaclassTraitV2Strategy.class.st delete mode 100644 src/Ring2-Core/RGMethod.class.st delete mode 100644 src/Ring2-Core/RGNotFoundError.class.st delete mode 100644 src/Ring2-Core/RGObject.class.st delete mode 100644 src/Ring2-Core/RGObjectLayout.class.st delete mode 100644 src/Ring2-Core/RGPackageDefinition.class.st delete mode 100644 src/Ring2-Core/RGPointerLayout.class.st delete mode 100644 src/Ring2-Core/RGPoolVariable.class.st delete mode 100644 src/Ring2-Core/RGReadOnlyBackend.class.st delete mode 100644 src/Ring2-Core/RGReadOnlyImageBackend.class.st delete mode 100644 src/Ring2-Core/RGResolvingError.class.st delete mode 100644 src/Ring2-Core/RGSlot.class.st delete mode 100644 src/Ring2-Core/RGStampParser.class.st delete mode 100644 src/Ring2-Core/RGTrait.class.st delete mode 100644 src/Ring2-Core/RGTraitAlias.class.st delete mode 100644 src/Ring2-Core/RGTraitComposition.class.st delete mode 100644 src/Ring2-Core/RGTraitCompositionVisitor.class.st delete mode 100644 src/Ring2-Core/RGTraitDescriptionStrategy.class.st delete mode 100644 src/Ring2-Core/RGTraitExclusion.class.st delete mode 100644 src/Ring2-Core/RGTraitStrategy.class.st delete mode 100644 src/Ring2-Core/RGTraitTransformation.class.st delete mode 100644 src/Ring2-Core/RGTraitV2DescriptionStrategy.class.st delete mode 100644 src/Ring2-Core/RGTraitV2Strategy.class.st delete mode 100644 src/Ring2-Core/RGUnknownSlot.class.st delete mode 100644 src/Ring2-Core/RGUnresolvedValue.class.st delete mode 100644 src/Ring2-Core/RGVariable.class.st delete mode 100644 src/Ring2-Core/RGVariableLayout.class.st delete mode 100644 src/Ring2-Core/RGWeakLayout.class.st delete mode 100644 src/Ring2-Core/RGWordLayout.class.st delete mode 100644 src/Ring2-Core/RGWrongEnvironment.class.st delete mode 100644 src/Ring2-Core/RPackage.extension.st delete mode 100644 src/Ring2-Core/Slot.extension.st delete mode 100644 src/Ring2-Core/VariableLayout.extension.st delete mode 100644 src/Ring2-Core/WeakLayout.extension.st delete mode 100644 src/Ring2-Core/WordLayout.extension.st delete mode 100644 src/Ring2-Core/package.st delete mode 100644 src/Ring2-Monticello/MCClassDefinition.extension.st delete mode 100644 src/Ring2-Monticello/MCClassTraitDefinition.extension.st delete mode 100644 src/Ring2-Monticello/MCDefinition.extension.st delete mode 100644 src/Ring2-Monticello/MCFileTreeRepository.extension.st delete mode 100644 src/Ring2-Monticello/MCMethodDefinition.extension.st delete mode 100644 src/Ring2-Monticello/MCSnapshot.extension.st delete mode 100644 src/Ring2-Monticello/MCTraitDefinition.extension.st delete mode 100644 src/Ring2-Monticello/RGBehaviorStrategyUser.extension.st delete mode 100644 src/Ring2-Monticello/RGByteLayout.extension.st delete mode 100644 src/Ring2-Monticello/RGClassStrategy.extension.st delete mode 100644 src/Ring2-Monticello/RGComment.extension.st delete mode 100644 src/Ring2-Monticello/RGCompiledMethodLayout.extension.st delete mode 100644 src/Ring2-Monticello/RGEnvironment.extension.st delete mode 100644 src/Ring2-Monticello/RGEphemeronLayout.extension.st delete mode 100644 src/Ring2-Monticello/RGFixedLayout.extension.st delete mode 100644 src/Ring2-Monticello/RGImmediateLayout.extension.st delete mode 100644 src/Ring2-Monticello/RGMethod.extension.st delete mode 100644 src/Ring2-Monticello/RGPackageDefinition.extension.st delete mode 100644 src/Ring2-Monticello/RGTraitV2Strategy.extension.st delete mode 100644 src/Ring2-Monticello/RGVariableLayout.extension.st delete mode 100644 src/Ring2-Monticello/RGWeakLayout.extension.st delete mode 100644 src/Ring2-Monticello/RGWordLayout.extension.st delete mode 100644 src/Ring2-Monticello/TonelRepository.extension.st delete mode 100644 src/Ring2-Monticello/package.st delete mode 100644 src/Ring2-RuntimeSupport/RGBehavior.extension.st delete mode 100644 src/Ring2-RuntimeSupport/RGEnvironment.extension.st delete mode 100644 src/Ring2-RuntimeSupport/RGInstanceVariableSlot.extension.st delete mode 100644 src/Ring2-RuntimeSupport/RGTraitComposition.extension.st delete mode 100644 src/Ring2-RuntimeSupport/package.st delete mode 100644 src/Ring2-Tests-ChunkImporter/Ring2ChunkImporterTest.class.st delete mode 100644 src/Ring2-Tests-ChunkImporter/package.st delete mode 100644 src/Ring2-Tests-Core/RGAnnouncementsTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGBackendTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGBehaviorTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGClassDescripitonStrategyTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGClassDescriptionTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGClassStrategyTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGClassTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGClassVariableTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGCommentTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGEnsureTraitTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGEnvironmentBackendTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGEnvironmentQueryInterfaceTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGEnvironmentTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGGlobalVariableTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGLayoutDefinitionTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGMCTraitCompositionVisitorTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGMergeErrorTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGMetaclassStrategyTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGMetaclassTraitStrategyTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGMetaclassTraitTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGMethodTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGObjectTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGPackageDefinitionTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGPoolVariableTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGReadOnlyBackendTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGReadOnlyImageBackendTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGSlotTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGStampParserTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGTestClass.class.st delete mode 100644 src/Ring2-Tests-Core/RGTestTrait.trait.st delete mode 100644 src/Ring2-Tests-Core/RGTraitAliasTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGTraitCompositionTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGTraitExclusionTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGTraitStrategyTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGTraitTest.class.st delete mode 100644 src/Ring2-Tests-Core/RGUnresolvedValueTest.class.st delete mode 100644 src/Ring2-Tests-Core/TRGBehaviorTest.trait.st delete mode 100644 src/Ring2-Tests-Core/TRGClassDescriptionTest.trait.st delete mode 100644 src/Ring2-Tests-Core/TRGReadOnlyTest.trait.st delete mode 100644 src/Ring2-Tests-Core/Trait.extension.st delete mode 100644 src/Ring2-Tests-Core/package.st delete mode 100644 src/Ring2-Tests-Monticello/RGMCClassTest.class.st delete mode 100644 src/Ring2-Tests-Monticello/RGMCTest.class.st delete mode 100644 src/Ring2-Tests-Monticello/package.st delete mode 100644 src/Ring2-TraitsV2Support/MetaclassForTraits.extension.st delete mode 100644 src/Ring2-TraitsV2Support/TaAbstractComposition.extension.st delete mode 100644 src/Ring2-TraitsV2Support/TaAliasMethod.extension.st delete mode 100644 src/Ring2-TraitsV2Support/TaCompositionElement.extension.st delete mode 100644 src/Ring2-TraitsV2Support/TaRemoveMethod.extension.st delete mode 100644 src/Ring2-TraitsV2Support/package.st diff --git a/src/BaselineOfMoose/BaselineOfMoose.class.st b/src/BaselineOfMoose/BaselineOfMoose.class.st index 3789d3810..18d8ebef9 100644 --- a/src/BaselineOfMoose/BaselineOfMoose.class.st +++ b/src/BaselineOfMoose/BaselineOfMoose.class.st @@ -13,6 +13,9 @@ BaselineOfMoose >> baseline: spec [ | repository | repository := self packageRepositoryURL. + spec for: #'pharo7.x' with: [ self baselineRing2ForPharo7: spec ]. + spec for: #'pharo8.x' with: [ self baselineRing2: spec ]. + spec for: #common do: [ spec package: 'Moose-PharoOverrides'. @@ -28,7 +31,6 @@ BaselineOfMoose >> baseline: spec [ spec package: 'GToolkit-Examples'. self baselineDeepTraverser: spec. - self baselineRing2: spec. spec package: 'Moose-Query'; @@ -411,19 +413,21 @@ BaselineOfMoose >> baselinePetitParser: spec [ ] { #category : #baseline } -BaselineOfMoose >> baselineRing2: spec [ - - self defineGroup: #Ring2 in: spec with: #( - 'Ring2-Core' - 'Ring2-TraitsV2Support' - 'Ring2-Monticello' - 'Ring2-ChunkImporter' - 'Ring2-Tests-Core' - 'Ring2-Tests-Monticello' - 'Ring2-Tests-ChunkImporter' - 'Ring2-RuntimeSupport' - 'Calypso-Ring2'). +BaselineOfMoose >> baselineRing2: spec [ + spec + baseline: 'Ring2' + with: [ spec + loads: 'runtimeSupport'; + repository: 'github://pavel-krivanek/Ring2:RGPackageRenamed/src' ] +] +{ #category : #baseline } +BaselineOfMoose >> baselineRing2ForPharo7: spec [ + spec + baseline: 'Ring2' + with: [ spec + loads: 'runtimeSupport'; + repository: 'github://pavel-krivanek/Ring2:v1.2.0/src' ] ] { #category : #baseline } diff --git a/src/Calypso-Ring2/ClyRing2Environment.class.st b/src/Calypso-Ring2/ClyRing2Environment.class.st deleted file mode 100644 index f0ac88069..000000000 --- a/src/Calypso-Ring2/ClyRing2Environment.class.st +++ /dev/null @@ -1,169 +0,0 @@ -" -Please comment me using the following template inspired by Class Responsibility Collaborator (CRC) design: - -For the Class part: State a one line summary. For example, ""I represent a paragraph of text"". - -For the Responsibility part: Three sentences about my main responsibilities - what I do, what I know. - -For the Collaborators Part: State my main collaborators and one line about how I interact with them. - -Public API and Key Messages - -- message one -- message two -- (for bonus points) how to create instances. - - One simple example is simply gorgeous. - -Internal Representation and Key Implementation Points. - - Instance Variables - environment: - name: - - - Implementation Points -" -Class { - #name : #ClyRing2Environment, - #superclass : #Object, - #instVars : [ - 'environment', - 'name', - 'packageOrganizer', - 'projectManager' - ], - #category : #'Calypso-Ring2' -} - -{ #category : #'instance creation' } -ClyRing2Environment class >> on: anRGEvironment [ - - ^ self new - environment: anRGEvironment; - yourself. -] - -{ #category : #converting } -ClyRing2Environment >> asGlobalScopeIn: aNavigationEnvironment [ - - - ^ClySystemEnvironmentScope of: self in: aNavigationEnvironment named: name -] - -{ #category : #binding } -ClyRing2Environment >> bindingOf: aSymbol [ - - ^ environment bindingOf: aSymbol -] - -{ #category : #accessing } -ClyRing2Environment >> classes [ - ^ self environment ask allClasses -] - -{ #category : #initialization } -ClyRing2Environment >> compileANewClassFrom: aString notifying: aController startingFrom: aClass [ - - | importer | - - importer := RGChunkImporter new. - importer environment: self environment. - importer fileInFrom: (aString, '!') readStream. - - ^ aClass -] - -{ #category : #initialization } -ClyRing2Environment >> createPackageNamed: aPackageName [ - - ^ environment ensurePackageNamed: aPackageName -] - -{ #category : #initialization } -ClyRing2Environment >> defaultClassCompiler [ - - ^ self class compiler -] - -{ #category : #accessing } -ClyRing2Environment >> environment [ - ^ environment -] - -{ #category : #accessing } -ClyRing2Environment >> environment: anObject [ - environment := anObject -] - -{ #category : #initialization } -ClyRing2Environment >> includesClassNamed: aSymbol [ - - ^ self environment includesClassNamed: aSymbol -] - -{ #category : #initialization } -ClyRing2Environment >> initialize [ - - super initialize. - - environment := RGEnvironment new. - projectManager := ClyProjectManagerRegistry new -] - -{ #category : #accessing } -ClyRing2Environment >> name [ - ^ name ifNil: [ super printString ] -] - -{ #category : #accessing } -ClyRing2Environment >> name: anObject [ - name := anObject -] - -{ #category : #accessing } -ClyRing2Environment >> packageOrganizer [ - ^ packageOrganizer -] - -{ #category : #accessing } -ClyRing2Environment >> packageOrganizer: anObject [ - packageOrganizer := anObject -] - -{ #category : #initialization } -ClyRing2Environment >> packages [ - - ^ environment ask packages -] - -{ #category : #accessing } -ClyRing2Environment >> projectManager [ - ^ projectManager -] - -{ #category : #accessing } -ClyRing2Environment >> projectManager: anObject [ - projectManager := anObject -] - -{ #category : #initialization } -ClyRing2Environment >> subscribe: anObject [ - self subscribe: anObject for: SystemAnnouncement -] - -{ #category : #initialization } -ClyRing2Environment >> subscribe: anObject for: anAnnouncementClass [ - self unsubscribe: anObject. - environment announcer when: anAnnouncementClass send: #systemChanged: to: anObject -] - -{ #category : #initialization } -ClyRing2Environment >> unsubscribe: anObject [ - environment announcer unsubscribe: anObject -] - -{ #category : #announcing } -ClyRing2Environment >> when: anAnnouncementClass send: aSelector to: anObject [ - self environment announcer when: anAnnouncementClass send: aSelector to: anObject -] diff --git a/src/Calypso-Ring2/RGBehavior.extension.st b/src/Calypso-Ring2/RGBehavior.extension.st deleted file mode 100644 index 11477a0ba..000000000 --- a/src/Calypso-Ring2/RGBehavior.extension.st +++ /dev/null @@ -1,120 +0,0 @@ -Extension { #name : #RGBehavior } - -{ #category : #'*Calypso-Ring2' } -RGBehavior >> calypsoEnvironmentType [ - ^ClyClass -] - -{ #category : #'*Calypso-Ring2' } -RGBehavior >> canUnderstand: selector [ - "Answer whether the receiver can respond to the message whose selector - is the argument." - - self allSuperclassesDo: [ :each | - (each methods anySatisfy: [ :method | method name = selector ]) - ifTrue: [ ^ true ] ]. - - ^ self methods anySatisfy: [ :method | method name = selector ]. -] - -{ #category : #'*Calypso-Ring2' } -RGBehavior >> hasAbstractMethods [ - "Tells whether the receiver locally defines an abstract method, i.e., a method sending subclassResponsibility" - - - ^ false -" ^ (self methods anySatisfy: [:cm | cm sendsSelector: #subclassResponsibility ])" -] - -{ #category : #'*Calypso-Ring2' } -RGBehavior >> includesLocalSelector: aSymbol [ - ^self localMethods anySatisfy: [ :each | each name = aSymbol ]. -] - -{ #category : #'*Calypso-Ring2' } -RGBehavior >> includesMethodsAffectedBy: aSystemAnnouncement [ - ^aSystemAnnouncement affectsMethodsDefinedInClass: self - -] - -{ #category : #'*Calypso-Ring2' } -RGBehavior >> includesVariablesAffectedByModificationOf: modifiedClass [ - "Any class has ClassVariables which are visible from instance side and class side. That's why here we must check both class and metaclass" - - self instanceSide = modifiedClass instanceSide ifTrue: [ ^true ]. - self classSide = modifiedClass classSide ifTrue: [ ^true ]. - - self isRootInEnvironment ifTrue: [ ^false ]. - - ^self superclass includesVariablesAffectedByModificationOf: modifiedClass -] - -{ #category : #'*Calypso-Ring2' } -RGBehavior >> isObsolete [ - - ^ false -] - -{ #category : #'*Calypso-Ring2' } -RGBehavior >> lookupSelector: selector [ - "Look up the given selector in my methodDictionary. - Return the corresponding method if found. - Otherwise chase the superclass chain and try again. - Return nil if no method is found." - | lookupClass | - lookupClass := self. - [lookupClass == nil] - whileFalse: [ - lookupClass methodDict - at: selector - ifPresent: [ :method | ^ method ]. - lookupClass := lookupClass superclass]. - ^ nil -] - -{ #category : #'*Calypso-Ring2' } -RGBehavior >> metaLevelScope [ - ^self isInstanceSide ifTrue: [ ClyInstanceSideScope ] ifFalse: [ ClyClassSideScope ] -] - -{ #category : #'*Calypso-Ring2' } -RGBehavior >> methodDict [ - - ^ Dictionary newFrom: (self methods collect: [ :each | each name asSymbol -> each ]) -] - -{ #category : #'*Calypso-Ring2' } -RGBehavior >> organization [ - - ^ self -] - -{ #category : #'*Calypso-Ring2' } -RGBehavior >> protocolNamed: aString [ - - ^ self protocols detect: [ :each | each name = aString ] -] - -{ #category : #'*Calypso-Ring2' } -RGBehavior >> sourceCodeTemplate [ - "Answer an expression to be edited and evaluated in order to define - methods in this class or trait." - - ^ 'messageSelectorAndArgumentNames - "comment stating purpose of message" - - | temporary variable names | - statements' -] - -{ #category : #'*Calypso-Ring2' } -RGBehavior >> subclassDefinerClass [ - ^RGClassDefinitionCompiler on: self environment -] - -{ #category : #'*Calypso-Ring2' } -RGBehavior >> traitCompositionIncludes: aTrait [ - ^self == aTrait or: - [self hasTraitComposition and: - [self traitComposition allTraits includes: aTrait]] -] diff --git a/src/Calypso-Ring2/RGByteLayout.extension.st b/src/Calypso-Ring2/RGByteLayout.extension.st deleted file mode 100644 index 7eac1fecd..000000000 --- a/src/Calypso-Ring2/RGByteLayout.extension.st +++ /dev/null @@ -1,8 +0,0 @@ -Extension { #name : #RGByteLayout } - -{ #category : #'*Calypso-Ring2' } -RGByteLayout >> kindOfSubclassDefinitionString [ - ^ ' variableByteSubclass: ' - - -] diff --git a/src/Calypso-Ring2/RGClassDefinitionCompiler.class.st b/src/Calypso-Ring2/RGClassDefinitionCompiler.class.st deleted file mode 100644 index e5115f249..000000000 --- a/src/Calypso-Ring2/RGClassDefinitionCompiler.class.st +++ /dev/null @@ -1,79 +0,0 @@ -Class { - #name : #RGClassDefinitionCompiler, - #superclass : #Object, - #instVars : [ - 'environment', - 'definitionString', - 'requestor' - ], - #category : #'Calypso-Ring2' -} - -{ #category : #'instance creation' } -RGClassDefinitionCompiler class >> on: anRGEnvironment [ - ^self new - environment: anRGEnvironment -] - -{ #category : #accessing } -RGClassDefinitionCompiler >> definitionString [ - ^ definitionString -] - -{ #category : #accessing } -RGClassDefinitionCompiler >> definitionString: anObject [ - definitionString := anObject -] - -{ #category : #accessing } -RGClassDefinitionCompiler >> environment [ - ^ environment -] - -{ #category : #accessing } -RGClassDefinitionCompiler >> environment: anObject [ - environment := anObject -] - -{ #category : #'public access' } -RGClassDefinitionCompiler >> evaluate [ - - | importer class createdClass | - - importer := RGChunkImporter new. - - importer fileInFrom: (definitionString, '!') readStream. - - class := importer environment ask behaviors detect: [:each | - each isRingResolved and: [each superclass isRingResolved ]]. - - importer := RGChunkImporter new. - importer environment: environment. - importer fileInFrom: (definitionString, '!') readStream. - - createdClass := environment ask behaviorNamed: class name. - - createdClass superclass metaclass metaclass isRingResolved ifTrue: [ - environment cleanWithMetaclassNamed: createdClass superclass metaclass metaclass name - ]. - ^createdClass -] - -{ #category : #'as yet unclassified' } -RGClassDefinitionCompiler >> logged: aBoolean [ -] - -{ #category : #'as yet unclassified' } -RGClassDefinitionCompiler >> new [ - ^self -] - -{ #category : #'as yet unclassified' } -RGClassDefinitionCompiler >> requestor: anObject [ - requestor := anObject -] - -{ #category : #'as yet unclassified' } -RGClassDefinitionCompiler >> source: aString [ - definitionString := aString -] diff --git a/src/Calypso-Ring2/RGComment.extension.st b/src/Calypso-Ring2/RGComment.extension.st deleted file mode 100644 index 117b966e5..000000000 --- a/src/Calypso-Ring2/RGComment.extension.st +++ /dev/null @@ -1,7 +0,0 @@ -Extension { #name : #RGComment } - -{ #category : #'*Calypso-Ring2' } -RGComment >> asText [ - - ^ (self content ifNil: ['']) asText -] diff --git a/src/Calypso-Ring2/RGCompiledMethodLayout.extension.st b/src/Calypso-Ring2/RGCompiledMethodLayout.extension.st deleted file mode 100644 index ff0564035..000000000 --- a/src/Calypso-Ring2/RGCompiledMethodLayout.extension.st +++ /dev/null @@ -1,6 +0,0 @@ -Extension { #name : #RGCompiledMethodLayout } - -{ #category : #'*Calypso-Ring2' } -RGCompiledMethodLayout >> kindOfSubclassDefinitionString [ - ^ ' variableByteSubclass: ' -] diff --git a/src/Calypso-Ring2/RGEnvironment.extension.st b/src/Calypso-Ring2/RGEnvironment.extension.st deleted file mode 100644 index 45a28b09b..000000000 --- a/src/Calypso-Ring2/RGEnvironment.extension.st +++ /dev/null @@ -1,60 +0,0 @@ -Extension { #name : #RGEnvironment } - -{ #category : #'*Calypso-Ring2' } -RGEnvironment >> associationsDo: aBlock [ - - self bindings do: aBlock -] - -{ #category : #'*Calypso-Ring2' } -RGEnvironment >> at: aSymbol [ - - ^ self ask behaviorNamed: aSymbol -] - -{ #category : #'*Calypso-Ring2' } -RGEnvironment >> bindings [ - - "TODO:" - - | dict | - - dict := Dictionary new. - self globalVariablesDo: [ :each | - each name -> each ]. - - ^ dict. -] - -{ #category : #'*Calypso-Ring2' } -RGEnvironment >> browse [ - - | clyEnv clyNavEnv browser | - - clyEnv := ClyRing2Environment new. - clyEnv environment: self. - - clyNavEnv := (ClyNavigationEnvironment over: clyEnv) - addPlugin: ClyDefaultSystemEnvironmentPlugin new; - attachToSystem. - - browser := ClyFullBrowser new - navigationEnvironment: clyNavEnv. - browser addPlugin: ClyStandardBrowserPlugin new. - - ^ browser open. -] - -{ #category : #'*Calypso-Ring2' } -RGEnvironment >> classNames [ - - "TODO:" - ^ self allClasses collect: #name. -] - -{ #category : #'*Calypso-Ring2' } -RGEnvironment >> nonClassNames [ - - "TODO:" - ^ #() -] diff --git a/src/Calypso-Ring2/RGEphemeronLayout.extension.st b/src/Calypso-Ring2/RGEphemeronLayout.extension.st deleted file mode 100644 index 85e71fd91..000000000 --- a/src/Calypso-Ring2/RGEphemeronLayout.extension.st +++ /dev/null @@ -1,6 +0,0 @@ -Extension { #name : #RGEphemeronLayout } - -{ #category : #'*Calypso-Ring2' } -RGEphemeronLayout >> kindOfSubclassDefinitionString [ - ^ ' ephemeronSubclass: ' -] diff --git a/src/Calypso-Ring2/RGFixedLayout.extension.st b/src/Calypso-Ring2/RGFixedLayout.extension.st deleted file mode 100644 index b1e722f89..000000000 --- a/src/Calypso-Ring2/RGFixedLayout.extension.st +++ /dev/null @@ -1,6 +0,0 @@ -Extension { #name : #RGFixedLayout } - -{ #category : #'*Calypso-Ring2' } -RGFixedLayout >> kindOfSubclassDefinitionString [ - ^ ' subclass: ' -] diff --git a/src/Calypso-Ring2/RGImmediateLayout.extension.st b/src/Calypso-Ring2/RGImmediateLayout.extension.st deleted file mode 100644 index 6221a17e3..000000000 --- a/src/Calypso-Ring2/RGImmediateLayout.extension.st +++ /dev/null @@ -1,6 +0,0 @@ -Extension { #name : #RGImmediateLayout } - -{ #category : #'*Calypso-Ring2' } -RGImmediateLayout >> kindOfSubclassDefinitionString [ - ^ ' immediateSubclass: ' -] diff --git a/src/Calypso-Ring2/RGMethod.extension.st b/src/Calypso-Ring2/RGMethod.extension.st deleted file mode 100644 index f4f452c1e..000000000 --- a/src/Calypso-Ring2/RGMethod.extension.st +++ /dev/null @@ -1,136 +0,0 @@ -Extension { #name : #RGMethod } - -{ #category : #'*Calypso-Ring2' } -RGMethod >> astForStylingInCalypso [ - "this method simplified remote method styling. - Remote proxy will redefine it by building AST on client side" - ^self ast -] - -{ #category : #'*Calypso-Ring2' } -RGMethod >> calypsoEnvironmentType [ - ^ClyMethod -] - -{ #category : #'*Calypso-Ring2' } -RGMethod >> hasPragmaNamed: aSymbol [ - ^ self pragmas anySatisfy: [ :pragma | pragma selector = aSymbol ] -] - -{ #category : #'*Calypso-Ring2' } -RGMethod >> hasSelector: aSelector [ - "Answers true if the method refers to the selector" - (self selector = aSelector) ifTrue: [ ^ true ]. - ^ self sendsSelector: aSelector -] - -{ #category : #'*Calypso-Ring2' } -RGMethod >> hasSelector: selector specialSelectorIndex: specialOrNil [ - - ^ self ast sentMessages includes: selector -] - -{ #category : #'*Calypso-Ring2' } -RGMethod >> implementors [ - - ^ #() -] - -{ #category : #'*Calypso-Ring2' } -RGMethod >> isDefinedInPackage: aPackage [ - - ^ self package = aPackage -] - -{ #category : #'*Calypso-Ring2' } -RGMethod >> isInstalled [ - ^ true -] - -{ #category : #'*Calypso-Ring2' } -RGMethod >> literalAt: anIndex [ - - ^ self ast literals at: anIndex -] - -{ #category : #'*Calypso-Ring2' } -RGMethod >> messages [ - - ^ self ast sentMessages -] - -{ #category : #'*Calypso-Ring2' } -RGMethod >> origin [ - - ^ self parent -] - -{ #category : #'*Calypso-Ring2' } -RGMethod >> pragmas [ - - ^ self ast pragmas -] - -{ #category : #'*Calypso-Ring2' } -RGMethod >> readsRef: literalAssociation [ - "Answer whether the receiver loads the argument." - ^ self ast allChildren anySatisfy: [:each | - each isVariable and: [ each name = literalAssociation key ]] - - "self ast nodesDo: [ :node | - node isVariable and: [ - node parent isAssignment not and: [ - (node binding = literalAssociation) - ifTrue: [^true]]]]. - ^false" -] - -{ #category : #'*Calypso-Ring2' } -RGMethod >> readsSlot: aSlot [ - | nodes | - nodes := self ast allChildren. - nodes := nodes select: #isVariable. - nodes := nodes select: #isInstance. - nodes := nodes reject: [ :node | node parent isAssignment and: [ node parent variable = node ] ]. - ^ nodes anySatisfy: [ :node | node binding slot == aSlot ] -] - -{ #category : #'*Calypso-Ring2' } -RGMethod >> sendNodes [ - ^self ast sendNodes -] - -{ #category : #'*Calypso-Ring2' } -RGMethod >> sendsSelector: aSymbol [ - "Answer whether the method sends a particular selector" - ^ self messages includes: aSymbol -] - -{ #category : #'*Calypso-Ring2' } -RGMethod >> variableNodes [ - ^self ast variableNodes -] - -{ #category : #'*Calypso-Ring2' } -RGMethod >> writesRef: literalAssociation [ - "Answer whether the receiver stores into the argument." - self ast nodesDo: [ :node | - node isVariable and: [ - node parent isAssignment and: [ - (node parent variable = node) and: [ - (node binding = literalAssociation) - ifTrue: [^true]]]]]. - ^false -] - -{ #category : #'*Calypso-Ring2' } -RGMethod >> writesSlot: aSlot [ - self ast nodesDo: [ :node | - node isVariable and: [ - node parent isAssignment and: [ - (node parent variable = node) and: [ - node isInstance and: [ - (node binding slot == aSlot) - ifTrue: [^true]]]]]]. - ^false -] diff --git a/src/Calypso-Ring2/RGPackageDefinition.extension.st b/src/Calypso-Ring2/RGPackageDefinition.extension.st deleted file mode 100644 index 69e3028bc..000000000 --- a/src/Calypso-Ring2/RGPackageDefinition.extension.st +++ /dev/null @@ -1,93 +0,0 @@ -Extension { #name : #RGPackageDefinition } - -{ #category : #'*Calypso-Ring2' } -RGPackageDefinition >> asPackageName [ - - ^ self name -] - -{ #category : #'*Calypso-Ring2' } -RGPackageDefinition >> calypsoEnvironmentType [ - ^RPackage -] - -{ #category : #'*Calypso-Ring2' } -RGPackageDefinition >> classTags [ - - self isRingResolved not ifTrue: [ ^ '' ]. - - ^ self classes collect: [:aClass | (aClass category ifNil: [ '' ]) withoutPrefix: (self name, '-')] as: Set -] - -{ #category : #'*Calypso-Ring2' } -RGPackageDefinition >> classesForClassTag: aTag [ - - ^ self classes select: [ :each | each category = aTag or: [ each category = (self packageName, '-', aTag) ] ] -] - -{ #category : #'*Calypso-Ring2' } -RGPackageDefinition >> extendedClassNames [ - - ^ self extendedClasses collect: #name -] - -{ #category : #'*Calypso-Ring2' } -RGPackageDefinition >> extendsClass: aClass [ - - ^ self extendedClasses includes: aClass. -] - -{ #category : #'*Calypso-Ring2' } -RGPackageDefinition >> extensionSelectorsForClass: aClass [ - - ^ (self extensionMethods select: [ :each | each parent = aClass ]) collect: #name -] - -{ #category : #'*Calypso-Ring2' } -RGPackageDefinition >> importClasses: classCollection [ - classCollection do: [ :each | - each package: self. ] -] - -{ #category : #'*Calypso-Ring2' } -RGPackageDefinition >> includesClassesAffectedBy: aSystemAnnouncement [ - - ^(aSystemAnnouncement affectsClassesDefinedInPackage: self) - or: [ aSystemAnnouncement affectsClassesExtendedInPackage: self ] -] - -{ #category : #'*Calypso-Ring2' } -RGPackageDefinition >> isAboutPackage: aPackage [ - - ^self == aPackage -] - -{ #category : #'*Calypso-Ring2' } -RGPackageDefinition >> isEmpty [ - - ^ self definedClasses isEmpty and: [ self extensionMethods isEmpty ] -] - -{ #category : #'*Calypso-Ring2' } -RGPackageDefinition >> packageManifestOrNil [ - - ^ nil "TODO" -] - -{ #category : #'*Calypso-Ring2' } -RGPackageDefinition >> packageName [ - - ^ self name -] - -{ #category : #'*Calypso-Ring2' } -RGPackageDefinition >> removeFromSystem [ - - self environment removePackage: self. -] - -{ #category : #'*Calypso-Ring2' } -RGPackageDefinition >> renameTo: aString [ - - self name: aString -] diff --git a/src/Calypso-Ring2/RGSlot.extension.st b/src/Calypso-Ring2/RGSlot.extension.st deleted file mode 100644 index 41630697a..000000000 --- a/src/Calypso-Ring2/RGSlot.extension.st +++ /dev/null @@ -1,11 +0,0 @@ -Extension { #name : #RGSlot } - -{ #category : #'*Calypso-Ring2' } -RGSlot >> isReadIn: aCompiledCode [ - ^aCompiledCode readsSlot: self -] - -{ #category : #'*Calypso-Ring2' } -RGSlot >> isWrittenIn: aCompiledCode [ - ^aCompiledCode writesSlot: self -] diff --git a/src/Calypso-Ring2/RGVariable.extension.st b/src/Calypso-Ring2/RGVariable.extension.st deleted file mode 100644 index 522836df9..000000000 --- a/src/Calypso-Ring2/RGVariable.extension.st +++ /dev/null @@ -1,14 +0,0 @@ -Extension { #name : #RGVariable } - -{ #category : #'*Calypso-Ring2' } -RGVariable >> isReadIn: aCompiledCode [ -"TODO" - ^aCompiledCode readsSlot: self -] - -{ #category : #'*Calypso-Ring2' } -RGVariable >> isWrittenIn: aCompiledCode [ - -"TODO" - ^aCompiledCode writesSlot: self -] diff --git a/src/Calypso-Ring2/RGVariableLayout.extension.st b/src/Calypso-Ring2/RGVariableLayout.extension.st deleted file mode 100644 index 484e88a90..000000000 --- a/src/Calypso-Ring2/RGVariableLayout.extension.st +++ /dev/null @@ -1,6 +0,0 @@ -Extension { #name : #RGVariableLayout } - -{ #category : #'*Calypso-Ring2' } -RGVariableLayout >> kindOfSubclassDefinitionString [ - ^ ' variableSubclass: ' -] diff --git a/src/Calypso-Ring2/RGWeakLayout.extension.st b/src/Calypso-Ring2/RGWeakLayout.extension.st deleted file mode 100644 index f0dbc4a9a..000000000 --- a/src/Calypso-Ring2/RGWeakLayout.extension.st +++ /dev/null @@ -1,6 +0,0 @@ -Extension { #name : #RGWeakLayout } - -{ #category : #'*Calypso-Ring2' } -RGWeakLayout >> kindOfSubclassDefinitionString [ - ^ ' weakSubclass: ' -] diff --git a/src/Calypso-Ring2/RGWordLayout.extension.st b/src/Calypso-Ring2/RGWordLayout.extension.st deleted file mode 100644 index 6f0276ade..000000000 --- a/src/Calypso-Ring2/RGWordLayout.extension.st +++ /dev/null @@ -1,8 +0,0 @@ -Extension { #name : #RGWordLayout } - -{ #category : #'*Calypso-Ring2' } -RGWordLayout >> kindOfSubclassDefinitionString [ - ^ ' variableWordSubclass: ' - - -] diff --git a/src/Calypso-Ring2/package.st b/src/Calypso-Ring2/package.st deleted file mode 100644 index ecc72b2b0..000000000 --- a/src/Calypso-Ring2/package.st +++ /dev/null @@ -1 +0,0 @@ -Package { #name : #'Calypso-Ring2' } diff --git a/src/Ring2-ChunkImporter/RGChunkImporter.class.st b/src/Ring2-ChunkImporter/RGChunkImporter.class.st deleted file mode 100644 index 52317ca72..000000000 --- a/src/Ring2-ChunkImporter/RGChunkImporter.class.st +++ /dev/null @@ -1,524 +0,0 @@ -" -I'm an object holding the result of loading a file containing Pharo code definitions in chunk format. -I create Ring definitions for the elements inside the chunk stream. -" -Class { - #name : #RGChunkImporter, - #superclass : #Object, - #instVars : [ - 'environment', - 'package', - 'doIts' - ], - #category : #'Ring2-ChunkImporter' -} - -{ #category : #'instance creation' } -RGChunkImporter class >> fromFileNamed: fileName [ - - ^ self new fromFileNamed: fileName; yourself -] - -{ #category : #'instance creation' } -RGChunkImporter class >> fromStream: aStream [ - - ^ self new fileInFrom: aStream; yourself -] - -{ #category : #accessing } -RGChunkImporter >> allowedSelectors [ - - ^ #( -#ephemeronSubclass:instanceVariableNames:classVariableNames:package: -#ephemeronSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: - -#immediateSubclass:instanceVariableNames:classVariableNames:package: -#immediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:package: -#immediateSubclass:uses:instanceVariableNames:classVariableNames:package: -#immediateSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:package: - -#subclass: -#subclass:instanceVariableNames: -#subclass:instanceVariableNames:classVariableNames:category: -#subclass:instanceVariableNames:classVariableNames:package: -#subclass:instanceVariableNames:classVariableNames:poolDictionaries:category: -#subclass:instanceVariableNames:classVariableNames:poolDictionaries:package: - -#subclass:layout:slots:classVariables:category: -#subclass:layout:slots:classVariables:poolDictionaries:category: -#subclass:slots:classVariables:category: -#subclass:slots:classVariables:poolDictionaries:category: -#subclass:uses: -#subclass:uses:instanceVariableNames:classVariableNames:category: -#subclass:uses:instanceVariableNames:classVariableNames:package: -#subclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:category: -#subclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:package: -#subclass:uses:layout:slots:classVariables:category: -#subclass:uses:layout:slots:classVariables:poolDictionaries:category: -#subclass:uses:slots:classVariables:category: -#subclass:uses:slots:classVariables:poolDictionaries:category: - -#variableByteSubclass:instanceVariableNames:classVariableNames:category: -#variableByteSubclass:instanceVariableNames:classVariableNames:package: -#variableByteSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: -#variableByteSubclass:uses:instanceVariableNames:classVariableNames:category: -#variableByteSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:category: - -#variableSubclass:instanceVariableNames:classVariableNames:category: -#variableSubclass:instanceVariableNames:classVariableNames:package: -#variableSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: -#variableSubclass:instanceVariableNames:classVariableNames:poolDictionaries:package: -#variableSubclass:uses:instanceVariableNames:classVariableNames:category: -#variableSubclass:uses:instanceVariableNames:classVariableNames:package: -#variableSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:category: -#variableSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:package: - -#variableWordSubclass:instanceVariableNames:classVariableNames:category: -#variableWordSubclass:instanceVariableNames:classVariableNames:package: -#variableWordSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: -#variableWordSubclass:instanceVariableNames:classVariableNames:poolDictionaries:package: -#variableWordSubclass:uses:instanceVariableNames:classVariableNames:category: -#variableWordSubclass:uses:instanceVariableNames:classVariableNames:package: -#variableWordSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:category: -#variableWordSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:package: - -#weakSubclass:instanceVariableNames:classVariableNames:category: -#weakSubclass:instanceVariableNames:classVariableNames:package: -#weakSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: -#weakSubclass:instanceVariableNames:classVariableNames:poolDictionaries:package: -#weakSubclass:uses:instanceVariableNames:classVariableNames:category: -#weakSubclass:uses:instanceVariableNames:classVariableNames:package: -#weakSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:category: -#weakSubclass:uses:instanceVariableNames:classVariableNames:poolDictionaries:package: - -#named: -#named:uses:category: -#named:uses:package: - -instanceVariableNames: -#uses: -#uses:instanceVariableNames: -) -] - -{ #category : #private } -RGChunkImporter >> classDefinition: aString with: chgRec [ - | tokens theClass superclass | - - tokens := self scannedSource: aString. - - theClass := self classNamed: tokens third. - theClass metaclass makeResolved. - superclass := self classNamed: tokens first. - superclass metaclass makeResolved. - theClass superclass: superclass. - theClass metaclass superclass: superclass metaclass. - - theClass cleanClassVariables. - theClass cleanSharedPools. - - "theClass definitionSource: aString." - - theClass category: tokens last. - - tokens size = 11 - ifTrue:[ - theClass instanceVariables: (tokens fifth findTokens: ' '); - classVariables: (tokens seventh findTokens: ' '); - sharedPools: (tokens ninth findTokens: ' ') ]. - - tokens size = 13 - ifTrue:[ - RGTraitCompositionVisitor new parse: (tokens fifth) for: theClass traitComposition. - theClass - instanceVariables: (tokens seventh findTokens: ' '); - classVariables: (tokens ninth findTokens: ' '); - sharedPools: ((tokens at: 11) findTokens: ' '). ]. -] - -{ #category : #private } -RGChunkImporter >> classNamed: className [ - - | behavior | - behavior := self environment ask behaviorNamed: className. - ^ behavior - ifNotNil: [ behavior ] - ifNil: [ self environment ensureClassNamed: className asSymbol. ] - -] - -{ #category : #accessing } -RGChunkImporter >> classes [ - ^ package classes values -] - -{ #category : #private } -RGChunkImporter >> createBehavior: subclassName superclassName: superclassName instanceVariableNames: instanceVariableNames classVariableNames: classVariableNames categoryName: categoryName packageName: packageName poolDictionariesNames: poolDictionariesNames layoutClass: layoutClass layoutDefinition: layoutDefinition slotsDefinition: slotsDefinition traits: traitsDefinition isTrait: isTrait hasNilSuperclass: hasNilSuperclass [ - - | behavior superclass | - - self assert: subclassName notNil. - - isTrait - ifTrue: [ - superclass := nil. - behavior := (subclassName endsWith: ' classTrait') - ifTrue: [ - self environment ensureMetaclassTraitNamed: subclassName ] - ifFalse: [ - self assert: (superclassName = #Trait). - self environment ensureTraitNamed: subclassName ]] - ifFalse: [ - behavior := self environment ensureClassNamed: subclassName. - hasNilSuperclass - ifTrue: [ behavior superclass: nil. ] - ifFalse: [ - superclassName ifNotNil: [ - | theSuperclass | - theSuperclass := self environment ensureClassNamed: superclassName. - behavior superclass: theSuperclass ] ] ]. - - isTrait ifFalse: [ - layoutClass ifNotNil: [ - behavior layout: (layoutClass parent: behavior). - "TODO: unknown layout definition"]]. - - slotsDefinition ifNotNil: [ - behavior layout: (layoutClass parent: behavior). - slotsDefinition children do: [:child | - | newSlot | - newSlot := (child isLiteralNode and: [ child value isSymbol ]) - ifTrue: [ RGInstanceVariableSlot named: child value parent: behavior layout ] - ifFalse: [ - "TODO: probably needs more robust analysis" - self assert: child isMessage. - (RGUnknownSlot named: (self slotNameFor: child) parent: behavior layout) - expression: child formattedCode; - yourself]. - behavior layout addSlot: newSlot] .]. - - "process instance variables after layout and slots" - instanceVariableNames ifNotNil: [ - behavior instanceVariables: (instanceVariableNames substrings collect: #asSymbol)]. - - classVariableNames ifNotNil: [ - behavior classVariables: (classVariableNames substrings collect: #asSymbol) ]. - - poolDictionariesNames ifNotNil: [ - behavior sharedPools: (poolDictionariesNames substrings collect: #asSymbol)]. - - categoryName ifNotNil: [ - behavior category: categoryName ]. - - packageName ifNotNil: [ - | pkg | - pkg := environment ensurePackageNamed: packageName. - behavior package: pkg ]. - - traitsDefinition ifNotNil: [ - | composition transformations | - composition := RGTraitComposition parent: behavior. - transformations := RGTraitCompositionVisitor new parse: traitsDefinition for: composition. - behavior traitComposition: composition. - transformations do: [ :each | - composition addTransformation: each ]. - ]. - -] - -{ #category : #private } -RGChunkImporter >> createTraitNamed: traitName [ - - | trait | - trait := RGTraitDefinition named: traitName. - trait withMetaclass. - package addTrait: trait. - ^ trait. -] - -{ #category : #accessing } -RGChunkImporter >> doIts [ - ^ doIts -] - -{ #category : #accessing } -RGChunkImporter >> environment [ - - ^ environment -] - -{ #category : #accessing } -RGChunkImporter >> environment: anRGEnvironment [ - - environment := anRGEnvironment -] - -{ #category : #reading } -RGChunkImporter >> fileInFrom: aStream [ - - | changes | - changes := (CodeImporter readStream: aStream) parseChunks. - changes do: [ :change | change accept: self ]. -] - -{ #category : #reading } -RGChunkImporter >> fromFileNamed: aName [ - - package := RGPackage named: aName. - self fileInFrom: aName asFileReference readStream. -] - -{ #category : #private } -RGChunkImporter >> if: selectorParts in: ast includes: aSymbol do: aBlock [ - - | index | - - index := selectorParts indexOf: aSymbol ifAbsent: [^ self]. - aBlock value: (ast arguments at: index). -] - -{ #category : #initialize } -RGChunkImporter >> initialize [ - super initialize. - environment := RGEnvironment new. - package := RGPackage named: 'ChangeSet'. - doIts := Set new. -] - -{ #category : #visitor } -RGChunkImporter >> isNilSuperclassDefinition: ast [ - - ^ (ast isSequence) - and: [(ast statements size = 2) - and: [(ast statements allSatisfy: #isMessage) - and: [(self allowedSelectors includes: ast statements first selector) - and: [(ast statements second selector = #superclass:) - and: [(ast statements second arguments first value isNil) - and: [((ast statements first arguments first value withoutPrefix: '#') = ast statements second receiver formattedCode)]]]]]] - -] - -{ #category : #private } -RGChunkImporter >> metaClassDefinition: string with: chgRec [ - | tokens theClass | - - tokens := self scannedSource: string. - - theClass := self classNamed: tokens first. - theClass theMetaClass instanceVariables: (tokens fourth findTokens: ' ') -] - -{ #category : #private } -RGChunkImporter >> metaTraitDefinition: string with: chgRec [ - | tokens trait | - - tokens := self scannedSource: string. - trait := environment ensureTraitNamed: tokens first. - -" trait theMetaClass definitionSource: string" -] - -{ #category : #private } -RGChunkImporter >> msgClassComment: string with: chgRec [ - - | tokens theClass | - tokens := self scannedSource: string. - - (tokens size >= 3 - and:[ tokens last isString ]) - ifTrue:[ - theClass := self classNamed: tokens first. - ((tokens at: (tokens size - 1)) == #class - ifTrue: [ theClass theMetaClass ] - ifFalse:[ theClass ]) comment: tokens last asString ] -] - -{ #category : #accessing } -RGChunkImporter >> packages [ - - ^ { package } -] - -{ #category : #private } -RGChunkImporter >> scannedSource: aString [ - - ^ Smalltalk compiler parseLiterals: aString -] - -{ #category : #private } -RGChunkImporter >> slotNameFor: definitionAST [ - - ^ (definitionAST respondsTo: #receiver) - ifTrue: [ self slotNameFor: definitionAST receiver ] - ifFalse: [ definitionAST value ] -] - -{ #category : #private } -RGChunkImporter >> traitDefinition: aString with: chgRec [ - - | tokens trait | - tokens := self scannedSource: aString. - trait := environment ensureTraitNamed: tokens third. - "trait superclassName: tokens first; - definitionSource: aString;" - trait category: tokens last -] - -{ #category : #visitor } -RGChunkImporter >> visitClassCommentChunk: aChunk [ - - | class comment | - - class := self classNamed: aChunk behaviorName. - comment := RGComment parent: class. - comment content: aChunk contents. - comment author: (RGStampParser authorForStamp: aChunk stamp). - comment time: (RGStampParser timeForStamp: aChunk stamp). - class comment: comment. - -] - -{ #category : #visitor } -RGChunkImporter >> visitClassOrganizationChunk: aChunk [ - - "Do nothing with class organizations for the moment" -] - -{ #category : #visitor } -RGChunkImporter >> visitDoItChunk: aChunk [ - - | contents ast layoutClass selectorParts superclassName subclassName instanceVariableNames classVariableNames categoryName packageName poolDictionariesNames layoutDefinition slotsDefinition traitsDefinition isTrait hasNilSuperclass | - - contents := aChunk contents trimBoth. - (contents endsWith: '!') ifTrue: [ contents := contents allButLast ]. - - ast := RBParser parseExpression: contents onError: [ - doIts add: aChunk. - ^ self ]. - - layoutClass := selectorParts := superclassName := subclassName := instanceVariableNames := - classVariableNames := categoryName := packageName := poolDictionariesNames := layoutDefinition := - slotsDefinition := traitsDefinition := nil. - - isTrait := false. - - hasNilSuperclass := self isNilSuperclassDefinition: ast. - hasNilSuperclass - ifTrue: [ ast := ast statements first ]. - - (ast isMessage and: [self allowedSelectors includes: ast selector]) ifTrue: [ - superclassName := ast receiver formattedCode. - self assert: ast arguments isNotEmpty. - selectorParts := ast selector findBetweenSubstrings: {$:}. - - (superclassName endsWith: ' classTrait') - ifTrue: [isTrait := true]. "for usage of #uses:" - - "TODO: handle removeSelector:, comment:" - - self if: selectorParts in: ast includes: #subclass do: [:argument | - subclassName := argument value. - layoutClass := RGFixedLayout. ]. - - self if: selectorParts in: ast includes: #named do: [:argument | - subclassName := argument value. - isTrait := true. - layoutClass := RGFixedLayout. ]. - - self if: selectorParts in: ast includes: #immediateSubclass do: [:argument | - subclassName := argument value. - layoutClass := RGImmediateLayout ]. - - self if: selectorParts in: ast includes: #variableSubclass do: [:argument | - subclassName := argument value. - layoutClass := RGVariableLayout ]. - - self if: selectorParts in: ast includes: #variableByteSubclass do: [:argument | - subclassName := argument value. - layoutClass := RGByteLayout ]. - - self if: selectorParts in: ast includes: #variableWordSubclass do: [:argument | - subclassName := argument value. - layoutClass := RGWordLayout ]. - - self if: selectorParts in: ast includes: #weakSubclass do: [:argument | - subclassName := argument value. - layoutClass := RGWeakLayout ]. - - self if: selectorParts in: ast includes: #ephemeronSubclass do: [:argument | - subclassName := argument value. - layoutClass := RGEphemeronLayout ]. - - self if: selectorParts in: ast includes: #instanceVariableNames do: [:argument | - instanceVariableNames := argument value. ]. - - self if: selectorParts in: ast includes: #classVariableNames do: [:argument | - classVariableNames := argument value. ]. - - self if: selectorParts in: ast includes: #category do: [:argument | - categoryName := argument value. ]. - - self if: selectorParts in: ast includes: #package do: [:argument | - packageName := argument value. ]. - - self if: selectorParts in: ast includes: #poolDictionaries do: [:argument | - poolDictionariesNames := argument value. ]. - - self if: selectorParts in: ast includes: #layout do: [:argument | - layoutDefinition := argument formattedCode. ]. - - self if: selectorParts in: ast includes: #slots do: [:argument | - slotsDefinition := argument "use AST directly". ]. - - self if: selectorParts in: ast includes: #uses do: [:argument | - traitsDefinition := argument formattedCode. ]. - - hasNilSuperclass ifTrue: [superclassName := nil]. - - (#(#instanceVariableNames: uses: uses:instanceVariableNames:) includes: ast selector) ifTrue: [ subclassName := ast receiver formattedCode asSymbol. - superclassName := nil ]. - - (#(CompiledBlock CompiledCode CompiledMethod) includes: subclassName) ifTrue: [ - layoutClass := RGCompiledMethodLayout ]. - - ^ self createBehavior: subclassName - superclassName: superclassName - instanceVariableNames: instanceVariableNames - classVariableNames: classVariableNames - categoryName: categoryName - packageName: packageName - poolDictionariesNames: poolDictionariesNames - layoutClass: layoutClass - layoutDefinition: layoutDefinition - slotsDefinition: slotsDefinition - traits: traitsDefinition - isTrait: isTrait - hasNilSuperclass: hasNilSuperclass. - ]. - - doIts add: aChunk. -] - -{ #category : #visitor } -RGChunkImporter >> visitMethodChunk: aChunk [ - - | theClass theMethod theProtocol | - - theClass := self classNamed: aChunk behaviorName. - aChunk isMeta ifTrue: [ - theClass := theClass theMetaClass makeResolved]. - - theMethod := theClass ensureLocalMethodNamed: aChunk methodSelector asSymbol. - theProtocol := theClass ensureProtocolNamed: aChunk category asSymbol. - theMethod protocol: theProtocol. - theMethod sourceCode: aChunk contents. - theMethod author: (RGStampParser authorForStamp: aChunk stamp). - theMethod time: (RGStampParser timeForStamp: aChunk stamp). - -] - -{ #category : #visitor } -RGChunkImporter >> visitStyleChunk: aChunk [ - - "Do nothing with styles" -] diff --git a/src/Ring2-ChunkImporter/package.st b/src/Ring2-ChunkImporter/package.st deleted file mode 100644 index f2a67bc60..000000000 --- a/src/Ring2-ChunkImporter/package.st +++ /dev/null @@ -1 +0,0 @@ -Package { #name : #'Ring2-ChunkImporter' } diff --git a/src/Ring2-Core/AbstractLayout.extension.st b/src/Ring2-Core/AbstractLayout.extension.st deleted file mode 100644 index d9e0e8b65..000000000 --- a/src/Ring2-Core/AbstractLayout.extension.st +++ /dev/null @@ -1,7 +0,0 @@ -Extension { #name : #AbstractLayout } - -{ #category : #'*Ring2-Core' } -AbstractLayout >> asRingMinimalDefinitionIn: anRGEnvironment [ - - self subclassResponsibility -] diff --git a/src/Ring2-Core/BitsLayout.extension.st b/src/Ring2-Core/BitsLayout.extension.st deleted file mode 100644 index 6ed33d42c..000000000 --- a/src/Ring2-Core/BitsLayout.extension.st +++ /dev/null @@ -1,7 +0,0 @@ -Extension { #name : #BitsLayout } - -{ #category : #'*Ring2-Core' } -BitsLayout >> asRingMinimalDefinitionIn: anRGEnvironment [ - - self subclassResponsibility -] diff --git a/src/Ring2-Core/ByteLayout.extension.st b/src/Ring2-Core/ByteLayout.extension.st deleted file mode 100644 index 75149d263..000000000 --- a/src/Ring2-Core/ByteLayout.extension.st +++ /dev/null @@ -1,9 +0,0 @@ -Extension { #name : #ByteLayout } - -{ #category : #'*Ring2-Core' } -ByteLayout >> asRingMinimalDefinitionIn: anRGEnvironment [ - - ^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [ - RGByteLayout parent: (self host asRingMinimalDefinitionIn: anRGEnvironment)] - -] diff --git a/src/Ring2-Core/Class.extension.st b/src/Ring2-Core/Class.extension.st deleted file mode 100644 index 9eda91350..000000000 --- a/src/Ring2-Core/Class.extension.st +++ /dev/null @@ -1,30 +0,0 @@ -Extension { #name : #Class } - -{ #category : #'*Ring2-Core' } -Class >> asRingMinimalCommentDefinitionIn: anRGEnvironment [ - - ^ anRGEnvironment backend definitionFor: ('classComment:', self name) asSymbol ifAbsentRegister: [ - RGComment parent: (self asRingMinimalDefinitionIn: anRGEnvironment). - ]. - -] - -{ #category : #'*Ring2-Core' } -Class >> asRingMinimalDefinitionIn: anRGEnvironment [ - - ^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [ - RGClass named: self name asSymbol parent: anRGEnvironment]. - -] - -{ #category : #'*Ring2-Core' } -Class >> ensureRingDefinitionIn: anRGEnvironment [ - - ^ anRGEnvironment ask behaviors - detect: [:each | each name = self name] - ifNone: [ - | behaviorModel | - behaviorModel := self asRingMinimalDefinitionIn: anRGEnvironment. - anRGEnvironment addBehavior: behaviorModel. - behaviorModel] -] diff --git a/src/Ring2-Core/ClassVariable.extension.st b/src/Ring2-Core/ClassVariable.extension.st deleted file mode 100644 index 62e144f77..000000000 --- a/src/Ring2-Core/ClassVariable.extension.st +++ /dev/null @@ -1,11 +0,0 @@ -Extension { #name : #ClassVariable } - -{ #category : #'*Ring2-Core' } -ClassVariable >> asRingMinimalDefinitionIn: anRGEnvironment [ - - ^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [ - | def realClass | - realClass := Smalltalk allClasses detect: [ :each | each classVariables includes: self ]. - def := RGClassVariable named: self key asSymbol parent: (realClass asRingMinimalDefinitionIn: anRGEnvironment). - def ]. -] diff --git a/src/Ring2-Core/CompiledMethod.extension.st b/src/Ring2-Core/CompiledMethod.extension.st deleted file mode 100644 index b7c5ed244..000000000 --- a/src/Ring2-Core/CompiledMethod.extension.st +++ /dev/null @@ -1,25 +0,0 @@ -Extension { #name : #CompiledMethod } - -{ #category : #'*Ring2-Core' } -CompiledMethod >> asRingMinimalDefinitionIn: anRGEnvironment [ - - ^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [ - RGMethod named: self selector asSymbol parent: (self methodClass asRingMinimalDefinitionIn: anRGEnvironment)] - -] - -{ #category : #'*Ring2-Core' } -CompiledMethod >> ensureRingDefinitionIn: anRGEnvironment [ - - | parentModel | - - parentModel := (self methodClass ensureRingDefinitionIn: anRGEnvironment). - - ^ parentModel methods - detect: [:each | each selector = self selector] - ifNone: [ - | methodModel | - methodModel := self asRingMinimalDefinitionIn: anRGEnvironment. - parentModel addLocalMethod: methodModel. - methodModel ] -] diff --git a/src/Ring2-Core/CompiledMethodLayout.extension.st b/src/Ring2-Core/CompiledMethodLayout.extension.st deleted file mode 100644 index 969779426..000000000 --- a/src/Ring2-Core/CompiledMethodLayout.extension.st +++ /dev/null @@ -1,9 +0,0 @@ -Extension { #name : #CompiledMethodLayout } - -{ #category : #'*Ring2-Core' } -CompiledMethodLayout >> asRingMinimalDefinitionIn: anRGEnvironment [ - - ^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [ - RGCompiledMethodLayout parent: (self host asRingMinimalDefinitionIn: anRGEnvironment)] - -] diff --git a/src/Ring2-Core/EmptyLayout.extension.st b/src/Ring2-Core/EmptyLayout.extension.st deleted file mode 100644 index d9a738890..000000000 --- a/src/Ring2-Core/EmptyLayout.extension.st +++ /dev/null @@ -1,15 +0,0 @@ -Extension { #name : #EmptyLayout } - -{ #category : #'*Ring2-Core' } -EmptyLayout >> asRingMinimalDefinitionIn: anRGEnvironment [ - - | aHost | - - aHost := self host - ifNotNil: [ :foundHost | foundHost asRingMinimalDefinitionIn: anRGEnvironment ] - ifNil: [ self error: 'Cannot create model for an empty layout without a host']. - - ^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [ - RGEmptyLayout parent: aHost] - -] diff --git a/src/Ring2-Core/EphemeronLayout.extension.st b/src/Ring2-Core/EphemeronLayout.extension.st deleted file mode 100644 index d0e361ee3..000000000 --- a/src/Ring2-Core/EphemeronLayout.extension.st +++ /dev/null @@ -1,9 +0,0 @@ -Extension { #name : #EphemeronLayout } - -{ #category : #'*Ring2-Core' } -EphemeronLayout >> asRingMinimalDefinitionIn: anRGEnvironment [ - - ^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [ - RGEphemeronLayout parent: (self host asRingMinimalDefinitionIn: anRGEnvironment)] - -] diff --git a/src/Ring2-Core/FixedLayout.extension.st b/src/Ring2-Core/FixedLayout.extension.st deleted file mode 100644 index a5edb762c..000000000 --- a/src/Ring2-Core/FixedLayout.extension.st +++ /dev/null @@ -1,9 +0,0 @@ -Extension { #name : #FixedLayout } - -{ #category : #'*Ring2-Core' } -FixedLayout >> asRingMinimalDefinitionIn: anRGEnvironment [ - - ^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [ - RGFixedLayout parent: (self host asRingMinimalDefinitionIn: anRGEnvironment)] - -] diff --git a/src/Ring2-Core/GlobalVariable.extension.st b/src/Ring2-Core/GlobalVariable.extension.st deleted file mode 100644 index 8c7bb78b4..000000000 --- a/src/Ring2-Core/GlobalVariable.extension.st +++ /dev/null @@ -1,8 +0,0 @@ -Extension { #name : #GlobalVariable } - -{ #category : #'*Ring2-Core' } -GlobalVariable >> asRingMinimalDefinitionIn: anRGEnvironment [ - - ^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [ - RGGlobalVariable named: self key asSymbol parent: anRGEnvironment]. -] diff --git a/src/Ring2-Core/ImmediateLayout.extension.st b/src/Ring2-Core/ImmediateLayout.extension.st deleted file mode 100644 index edb782a1d..000000000 --- a/src/Ring2-Core/ImmediateLayout.extension.st +++ /dev/null @@ -1,9 +0,0 @@ -Extension { #name : #ImmediateLayout } - -{ #category : #'*Ring2-Core' } -ImmediateLayout >> asRingMinimalDefinitionIn: anRGEnvironment [ - - ^ anRGEnvironment backend definitionFor: self ifAbsentRegister: [ - RGImmediateLayout parent: (self host asRingMinimalDefinitionIn: anRGEnvironment)] - -] diff --git a/src/Ring2-Core/IndexedSlot.extension.st b/src/Ring2-Core/IndexedSlot.extension.st deleted file mode 100644 index ccf54d7b6..000000000 --- a/src/Ring2-Core/IndexedSlot.extension.st +++ /dev/null @@ -1,10 +0,0 @@ -Extension { #name : #IndexedSlot } - -{ #category : #'*Ring2-Core' } -IndexedSlot >> asRingMinimalDefinitionIn: anRGEnvironment [ - - ^ self class == IndexedSlot - ifTrue: [ anRGEnvironment backend definitionFor: self ifAbsentRegister: [ - RGIndexedSlot named: self name asSymbol parent: (self definingClass classLayout asRingMinimalDefinitionIn: anRGEnvironment)]] - ifFalse: [ super asRingMinimalDefinitionIn: anRGEnvironment ] -] diff --git a/src/Ring2-Core/InstanceVariableSlot.extension.st b/src/Ring2-Core/InstanceVariableSlot.extension.st deleted file mode 100644 index 41e5146fb..000000000 --- a/src/Ring2-Core/InstanceVariableSlot.extension.st +++ /dev/null @@ -1,16 +0,0 @@ -Extension { #name : #InstanceVariableSlot } - -{ #category : #'*Ring2-Core' } -InstanceVariableSlot >> asRingMinimalDefinitionIn: anRGEnvironment [ - - ^ self class == InstanceVariableSlot - ifTrue: [ - anRGEnvironment backend definitionFor: self ifAbsentRegister: [ - RGInstanceVariableSlot - named: self name asSymbol - parent: - (self definingClass classLayout asRingMinimalDefinitionIn: anRGEnvironment)]] - ifFalse: [ super asRingMinimalDefinitionIn: anRGEnvironment ] - - -] diff --git a/src/Ring2-Core/Metaclass.extension.st b/src/Ring2-Core/Metaclass.extension.st deleted file mode 100644 index 31ec8bb7f..000000000 --- a/src/Ring2-Core/Metaclass.extension.st +++ /dev/null @@ -1,8 +0,0 @@ -Extension { #name : #Metaclass } - -{ #category : #'*Ring2-Core' } -Metaclass >> asRingMinimalDefinitionIn: anRGEnvironment [ - - ^ RGMetaclass named: self name parent: anRGEnvironment. - -] diff --git a/src/Ring2-Core/Object.extension.st b/src/Ring2-Core/Object.extension.st deleted file mode 100644 index c5214bfb0..000000000 --- a/src/Ring2-Core/Object.extension.st +++ /dev/null @@ -1,43 +0,0 @@ -Extension { #name : #Object } - -{ #category : #'*Ring2-Core' } -Object >> isRGObject [ - - ^ false -] - -{ #category : #'*Ring2-Core' } -Object >> isRGUnresolvedValue [ - - ^ false -] - -{ #category : #'*Ring2-Core' } -Object >> isRingFullyResolved [ - - ^ true -] - -{ #category : #'*Ring2-Core' } -Object >> isRingFullyUnresolved [ - - ^ false -] - -{ #category : #'*Ring2-Core' } -Object >> isRingResolved [ - - ^ true -] - -{ #category : #'*Ring2-Core' } -Object >> markAsRingResolved [ - - "do nothing" -] - -{ #category : #'*Ring2-Core' } -Object >> orDefaultForUnresolved [ - - ^ self -] diff --git a/src/Ring2-Core/ObjectLayout.extension.st b/src/Ring2-Core/ObjectLayout.extension.st deleted file mode 100644 index 40bfb8999..000000000 --- a/src/Ring2-Core/ObjectLayout.extension.st +++ /dev/null @@ -1,8 +0,0 @@ -Extension { #name : #ObjectLayout } - -{ #category : #'*Ring2-Core' } -ObjectLayout >> asRingMinimalDefinitionIn: anRGEnvironment [ - - self subclassResponsibility - -] diff --git a/src/Ring2-Core/PointerLayout.extension.st b/src/Ring2-Core/PointerLayout.extension.st deleted file mode 100644 index 4c6abf806..000000000 --- a/src/Ring2-Core/PointerLayout.extension.st +++ /dev/null @@ -1,7 +0,0 @@ -Extension { #name : #PointerLayout } - -{ #category : #'*Ring2-Core' } -PointerLayout >> asRingMinimalDefinitionIn: anRGEnvironment [ - - self subclassResponsibility -] diff --git a/src/Ring2-Core/Protocol.extension.st b/src/Ring2-Core/Protocol.extension.st deleted file mode 100644 index 95373cee6..000000000 --- a/src/Ring2-Core/Protocol.extension.st +++ /dev/null @@ -1,10 +0,0 @@ -Extension { #name : #Protocol } - -{ #category : #'*Ring2-Core' } -Protocol >> asRingMinimalDefinitionIn: anRGEnvironment [ - - self error: 'For Protocol you need to use #asRingMinimalDefinitionIn:parent: because parent class cannot be resolved automatically' - - - -] diff --git a/src/Ring2-Core/RGBadInstantiationError.class.st b/src/Ring2-Core/RGBadInstantiationError.class.st deleted file mode 100644 index d04abadf2..000000000 --- a/src/Ring2-Core/RGBadInstantiationError.class.st +++ /dev/null @@ -1,8 +0,0 @@ -" -I'm a specialized error exception used for cases where you want to work directly with instances of RGBehavior without assigned behavior strategy -" -Class { - #name : #RGBadInstantiationError, - #superclass : #Error, - #category : #'Ring2-Core-Kernel' -} diff --git a/src/Ring2-Core/RGBehavior.class.st b/src/Ring2-Core/RGBehavior.class.st deleted file mode 100644 index be80bc730..000000000 --- a/src/Ring2-Core/RGBehavior.class.st +++ /dev/null @@ -1,1205 +0,0 @@ -" -An RGBehavior is an abstract definition for class-alike entities (e.g. classes, traits) - -Instance Variables - methods: - protocols: - superclass: -" -Class { - #name : #RGBehavior, - #superclass : #RGBehaviorStrategyUser, - #instVars : [ - 'superclass', - 'localMethods', - 'traitComposition', - 'metaclass', - 'tagsForMethods', - 'tags' - ], - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'as yet unclassified' } -RGBehavior class >> badInstantiationError [ - - RGBadInstantiationError signal: 'I cannot be instantiated this way because every RGBehavior must know its proper behavior strategy. Please use a subclass of RGBehaviorFactory or my methods like #newClass' -] - -{ #category : #'as yet unclassified' } -RGBehavior class >> named: aString [ - - ^ self badInstantiationError -] - -{ #category : #'as yet unclassified' } -RGBehavior class >> named: aName behaviorStrategy: anRGBehaviorStrategy [ - - | aBehavior | - - aBehavior := self basicNew - behaviorStrategy: anRGBehaviorStrategy; - initialize. - anRGBehaviorStrategy initialize. - ^ aBehavior - pvtName: aName asSymbol; - yourself - -] - -{ #category : #'as yet unclassified' } -RGBehavior class >> named: aString parent: anRGObject [ - - ^ self badInstantiationError -] - -{ #category : #'as yet unclassified' } -RGBehavior class >> named: aName parent: anRGObject behaviorStrategy: anRGBehaviorStrategy [ - - | aBehavior | - - aBehavior := self basicNew - behaviorStrategy: anRGBehaviorStrategy; - parent: anRGObject; - initialize. - anRGBehaviorStrategy initialize. - ^ aBehavior - pvtName: aName asSymbol; - yourself - -] - -{ #category : #'instance creation' } -RGBehavior class >> newClass [ - - ^ self unnamedWithBehaviorStrategy: RGClassStrategy basicNew -] - -{ #category : #'instance creation' } -RGBehavior class >> newMetaclass [ - - ^ self unnamedWithBehaviorStrategy: RGMetaclassStrategy basicNew -] - -{ #category : #'instance creation' } -RGBehavior class >> newMetaclassTrait [ - - ^ self unnamedWithBehaviorStrategy: RGMetaclassTrait newStrategy -] - -{ #category : #'instance creation' } -RGBehavior class >> newTrait [ - - ^ self unnamedWithBehaviorStrategy: RGTrait newStrategy -] - -{ #category : #'as yet unclassified' } -RGBehavior class >> parent: anRGObject behaviorStrategy: anRGBehaviorStrategy [ - - | aBehavior | - - aBehavior := self basicNew - behaviorStrategy: anRGBehaviorStrategy; - parent: anRGObject; - initialize. - anRGBehaviorStrategy initialize. - ^ aBehavior - -] - -{ #category : #'as yet unclassified' } -RGBehavior class >> unnamedWithBehaviorStrategy: anRGBehaviorStrategy [ - - | aBehavior | - - aBehavior := self basicNew - behaviorStrategy: anRGBehaviorStrategy; - initialize. - anRGBehaviorStrategy initialize. - ^ aBehavior - -] - -{ #category : #'as yet unclassified' } -RGBehavior class >> unresolvedNamed: aName withParent: anRGObject behaviorStrategy: anRGBehaviorStrategy [ - - | aBehavior | - - aBehavior := self basicNew - behaviorStrategy: anRGBehaviorStrategy; - parent: anRGObject; - initializeUnresolved. - anRGBehaviorStrategy initializeUnresolved. - ^ aBehavior - pvtName: aName asSymbol; - yourself - -] - -{ #category : #'as yet unclassified' } -RGBehavior class >> unresolvedWithBehaviorStrategy: anRGBehaviorStrategy [ - - | aBehavior | - - aBehavior := self basicNew - behaviorStrategy: anRGBehaviorStrategy; - initializeUnresolved. - anRGBehaviorStrategy initializeUnresolved. - ^ aBehavior - -] - -{ #category : #'as yet unclassified' } -RGBehavior class >> unresolvedWithParent: anRGObject behaviorStrategy: anRGBehaviorStrategy [ - - | aBehavior | - - aBehavior := self basicNew - behaviorStrategy: anRGBehaviorStrategy; - parent: anRGObject; - initializeUnresolved. - anRGBehaviorStrategy initializeUnresolved. - ^ aBehavior - -] - -{ #category : #'accessing - backend' } -RGBehavior >> addLocalMethod: anRGMethod [ - - self backend forBehavior addLocalMethod: anRGMethod to: self. - - self announcer methodAdded: anRGMethod. - -] - -{ #category : #'accessing - backend' } -RGBehavior >> addMethodTag: aSymbol [ - - self announceDefinitionChangeDuring: [ - self backend forBehavior addMethodTag: aSymbol to: self. ]. -] - -{ #category : #'accessing - backend' } -RGBehavior >> addProtocol: aSymbol [ - - self addMethodTag: aSymbol - -] - -{ #category : #'managing container' } -RGBehavior >> addoptToParentStub [ - - self isRingResolved ifFalse: [ ^ self ]. - - super addoptToParentStub. - - self parent pvtAddBehavior: self. - - - -] - -{ #category : #'queries - other' } -RGBehavior >> allInstVarNames [ - "Answer an Array of the names of the receiver's instance variables. The - Array ordering is the order in which the variables are stored and - accessed by the interpreter." - - | vars | - (self superclass == self or: [ self superclass isNil ]) - ifTrue: [vars := self instVarNames copy] "Guarantee a copy is answered." - ifFalse: [vars := self superclass allInstVarNames , self instVarNames]. - ^vars -] - -{ #category : #announcements } -RGBehavior >> announceDefinitionChangeDuring: aBlock [ - - | oldVersion | - - self announcer isSuspended ifTrue: [ - aBlock value. - ^ self ] . - - self announcer suspendAllWhile: [ - oldVersion := self copyForBehaviorDefinition.]. - aBlock value. - self announcer behaviorDefinitionChangedFrom: oldVersion to: self. - self announcer behaviorModificationAppliedTo: self. - - - -] - -{ #category : #asYetUnclassified } -RGBehavior >> asYetUnclassifiedProtocolName [ - - ^ 'as yet unclassified' asSymbol -] - -{ #category : #testing } -RGBehavior >> canMergeWith: anRGObject visited: visitedDefinitions [ - - | newVisited | - - (visitedDefinitions includes: self) ifTrue: [ ^ true ]. - - (self isRingFullyResolved or: [ anRGObject isRingFullyResolved]) ifTrue: [^ true]. - - (super canMergeWith: anRGObject visited: visitedDefinitions) ifFalse: [ ^ false ]. - - newVisited := visitedDefinitions copyWith: self. - - self superclass ~~ self ifTrue: [ - (self superclass canMergeWith: anRGObject superclass visited: newVisited) ifFalse: [ ^ false ]]. - - self metaclass ~~ self ifTrue: [ - (self metaclass canMergeWith: anRGObject metaclass visited: newVisited) ifFalse: [ ^ false ]]. - - ^ true. -] - -{ #category : #'accessing - definition' } -RGBehavior >> classVariablesBindings [ - - ^ self propertyNamed: #classVariablesBindings ifAbsentPut: [ IdentityDictionary new.] -] - -{ #category : #'accessing - definition' } -RGBehavior >> classVariablesString [ - "Answer a string of my class variable names separated by spaces." - - ^ self behaviorStrategy classVariablesString -] - -{ #category : #'accessing - backend' } -RGBehavior >> cleanLocalMethods [ - - | oldMethods | - - oldMethods := self localMethods. - - self backend forBehavior cleanLocalMethodsFor: self. - - self cleanProtocols. - - oldMethods do: [ :each | - self announcer methodRemoved: each ] - -] - -{ #category : #'accessing - backend' } -RGBehavior >> cleanProtocols [ - - self cleanTagsForMethods -] - -{ #category : #'accessing - backend' } -RGBehavior >> cleanTags [ - - self announceDefinitionChangeDuring: [ - self cleanTagsWithoutAnnouncemnt ]. -] - -{ #category : #'accessing - backend' } -RGBehavior >> cleanTagsForMethods [ - - self backend forPackage cleanTagsForMethodsFor: self -] - -{ #category : #'accessing - backend' } -RGBehavior >> cleanTagsWithoutAnnouncemnt [ - - self backend forBehavior cleanClassTagsFor: self. -] - -{ #category : #accessing } -RGBehavior >> compiler [ - - ^ self class compiler -] - -{ #category : #conversion } -RGBehavior >> convertToMetaclassTrait [ - - | metaclassTraitStrategy originalName | - - (self resolvedProperties includesAnyOf: #(traitComposition)) - ifTrue: [self error: 'This class cannot be converted to trait']. - - "TODO: check empty layout" -" newMetaclassTrait := RGMetaclassTrait unresolvedWithParent: self parent. - newMetaclassTrait copyPropertiesFrom: self. -" - metaclassTraitStrategy := RGMetaclassTrait newStrategyFor: self environment. - metaclassTraitStrategy owner: self. - metaclassTraitStrategy pvtBaseTrait: self behaviorStrategy pvtBaseClass. - - self behaviorStrategy: metaclassTraitStrategy. - - originalName := self name. - - (self hasResolvedName) - ifTrue: [ self pvtName: ((self name withoutSuffix: ' class'), ' classTrait') asSymbol ]. - - self environment ask replaceName: originalName with: self name. - - - - -] - -{ #category : #conversion } -RGBehavior >> convertToTrait [ - - | traitStrategy originalName | - - (self resolvedProperties includesAnyOf: #("superclass" traitComposition classVariables sharedPools)) - ifTrue: [self error: 'This class cannot be converted to trait']. - - "TODO: check empty layout" - "newTrait := RGTrait unresolvedWithParent: self parent. - newTrait copyPropertiesFrom: self. - newTrait pvtName: name. - newTrait pvtLocalMethods: localMethods. - newTrait pvtTags: tags. - - newTrait behaviorStrategy pvtComment: self behaviorStrategy comment. - newTrait behaviorStrategy pvtPackage: self behaviorStrategy package." - - originalName := self name. - - traitStrategy := RGTrait newStrategyFor: self environment. - traitStrategy owner: self. - traitStrategy pvtClassTrait: self pvtMetaclass. - traitStrategy pvtPackage: self behaviorStrategy pvtPackage. - traitStrategy pvtComment: self behaviorStrategy pvtComment. - - self behaviorStrategy: traitStrategy. - - self environment ask replaceName: originalName with: self name. - - -] - -{ #category : #copying } -RGBehavior >> copyForBehaviorDefinitionPostCopy [ - - super copyForBehaviorDefinitionPostCopy. - - superclass := self superclass shallowCopy. "we need the superclass name" - traitComposition := self traitComposition copyForBehaviorDefinition. - tagsForMethods := self tagsForMethods copy asSet. - tags := self tags copy asSet. - - behaviorStrategy := behaviorStrategy copyForBehaviorDefinitionWithOwner: self - -] - -{ #category : #'default model values' } -RGBehavior >> defaultLayout [ - - ^ self defaultFixedLayoutStubIn: self. -] - -{ #category : #'default model values' } -RGBehavior >> defaultLocalMethods [ - - ^ Set new -] - -{ #category : #'managing container' } -RGBehavior >> defaultParentStub [ - - ^ self defaultEnvironmentStub -] - -{ #category : #'default model values' } -RGBehavior >> defaultTags [ - - ^ Set new -] - -{ #category : #'default model values' } -RGBehavior >> defaultTagsForMethods [ - - ^ Set new -] - -{ #category : #'default model values' } -RGBehavior >> defaultTraitComposition [ - - ^ self defaultTraitCompositionStubIn: self. -] - -{ #category : #'accessing - definition' } -RGBehavior >> definitionForNautilus [ - - ^ self definition -] - -{ #category : #'queries - methods' } -RGBehavior >> ensureLocalMethodNamed: aSymbol [ - - ^ self localMethodNamed: aSymbol ifAbsent: [ - | newMethod | - newMethod := RGMethod named: aSymbol asSymbol parent: self. - self addLocalMethod: newMethod. - newMethod]. -] - -{ #category : #'queries - tags' } -RGBehavior >> ensureMethodTagNamed: aSymbol [ - - ^ self tagsForMethods detect: [ :each | each asSymbol = aSymbol ] ifNone: [ - self addMethodTag: aSymbol. - aSymbol ] -] - -{ #category : #'queries - protocols' } -RGBehavior >> ensureProtocolNamed: aSymbol [ - - ^ self ensureMethodTagNamed: aSymbol -] - -{ #category : #'queries - methods' } -RGBehavior >> ensureUnresolvedLocalMethod [ - - | newMethod | - newMethod := RGMethod parent: self. - self addLocalMethod: newMethod. - ^ newMethod -] - -{ #category : #documentation } -RGBehavior >> extensions [ - - ^ self localMethods select: [ :each | each package ~= self package ] -] - -{ #category : #testing } -RGBehavior >> hasComment [ - - ^ self comment isEmptyOrNil not -] - -{ #category : #'queries - testing' } -RGBehavior >> hasMethods [ - "validates the existance of methods" - - ^ self methods notEmpty -] - -{ #category : #testing } -RGBehavior >> hasResolvedSuperclass [ - - ^ self hasResolved: #superclass -] - -{ #category : #'queries - testing' } -RGBehavior >> hasTraitComposition [ - - ^ self traitComposition transformations isEmpty not -] - -{ #category : #'queries - methods' } -RGBehavior >> includesSelector: aString [ - - ^ self selectors includes: aString -] - -{ #category : #'testing class hierarchy' } -RGBehavior >> inheritsFrom: aClass [ - "Answer whether the argument, aClass, is on the receiver's superclass - chain." - - | aSuperclass | - aSuperclass := self superclass. - [aSuperclass == nil] - whileFalse: - [aSuperclass == aClass ifTrue: [^true]. - aSuperclass := aSuperclass superclass]. - ^false -] - -{ #category : #initialization } -RGBehavior >> initialize [ - - super initialize. - - "use unresolved value for superclass to avoid infinite recursion. It needs to be set later" - superclass := RGUnresolvedValue recursive. - metaclass := RGUnresolvedValue recursive. - localMethods := self unresolvedValue: self defaultLocalMethods. - traitComposition := self unresolvedValue: self defaultTraitComposition. - tagsForMethods := self unresolvedValue: self defaultTagsForMethods. - tags := self unresolvedValue: self defaultTags. - -] - -{ #category : #initialization } -RGBehavior >> initializeUnresolved [ - - super initializeUnresolved. - - superclass := self. "will be set later" - metaclass := self. "will be set later" - localMethods := self unresolvedValue: self defaultLocalMethods. - traitComposition := self unresolvedValue: self defaultTraitComposition. - tagsForMethods := self unresolvedValue: self defaultTagsForMethods. - tags := self unresolvedValue: self defaultTags. - -] - -{ #category : #testing } -RGBehavior >> isBehavior [ - - ^ true -] - -{ #category : #'testing - layouts' } -RGBehavior >> isBits [ - - ^ self layout isBitsLayout -] - -{ #category : #'testing - layouts' } -RGBehavior >> isBytes [ - - ^ self layout isByteLayout -] - -{ #category : #'testing - layouts' } -RGBehavior >> isCompiledMethod [ - - ^ self layout isCompiledMethodLayout -] - -{ #category : #'testing - layouts' } -RGBehavior >> isEphemeron [ - - ^ self layout isEphemeronLayout -] - -{ #category : #'testing - layouts' } -RGBehavior >> isEphemeronClass [ - - ^ self layout isEphemeronLayout -] - -{ #category : #'testing - layouts' } -RGBehavior >> isImmediateClass [ - - ^ self layout isImmediateLayout -] - -{ #category : #testing } -RGBehavior >> isPointers [ - - ^ self isBits not -] - -{ #category : #'queries - testing' } -RGBehavior >> isReferencedIn: anRGMethod [ - - ^ (anRGMethod ast variableNodes select: #isGlobal) anySatisfy: [ :each | each name = self name ] -] - -{ #category : #'queries - testing' } -RGBehavior >> isRootInEnvironment [ - - ^ self superclass == self or: [ self superclass isNil ] -] - -{ #category : #testing } -RGBehavior >> isTaggedWith: aSymbol [ - - ^self tags includes: aSymbol -] - -{ #category : #'testing - layouts' } -RGBehavior >> isVariable [ - - "is the definition a variable class?" - - ^ self layout isVariableLayout -] - -{ #category : #testing } -RGBehavior >> isWeak [ - - ^ self layout isWeakLayout -] - -{ #category : #'testing - layouts' } -RGBehavior >> isWords [ - - ^ self layout isWordLayout -] - -{ #category : #'queries - methods' } -RGBehavior >> localMethodNamed: aSymbol ifAbsent: aBlock [ - - self localMethodsDo: [ :each | (each name = aSymbol) ifTrue: [^ each]]. - - ^ aBlock value. -] - -{ #category : #'queries - methods' } -RGBehavior >> localMethods [ - - ^ self localMethodsSet asArray -] - -{ #category : #'accessing - backend' } -RGBehavior >> localMethodsDo: aBlock [ - - self backend forBehavior localMethodsFor: self do: aBlock -] - -{ #category : #'queries - methods' } -RGBehavior >> localMethodsSet [ - - | methods | - - methods := self defaultLocalMethods. - self localMethodsDo: [ :each | methods add: each ]. - ^ methods -] - -{ #category : #'queries - methods' } -RGBehavior >> localSelectors [ - - ^ self localMethods collect: #name -] - -{ #category : #resolving } -RGBehavior >> makeResolved [ - - superclass := self superclass markAsRingResolved. - localMethods := self localMethodsSet markAsRingResolved. - traitComposition := self traitComposition markAsRingResolved. - metaclass := self metaclass markAsRingResolved. - tagsForMethods := self tagsForMethodsSet markAsRingResolved. - tags := self tagsSet markAsRingResolved. - - super makeResolved. -] - -{ #category : #'accessing - backend' } -RGBehavior >> metaclass [ - - ^ self backend forBehavior metaclassFor: self -] - -{ #category : #'accessing - backend' } -RGBehavior >> metaclass: anRGMetaclass [ - - self backend forBehavior setMetaclassFor: self to: anRGMetaclass. - - -] - -{ #category : #'queries - methods' } -RGBehavior >> methodNamed: aSymbol [ - - | allMethods | - allMethods := IdentitySet new. - self methods do: [ :each | each name = aSymbol ifTrue: [^ each]]. - ^ nil -] - -{ #category : #'queries - methods' } -RGBehavior >> methods [ - - | methodsFromTraits methodsDict | - "TODO: make nicer" - "^ self propertyNamed: #methods ifAbsentPut: [ " - methodsFromTraits := self traitComposition methods collect: [ :each | each copy parent: self ]. - methodsDict := Dictionary new. - methodsFromTraits do: [ :each | - methodsDict at: each name put: each ]. - self localMethodsDo: [ :each | - methodsDict at: each name put: each ]. - ^ methodsDict values asArray"]" - -] - -{ #category : #'queries - tags' } -RGBehavior >> methodsTaggedWith: aSymbol [ - - ^ self localMethods select: [ :each | each isTaggedWith: aSymbol ] -] - -{ #category : #'accessing - backend' } -RGBehavior >> name: aString [ - - | oldName subclassesWithOldDefinitions | - - oldName := self name. - - subclassesWithOldDefinitions := (self subclasses reject: #isMeta) collect: [ :each | - each -> each copyForBehaviorDefinition ]. - - self announceDefinitionChangeDuring: [ - super name: aString ]. - - self announcer behaviorRenamed: self from: oldName. - - subclassesWithOldDefinitions do: [ :assoc | - self announcer behaviorDefinitionChangedFrom: assoc value to: assoc key. - self announcer behaviorModificationAppliedTo: assoc key. - self announcer behaviorParentRenamed: assoc key from: oldName ]. -] - -{ #category : #printing } -RGBehavior >> printOn: aStream [ - aStream nextPutAll: self name -] - -{ #category : #'queries - protocols' } -RGBehavior >> protocols [ - - | methodTags | - - methodTags := self tagsForMethods. - ^ methodTags - ifEmpty: [ - self methods - ifEmpty: [ OrderedCollection new ] - ifNotEmpty: [ OrderedCollection with: self class asYetUnclassifiedProtocolName ]. - ] - ifNotEmpty: [ methodTags ] - -] - -{ #category : #'private - backend interface' } -RGBehavior >> pvtAddLocalMethod: anRGMethod [ - - self environment verifyOwnership: anRGMethod. - - localMethods isRingResolved ifFalse: [ - self pvtCleanLocalMethods ]. - - (self hasResolved: #tagsForMethods) - ifFalse: [ self pvtCleanTagsForMethods ]. - - anRGMethod tags do: [ :aTag | - self pvtAddMethodTag: aTag ]. - - localMethods add: anRGMethod. - -] - -{ #category : #'private - backend access' } -RGBehavior >> pvtAddMethodTag: aSymbol [ - - tagsForMethods isRingResolved ifFalse: [ - self pvtCleanTagsForMethods ]. - - tagsForMethods add: aSymbol. - -] - -{ #category : #strategy } -RGBehavior >> pvtAsTrait [ - - | traitStrategy | - - (self resolvedProperties includesAnyOf: #("superclass" traitComposition classVariables sharedPools)) - ifTrue: [self error: 'This class cannot be converted to trait']. - - "TODO: check empty layout" - "newTrait := RGTrait unresolvedWithParent: self parent. - newTrait copyPropertiesFrom: self. - newTrait pvtName: name. - newTrait pvtLocalMethods: localMethods. - newTrait pvtTags: tags. - - newTrait behaviorStrategy pvtComment: self behaviorStrategy comment. - newTrait behaviorStrategy pvtPackage: self behaviorStrategy package." - - traitStrategy := RGTrait newStrategyFor: self environment. - - traitStrategy pvtComment: self behaviorStrategy comment. - traitStrategy pvtPackage: self behaviorStrategy package. - - self behaviorStrategy: traitStrategy. - - ^ self - -] - -{ #category : #'private - backend interface' } -RGBehavior >> pvtCleanLocalMethods [ - - localMethods := self defaultLocalMethods. - -] - -{ #category : #'private - backend access' } -RGBehavior >> pvtCleanTags [ - - tags := self defaultTags. - - "TODO:Announce if not empty" - - -] - -{ #category : #'private - backend access' } -RGBehavior >> pvtCleanTagsForMethods [ - - tagsForMethods := self defaultTagsForMethods. - - "TODO:Announce if not empty" - - -] - -{ #category : #private } -RGBehavior >> pvtLocalMethods: aCollection [ - - "use only for low-level copying" - localMethods := aCollection -] - -{ #category : #'private - backend interface' } -RGBehavior >> pvtLocalMethodsDo: aBlock [ - - ^ localMethods value do: aBlock -] - -{ #category : #'private - backend access' } -RGBehavior >> pvtMetaclass [ - - ^ metaclass value -] - -{ #category : #'private - backend access' } -RGBehavior >> pvtMetaclass: anRGMetaclass [ - - self environment verifyOwnership: anRGMetaclass. - - ^ metaclass := anRGMetaclass -] - -{ #category : #'private - backend interface' } -RGBehavior >> pvtRemoveLocalMethod: anRGMethod [ - - self environment verifyOwnership: anRGMethod. - - localMethods remove: anRGMethod. - - -] - -{ #category : #'private - backend access' } -RGBehavior >> pvtRemoveMethodTag: aSymbol [ - - tagsForMethods remove: aSymbol. - - "TODO:Announce" - - -] - -{ #category : #'private - backend interface' } -RGBehavior >> pvtResolvableProperties [ - - ^ super pvtResolvableProperties, { - #superclass -> superclass. - #localMethods -> localMethods. - #traitComposition -> traitComposition. - #metaclass -> metaclass. - #tagsForMethods -> tagsForMethods. - #tags -> tags. - }, self behaviorStrategy pvtResolvableProperties - - -] - -{ #category : #'private - backend interface' } -RGBehavior >> pvtSuperclass [ - - ^ superclass value - -] - -{ #category : #'private - backend interface' } -RGBehavior >> pvtSuperclass: anRGBehavior [ - - anRGBehavior ifNotNil: [ - self environment verifyOwnership: anRGBehavior.]. - - ^ superclass := anRGBehavior - -] - -{ #category : #'private - backend access' } -RGBehavior >> pvtTagWith: aSymbol [ - - tags isRingResolved ifFalse: [ - self pvtCleanTags ]. - - tags add: aSymbol. - -] - -{ #category : #'private - backend access' } -RGBehavior >> pvtTags: aCollection [ - - ^ tags := aCollection -] - -{ #category : #'private - backend access' } -RGBehavior >> pvtTagsDo: aBlock [ - - ^ tags value do: aBlock -] - -{ #category : #'private - backend access' } -RGBehavior >> pvtTagsForMethodsDo: aBlock [ - - ^ tagsForMethods value do: aBlock -] - -{ #category : #'private - backend interface' } -RGBehavior >> pvtTraitComposition [ - - ^ traitComposition value -] - -{ #category : #'private - backend interface' } -RGBehavior >> pvtTraitComposition: anRGTraitComposition [ - - self environment verifyOwnership: anRGTraitComposition. - - ^ traitComposition := anRGTraitComposition -] - -{ #category : #'private - backend access' } -RGBehavior >> pvtUntagFrom: aSymbol [ - - (tags value includes: aSymbol) - ifTrue: [ tags remove: aSymbol ]. - - "TODO:Announce" - - -] - -{ #category : #'accessing - backend' } -RGBehavior >> removeLocalMethod: anRGMethod [ - - (anRGMethod package = self package) - ifFalse: [ anRGMethod package removeExtensionMethod: anRGMethod ]. - - self backend forBehavior removeLocalMethod: anRGMethod from: self. - - self announcer methodRemoved: anRGMethod. - -] - -{ #category : #'accessing - backend' } -RGBehavior >> removeMethodTag: aSymbol [ - - self backend forPackage removeMethodTag: aSymbol from: self. - - self localMethodsDo: [ :method | - method untagFrom: aSymbol ]. -] - -{ #category : #'accessing - backend' } -RGBehavior >> removeProtocol: aSymbol [ - - self removeMethodTag: aSymbol. -] - -{ #category : #'queries - methods' } -RGBehavior >> selectors [ - - ^ self methods collect: #name -] - -{ #category : #'accessing - definition' } -RGBehavior >> sharedPoolsString [ - "Answer a string of my class variable names separated by spaces." - - "TODO: check validity" - ^String streamContents: [ :stream | - self sharedPools - do: [ :each | stream nextPutAll: each name] - separatedBy: [ stream space ] ] -] - -{ #category : #printing } -RGBehavior >> slotDefinitionString [ - "Answer a string that contains an executable description of my Slots" - - "^self slots ifNotEmpty: [self slots asString] ifEmpty: ['{}']" - - ^String streamContents: [ :str | | special | - str nextPutAll: '{ '. - self slots do: [:slot | - str nextPutAll: slot definitionString. - special := slot isSpecial] - separatedBy: [ - str nextPutAll: '. '. - special ifTrue: [ str cr;tab;tab;tab;tab ]]. - str nextPutAll: ' }'. ] - -] - -{ #category : #slots } -RGBehavior >> slots [ - - ^ self layout slots -] - -{ #category : #'accessing class hierarchy' } -RGBehavior >> subclasses [ - - | result | - result := IdentitySet new. - self environment behaviorsDo: [ :each | - (each superclass == self) ifTrue: [ result add: each] ]. - ^ result asArray -] - -{ #category : #'accessing - backend' } -RGBehavior >> superclass [ - - ^ self backend forBehavior superclassFor: self -] - -{ #category : #'accessing - backend' } -RGBehavior >> superclass: anRGBehavior [ - - self announceDefinitionChangeDuring: [ - self backend forBehavior setSuperclassFor: self to: anRGBehavior ]. -] - -{ #category : #'accessing - backend' } -RGBehavior >> tagWith: aSymbol [ - - self announceDefinitionChangeDuring: [ - self backend forBehavior tagClass: self with: aSymbol. - self package addClassTag: aSymbol. - ]. - -] - -{ #category : #'accessing - model' } -RGBehavior >> tags [ - - ^ self tagsSet asArray - -] - -{ #category : #'accessing - backend' } -RGBehavior >> tagsDo: aBlock [ - - self backend forBehavior tagsForClass: self do: aBlock -] - -{ #category : #'accessing - model' } -RGBehavior >> tagsForMethods [ - "Retrieves the traits defined in the receiver" - - | allTags | - allTags := self defaultTagsForMethods. - self tagsForMethodsDo: [ :each | allTags add: each]. - ^ allTags asArray -] - -{ #category : #'accessing - backend' } -RGBehavior >> tagsForMethodsDo: aBlock [ - - self backend forBehavior tagsForMethodsFor: self do: aBlock -] - -{ #category : #'accessing - model' } -RGBehavior >> tagsForMethodsSet [ - "Retrieves the traits defined in the receiver" - - | allTags | - allTags := self defaultTagsForMethods. - self tagsForMethodsDo: [ :each | allTags add: each]. - ^ allTags -] - -{ #category : #'accessing - model' } -RGBehavior >> tagsSet [ - - | allTags | - allTags := self defaultTags. - self tagsDo: [ :each | allTags add: each]. - ^ allTags - -] - -{ #category : #'accessing - backend' } -RGBehavior >> traitComposition [ - - ^ self backend forBehavior traitCompositionFor: self -] - -{ #category : #'accessing - backend' } -RGBehavior >> traitComposition: anRGTraitComposition [ - - self announceDefinitionChangeDuring: [ - self backend forBehavior setTraitCompositionFor: self to: anRGTraitComposition.]. -] - -{ #category : #'accessing - definition' } -RGBehavior >> traitCompositionString [ - ^ self traitComposition traitCompositionString - -] - -{ #category : #'accessing - backend' } -RGBehavior >> unresolveName [ - - | oldName subclassesWithOldDefinitions | - - oldName := self name. - - subclassesWithOldDefinitions := (self subclasses reject: #isMeta) collect: [ :each | - each -> each copyForBehaviorDefinition ]. - - self announceDefinitionChangeDuring: [ - super unresolveName ]. - - self announcer behaviorRenamed: self from: oldName. - - subclassesWithOldDefinitions do: [ :assoc | - self announcer behaviorDefinitionChangedFrom: assoc value to: assoc key. - self announcer behaviorModificationAppliedTo: assoc key. - self announcer behaviorParentRenamed: assoc key from: oldName ]. -] - -{ #category : #'accessing - backend' } -RGBehavior >> unresolveSuperclass [ - - self announceDefinitionChangeDuring: [ - self pvtSuperclass: (RGUnresolvedValue recursive) ]. -] - -{ #category : #'accessing - backend' } -RGBehavior >> untagFrom: aSymbol [ - - self backend forPackage untagClass: self from: aSymbol -] - -{ #category : #asYetUnclassified } -RGBehavior >> usedTraits [ - - ^ self traitComposition usedTraits -] - -{ #category : #slots } -RGBehavior >> usesSpecialSlot [ - "return true if we define something else than InstanceVariableSlots" - ^self slots anySatisfy: [ :each | each isSpecial ] -] diff --git a/src/Ring2-Core/RGBehaviorFactory.class.st b/src/Ring2-Core/RGBehaviorFactory.class.st deleted file mode 100644 index 8dcc67f61..000000000 --- a/src/Ring2-Core/RGBehaviorFactory.class.st +++ /dev/null @@ -1,69 +0,0 @@ -" -My subclasses are very simple factories that serve as entry point to create different kind of behaviors. There should be no instances of me. - -The behaviors are composition of a RGBehavior instances and a strategy that describes a kind of the behavior. The behavior factory only create sach pairs so for example my subclass RGClass creates a composition of RGBehavior instance with a RGClassStrategy. -" -Class { - #name : #RGBehaviorFactory, - #superclass : #Object, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'instance creation' } -RGBehaviorFactory class >> named: aString [ - - ^ (RGBehavior named: aString behaviorStrategy: self newStrategy) - yourself -] - -{ #category : #'instance creation' } -RGBehaviorFactory class >> named: aString parent: anRGObject [ - - ^ (RGBehavior named: aString parent: anRGObject behaviorStrategy: (self newStrategyFor: anRGObject environment)) - yourself -] - -{ #category : #'instance creation' } -RGBehaviorFactory class >> newStrategy [ - - self subclassResponsibility -] - -{ #category : #'instance creation' } -RGBehaviorFactory class >> newStrategyFor: anRGEnvironment [ - - ^ self newStrategy -] - -{ #category : #'instance creation' } -RGBehaviorFactory class >> parent: anRGObject [ - - ^ (RGBehavior parent: anRGObject behaviorStrategy: (self newStrategyFor: anRGObject environment)) - yourself -] - -{ #category : #'instance creation' } -RGBehaviorFactory class >> unnamed [ - - ^ RGBehavior unnamedWithBehaviorStrategy: self newStrategy - -] - -{ #category : #'instance creation' } -RGBehaviorFactory class >> unresolved [ - - ^ RGBehavior unresolvedWithBehaviorStrategy: self newStrategy - -] - -{ #category : #'instance creation' } -RGBehaviorFactory class >> unresolvedNamed: aString withParent: anRGDefintion [ - - ^ RGBehavior unresolvedNamed: aString withParent: anRGDefintion behaviorStrategy: (self newStrategyFor: anRGDefintion environment) -] - -{ #category : #'instance creation' } -RGBehaviorFactory class >> unresolvedWithParent: anRGDefintion [ - - ^ RGBehavior unresolvedWithParent: anRGDefintion behaviorStrategy: (self newStrategyFor: anRGDefintion environment) -] diff --git a/src/Ring2-Core/RGBehaviorStrategy.class.st b/src/Ring2-Core/RGBehaviorStrategy.class.st deleted file mode 100644 index 54875e472..000000000 --- a/src/Ring2-Core/RGBehaviorStrategy.class.st +++ /dev/null @@ -1,431 +0,0 @@ -Class { - #name : #RGBehaviorStrategy, - #superclass : #Object, - #instVars : [ - 'owner' - ], - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'instance creation' } -RGBehaviorStrategy class >> unresolved [ - - ^ self basicNew -] - -{ #category : #visiting } -RGBehaviorStrategy >> acceptVisitor: aVisitor [ - - self subclassResponsibility -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> addClassVariable: anRGInstanceVariableDefinition [ - - self incompatibleBehaviorType -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> addSharedPool: anRGPoolVariable [ - - self incompatibleBehaviorType -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> allClassVarNames [ - - self subclassResponsibility -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> allClassVariables [ - - self incompatibleBehaviorType -] - -{ #category : #utilities } -RGBehaviorStrategy >> allSlots [ - - ^ OrderedCollection new -] - -{ #category : #utilities } -RGBehaviorStrategy >> announceDefinitionChangeDuring: aBlock [ - - self owner announceDefinitionChangeDuring: aBlock -] - -{ #category : #utilities } -RGBehaviorStrategy >> backend [ - - ^ self owner backend forBehavior -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> baseBehavior [ - - ^ self owner -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> baseClass [ - - ^ self owner -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> baseClass: anRGClass [ - - self incompatibleBehaviorType -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> baseTrait [ - - self incompatibleBehaviorType -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> baseTrait: anRGClass [ - - self incompatibleBehaviorType -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> bindingOf: varName [ - - ^ self owner isRootInEnvironment - ifFalse: [self owner superclass bindingOf: varName] - ifTrue: [ nil ] -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> category [ - - self subclassResponsibility -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> category: aString [ - - self incompatibleBehaviorType -] - -{ #category : #accessing } -RGBehaviorStrategy >> classSide [ - - ^ self owner -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> classTrait [ - - self incompatibleBehaviorType -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> classTrait: anRGMetaclassTrait [ - - self incompatibleBehaviorType -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> classVarNames [ - - ^#() -] - -{ #category : #'class variables' } -RGBehaviorStrategy >> classVariableDefinitionString [ - - self incompatibleBehaviorType -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> classVariables [ - - self incompatibleBehaviorType -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> classVariables: aCollectionOfSymbols [ - - self incompatibleBehaviorType -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> classVariablesDo: aBlock [ - - self incompatibleBehaviorType -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> classVariablesString [ - - ^ String new -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> cleanClassVariables [ - - self incompatibleBehaviorType -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> cleanSharedPools [ - - self incompatibleBehaviorType -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> comment [ - - self subclassResponsibility -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> comment: anRGComment [ - - self incompatibleBehaviorType -] - -{ #category : #copying } -RGBehaviorStrategy >> copyForBehaviorDefinitionPostCopy [ - - super postCopy. - -] - -{ #category : #copying } -RGBehaviorStrategy >> copyForBehaviorDefinitionWithOwner: aNewOwner [ - - ^ self shallowCopy - owner: aNewOwner; - copyForBehaviorDefinitionPostCopy -] - -{ #category : #'default model values' } -RGBehaviorStrategy >> defaultMetaClass [ - - ^ self incompatibleBehaviorType -] - -{ #category : #utilities } -RGBehaviorStrategy >> environment [ - - ^ self owner environment -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> incompatibleBehaviorType [ - - RGIncompatibleBehaviorTypeError signal -] - -{ #category : #initialization } -RGBehaviorStrategy >> initializeUnresolved [ -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> innerBindingOf: aSymbol [ - - ^ nil -] - -{ #category : #utilities } -RGBehaviorStrategy >> instSize [ - - ^ 0 -] - -{ #category : #utilities } -RGBehaviorStrategy >> instVarNames [ - - ^ OrderedCollection new -] - -{ #category : #'accessing - parallel hierarchy' } -RGBehaviorStrategy >> instanceSide [ - - ^ self owner -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> instanceVariables: aCollectionOfSymbols [ - - self incompatibleBehaviorType -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> instanceVariablesString [ - - ^ String new -] - -{ #category : #testing } -RGBehaviorStrategy >> isClass [ - - ^ false -] - -{ #category : #testing } -RGBehaviorStrategy >> isClassStrategy [ - - ^ false -] - -{ #category : #testing } -RGBehaviorStrategy >> isMeta [ - "By default a non-meta class is considered" - - ^false -] - -{ #category : #testing } -RGBehaviorStrategy >> isMetaclass [ - - ^ false -] - -{ #category : #testing } -RGBehaviorStrategy >> isMetaclassStrategy [ - - ^ false -] - -{ #category : #testing } -RGBehaviorStrategy >> isMetaclassTrait [ - - ^ false -] - -{ #category : #testing } -RGBehaviorStrategy >> isMetaclassTraitStrategy [ - - ^ false -] - -{ #category : #testing } -RGBehaviorStrategy >> isTrait [ - - ^false -] - -{ #category : #testing } -RGBehaviorStrategy >> isTraitStrategy [ - - ^ false -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> kindOfSubclass [ - - self incompatibleBehaviorType -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> makeResolved [ - - "do nothing" - -] - -{ #category : #accessing } -RGBehaviorStrategy >> owner [ - ^ owner -] - -{ #category : #accessing } -RGBehaviorStrategy >> owner: anObject [ - owner := anObject -] - -{ #category : #utilities } -RGBehaviorStrategy >> pvtResolvableProperties [ - - ^ OrderedCollection new -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> referencedBehaviors [ - - ^ { self owner superclass. self owner metaclass}, self owner traitComposition referencedBehaviors -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> referencedPackages [ - - ^ Array new -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> removeClassVariable: anRGInstanceVariableDefinition [ - - self incompatibleBehaviorType -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> removeSharedPool: anRGPoolVariable [ - - self incompatibleBehaviorType -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> sharedPoolNames [ - - ^ OrderedCollection new -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> sharedPools [ - - ^ OrderedCollection new -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> sharedPools: aCollectionOfSymbols [ - - self incompatibleBehaviorType -] - -{ #category : #'private - backend access' } -RGBehaviorStrategy >> sharedPoolsDo: aBlock [ - - self incompatibleBehaviorType -] - -{ #category : #utilities } -RGBehaviorStrategy >> sibling [ - - ^ self subclassResponsibility -] - -{ #category : #utilities } -RGBehaviorStrategy >> storeName [ - - self subclassResponsibility -] - -{ #category : #'accessing - deprecated parallel hierarchy' } -RGBehaviorStrategy >> theMetaClass [ - - ^ self owner -] - -{ #category : #'accessing - deprecated parallel hierarchy' } -RGBehaviorStrategy >> theNonMetaClass [ - - ^ self owner -] - -{ #category : #variables } -RGBehaviorStrategy >> trait [ - - ^ self incompatibleBehaviorType -] - -{ #category : #utilities } -RGBehaviorStrategy >> unresolvedValue: aDefaultValue [ - - ^ self owner unresolvedValue: aDefaultValue -] diff --git a/src/Ring2-Core/RGBehaviorStrategyUser.class.st b/src/Ring2-Core/RGBehaviorStrategyUser.class.st deleted file mode 100644 index ca54439c9..000000000 --- a/src/Ring2-Core/RGBehaviorStrategyUser.class.st +++ /dev/null @@ -1,389 +0,0 @@ -" -I am an abstract behavior that has a behavior strategy and and delegates all messages to it -" -Class { - #name : #RGBehaviorStrategyUser, - #superclass : #RGObject, - #instVars : [ - 'behaviorStrategy' - ], - #category : #'Ring2-Core-Kernel' -} - -{ #category : #visiting } -RGBehaviorStrategyUser >> acceptVisitor: aVisitor [ - - ^ self behaviorStrategy acceptVisitor: aVisitor -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> addClassVariable: anRGInstanceVariableDefinition [ - - ^ self behaviorStrategy addClassVariable: anRGInstanceVariableDefinition -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> addSharedPool: anRGPoolVariable [ - - ^ self behaviorStrategy addSharedPool: anRGPoolVariable -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> allClassVarNames [ - - ^ self behaviorStrategy allClassVarNames -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> allClassVariables [ - - ^ self behaviorStrategy allClassVariables -] - -{ #category : #'as yet unclassified' } -RGBehaviorStrategyUser >> allSlots [ - - ^ self behaviorStrategy allSlots -] - -{ #category : #'queries - other' } -RGBehaviorStrategyUser >> baseBehavior [ - - ^ self behaviorStrategy baseBehavior -] - -{ #category : #'as yet unclassified' } -RGBehaviorStrategyUser >> baseClass [ - - ^ self behaviorStrategy baseClass -] - -{ #category : #accessing } -RGBehaviorStrategyUser >> baseClass: anRGClass [ - - ^ self behaviorStrategy baseClass: anRGClass -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> baseTrait [ - - ^ self behaviorStrategy baseTrait -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> baseTrait: anRGClass [ - - ^ self behaviorStrategy baseTrait: anRGClass -] - -{ #category : #accessing } -RGBehaviorStrategyUser >> behaviorStrategy [ - ^ behaviorStrategy -] - -{ #category : #accessing } -RGBehaviorStrategyUser >> behaviorStrategy: anObject [ - - | needsInitialization | - - needsInitialization := behaviorStrategy isNil. - behaviorStrategy := anObject. - behaviorStrategy owner: self. - needsInitialization ifTrue: [ - behaviorStrategy initializeUnresolved ]. - -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> bindingOf: varName [ - - ^ self behaviorStrategy bindingOf: varName - -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> category [ - - ^ self behaviorStrategy category -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> category: aString [ - - ^ self behaviorStrategy category: aString -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> classSide [ - - ^ self behaviorStrategy classSide -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> classTrait [ - - ^ self behaviorStrategy classTrait -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> classTrait: anRGMetaclassTrait [ - - ^ self behaviorStrategy classTrait: anRGMetaclassTrait -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> classVarNames [ - - ^ self behaviorStrategy classVarNames -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> classVariableDefinitionString [ - - ^ self behaviorStrategy classVariableDefinitionString -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> classVariables [ - - ^ self behaviorStrategy classVariables -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> classVariables: aCollectionOfSymbols [ - - ^ self behaviorStrategy classVariables: aCollectionOfSymbols -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> classVariablesDo: aBlock [ - - ^ self behaviorStrategy classVariablesDo: aBlock -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> cleanClassVariables [ - - ^ self behaviorStrategy cleanClassVariables -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> cleanSharedPools [ - - ^ self behaviorStrategy cleanSharedPools -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> comment [ - - ^ self behaviorStrategy comment -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> comment: anRGComment [ - - ^ self behaviorStrategy comment: anRGComment -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> defaultMetaClass [ - - ^ self behaviorStrategy defaultMetaClass -] - -{ #category : #'accessing - definition' } -RGBehaviorStrategyUser >> definition [ - - ^ self behaviorStrategy definition -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> innerBindingOf: aSymbol [ - - ^ self behaviorStrategy innerBindingOf: aSymbol -] - -{ #category : #'as yet unclassified' } -RGBehaviorStrategyUser >> instSize [ - - ^ self behaviorStrategy instSize -] - -{ #category : #'as yet unclassified' } -RGBehaviorStrategyUser >> instVarNames [ - ^ self behaviorStrategy instVarNames -] - -{ #category : #'as yet unclassified' } -RGBehaviorStrategyUser >> instanceSide [ - - ^ self behaviorStrategy instanceSide -] - -{ #category : #accessing } -RGBehaviorStrategyUser >> instanceVariables: aCollectionOfSymbols [ - - ^ self behaviorStrategy instanceVariables: aCollectionOfSymbols -] - -{ #category : #printing } -RGBehaviorStrategyUser >> instanceVariablesString [ - - ^ self behaviorStrategy instanceVariablesString -] - -{ #category : #testing } -RGBehaviorStrategyUser >> isClass [ - - ^ self behaviorStrategy isClass -] - -{ #category : #'queries - testing' } -RGBehaviorStrategyUser >> isMeta [ - "By default a non-meta class is considered" - - ^ self behaviorStrategy isMeta -] - -{ #category : #'testing types' } -RGBehaviorStrategyUser >> isMetaclass [ - - ^ self behaviorStrategy isMetaclass -] - -{ #category : #'testing types' } -RGBehaviorStrategyUser >> isMetaclassTrait [ - - ^ self behaviorStrategy isMetaclassTrait -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> isTrait [ - - ^ self behaviorStrategy isTrait -] - -{ #category : #'testing class hierarchy' } -RGBehaviorStrategyUser >> kindOfSubclass [ - - ^ self behaviorStrategy kindOfSubclass -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> layout [ - - ^ self behaviorStrategy layout -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> layout: anRGLayout [ - - ^ self behaviorStrategy layout: anRGLayout -] - -{ #category : #resolving } -RGBehaviorStrategyUser >> makeResolved [ - - self behaviorStrategy makeResolved. - super makeResolved. - -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> package [ - - ^ self behaviorStrategy package -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> package: anRGPackageDefinition [ - - ^ self behaviorStrategy package: anRGPackageDefinition - -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> referencedBehaviors [ - - ^ self behaviorStrategy referencedBehaviors -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> referencedPackages [ - - ^ self behaviorStrategy referencedPackages -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> removeClassVariable: anRGInstanceVariableDefinition [ - - ^ self behaviorStrategy removeClassVariable: anRGInstanceVariableDefinition -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> removeSharedPool: anRGPoolVariable [ - - ^ self behaviorStrategy removeSharedPool: anRGPoolVariable -] - -{ #category : #testing } -RGBehaviorStrategyUser >> sharedPoolNames [ - - ^ self behaviorStrategy sharedPoolNames -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> sharedPools [ - - ^ self behaviorStrategy sharedPools -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> sharedPools: aCollectionOfSymbols [ - - ^ self behaviorStrategy sharedPools: aCollectionOfSymbols -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> sharedPoolsDo: aBlock [ - - ^ self behaviorStrategy sharedPoolsDo: aBlock -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> sibling [ - - ^ self behaviorStrategy sibling -] - -{ #category : #printing } -RGBehaviorStrategyUser >> storeOn: aStream [ - - ^ self behaviorStrategy storeOn: aStream -] - -{ #category : #'as yet unclassified' } -RGBehaviorStrategyUser >> theMetaClass [ - - ^ self behaviorStrategy theMetaClass -] - -{ #category : #'as yet unclassified' } -RGBehaviorStrategyUser >> theNonMetaClass [ - - ^ self behaviorStrategy theNonMetaClass -] - -{ #category : #variables } -RGBehaviorStrategyUser >> trait [ - - "Because of API compatibility between traits and trait transformations" - - ^ self behaviorStrategy trait -] - -{ #category : #strategy } -RGBehaviorStrategyUser >> traitTransformationString [ - - ^ self behaviorStrategy traitTransformationString -] diff --git a/src/Ring2-Core/RGBitsLayout.class.st b/src/Ring2-Core/RGBitsLayout.class.st deleted file mode 100644 index 0bc4724a5..000000000 --- a/src/Ring2-Core/RGBitsLayout.class.st +++ /dev/null @@ -1,23 +0,0 @@ -Class { - #name : #RGBitsLayout, - #superclass : #RGObjectLayout, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'testing types' } -RGBitsLayout >> isBitsLayout [ - - ^ true -] - -{ #category : #'testing types' } -RGBitsLayout >> isVariableLayout [ - - ^ true -] - -{ #category : #accessing } -RGBitsLayout >> layoutName [ - - ^ #BitsLayout -] diff --git a/src/Ring2-Core/RGByteLayout.class.st b/src/Ring2-Core/RGByteLayout.class.st deleted file mode 100644 index 5aaa64d3d..000000000 --- a/src/Ring2-Core/RGByteLayout.class.st +++ /dev/null @@ -1,17 +0,0 @@ -Class { - #name : #RGByteLayout, - #superclass : #RGBitsLayout, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'testing types' } -RGByteLayout >> isByteLayout [ - - ^ true -] - -{ #category : #accessing } -RGByteLayout >> layoutName [ - - ^ #ByteLayout -] diff --git a/src/Ring2-Core/RGClass.class.st b/src/Ring2-Core/RGClass.class.st deleted file mode 100644 index 7fc8e19e1..000000000 --- a/src/Ring2-Core/RGClass.class.st +++ /dev/null @@ -1,14 +0,0 @@ -" -A factory that produces instances of RG2Behavior composed with RG2ClassStrategy -" -Class { - #name : #RGClass, - #superclass : #RGBehaviorFactory, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'instance creation' } -RGClass class >> newStrategy [ - - ^ RGClassStrategy unresolved -] diff --git a/src/Ring2-Core/RGClassDescriptionStrategy.class.st b/src/Ring2-Core/RGClassDescriptionStrategy.class.st deleted file mode 100644 index bad73c580..000000000 --- a/src/Ring2-Core/RGClassDescriptionStrategy.class.st +++ /dev/null @@ -1,181 +0,0 @@ -Class { - #name : #RGClassDescriptionStrategy, - #superclass : #RGBehaviorStrategy, - #instVars : [ - 'layout' - ], - #category : #'Ring2-Core-Kernel' -} - -{ #category : #utilities } -RGClassDescriptionStrategy >> allSlots [ - - | superclassSlots aSuperclass | - aSuperclass := self owner superclass. - superclassSlots := OrderedCollection new. - ((aSuperclass == self owner) or: [aSuperclass isNil ]) ifFalse: [ - superclassSlots addAll: aSuperclass allSlots ]. - ^ (superclassSlots, self layout allSlots) asArray. -] - -{ #category : #initialization } -RGClassDescriptionStrategy >> classVariablesString [ - "Answer a string of my class variable names separated by spaces." - - ^ String streamContents: [ :stream | - self owner classVarNames - do: [ :each | stream nextPutAll: each ] - separatedBy: [ stream space ] ] -] - -{ #category : #copying } -RGClassDescriptionStrategy >> copyForBehaviorDefinitionPostCopy [ - - super copyForBehaviorDefinitionPostCopy. - layout := self layout copyForBehaviorDefinition. - layout parent: self owner. - -] - -{ #category : #initialization } -RGClassDescriptionStrategy >> defaultLayout [ - - ^ self owner defaultFixedLayoutStubIn: self. -] - -{ #category : #initialization } -RGClassDescriptionStrategy >> initialize [ - - super initialize. - - layout := self unresolvedValue: self defaultLayout. - self owner environment backend createUnresolvedClassGroupFor: self owner. -] - -{ #category : #initialization } -RGClassDescriptionStrategy >> initializeUnresolved [ - - super initializeUnresolved. - - layout := self unresolvedValue: self defaultLayout. - -] - -{ #category : #initialization } -RGClassDescriptionStrategy >> instSize [ - - ^ self owner allInstVarNames size -] - -{ #category : #initialization } -RGClassDescriptionStrategy >> instVarNames [ - ^ self layout instVarNames -] - -{ #category : #accessing } -RGClassDescriptionStrategy >> instanceVariables: aCollectionOfSymbols [ - - "specify instance variable names" - - (self owner hasUnresolved: #layout) - ifTrue: [ self layout: (RGFixedLayout parent: self)]. - - (self layout isPointerLayout not and: [ aCollectionOfSymbols isEmpty ]) - ifTrue: [ ^ self ]. - - self layout cleanSlots. - - aCollectionOfSymbols do: [ :instVarName | - layout addSlot: (RGInstanceVariableSlot named: instVarName asSymbol parent: self)]. -] - -{ #category : #accessing } -RGClassDescriptionStrategy >> instanceVariablesString [ - "Answer a string of my instance variable names separated by spaces." - - ^String streamContents: [ :stream | - self instVarNames - do: [ :each | stream nextPutAll: each ] - separatedBy: [ stream space ] ] -] - -{ #category : #'testing class hierarchy' } -RGClassDescriptionStrategy >> kindOfSubclass [ - "Answer a String that is the keyword that describes the receiver's kind of subclass, - either a regular subclass, a variableSubclass, a variableByteSubclass, - a variableWordSubclass, a weakSubclass, an ephemeronSubclass or an immediateSubclass. - c.f. typeOfClass" - ^self owner isVariable - ifTrue: - [self layout isBitsLayout - ifTrue: - [self layout isByteLayout - ifTrue: [' variableByteSubclass: '] - ifFalse: [' variableWordSubclass: ']] - ifFalse: - [self layout isWeakLayout - ifTrue: [' weakSubclass: '] - ifFalse: [' variableSubclass: ']]] - ifFalse: - [self layout isImmediateLayout - ifTrue: [' immediateSubclass: '] - ifFalse: - [self layout isEphemeronLayout - ifTrue: [' ephemeronSubclass: '] - ifFalse: [' subclass: ']]] -] - -{ #category : #'accessing - backend' } -RGClassDescriptionStrategy >> layout [ - - ^ self backend forBehavior layoutFor: self owner -] - -{ #category : #'accessing - backend' } -RGClassDescriptionStrategy >> layout: anRGLayout [ - - self owner announceDefinitionChangeDuring: [ - self backend forBehavior setLayoutFor: self owner to: anRGLayout ]. - -] - -{ #category : #'private - backend interface' } -RGClassDescriptionStrategy >> makeResolved [ - - super makeResolved. - - layout := self layout makeResolved markAsRingResolved. - -] - -{ #category : #'private - backend interface' } -RGClassDescriptionStrategy >> pvtLayout [ - - ^ layout value -] - -{ #category : #'private - backend interface' } -RGClassDescriptionStrategy >> pvtLayout: anRGLayout [ - - self environment verifyOwnership: anRGLayout. - - ^ layout := anRGLayout -] - -{ #category : #'private - backend interface' } -RGClassDescriptionStrategy >> pvtResolvableProperties [ - - ^ super pvtResolvableProperties, { - #layout -> layout. - } -] - -{ #category : #printing } -RGClassDescriptionStrategy >> storeOn: aStream [ - aStream - nextPutAll: '('; - nextPutAll: self storeName; - nextPutAll: ' named: '. - self owner name storeOn: aStream. - aStream nextPut: $) -] diff --git a/src/Ring2-Core/RGClassStrategy.class.st b/src/Ring2-Core/RGClassStrategy.class.st deleted file mode 100644 index 28ae6f2ef..000000000 --- a/src/Ring2-Core/RGClassStrategy.class.st +++ /dev/null @@ -1,605 +0,0 @@ -Class { - #name : #RGClassStrategy, - #superclass : #RGClassDescriptionStrategy, - #instVars : [ - 'comment', - 'classVariables', - 'package', - 'sharedPools' - ], - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'private - backend access' } -RGClassStrategy >> acceptVisitor: aVisitor [ - - ^ aVisitor visitClass: self owner -] - -{ #category : #'private - backend access' } -RGClassStrategy >> addClassVariable: anRGInstanceVariableDefinition [ - - self owner announceDefinitionChangeDuring: [ - self privAddClassVariable: anRGInstanceVariableDefinition ] - - -] - -{ #category : #'private - backend access' } -RGClassStrategy >> addSharedPool: anRGPoolVariable [ - - self owner announceDefinitionChangeDuring: [ - self privAddSharedPool: anRGPoolVariable ]. -] - -{ #category : #'private - backend access' } -RGClassStrategy >> allClassVarNames [ - - ^self allClassVariables collect:[ :cvar| cvar name ] -] - -{ #category : #'private - backend access' } -RGClassStrategy >> allClassVariables [ - "Answer a collection of the receiver's classVariables, including those defined its superclasses" - - ^ ((self owner superclass == nil) or: [ self owner superclass == self owner]) - ifTrue: [ self classVariables ] - ifFalse: [ self owner superclass allClassVariables, classVariables ] -] - -{ #category : #'private - backend access' } -RGClassStrategy >> bindingOf: varName [ - - | aSymbol | - aSymbol := varName asSymbol. - - ^ (self innerBindingOf: aSymbol) ifNil: [ - self environment bindingOf: aSymbol ] -] - -{ #category : #'private - backend access' } -RGClassStrategy >> category [ - - ^ self owner tags - ifEmpty: [ self owner package categoryName ] - ifNotEmpty: [ - (self owner package hasResolvedName) - ifTrue: [ self owner package categoryName, '-', self owner tags first ] - ifFalse: [ self owner tags first ] ] - - "todo" -] - -{ #category : #'private - backend access' } -RGClassStrategy >> category: aString [ - - | aTag | - - self owner cleanTagsWithoutAnnouncemnt. - aTag := self owner package - ifNotNil: [ - self owner package name = aString - ifTrue: [ ^ self owner ] "category contains only the package name" - ifFalse: [ aString withoutPrefix: self package name, '-' ]] - ifNil: [ aString ]. - self owner tagWith: aTag asSymbol. - -" self backend forBehavior setCategoryFor: self to: aaString. - - self announcer behaviorDefinitionModified: self. - self announcer behaviorRecategorized: self." -] - -{ #category : #'private - backend access' } -RGClassStrategy >> classSide [ - - ^ self owner metaclass -] - -{ #category : #'private - backend access' } -RGClassStrategy >> classVarNames [ - - ^ self classVariables collect: #name -] - -{ #category : #'class variables' } -RGClassStrategy >> classVariableDefinitionString [ - "Answer a string that evaluates to the definition of the class Variables" - - ^String streamContents: [ :str | | special | - str nextPutAll: '{ '. - self owner classVariables do: [:global | - str nextPutAll: global definitionString. - special := global isSpecial] - separatedBy: [ - str nextPutAll: '. '. - special ifTrue: [ str cr;tab;tab;tab;tab ]]. - str nextPutAll: ' }'. ] -] - -{ #category : #'private - backend access' } -RGClassStrategy >> classVariables [ - - | allClassVariables | - allClassVariables := OrderedCollection new. - self classVariablesDo: [ :each | allClassVariables add: each]. - ^ allClassVariables asArray -] - -{ #category : #'private - backend access' } -RGClassStrategy >> classVariables: aCollectionOfSymbols [ - - self cleanClassVariables. - aCollectionOfSymbols do: [ :classVarName | - self addClassVariable: (RGClassVariable named: classVarName asSymbol parent: self).]. -] - -{ #category : #'private - backend access' } -RGClassStrategy >> classVariablesDo: aBlock [ - - self backend forBehavior classVariablesFor: self owner do: aBlock -] - -{ #category : #'private - backend access' } -RGClassStrategy >> cleanClassVariables [ - - self owner announceDefinitionChangeDuring: [ - self backend forBehavior cleanClassVariablesFor: self owner ]. -] - -{ #category : #'private - backend access' } -RGClassStrategy >> cleanSharedPools [ - - self backend forBehavior cleanSharedPoolsFor: self owner. -] - -{ #category : #'private - backend access' } -RGClassStrategy >> comment [ - - ^ self backend forBehavior commentFor: self owner -] - -{ #category : #'private - backend access' } -RGClassStrategy >> comment: anRGComment [ - - self backend forBehavior setCommentFor: self owner to: anRGComment. - - self owner announcer behaviorCommentModified: self. -] - -{ #category : #'private - backend access' } -RGClassStrategy >> copyForBehaviorDefinitionPostCopy [ - - | newVariables newSharedPools | - - self owner behaviorStrategy: self. - - super copyForBehaviorDefinitionPostCopy. - - newVariables := self classVariables collect: [ :each | each copyWithParent: self owner]. - newSharedPools := self sharedPools collect: [ :each | each shallowCopy. ]. - - self pvtCleanClassVariables. - self pvtCleanSharedPools. - - newVariables do: [ :each | self privAddClassVariable: each ]. - newSharedPools do: [ :each | self privAddSharedPool: each ]. - - - -] - -{ #category : #'default model values' } -RGClassStrategy >> defaultClassVariables [ - - ^ OrderedCollection new - - -] - -{ #category : #'default model values' } -RGClassStrategy >> defaultComment [ - - ^ self owner defaultCommentStubIn: self owner -] - -{ #category : #testing } -RGClassStrategy >> defaultMetaClass [ - - ^ self owner environment backend createNewUnresolvedMetaclassFor: self owner -] - -{ #category : #'default model values' } -RGClassStrategy >> defaultPackage [ - - ^ self owner defaultPackageStubIn: self environment - - -] - -{ #category : #'default model values' } -RGClassStrategy >> defaultSharedPools [ - - ^ OrderedCollection new - - -] - -{ #category : #testing } -RGClassStrategy >> definition [ - - | aStream poolString | - - self owner usesSpecialSlot - ifTrue: [ ^ self definitionWithSlots ]. - - poolString := self owner sharedPoolsString. - aStream := (String new: 800) writeStream. - owner superclass - ifNil: [ aStream nextPutAll: 'ProtoObject' ] - ifNotNil: [ aStream nextPutAll: self owner superclass name ]. - aStream - nextPutAll: self kindOfSubclass; - store: self owner name. - self owner hasTraitComposition - ifTrue: - [ aStream - cr; - tab; - nextPutAll: 'uses: '; - nextPutAll: self owner traitCompositionString ]. - aStream - cr; - tab; - nextPutAll: 'instanceVariableNames: '; - store: self owner instanceVariablesString. - aStream - cr; - tab; - nextPutAll: 'classVariableNames: '; - store: self owner classVariablesString. - poolString = '' - ifFalse: - [ aStream - cr; - tab; - nextPutAll: 'poolDictionaries: '; - store: poolString ]. - aStream - cr; - tab; - nextPutAll: 'package: '; - store: self owner category asString. - owner superclass - ifNil: - [ aStream - nextPutAll: '.'; - cr. - aStream nextPutAll: self owner name. - aStream - space; - nextPutAll: 'superclass: nil' ]. - ^ aStream contents -] - -{ #category : #testing } -RGClassStrategy >> definitionWithSlots [ - - | aStream poolString| - - poolString := self owner sharedPoolsString. - - aStream := (String new: 800) writeStream. - self owner superclass - ifNil: [aStream nextPutAll: 'ProtoObject'] - ifNotNil: [aStream nextPutAll: self owner superclass name]. - aStream nextPutAll: ' subclass: '; - store: self owner name. - (self owner hasTraitComposition) ifTrue: [ - aStream cr; tab; nextPutAll: 'uses: '; - nextPutAll: self owner traitCompositionString]. - - (self layout layoutName = #FixedLayout) ifFalse: [ - aStream cr; tab; nextPutAll: 'layout: '; - nextPutAll: self layout layoutName]. - aStream cr; tab; nextPutAll: 'slots: '; - nextPutAll: self owner slotDefinitionString. - aStream cr; tab; nextPutAll: 'classVariables: '; - nextPutAll: self owner classVariableDefinitionString. - poolString = '' ifFalse: [ - aStream cr; tab; nextPutAll: 'poolDictionaries: '; - store: poolString]. - aStream cr; tab; nextPutAll: 'package: '; - store: self category asString. - - self owner superclass ifNil: [ - aStream nextPutAll: '.'; cr. - aStream nextPutAll: self owner name. - aStream space; nextPutAll: 'superclass: nil'. ]. - - ^ aStream contents -] - -{ #category : #initialization } -RGClassStrategy >> initialize [ - - super initialize. - - comment := self unresolvedValue: self defaultComment. - classVariables := self unresolvedValue: self defaultClassVariables. - package := self unresolvedValue: self defaultPackage. - sharedPools := self unresolvedValue: self defaultSharedPools. - - -] - -{ #category : #initialization } -RGClassStrategy >> initializeUnresolved [ - - super initializeUnresolved. - - comment := self unresolvedValue: self defaultComment. - classVariables := self unresolvedValue: self defaultClassVariables. - package := self unresolvedValue: self defaultPackage. - sharedPools := self unresolvedValue: self defaultSharedPools. - -] - -{ #category : #'private - backend access' } -RGClassStrategy >> innerBindingOf: aSymbol [ - - self classVariables detect: [ :each | each name = aSymbol ] ifFound: [ :found | ^ found ]. - - self sharedPoolsDo: [:pool | - ((self environment ask behaviorNamed: pool name) bindingOf: aSymbol) ifNotNil: [:binding | ^binding]]. - - ((self owner superclass == self owner) or: [ self owner superclass isNil ]) ifFalse: [ ^ self owner superclass innerBindingOf: aSymbol]. - - ^ nil -] - -{ #category : #testing } -RGClassStrategy >> isClass [ - - ^ true -] - -{ #category : #testing } -RGClassStrategy >> isClassStrategy [ - - ^ true -] - -{ #category : #'default model values' } -RGClassStrategy >> makeResolved [ - - - "try to set the correct name before resolving of it" - ((self owner hasResolvedName not) and: [ self owner metaclass isRingResolved and: [ self owner metaclass hasResolvedName ] ]) ifTrue: [ - self owner pvtName: (self owner metaclass name withoutSuffix: ' class') asSymbol. - ]. - - super makeResolved. - - comment := self comment markAsRingResolved. - classVariables := self classVariables markAsRingResolved. - package := self package markAsRingResolved. - sharedPools := self sharedPools markAsRingResolved. - -] - -{ #category : #'accessing - backend' } -RGClassStrategy >> package [ - - ^ self backend forBehavior packageFor: self owner -] - -{ #category : #'accessing - backend' } -RGClassStrategy >> package: anRGPackageDefinition [ - - | oldPackage | - oldPackage := self package. - - self owner announceDefinitionChangeDuring: [ - self owner backend forBehavior setPackageFor: self owner to: anRGPackageDefinition. - self owner environment addPackage: anRGPackageDefinition. - (oldPackage hasResolved: #definedBehaviors) - ifTrue: [ oldPackage removeDefinedBehavior: self owner ]. - anRGPackageDefinition addDefinedBehavior: self owner. ]. - - self owner announce: (ClassRepackaged - classRepackaged: self owner - oldPackage: oldPackage - newPackage: anRGPackageDefinition) -] - -{ #category : #'private - backend access' } -RGClassStrategy >> privAddClassVariable: anRGInstanceVariableDefinition [ - - self backend forBehavior addClassVariable: anRGInstanceVariableDefinition to: self owner - -] - -{ #category : #'private - backend access' } -RGClassStrategy >> privAddSharedPool: anRGPoolVariable [ - - self backend forBehavior addSharedPool: anRGPoolVariable to: self owner -] - -{ #category : #'private - backend access' } -RGClassStrategy >> pvtAddClassVariable: anRGInstanceVariableDefinition [ - - self owner environment verifyOwnership: anRGInstanceVariableDefinition. - - classVariables isRingResolved ifFalse: [ - self pvtCleanClassVariables ]. - - classVariables add: anRGInstanceVariableDefinition. -] - -{ #category : #'private - backend access' } -RGClassStrategy >> pvtAddSharedPool: anRGPoolVariable [ - - self owner environment verifyOwnership: anRGPoolVariable. - - sharedPools isRingResolved ifFalse: [ - self pvtCleanSharedPools ]. - - sharedPools add: anRGPoolVariable. -] - -{ #category : #'private - backend access' } -RGClassStrategy >> pvtClassVariablesDo: aBlock [ - - classVariables value do: aBlock -] - -{ #category : #'private - backend access' } -RGClassStrategy >> pvtCleanClassVariables [ - - classVariables := self defaultClassVariables. -] - -{ #category : #'private - backend access' } -RGClassStrategy >> pvtCleanSharedPools [ - - sharedPools := self defaultSharedPools. -] - -{ #category : #'private - backend access' } -RGClassStrategy >> pvtComment [ - - ^ comment value -] - -{ #category : #'private - backend access' } -RGClassStrategy >> pvtComment: anRGComment [ - - self owner environment verifyOwnership: anRGComment. - - ^ comment := anRGComment -] - -{ #category : #testing } -RGClassStrategy >> pvtPackage [ - - ^ package value -] - -{ #category : #testing } -RGClassStrategy >> pvtPackage: anRGPackageDefinition [ - - self owner environment verifyOwnership: anRGPackageDefinition. - - ^ package := anRGPackageDefinition -] - -{ #category : #'private - backend access' } -RGClassStrategy >> pvtRemoveClassVariable: anRGInstanceVariableDefinition [ - - self owner environment verifyOwnership: anRGInstanceVariableDefinition. - - classVariables remove: anRGInstanceVariableDefinition. -] - -{ #category : #'private - backend access' } -RGClassStrategy >> pvtRemoveSharedPool: anRGPoolVariableDefinition [ - - self owner environment verifyOwnership: anRGPoolVariableDefinition. - - sharedPools remove: anRGPoolVariableDefinition. -] - -{ #category : #initialization } -RGClassStrategy >> pvtResolvableProperties [ - - ^ super pvtResolvableProperties, { - #comment -> comment. - #classVariables -> classVariables. - #package -> package. - #sharedPools -> sharedPools. - } - - - -] - -{ #category : #enumerating } -RGClassStrategy >> pvtSharedPoolsDo: aBlock [ - - sharedPools value do: aBlock -] - -{ #category : #'private - backend access' } -RGClassStrategy >> removeClassVariable: anRGInstanceVariableDefinition [ - - self owner announceDefinitionChangeDuring: [ - self backend forBehavior removeClassVariable: anRGInstanceVariableDefinition from: self owner ]. -] - -{ #category : #'private - backend access' } -RGClassStrategy >> removeSharedPool: anRGPoolVariable [ - - self owner announceDefinitionChangeDuring: [ - self backend forBehavior removeSharedPool: anRGPoolVariable from: self owner]. -] - -{ #category : #'private - backend access' } -RGClassStrategy >> sharedPoolNames [ - - | allSharedPools | - allSharedPools := OrderedCollection new. - self sharedPoolsDo: [ :each | allSharedPools add: each name]. - ^ allSharedPools asArray -] - -{ #category : #'private - backend access' } -RGClassStrategy >> sharedPools [ - - | allSharedPools | - allSharedPools := OrderedCollection new. - self sharedPoolsDo: [ :each | allSharedPools add: ( - "use classes everywhare you can. TODO: really?" - each isSymbol - ifTrue: [ self environment ask behaviorNamed: each name ] - ifFalse: [ - (each isVariableDefinition and: [each isPoolVariable ]) - ifTrue: [ - | beh | - beh := self environment ask behaviorNamed: each name. - beh ifNotNil: [ beh ] ifNil: [ each ] ] - ifFalse: [ each copy ]])]. - ^ allSharedPools -] - -{ #category : #'private - backend access' } -RGClassStrategy >> sharedPools: aCollectionOfSymbols [ - - self cleanSharedPools. - aCollectionOfSymbols do: [ :poolName | - self addSharedPool: (RGPoolVariable named: poolName asSymbol parent: self).]. -] - -{ #category : #'private - backend access' } -RGClassStrategy >> sharedPoolsDo: aBlock [ - - self owner backend forBehavior sharedPoolsFor: self owner do: aBlock -] - -{ #category : #'private - backend access' } -RGClassStrategy >> sibling [ - - ^ self owner metaclass. -] - -{ #category : #testing } -RGClassStrategy >> storeName [ - - ^ 'RGClass' -] - -{ #category : #'accessing - deprecated parallel hierarchy' } -RGClassStrategy >> theMetaClass [ - - ^ self owner metaclass -] diff --git a/src/Ring2-Core/RGClassVariable.class.st b/src/Ring2-Core/RGClassVariable.class.st deleted file mode 100644 index 469f9795c..000000000 --- a/src/Ring2-Core/RGClassVariable.class.st +++ /dev/null @@ -1,37 +0,0 @@ -" -A class variable definition -" -Class { - #name : #RGClassVariable, - #superclass : #RGVariable, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'managing container' } -RGClassVariable >> addoptToParentStub [ - - super addoptToParentStub. - self environment backend createUnresolvedClassGroupFor: self parent. - self parent addClassVariable: self. -] - -{ #category : #'managing container' } -RGClassVariable >> defaultParentStub [ - - ^ self defaultClassStub -] - -{ #category : #printing } -RGClassVariable >> definitionString [ - - "TODO: special class variables?" - - ^ self name printString - -] - -{ #category : #testing } -RGClassVariable >> isClassVariable [ - - ^true -] diff --git a/src/Ring2-Core/RGComment.class.st b/src/Ring2-Core/RGComment.class.st deleted file mode 100644 index bb809b357..000000000 --- a/src/Ring2-Core/RGComment.class.st +++ /dev/null @@ -1,200 +0,0 @@ -" -RGComment is a first-class representation of class's comments -" -Class { - #name : #RGComment, - #superclass : #RGElement, - #instVars : [ - 'content', - 'author', - 'time' - ], - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'managing container' } -RGComment >> addoptToParentStub [ - - super addoptToParentStub. - - self environment backend createUnresolvedClassGroupFor: self parent -] - -{ #category : #'accessing - backend' } -RGComment >> author [ - - ^ self backend forBehavior classCommentAuthorFor: self -] - -{ #category : #'accessing - backend' } -RGComment >> author: aString [ - - self backend forBehavior setClassCommentAuthorFor: self to: aString. - - self announcer behaviorCommentModified: self parent. -] - -{ #category : #'accessing - backend' } -RGComment >> content [ - - ^ self backend forBehavior classCommentContentFor: self -] - -{ #category : #'accessing - backend' } -RGComment >> content: aString [ - - self backend forBehavior setClassCommentContentFor: self to: aString. - - self announcer behaviorCommentModified: self parent. -] - -{ #category : #'default model values' } -RGComment >> defaultAuthor [ - - ^ '' -] - -{ #category : #'default model values' } -RGComment >> defaultContent [ - - ^ '' -] - -{ #category : #'managing container' } -RGComment >> defaultParentStub [ - - ^ self defaultClassStub -] - -{ #category : #'default model values' } -RGComment >> defaultTime [ - - ^ DateAndTime new -] - -{ #category : #accessing } -RGComment >> fullName [ - - ^ (self parent name, ' comment') asSymbol -] - -{ #category : #initialization } -RGComment >> initialize [ - - super initialize. - - content := self unresolvedValue: self defaultContent. - author := self unresolvedValue: self defaultAuthor. - time := self unresolvedValue: self defaultTime. - -] - -{ #category : #initialization } -RGComment >> initializeUnresolved [ - - super initializeUnresolved. - - content := self unresolvedValue: self defaultContent. - author := self unresolvedValue: self defaultAuthor. - time := self unresolvedValue: self defaultTime. - -] - -{ #category : #testing } -RGComment >> isComment [ - - ^ true -] - -{ #category : #testing } -RGComment >> isEmptyOrNil [ - - ^ self content isEmptyOrNil -] - -{ #category : #resolving } -RGComment >> makeResolved [ - - super makeResolved. - - content := self content markAsRingResolved. - author := self author markAsRingResolved. - time := self time markAsRingResolved. -] - -{ #category : #printing } -RGComment >> printOn: aStream [ - - self parent name ifNotNil: [ - aStream nextPutAll: self parent name; - nextPutAll: ' ' ]. - aStream nextPutAll: self name asString -] - -{ #category : #'private - backend interface' } -RGComment >> pvtAuthor [ - - ^ author value -] - -{ #category : #'private - backend interface' } -RGComment >> pvtAuthor: aString [ - - ^ author := aString -] - -{ #category : #'private - backend interface' } -RGComment >> pvtContent [ - - ^ content value -] - -{ #category : #'private - backend interface' } -RGComment >> pvtContent: aString [ - - ^ content := aString -] - -{ #category : #'private - backend interface' } -RGComment >> pvtResolvableProperties [ - - ^ super pvtResolvableProperties, { - #content -> content. - #author -> author. - #time -> time. - } - - -] - -{ #category : #'private - backend interface' } -RGComment >> pvtTime [ - - ^ time value -] - -{ #category : #'private - backend interface' } -RGComment >> pvtTime: aDateAndTime [ - - ^ time := aDateAndTime -] - -{ #category : #'backward compatibility' } -RGComment >> sourceCode [ - - ^ self content -] - -{ #category : #'accessing - backend' } -RGComment >> time [ - - ^ self backend forBehavior classCommentTimeFor: self -] - -{ #category : #'accessing - backend' } -RGComment >> time: aDateAndTime [ - - self backend forBehavior setClassCommentTimeFor: self to: aDateAndTime. - - self announcer behaviorCommentModified: self parent. -] diff --git a/src/Ring2-Core/RGCompiledMethodLayout.class.st b/src/Ring2-Core/RGCompiledMethodLayout.class.st deleted file mode 100644 index 2bbbd5c4e..000000000 --- a/src/Ring2-Core/RGCompiledMethodLayout.class.st +++ /dev/null @@ -1,35 +0,0 @@ -Class { - #name : #RGCompiledMethodLayout, - #superclass : #RGObjectLayout, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'testing types' } -RGCompiledMethodLayout >> isBitsLayout [ - - ^ true -] - -{ #category : #'testing types' } -RGCompiledMethodLayout >> isByteLayout [ - - ^ true -] - -{ #category : #'testing types' } -RGCompiledMethodLayout >> isCompiledMethodLayout [ - - ^ true -] - -{ #category : #'testing types' } -RGCompiledMethodLayout >> isVariableLayout [ - - ^ true -] - -{ #category : #accessing } -RGCompiledMethodLayout >> layoutName [ - - ^ #CompiledMethodLayout -] diff --git a/src/Ring2-Core/RGElement.class.st b/src/Ring2-Core/RGElement.class.st deleted file mode 100644 index c003c6920..000000000 --- a/src/Ring2-Core/RGElement.class.st +++ /dev/null @@ -1,88 +0,0 @@ -" -RG2Element is the abstract class for representing elements of a class-alike definition (i.e., methods, variables, comment). - -parent holds the RG2ClassDefinition or RG2Metaclass defining this element. - - -Now a RingEntityDefinition offers two APIs: one that is generic and works for all the source code entities and this is the one we just -presented: parent, parentName and realParent. Having such interface is important to build generic tools that could manipulate -any entities in a polymorphic way (yes no isKindOf: everywhere). - -In addition, a ring method definition offers a specific interface that should only be used when you know that you are solely manipulate -specific entity such as class element: method definition, class comment, and variables. - -Here is the equivalence table - - realParent realClass - parent ringClass - parentName className - -For example for a methodDefinition we will have the following: - -GENERIC API ------------------- -* To access the ring class definition name, use parentName - aRG2MethodDefinition parentName - -Example: - (Point>>#dist:) asRing2Definition parentName - -> #Point - -* If you have a complete model where classes and methods are ring definition, to access the ring class definition , use parent - aRG2MethodDefinition parent - -Example: - aRG2MethodDefinition(Point>>#dist:) parent - -> aRG2ClassDefinition(Point) - -* If you want to access the smalltalk class that contains the compiledMethod that is represented by a ringMethodDefinition, use realParent - aRG2MethodDefinition realParent - -Example: - (Point>>#dist:) asRing2Definition realParent - -> Point - - - -CLASS Element specific API ------------------------------------------- -* The message class returns the class of the object :). Yes as you see we could not use class and className because class is already used to refer to the class of the object. - -Example: - (Point>>#dist:) asRing2Definition class - -> RingMethodDefinition - -* The message className returns the name of the ring class defining the reingMethodDefinition. - -Example: - (Point>>#dist:) asRing2Definition className - -> #Point - -* If you have a complete model where classes and methods are ring definition, to access the ring class definition , use parent - aRG2MethodDefinition ringClass - -Example: - aRG2MethodDefinition(Point>>#dist:) ringClass - -> aRG2ClassDefinition(Point) - - -* If you want to access the smalltalk class that contains the compiledMethod that is represented by a ringMethodDefinition, use realClass - aRG2MethodDefinition realClass - -Example: - (Point>>#dist:) asRing2Definition realClass - -> Point - - -" -Class { - #name : #RGElement, - #superclass : #RGObject, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #accessing } -RGElement >> package [ - - ^ self parent package -] diff --git a/src/Ring2-Core/RGEmptyLayout.class.st b/src/Ring2-Core/RGEmptyLayout.class.st deleted file mode 100644 index 92ddaef06..000000000 --- a/src/Ring2-Core/RGEmptyLayout.class.st +++ /dev/null @@ -1,17 +0,0 @@ -Class { - #name : #RGEmptyLayout, - #superclass : #RGLayout, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'testing types' } -RGEmptyLayout >> isEmptyLayout [ - - ^ true -] - -{ #category : #accessing } -RGEmptyLayout >> layoutName [ - - ^ #EmptyLayout -] diff --git a/src/Ring2-Core/RGEnvironment.class.st b/src/Ring2-Core/RGEnvironment.class.st deleted file mode 100644 index 33abe5a63..000000000 --- a/src/Ring2-Core/RGEnvironment.class.st +++ /dev/null @@ -1,959 +0,0 @@ -" -I'm a representation of a Pharo environment that contains behaviors, packages and global variables. I have my own announcer for processing of events inside of the environment. - -I'm connected to a data source - backend, that provides me real data I'm working with. - -In most cases, you should communicate with me using my query interface. You will get it by sending me a message #ask. - -" -Class { - #name : #RGEnvironment, - #superclass : #RGObject, - #instVars : [ - 'announcer', - 'behaviors', - 'packages', - 'globalVariables', - 'backend', - 'queryInterface', - 'version' - ], - #category : #'Ring2-Core-Environment' -} - -{ #category : #'accessing - backend' } -RGEnvironment >> addBehavior: anRGBehavior [ - - self backend forEnvironment - addBehavior: anRGBehavior - to: self. - anRGBehavior isMeta ifFalse: [ - anRGBehavior package - ifNotNil: [ :package | - self backend forEnvironment addPackage: anRGBehavior package to: self. - package addDefinedBehavior: anRGBehavior. ]. - "self backend forEnvironment - addGlobalVariable: (RGGlobalVariable named: anRGBehavior name parent: self) - to: self" ]. - - (anRGBehavior hasResolvedName) - ifTrue: [ self queryInterface behaviorsDictionary at: anRGBehavior name asSymbol put: anRGBehavior ]. - - -] - -{ #category : #'accessing - backend' } -RGEnvironment >> addGlobalVariable: anRGGlobalVariable [ - - self backend forBehavior addGlobalVariable: anRGGlobalVariable to: self. -] - -{ #category : #'accessing - backend' } -RGEnvironment >> addPackage: anRGPackageDefinition [ - - self backend forPackage addPackage: anRGPackageDefinition to: self. - - self announce: (RPackageRegistered to: anRGPackageDefinition). - -] - -{ #category : #accessing } -RGEnvironment >> announcer [ - - ^ announcer ifNil: [ announcer := RGEnvironmentAnnouncer new ] -] - -{ #category : #accessing } -RGEnvironment >> ask [ - - ^ queryInterface ifNil: [ queryInterface := RGEnvironmentQueryInterface for: self ]. -] - -{ #category : #accessing } -RGEnvironment >> backend [ - - ^ backend ifNil: [ backend := RGEnvironmentBackend for: self ]. -] - -{ #category : #accessing } -RGEnvironment >> backend: anRGEnvironmentBackend [ - - ^ backend := anRGEnvironmentBackend -] - -{ #category : #'accessing - backend' } -RGEnvironment >> behaviorsDo: aBlock [ - - self backend forEnvironment behaviorsFor: self do: aBlock -] - -{ #category : #binding } -RGEnvironment >> bindingOf: aSymbol [ - - | behavior result | - - self globalVariablesBindings at: aSymbol ifPresent: [ :val | ^ val ]. - - self ask globalVariables detect: [ :each | each name = aSymbol ] ifFound: [ :found | - self globalVariablesBindings at: aSymbol put: found. - ^ found ]. - - behavior := self ask behaviorNamed: aSymbol. - result := behavior ifNotNil: [ GlobalVariable key: aSymbol value: behavior]. - self globalVariablesBindings at: aSymbol put: result. - ^ result -] - -{ #category : #'as yet unclassified' } -RGEnvironment >> child: aChildDefinition renamedFrom: oldName to: newName [ - - self queryInterface behaviorsDictionary removeKey: oldName ifAbsent: []. - self queryInterface behaviorsDictionary at: newName asSymbol put: aChildDefinition. - -] - -{ #category : #cleaning } -RGEnvironment >> clean [ - - self cleanWithMetaclassNamed: #Metaclass - -] - -{ #category : #'accessing - backend' } -RGEnvironment >> cleanBehaviors [ - - | oldBehaviors | - - oldBehaviors := self ask behaviors. - - self backend forPackage cleanBehaviorsFor: self. - - oldBehaviors do: [ :each | - self announcer behaviorRemoved: each ]. - - self queryInterface resetBehaviorsDictionary. - -] - -{ #category : #'accessing - backend' } -RGEnvironment >> cleanGlobalVariables [ - - self backend forBehavior cleanGlobalVariablesFor: self. -] - -{ #category : #'accessing - backend' } -RGEnvironment >> cleanPackages [ - - self backend forEnvironment cleanPackagesFor: self -] - -{ #category : #cleaning } -RGEnvironment >> cleanSuperclassesOfMetaclasses [ - - "fix suprclasses of metaclasses do not pointing to metaclasses of superclasses" - - self ask behaviorsDo: [ :each | - (each isMetaclass and: [ each superclass isRingResolved not ]) - ifTrue: [ - each baseClass superclass ifNotNil: [ - each superclass: each baseClass superclass metaclass] ] ]. - -] - -{ #category : #cleaning } -RGEnvironment >> cleanUnusedUnreferencedBehaviors [ - - "remove behaviors that are not linked in the graph of the named behaviors" - - | referenced unreferenced newelyAdded | - - referenced := IdentitySet new. - self ask behaviorsDo: [ :each | - (each hasResolvedName) ifTrue: [ - referenced add: each. - referenced addAll: (each referencedBehaviors copyWithoutAll: {each. nil}) ] ]. - [ newelyAdded := IdentitySet new. - (referenced copyWithout: nil) do: [ :each | - each referencedBehaviors do: [ :ref | - (referenced includes: ref) ifFalse: [ - referenced add: ref. - newelyAdded add: ref]]]. - newelyAdded isEmpty ] whileFalse. - - unreferenced := (self ask behaviors copyWithoutAll: referenced). - - unreferenced do: [:each | self removeBehavior: each ]. - - ^ unreferenced -] - -{ #category : #cleaning } -RGEnvironment >> cleanUnusedUnreferencedPackages [ - - "remove packages that are not not used" - - | referenced unreferenced | - - referenced := IdentitySet new. - self ask behaviorsDo: [ :each | - referenced addAll: each referencedPackages ]. - - unreferenced := (self ask packages copyWithoutAll: referenced). - - unreferenced do: [:each | self removePackage: each ]. - - ^ unreferenced -] - -{ #category : #cleaning } -RGEnvironment >> cleanWithMetaclassNamed: aProposedName [ - - self unifyMetaclass: aProposedName. - self hasTraits ifTrue: [ - self unifyTrait. - self unifyClassTrait. ]. - self cleanSuperclassesOfMetaclasses. - self cleanUnusedUnreferencedBehaviors. - self cleanUnusedUnreferencedPackages. -] - -{ #category : #'as yet unclassified' } -RGEnvironment >> createDefaultEnvironment [ - - | protoobject protoobjectClass object objectClass class classClass classDescription classDescriptionClass behavior behaviorClass metaclass metaclassClass kernelPackage | - - protoobject := RGClass unresolvedNamed: #'ProtoObject' withParent: self. - protoobjectClass := RGMetaclass unresolvedNamed: #'ProtoObject class' withParent: self. - object := RGClass unresolvedNamed: #'Object' withParent: self. - objectClass := RGMetaclass unresolvedNamed: #'Object class' withParent: self. - class := RGClass unresolvedNamed: #'Class' withParent: self. - classClass := RGMetaclass unresolvedNamed: #'Class class' withParent: self. - classDescription := RGClass unresolvedNamed: #'ClassDescription' withParent: self. - classDescriptionClass := RGMetaclass unresolvedNamed: #'ClassDescription class' withParent: self. - behavior := RGClass unresolvedNamed: #'Behavior' withParent: self. - behaviorClass := RGMetaclass unresolvedNamed: #'Behavior class' withParent: self. - metaclass := RGClass unresolvedNamed: #'Metaclass' withParent: self. - metaclassClass := RGMetaclass unresolvedNamed: #'Metaclass class' withParent: self. - kernelPackage := RGPackageDefinition unresolvedNamed: #'Kernel' withParent: self. - - { protoobject. protoobjectClass. object. objectClass. class. classClass. classDescription. classDescriptionClass. behavior. behaviorClass. metaclass. metaclassClass } do: [ :each | - kernelPackage pvtAddDefinedBehavior: each. - self pvtAddBehavior: each.]. - self pvtAddPackage: kernelPackage. - - protoobject pvtSuperclass: protoobject. - protoobject pvtMetaclass: protoobjectClass. - protoobject behaviorStrategy pvtPackage: kernelPackage. - - protoobjectClass pvtSuperclass: class. - protoobjectClass pvtMetaclass: metaclass. - - object pvtSuperclass: protoobject. - object pvtMetaclass: objectClass. - object behaviorStrategy pvtPackage: kernelPackage. - - objectClass pvtSuperclass: protoobjectClass. - objectClass pvtMetaclass: metaclass. - - class pvtSuperclass: classDescription. - class pvtMetaclass: classClass. - class behaviorStrategy pvtPackage: kernelPackage. - - classClass pvtSuperclass: classDescriptionClass. - classClass pvtMetaclass: metaclass. - - classDescription pvtSuperclass: behavior. - classDescription pvtMetaclass: classDescriptionClass. - classDescription behaviorStrategy pvtPackage: kernelPackage. - - classDescriptionClass pvtSuperclass: behaviorClass. - classDescriptionClass pvtMetaclass: metaclass. - - behavior pvtSuperclass: object. - behavior pvtMetaclass: behaviorClass. - behavior behaviorStrategy pvtPackage: kernelPackage. - - behaviorClass pvtSuperclass: objectClass. - behaviorClass pvtMetaclass: metaclass. - - metaclass pvtSuperclass: classDescription. - metaclass pvtMetaclass: metaclassClass. - metaclass behaviorStrategy pvtPackage: kernelPackage. - - metaclassClass pvtSuperclass: classDescriptionClass. - metaclassClass pvtMetaclass: metaclass. - - - -] - -{ #category : #'default model values' } -RGEnvironment >> defaultBehaviors [ - - ^ IdentitySet new -] - -{ #category : #'default model values' } -RGEnvironment >> defaultGlobalVariables [ - - ^ IdentitySet new -] - -{ #category : #'default model values' } -RGEnvironment >> defaultPackages [ - - ^ IdentitySet new -] - -{ #category : #'default model values' } -RGEnvironment >> defaultVersion [ - - ^ 6 -] - -{ #category : #accessing } -RGEnvironment >> definitionFor: anObject [ - - ^ self backend definitionFor: anObject. -] - -{ #category : #'as yet unclassified' } -RGEnvironment >> ensureClassNamed: aSymbol [ - - self assert: (aSymbol endsWith: ' classTrait') not. - - ^ self ask behaviorNamedExactlyAs: aSymbol ifAbsent: [ - | behaviorClass newBehavior sibling siblingName | - siblingName := (aSymbol endsWith: ' class') - ifTrue: [ aSymbol withoutSuffix: ' class' ] - ifFalse: [ (aSymbol, 'class') asSymbol ]. - - sibling := self ask behaviors detect: [ :each | each name = siblingName ] ifNone: nil. - sibling ifNotNil: [ - | result | - result := sibling isMetaclass - ifTrue: [ sibling baseClass ] - ifFalse: [ sibling metaclass ]. - result name: aSymbol. - result propertyNamed: #resolved put: true. - ^ result ]. - - behaviorClass := (aSymbol endsWith: ' class') - ifFalse: [ RGClass ] - ifTrue: [ RGMetaclass ]. - newBehavior := behaviorClass named: aSymbol parent: self. - self addBehavior: newBehavior. - newBehavior ] -] - -{ #category : #cleaning } -RGEnvironment >> ensureClassTrait [ - - | aClassTrait | - - aClassTrait := self ask behaviorNamed: #ClassTrait. - aClassTrait ifNotNil: [ ^ aClassTrait ]. - - aClassTrait := self ask behaviors detect: [ :each | - (each propertyNamed: #ClassTrait ifAbsent: [ false ]) ] ifNone: [ nil ]. - aClassTrait ifNotNil: [ ^ aClassTrait ]. - - aClassTrait := self ensureClassNamed: #ClassTrait. - - aClassTrait propertyNamed: #ClassTrait put: true. - - ^ aClassTrait. -] - -{ #category : #cleaning } -RGEnvironment >> ensureMetaclass [ - - | aMetaclass | - - aMetaclass := self ask behaviorNamed: #Metaclass. - aMetaclass ifNotNil: [ ^ aMetaclass ]. - - aMetaclass := self ask behaviors detect: [ :each | - (each propertyNamed: #Metaclass ifAbsent: [ false ]) ] ifNone: [ nil ]. - aMetaclass ifNotNil: [ ^ aMetaclass ]. - - aMetaclass := self ensureClassNamed: #Metaclass. - - aMetaclass propertyNamed: #Metaclass put: true. - - ^ aMetaclass. -] - -{ #category : #cleaning } -RGEnvironment >> ensureMetaclass: aProposedName [ - - | aMetaclass | - - aMetaclass := self ask behaviorNamed: aProposedName. - aMetaclass ifNotNil: [ ^ aMetaclass ]. - - aMetaclass := self ask behaviors detect: [ :each | - (each propertyNamed: #Metaclass ifAbsent: [ false ]) ] ifNone: [ nil ]. - aMetaclass ifNotNil: [ ^ aMetaclass ]. - - aMetaclass := self ensureClassNamed: aProposedName. - - aMetaclass propertyNamed: #Metaclass put: true. - - ^ aMetaclass. -] - -{ #category : #'as yet unclassified' } -RGEnvironment >> ensureMetaclassTraitNamed: aSymbol [ - - | found newTrait newMetaclassTrait similarMetaclass similarMetaclassName siblingName sibling originalMetaclass | - - self assert: (aSymbol endsWith: ' class') not. - self assert: (aSymbol endsWith: ' classTrait'). - - found := self ask behaviorNamedExactlyAs: aSymbol. - (found notNil and: [ found isMetaclassTrait ]) ifTrue: [ ^ found ]. - - ^ found - ifNil: [ - "trait not found, check if the environment contains already a correspoinding trait" - siblingName := (aSymbol withoutSuffix: ' classTrait') asSymbol. - sibling := self ask behaviorNamedExactlyAs: siblingName. - sibling - ifNotNil: [ - "resolve and return existing corresponding trait" - | existing | - sibling isTrait - ifTrue: [ - existing := sibling classTrait. - existing name: aSymbol. - existing propertyNamed: #resolved put: true. - existing ] - ifFalse: [ - sibling convertToTrait. - sibling classSide convertToMetaclassTrait. - "sibling metaclass becomeForward: newMetaclassTrait. - originalMetaclass becomeForward: newMetaclassTrait. - sibling becomeForward: newTrait." - "sibling classTrait: newMetaclassTrait. - newMetaclassTrait baseTrait: sibling. - " - sibling classSide name: (siblingName, ' classTrait') asSymbol. - sibling classSide propertyNamed: #resolved put: true. - sibling classSide - ]] - ifNil: [ - similarMetaclassName := ((aSymbol withoutSuffix: ' classTrait'), ' class') asSymbol. - similarMetaclass := self ask behaviorNamed: similarMetaclassName. - similarMetaclass - ifNotNil: [ - "environment already contains metaclass of the similar name. It was probably - created because correct type was not known. Convert it to classTrait" - | similarClass | - similarClass := similarMetaclass baseClass. - newMetaclassTrait := similarMetaclass behaviorStrategy pvtAsMetaclassTrait. - newTrait := similarClass convertToTrait. - "similarMetaclass becomeForward: newMetaclassTrait. - similarClass becomeForward: newTrait." - newTrait classTrait: newMetaclassTrait. - newMetaclassTrait baseTrait: newTrait. - newTrait name: siblingName asSymbol. - newMetaclassTrait ] - ifNil: [ - "we need to create new behavior" - | newBehavior | - newBehavior := RGMetaclassTrait named: aSymbol parent: self. - self addBehavior: newBehavior. - newBehavior ] ] ] - ifNotNil: [ - "some non-trait behavior found. We created this trait before as a class because correct behavior type was not known." - newTrait := found convertToTrait. - originalMetaclass := found metaclass. - newMetaclassTrait := originalMetaclass pvtAsMetaclassTrait. - self ask replaceName: originalMetaclass name with: newMetaclassTrait name. - "found becomeForward: newTrait. - found metaclass becomeForward: newMetaclassTrait. - originalMetaclass becomeForward: newMetaclassTrait." - found ]. - - - -] - -{ #category : #'as yet unclassified' } -RGEnvironment >> ensurePackageNamed: aSymbol [ - - ^ self ask packages - detect: [:each | each name = aSymbol] - ifNone: [ | newPackage | - newPackage := RGPackageDefinition named: aSymbol parent: self. - self addPackage: newPackage. - newPackage ]. - - -] - -{ #category : #cleaning } -RGEnvironment >> ensureTrait [ - - | aTrait | - - aTrait := self ask behaviorNamed: #Trait. - aTrait ifNotNil: [ ^ aTrait ]. - - aTrait := self ask behaviors detect: [ :each | - (each propertyNamed: #Trait ifAbsent: [ false ]) ] ifNone: [ nil ]. - aTrait ifNotNil: [ ^ aTrait ]. - - aTrait := self ensureClassNamed: #Trait. - - aTrait propertyNamed: #Trait put: true. - - ^ aTrait. -] - -{ #category : #'as yet unclassified' } -RGEnvironment >> ensureTraitNamed: aSymbol [ - - | found siblingName sibling | - - self assert: (aSymbol endsWith: ' class') not. - - "process classTraits" - (aSymbol endsWith: ' classTrait') ifTrue: [ - ^ self ensureMetaclassTraitNamed: aSymbol ]. - - "a trait with the same name already exists" - found := self ask behaviorNamedExactlyAs: aSymbol. - (found notNil and: [ found isTrait ]) ifTrue: [ ^ found ]. - - ^ found - ifNil: [ - "trait not found, check if the environment contains already a correspoinding metaclass trait" - siblingName := (aSymbol, ' classTrait') asSymbol. - sibling := self ask behaviorNamedExactlyAs: siblingName. - sibling - ifNotNil: [ - "resolve and return existing corresponding trait" - | existing | - existing := sibling baseTrait. - existing name: aSymbol. - existing propertyNamed: #resolved put: true. - existing ] - ifNil: [ - "we need to create new behavior" - | newBehavior | - newBehavior := RGTrait named: aSymbol parent: self. - self addBehavior: newBehavior. - newBehavior ] ] - ifNotNil: [ - "some non-trait behavior found. We created this trait before as a class because correct behavior type was not known." - found convertToTrait. - found metaclass convertToMetaclassTrait. - found ]. - - -] - -{ #category : #'unpackaged ' } -RGEnvironment >> ensureUnpackagedPackage [ - - ^ self unpackagedPackageOrNil - ifNotNil: [ :found | found ] - ifNil: [ | newPackage | - newPackage := RGPackageDefinition unresolvedWithParent: self. - newPackage pvtName: self unpackagedPackageName. - self pvtAddPackage: newPackage. - ^ newPackage ] -] - -{ #category : #accessing } -RGEnvironment >> environment [ - - ^ self -] - -{ #category : #'as yet unclassified' } -RGEnvironment >> fixProtoObjectClassSuperclass [ - - (self ask classNamed: #'ProtoObject class') superclass: (self ask classNamed: #Class). - -] - -{ #category : #'as yet unclassified' } -RGEnvironment >> globalVariablesBindings [ - - ^ self propertyNamed: #globalVariablesBindings ifAbsentPut: [ IdentityDictionary new.] -] - -{ #category : #'accessing - backend' } -RGEnvironment >> globalVariablesDo: aBlock [ - - self backend forBehavior globalVariablesFor: self do: aBlock -] - -{ #category : #'as yet unclassified' } -RGEnvironment >> hasTraits [ - - self behaviorsDo: [ :each | - each isTrait ifTrue: [ ^ true ] ]. - - ^ false -] - -{ #category : #initialization } -RGEnvironment >> initialize [ - - super initialize. - - behaviors := self unresolvedValue: self defaultBehaviors. - packages := self unresolvedValue: self defaultPackages. - globalVariables := self unresolvedValue: self defaultGlobalVariables. - - version := self defaultVersion - - -] - -{ #category : #initialization } -RGEnvironment >> initializeUnresolved [ - - super initializeUnresolved. - - behaviors := self unresolvedValue: self defaultBehaviors. - packages := self unresolvedValue: self defaultPackages. - globalVariables := self unresolvedValue: self defaultGlobalVariables. - - version := self defaultVersion - -] - -{ #category : #'testing types' } -RGEnvironment >> isEnvironment [ - - ^ true -] - -{ #category : #resolving } -RGEnvironment >> makeResolved [ - - super makeResolved. - - behaviors := self ask behaviors markAsRingResolved. - packages := self ask packages markAsRingResolved. - globalVariables := self ask globalVariables markAsRingResolved. - - -] - -{ #category : #accessing } -RGEnvironment >> package [ - - ^ nil -] - -{ #category : #'accessing - backend' } -RGEnvironment >> packagesDo: aBlock [ - - self backend packagesFor: self do: aBlock -] - -{ #category : #'private - backend interface' } -RGEnvironment >> pvtAddBehavior: anRGBehavior [ - - self environment verifyOwnership: anRGBehavior. - - behaviors isRingResolved ifFalse: [ - self pvtCleanBehaviors ]. - - (behaviors includes: anRGBehavior) - ifFalse: [ - behaviors add: anRGBehavior. - self announcer behaviorAdded: anRGBehavior]. - - - -] - -{ #category : #'private - backend access' } -RGEnvironment >> pvtAddGlobalVariable: anRGGlobalVariable [ - - self environment verifyOwnership: anRGGlobalVariable. - - globalVariables isRingResolved ifFalse: [ - self pvtCleanGlobalVariables ]. - - globalVariables add: anRGGlobalVariable. -] - -{ #category : #'private - backend interface' } -RGEnvironment >> pvtAddPackage: anRGPackageDefinition [ - - self environment verifyOwnership: anRGPackageDefinition. - - packages isRingResolved ifFalse: [ - self pvtCleanPackages ]. - - packages add: anRGPackageDefinition. - -] - -{ #category : #'private - backend interface' } -RGEnvironment >> pvtBehaviorsDo: aBlock [ - - ^ behaviors value do: aBlock -] - -{ #category : #'private - backend interface' } -RGEnvironment >> pvtCleanBehaviors [ - - behaviors := self defaultBehaviors. - - "TODO:Announce if not empty" - - -] - -{ #category : #'private - backend access' } -RGEnvironment >> pvtCleanGlobalVariables [ - - globalVariables := self defaultGlobalVariables. -] - -{ #category : #'private - backend interface' } -RGEnvironment >> pvtCleanPackages [ - - packages := self defaultPackages. - - "TODO:Announce if not empty" - - -] - -{ #category : #'private - backend access' } -RGEnvironment >> pvtGlobalVariablesDo: aBlock [ - - globalVariables value do: aBlock -] - -{ #category : #'private - backend interface' } -RGEnvironment >> pvtPackagesDo: aBlock [ - - ^ packages value do: aBlock -] - -{ #category : #'private - backend interface' } -RGEnvironment >> pvtRemoveBehavior: anRGBehavior [ - - self verifyOwnership: anRGBehavior. - - behaviors remove: anRGBehavior. - - "TODO:Announce" - - -] - -{ #category : #'private - backend access' } -RGEnvironment >> pvtRemoveGlobalVariable: anRGGlobalVariable [ - - self environment verifyOwnership: anRGGlobalVariable. - - globalVariables remove: anRGGlobalVariable. -] - -{ #category : #'private - backend interface' } -RGEnvironment >> pvtRemovePackage: anRGPackageDefinition [ - - self verifyOwnership: anRGPackageDefinition. - - packages remove: anRGPackageDefinition. - - "TODO:Announce" - - -] - -{ #category : #'private - backend interface' } -RGEnvironment >> pvtResolvableProperties [ - - ^ super pvtResolvableProperties, { - #behaviors -> behaviors. - #packages -> packages. - #globalVariables -> globalVariables. - } - - -] - -{ #category : #accessing } -RGEnvironment >> queryInterface [ - - ^ self ask -] - -{ #category : #'accessing - backend' } -RGEnvironment >> removeBehavior: anRGBehavior [ - - self backend forEnvironment removeBehavior: anRGBehavior from: self. - - "remove extensions methods deleted with the behavior from owning packages" - anRGBehavior extensions do: [ :each | - each package removeExtensionMethod: each ]. - - (anRGBehavior package notNil and: [anRGBehavior package definedBehaviors includes: anRGBehavior]) ifTrue: [ - anRGBehavior package removeDefinedBehavior: anRGBehavior. - ]. - - self announcer behaviorRemoved: anRGBehavior. - - (anRGBehavior hasResolvedName) ifTrue: [ - self queryInterface behaviorsDictionary removeKey: anRGBehavior name ifAbsent: []]. - -] - -{ #category : #'accessing - backend' } -RGEnvironment >> removeGlobalVariable: anRGGlobalVariable [ - - self backend forBehavior removeGlobalVariable: anRGGlobalVariable from: self -] - -{ #category : #'accessing - backend' } -RGEnvironment >> removePackage: anRGPackageDefinition [ - - self backend forPackage removePackage: anRGPackageDefinition from: self. - - self announce: (RPackageUnregistered to: anRGPackageDefinition). - -] - -{ #category : #'unpackaged ' } -RGEnvironment >> removeUnusedPackages [ - - "remove all packages that are not used in the system. It cannot be done automatically - for every change in the package structure because then it would be impossible to - create e.g. an environment with one empty package" - - | usedPackages | - - usedPackages := IdentitySet new. - self behaviorsDo: [ :behavior | - behavior isMeta - ifFalse: [ usedPackages add: behavior package]. - behavior localMethodsDo: [ :method | - usedPackages add: method package]]. - - self ask packages copy do: [ :each | - (usedPackages includes: each) - ifFalse: [ self removePackage: each ] ]. -] - -{ #category : #cleaning } -RGEnvironment >> unifyClassTrait [ - - "set all metaclasses of classTraits to the same object (ClassTrait) " - - | aTrait | - - aTrait := self ensureClassTrait. - - self ask behaviorsDo: [ :each | - (each isMetaclassTrait) - ifTrue: [ each metaclass: aTrait]]. - -] - -{ #category : #cleaning } -RGEnvironment >> unifyMetaclass [ - - "set all metaclasses of metaclasses to the same object (Metaclass) " - - | aMetaclass | - - aMetaclass := self ensureMetaclass. - - self ask behaviorsDo: [ :each | - (each isMetaclass) - ifTrue: [ each metaclass: aMetaclass] ]. - -] - -{ #category : #cleaning } -RGEnvironment >> unifyMetaclass: aProposedName [ - - "set all metaclasses of metaclasses to the same object (Metaclass) " - - | aMetaclass | - - aMetaclass := self ensureMetaclass: aProposedName. - - self ask behaviorsDo: [ :each | - (each isMetaclass) - ifTrue: [ each metaclass: aMetaclass] ]. - -] - -{ #category : #cleaning } -RGEnvironment >> unifyTrait [ - - "set all metaclasses of metaclasses to the same object (Metaclass) " - - | aTrait | - - aTrait := self ensureTrait. - - self ask behaviorsDo: [ :each | - (each isTrait) - ifTrue: [ each metaclass: aTrait]]. - - (self ask behaviors select: [ :each | each isRingResolved not and: [(each propertyNamed: #role) = #trait] ]) do: [:each | self removeBehavior: each ]. - - -] - -{ #category : #'unpackaged ' } -RGEnvironment >> unpackagedPackage [ - - | aProtocol | - aProtocol := RGPackageDefinition unresolvedWithParent: self. - aProtocol pvtName: self unpackagedPackageName. - - ^ aProtocol - -] - -{ #category : #'unpackaged ' } -RGEnvironment >> unpackagedPackageName [ - - ^ '_UnpackagedPackage' asSymbol -] - -{ #category : #'unpackaged ' } -RGEnvironment >> unpackagedPackageOrNil [ - - self packagesDo: [ :each | - (each name = self unpackagedPackageName) ifTrue: [ ^ each ] ]. - - ^ nil. - -] - -{ #category : #utility } -RGEnvironment >> verifyOwnership: anRGObject [ - - "ignore unresolved values. TODO: check default values ownership?" - anRGObject isRingResolved ifFalse: [ ^ self.]. - - (anRGObject environment = self) - ifFalse: [ RGWrongEnvironment signal ]. -] - -{ #category : #accessing } -RGEnvironment >> version [ - ^ version -] - -{ #category : #accessing } -RGEnvironment >> version: anObject [ - version := anObject -] diff --git a/src/Ring2-Core/RGEnvironmentAnnouncer.class.st b/src/Ring2-Core/RGEnvironmentAnnouncer.class.st deleted file mode 100644 index 0b21cbdc2..000000000 --- a/src/Ring2-Core/RGEnvironmentAnnouncer.class.st +++ /dev/null @@ -1,161 +0,0 @@ -" -This class plays the role of the announcer for events raised by the Pharo system. - -BEWARE: You should not need to subclass me. Think about just using me to send your announces (if you need system behavior) or using your own announcers as instance or class variables. -" -Class { - #name : #RGEnvironmentAnnouncer, - #superclass : #Announcer, - #instVars : [ - 'suspended', - 'private', - 'storedAnnouncements' - ], - #classInstVars : [ - 'announcer' - ], - #category : #'Ring2-Core-Announcements' -} - -{ #category : #announce } -RGEnvironmentAnnouncer >> announce: anAnnouncement [ - self isSuspended - ifFalse: [ - self private announce: anAnnouncement. - super announce: anAnnouncement ] - ifTrue:[ - storedAnnouncements ifNotNil:[ storedAnnouncements add: anAnnouncement ] - ]. -] - -{ #category : #triggering } -RGEnvironmentAnnouncer >> behaviorAdded: anRGBehavior [ - - self announce: (ClassAdded class: anRGBehavior category: nil) -] - -{ #category : #triggering } -RGEnvironmentAnnouncer >> behaviorCommentModified: anRGBehavior [ - - self announce: (ClassCommented classCommented: anRGBehavior) -] - -{ #category : #triggering } -RGEnvironmentAnnouncer >> behaviorDefinitionChangedFrom: oldRGBehavior to: newRGBehavior [ - - self announce: (ClassModifiedClassDefinition - classDefinitionChangedFrom: oldRGBehavior - to: newRGBehavior) -] - -{ #category : #triggering } -RGEnvironmentAnnouncer >> behaviorDefinitionModified: anRGBehavior [ - - self announce: (ClassModificationApplied toClass: anRGBehavior) -] - -{ #category : #triggering } -RGEnvironmentAnnouncer >> behaviorModificationAppliedTo: anRGBehavior [ - - self announce: (ClassModificationApplied toClass: anRGBehavior) -] - -{ #category : #triggering } -RGEnvironmentAnnouncer >> behaviorParentRenamed: anRGBehavior from: oldName [ - - self announce: (ClassParentRenamed - classParentOf: anRGBehavior - renamedFrom: oldName - to: anRGBehavior name) -] - -{ #category : #triggering } -RGEnvironmentAnnouncer >> behaviorRecategorized: anRGBehavior [ - - self announce: (ClassRecategorized - class: anRGBehavior - recategorizedFrom: nil - to: anRGBehavior category) -] - -{ #category : #triggering } -RGEnvironmentAnnouncer >> behaviorRemoved: anRGBehavior [ - - self announce: (ClassRemoved - class: anRGBehavior category: anRGBehavior category) -] - -{ #category : #triggering } -RGEnvironmentAnnouncer >> behaviorRenamed: anRGBehavior from: oldName [ - - self announce: (ClassRenamed - class: anRGBehavior - category: anRGBehavior category - oldName: oldName - newName: anRGBehavior name) -] - -{ #category : #triggering } -RGEnvironmentAnnouncer >> behaviorReorganized: anRGBehavior [ - - self announce: (ClassReorganized class: anRGBehavior) -] - -{ #category : #testing } -RGEnvironmentAnnouncer >> isSuspended [ - ^suspended ifNil: [ suspended := false ] -] - -{ #category : #triggering } -RGEnvironmentAnnouncer >> methodAdded: aMethod [ - - self announce: (MethodAdded method: aMethod) -] - -{ #category : #triggering } -RGEnvironmentAnnouncer >> methodRemoved: aMethod [ - - "TODO:" - self announce: (MethodRemoved methodRemoved: aMethod protocol: nil origin: nil) -] - -{ #category : #accessing } -RGEnvironmentAnnouncer >> private [ - ^private ifNil: [ private := Announcer new ] -] - -{ #category : #announce } -RGEnvironmentAnnouncer >> suspendAllWhile: aBlock [ - | oldSuspended | - oldSuspended := self isSuspended. - suspended := true. - ^aBlock ensure: [ suspended := oldSuspended ] -] - -{ #category : #announce } -RGEnvironmentAnnouncer >> suspendAllWhileStoring: aBlock [ - | reentring | - " Suspend all the announcements, storing them in an OrderedCollection, then returns this collection" - - reentring := storedAnnouncements isNotNil. - - reentring ifFalse:[ - storedAnnouncements := OrderedCollection new. - ]. - - [ - self suspendAllWhile: aBlock. - ^ storedAnnouncements. - ] ensure:[ - reentring ifFalse:[ - storedAnnouncements := nil. - ] - ] -] - -{ #category : #subscription } -RGEnvironmentAnnouncer >> unsubscribe: anObject [ - self private unsubscribe: anObject. - super unsubscribe: anObject. - -] diff --git a/src/Ring2-Core/RGEnvironmentBackend.class.st b/src/Ring2-Core/RGEnvironmentBackend.class.st deleted file mode 100644 index c6ddaa61b..000000000 --- a/src/Ring2-Core/RGEnvironmentBackend.class.st +++ /dev/null @@ -1,921 +0,0 @@ -Class { - #name : #RGEnvironmentBackend, - #superclass : #Object, - #instVars : [ - 'environment', - 'providedDefinitions' - ], - #category : #'Ring2-Core-Environment' -} - -{ #category : #'as yet unclassified' } -RGEnvironmentBackend class >> for: anRGEnvironment [ - - ^ self new - environment: anRGEnvironment; - yourself. -] - -{ #category : #'trait alias' } -RGEnvironmentBackend >> addAlias: aSymbol to: anRGTraitAlias [ - - ^ anRGTraitAlias pvtAddAlias: aSymbol -] - -{ #category : #environment } -RGEnvironmentBackend >> addBehavior: anRGBehavior to: anRGEnvironment [ - - ^ anRGEnvironment pvtAddBehavior: anRGBehavior -] - -{ #category : #package } -RGEnvironmentBackend >> addClassTag: aSymbol to: anRGPackageDefinition [ - - ^ anRGPackageDefinition pvtAddClassTag: aSymbol -] - -{ #category : #class } -RGEnvironmentBackend >> addClassVariable: anRGInstanceVariableDefinition to: anRGBehavior [ - - ^ anRGBehavior behaviorStrategy pvtAddClassVariable: anRGInstanceVariableDefinition -] - -{ #category : #package } -RGEnvironmentBackend >> addDefinedBehavior: anRGBehavior to: anRGPackageDefinition [ - - ^ anRGPackageDefinition pvtAddDefinedBehavior: anRGBehavior -] - -{ #category : #'trait exclusion' } -RGEnvironmentBackend >> addExclusion: aSymbol to: anRGTraitExclusion [ - - ^ anRGTraitExclusion pvtAddExclusion: aSymbol -] - -{ #category : #package } -RGEnvironmentBackend >> addExtensionMethod: anRGMethod to: anRGPackageDefinition [ - - ^ anRGPackageDefinition pvtAddExtensionMethod: anRGMethod -] - -{ #category : #environment } -RGEnvironmentBackend >> addGlobalVariable: anRGGlobalVariable to: anRGEnvironment [ - - ^ anRGEnvironment pvtAddGlobalVariable: anRGGlobalVariable -] - -{ #category : #behavior } -RGEnvironmentBackend >> addLocalMethod: anRGMethod to: anRGBehavior [ - - ^ anRGBehavior pvtAddLocalMethod: anRGMethod -] - -{ #category : #class } -RGEnvironmentBackend >> addMethodTag: aSymbol to: anRGBehavior [ - - ^ anRGBehavior pvtAddMethodTag: aSymbol -] - -{ #category : #environment } -RGEnvironmentBackend >> addPackage: anRGPackageDefinition to: anRGEnvironment [ - - ^ anRGEnvironment pvtAddPackage: anRGPackageDefinition -] - -{ #category : #class } -RGEnvironmentBackend >> addSharedPool: anRGPoolVariable to: anRGBehavior [ - - ^ anRGBehavior behaviorStrategy pvtAddSharedPool: anRGPoolVariable -] - -{ #category : #'pointer layout' } -RGEnvironmentBackend >> addSlot: anRGSlot to: anRGLayout [ - - ^ anRGLayout pvtAddSlot: anRGSlot -] - -{ #category : #'trait composition' } -RGEnvironmentBackend >> addTransformation: anRGTraitTransformation to: anRGTraitComposition [ - - ^ anRGTraitComposition pvtAddTransformation: anRGTraitTransformation -] - -{ #category : #'trait alias' } -RGEnvironmentBackend >> aliasesFor: anRGTraitAlias do: aBlock [ - - ^ anRGTraitAlias pvtAliasesDo: aBlock -] - -{ #category : #method } -RGEnvironmentBackend >> astFor: anRGMethod [ - - ^ anRGMethod astFromSource -] - -{ #category : #method } -RGEnvironmentBackend >> authorFor: anRGMethod [ - - ^ anRGMethod pvtAuthor -] - -{ #category : #metaclass } -RGEnvironmentBackend >> baseClassFor: anRGBehavior [ - - ^ anRGBehavior behaviorStrategy pvtBaseClass -] - -{ #category : #environment } -RGEnvironmentBackend >> behaviorsFor: anRGEnvironment do: aBlock [ - - ^ anRGEnvironment pvtBehaviorsDo: aBlock -] - -{ #category : #'class comment' } -RGEnvironmentBackend >> classCommentAuthorFor: anRGComment [ - - ^ anRGComment pvtAuthor -] - -{ #category : #'class comment' } -RGEnvironmentBackend >> classCommentContentFor: anRGComment [ - - ^ anRGComment pvtContent - -] - -{ #category : #'class comment' } -RGEnvironmentBackend >> classCommentTimeFor: anRGComment [ - - ^ anRGComment pvtTime -] - -{ #category : #trait } -RGEnvironmentBackend >> classTraitFor: anRGTrait [ - - ^ anRGTrait behaviorStrategy pvtClassTrait -] - -{ #category : #class } -RGEnvironmentBackend >> classVariablesFor: anRGBehavior do: aBlock [ - - ^ anRGBehavior behaviorStrategy pvtClassVariablesDo: aBlock -] - -{ #category : #'trait alias' } -RGEnvironmentBackend >> cleanAliasesFor: anRGTraitAlias [ - - ^ anRGTraitAlias pvtCleanAliases -] - -{ #category : #environment } -RGEnvironmentBackend >> cleanBehaviorsFor: anRGEnvironment [ - - anRGEnvironment pvtCleanBehaviors. -] - -{ #category : #class } -RGEnvironmentBackend >> cleanClassTagsFor: anRGBehavior [ - - anRGBehavior pvtCleanTags. -] - -{ #category : #class } -RGEnvironmentBackend >> cleanClassVariablesFor: anRGBehavior [ - - ^ anRGBehavior behaviorStrategy pvtCleanClassVariables -] - -{ #category : #package } -RGEnvironmentBackend >> cleanDefinedBehaviorsFor: anRGPackageDefinition [ - - anRGPackageDefinition pvtCleanDefinedBehaviors. -] - -{ #category : #'trait exclusion' } -RGEnvironmentBackend >> cleanExclusionsFor: anRGTraitExclusion [ - - ^ anRGTraitExclusion pvtCleanExclusions -] - -{ #category : #package } -RGEnvironmentBackend >> cleanExtensionMethodsFor: anRGPackageDefinition [ - - anRGPackageDefinition pvtCleanExtensionMethods -] - -{ #category : #environment } -RGEnvironmentBackend >> cleanGlobalVariablesFor: anRGEnvironment [ - - ^ anRGEnvironment pvtCleanGlobalVariables -] - -{ #category : #behavior } -RGEnvironmentBackend >> cleanLocalMethodsFor: anRGBehavior [ - - ^ anRGBehavior pvtCleanLocalMethods -] - -{ #category : #method } -RGEnvironmentBackend >> cleanMethodTagsFor: anRGMethod [ - - anRGMethod pvtCleanTags. -] - -{ #category : #environment } -RGEnvironmentBackend >> cleanPackagesFor: anRGEnvironment [ - - anRGEnvironment pvtCleanPackages -] - -{ #category : #class } -RGEnvironmentBackend >> cleanSharedPoolsFor: anRGBehavior [ - - ^ anRGBehavior behaviorStrategy pvtCleanSharedPools -] - -{ #category : #'pointer layout' } -RGEnvironmentBackend >> cleanSlotsFor: anRGLayout [ - - ^ anRGLayout pvtCleanSlots -] - -{ #category : #package } -RGEnvironmentBackend >> cleanTagsForClassesFor: anRGPackageDefinition [ - - anRGPackageDefinition pvtCleanTagsForClasses. -] - -{ #category : #class } -RGEnvironmentBackend >> cleanTagsForMethodsFor: anRGBehavior [ - - anRGBehavior pvtCleanTagsForMethods. -] - -{ #category : #'trait composition' } -RGEnvironmentBackend >> cleanTransformationsFor: anRGTraitComposition [ - - ^ anRGTraitComposition pvtCleanTransformations -] - -{ #category : #class } -RGEnvironmentBackend >> commentFor: anRGBehavior [ - - ^ anRGBehavior behaviorStrategy pvtComment -] - -{ #category : #'unresolved objects' } -RGEnvironmentBackend >> createNewUnresolvedClass [ - - | classStub metaclassStub packageStub | - - classStub := RGClass unresolvedWithParent: self environment. - packageStub := RGPackageDefinition unresolvedWithParent: self environment. - classStub behaviorStrategy pvtPackage: packageStub. - packageStub pvtAddDefinedBehavior: classStub. - metaclassStub := self createNewUnresolvedMetaclassFor: classStub. - - classStub pvtSuperclass: classStub. - classStub pvtMetaclass: metaclassStub. - classStub pvtPackage: packageStub. - packageStub pvtAddDefinedBehavior: classStub. - self environment pvtAddBehavior: classStub. - self environment pvtAddPackage: packageStub. - - ^ classStub - - - -] - -{ #category : #'unresolved objects' } -RGEnvironmentBackend >> createNewUnresolvedMetaclassFor: anRGBehavior [ - - | metaclassStub superclassMetaclass | - - metaclassStub := RGMetaclass unresolvedWithParent: self environment. - - superclassMetaclass := anRGBehavior pvtSuperclass pvtMetaclass. - superclassMetaclass - ifNotNil: [ - metaclassStub pvtSuperclass: superclassMetaclass. - metaclassStub pvtMetaclass: superclassMetaclass ] - ifNil: [ - metaclassStub pvtSuperclass: metaclassStub. - metaclassStub pvtMetaclass: metaclassStub ]. - self environment pvtAddBehavior: metaclassStub. - - ^ metaclassStub - -] - -{ #category : #'unresolved objects' } -RGEnvironmentBackend >> createUnresolvedClassGroupFor: anRGBehavior [ - - | classStub metaclassStub superclassStub superclassMetaclassStub packageStub1 packageStub2 | - - classStub := anRGBehavior isMeta - ifFalse: [ anRGBehavior ] - ifTrue: [ RGClass unresolvedWithParent: self environment ]. - classStub propertyNamed: #creator put: anRGBehavior. - classStub propertyNamed: #role put: #class. - - metaclassStub := anRGBehavior isMeta - ifFalse: [ RGMetaclass unresolvedWithParent: self environment ] - ifTrue: [ anRGBehavior ]. - metaclassStub propertyNamed: #creator put: anRGBehavior. - metaclassStub propertyNamed: #role put: #metaclass. - - superclassStub := RGClass unresolvedWithParent: self environment. - superclassStub propertyNamed: #creator put: anRGBehavior. - superclassStub propertyNamed: #role put: #superclass. - - superclassMetaclassStub := RGMetaclass unresolvedWithParent: self environment. - superclassMetaclassStub propertyNamed: #creator put: anRGBehavior. - superclassMetaclassStub propertyNamed: #role put: #superclassMetaclass. - - packageStub1 := RGPackageDefinition unresolvedWithParent: self environment. - classStub behaviorStrategy pvtPackage: packageStub1. - self environment pvtAddPackage: packageStub1. - packageStub1 pvtAddDefinedBehavior: classStub. - packageStub1 propertyNamed: #creator put: anRGBehavior. - packageStub1 propertyNamed: #role put: #package. - - packageStub2 := RGPackageDefinition unresolvedWithParent: self environment. - superclassStub behaviorStrategy pvtPackage: packageStub2. - self environment pvtAddPackage: packageStub2. - packageStub2 pvtAddDefinedBehavior: superclassStub. - packageStub2 propertyNamed: #creator put: anRGBehavior. - packageStub2 propertyNamed: #role put: #superclassPackage. - - classStub pvtSuperclass: superclassStub. - classStub pvtMetaclass: metaclassStub. - - superclassStub pvtSuperclass: superclassStub. - superclassStub pvtMetaclass: superclassMetaclassStub. - - metaclassStub pvtSuperclass: superclassMetaclassStub. - metaclassStub pvtMetaclass: superclassMetaclassStub. - metaclassStub behaviorStrategy pvtBaseClass: classStub. - - superclassMetaclassStub pvtSuperclass: superclassMetaclassStub. - superclassMetaclassStub pvtMetaclass: superclassMetaclassStub. - superclassMetaclassStub behaviorStrategy pvtBaseClass: superclassStub. - - self environment pvtAddBehavior: classStub. - self environment pvtAddBehavior: metaclassStub. - self environment pvtAddBehavior: superclassStub. - self environment pvtAddBehavior: superclassMetaclassStub. - - - ^ anRGBehavior isMeta - ifFalse: [ metaclassStub ] - ifTrue: [ classStub ]. - -] - -{ #category : #'unresolved objects' } -RGEnvironmentBackend >> createUnresolvedTraitGroupFor: anRGBehavior [ - - | traitStub classTraitStub traitMetaclassStub classTraitMetaclassStub packageStub1 | - - traitStub := anRGBehavior isMeta - ifFalse: [ anRGBehavior ] - ifTrue: [ RGTrait unresolvedWithParent: self environment ]. - traitStub propertyNamed: #creator put: anRGBehavior. - traitStub propertyNamed: #role put: #trait. - - classTraitStub := anRGBehavior isMeta - ifFalse: [ RGMetaclassTrait unresolvedWithParent: self environment ] - ifTrue: [ anRGBehavior ]. - classTraitStub propertyNamed: #creator put: anRGBehavior. - classTraitStub propertyNamed: #role put: #classTrait. - - "Trait" - traitMetaclassStub := RGClass unresolvedWithParent: self environment. - self createUnresolvedClassGroupFor: traitMetaclassStub. - traitMetaclassStub propertyNamed: #creator put: anRGBehavior. - traitMetaclassStub propertyNamed: #role put: #traitMetaclass. - - "ClassTrait" - classTraitMetaclassStub := RGClass unresolvedWithParent: self environment. - self createUnresolvedClassGroupFor: classTraitMetaclassStub. - classTraitMetaclassStub propertyNamed: #creator put: anRGBehavior. - classTraitMetaclassStub propertyNamed: #role put: #classTraitMetaclass. - - packageStub1 := RGPackageDefinition unresolvedWithParent: self environment. - packageStub1 propertyNamed: #creator put: anRGBehavior. - packageStub1 propertyNamed: #role put: #traitMetaclassPackage. - - traitStub behaviorStrategy pvtPackage: packageStub1. - packageStub1 pvtAddDefinedBehavior: traitStub. - traitStub pvtSuperclass: traitStub. - traitStub pvtMetaclass: traitMetaclassStub. - traitStub behaviorStrategy pvtClassTrait: classTraitStub. - - classTraitStub pvtSuperclass: classTraitStub. - classTraitStub pvtMetaclass: classTraitMetaclassStub. - classTraitStub behaviorStrategy pvtBaseTrait: traitStub. - - self environment pvtAddBehavior: traitStub. - self environment pvtAddBehavior: classTraitStub. - self environment pvtAddBehavior: traitMetaclassStub. - self environment pvtAddBehavior: classTraitMetaclassStub. - self environment pvtAddPackage: packageStub1. - - ^ anRGBehavior isMeta - ifFalse: [ traitStub ] - ifTrue: [ classTraitStub ]. - -] - -{ #category : #package } -RGEnvironmentBackend >> definedBehaviorsFor: anRGPackageDefinition do: aBlock [ - - ^ anRGPackageDefinition pvtDefinedBehaviorsDo: aBlock -] - -{ #category : #accesing } -RGEnvironmentBackend >> definitionFor: anObject [ - - ^ self definitionFor: anObject ifAbsentRegister: [ anObject ensureRingDefinitionIn: self environment ] - -] - -{ #category : #accesing } -RGEnvironmentBackend >> definitionFor: anObject ifAbsentRegister: aDefinitionOrBlock [ - - ^ providedDefinitions at: anObject - ifPresent: [:definition | definition ] - ifAbsentPut: [ aDefinitionOrBlock value ]. -] - -{ #category : #accesing } -RGEnvironmentBackend >> environment [ - - ^ environment -] - -{ #category : #accesing } -RGEnvironmentBackend >> environment: anRGEnironment [ - - environment := anRGEnironment -] - -{ #category : #'trait exclusion' } -RGEnvironmentBackend >> exclusionsFor: anRGTraitExclusion do: aBlock [ - - ^ anRGTraitExclusion pvtExclusionsDo: aBlock -] - -{ #category : #slot } -RGEnvironmentBackend >> expressionFor: anRGUnknownSlot [ - - ^ anRGUnknownSlot pvtExpression -] - -{ #category : #package } -RGEnvironmentBackend >> extensionMethodsFor: anRGPackageDefinition do: aBlock [ - - ^ anRGPackageDefinition pvtExtensionMethodsDo: aBlock -] - -{ #category : #subbackends } -RGEnvironmentBackend >> forBehavior [ - - ^ self -] - -{ #category : #subbackends } -RGEnvironmentBackend >> forEnvironment [ - - ^ self -] - -{ #category : #subbackends } -RGEnvironmentBackend >> forMethod [ - - ^ self -] - -{ #category : #subbackends } -RGEnvironmentBackend >> forPackage [ - - ^ self -] - -{ #category : #environment } -RGEnvironmentBackend >> globalVariablesFor: anRGEnvironment do: aBlock [ - - ^ anRGEnvironment pvtGlobalVariablesDo: aBlock -] - -{ #category : #resolving } -RGEnvironmentBackend >> hasFullyResolved: anRGObject [ - - ^ anRGObject pvtFullyResolved - -] - -{ #category : #resolving } -RGEnvironmentBackend >> hasFullyUnresolved: anRGObject [ - - ^ anRGObject pvtFullyUnresolved -] - -{ #category : #method } -RGEnvironmentBackend >> hasSourceCodeFor: anRGMethod [ - - ^ anRGMethod pvtSourceCode notNil -] - -{ #category : #initialization } -RGEnvironmentBackend >> initialize [ - - super initialize. - - providedDefinitions := IdentityDictionary new. -] - -{ #category : #behavior } -RGEnvironmentBackend >> layoutFor: anRGBehavior [ - - ^ anRGBehavior behaviorStrategy pvtLayout -] - -{ #category : #behavior } -RGEnvironmentBackend >> localMethodsFor: anRGBehavior do: aBlock [ - - ^ anRGBehavior pvtLocalMethodsDo: aBlock -] - -{ #category : #'as yet unclassified' } -RGEnvironmentBackend >> metaclassFor: anRGBehavior [ - - ^ anRGBehavior pvtMetaclass -] - -{ #category : #'metaclass trait' } -RGEnvironmentBackend >> metaclassTraitBaseTraitFor: anRGMetaclassTrait [ - - ^ anRGMetaclassTrait behaviorStrategy pvtBaseTrait -] - -{ #category : #method } -RGEnvironmentBackend >> methodPackageFor: anRGMethod [ - - ^ anRGMethod pvtPackage -] - -{ #category : #general } -RGEnvironmentBackend >> nameFor: anRGObject [ - - ^ anRGObject pvtName -] - -{ #category : #class } -RGEnvironmentBackend >> packageFor: anRGBehavior [ - - ^ anRGBehavior behaviorStrategy pvtPackage -] - -{ #category : #environment } -RGEnvironmentBackend >> packagesFor: anRGEnvironment do: aBlock [ - - ^ anRGEnvironment pvtPackagesDo: aBlock -] - -{ #category : #'trait alias' } -RGEnvironmentBackend >> removeAlias: aSymbol from: anRGTraitAlias [ - - ^ anRGTraitAlias pvtRemoveAlias: aSymbol -] - -{ #category : #environment } -RGEnvironmentBackend >> removeBehavior: anRGBehavior from: anRGEnvironment [ - - anRGEnvironment pvtRemoveBehavior: anRGBehavior. - - -] - -{ #category : #package } -RGEnvironmentBackend >> removeClassTag: aSymbol from: anRGPackageDefinition [ - - ^ anRGPackageDefinition pvtRemoveClassTag: aSymbol -] - -{ #category : #class } -RGEnvironmentBackend >> removeClassVariable: anRGInstanceVariableDefinition from: anRGBehavior [ - - ^ anRGBehavior behaviorStrategy pvtRemoveClassVariable: anRGInstanceVariableDefinition -] - -{ #category : #package } -RGEnvironmentBackend >> removeDefinedBehavior: anRGBehavior from: anRGPackageDefinition [ - - ^ anRGPackageDefinition pvtRemoveDefinedBehavior: anRGBehavior -] - -{ #category : #'trait exclusion' } -RGEnvironmentBackend >> removeExclusion: aSymbol from: anRGTraitExclusion [ - - ^ anRGTraitExclusion pvtRemoveExclusion: aSymbol -] - -{ #category : #package } -RGEnvironmentBackend >> removeExtensionMethod: anRGMethod from: anRGPackageDefinition [ - - ^ anRGPackageDefinition pvtRemoveExtensionMethod: anRGMethod -] - -{ #category : #environment } -RGEnvironmentBackend >> removeGlobalVariable: anRGGlobalVariable from: anRGEnvironment [ - - ^ anRGEnvironment pvtRemoveGlobalVariable: anRGGlobalVariable -] - -{ #category : #behavior } -RGEnvironmentBackend >> removeLocalMethod: anRGMethod from: anRGBehavior [ - - ^ anRGBehavior pvtRemoveLocalMethod: anRGMethod -] - -{ #category : #class } -RGEnvironmentBackend >> removeMethodTag: aSymbol from: anRGBehavior [ - - ^ anRGBehavior pvtRemoveMethodTag: aSymbol -] - -{ #category : #environment } -RGEnvironmentBackend >> removePackage: anRGPackageDefinition from: anRGEnvironment [ - - ^ anRGEnvironment pvtRemovePackage: anRGPackageDefinition -] - -{ #category : #class } -RGEnvironmentBackend >> removeSharedPool: anRGPoolVariable from: anRGBehavior [ - - ^ anRGBehavior behaviorStrategy pvtRemoveSharedPool: anRGPoolVariable -] - -{ #category : #'pointer layout' } -RGEnvironmentBackend >> removeSlot: anRGSlot from: anRGLayout [ - - ^ anRGLayout pvtRemoveSlot: anRGSlot -] - -{ #category : #'trait composition' } -RGEnvironmentBackend >> removeTransformation: anRGTraitTransformation from: anRGTraitComposition [ - - ^ anRGTraitComposition pvtRemoveTransformation: anRGTraitTransformation -] - -{ #category : #resolving } -RGEnvironmentBackend >> resolvedPropertiesFor: anRGObject [ - - ^ anRGObject pvtResolvedProperties -] - -{ #category : #method } -RGEnvironmentBackend >> setAuthorFor: anRGMethod to: aDateAndTime [ - - ^ anRGMethod pvtAuthor: aDateAndTime -] - -{ #category : #metaclass } -RGEnvironmentBackend >> setBaseClassFor: anRGBehavior to: anRGClass [ - - ^ anRGBehavior behaviorStrategy pvtBaseClass: anRGClass -] - -{ #category : #'class comment' } -RGEnvironmentBackend >> setClassCommentAuthorFor: anRGComment to: aString [ - - ^ anRGComment pvtAuthor: aString -] - -{ #category : #'class comment' } -RGEnvironmentBackend >> setClassCommentContentFor: anRGComment to: anObject [ - - anRGComment pvtContent: anObject. - -] - -{ #category : #'class comment' } -RGEnvironmentBackend >> setClassCommentTimeFor: anRGComment to: aDateAndTime [ - - ^ anRGComment pvtTime: aDateAndTime -] - -{ #category : #trait } -RGEnvironmentBackend >> setClassTraitFor: anRGTrait to: anRGMetatraitDefinition [ - - ^ anRGTrait behaviorStrategy pvtClassTrait: anRGMetatraitDefinition -] - -{ #category : #class } -RGEnvironmentBackend >> setCommentFor: anRGBehavior to: anRGComment [ - - ^ anRGBehavior behaviorStrategy pvtComment: anRGComment -] - -{ #category : #slot } -RGEnvironmentBackend >> setExpressionFor: anRGUnknownSlot to: aString [ - - ^ anRGUnknownSlot pvtExpression: aString -] - -{ #category : #behavior } -RGEnvironmentBackend >> setLayoutFor: anRGBehavior to: anRGLayout [ - - ^ anRGBehavior behaviorStrategy pvtLayout: anRGLayout -] - -{ #category : #'as yet unclassified' } -RGEnvironmentBackend >> setMetaclassFor: anRGBehavior to: anRGMetaclass [ - - ^ anRGBehavior pvtMetaclass: anRGMetaclass -] - -{ #category : #'metaclass trait' } -RGEnvironmentBackend >> setMetaclassTraitBaseTraitFor: anRGMetaclassTrait to: anRGTrait [ - - ^ anRGMetaclassTrait pvtBaseTrait: anRGTrait -] - -{ #category : #method } -RGEnvironmentBackend >> setMethodPackageFor: anRGMethod to: anRGPackageDefinition [ - - ^ anRGMethod pvtPackage: anRGPackageDefinition -] - -{ #category : #general } -RGEnvironmentBackend >> setNameFor: anRGObject to: aString [ - - ^ anRGObject pvtName: aString -] - -{ #category : #class } -RGEnvironmentBackend >> setPackageFor: anRGBehavior to: anRGPackageDefinition [ - - ^ anRGBehavior behaviorStrategy pvtPackage: anRGPackageDefinition -] - -{ #category : #method } -RGEnvironmentBackend >> setSourceCodeFor: anRGMethod to: anObject [ - - anRGMethod pvtSourceCode: anObject -] - -{ #category : #'trait transormation' } -RGEnvironmentBackend >> setSubjectFor: anRGTraitComposition to: anRGTrait [ - - ^ anRGTraitComposition pvtSubject: anRGTrait -] - -{ #category : #behavior } -RGEnvironmentBackend >> setSuperclassFor: anRGBehavior to: anObject [ - - ^ anRGBehavior pvtSuperclass: anObject -] - -{ #category : #method } -RGEnvironmentBackend >> setTimeFor: anRGMethod to: aDateAndTime [ - - ^ anRGMethod pvtTime: aDateAndTime -] - -{ #category : #trait } -RGEnvironmentBackend >> setTraitCommentFor: anRGBehavior to: anRGComment [ - - ^ anRGBehavior behaviorStrategy pvtComment: anRGComment -] - -{ #category : #behavior } -RGEnvironmentBackend >> setTraitCompositionFor: anRGBehavior to: anRGTraitComposition [ - - ^ anRGBehavior pvtTraitComposition: anRGTraitComposition -] - -{ #category : #trait } -RGEnvironmentBackend >> setTraitPackageFor: anRGBehavior to: anRGPackageDefinition [ - - ^ anRGBehavior pvtPackage: anRGPackageDefinition -] - -{ #category : #class } -RGEnvironmentBackend >> sharedPoolsFor: anRGBehavior do: aBlock [ - - ^ anRGBehavior behaviorStrategy pvtSharedPoolsDo: aBlock -] - -{ #category : #'pointer layout' } -RGEnvironmentBackend >> slotsFor: anRGLayout do: aBlock [ - - ^ anRGLayout pvtSlotsDo: aBlock -] - -{ #category : #method } -RGEnvironmentBackend >> sourceCodeFor: anRGMethod [ - - ^ anRGMethod pvtSafeSourceCode - -] - -{ #category : #'trait transormation' } -RGEnvironmentBackend >> subjectFor: anRGTraitComposition [ - - ^ anRGTraitComposition pvtSubject -] - -{ #category : #behavior } -RGEnvironmentBackend >> superclassFor: anRGBehavior [ - - ^ anRGBehavior pvtSuperclass -] - -{ #category : #class } -RGEnvironmentBackend >> tagClass: anRGBehavior with: aSymbol [ - - ^ anRGBehavior pvtTagWith: aSymbol -] - -{ #category : #method } -RGEnvironmentBackend >> tagMethod: anRGMethod with: aSymbol [ - - ^ anRGMethod pvtTagWith: aSymbol -] - -{ #category : #class } -RGEnvironmentBackend >> tagsForClass: anRGBehavior do: aBlock [ - - ^ anRGBehavior pvtTagsDo: aBlock -] - -{ #category : #package } -RGEnvironmentBackend >> tagsForClassesFor: anRGPackageDefinition do: aBlock [ - - ^ anRGPackageDefinition pvtTagsForClassesDo: aBlock -] - -{ #category : #method } -RGEnvironmentBackend >> tagsForMethod: anRGMethod do: aBlock [ - - ^ anRGMethod pvtTagsDo: aBlock -] - -{ #category : #class } -RGEnvironmentBackend >> tagsForMethodsFor: anRGBehavior do: aBlock [ - - ^ anRGBehavior pvtTagsForMethodsDo: aBlock -] - -{ #category : #method } -RGEnvironmentBackend >> timeFor: anRGMethod [ - - ^ anRGMethod pvtTime -] - -{ #category : #trait } -RGEnvironmentBackend >> traitCommentFor: anRGBehavior [ - - ^ anRGBehavior behaviorStrategy pvtComment -] - -{ #category : #behavior } -RGEnvironmentBackend >> traitCompositionFor: anRGBehavior [ - - ^ anRGBehavior pvtTraitComposition -] - -{ #category : #trait } -RGEnvironmentBackend >> traitPackageFor: anRGBehavior [ - - ^ anRGBehavior behaviorStrategy pvtPackage -] - -{ #category : #'trait composition' } -RGEnvironmentBackend >> transformationsFor: anRGTraitComposition do: aBlock [ - - ^ anRGTraitComposition pvtTransformationsDo: aBlock -] - -{ #category : #resolving } -RGEnvironmentBackend >> unresolvedPropertiesFor: anRGObject [ - - ^ anRGObject pvtUnresolvedProperties -] - -{ #category : #class } -RGEnvironmentBackend >> untagClass: anRGBehavior from: aSymbol [ - - ^ anRGBehavior pvtUntagFrom: aSymbol -] - -{ #category : #method } -RGEnvironmentBackend >> untagMethod: anRGMethod from: aSymbol [ - - ^ anRGMethod pvtUntagFrom: aSymbol - - -] diff --git a/src/Ring2-Core/RGEnvironmentQueryInterface.class.st b/src/Ring2-Core/RGEnvironmentQueryInterface.class.st deleted file mode 100644 index 7c4fe65e6..000000000 --- a/src/Ring2-Core/RGEnvironmentQueryInterface.class.st +++ /dev/null @@ -1,232 +0,0 @@ -Class { - #name : #RGEnvironmentQueryInterface, - #superclass : #Object, - #instVars : [ - 'environment', - 'behaviorsDictionary' - ], - #category : #'Ring2-Core-Environment' -} - -{ #category : #'as yet unclassified' } -RGEnvironmentQueryInterface class >> for: anRGEnvironment [ - - ^ self new - environment: anRGEnvironment; - yourself. -] - -{ #category : #accessing } -RGEnvironmentQueryInterface >> allClasses [ - - ^ self behaviors select: [ :each | each isClass ] -] - -{ #category : #'as yet unclassified' } -RGEnvironmentQueryInterface >> allClassesAndTraits [ - - ^ self behaviors select: [ :each | each isClass or: [ each isTrait and: [ each isMetaclassTrait not ] ] ] -] - -{ #category : #accessing } -RGEnvironmentQueryInterface >> behaviorNamed: aSymbol [ - - ^ self behaviorNamed: aSymbol ifAbsent: [ nil] - -] - -{ #category : #'as yet unclassified' } -RGEnvironmentQueryInterface >> behaviorNamed: aSymbol ifAbsent: aBlock [ - - | found siblingName | - - found := self behaviorNamedExactlyAs: aSymbol ifAbsent: [nil]. - found ifNotNil: [ ^ found ]. - - (aSymbol endsWith: ' class') - ifTrue: [ - siblingName := (aSymbol withoutSuffix: ' class'). - found := self behaviorNamedExactlyAs: siblingName ifAbsent: [nil]. - found ifNotNil: [ - found isClass ifTrue: [ ^ found metaclass ]]]. - - (aSymbol endsWith: ' classTrait') - ifTrue: [ - siblingName := (aSymbol withoutSuffix: ' classTrait'). - found := self behaviorNamedExactlyAs: siblingName ifAbsent: [nil]. - found ifNotNil: [ - found isTrait ifTrue: [ ^ found classTrait ]]]. - - siblingName := (aSymbol, ' class'). - found := self behaviorNamedExactlyAs: siblingName ifAbsent: [nil]. - found ifNotNil: [ ^ found baseClass ]. - - siblingName := (aSymbol, ' classTrait'). - found := self behaviorNamedExactlyAs: siblingName ifAbsent: [nil]. - found ifNotNil: [ ^ found baseTrait ]. - - ^ aBlock value. -] - -{ #category : #'as yet unclassified' } -RGEnvironmentQueryInterface >> behaviorNamedExactlyAs: aSymbol [ - - ^ self behaviorNamedExactlyAs: aSymbol ifAbsent: [nil] -] - -{ #category : #'as yet unclassified' } -RGEnvironmentQueryInterface >> behaviorNamedExactlyAs: aSymbol ifAbsent: aBlock [ - - ^ self behaviorsDictionary at: aSymbol asSymbol ifAbsent: aBlock - " - self behaviorsDo: [:each | - (each name = aSymbol) ifTrue: [ ^ each ] ]. - - ^ nil - " -] - -{ #category : #'as yet unclassified' } -RGEnvironmentQueryInterface >> behaviors [ - "Retrieves the traits defined in the receiver" - - | allBehaviors | - allBehaviors := IdentitySet new. - self behaviorsDo: [ :each | allBehaviors add: each]. - ^ allBehaviors asArray - -] - -{ #category : #caching } -RGEnvironmentQueryInterface >> behaviorsDictionary [ - - ^ behaviorsDictionary ifNil: [ - behaviorsDictionary := IdentityDictionary new. - self behaviorsDo: [:each | - behaviorsDictionary at: each name put: each ]. - behaviorsDictionary - ] -] - -{ #category : #'as yet unclassified' } -RGEnvironmentQueryInterface >> behaviorsDo: aBlock [ - - self environment behaviorsDo: aBlock -] - -{ #category : #'as yet unclassified' } -RGEnvironmentQueryInterface >> classNamed: aSymbol [ - - ^ self behaviorNamed: aSymbol -] - -{ #category : #'as yet unclassified' } -RGEnvironmentQueryInterface >> classOrTraitNamed: aSymbol [ - - ^ self behaviorNamed: aSymbol -] - -{ #category : #accessing } -RGEnvironmentQueryInterface >> environment [ - ^ environment -] - -{ #category : #accessing } -RGEnvironmentQueryInterface >> environment: anObject [ - environment := anObject -] - -{ #category : #'as yet unclassified' } -RGEnvironmentQueryInterface >> globalVariables [ - "Retrieves the traits defined in the receiver" - - | allGlobalVariables | - allGlobalVariables := IdentitySet new. - self globalVariablesDo: [ :each | allGlobalVariables add: each]. - ^ allGlobalVariables asArray - -] - -{ #category : #'as yet unclassified' } -RGEnvironmentQueryInterface >> globalVariablesDo: aBlock [ - - self environment globalVariablesDo: aBlock -] - -{ #category : #'as yet unclassified' } -RGEnvironmentQueryInterface >> includesClassNamed: aSymbol [ - - self globalVariablesDo: [ :var | - var name = aSymbol ifTrue: [ ^ true ] ]. - - ^ self behaviorsDictionary - at: aSymbol asSymbol - ifPresent: [ :element | true ] - ifAbsent: [ false ] - " - self behaviorsDo: [:each | - (each name = aSymbol) ifTrue: [ ^ each ] ]. - - ^ nil - " -] - -{ #category : #caching } -RGEnvironmentQueryInterface >> invalidateName: aSymbol [ - - behaviorsDictionary removeKey: aSymbol -] - -{ #category : #'as yet unclassified' } -RGEnvironmentQueryInterface >> packageNamed: aString [ - - self packagesDo: [:each | - (each name = aString) ifTrue: [ ^ each ] ]. - - ^ nil -] - -{ #category : #'as yet unclassified' } -RGEnvironmentQueryInterface >> packages [ - "Retrieves the traits defined in the receiver" - - | allPackages | - allPackages := IdentitySet new. - self packagesDo: [ :each | allPackages add: each]. - ^ allPackages asArray - -] - -{ #category : #'as yet unclassified' } -RGEnvironmentQueryInterface >> packagesDo: aBlock [ - - self environment packagesDo: aBlock -] - -{ #category : #caching } -RGEnvironmentQueryInterface >> replaceName: aSymbol with: aNewSymbol [ - - | anRGBehavior | - anRGBehavior := behaviorsDictionary at: aSymbol ifAbsent: [ nil ]. - anRGBehavior ifNotNil: [ - behaviorsDictionary removeKey: aSymbol. - behaviorsDictionary at: aNewSymbol put: anRGBehavior. - ] - -] - -{ #category : #caching } -RGEnvironmentQueryInterface >> resetBehaviorsDictionary [ - - behaviorsDictionary := IdentityDictionary new -] - -{ #category : #'as yet unclassified' } -RGEnvironmentQueryInterface >> traitNamed: traitName [ - "Retrieves an RGTrait object. The traitName could be theMetaClass name" - | trait | - - ^(trait:= self classOrTraitNamed: traitName) isTrait - ifTrue:[ trait ] - ifFalse:[ nil ] -] diff --git a/src/Ring2-Core/RGEphemeronLayout.class.st b/src/Ring2-Core/RGEphemeronLayout.class.st deleted file mode 100644 index ad2d104d1..000000000 --- a/src/Ring2-Core/RGEphemeronLayout.class.st +++ /dev/null @@ -1,17 +0,0 @@ -Class { - #name : #RGEphemeronLayout, - #superclass : #RGPointerLayout, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'testing types' } -RGEphemeronLayout >> isEphemeronLayout [ - - ^ true -] - -{ #category : #accessing } -RGEphemeronLayout >> layoutName [ - - ^ #EphemeronLayout -] diff --git a/src/Ring2-Core/RGFixedLayout.class.st b/src/Ring2-Core/RGFixedLayout.class.st deleted file mode 100644 index 7cdf359e4..000000000 --- a/src/Ring2-Core/RGFixedLayout.class.st +++ /dev/null @@ -1,17 +0,0 @@ -Class { - #name : #RGFixedLayout, - #superclass : #RGPointerLayout, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'testing types' } -RGFixedLayout >> isFixedLayout [ - - ^ true -] - -{ #category : #accessing } -RGFixedLayout >> layoutName [ - - ^ #FixedLayout -] diff --git a/src/Ring2-Core/RGGlobalVariable.class.st b/src/Ring2-Core/RGGlobalVariable.class.st deleted file mode 100644 index 95f4477a8..000000000 --- a/src/Ring2-Core/RGGlobalVariable.class.st +++ /dev/null @@ -1,27 +0,0 @@ -" -A global variable definition -" -Class { - #name : #RGGlobalVariable, - #superclass : #RGObject, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'managing container' } -RGGlobalVariable >> addoptToParentStub [ - - super addoptToParentStub. - self parent addGlobalVariable: self. -] - -{ #category : #'managing container' } -RGGlobalVariable >> defaultParentStub [ - - ^ self defaultEnvironmentStub -] - -{ #category : #testing } -RGGlobalVariable >> isGlobalVariable [ - - ^true -] diff --git a/src/Ring2-Core/RGImmediateLayout.class.st b/src/Ring2-Core/RGImmediateLayout.class.st deleted file mode 100644 index 78e9d64c0..000000000 --- a/src/Ring2-Core/RGImmediateLayout.class.st +++ /dev/null @@ -1,17 +0,0 @@ -Class { - #name : #RGImmediateLayout, - #superclass : #RGObjectLayout, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'testing types' } -RGImmediateLayout >> isImmediateLayout [ - - ^ true -] - -{ #category : #accessing } -RGImmediateLayout >> layoutName [ - - ^ #ImmediateLayout -] diff --git a/src/Ring2-Core/RGIncompatibleBehaviorTypeError.class.st b/src/Ring2-Core/RGIncompatibleBehaviorTypeError.class.st deleted file mode 100644 index 295d6d6a1..000000000 --- a/src/Ring2-Core/RGIncompatibleBehaviorTypeError.class.st +++ /dev/null @@ -1,11 +0,0 @@ -Class { - #name : #RGIncompatibleBehaviorTypeError, - #superclass : #Error, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #accessing } -RGIncompatibleBehaviorTypeError >> messageText [ - - ^ 'This message cannot be sent. Incompatible behavior type.' -] diff --git a/src/Ring2-Core/RGIndexedSlot.class.st b/src/Ring2-Core/RGIndexedSlot.class.st deleted file mode 100644 index 7eb11df43..000000000 --- a/src/Ring2-Core/RGIndexedSlot.class.st +++ /dev/null @@ -1,5 +0,0 @@ -Class { - #name : #RGIndexedSlot, - #superclass : #RGSlot, - #category : #'Ring2-Core-Kernel' -} diff --git a/src/Ring2-Core/RGInstanceVariableSlot.class.st b/src/Ring2-Core/RGInstanceVariableSlot.class.st deleted file mode 100644 index e2b82bfa4..000000000 --- a/src/Ring2-Core/RGInstanceVariableSlot.class.st +++ /dev/null @@ -1,11 +0,0 @@ -Class { - #name : #RGInstanceVariableSlot, - #superclass : #RGIndexedSlot, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #testing } -RGInstanceVariableSlot >> isSpecial [ - - ^ false -] diff --git a/src/Ring2-Core/RGJoiningError.class.st b/src/Ring2-Core/RGJoiningError.class.st deleted file mode 100644 index bb6051f40..000000000 --- a/src/Ring2-Core/RGJoiningError.class.st +++ /dev/null @@ -1,5 +0,0 @@ -Class { - #name : #RGJoiningError, - #superclass : #Error, - #category : #'Ring2-Core-Kernel' -} diff --git a/src/Ring2-Core/RGLayout.class.st b/src/Ring2-Core/RGLayout.class.st deleted file mode 100644 index 15b58b279..000000000 --- a/src/Ring2-Core/RGLayout.class.st +++ /dev/null @@ -1,108 +0,0 @@ -Class { - #name : #RGLayout, - #superclass : #RGObject, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'managing container' } -RGLayout >> addoptToParentStub [ - - super addoptToParentStub. - self environment backend createUnresolvedClassGroupFor: self parent. - self parent behaviorStrategy pvtLayout: self. -] - -{ #category : #accessing } -RGLayout >> allSlots [ - - ^ { } -] - -{ #category : #'managing container' } -RGLayout >> defaultParentStub [ - - ^ self defaultClassStub -] - -{ #category : #accessing } -RGLayout >> instVarNames [ - ^ {} -] - -{ #category : #'testing types' } -RGLayout >> isBitsLayout [ - - ^ false -] - -{ #category : #'testing types' } -RGLayout >> isByteLayout [ - - ^ false -] - -{ #category : #'testing types' } -RGLayout >> isCompiledMethodLayout [ - - ^ false -] - -{ #category : #'testing types' } -RGLayout >> isEmptyLayout [ - - ^ false -] - -{ #category : #'testing types' } -RGLayout >> isEphemeronLayout [ - - ^ false -] - -{ #category : #'testing types' } -RGLayout >> isFixedLayout [ - - ^ false -] - -{ #category : #'testing types' } -RGLayout >> isImmediateLayout [ - - ^ false -] - -{ #category : #'testing types' } -RGLayout >> isLayout [ - - ^true -] - -{ #category : #'testing types' } -RGLayout >> isObjectLayout [ - - ^ false -] - -{ #category : #'testing types' } -RGLayout >> isPointerLayout [ - - ^ false -] - -{ #category : #'testing types' } -RGLayout >> isVariableLayout [ - - ^ false -] - -{ #category : #'testing types' } -RGLayout >> isWeakLayout [ - - ^ false -] - -{ #category : #'testing types' } -RGLayout >> isWordLayout [ - - ^ false -] diff --git a/src/Ring2-Core/RGMergeError.class.st b/src/Ring2-Core/RGMergeError.class.st deleted file mode 100644 index db3e48a0a..000000000 --- a/src/Ring2-Core/RGMergeError.class.st +++ /dev/null @@ -1,51 +0,0 @@ -Class { - #name : #RGMergeError, - #superclass : #Error, - #instVars : [ - 'property', - 'target', - 'source' - ], - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'as yet unclassified' } -RGMergeError class >> property: propertySymbol target: targetDefinition source: sourceDefinition [ - - ^ self new - property: propertySymbol; - target: targetDefinition; - source: sourceDefinition; - signal. - -] - -{ #category : #accessing } -RGMergeError >> property [ - ^ property -] - -{ #category : #accessing } -RGMergeError >> property: anObject [ - property := anObject -] - -{ #category : #accessing } -RGMergeError >> source [ - ^ source -] - -{ #category : #accessing } -RGMergeError >> source: anObject [ - source := anObject -] - -{ #category : #accessing } -RGMergeError >> target [ - ^ target -] - -{ #category : #accessing } -RGMergeError >> target: anObject [ - target := anObject -] diff --git a/src/Ring2-Core/RGMetaclass.class.st b/src/Ring2-Core/RGMetaclass.class.st deleted file mode 100644 index fbfd594a8..000000000 --- a/src/Ring2-Core/RGMetaclass.class.st +++ /dev/null @@ -1,14 +0,0 @@ -" -A factory that produces instances of RG2Behavior composed with RGMetaclassStrategy -" -Class { - #name : #RGMetaclass, - #superclass : #RGBehaviorFactory, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'instance creation' } -RGMetaclass class >> newStrategy [ - - ^ RGMetaclassStrategy unresolved -] diff --git a/src/Ring2-Core/RGMetaclassStrategy.class.st b/src/Ring2-Core/RGMetaclassStrategy.class.st deleted file mode 100644 index 2d9b4caf8..000000000 --- a/src/Ring2-Core/RGMetaclassStrategy.class.st +++ /dev/null @@ -1,234 +0,0 @@ -Class { - #name : #RGMetaclassStrategy, - #superclass : #RGClassDescriptionStrategy, - #instVars : [ - 'baseClass' - ], - #category : #'Ring2-Core-Kernel' -} - -{ #category : #visiting } -RGMetaclassStrategy >> acceptVisitor: aVisitor [ - - ^ aVisitor visitMetaclass: self owner -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> allClassVarNames [ - - self owner instanceSide allClassVarNames -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> baseBehavior [ - - ^ self baseClass -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> baseClass [ - - ^ self backend forBehavior baseClassFor: self owner -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> baseClass: anRGClass [ - - self backend forBehavior setBaseClassFor: self owner to: anRGClass -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> bindingOf: varName [ - - ^ self baseClass bindingOf: varName -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> category [ - - ^ self baseClass category -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> classSide [ - - ^ self owner -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> classVarNames [ - - ^ self theNonMetaClass classVarNames -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> comment [ - - ^ self baseClass comment -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> defaultMetaClass [ - - "will be set correctly together with baseClass" - ^ RGUnresolvedValue new default: nil. -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> definition [ - "Refer to the comment in ClassDescription|definition." - - ^ String streamContents: - [:strm | - strm print: self. - self owner hasTraitComposition ifTrue: [ - strm - crtab; - nextPutAll: 'uses: '; - print: self traitComposition ]. - - (self owner usesSpecialSlot or: [ Slot showSlotClassDefinition ]) - ifFalse: [ - strm - crtab; - nextPutAll: 'instanceVariableNames: '; - store: self owner instanceVariablesString] - ifTrue: [ - strm - crtab; - nextPutAll: 'slots: '; - nextPutAll: self owner slotDefinitionString]] -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> initialize [ - - baseClass := RGUnresolvedValue recursive. - - super initialize. - - -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> innerBindingOf: varName [ - - ^self instanceSide innerBindingOf: varName -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> instanceSide [ - ^ self baseClass -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> isMeta [ - - ^true -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> isMetaclass [ - - ^true -] - -{ #category : #testing } -RGMetaclassStrategy >> isMetaclassStrategy [ - - ^ true -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> makeResolved [ - - "try to set the correct name before resolving of it" - ((self owner hasUnresolved: #name) and: [ self baseClass isRingResolved and: [ self baseClass hasResolvedName ] ]) ifTrue: [ - self owner pvtName: (self baseClass name, ' class') asSymbol. - ]. - - super makeResolved markAsRingResolved. - - baseClass := self baseClass. -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> metaclass [ - - "temporary" - ^ self -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> package [ - - ^ self baseClass package -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> pvtAsMetaclassTrait [ - - | newMetaclassTrait | - - (self owner resolvedProperties includesAnyOf: #(superclass traitComposition)) - ifTrue: [self error: 'This class cannot be converted to trait']. - - "TODO: check empty layout" - newMetaclassTrait := RGMetaclassTrait unresolvedWithParent: self owner parent. - newMetaclassTrait copyPropertiesFrom: self owner. - - (self owner hasResolvedName) - ifTrue: [ newMetaclassTrait pvtName: ((self owner name withoutSuffix: ' class'), ' classTrait') asSymbol ]. - newMetaclassTrait pvtLocalMethods: self owner localMethods. - - ^ newMetaclassTrait - - -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> pvtBaseClass [ - - ^ baseClass value -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> pvtBaseClass: anRGClass [ - - self owner environment verifyOwnership: anRGClass. - - ^ baseClass := anRGClass -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> pvtResolvableProperties [ - - ^ super pvtResolvableProperties, { - #baseClass -> baseClass. - } - - -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> referencedBehaviors [ - - ^ super referencedBehaviors, {self baseClass} -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> sibling [ - - ^ self baseClass. -] - -{ #category : #testing } -RGMetaclassStrategy >> storeName [ - - ^ 'RGMetaclass' -] - -{ #category : #'private - backend access' } -RGMetaclassStrategy >> theNonMetaClass [ - ^self baseClass -] diff --git a/src/Ring2-Core/RGMetaclassTrait.class.st b/src/Ring2-Core/RGMetaclassTrait.class.st deleted file mode 100644 index e12b6f7fb..000000000 --- a/src/Ring2-Core/RGMetaclassTrait.class.st +++ /dev/null @@ -1,30 +0,0 @@ -" -A factory that produces instances of RG2Behavior composed with RGMetaclassTraitStrategy -" -Class { - #name : #RGMetaclassTrait, - #superclass : #RGBehaviorFactory, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'instance creation' } -RGMetaclassTrait class >> newStrategy [ - - ^ RGMetaclassTraitStrategy unresolved -] - -{ #category : #'instance creation' } -RGMetaclassTrait class >> newStrategyFor: anRGEnvironment [ - - ^ (self strategyClassForVersion: anRGEnvironment version) unresolved - -] - -{ #category : #'instance creation' } -RGMetaclassTrait class >> strategyClassForVersion: aVersionNumber [ - - ^ (aVersionNumber <= 6) - ifTrue: [ RGMetaclassTraitStrategy ] - ifFalse: [ RGMetaclassTraitV2Strategy ] - -] diff --git a/src/Ring2-Core/RGMetaclassTraitStrategy.class.st b/src/Ring2-Core/RGMetaclassTraitStrategy.class.st deleted file mode 100644 index c3a1dbeaa..000000000 --- a/src/Ring2-Core/RGMetaclassTraitStrategy.class.st +++ /dev/null @@ -1,152 +0,0 @@ -Class { - #name : #RGMetaclassTraitStrategy, - #superclass : #RGTraitDescriptionStrategy, - #instVars : [ - 'baseTrait' - ], - #category : #'Ring2-Core-Kernel' -} - -{ #category : #visiting } -RGMetaclassTraitStrategy >> acceptVisitor: aVisitor [ - - ^ aVisitor visitClassTrait: self owner -] - -{ #category : #'private - backend access' } -RGMetaclassTraitStrategy >> baseBehavior [ - - ^ self baseTrait -] - -{ #category : #'private - backend access' } -RGMetaclassTraitStrategy >> baseTrait [ - - ^ self backend forBehavior metaclassTraitBaseTraitFor: self owner -] - -{ #category : #'private - backend access' } -RGMetaclassTraitStrategy >> baseTrait: anRGClass [ - - self backend forBehavior setMetaclassTraitBaseTraitFor: self to: anRGClass -] - -{ #category : #'private - backend access' } -RGMetaclassTraitStrategy >> category [ - - ^ self baseTrait category -] - -{ #category : #'private - backend access' } -RGMetaclassTraitStrategy >> comment [ - - ^ self baseTrait comment -] - -{ #category : #'private - backend access' } -RGMetaclassTraitStrategy >> definition [ - ^String streamContents: [:stream | - stream - nextPutAll: self baseTrait name; - nextPutAll: ' clasTrait'; - crtab; - nextPutAll: 'uses: '; - nextPutAll: self owner traitCompositionString] -] - -{ #category : #'private - backend access' } -RGMetaclassTraitStrategy >> instanceSide [ - - ^ self baseTrait -] - -{ #category : #'private - backend access' } -RGMetaclassTraitStrategy >> isMeta [ - - ^true -] - -{ #category : #'private - backend access' } -RGMetaclassTraitStrategy >> isMetaclassTrait [ - - ^ true -] - -{ #category : #testing } -RGMetaclassTraitStrategy >> isMetaclassTraitStrategy [ - - ^ true -] - -{ #category : #'private - backend access' } -RGMetaclassTraitStrategy >> makeResolved [ - - - "try to set the correct name before resolving of it" - ((self owner hasUnresolved: #name) and: [ self baseClass isRingResolved and: [ self baseTrait hasResolvedName] ]) ifTrue: [ - self owner pvtName: (self baseTrait name, ' classTrait') asSymbol. - ]. - - super makeResolved. - - baseTrait := self baseTrait markAsRingResolved. -] - -{ #category : #'private - backend access' } -RGMetaclassTraitStrategy >> package [ - - ^ self baseTrait package -] - -{ #category : #'private - backend access' } -RGMetaclassTraitStrategy >> pvtBaseTrait [ - - ^ baseTrait value -] - -{ #category : #'private - backend access' } -RGMetaclassTraitStrategy >> pvtBaseTrait: anRGTrait [ - - self owner environment verifyOwnership: anRGTrait. - - ^ baseTrait := anRGTrait -] - -{ #category : #'private - backend access' } -RGMetaclassTraitStrategy >> pvtResolvableProperties [ - - ^ super pvtResolvableProperties, { - #baseTrait -> baseTrait. - } - - -] - -{ #category : #'private - backend access' } -RGMetaclassTraitStrategy >> referencedBehaviors [ - - ^ super referencedBehaviors, {self baseTrait} -] - -{ #category : #'private - backend access' } -RGMetaclassTraitStrategy >> sibling [ - - ^ self baseTrait. -] - -{ #category : #testing } -RGMetaclassTraitStrategy >> storeName [ - - ^ 'RGMetaclassTrait' -] - -{ #category : #'private - backend access' } -RGMetaclassTraitStrategy >> theNonMetaClass [ - ^self baseTrait -] - -{ #category : #'private - backend access' } -RGMetaclassTraitStrategy >> traitTransformationString [ - - ^ self owner name -] diff --git a/src/Ring2-Core/RGMetaclassTraitV2Strategy.class.st b/src/Ring2-Core/RGMetaclassTraitV2Strategy.class.st deleted file mode 100644 index 6c52929de..000000000 --- a/src/Ring2-Core/RGMetaclassTraitV2Strategy.class.st +++ /dev/null @@ -1,213 +0,0 @@ -Class { - #name : #RGMetaclassTraitV2Strategy, - #superclass : #RGTraitV2DescriptionStrategy, - #instVars : [ - 'baseClass' - ], - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> baseBehavior [ - - ^ self baseClass -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> baseClass [ - - ^ self backend forBehavior baseClassFor: self owner -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> baseClass: anRGClass [ - - self backend forBehavior setBaseClassFor: self owner to: anRGClass -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> bindingOf: varName [ - - ^ self baseClass bindingOf: varName -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> category [ - - ^ self baseClass category -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> classSide [ - - ^ self owner -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> classVarNames [ - - ^ self theNonMetaClass classVarNames -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> comment [ - - ^ self baseClass comment -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> defaultMetaClass [ - - "will be set correctly together with baseClass" - ^ RGUnresolvedValue new default: nil. -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> definition [ - ^String streamContents: [:stream | - stream - nextPutAll: self baseTrait name; - nextPutAll: ' clasTrait'; - crtab; - nextPutAll: 'uses: '; - nextPutAll: self owner traitCompositionString. - (self owner slots size > 0) ifTrue: [ - (self owner usesSpecialSlot or: [ Slot showSlotClassDefinition ]) - ifFalse: [ - stream - crtab; - nextPutAll: 'instanceVariableNames: '; - store: self owner instanceVariablesString] - ifTrue: [ - stream - crtab; - nextPutAll: 'slots: '; - nextPutAll: self owner slotDefinitionString]]] -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> initialize [ - - baseClass := RGUnresolvedValue recursive. - - super initialize. - - -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> instanceSide [ - ^ self baseClass -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> isMeta [ - - ^true -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> isMetaclass [ - - ^true -] - -{ #category : #testing } -RGMetaclassTraitV2Strategy >> isMetaclassStrategy [ - - ^ true -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> makeResolved [ - - "try to set the correct name before resolving of it" - ((self owner hasUnresolved: #name) and: [ self baseClass isRingResolved and: [ self baseClass hasResolvedName ] ]) ifTrue: [ - self owner pvtName: (self baseClass name, ' class') asSymbol. - ]. - - super makeResolved. - - baseClass := self baseClass markAsRingResolved. -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> metaclass [ - - "temporary" - ^ self -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> package [ - - ^ self baseClass package -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> pvtAsMetaclassTrait [ - - | newMetaclassTrait | - - (self owner resolvedProperties includesAnyOf: #(superclass traitComposition)) - ifTrue: [self error: 'This class cannot be converted to trait']. - - "TODO: check empty layout" - newMetaclassTrait := RGMetaclassTrait unresolvedWithParent: self owner parent. - newMetaclassTrait copyPropertiesFrom: self owner. - - (self owner hasResolvedName) - ifTrue: [ newMetaclassTrait pvtName: ((self owner name withoutSuffix: ' class'), ' classTrait') asSymbol ]. - newMetaclassTrait pvtLocalMethods: self owner localMethods. - - ^ newMetaclassTrait - - -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> pvtBaseClass [ - - ^ baseClass value -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> pvtBaseClass: anRGClass [ - - self owner environment verifyOwnership: anRGClass. - - ^ baseClass := anRGClass -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> pvtResolvableProperties [ - - ^ super pvtResolvableProperties, { - #baseClass -> baseClass. - } - - -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> referencedBehaviors [ - - ^ super referencedBehaviors, {self baseClass} -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> sibling [ - - ^ self baseClass. -] - -{ #category : #testing } -RGMetaclassTraitV2Strategy >> storeName [ - - ^ 'RGMetaclass' -] - -{ #category : #'private - backend access' } -RGMetaclassTraitV2Strategy >> theNonMetaClass [ - ^self baseClass -] diff --git a/src/Ring2-Core/RGMethod.class.st b/src/Ring2-Core/RGMethod.class.st deleted file mode 100644 index 5d97e90fd..000000000 --- a/src/Ring2-Core/RGMethod.class.st +++ /dev/null @@ -1,540 +0,0 @@ -" -RG2Method is a concrete representation of methods. It can be used to build browser for methods that are not in the image. It is polymorphic with CompiledMethod. - -* We can ask a RG2Method for its selector using the selector message. -Example: - (Point>>#dist:) asRing2Definition selector - -> #dist - -We can also ask the ring object representation of its class or the Smalltalk class actually implementing the corresponding compiledMethod. - -* To access the ring class definition name, use parentName - aRG2MethodDefinition parentName - -Example: - (Point>>#dist:) asRing2Definition parentName - -> #Point - -* If you have a complete model where classes and methods are ring definition, to access the ring class definition , use parent - aRG2MethodDefinition parent - -Example: - aRG2MethodDefinition(Point>>#dist:) parent - -> aRG2ClassDefinition(Point) - -* If you want to access the smalltalk class that contains the compiledMethod that is represented by a ringMethodDefinition, use realParent - aRG2MethodDefinition realParent - -Example: - (Point>>#dist:) asRing2Definition realParent - -> Point - - -Now a RingEntityDefinition offers two APIs: one that is generic and works for all the source code entities and this is the one we just -presented: parent, parentName and realParent. Having such interface is important to build generic tools that could manipulate -any entities in a polymorphic way (yes no isKindOf: everywhere). - -In addition, a ring method definition offers a specific interface that should only be used when you know that you are solely manipulate -specific entity such as class element: method definition, class comment, and variables. - -Here is the equivalence table - - realParent realClass - parent ringClass - parentName className - - -* The message class returns the class of the object :). - -Example: - (Point>>#dist:) asRing2Definition class - -> RingMethodDefinition - -* The message className returns the name of the ring class defining the reingMethodDefinition. - -Example: - (Point>>#dist:) asRing2Definition className - -> #Point - -* If you have a complete model where classes and methods are ring definition, to access the ring class definition , use parent - aRG2MethodDefinition ringClass - -Example: - aRG2MethodDefinition(Point>>#dist:) ringClass - -> aRG2ClassDefinition(Point) - - -* If you want to access the smalltalk class that contains the compiledMethod that is represented by a ringMethodDefinition, use realClass - aRG2MethodDefinition realClass - -Example: - (Point>>#dist:) asRing2Definition realClass - -> Point - - -" -Class { - #name : #RGMethod, - #superclass : #RGElement, - #instVars : [ - 'sourceCode', - 'package', - 'author', - 'time', - 'tags' - ], - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'managing container' } -RGMethod >> addoptToParentStub [ - - super addoptToParentStub. - self environment backend createUnresolvedClassGroupFor: self parent. - self parent pvtAddLocalMethod: self. - - - -] - -{ #category : #accessing } -RGMethod >> argumentNames [ - - ^ self ast argumentNames -] - -{ #category : #accessing } -RGMethod >> ast [ - "Answer my AST with semantic analysis. See #parseTree." - - ^ self propertyNamed: #ast ifAbsentPut: [ self parseTree doSemanticAnalysisIn: self methodClass ] - - -] - -{ #category : #private } -RGMethod >> astFromSource [ - - ^ RBParser parseMethod: self sourceCode -] - -{ #category : #'accessing - backend' } -RGMethod >> author [ - - ^ self backend forBehavior authorFor: self -] - -{ #category : #'accessing - backend' } -RGMethod >> author: aString [ - - self backend forBehavior setAuthorFor: self to: aString -] - -{ #category : #'backward compatibility' } -RGMethod >> category [ - - ^ self protocol -] - -{ #category : #private } -RGMethod >> changeProtocolDuring: aBlock [ - - | oldProtocol | - - oldProtocol := self protocol. - aBlock value. - self announce: (MethodRecategorized method: self oldProtocol: oldProtocol) -] - -{ #category : #'accessing - backend' } -RGMethod >> cleanTags [ - - self changeProtocolDuring: [ - self cleanTagsWithoutAnnouncemnt ] -] - -{ #category : #'accessing - backend' } -RGMethod >> cleanTagsWithoutAnnouncemnt [ - - self backend forMethod cleanMethodTagsFor: self. -] - -{ #category : #accessing } -RGMethod >> compiledMethod [ - ^ self -] - -{ #category : #'default model values' } -RGMethod >> defaultAuthor [ - - ^ '' -] - -{ #category : #'managing container' } -RGMethod >> defaultParentStub [ - - ^ self defaultClassStub -] - -{ #category : #'default model values' } -RGMethod >> defaultSourceCode [ - - ^ self sourceCodeForNoSelector -] - -{ #category : #'default model values' } -RGMethod >> defaultTags [ - - ^ Set new -] - -{ #category : #'default model values' } -RGMethod >> defaultTime [ - - ^ DateAndTime new -] - -{ #category : #accessing } -RGMethod >> fullName [ - "Keeps a unique description for the receiver. As annotation to avoid converting each time is invoked" - - ^ (self parent name, '>>#', self selector) asSymbol -] - -{ #category : #accessing } -RGMethod >> hasSourceCode [ - - ^ self backend forMethod hasSourceCodeFor: self -] - -{ #category : #initialization } -RGMethod >> initialize [ - - super initialize. - - sourceCode := self unresolvedValue: self defaultSourceCode. - tags := self unresolvedValue: self defaultTags. "tags must be set before package" - package := self unresolvedValue: self parent package. - author := self unresolvedValue: self defaultAuthor. - time := self unresolvedValue: self defaultTime. - -] - -{ #category : #initialization } -RGMethod >> initializeUnresolved [ - - super initializeUnresolved. - - sourceCode := self unresolvedValue: self defaultSourceCode. - tags := self unresolvedValue: self defaultTags. - package := self unresolvedValue: self parent package. - author := self unresolvedValue: self defaultAuthor. - time := self unresolvedValue: self defaultTime. - -] - -{ #category : #accessing } -RGMethod >> isExtension [ - "The receiver is an extension when is defined in a different package to the one of its parent" - - ^ self parent package ~= self package -] - -{ #category : #testing } -RGMethod >> isFromTrait [ - ^ self parent isTrait -] - -{ #category : #testing } -RGMethod >> isMetaSide [ - - ^ self parent isMeta -] - -{ #category : #testing } -RGMethod >> isMethod [ - - ^true -] - -{ #category : #'queries - tags' } -RGMethod >> isTaggedWith: aSymbol [ - - ^self tags includes: aSymbol -] - -{ #category : #resolving } -RGMethod >> makeResolved [ - - super makeResolved. - - sourceCode := self sourceCode markAsRingResolved. - package := self package markAsRingResolved. - author := self author markAsRingResolved. - time := self time markAsRingResolved. - tags := self tags markAsRingResolved. -] - -{ #category : #'queries - class' } -RGMethod >> methodClass [ - - ^ self parent -] - -{ #category : #accessing } -RGMethod >> numArgs [ - ^ self selector asString numArgs -] - -{ #category : #'accessing - backend' } -RGMethod >> package [ - - ^ self backend forMethod methodPackageFor: self -] - -{ #category : #'accessing - backend' } -RGMethod >> package: anRGPackageDefinition [ - - self backend forMethod setMethodPackageFor: self to: anRGPackageDefinition. - self environment addPackage: anRGPackageDefinition. - (self parent package = anRGPackageDefinition) - ifFalse: [ self package addExtensionMethod: self ]. - -] - -{ #category : #accessing } -RGMethod >> parseTree [ - - ^(RBParser - parseMethod: self sourceCode - onError: [ :msg :pos | ^ nil ]) methodClass: self methodClass. - -] - -{ #category : #printing } -RGMethod >> printOn: aStream [ - - self parent name ifNotNil: [ - aStream nextPutAll: self parent name; - nextPutAll: '>>' ]. - aStream print: self selector -] - -{ #category : #'accessing - backend' } -RGMethod >> protocol [ - - | methodTags | - - methodTags := self tags. - ^ methodTags - ifEmpty: [ self class asYetUnclassifiedProtocolName] - ifNotEmpty: [ methodTags sorted first ] - -] - -{ #category : #'accessing - backend' } -RGMethod >> protocol: aSymbol [ - - self cleanTagsWithoutAnnouncemnt. - self tagWith: aSymbol. - - -] - -{ #category : #'private - backend interface' } -RGMethod >> pvtAuthor [ - - ^ author value -] - -{ #category : #'private - backend interface' } -RGMethod >> pvtAuthor: aString [ - - ^ author := aString -] - -{ #category : #'private - backend interface' } -RGMethod >> pvtCleanTags [ - - tags := self defaultTags. - - "TODO:Announce if not empty" - - -] - -{ #category : #'private - backend interface' } -RGMethod >> pvtPackage [ - - ^ package value -] - -{ #category : #'private - backend interface' } -RGMethod >> pvtPackage: anRGPackageDefinition [ - - self environment verifyOwnership: anRGPackageDefinition. - - ^ package := anRGPackageDefinition -] - -{ #category : #'private - backend interface' } -RGMethod >> pvtResolvableProperties [ - - ^ super pvtResolvableProperties, { - #sourceCode -> sourceCode. - #package -> package. - #author -> author. - #time -> time. - #tags -> tags. - } - - -] - -{ #category : #private } -RGMethod >> pvtSafeSourceCode [ - - | aStringOrUnresolved | - aStringOrUnresolved := self pvtSourceCode. - ^ aStringOrUnresolved isRingResolved - ifFalse: [ - self pvtName isRingResolved - ifTrue: [ self sourceCodeForNoSource ] - ifFalse: [ self sourceCodeForNoSelector ] ] - ifTrue: [ aStringOrUnresolved value ] -] - -{ #category : #private } -RGMethod >> pvtSourceCode [ - - ^ sourceCode -] - -{ #category : #private } -RGMethod >> pvtSourceCode: anObject [ - - sourceCode := anObject -] - -{ #category : #'private - backend interface' } -RGMethod >> pvtTagWith: aSymbol [ - - tags isRingResolved ifFalse: [ - self pvtCleanTags ]. - - tags add: aSymbol. - -] - -{ #category : #private } -RGMethod >> pvtTagsDo: aBlock [ - - ^ tags value do: aBlock -] - -{ #category : #'private - backend interface' } -RGMethod >> pvtTime [ - - ^ time value -] - -{ #category : #'private - backend interface' } -RGMethod >> pvtTime: aDateAndTime [ - - ^ time := aDateAndTime -] - -{ #category : #'private - backend interface' } -RGMethod >> pvtUntagFrom: aSymbol [ - - (tags value includes: aSymbol) - ifTrue: [ tags remove: aSymbol ]. - - "TODO:Announce" - - -] - -{ #category : #removing } -RGMethod >> removeFromSystem [ - - ^ self parent removeLocalMethod: self -] - -{ #category : #accessing } -RGMethod >> selector [ - "Retrieves the name of the method" - - ^ self name asSymbol -] - -{ #category : #accessing } -RGMethod >> sourceCode [ - - ^ self backend forMethod sourceCodeFor: self -] - -{ #category : #accessing } -RGMethod >> sourceCode: anObject [ - - "ATTENTION: There is no check here if the selector is changed!" - - self backend forMethod setSourceCodeFor: self to: anObject asString - "TODO: announcements" -] - -{ #category : #accessing } -RGMethod >> sourceCodeForNoSelector [ - - ^ 'unresolvedMessage', String cr, String tab, '"source code for the method model not set"' -] - -{ #category : #accessing } -RGMethod >> sourceCodeForNoSource [ - - ^ self selector asMethodPreamble, String cr, String tab, '"source code for the method model not set"' -] - -{ #category : #'accessing - backend' } -RGMethod >> tagWith: aSymbol [ - - self changeProtocolDuring: [ - self backend forMethod tagMethod: self with: aSymbol. - self parent addMethodTag: aSymbol. - ] - -] - -{ #category : #'accessing - model' } -RGMethod >> tags [ - - | allTags | - allTags := IdentitySet new. - self tagsDo: [ :each | allTags add: each]. - ^ allTags asArray - -] - -{ #category : #'accessing - backend' } -RGMethod >> tagsDo: aBlock [ - - self backend forMethod tagsForMethod: self do: aBlock -] - -{ #category : #'accessing - backend' } -RGMethod >> time [ - - ^ self backend forBehavior timeFor: self -] - -{ #category : #'accessing - backend' } -RGMethod >> time: aDateAndTime [ - - self backend forBehavior setTimeFor: self to: aDateAndTime -] - -{ #category : #'accessing - backend' } -RGMethod >> untagFrom: aSymbol [ - - self backend forMethod untagMethod: self from: aSymbol -] diff --git a/src/Ring2-Core/RGNotFoundError.class.st b/src/Ring2-Core/RGNotFoundError.class.st deleted file mode 100644 index 3f3cd7fe6..000000000 --- a/src/Ring2-Core/RGNotFoundError.class.st +++ /dev/null @@ -1,5 +0,0 @@ -Class { - #name : #RGNotFoundError, - #superclass : #Error, - #category : #'Ring2-Core-Kernel' -} diff --git a/src/Ring2-Core/RGObject.class.st b/src/Ring2-Core/RGObject.class.st deleted file mode 100644 index f38118f96..000000000 --- a/src/Ring2-Core/RGObject.class.st +++ /dev/null @@ -1,690 +0,0 @@ -" -I am the root class of the Ring meta-model definitions. -A Ring definition has a name, properties and knows its environment -" -Class { - #name : #RGObject, - #superclass : #Object, - #instVars : [ - 'properties', - 'name', - 'parent' - ], - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'instance creation' } -RGObject class >> asYetUnclassifiedProtocolName [ - - ^ 'as yet unclassified' asSymbol -] - -{ #category : #'instance creation' } -RGObject class >> named: aString [ - - "create model in its own environment" - - ^self new - pvtName: aString; - yourself -] - -{ #category : #'instance creation' } -RGObject class >> named: aName parent: anRGObject [ - - ^self basicNew - parent: anRGObject; - initialize; - pvtName: aName asSymbol; - yourself -] - -{ #category : #'instance creation' } -RGObject class >> parent: anRGObject [ - - ^self basicNew - parent: anRGObject; - initialize; - yourself -] - -{ #category : #'instance creation' } -RGObject class >> unnamed [ - - ^self new -] - -{ #category : #'instance creation' } -RGObject class >> unresolved [ - - ^ self basicNew - initializeUnresolved; - yourself. -] - -{ #category : #'instance creation' } -RGObject class >> unresolvedNamed: aString withParent: anRGDefintion [ - - ^self basicNew - initializeUnresolved; - pvtName: aString asSymbol; - parent: anRGDefintion; - yourself -] - -{ #category : #'instance creation' } -RGObject class >> unresolvedWithParent: anRGDefintion [ - - ^self basicNew - initializeUnresolved; - parent: anRGDefintion; - yourself -] - -{ #category : #'managing container' } -RGObject >> addoptToParentStub [ -] - -{ #category : #announcements } -RGObject >> announce: anAnnouncement [ - - self environment announcer announce: anAnnouncement -] - -{ #category : #announcements } -RGObject >> announcer [ - - ^ self environment announcer -] - -{ #category : #converting } -RGObject >> asRGDefinition [ - - ^ self -] - -{ #category : #accessing } -RGObject >> ask [ - - ^ self -] - -{ #category : #accessing } -RGObject >> backend [ - - ^ self environment backend -] - -{ #category : #events } -RGObject >> child: aChildDefinition renamedFrom: oldName to: newName [ - - "react on renaming of a child definition. By default do nothing" -] - -{ #category : #copying } -RGObject >> copyForBehaviorDefinition [ - - "returns copy of the behavior model that contains only information related to the behavior - definition" - "removing of ^ can cause infinite loops" - ^ self shallowCopy copyForBehaviorDefinitionPostCopy -] - -{ #category : #copying } -RGObject >> copyForBehaviorDefinitionPostCopy [ - - - - super postCopy. - - - - -] - -{ #category : #properties } -RGObject >> copyPropertiesFrom: anRGObject [ - - properties := anRGObject properties copy. -] - -{ #category : #copying } -RGObject >> copyWithParent: newParent [ - - "create copy of the definition and then assign the new parent" - - ^ self copy - parent: newParent; - yourself. -] - -{ #category : #'hierarchy-defaults' } -RGObject >> defaultClassStub [ - - - ^ RGClass unresolved -] - -{ #category : #'hierarchy-defaults' } -RGObject >> defaultCommentStubIn: anRGBehavior [ - - - ^ RGComment unresolved - parent: anRGBehavior; - yourself. -] - -{ #category : #'hierarchy-defaults' } -RGObject >> defaultEnvironmentStub [ - - - ^ RGEnvironment unresolved -] - -{ #category : #'hierarchy-defaults' } -RGObject >> defaultFixedLayoutStub [ - - - ^ RGFixedLayout unresolved -] - -{ #category : #'hierarchy-defaults' } -RGObject >> defaultFixedLayoutStubIn: anRGBehavior [ - - - ^ RGFixedLayout unresolved - parent: anRGBehavior; - yourself. -] - -{ #category : #'hierarchy-defaults' } -RGObject >> defaultPackageStubIn: anRGEnvironment [ - - - ^ RGPackageDefinition unresolved - parent: anRGEnvironment; - yourself. -] - -{ #category : #'managing container' } -RGObject >> defaultParentStub [ - - self subclassResponsibility -] - -{ #category : #'hierarchy-defaults' } -RGObject >> defaultTraitCompositionStub [ - - ^ RGTraitComposition unresolved -] - -{ #category : #'hierarchy-defaults' } -RGObject >> defaultTraitCompositionStubIn: anRGBehavior [ - - - ^ RGTraitComposition unresolved - parent: anRGBehavior; - yourself. -] - -{ #category : #accessing } -RGObject >> environment [ - - - - ^ self propertyNamed: #environment ifAbsent: [ self parent environment ]. -] - -{ #category : #copying } -RGObject >> fullCopy [ - - ^ self copy. -] - -{ #category : #accessing } -RGObject >> fullName [ - - ^self name -] - -{ #category : #properties } -RGObject >> hasProperties [ - - ^ properties isEmptyOrNil not -] - -{ #category : #properties } -RGObject >> hasPropertyNamed: propertyName [ - - ^ self hasProperties - ifTrue: [ properties includesKey: propertyName ] - ifFalse:[ false ]. - -] - -{ #category : #resolving } -RGObject >> hasResolved: propertySymbol [ - - ^ self resolvedProperties includes: propertySymbol - - - -] - -{ #category : #resolving } -RGObject >> hasResolvedAll: aCollectionOfSymbols [ - - ^ self resolvedProperties includesAll: aCollectionOfSymbols - - - -] - -{ #category : #testing } -RGObject >> hasResolvedName [ - - ^ self hasResolved: #name -] - -{ #category : #resolving } -RGObject >> hasUnresolved: propertySymbol [ - - ^ (self resolvedProperties includes: propertySymbol) not - - - -] - -{ #category : #resolving } -RGObject >> hasUnresolvedAll: aCollectionOfSymbols [ - - ^ (self resolvedProperties includesAll: aCollectionOfSymbols) not - - - -] - -{ #category : #initialization } -RGObject >> initialize [ - - super initialize. - - name := self unresolvedValue: self unresolvedName. - - -] - -{ #category : #initialization } -RGObject >> initializeUnresolved [ - - self propertyNamed: #resolved put: false. - name := self unresolvedValue: self unresolvedName. - - - -] - -{ #category : #'testing types' } -RGObject >> isBehavior [ - - ^ false -] - -{ #category : #'testing types' } -RGObject >> isClass [ - - ^ false -] - -{ #category : #'testing types' } -RGObject >> isComment [ - - ^false -] - -{ #category : #'testing types' } -RGObject >> isEnvironment [ - - ^false -] - -{ #category : #'testing types' } -RGObject >> isGlobalVariable [ - - ^false -] - -{ #category : #'testing types' } -RGObject >> isLayout [ - - ^false -] - -{ #category : #testing } -RGObject >> isMeta [ - - ^ false -] - -{ #category : #'testing types' } -RGObject >> isMetaclass [ - - ^ false -] - -{ #category : #'testing types' } -RGObject >> isMetaclassTrait [ - - ^ false -] - -{ #category : #'testing types' } -RGObject >> isMethod [ - - ^false -] - -{ #category : #'testing types' } -RGObject >> isPackage [ - - ^false -] - -{ #category : #'testing types' } -RGObject >> isProtocol [ - - ^false -] - -{ #category : #testing } -RGObject >> isRGObject [ - - ^true -] - -{ #category : #resolving } -RGObject >> isRingFullyResolved [ - - ^ self backend hasFullyResolved: self -] - -{ #category : #resolving } -RGObject >> isRingFullyUnresolved [ - - ^ self backend hasFullyUnresolved: self - - -] - -{ #category : #testing } -RGObject >> isRingResolved [ - - ^ self propertyNamed: #resolved ifAbsent: [ true ] -] - -{ #category : #'testing types' } -RGObject >> isSlot [ - - ^ false -] - -{ #category : #'testing types' } -RGObject >> isTraitAlias [ - - ^ false -] - -{ #category : #'testing types' } -RGObject >> isTraitComposition [ - - ^ false -] - -{ #category : #'testing types' } -RGObject >> isTraitExclusion [ - - ^ false -] - -{ #category : #'testing types' } -RGObject >> isTraitTransformation [ - - ^ false -] - -{ #category : #'testing types' } -RGObject >> isVariable [ - - "is the definition a variable class?" - - ^ false -] - -{ #category : #'testing types' } -RGObject >> isVariableDefinition [ - - ^ false -] - -{ #category : #resolving } -RGObject >> makeResolved [ - - self markAsRingResolved. - - name := self name markAsRingResolved. -] - -{ #category : #resolving } -RGObject >> markAsRingResolved [ - - self propertyNamed: #resolved put: true. - -] - -{ #category : #accessing } -RGObject >> name [ - - ^ (self backend nameFor: self) orDefaultForUnresolved -] - -{ #category : #accessing } -RGObject >> name: aString [ - - | oldName | - - oldName := name. - self backend setNameFor: self to: aString. - self parent child: self renamedFrom: oldName to: aString. - -] - -{ #category : #accessing } -RGObject >> package [ - - ^ self parent package -] - -{ #category : #accessing } -RGObject >> parent [ - "The parent of a class definition element: method, comment and variable is the class definition. This method retrieves the class that defines such element" - - - parent ifNil: [ - self parent: self defaultParentStub. - self addoptToParentStub ]. - - ^ parent. -] - -{ #category : #accessing } -RGObject >> parent: anRGBehavior [ - - "If possible, do not use this method directly." - - - parent := anRGBehavior. - "self addoptToParentStub." - - -] - -{ #category : #copying } -RGObject >> postCopy [ - - super postCopy. - - properties := properties copy. -] - -{ #category : #properties } -RGObject >> properties [ - - ^ properties ifNil: [ properties := IdentityDictionary new ] -] - -{ #category : #properties } -RGObject >> propertyNamed: propertyName [ - - ^ self - propertyNamed: propertyName - ifAbsent: [ nil ] -] - -{ #category : #properties } -RGObject >> propertyNamed: annotationName ifAbsent: exceptionBlock [ - - ^ self properties - at: annotationName - ifAbsent: [ exceptionBlock value ] -] - -{ #category : #properties } -RGObject >> propertyNamed: annotationName ifAbsentPut: blockValue [ - - ^ self properties - at: annotationName - ifAbsentPut: blockValue -] - -{ #category : #properties } -RGObject >> propertyNamed: annotationName put: value [ - - self properties - at: annotationName - put: value -] - -{ #category : #properties } -RGObject >> propertyNames [ - - self hasProperties - ifFalse:[ ^ OrderedCollection new ]. - ^ properties keys -] - -{ #category : #'private - backend interface' } -RGObject >> pvtFullyResolved [ - - ^ (self pvtResolvableProperties collect: #value) allSatisfy: #isRingFullyResolved -] - -{ #category : #'private - backend interface' } -RGObject >> pvtFullyUnresolved [ - - ^ (self pvtResolvableProperties collect: #value) noneSatisfy: #isRingFullyResolved -] - -{ #category : #'private - backend interface' } -RGObject >> pvtName [ - - ^ name -] - -{ #category : #'private - backend interface' } -RGObject >> pvtName: aString [ - - name := aString -] - -{ #category : #private } -RGObject >> pvtParent: anRGObject [ - - parent := anRGObject. -] - -{ #category : #'private - backend interface' } -RGObject >> pvtResolvableProperties [ - - ^ { #name -> name }. -] - -{ #category : #'private - backend interface' } -RGObject >> pvtResolvedProperties [ - - ^ self pvtResolvableProperties select: [:each | each value isRingResolved ] thenCollect: #key -] - -{ #category : #'private - backend interface' } -RGObject >> pvtUnresolvedProperties [ - - ^ self pvtResolvableProperties select: [:each | each value isRingResolved not ] thenCollect: #key -] - -{ #category : #properties } -RGObject >> removePropertyNamed: propertyName [ - - (self hasPropertyNamed: propertyName) - ifTrue: [ properties removeKey: propertyName ] -] - -{ #category : #accessing } -RGObject >> resolvedNameOrNil [ - - ^ self hasResolvedName - ifTrue: [ self name. ] - ifFalse: [ nil ]. -] - -{ #category : #resolving } -RGObject >> resolvedProperties [ - - ^ (self backend resolvedPropertiesFor: self) -] - -{ #category : #accessing } -RGObject >> unresolveName [ - - | oldName result | - - oldName := name. - result := self unresolvedValue: self unresolvedName. - self pvtName: result. - self parent child: self renamedFrom: oldName to: result value. - ^ result -] - -{ #category : #defaults } -RGObject >> unresolvedName [ - - ^ #unresolved -] - -{ #category : #resolving } -RGObject >> unresolvedProperties [ - - ^ (self backend unresolvedPropertiesFor: self) -] - -{ #category : #converting } -RGObject >> unresolvedValue [ - - ^ RGUnresolvedValue new. -] - -{ #category : #converting } -RGObject >> unresolvedValue: aDefaultValue [ - - ^ RGUnresolvedValue new - default: aDefaultValue; - yourself -] diff --git a/src/Ring2-Core/RGObjectLayout.class.st b/src/Ring2-Core/RGObjectLayout.class.st deleted file mode 100644 index 33a309cae..000000000 --- a/src/Ring2-Core/RGObjectLayout.class.st +++ /dev/null @@ -1,24 +0,0 @@ -Class { - #name : #RGObjectLayout, - #superclass : #RGLayout, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'testing types' } -RGObjectLayout >> isObjectLayout [ - - ^ true -] - -{ #category : #accessing } -RGObjectLayout >> layoutName [ - - ^ #ObjectLayout -] - -{ #category : #accessing } -RGObjectLayout >> slots [ - - "only for API compatibility purposes" - ^ Array new -] diff --git a/src/Ring2-Core/RGPackageDefinition.class.st b/src/Ring2-Core/RGPackageDefinition.class.st deleted file mode 100644 index 2f27fb2a4..000000000 --- a/src/Ring2-Core/RGPackageDefinition.class.st +++ /dev/null @@ -1,459 +0,0 @@ -" -RGPackageDefinition is the representation for packages. -A package manages classes, methods and children packages as elements. -A package can also know in which package is defined - -" -Class { - #name : #RGPackageDefinition, - #superclass : #RGObject, - #instVars : [ - 'definedBehaviors', - 'extensionMethods', - 'tagsForClasses' - ], - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'accessing - backend' } -RGPackageDefinition >> addClassTag: sSymbol [ - - self backend forPackage addClassTag: sSymbol to: self -] - -{ #category : #'accessing - backend' } -RGPackageDefinition >> addDefinedBehavior: anRGBehavior [ - - self backend forPackage addDefinedBehavior: anRGBehavior to: self -] - -{ #category : #'accessing - backend' } -RGPackageDefinition >> addExtensionMethod: anRGMethod [ - - self backend forPackage addExtensionMethod: anRGMethod to: self -] - -{ #category : #'managing container' } -RGPackageDefinition >> addoptToParentStub [ - - self isRingResolved ifFalse: [ ^ self ]. - - super addoptToParentStub. - - ^ self parent addPackage: self. -] - -{ #category : #accessing } -RGPackageDefinition >> categories [ - - ^ self definedBehaviors collect: #category as: Set - -] - -{ #category : #accessing } -RGPackageDefinition >> categoryName [ - - ^ self name -] - -{ #category : #accessing } -RGPackageDefinition >> classNames [ - - ^ self classes collect: #name -] - -{ #category : #accessing } -RGPackageDefinition >> classes [ - "Retrieves a collection of classes defined in the receiver and classes holding extension methods" - - ^self definedClassesOnly, self extendedClasses -] - -{ #category : #'accessing - model' } -RGPackageDefinition >> classesTaggedWith: aSymbol [ - - ^ self definedBehaviors select: [ :each | each isTaggedWith: aSymbol ] -] - -{ #category : #'accessing - backend' } -RGPackageDefinition >> cleanDefinedBehaviors [ - - self backend forPackage cleanDefinedBehaviorsFor: self -] - -{ #category : #'accessing - backend' } -RGPackageDefinition >> cleanExtensionMethods [ - - self backend forPackage cleanExtensionMethodsFor: self -] - -{ #category : #'accessing - backend' } -RGPackageDefinition >> cleanTagsForClasses [ - - self backend forPackage cleanTagsForClassesFor: self -] - -{ #category : #'default model values' } -RGPackageDefinition >> defaultDefinedBehaviors [ - - ^ Set new -] - -{ #category : #'default model values' } -RGPackageDefinition >> defaultExtensionMethods [ - - ^ Set new -] - -{ #category : #'managing container' } -RGPackageDefinition >> defaultParentStub [ - - ^ RGEnvironment new - yourself. -] - -{ #category : #'default model values' } -RGPackageDefinition >> defaultTagsForClasses [ - - ^ Set new -] - -{ #category : #'queries - behaviors' } -RGPackageDefinition >> definedBehaviors [ - - | allDefinedBehaviors | - allDefinedBehaviors := IdentitySet new. - self definedBehaviorsDo: [ :each | allDefinedBehaviors add: each]. - ^ allDefinedBehaviors asArray - -] - -{ #category : #'accessing - backend' } -RGPackageDefinition >> definedBehaviorsDo: aBlock [ - - self backend forPackage definedBehaviorsFor: self do: aBlock -] - -{ #category : #accessing } -RGPackageDefinition >> definedClassNames [ - - ^ self definedClassesOnly collect: #name -] - -{ #category : #accessing } -RGPackageDefinition >> definedClasses [ - - ^ self definedBehaviors -] - -{ #category : #'queries - behaviors' } -RGPackageDefinition >> definedClassesOnly [ - - ^ self definedBehaviors select: #isClass -] - -{ #category : #accessing } -RGPackageDefinition >> definedTraits [ - "Retrieves the traits defined in the receiver" - - ^self definedBehaviors select: #isTrait -] - -{ #category : #accessing } -RGPackageDefinition >> extendedBehaviors [ - - ^ ((self extensionMethods collect: #parent) collect: [:behavior | - behavior isClass - ifTrue: [behavior ] - ifFalse: [ behavior baseClass]] as: IdentitySet) asArray -] - -{ #category : #accessing } -RGPackageDefinition >> extendedClasses [ - - ^ self extendedBehaviors -] - -{ #category : #accessing } -RGPackageDefinition >> extendedClassesAndTraits [ - - ^ self extendedBehaviors -] - -{ #category : #accessing } -RGPackageDefinition >> extendedSelectors [ - "Retrieves the names of the methods" - - ^ self extensionMethods collect: #selector -] - -{ #category : #accessing } -RGPackageDefinition >> extendedTraits [ - - ^ (self extensionMethods collect: #parent) select: #isTrait -] - -{ #category : #accessing } -RGPackageDefinition >> extensionMethods [ - - | allMethods | - allMethods := IdentitySet new. - self extensionMethodsDo: [ :each | allMethods add: each]. - ^ allMethods asArray - -] - -{ #category : #'accessing - backend' } -RGPackageDefinition >> extensionMethodsDo: aBlock [ - - self backend forPackage extensionMethodsFor: self do: aBlock -] - -{ #category : #initialization } -RGPackageDefinition >> initialize [ - - super initialize. - - extensionMethods := self unresolvedValue: self defaultExtensionMethods. - definedBehaviors := self unresolvedValue: self defaultDefinedBehaviors. - tagsForClasses := self unresolvedValue: self defaultTagsForClasses. - -] - -{ #category : #initialization } -RGPackageDefinition >> initializeUnresolved [ - - super initializeUnresolved. - - extensionMethods := self unresolvedValue: self defaultDefinedBehaviors. - definedBehaviors := self unresolvedValue: self defaultExtensionMethods. - tagsForClasses := self unresolvedValue: self defaultTagsForClasses. - -] - -{ #category : #testing } -RGPackageDefinition >> isPackage [ - - ^true -] - -{ #category : #resolving } -RGPackageDefinition >> makeResolved [ - - super makeResolved. - - definedBehaviors := self definedBehaviors markAsRingResolved. - extensionMethods := self extensionMethods markAsRingResolved. - tagsForClasses := self tagsForClasses markAsRingResolved. - -] - -{ #category : #accessing } -RGPackageDefinition >> methods [ - "Retrieves all the methods defined in the receiver. - #methods holds the methods of defined classes" - - ^ (self definedBehaviors flatCollect: #methods), self extensionMethods -] - -{ #category : #accessing } -RGPackageDefinition >> name: aString [ - - | oldName | - - oldName := self name. - super name: aString. - - self announce: (RPackageRenamed - to: self - oldName: oldName - newName: aString) -] - -{ #category : #accessing } -RGPackageDefinition >> package [ - - ^ self -] - -{ #category : #printing } -RGPackageDefinition >> printOn: aStream [ - aStream - nextPutAll: self class name; - nextPutAll: '('; - nextPutAll: self name; - nextPutAll: ')' -] - -{ #category : #'private - backend interface' } -RGPackageDefinition >> pvtAddClassTag: aSymbol [ - - tagsForClasses isRingResolved ifFalse: [ - self pvtCleanTagsForClasses ]. - - tagsForClasses add: aSymbol. - -] - -{ #category : #'private - backend interface' } -RGPackageDefinition >> pvtAddDefinedBehavior: anRGBehavior [ - - self environment verifyOwnership: anRGBehavior. - - definedBehaviors isRingResolved ifFalse: [ - self pvtCleanDefinedBehaviors ]. - - definedBehaviors add: anRGBehavior. - -] - -{ #category : #'private - backend interface' } -RGPackageDefinition >> pvtAddExtensionMethod: aMethodDefinition [ - - self environment verifyOwnership: aMethodDefinition. - - extensionMethods isRingResolved ifFalse: [ - self pvtCleanExtensionMethods ]. - - extensionMethods add: aMethodDefinition. - - "TODO:Announce" - - -] - -{ #category : #'private - backend interface' } -RGPackageDefinition >> pvtCleanDefinedBehaviors [ - - definedBehaviors := self defaultDefinedBehaviors. - - "TODO:Announce if not empty" - - -] - -{ #category : #'private - backend interface' } -RGPackageDefinition >> pvtCleanExtensionMethods [ - - extensionMethods := self defaultExtensionMethods. - - "TODO:Announce if not empty" - - -] - -{ #category : #'private - backend interface' } -RGPackageDefinition >> pvtCleanTagsForClasses [ - - tagsForClasses := self defaultTagsForClasses. - - "TODO:Announce if not empty" - - -] - -{ #category : #'private - backend interface' } -RGPackageDefinition >> pvtDefinedBehaviorsDo: aBlock [ - - ^ definedBehaviors value do: aBlock -] - -{ #category : #'private - backend interface' } -RGPackageDefinition >> pvtExtensionMethodsDo: aBlock [ - - ^ extensionMethods value do: aBlock -] - -{ #category : #'private - backend interface' } -RGPackageDefinition >> pvtRemoveClassTag: aSymbol [ - - tagsForClasses remove: aSymbol. - - "TODO:Announce" - - -] - -{ #category : #'private - backend interface' } -RGPackageDefinition >> pvtRemoveDefinedBehavior: anRGBehavior [ - - self environment verifyOwnership: anRGBehavior. - - definedBehaviors remove: anRGBehavior. - - "TODO:Announce" - - -] - -{ #category : #'private - backend interface' } -RGPackageDefinition >> pvtRemoveExtensionMethod: anRGMethod [ - - self environment verifyOwnership: anRGMethod. - - extensionMethods remove: anRGMethod. - - "TODO:Announce" - - -] - -{ #category : #'private - backend interface' } -RGPackageDefinition >> pvtResolvableProperties [ - - ^ super pvtResolvableProperties, { - #definedBehaviors -> definedBehaviors. - #extensionMethods -> extensionMethods. - #tagsForClasses -> tagsForClasses - } - - -] - -{ #category : #'private - backend interface' } -RGPackageDefinition >> pvtTagsForClassesDo: aBlock [ - - ^ tagsForClasses value do: aBlock -] - -{ #category : #'accessing - backend' } -RGPackageDefinition >> removeClassTag: aSymbol [ - - self backend forPackage removeClassTag: aSymbol from: self -] - -{ #category : #'accessing - backend' } -RGPackageDefinition >> removeDefinedBehavior: anRGBehavior [ - - self backend forPackage removeDefinedBehavior: anRGBehavior from: self -] - -{ #category : #'accessing - backend' } -RGPackageDefinition >> removeExtensionMethod: anRGMethod [ - - self backend forPackage removeExtensionMethod: anRGMethod from: self -] - -{ #category : #'accessing - model' } -RGPackageDefinition >> tagsForClasses [ - "Retrieves the traits defined in the receiver" - - | allTags | - allTags := IdentitySet new. - self tagsForClassesDo: [ :each | allTags add: each]. - ^ allTags asArray - -] - -{ #category : #'accessing - backend' } -RGPackageDefinition >> tagsForClassesDo: aBlock [ - - self backend forPackage tagsForClassesFor: self do: aBlock -] - -{ #category : #accessing } -RGPackageDefinition >> traits [ - "Retrieves a collection of classes defined in the receiver and classes holding extension methods" - - ^self definedTraits, self extendedTraits -] diff --git a/src/Ring2-Core/RGPointerLayout.class.st b/src/Ring2-Core/RGPointerLayout.class.st deleted file mode 100644 index 22896f791..000000000 --- a/src/Ring2-Core/RGPointerLayout.class.st +++ /dev/null @@ -1,145 +0,0 @@ -Class { - #name : #RGPointerLayout, - #superclass : #RGLayout, - #instVars : [ - 'slots' - ], - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'accessing - backend' } -RGPointerLayout >> addSlot: anRGSlot [ - - self parent announceDefinitionChangeDuring: [ - self backend forBehavior addSlot: anRGSlot to: self ]. -] - -{ #category : #'queries - slots' } -RGPointerLayout >> allSlots [ - - ^ self slots -] - -{ #category : #'accessing - backend' } -RGPointerLayout >> cleanSlots [ - - self parent announceDefinitionChangeDuring: [ - self backend forBehavior cleanSlotsFor: self ]. - - -] - -{ #category : #'default model values' } -RGPointerLayout >> defaultSlots [ - - ^ OrderedCollection new -] - -{ #category : #initialization } -RGPointerLayout >> initialize [ - - super initialize. - slots := self unresolvedValue: self defaultSlots. - - -] - -{ #category : #initialization } -RGPointerLayout >> initializeUnresolved [ - - super initializeUnresolved. - slots := self unresolvedValue: self defaultSlots. - - -] - -{ #category : #'queries - slots' } -RGPointerLayout >> instVarNames [ - ^ self slots collect: #name -] - -{ #category : #'testing types' } -RGPointerLayout >> isPointerLayout [ - - ^ true -] - -{ #category : #accessing } -RGPointerLayout >> layoutName [ - - ^ #PointerLayout -] - -{ #category : #resolving } -RGPointerLayout >> makeResolved [ - - super makeResolved. - - slots := self slots asOrderedCollection markAsRingResolved. - -] - -{ #category : #'private - backend access' } -RGPointerLayout >> pvtAddSlot: anRGSlot [ - - self environment verifyOwnership: anRGSlot. - - slots isRingResolved ifFalse: [ - self pvtCleanSlots ]. - - slots add: anRGSlot. -] - -{ #category : #'private - backend access' } -RGPointerLayout >> pvtCleanSlots [ - - slots := self defaultSlots. -] - -{ #category : #'private - backend access' } -RGPointerLayout >> pvtRemoveSlot: anRGSlot [ - - self environment verifyOwnership: anRGSlot. - - slots remove: anRGSlot. - - -] - -{ #category : #'private - backend access' } -RGPointerLayout >> pvtResolvableProperties [ - - ^ super pvtResolvableProperties, { - #slots -> slots. - } - - -] - -{ #category : #'private - backend access' } -RGPointerLayout >> pvtSlotsDo: aBlock [ - - slots value do: aBlock -] - -{ #category : #'accessing - backend' } -RGPointerLayout >> removeSlot: anRGSlot [ - - self parent announceDefinitionChangeDuring: [ - self backend forBehavior removeSlot: anRGSlot from: self ]. -] - -{ #category : #'queries - slots' } -RGPointerLayout >> slots [ - - | allSlots | - allSlots := OrderedCollection new. - self slotsDo: [ :each | allSlots add: each]. - ^ allSlots asArray -] - -{ #category : #'accessing - backend' } -RGPointerLayout >> slotsDo: aBlock [ - - self backend forBehavior slotsFor: self do: aBlock -] diff --git a/src/Ring2-Core/RGPoolVariable.class.st b/src/Ring2-Core/RGPoolVariable.class.st deleted file mode 100644 index 5249aeec4..000000000 --- a/src/Ring2-Core/RGPoolVariable.class.st +++ /dev/null @@ -1,28 +0,0 @@ -" -A pool variable definition -" -Class { - #name : #RGPoolVariable, - #superclass : #RGVariable, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #'managing container' } -RGPoolVariable >> addoptToParentStub [ - - super addoptToParentStub. - - self environment backend createUnresolvedClassGroupFor: self parent -] - -{ #category : #'managing container' } -RGPoolVariable >> defaultParentStub [ - - ^ self defaultClassStub -] - -{ #category : #testing } -RGPoolVariable >> isPoolVariable [ - - ^true -] diff --git a/src/Ring2-Core/RGReadOnlyBackend.class.st b/src/Ring2-Core/RGReadOnlyBackend.class.st deleted file mode 100644 index 66bf7358b..000000000 --- a/src/Ring2-Core/RGReadOnlyBackend.class.st +++ /dev/null @@ -1,487 +0,0 @@ -Class { - #name : #RGReadOnlyBackend, - #superclass : #RGEnvironmentBackend, - #category : #'Ring2-Core-Environment' -} - -{ #category : #'as yet unclassified' } -RGReadOnlyBackend class >> for: anRGEnvironment [ - - ^ self new - environment: anRGEnvironment; - yourself. -] - -{ #category : #'trait alias' } -RGReadOnlyBackend >> addAlias: aSymbol to: anRGTraitAlias [ - - self readOnlyError -] - -{ #category : #environment } -RGReadOnlyBackend >> addBehavior: anRGBehavior to: anRGEnvironment [ - - self readOnlyError. -] - -{ #category : #package } -RGReadOnlyBackend >> addClassTag: aSymbol to: anRGPackageDefinition [ - - self readOnlyError. -] - -{ #category : #class } -RGReadOnlyBackend >> addClassVariable: anRGInstanceVariableDefinition to: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #package } -RGReadOnlyBackend >> addDefinedBehavior: anRGBehavior to: anRGPackageDefinition [ - - self readOnlyError. -] - -{ #category : #'trait exclusion' } -RGReadOnlyBackend >> addExclusion: aSymbol to: anRGTraitExclusion [ - - self readOnlyError -] - -{ #category : #package } -RGReadOnlyBackend >> addExtensionMethod: anRGMethod to: anRGPackageDefinition [ - - self readOnlyError. -] - -{ #category : #environment } -RGReadOnlyBackend >> addGlobalVariable: anRGGlobalVariable to: anRGEnvironment [ - - self readOnlyError. -] - -{ #category : #'class description' } -RGReadOnlyBackend >> addInstanceVariable: anRGInstanceVariableDefinition to: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #behavior } -RGReadOnlyBackend >> addLocalMethod: anRGMethod to: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #class } -RGReadOnlyBackend >> addMethodTag: aSymbol to: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #environment } -RGReadOnlyBackend >> addPackage: anRGPackageDefinition to: anRGEnvironment [ - - self readOnlyError. -] - -{ #category : #behavior } -RGReadOnlyBackend >> addProtocol: anRGProtocolDefinition to: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #class } -RGReadOnlyBackend >> addSharedPool: anRGPoolVariable to: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #'pointer layout' } -RGReadOnlyBackend >> addSlot: anRGSlot to: anRGLayout [ - - self readOnlyError -] - -{ #category : #'trait composition' } -RGReadOnlyBackend >> addTransformation: anRGTraitTransformation to: anRGTraitComposition [ - - self readOnlyError -] - -{ #category : #'trait alias' } -RGReadOnlyBackend >> cleanAliasesFor: anRGTraitAlias [ - - self readOnlyError -] - -{ #category : #environment } -RGReadOnlyBackend >> cleanBehaviorsFor: anRGEnvironment [ - - self readOnlyError. -] - -{ #category : #class } -RGReadOnlyBackend >> cleanClassTagsFor: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #class } -RGReadOnlyBackend >> cleanClassVariablesFor: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #package } -RGReadOnlyBackend >> cleanDefinedBehaviorsFor: anRGPackageDefinition [ - - self readOnlyError. -] - -{ #category : #'trait exclusion' } -RGReadOnlyBackend >> cleanExclusionsFor: anRGTraitExclusion [ - - self readOnlyError -] - -{ #category : #package } -RGReadOnlyBackend >> cleanExtensionMethodsFor: anRGPackageDefinition [ - - self readOnlyError. -] - -{ #category : #environment } -RGReadOnlyBackend >> cleanGlobalVariablesFor: anRGEnvironment [ - - self readOnlyError. -] - -{ #category : #'class description' } -RGReadOnlyBackend >> cleanInstanceVariablesFor: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #behavior } -RGReadOnlyBackend >> cleanLocalMethodsFor: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #method } -RGReadOnlyBackend >> cleanMethodTagsFor: anRGMethod [ - - self readOnlyError. -] - -{ #category : #environment } -RGReadOnlyBackend >> cleanPackagesFor: anRGEnvironment [ - - self readOnlyError. -] - -{ #category : #behavior } -RGReadOnlyBackend >> cleanProtocolsFor: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #class } -RGReadOnlyBackend >> cleanSharedPoolsFor: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #'pointer layout' } -RGReadOnlyBackend >> cleanSlotsFor: anRGLayout [ - - self readOnlyError -] - -{ #category : #package } -RGReadOnlyBackend >> cleanTagsForClassesFor: anRGPackageDefinition [ - - self readOnlyError. -] - -{ #category : #method } -RGReadOnlyBackend >> cleanTagsForMethodsFor: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #'trait composition' } -RGReadOnlyBackend >> cleanTransformationsFor: anRGTraitComposition [ - - self readOnlyError -] - -{ #category : #'unresolved objects' } -RGReadOnlyBackend >> createNewUnresolvedClass [ - - self readOnlyError -" | unresolvedValue | - - unresolvedValue := RGUnresolvedValue new. - unresolvedValue default: unresolvedValue. - ^ unresolvedValue." - -] - -{ #category : #'unresolved objects' } -RGReadOnlyBackend >> createNewUnresolvedMetaclassFor: anRGBehavior [ - - self readOnlyError - "^ RGUnresolvedValue recursive" -] - -{ #category : #'unresolved objects' } -RGReadOnlyBackend >> createNewUnresolvedMetaclassMetaclassFor: anRGBehavior [ - - self readOnlyError - "| unresolvedValue | - - unresolvedValue := RGUnresolvedValue new. - unresolvedValue default: unresolvedValue. - ^ unresolvedValue." -] - -{ #category : #'as yet unclassified' } -RGReadOnlyBackend >> readOnlyError [ - - self error: 'read-only environment' -] - -{ #category : #'trait alias' } -RGReadOnlyBackend >> removeAlias: aSymbol from: anRGTraitAlias [ - - self readOnlyError -] - -{ #category : #environment } -RGReadOnlyBackend >> removeBehavior: anRGBehavior from: anRGEnvironment [ - - self readOnlyError. -] - -{ #category : #package } -RGReadOnlyBackend >> removeClassTag: aSymbol from: anRGPackageDefinition [ - - self readOnlyError. -] - -{ #category : #class } -RGReadOnlyBackend >> removeClassVariable: anRGInstanceVariableDefinition from: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #package } -RGReadOnlyBackend >> removeDefinedBehavior: anRGBehavior from: anRGPackageDefinition [ - - self readOnlyError. -] - -{ #category : #'trait exclusion' } -RGReadOnlyBackend >> removeExclusion: aSymbol from: anRGTraitExclusion [ - - self readOnlyError -] - -{ #category : #package } -RGReadOnlyBackend >> removeExtensionMethod: anRGMethod from: anRGPackageDefinition [ - - self readOnlyError. -] - -{ #category : #environment } -RGReadOnlyBackend >> removeGlobalVariable: anRGGlobalVariable from: anRGEnvironment [ - - self readOnlyError. -] - -{ #category : #'class description' } -RGReadOnlyBackend >> removeInstanceVariable: anRGInstanceVariableDefinition from: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #behavior } -RGReadOnlyBackend >> removeLocalMethod: anRGMethod from: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #class } -RGReadOnlyBackend >> removeMethodTag: aSymbol from: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #environment } -RGReadOnlyBackend >> removePackage: anRGPackageDefinition from: anRGEnvironment [ - - self readOnlyError. -] - -{ #category : #behavior } -RGReadOnlyBackend >> removeProtocol: anRGProtocolDefinition from: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #class } -RGReadOnlyBackend >> removeSharedPool: anRGPoolVariable from: anRGBehavior [ - - self readOnlyError. -] - -{ #category : #'pointer layout' } -RGReadOnlyBackend >> removeSlot: anRGSlot from: anRGLayout [ - - self readOnlyError -] - -{ #category : #'trait composition' } -RGReadOnlyBackend >> removeTransformation: anRGTraitTransformation from: anRGTraitComposition [ - - self readOnlyError -] - -{ #category : #metaclass } -RGReadOnlyBackend >> setBaseClassFor: anRGBehavior to: anRGClass [ - - self readOnlyError. -] - -{ #category : #'class comment' } -RGReadOnlyBackend >> setClassCommentAuthorFor: anRGComment to: aString [ - - self readOnlyError. -] - -{ #category : #'class comment' } -RGReadOnlyBackend >> setClassCommentContentFor: anRGComment to: anObject [ - - self readOnlyError. -] - -{ #category : #'class comment' } -RGReadOnlyBackend >> setClassCommentTimeFor: anRGComment to: aDateAndTime [ - - self readOnlyError. -] - -{ #category : #trait } -RGReadOnlyBackend >> setClassTraitFor: anRGTrait to: anRGMetatraitDefinition [ - - self readOnlyError -] - -{ #category : #class } -RGReadOnlyBackend >> setCommentFor: anRGBehavior to: anRGComment [ - - self readOnlyError. -] - -{ #category : #slot } -RGReadOnlyBackend >> setExpressionFor: anRGUnknownSlot to: aString [ - - self readOnlyError -] - -{ #category : #behavior } -RGReadOnlyBackend >> setLayoutFor: anRGBehavior to: anRGLayout [ - - self readOnlyError. -] - -{ #category : #'class description' } -RGReadOnlyBackend >> setMetaClassFor: anRGBehavior to: anRGMetaclass [ - - self readOnlyError. -] - -{ #category : #method } -RGReadOnlyBackend >> setMethodPackageFor: anRGMethod to: anRGPackageDefinition [ - - self readOnlyError. -] - -{ #category : #method } -RGReadOnlyBackend >> setMethodStampFor: anRGMethod to: anObject [ - - self readOnlyError. -] - -{ #category : #general } -RGReadOnlyBackend >> setNameFor: anRGObject to: aString [ - - self readOnlyError. -] - -{ #category : #class } -RGReadOnlyBackend >> setPackageFor: anRGBehavior to: anRGPackageDefinition [ - - self readOnlyError. -] - -{ #category : #method } -RGReadOnlyBackend >> setProtocolFor: anRGMethod to: anObject [ - - self readOnlyError. -] - -{ #category : #method } -RGReadOnlyBackend >> setSourceCodeFor: anRGMethod to: anObject [ - - self readOnlyError. -] - -{ #category : #'trait transormation' } -RGReadOnlyBackend >> setSubjectFor: anRGTraitComposition to: anRGTrait [ - - self readOnlyError -] - -{ #category : #behavior } -RGReadOnlyBackend >> setSuperclassFor: anRGBehavior to: anObject [ - - self readOnlyError. -] - -{ #category : #trait } -RGReadOnlyBackend >> setTraitCommentFor: anRGBehavior to: anRGComment [ - - self readOnlyError -] - -{ #category : #trait } -RGReadOnlyBackend >> setTraitPackageFor: anRGBehavior to: anRGPackageDefinition [ - - self readOnlyError -] - -{ #category : #class } -RGReadOnlyBackend >> tagClass: anRGBehavior with: aSymbol [ - - self readOnlyError. -] - -{ #category : #class } -RGReadOnlyBackend >> tagMethod: anRGMethod with: aSymbol [ - - self readOnlyError. -] - -{ #category : #class } -RGReadOnlyBackend >> untagClass: anRGBehavior from: aSymbol [ - - self readOnlyError. -] - -{ #category : #method } -RGReadOnlyBackend >> untagMethod: anRGMethod from: aSymbol [ - - self readOnlyError. -] diff --git a/src/Ring2-Core/RGReadOnlyImageBackend.class.st b/src/Ring2-Core/RGReadOnlyImageBackend.class.st deleted file mode 100644 index 00fc1a8ac..000000000 --- a/src/Ring2-Core/RGReadOnlyImageBackend.class.st +++ /dev/null @@ -1,436 +0,0 @@ -Class { - #name : #RGReadOnlyImageBackend, - #superclass : #RGReadOnlyBackend, - #category : #'Ring2-Core-Environment' -} - -{ #category : #'as yet unclassified' } -RGReadOnlyImageBackend class >> for: anRGEnvironment [ - - ^ self new - environment: anRGEnvironment; - yourself. -] - -{ #category : #'trait alias' } -RGReadOnlyImageBackend >> aliasesFor: anRGTraitAlias do: aBlock [ - - ^ (anRGTraitAlias propertyNamed: #realObject ifAbsent: [ self error: 'You can use only trait transformations generated directly by this backend' ]) aliases associations do: [:each | aBlock value: each ] -] - -{ #category : #method } -RGReadOnlyImageBackend >> astFor: anRGMethod [ - - ^ anRGMethod astFromSource -] - -{ #category : #method } -RGReadOnlyImageBackend >> authorFor: anRGMethod [ - - ^ RGStampParser authorForStamp: (self realMethodFor: anRGMethod) stamp -] - -{ #category : #metaclass } -RGReadOnlyImageBackend >> baseClassFor: anRGMetaclassTrait [ - - ^ (self realBehaviorFor: anRGMetaclassTrait) baseClass asRingMinimalDefinitionIn: anRGMetaclassTrait environment. -] - -{ #category : #environment } -RGReadOnlyImageBackend >> behaviorsFor: anRGEnvironment do: aBlock [ - - SystemNavigation default allBehaviors do: [:each | - | def | - def := self definitionFor: each ifAbsentRegister: [each asRingMinimalDefinitionIn: anRGEnvironment]. - aBlock value: def.]. -] - -{ #category : #class } -RGReadOnlyImageBackend >> categoryFor: anRGBehavior [ - - ^ (self realBehaviorFor: anRGBehavior) category - -] - -{ #category : #'class comment' } -RGReadOnlyImageBackend >> classCommentAuthorFor: anRGComment [ - - ^ RGStampParser authorForStamp: (self realBehaviorFor: anRGComment parent) organization commentStamp. - -] - -{ #category : #'class comment' } -RGReadOnlyImageBackend >> classCommentContentFor: anRGComment [ - - ^ (self realBehaviorFor: anRGComment parent) organization classComment. - -] - -{ #category : #'class comment' } -RGReadOnlyImageBackend >> classCommentTimeFor: anRGComment [ - - ^ RGStampParser timeForStamp: (self realBehaviorFor: anRGComment parent) organization commentStamp. -] - -{ #category : #trait } -RGReadOnlyImageBackend >> classTraitFor: anRGTrait [ - - ^ (self realBehaviorFor: anRGTrait) classTrait asRingMinimalDefinitionIn: anRGTrait environment. -] - -{ #category : #class } -RGReadOnlyImageBackend >> classVariablesFor: anRGBehavior do: aBlock [ - - | realClass | - realClass := self realBehaviorFor: anRGBehavior. - realClass classVariables do: [ :classVariable | - | def | - def := RGClassVariable named: classVariable key parent: anRGBehavior. - aBlock value: def. ] -] - -{ #category : #class } -RGReadOnlyImageBackend >> commentFor: anRGBehavior [ - - ^ (self realBehaviorFor: anRGBehavior) asRingMinimalCommentDefinitionIn: self environment -] - -{ #category : #'unresolved objects' } -RGReadOnlyImageBackend >> createUnresolvedClassGroupFor: anRGBehavior [ - - ^ anRGBehavior isMeta - ifFalse: [ anRGBehavior ] - ifTrue: [ anRGBehavior metaclass]. - -] - -{ #category : #package } -RGReadOnlyImageBackend >> definedBehaviorsFor: anRGPackageDefinition do: aBlock [ - - | realPackage | - - realPackage := self realPackageFor: anRGPackageDefinition. - realPackage ifNotNil: [ - realPackage definedClassesDo: [:behaviorName | - | def cls | - cls := Smalltalk classOrTraitNamed: behaviorName. - def := self definitionFor: cls ifAbsentRegister: [cls asRingMinimalDefinitionIn: anRGPackageDefinition environment]. - aBlock value: def.]] -] - -{ #category : #'as yet unclassified' } -RGReadOnlyImageBackend >> definitionFor: anObject [ - - ^ self definitionFor: anObject ifAbsentRegister: [ anObject ensureRingDefinitionIn: self environment ] - -] - -{ #category : #'trait exclusion' } -RGReadOnlyImageBackend >> exclusionsFor: anRGTraitExclusion do: aBlock [ - - ^ (anRGTraitExclusion propertyNamed: #realObject ifAbsent: [ self error: 'You can use only trait transformations generated directly by this backend' ]) exclusions do: [:each | aBlock value: each ] -] - -{ #category : #slot } -RGReadOnlyImageBackend >> expressionFor: anRGUnknownSlot [ - - | realClass realSlot | - - realClass := self realBehaviorFor: anRGUnknownSlot parent parent. - realSlot := realClass slotNamed: anRGUnknownSlot name. - ^ (realSlot printString copyAfter: $>) trimBoth - -] - -{ #category : #package } -RGReadOnlyImageBackend >> extensionMethodsFor: anRGPackageDefinition do: aBlock [ - - | realPackage | - - realPackage := self realPackageFor: anRGPackageDefinition. - realPackage ifNotNil: [ - realPackage extensionMethods do: [:aCompiledMethod | - | def | - def := self definitionFor: aCompiledMethod ifAbsentRegister: [aCompiledMethod asRingMinimalDefinitionIn: anRGPackageDefinition environment]. - aBlock value: def.]] -] - -{ #category : #environment } -RGReadOnlyImageBackend >> globalVariablesFor: anRGEnvironment do: aBlock [ - - Smalltalk globals associations do: [:each | - | def | - def := self definitionFor: each ifAbsentRegister: [each asRingMinimalDefinitionIn: anRGEnvironment]. - aBlock value: def.]. -] - -{ #category : #resolving } -RGReadOnlyImageBackend >> hasFullyResolved: anRGObject [ - - ^ true - -] - -{ #category : #resolving } -RGReadOnlyImageBackend >> hasFullyUnresolved: anRGObject [ - - ^ false -] - -{ #category : #resolving } -RGReadOnlyImageBackend >> hasResolved: anRGObject [ - - ^ true - -] - -{ #category : #method } -RGReadOnlyImageBackend >> hasSourceCodeFor: anRGMethod [ - - ^ (self realMethodFor: anRGMethod) sourceCode -] - -{ #category : #initialization } -RGReadOnlyImageBackend >> initialize [ - - super initialize. - - providedDefinitions := IdentityDictionary new. - -] - -{ #category : #behavior } -RGReadOnlyImageBackend >> layoutFor: anRGBehavior [ - - | realClass realLayout def | - - realClass := self realBehaviorFor: anRGBehavior. - realLayout := realClass classLayout. - def := self definitionFor: realLayout ifAbsentRegister: [ - realLayout asRingMinimalDefinitionIn: anRGBehavior environment ]. - ^ def -] - -{ #category : #behavior } -RGReadOnlyImageBackend >> localMethodsFor: anRGBehavior do: aBlock [ - - (self realBehaviorFor: anRGBehavior) localMethods do: [:method | - | def | - def := self definitionFor: method ifAbsentRegister: [ - method asRingMinimalDefinitionIn: anRGBehavior environment]. - aBlock value: def] - -] - -{ #category : #'class description' } -RGReadOnlyImageBackend >> metaClassFor: anRGBehavior [ - - | realClass realMetaclass def | - - realClass := self realBehaviorFor: anRGBehavior. - realMetaclass := realClass class. - def := self definitionFor: realMetaclass ifAbsentRegister: [ - realMetaclass asRingMinimalDefinitionIn: anRGBehavior environment ]. - ^ def - -] - -{ #category : #behavior } -RGReadOnlyImageBackend >> metaclassFor: anRGBehavior [ - - | realBehavior realMetaclass def | - - realBehavior := self realBehaviorFor: anRGBehavior. - realMetaclass := realBehavior class. - def := self definitionFor: realMetaclass ifAbsentRegister: [ - realMetaclass asRingMinimalDefinitionIn: anRGBehavior environment ]. - ^ def - -] - -{ #category : #'metaclass trait' } -RGReadOnlyImageBackend >> metaclassTraitBaseTraitFor: anRGMetaclassTrait [ - - ^ (self realBehaviorFor: anRGMetaclassTrait) baseTrait asRingMinimalDefinitionIn: anRGMetaclassTrait environment. -] - -{ #category : #method } -RGReadOnlyImageBackend >> methodPackageFor: anRGMethod [ - - ^ (self realMethodFor: anRGMethod) package asRingMinimalDefinitionIn: anRGMethod environment. -] - -{ #category : #general } -RGReadOnlyImageBackend >> nameFor: anRGObject [ - - ^ anRGObject pvtName -] - -{ #category : #class } -RGReadOnlyImageBackend >> packageFor: anRGBehavior [ - - ^ (self realBehaviorFor: anRGBehavior) package asRingMinimalDefinitionIn: anRGBehavior environment. -] - -{ #category : #environment } -RGReadOnlyImageBackend >> packagesFor: anRGEnvironment do: aBlock [ - - RPackageOrganizer default packagesDo: [:each | - | def | - def := self definitionFor: each ifAbsentRegister: [each asRingMinimalDefinitionIn: anRGEnvironment]. - aBlock value: def.]. -] - -{ #category : #'as yet unclassified' } -RGReadOnlyImageBackend >> realBehaviorFor: anRGBehavior [ - - "TODO: should we cache the definition?" - ^ Smalltalk classOrTraitNamed: anRGBehavior name asSymbol -] - -{ #category : #'as yet unclassified' } -RGReadOnlyImageBackend >> realMethodFor: anRGMethod [ - - "TODO: should we cache the definition?" - ^ ((self realBehaviorFor: anRGMethod parent) >> anRGMethod selector) - - -] - -{ #category : #'as yet unclassified' } -RGReadOnlyImageBackend >> realPackageFor: anRGPackageDefinition [ - - ^ RPackageOrganizer default packageNamed: anRGPackageDefinition name ifAbsent: [nil]. -] - -{ #category : #resolving } -RGReadOnlyImageBackend >> resolvedPropertiesFor: anRGObject [ - - ^ anRGObject pvtResolvableProperties collect: #key -] - -{ #category : #class } -RGReadOnlyImageBackend >> sharedPoolsFor: anRGBehavior do: aBlock [ - - ^ anRGBehavior behaviorStrategy pvtSharedPoolsDo: aBlock -] - -{ #category : #'pointer layout' } -RGReadOnlyImageBackend >> slotsFor: anRGLayout do: aBlock [ - | realClass | - realClass := self realBehaviorFor: anRGLayout parent. - realClass classLayout slots - do: [ :each | - | def | - def := self - definitionFor: each - ifAbsentRegister: [ each asRingMinimalDefinitionIn: anRGLayout environment ]. - aBlock value: def ] -] - -{ #category : #method } -RGReadOnlyImageBackend >> sourceCodeFor: anRGMethod [ - - ^ (self realMethodFor: anRGMethod) sourceCode - -] - -{ #category : #'trait transormation' } -RGReadOnlyImageBackend >> subjectFor: anRGTraitTransformation [ - - ^ (anRGTraitTransformation propertyNamed: #realObject ifAbsent: [ self error: 'You can use only trait transformations generated directly by this backend' ]) subject asRingMinimalDefinitionIn: anRGTraitTransformation environment -] - -{ #category : #behavior } -RGReadOnlyImageBackend >> superclassFor: anRGBehavior [ - - | realClass realSuperclass def | - - realClass := self realBehaviorFor: anRGBehavior. - realSuperclass := realClass superclass. - realSuperclass ifNil: [ realSuperclass := realClass ]. - def := self definitionFor: realSuperclass ifAbsentRegister: [ - realSuperclass asRingMinimalDefinitionIn: anRGBehavior environment ]. - ^ def - -] - -{ #category : #behavior } -RGReadOnlyImageBackend >> tagsForClass: anRGBehavior do: aBlock [ - - | realClass | - - realClass := self realBehaviorFor: anRGBehavior. - realClass tags do: [:tag | aBlock value: tag ] - -] - -{ #category : #method } -RGReadOnlyImageBackend >> tagsForMethod: anRGMethod do: aBlock [ - - | realMethod | - - realMethod := self realMethodFor: anRGMethod. - { realMethod protocol } do: aBlock. -] - -{ #category : #method } -RGReadOnlyImageBackend >> tagsForMethodsFor: anRGBehavior do: aBlock [ - - (self realBehaviorFor: anRGBehavior) protocols do: aBlock - -] - -{ #category : #method } -RGReadOnlyImageBackend >> timeFor: anRGMethod [ - - ^ RGStampParser timeForStamp: (self realMethodFor: anRGMethod) stamp -] - -{ #category : #trait } -RGReadOnlyImageBackend >> traitCommentFor: anRGBehavior [ - - ^ (self realBehaviorFor: anRGBehavior) asRingMinimalCommentDefinitionIn: self environment -] - -{ #category : #behavior } -RGReadOnlyImageBackend >> traitCompositionFor: anRGBehavior [ - - | realClass realTraitComposition def | - - realClass := self realBehaviorFor: anRGBehavior. - realTraitComposition := realClass traitComposition. - def := self definitionFor: realTraitComposition ifAbsentRegister: [ - realTraitComposition asRingMinimalDefinitionIn: anRGBehavior environment ]. - ^ def - -] - -{ #category : #trait } -RGReadOnlyImageBackend >> traitPackageFor: anRGBehavior [ - - ^ (self realBehaviorFor: anRGBehavior) package asRingMinimalDefinitionIn: anRGBehavior environment. -] - -{ #category : #'trait composition' } -RGReadOnlyImageBackend >> transformationsFor: anRGTraitComposition do: aBlock [ - - | realBehavior realTraitComposition | - "^ anRGTraitComposition pvtTransformationsDo: aBlock" - - realBehavior := self realBehaviorFor: anRGTraitComposition parent. - realTraitComposition := realBehavior traitComposition. - - realTraitComposition transformations do: [:transformation | - | def | - def := self definitionFor: transformation ifAbsentRegister: [ - transformation asRingMinimalDefinitionIn: anRGTraitComposition environment]. - aBlock value: def] - -] - -{ #category : #resolving } -RGReadOnlyImageBackend >> unresolvedPropertiesFor: anRGObject [ - - ^ Dictionary new. -] diff --git a/src/Ring2-Core/RGResolvingError.class.st b/src/Ring2-Core/RGResolvingError.class.st deleted file mode 100644 index eadbe6165..000000000 --- a/src/Ring2-Core/RGResolvingError.class.st +++ /dev/null @@ -1,10 +0,0 @@ -" -I'm a specialized error exception used mainly during failures in applying of changes on Ring models in cases when you cannot determine to which entity in the model the change should be applied. - - -" -Class { - #name : #RGResolvingError, - #superclass : #Error, - #category : #'Ring2-Core-Kernel' -} diff --git a/src/Ring2-Core/RGSlot.class.st b/src/Ring2-Core/RGSlot.class.st deleted file mode 100644 index b7a23985f..000000000 --- a/src/Ring2-Core/RGSlot.class.st +++ /dev/null @@ -1,49 +0,0 @@ -Class { - #name : #RGSlot, - #superclass : #RGElement, - #category : #'Ring2-Core-Kernel' -} - -{ #category : #bootstrap } -RGSlot >> accept: anInterpreter assign: aValue inNode: aVariableNode [ - self error: #TBD -] - -{ #category : #'managing container' } -RGSlot >> addoptToParentStub [ - - super addoptToParentStub. - self parent addSlot: self. -] - -{ #category : #'managing container' } -RGSlot >> defaultParentStub [ - - ^ self defaultFixedLayoutStub -] - -{ #category : #accessing } -RGSlot >> definitionString [ - - ^ String streamContents: [ :aStream | - aStream nextPutAll: '#'; nextPutAll: self name] -] - -{ #category : #'testing types' } -RGSlot >> isSlot [ - - ^ true -] - -{ #category : #testing } -RGSlot >> isSpecial [ - - ^ true -] - -{ #category : #accessing } -RGSlot >> name: aString [ - - self parent parent announceDefinitionChangeDuring: [ - super name: aString ]. -] diff --git a/src/Ring2-Core/RGStampParser.class.st b/src/Ring2-Core/RGStampParser.class.st deleted file mode 100644 index c1b470b5b..000000000 --- a/src/Ring2-Core/RGStampParser.class.st +++ /dev/null @@ -1,134 +0,0 @@ -Class { - #name : #RGStampParser, - #superclass : #Object, - #category : #'Ring2-Core-Parsing' -} - -{ #category : #parsing } -RGStampParser class >> authorForStamp: aString [ - - ^ aString isEmptyOrNil - ifTrue: [ self historicalStamp ] - ifFalse: [ self parseAuthorAliasFrom: aString ]. -] - -{ #category : #parsing } -RGStampParser class >> historicalStamp [ - - ^ '' -] - -{ #category : #parsing } -RGStampParser class >> parseAuthorAliasFrom: aString [ - - ^ self new basicParseAuthorAliasFrom: aString -] - -{ #category : #parsing } -RGStampParser class >> parseTimestampFrom: aString [ - - ^ self new parseTimestampFrom: aString -] - -{ #category : #parsing } -RGStampParser class >> timeForStamp: stamp [ - - ^ self new timeForStamp: stamp -] - -{ #category : #'parsing stamp' } -RGStampParser >> basicParseAuthorAliasFrom: aString [ - "Parse an alias/name of the author from a string that is extracted from a source file. If there is no alias/name we return emtpy string." - - | tokens dateStartIndex unknown | - "The following timestamp strings are supported (source: squeak sources archeological survey): -