CopyClassRefactoring broken by d2b8d98

Since d2b8d98 AddClassRefactoring creates a class as described by ClassDetails, and this can include variables. This broke CopyClassRefactoring because it tried to add the variables as well after creating the class with them already defined, and there was a test gap so this went unnoticed. The refactoring is enhanced to copy the variables of superclasses that it references. This ensures that the copied methods will compile. Any inherited but unreferenced variables are not copied. There might be place for copying down inherited methods that are not overriden and not common, but not for now. This is a refactoring since the existing behaviour of the system is preserved, even if the cloned class is not complete. The preconditions for AddClassRefactoring should also have been enriched to validate the variables.
dolphinsmalltalk · Dec 20, 2023 · f2b1b56 · f2b1b56
1 parent 9575c15
commit f2b1b56
Show file tree

Hide file tree

Showing 43 changed files with 943 additions and 220 deletions.
diff --git a/...butions/Refactory/Refactoring Browser/Change Objects/Refactory.Browser.AddClassChange.cls b/...butions/Refactory/Refactoring Browser/Change Objects/Refactory.Browser.AddClassChange.cls
@@ -42,7 +42,7 @@ definingSuperclass
 	^self class!
 
 definition
-	^definition ifNil: [definition := details printString]!
+	^definition ifNil: [definition := details fullPrintString]!
 
 definition: aString 
 	definition := aString.

diff --git a/...ributions/Refactory/Refactoring Browser/Change Objects/Refactory.Browser.ClassDetails.cls b/...ributions/Refactory/Refactoring Browser/Change Objects/Refactory.Browser.ClassDetails.cls
@@ -27,6 +27,9 @@ category: anObject
 categoryNames
 	^categoryNames!
 
+classBindingNames
+	^self classVariableNames , (self classConstants collect: [:each | each key])!
+
 classCategories
 	^categoryNames ifNotNil: [categoryNames collect: [:each | ClassCategory name: each]]!
 
@@ -52,6 +55,15 @@ className
 className: anObject
 	classReference := anObject asQualifiedReference!
 
+className: anObject superclass: aClass categories: aCollection
+	self className: anObject.
+	aClass
+		ifNil: [instanceSpec := 0]
+		ifNotNil: 
+			[superclassReference := aClass fullyQualifiedReference.
+			instanceSpec := aClass instanceSpec].
+	self categories: aCollection!
+
 classReference
 	^classReference!
 
@@ -135,6 +147,18 @@ instanceVariableString
 instanceVariableString: aString
 	instanceVariableNames := $\x20 split: aString!
 
+instSize
+	"Answer the number of fixed fields (named instance variables) in instances of the receiver."
+
+	"If the instance variables have been changed, the instSize there may be out of date, so calculate it."
+
+	^superclassReference value instSize + self instanceVariableNames size!
+
+instSize: anInteger
+	(anInteger between: 0 and: (self isBytes ifTrue: [0] ifFalse: [Behavior._SizeMask]))
+		ifFalse: [self error: 'Invalid number of fixed fields'].
+	instanceSpec := (self instanceSpec maskClear: Behavior._SizeMask) maskSet: anInteger!
+
 isBytes
 	"Answer whether the class described by the receiver has indexable instance variables that are bytes, as opposed to pointers."
 
@@ -215,10 +239,10 @@ kindOfSubclass
 
 kindOfSubclass: aString
 	aString = 'subclass:'
-		ifTrue: [self instanceSpec: Behavior._IsPointersMask]
+		ifTrue: [self instanceSpec: Behavior._PointersMask]
 		ifFalse: 
 			[aString = 'variableSubclass:'
-				ifTrue: [self instanceSpec: Behavior._IsPointersMask | Behavior._VariableMask]
+				ifTrue: [self instanceSpec: Behavior._PointersMask | Behavior._VariableMask]
 				ifFalse: [self instanceSpec: Behavior._VariableMask]]!
 
 name
@@ -348,6 +372,7 @@ categories!accessing!public! !
 categories:!accessing!public! !
 category:!accessing!public! !
 categoryNames!accessing!public! !
+classBindingNames!accessing!public! !
 classCategories!accessing!public! !
 classConstants!accessing!public! !
 classConstants:!accessing!public! !
@@ -356,6 +381,7 @@ classInstanceVariableNames:!accessing!public! !
 classInstanceVariableString:!accessing!public! !
 className!accessing!public! !
 className:!accessing!public! !
