From a8c7b77ee097c7eaaecbce2d376efa2bdfe3edad Mon Sep 17 00:00:00 2001 From: CyrilFerlicot Date: Tue, 9 May 2023 12:13:48 +0200 Subject: [PATCH 1/6] ClassDescription>>protocols should return protocols Fixes ##10856 --- .../ClassDescriptionProtocolsTest.class.st | 14 ++++++++++++++ src/Kernel/ClassDescription.class.st | 8 ++++++++ .../ClassDescription.extension.st | 10 ---------- 3 files changed, 22 insertions(+), 10 deletions(-) delete mode 100644 src/Ring-Definitions-Core/ClassDescription.extension.st diff --git a/src/Kernel-Tests/ClassDescriptionProtocolsTest.class.st b/src/Kernel-Tests/ClassDescriptionProtocolsTest.class.st index 23105fdca43..d29f9644d77 100644 --- a/src/Kernel-Tests/ClassDescriptionProtocolsTest.class.st +++ b/src/Kernel-Tests/ClassDescriptionProtocolsTest.class.st @@ -46,3 +46,17 @@ ClassDescriptionProtocolsTest >> testProtocolNames [ self assertCollection: class protocolNames hasSameElements: #( #human #witch ) ] + +{ #category : #tests } +ClassDescriptionProtocolsTest >> testProtocols [ + + class organization addProtocol: #titan. + class organization addProtocol: #human. + class organization addProtocol: #witch. + + self assertCollection: class protocols hasSameElements: (#( #titan #human #witch ) collect: [ :protocolName | class organization protocolNamed: protocolName ]). + + class organization removeProtocolIfEmpty: #titan. + + self assertCollection: class protocols hasSameElements: (#( #human #witch ) collect: [ :protocolName | class organization protocolNamed: protocolName ]) +] diff --git a/src/Kernel/ClassDescription.class.st b/src/Kernel/ClassDescription.class.st index 4b6494e3d65..7edde985d9b 100644 --- a/src/Kernel/ClassDescription.class.st +++ b/src/Kernel/ClassDescription.class.st @@ -760,6 +760,14 @@ ClassDescription >> protocolNames [ ^ self organization protocolNames copy ] +{ #category : #'accessing - protocols' } +ClassDescription >> protocols [ + "I return all the protocols contained in me. + In the past I was returning the protocol names but now I am returning the instances directly. If you want to deal with the names you can use #protocolNames." + + ^ self organization protocols +] + { #category : #compiling } ClassDescription >> reformatAll [ "Reformat all methods in this class" diff --git a/src/Ring-Definitions-Core/ClassDescription.extension.st b/src/Ring-Definitions-Core/ClassDescription.extension.st deleted file mode 100644 index 36b11fadee9..00000000000 --- a/src/Ring-Definitions-Core/ClassDescription.extension.st +++ /dev/null @@ -1,10 +0,0 @@ -Extension { #name : #ClassDescription } - -{ #category : #'*Ring-Definitions-Core' } -ClassDescription >> protocols [ - - self - deprecated: 'Use #protocolNames instead because I should return real protocols and not just names.' - transformWith: '`@rcv protocols' -> '`@rcv protocolNames'. - ^ self organization protocolNames copy -] From 05bd898a87470e91cde3bc178468b2a4d728e341 Mon Sep 17 00:00:00 2001 From: CyrilFerlicot Date: Tue, 9 May 2023 12:16:38 +0200 Subject: [PATCH 2/6] Use #protocols instead of `organization protocols` --- .../ClassDescription.extension.st | 2 +- .../TraitedMetaclass.extension.st | 2 +- src/CodeExport/ClassDescription.extension.st | 4 ++-- src/Kernel/ClassDescription.class.st | 2 +- src/RPackage-Core/RPackageOrganizer.class.st | 11 ++++------- .../ProperMethodCategorizationTest.class.st | 3 +-- src/ReleaseTests/ProtocolConventionsTest.class.st | 2 +- 7 files changed, 11 insertions(+), 15 deletions(-) diff --git a/src/Calypso-SystemQueries/ClassDescription.extension.st b/src/Calypso-SystemQueries/ClassDescription.extension.st index cb7ca6785f4..fad59e83295 100644 --- a/src/Calypso-SystemQueries/ClassDescription.extension.st +++ b/src/Calypso-SystemQueries/ClassDescription.extension.st @@ -5,7 +5,7 @@ ClassDescription >> tagsForAllMethods [ "I act as #tagsForMethods but I also takes into account methods comming from traits" | allProtocols | - allProtocols := self organization protocols reject: [ :each | each isUnclassifiedProtocol | each isExtensionProtocol ]. + allProtocols := self protocols reject: [ :each | each isUnclassifiedProtocol | each isExtensionProtocol ]. ^ allProtocols select: [ :protocol | protocol methodSelectors ifEmpty: [ true ] ifNotEmpty: [ :methods | methods anySatisfy: [ :method | self selectors includes: method ] ] ] diff --git a/src/Calypso-SystemQueries/TraitedMetaclass.extension.st b/src/Calypso-SystemQueries/TraitedMetaclass.extension.st index de91e867d7e..90a20a08b70 100644 --- a/src/Calypso-SystemQueries/TraitedMetaclass.extension.st +++ b/src/Calypso-SystemQueries/TraitedMetaclass.extension.st @@ -5,7 +5,7 @@ TraitedMetaclass >> tagsForAllMethods [ "I act as #tagsForMethods but I also takes into account methods comming from traits" | allProtocols selectors | - allProtocols := self organization protocols reject: [ :each | each isUnclassifiedProtocol | each isExtensionProtocol ]. + allProtocols := self protocols reject: [ :each | each isUnclassifiedProtocol | each isExtensionProtocol ]. selectors := self visibleMethods collect: [ :each | each selector ]. diff --git a/src/CodeExport/ClassDescription.extension.st b/src/CodeExport/ClassDescription.extension.st index ca72b8878c8..a72d3f6f715 100644 --- a/src/CodeExport/ClassDescription.extension.st +++ b/src/CodeExport/ClassDescription.extension.st @@ -5,7 +5,7 @@ ClassDescription >> fileOutChangedMessages: aSet on: aFileStream [ "File a description of the messages of this class that have been changed (i.e., are entered into the argument, aSet) onto aFileStream." - self organization protocols do: [ :protocol | + self protocols do: [ :protocol | protocol methodSelectors select: [ :selector | aSet includes: selector ] thenDo: [ :selector | self printMethodChunk: selector on: aFileStream ] ] @@ -49,7 +49,7 @@ ClassDescription >> fileOutOn: aFileStream [ aFileStream nextChunkPut: self oldPharoDefinition. self putCommentOnFile: aFileStream. - self organization protocols do: [ :protocol | self fileOutLocalMethodsInProtocol: protocol on: aFileStream ] + self protocols do: [ :protocol | self fileOutLocalMethodsInProtocol: protocol on: aFileStream ] ] { #category : #'*CodeExport' } diff --git a/src/Kernel/ClassDescription.class.st b/src/Kernel/ClassDescription.class.st index 7edde985d9b..e6cf8a245e6 100644 --- a/src/Kernel/ClassDescription.class.st +++ b/src/Kernel/ClassDescription.class.st @@ -1008,7 +1008,7 @@ ClassDescription >> tagsForMethods [ which is opposite to current Protocol implementation. And extension protocol is not treated as tag" | allProtocols | - allProtocols := self organization protocols reject: [ :each | each isUnclassifiedProtocol | each isExtensionProtocol ]. + allProtocols := self protocols reject: [ :each | each isUnclassifiedProtocol | each isExtensionProtocol ]. ^ allProtocols select: [ :each | self isLocalMethodsProtocol: each ] thenCollect: #name ] diff --git a/src/RPackage-Core/RPackageOrganizer.class.st b/src/RPackage-Core/RPackageOrganizer.class.st index 5df81d50fc4..f55c0b8ee47 100644 --- a/src/RPackage-Core/RPackageOrganizer.class.st +++ b/src/RPackage-Core/RPackageOrganizer.class.st @@ -551,15 +551,12 @@ RPackageOrganizer >> initializeFor: aBehavior [ { #category : #'initialization - data' } RPackageOrganizer >> initializeMethodsFor: aBehavior [ - | package | + | package | package := aBehavior package. - (aBehavior organization protocols - select: [ :each | each isExtensionProtocol not ]) - do: [ :eachProtocol | - (eachProtocol methodSelectors - select: [ :eachSelector | (aBehavior >> eachSelector) origin = aBehavior ]) - do: [ :eachSelector | package addMethod: (aBehavior >> eachSelector) ] ] + (aBehavior protocols reject: [ :each | each isExtensionProtocol ]) do: [ :eachProtocol | + (eachProtocol methodSelectors select: [ :eachSelector | (aBehavior >> eachSelector) origin = aBehavior ]) do: [ :eachSelector | + package addMethod: aBehavior >> eachSelector ] ] ] { #category : #'system organizer facade' } diff --git a/src/ReleaseTests/ProperMethodCategorizationTest.class.st b/src/ReleaseTests/ProperMethodCategorizationTest.class.st index 7634e1531fe..dcd648cc4e3 100644 --- a/src/ReleaseTests/ProperMethodCategorizationTest.class.st +++ b/src/ReleaseTests/ProperMethodCategorizationTest.class.st @@ -143,8 +143,7 @@ ProperMethodCategorizationTest >> testNoEmptyProtocols [ | violations | violations := Dictionary new. ProtoObject withAllSubclasses do: [ :cls | - (cls organization protocols select: [ :protocol | protocol isEmpty ]) - ifNotEmpty: [ :emptyProtocols | violations at: cls put: emptyProtocols ] ]. + (cls protocols select: [ :protocol | protocol isEmpty ]) ifNotEmpty: [ :emptyProtocols | violations at: cls put: emptyProtocols ] ]. self assertEmpty: violations ] diff --git a/src/ReleaseTests/ProtocolConventionsTest.class.st b/src/ReleaseTests/ProtocolConventionsTest.class.st index 70cbfa41d37..558bdd4a5e1 100644 --- a/src/ReleaseTests/ProtocolConventionsTest.class.st +++ b/src/ReleaseTests/ProtocolConventionsTest.class.st @@ -13,7 +13,7 @@ Class { ProtocolConventionsTest >> assertProtocolName: aProtocolName notAcceptingProtocolNamesLike: aCollectionOfSelectors [ | violations | violations := self class environment allClassesAndTraits - select: [ :c | (c protocolNames includesAny: aCollectionOfSelectors) or: [ c class protocols includesAny: aCollectionOfSelectors ] ]. + select: [ :c | (c protocolNames includesAny: aCollectionOfSelectors) or: [ c class protocolNames includesAny: aCollectionOfSelectors ] ]. self assert: violations isEmpty description: [ 'In the default Pharo images, the protocol #{1} should be used instead of {2}. From b2cc30211839b1f836841bfe67e704016f9ae7ff Mon Sep 17 00:00:00 2001 From: CyrilFerlicot Date: Sun, 21 May 2023 01:36:41 +0200 Subject: [PATCH 3/6] Try to make bootstrap build --- src/Monticello/MCClassDefinition.class.st | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Monticello/MCClassDefinition.class.st b/src/Monticello/MCClassDefinition.class.st index 86547368b80..60c69e257dd 100644 --- a/src/Monticello/MCClassDefinition.class.st +++ b/src/Monticello/MCClassDefinition.class.st @@ -171,6 +171,13 @@ MCClassDefinition >> createClass [ ifTrue: [ Context comment = comment ifFalse: [ Context comment: comment stamp: commentStamp ]. ^ self ]. + + "Ignore FullBlockClosure definition because of troubles with class migration on bootstrapped image. Temporary solution." + name = #FullBlockClosure + ifTrue: [ FullBlockClosure comment = comment + ifFalse: [ FullBlockClosure comment: comment stamp: commentStamp ]. + ^ self ]. + superClass := superclassName = #nil ifFalse: [ Smalltalk globals at: superclassName ]. ^ [ Smalltalk classInstaller From 814fe55da31fc0865f16e5277c2f65837928460b Mon Sep 17 00:00:00 2001 From: CyrilFerlicot Date: Sun, 21 May 2023 02:03:06 +0200 Subject: [PATCH 4/6] Update MCClassDefinition.class.st --- src/Monticello/MCClassDefinition.class.st | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Monticello/MCClassDefinition.class.st b/src/Monticello/MCClassDefinition.class.st index 60c69e257dd..bb92fe78885 100644 --- a/src/Monticello/MCClassDefinition.class.st +++ b/src/Monticello/MCClassDefinition.class.st @@ -172,10 +172,10 @@ MCClassDefinition >> createClass [ ifFalse: [ Context comment: comment stamp: commentStamp ]. ^ self ]. - "Ignore FullBlockClosure definition because of troubles with class migration on bootstrapped image. Temporary solution." - name = #FullBlockClosure - ifTrue: [ FullBlockClosure comment = comment - ifFalse: [ FullBlockClosure comment: comment stamp: commentStamp ]. + "Ignore CompiledBlock definition because of troubles with class migration on bootstrapped image. Temporary solution." + name = #CompiledBlock + ifTrue: [ CompiledBlock comment = comment + ifFalse: [ CompiledBlock comment: comment stamp: commentStamp ]. ^ self ]. superClass := superclassName = #nil From fe0d727dea25ace67806484def4b8c6bae526d5f Mon Sep 17 00:00:00 2001 From: CyrilFerlicot Date: Tue, 23 May 2023 15:39:34 +0200 Subject: [PATCH 5/6] Remove hack --- src/Monticello/MCClassDefinition.class.st | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Monticello/MCClassDefinition.class.st b/src/Monticello/MCClassDefinition.class.st index bb92fe78885..4f2e1dc8ad8 100644 --- a/src/Monticello/MCClassDefinition.class.st +++ b/src/Monticello/MCClassDefinition.class.st @@ -172,12 +172,6 @@ MCClassDefinition >> createClass [ ifFalse: [ Context comment: comment stamp: commentStamp ]. ^ self ]. - "Ignore CompiledBlock definition because of troubles with class migration on bootstrapped image. Temporary solution." - name = #CompiledBlock - ifTrue: [ CompiledBlock comment = comment - ifFalse: [ CompiledBlock comment: comment stamp: commentStamp ]. - ^ self ]. - superClass := superclassName = #nil ifFalse: [ Smalltalk globals at: superclassName ]. ^ [ Smalltalk classInstaller From 7a9336d789012fd730c2bb56ac48e0e6b10f3329 Mon Sep 17 00:00:00 2001 From: CyrilFerlicot Date: Tue, 30 May 2023 16:07:59 +0200 Subject: [PATCH 6/6] Adapt to latest P12 --- src/Kernel-Tests/ClassDescriptionProtocolsTest.class.st | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Kernel-Tests/ClassDescriptionProtocolsTest.class.st b/src/Kernel-Tests/ClassDescriptionProtocolsTest.class.st index 9348d3863a9..783d6572aa6 100644 --- a/src/Kernel-Tests/ClassDescriptionProtocolsTest.class.st +++ b/src/Kernel-Tests/ClassDescriptionProtocolsTest.class.st @@ -229,11 +229,11 @@ ClassDescriptionProtocolsTest >> testProtocols [ class organization addProtocol: #human. class organization addProtocol: #witch. - self assertCollection: class protocols hasSameElements: (#( #titan #human #witch ) collect: [ :protocolName | class organization protocolNamed: protocolName ]). + self assertCollection: class protocols hasSameElements: (#( #titan #human #witch ) collect: [ :protocolName | class protocolNamed: protocolName ]). class organization removeProtocolIfEmpty: #titan. - self assertCollection: class protocols hasSameElements: (#( #human #witch ) collect: [ :protocolName | class organization protocolNamed: protocolName ]) + self assertCollection: class protocols hasSameElements: (#( #human #witch ) collect: [ :protocolName | class protocolNamed: protocolName ]) ] { #category : #tests }