diff --git a/src/Epicea-Tests/EpCodeChangeIntegrationTest.class.st b/src/Epicea-Tests/EpCodeChangeIntegrationTest.class.st index de3c6ff590b..d807b799e83 100644 --- a/src/Epicea-Tests/EpCodeChangeIntegrationTest.class.st +++ b/src/Epicea-Tests/EpCodeChangeIntegrationTest.class.st @@ -202,6 +202,21 @@ EpCodeChangeIntegrationTest >> testMethodAddition [ self assert: (self countLogEventsWith: EpMethodAddition) equals: 1 ] +{ #category : 'tests' } +EpCodeChangeIntegrationTest >> testMethodAdditionFromExistingClass [ + + | anotherClass | + aClass := classFactory newClass. + aClass compile: 'fortyTwo ^42'. + + self assert: (self countLogEventsWith: EpMethodAddition) equals: 1. + + anotherClass := classFactory newClass. + anotherClass compileAllFrom: aClass. + + self assert: (self countLogEventsWith: EpMethodAddition) equals: 2 +] + { #category : 'tests' } EpCodeChangeIntegrationTest >> testMethodModificationOfProtocol [ diff --git a/src/Kernel-Tests/ClassAnnouncementsTest.class.st b/src/Kernel-Tests/ClassAnnouncementsTest.class.st index d65d2d969d6..d7990309d61 100644 --- a/src/Kernel-Tests/ClassAnnouncementsTest.class.st +++ b/src/Kernel-Tests/ClassAnnouncementsTest.class.st @@ -6,6 +6,21 @@ Class { #tag : 'Classes' } +{ #category : 'tests' } +ClassAnnouncementsTest >> testDuplicatingAClassAnnouncesAddition [ + + class compile: 'billy ^ #meow' classified: '*' , self packageNameForTests , '2'. + + self when: ClassAdded do: [ :ann | + self assert: ann classAffected originalName equals: self classNameForTests, '2'. + self assert: ann packageAffected name equals: self packageNameForTests. + self assertCollection: (ann packagesAffected collect: [ :package | package name ]) hasSameElements: { self packageNameForTests } ]. + + class duplicateClassWithNewName: self classNameForTests, '2'. + + self assert: numberOfAnnouncements equals: 1 +] + { #category : 'tests' } ClassAnnouncementsTest >> testRemovingAClassWithExtension [ "Regression test about an issue where class removed was not returning the extension packages in its affected packages" diff --git a/src/Kernel-Tests/MethodAnnouncementsTest.class.st b/src/Kernel-Tests/MethodAnnouncementsTest.class.st index 6f91defd6ac..834c8576bf4 100644 --- a/src/Kernel-Tests/MethodAnnouncementsTest.class.st +++ b/src/Kernel-Tests/MethodAnnouncementsTest.class.st @@ -26,6 +26,25 @@ MethodAnnouncementsTest >> testCompileMethodAnnounceAddition [ self assert: numberOfAnnouncements equals: 1 ] +{ #category : 'tests' } +MethodAnnouncementsTest >> testCompileMethodByDuplicatingAClassAnnounceAddition [ + + class compiler + protocol: #titan; + install: 'king ^ 1'. + + self when: MethodAdded do: [ :ann | + self assert: ann method selector equals: #king. + self assert: ann method protocol name equals: #titan. + self assert: ann methodClass name equals: self classNameForTests, '2'. + self assert: ann methodPackage name equals: self packageNameForTests. + self assert: ann packagesAffected equals: { self packageNameForTests asPackage } ]. + + class duplicateClassWithNewName: self classNameForTests, '2'. + + self assert: numberOfAnnouncements equals: 1 +] + { #category : 'tests' } MethodAnnouncementsTest >> testRemoveMethodAnnounceRemoval [ diff --git a/src/OpalCompiler-Core/Behavior.extension.st b/src/OpalCompiler-Core/Behavior.extension.st index 4a1b3ed0c47..941dc0256c1 100644 --- a/src/OpalCompiler-Core/Behavior.extension.st +++ b/src/OpalCompiler-Core/Behavior.extension.st @@ -15,6 +15,26 @@ Behavior >> compile: code [ ^self compile: code notifying: nil ] +{ #category : '*OpalCompiler-Core' } +Behavior >> compile: selector from: oldClass [ + "Compile the method associated with selector in the receiver's method dictionary." + + | method newMethod | + method := oldClass compiledMethodAt: selector. + newMethod := oldClass compiler + source: (oldClass sourceCodeAt: selector); + priorMethod: method; + class: self; + permitFaulty: true; + "No need to log recompilation in the sources, + We are going to reuse the original source pointer." + logged: false; + install. + newMethod sourcePointer: method sourcePointer. + selector == newMethod selector ifFalse: [ + self error: 'selector changed!' ] +] + { #category : '*OpalCompiler-Core' } Behavior >> compile: code notifying: requestor [ "Compile the argument, code, as source code in the context of the @@ -46,7 +66,7 @@ Behavior >> compileAllFrom: oldClass [ "Compile all the methods in the receiver's method dictionary. This validates sourceCode and variable references and forces all methods to use the current bytecode set" - oldClass localSelectors do: [:sel | self recompile: sel from: oldClass] + oldClass localSelectors do: [:sel | self compile: sel from: oldClass] ] { #category : '*OpalCompiler-Core' } @@ -83,24 +103,8 @@ Behavior >> recompile: selector [ { #category : '*OpalCompiler-Core' } Behavior >> recompile: selector from: oldClass [ - "Compile the method associated with selector in the receiver's method dictionary." - - | method newMethod | "Recompilation should be done silently, to avoid putting noise in the system" self codeChangeAnnouncer suspendAllWhile: [ - method := oldClass compiledMethodAt: selector. - newMethod := oldClass compiler - source: (oldClass sourceCodeAt: selector); - priorMethod: method; - class: self; - permitFaulty: true; - "No need to log recompilation in the sources, - We are going to reuse the original source pointer." - logged: false; - install ]. - - newMethod sourcePointer: method sourcePointer. - selector == newMethod selector ifFalse: [ - self error: 'selector changed!' ] + self compile: selector from: oldClass ]. ] diff --git a/src/Shift-ClassBuilder/ShiftClassBuilder.class.st b/src/Shift-ClassBuilder/ShiftClassBuilder.class.st index f0d232af29d..5d2911761b2 100644 --- a/src/Shift-ClassBuilder/ShiftClassBuilder.class.st +++ b/src/Shift-ClassBuilder/ShiftClassBuilder.class.st @@ -56,7 +56,8 @@ Class { 'superclassResolver', 'inRemake', 'package', - 'tag' + 'tag', + 'movedToPackage' ], #classVars : [ 'BuilderEnhancer' @@ -118,6 +119,7 @@ ShiftClassBuilder >> build [ self createClass. self oldClass ifNotNil: [ + self copyPackage. self copyProtocols. self newClass commentSourcePointer: self oldClass commentSourcePointer ]. @@ -125,8 +127,11 @@ ShiftClassBuilder >> build [ self installSlotsAndVariables. - self oldClass ifNotNil: [ self builderEnhancer compileMethodsFor: self ]. - + self oldClass ifNotNil: [ + self builderEnhancer compileMethodsFor: self. + self environment codeChangeAnnouncer announce: (ClassAdded class: newClass). + + ]. self builderEnhancer afterMethodsCompiled: self. ^ newClass ] @@ -222,6 +227,34 @@ ShiftClassBuilder >> compileMethods [ removeNonexistentSelectorsFromProtocols ] +{ #category : 'building' } +ShiftClassBuilder >> copyPackage [ + + | oldPackage oldTag | + + self isRebuild ifTrue: [ + oldPackage := oldClass package name. + oldTag := oldClass packageTag name. + + { oldClass instanceSide . oldClass classSide } + do: [:cls | cls package removeClass: cls ] . + + self package ifNil: [ + self environment codeChangeAnnouncer suspendAllWhile: [ + newClass package: oldPackage tag: oldTag. + movedToPackage := true + ] + ] + ]. + self movedToPackage ifFalse: [ + self environment codeChangeAnnouncer suspendAllWhile: [ + newClass package: self package tag: self tag. + movedToPackage := true + ]. + ] + +] + { #category : 'building' } ShiftClassBuilder >> copyProtocols [ @@ -482,6 +515,11 @@ ShiftClassBuilder >> metaclassClass [ ^ self builderEnhancer metaclassClassFor: self ] +{ #category : 'accessing' } +ShiftClassBuilder >> movedToPackage [ + ^ movedToPackage ifNil: [ movedToPackage := false ] +] + { #category : 'accessing' } ShiftClassBuilder >> name [ ^ name diff --git a/src/Shift-ClassBuilder/ShiftClassInstaller.class.st b/src/Shift-ClassBuilder/ShiftClassInstaller.class.st index 55e52d20c4f..ae5310c475e 100644 --- a/src/Shift-ClassBuilder/ShiftClassInstaller.class.st +++ b/src/Shift-ClassBuilder/ShiftClassInstaller.class.st @@ -170,8 +170,8 @@ ShiftClassInstaller >> installingEnvironment: anEnvironment [ { #category : 'building' } ShiftClassInstaller >> make [ - | newClass | + | newClass | [ newClass := builder build. @@ -185,14 +185,14 @@ ShiftClassInstaller >> make [ builder builderEnhancer afterMigratingClass: builder installer: self. - builder builderEnhancer propagateChangesToRelatedClasses: newClass builder: builder. + builder builderEnhancer propagateChangesToRelatedClasses: newClass builder: builder - ] on: ShNoChangesInClass do:[ + ] on: ShNoChangesInClass do: [ "If there are no changes in the building, I am not building or replacing nothing" - newClass := self oldClass. + newClass := self oldClass ]. - self updatePackage: newClass. + builder movedToPackage ifFalse: [ self updatePackage: newClass ]. self comment: newClass. self notifyChanges.