+className:superclass:categories:!accessing!initializing!private! !
 classReference!accessing!public! !
 classVariableNames!accessing!public! !
 classVariableNames:!accessing!public! !
@@ -378,6 +404,8 @@ instanceVariableNames!accessing!public! !
 instanceVariableNames:!accessing!public! !
 instanceVariableString!accessing!public! !
 instanceVariableString:!accessing!public! !
+instSize!instance specification-accessing!public! !
+instSize:!accessing!public! !
 isBytes!instance specification-testing!public! !
 isBytes:!instance specification-accessing!public! !
 isInBaseEnvironment!public!testing! !
@@ -418,9 +446,9 @@ unqualifiedName!accessing!public! !
 
 className: aString superclass: aClass categories: aCollection
 	^self new
-		className: aString;
-		superclass: aClass;
-		categories: aCollection;
+		className: aString
+			superclass: aClass
+			categories: aCollection;
 		yourself!
 
 fromClass: aClassDescription

diff --git a/...ontributions/Refactory/Refactoring Browser/Parser/Refactory.Browser.ParseTreeSearcher.cls b/...ontributions/Refactory/Refactoring Browser/Parser/Refactory.Browser.ParseTreeSearcher.cls
@@ -216,7 +216,7 @@ buildSelectorString: aSelector
 			stream
 				nextPutAll: (keywords at: i);
 				nextPutAll: ' ``@arg';
-				nextPutAll: i printString;
+				print: i;
 				nextPut: $\x20].
 	^stream contents!
 

diff --git a/...ntributions/Refactory/Refactoring Browser/Parser/Refactory.Browser.RBBindingReference.cls b/...ntributions/Refactory/Refactoring Browser/Parser/Refactory.Browser.RBBindingReference.cls
@@ -46,6 +46,9 @@ realReference
 referenceInModel: aRBModel
 	^model == aRBModel ifTrue: [self] ifFalse: [self class model: aRBModel reference: reference]!
 
+species
+	^reference species!
+
 valueOfBinding: aVariableBinding
 	^reference isMeta ifTrue: [aVariableBinding value metaclass] ifFalse: [aVariableBinding value]! !
 !Refactory.Browser.RBBindingReference categoriesForMethods!
@@ -56,6 +59,7 @@ model:!initializing!private! !
 newWrapping:!converting!private! !
 realReference!accessing!public! !
 referenceInModel:!converting!public! !
+species!comparing!public! !
 valueOfBinding:!accessing!private! !
 !
 

diff --git a/...ions/Refactory/Refactoring Browser/Refactorings/Refactory.Browser.AddClassRefactoring.cls b/...ions/Refactory/Refactoring Browser/Refactorings/Refactory.Browser.AddClassRefactoring.cls
@@ -18,6 +18,9 @@ className
 definitionMessage
 	^details printString!
 
+details
+	^details!
+
 details: aClassDetails subclasses: aCollection
 	details := aClassDetails.
 	details className: (aClassDetails classReference referenceInModel: self model).
@@ -26,21 +29,43 @@ details: aClassDetails subclasses: aCollection
 	subclasses := aCollection collect: [:each | self classObjectFor: each]!
 
 preconditions
-	| cond superNotMeta superclass |
-	#rbFix.	"Bodge to allow for nil superclass"
-	superclass := details superclass.
-	superNotMeta := superclass isNil
-				ifTrue: [RBCondition empty]
-				ifFalse: 
-					[((RBCondition isMetaclass: superclass) errorMacro: 'Superclass must <1?not :>be a metaclass') not].
-	cond := subclasses inject: superNotMeta
+	| cond superclass |
+	superclass := self superclass.
+	cond := subclasses inject: self superclassPreconditions
 				into: 
 					[:sub :each |
 					sub & ((RBCondition isMetaclass: each) errorMacro: 'Subclass must <1?not :>be a metaclass') not
 						& (RBCondition isImmediateSubclass: each of: superclass)].
-	#rbFix.	"Dolphin's class categories are named by Strings, not Symbols, and any class can be in multiple categories"
 	^cond & (RBCondition isValidClassName: self className)
-		& (RBCondition isStatic: self className in: self model) not!
+		& (RBCondition isStatic: self className in: self model) not
+			& ((RBCondition withBlock: [details isPointers or: [details instanceVariableNames isEmpty]])
+					errorMacro: ClassBuilder.ErrorBytesAndNamedInstVars;
+					yourself)
+			& ((RBCondition withBlock: 
+						[details instanceVariableNames asBag
+							removeAll: details instanceVariableNames asSet;
+							isEmpty])
+					errorMacro: 
+							[ClassBuilder.ErrorInstVarAlreadyDefined << (details instanceVariableNames asOrderedCollection
+										removeAll: details instanceVariableNames asSet;
+										first)];
+					yourself)
+			& ((RBCondition withBlock: 
+						[| varNames |
+						varNames := details classBindingNames.
+						varNames asBag
+							removeAll: varNames asSet;
+							isEmpty])
+					errorMacro: 
+							[| varNames |
+							varNames := details classBindingNames.
+							ClassBuilder.ErrorClassVarAlreadyDefined << {
+										self className.
+										varNames asSortedCollection
+											removeAll: varNames asSet;
+											first
+									}];
+					yourself)!
 
 storeOn: aStream
 	aStream
@@ -52,6 +77,46 @@ storeOn: aStream
 		store: details;
 		nextPut: $)!
 
+superclass
+	^details superclass!
+
+superclassPreconditions
+	| superclass cond |
+	superclass := self superclass.
+	superclass ifNil: [^RBCondition empty].
+	cond := (RBCondition isSubclassable: superclass)
+				& ((RBCondition isMetaclass: superclass) errorMacro: 'Superclass must <1?not :>be a metaclass') not.
+	details isBytes
+		ifTrue: 
+			[cond := cond & ((RBCondition withBlock: [superclass isBytes or: [superclass isVariable not]])
+								errorMacro: [ClassBuilder.ErrorByteSubclassOfVariable << superclass];
+								yourself)
+						& ((RBCondition withBlock: [superclass instSize == 0])
+								errorMacro: [ClassBuilder.ErrorByteSubclassOfFixed << superclass];
+								yourself)]
+		ifFalse: 
+			[cond := cond & ((RBCondition withBlock: [superclass isPointers])
+								errorMacro: [ClassBuilder.ErrorPointerSubclassOfBytes << superclass];
+								yourself)
+						& ((RBCondition withBlock: 
+									["If the superclass is variable, then the subclass must be too"
+									superclass isVariable not or: [details isVariable]])
+								errorMacro: [ClassBuilder.ErrorFixedSubclassOfVariable << superclass];
+								yourself)].
+	details instanceVariableNames do: 
+			[:each |
+			cond := cond & (RBCondition isValidInstanceVariableName: each)
+						& (RBCondition definesInstanceVariable: each in: superclass) not].
+	details classBindingNames do: 
+			[:each |
+			cond := cond & (RBCondition isValidClassVarName: each)
+						& (RBCondition definesClassVariable: each in: superclass) not].
+	details classInstanceVariableNames do: 
+			[:each |
+			cond := cond & (RBCondition isValidInstanceVariableName: each)
+						& (RBCondition definesInstanceVariable: each in: superclass metaclass) not].
+	^cond!
+
 transform
 	#rbFix.	"Factor out #definitionMessage in order to permit override in subclass"
 	self model
@@ -60,9 +125,12 @@ transform
 !Refactory.Browser.AddClassRefactoring categoriesForMethods!
 className!accessing!public! !
 definitionMessage!public!transforming! !
+details!accessing!private! !
 details:subclasses:!initializing!private! !
-preconditions!public! !
+preconditions!preconditions!public! !
 storeOn:!printing!public! !
+superclass!accessing!private! !
+superclassPreconditions!preconditions!private! !
 transform!public!transforming! !
 !
 

diff --git a/...actory/Refactoring Browser/Refactorings/Refactory.Browser.AddClassVariableRefactoring.cls b/...actory/Refactoring Browser/Refactorings/Refactory.Browser.AddClassVariableRefactoring.cls
@@ -13,7 +13,7 @@ Refactory.Browser.AddClassVariableRefactoring comment: ''!
 !Refactory.Browser.AddClassVariableRefactoring methodsFor!
 
 preconditions
-	^(RBCondition isMetaclass: class) not & (RBCondition isValidClassVarName: variableName for: class)
+	^(RBCondition isMetaclass: class) not & (RBCondition isValidClassVarName: variableName)
 		& (RBCondition hierarchyOf: class definesVariable: variableName asString) not
 			& (RBCondition isStatic: variableName in: self model) not!
 

diff --git a/...ory/Refactoring Browser/Refactorings/Refactory.Browser.AddInstanceVariableRefactoring.cls b/...ory/Refactoring Browser/Refactorings/Refactory.Browser.AddInstanceVariableRefactoring.cls
@@ -13,7 +13,7 @@ Refactory.Browser.AddInstanceVariableRefactoring comment: ''!
 !Refactory.Browser.AddInstanceVariableRefactoring methodsFor!
 
 preconditions
-	^(RBCondition isValidInstanceVariableName: variableName for: class)
+	^(RBCondition isValidInstanceVariableName: variableName)
 		& (RBCondition hierarchyOf: class definesVariable: variableName) not
 			& (RBCondition isStatic: variableName in: self model) not!
 

diff --git a/...butions/Refactory/Refactoring Browser/Refactorings/Refactory.Browser.ClassRefactoring.cls b/...butions/Refactory/Refactoring Browser/Refactorings/Refactory.Browser.ClassRefactoring.cls
@@ -20,7 +20,10 @@ className: aString
 	self classReference: (BindingReference fullPathString: aString)!
 
 classReference: aBindingReference
-	className := aBindingReference referenceInModel: self model!
+	"Accessing the model may lazily create it, which involves setting its name to the displayString of this refactoring. Since the displayString may involve the className, we have a chicken-before-egg problem. To workround this we set the className twice - once to the original binding reference, and then again to the reference in the model."
+
+	className := aBindingReference.
+	className := className referenceInModel: self model!
 
 environment
 	^className environment!

diff --git a/...tory/Refactoring Browser/Refactorings/Refactory.Browser.ExtractToTemporaryRefactoring.cls b/...tory/Refactoring Browser/Refactorings/Refactory.Browser.ExtractToTemporaryRefactoring.cls
@@ -63,8 +63,8 @@ parseTree
 	^self method parseTreeWithSourceIntervals ifNil: [self refactoringError: 'Could not parse method']!
 
 preconditions
-	^(RBCondition definesSelector: selector in: class) 
-		& (RBCondition isValidInstanceVariableName: newVariableName for: class) 
+	^(RBCondition definesSelector: selector in: class)
+		& (RBCondition isValidInstanceVariableName: newVariableName)
 			& (RBCondition withBlock: 
 						[self verifySelectedInterval.
 						self checkVariableName.

diff --git a/...ns/Refactory/Refactoring Browser/Refactorings/Refactory.Browser.MoveMethodRefactoring.cls b/...ns/Refactory/Refactoring Browser/Refactorings/Refactory.Browser.MoveMethodRefactoring.cls
@@ -104,7 +104,7 @@ getAllClassesForGlobalOrClassVariable
 getArgumentNameForSelf
 	self needsToReplaceSelfReferences ifFalse: [^self].
 	selfVariableName := self requestSelfArgumentName.
-	(self checkInstanceVariableName: selfVariableName in: class)
+	(self checkInstanceVariableName: selfVariableName)
 		ifTrue: 
 			[self verifyTemporaryVariableDoesNotOverride
 				ifFalse: 

diff --git a/.../Refactoring Browser/Refactorings/Refactory.Browser.MoveVariableDefinitionRefactoring.cls b/.../Refactoring Browser/Refactorings/Refactory.Browser.MoveVariableDefinitionRefactoring.cls
@@ -51,20 +51,16 @@ class: aClass selector: aSelector interval: anInterval
 !
 
 preconditions
-	^(RBCondition definesSelector: selector in: class) 
+	^(RBCondition definesSelector: selector in: class)
 		& (RBCondition withBlock: 
 					[| methodSource |
-					interval first <= interval last 
-						ifFalse: [self refactoringError: 'Invalid variable name'].
+					interval first <= interval last ifFalse: [self refactoringError: 'Invalid variable name'].
 					methodSource := class sourceCodeFor: selector.
-					methodSource size >= interval last 
-						ifFalse: [self refactoringError: 'Invalid range for variable'].
-					#rbFix. "Allow trailing blanks in the selection"
+					methodSource size >= interval last ifFalse: [self refactoringError: 'Invalid range for variable'].
+					#rbFix.	"Allow trailing blanks in the selection"
 					name := (methodSource copyFrom: interval first to: interval last) trimBlanks.
-					(self checkInstanceVariableName: name in: class) 
-						ifFalse: 
-							[self 
-								refactoringError: name , ' does not seem to be a valid variable name.'].
+					(self checkInstanceVariableName: name)
+						ifFalse: [self refactoringError: name , ' does not seem to be a valid variable name.'].
 					method := class methodFor: selector.
 					parseTree := method parseTreeWithSourceIntervals.
 					self checkParseTree.