Merge pull request #14676 from jecisc/kernel/make-sure-category-is-ne…

…ver-nil Kernel: Make sure category is never nil
pharo-project · Sep 17, 2023 · 97ba76a · 97ba76a
2 parents 366f303 + 0a2e6fa
commit 97ba76a
Show file tree

Hide file tree

Showing 15 changed files with 224 additions and 210 deletions.
diff --git a/src/Kernel/Class.class.st b/src/Kernel/Class.class.st
@@ -276,14 +276,14 @@ Class >> category [
 	category name stored in the ivar is still correct and only if this fails look it up
 	(latter is much more expensive)"
 
-	| result |
-	self basicCategory ifNotNil: [ :symbol |
-		symbol = Class unclassifiedCategory ifTrue: [ ^ symbol ].
+	| result cat |
+	cat := self basicCategory.
 
-		((self packageOrganizer listAtCategoryNamed: symbol) includes: self name) ifTrue: [ ^ symbol ] ].
+	cat = Class unclassifiedCategory ifTrue: [ ^ cat ].
 
+	"The next lines are only useful anymore because of a problem in Fuel that should be resolved in not too long. Then we will be able to just return #basicCategory in this whole method"
+	((self packageOrganizer listAtCategoryNamed: cat) includes: self name) ifTrue: [ ^ cat ].
 	result := (self packageOrganizer categoryOfBehavior: self) ifNil: [ #Unclassified ].
-
 	self basicCategory: result.
 
 	^ result

diff --git a/src/Shift-ClassBuilder/ClassResolver.class.st b/src/Shift-ClassBuilder/ClassResolver.class.st
@@ -2,17 +2,18 @@
 I am in charge of resolving the existence of a class
 "
 Class {
-	#name : #ClassResolver,
-	#superclass : #Object,
-	#category : #'Shift-ClassBuilder'
+	#name : 'ClassResolver',
+	#superclass : 'Object',
+	#category : 'Shift-ClassBuilder',
+	#package : 'Shift-ClassBuilder'
 }
 
-{ #category : #resolving }
+{ #category : 'resolving' }
 ClassResolver >> resolve: aCDClassDefinitionNode [
 	^self subclassResponsibility
 ]
 
-{ #category : #resolving }
+{ #category : 'resolving' }
 ClassResolver >> resolve: aClassName inEnv: anEnvironment [
 	^ (anEnvironment classNamed: aClassName) ifNil: [ self resolve: aClassName ]
 ]
diff --git a/src/Shift-ClassBuilder/ClassResolverStrictResolve.class.st b/src/Shift-ClassBuilder/ClassResolverStrictResolve.class.st
@@ -2,12 +2,13 @@
 My strategy is to raise an error if the class doesn't exist
 "
 Class {
-	#name : #ClassResolverStrictResolve,
-	#superclass : #ClassResolver,
-	#category : #'Shift-ClassBuilder'
+	#name : 'ClassResolverStrictResolve',
+	#superclass : 'ClassResolver',
+	#category : 'Shift-ClassBuilder',
+	#package : 'Shift-ClassBuilder'
 }
 
-{ #category : #resolving }
+{ #category : 'resolving' }
 ClassResolverStrictResolve >> resolve: aClassName [
 	"^Error new:'You''re superclass doesn''t exist'."
 	^ self error: 'Superclass ', aClassName,' doesn''t exist'

diff --git a/src/Shift-ClassBuilder/DangerousClassNotifier.class.st b/src/Shift-ClassBuilder/DangerousClassNotifier.class.st
@@ -21,15 +21,16 @@ restoreState
 
 "
 Class {
-	#name : #DangerousClassNotifier,
-	#superclass : #Object,
+	#name : 'DangerousClassNotifier',
+	#superclass : 'Object',
 	#classInstVars : [
 		'enabled'
 	],
-	#category : #'Shift-ClassBuilder'
+	#category : 'Shift-ClassBuilder',
+	#package : 'Shift-ClassBuilder'
 }
 
-{ #category : #validation }
+{ #category : 'validation' }
 DangerousClassNotifier class >> check: classSymbol [
 
 	self enabled ifFalse: [ ^false ].
@@ -38,12 +39,12 @@ DangerousClassNotifier class >> check: classSymbol [
 			ifTrue: [ self notify: '"' , classSymbol , '" should not be redefined as its structure is known to the VM. \Only proceed if you know what you are doing!' withCRs ]
 ]
 
-{ #category : #accessing }
+{ #category : 'accessing' }
 DangerousClassNotifier class >> disable [
 	enabled := false
 ]
 
-{ #category : #accessing }
+{ #category : 'accessing' }
 DangerousClassNotifier class >> disableDuring: aBlock [
 	"execute a block with me disabled. Works even nested and restores the old state"
 	| oldState |
@@ -53,23 +54,23 @@ DangerousClassNotifier class >> disableDuring: aBlock [
 	enabled := oldState
 ]
 
-{ #category : #accessing }
+{ #category : 'accessing' }
 DangerousClassNotifier class >> enable [
 	enabled := true
 ]
 
-{ #category : #accessing }
+{ #category : 'accessing' }
 DangerousClassNotifier class >> enabled [
 	^enabled ifNil: [  enabled := false ]
 ]
 
-{ #category : #'class initialization' }
+{ #category : 'class initialization' }
 DangerousClassNotifier class >> initialize [
 
 	enabled := true
 ]
 
-{ #category : #accessing }
+{ #category : 'accessing' }
 DangerousClassNotifier class >> shouldNotBeRedefined: classSymbol [
 	(self tooDangerousClasses includes: classSymbol) ifTrue: [ ^true ].
 	^Smalltalk globals
@@ -78,7 +79,7 @@ DangerousClassNotifier class >> shouldNotBeRedefined: classSymbol [
 		ifAbsent: false
 ]
 
-{ #category : #accessing }
+{ #category : 'accessing' }
 DangerousClassNotifier class >> tooDangerousClasses [
 	"Return a list of class names which will not be modified in the public interface"
 	^#(

diff --git a/src/Shift-ClassBuilder/ShDefaultBuilderEnhancer.class.st b/src/Shift-ClassBuilder/ShDefaultBuilderEnhancer.class.st
@@ -5,63 +5,64 @@ I am the point of extension to add new features to it in a modular way.
 Also I can configure the builder to add more comparers or do additional things.
 "
 Class {
-	#name : #ShDefaultBuilderEnhancer,
-	#superclass : #Object,
-	#category : #'Shift-ClassBuilder'
+	#name : 'ShDefaultBuilderEnhancer',
+	#superclass : 'Object',
+	#category : 'Shift-ClassBuilder',
+	#package : 'Shift-ClassBuilder'
 }
 
-{ #category : #testing }
+{ #category : 'testing' }
 ShDefaultBuilderEnhancer class >> isApplicableFor: aBuilder [
 	^ false
 ]
 
-{ #category : #'class modifications' }
+{ #category : 'class modifications' }
 ShDefaultBuilderEnhancer >> afterMethodsCompiled: builder [
 ]
 
-{ #category : #migrating }
+{ #category : 'migrating' }
 ShDefaultBuilderEnhancer >> afterMigratingClass: aBuilder installer: anInstaller [
 ]
 
-{ #category : #accessing }
+{ #category : 'accessing' }
 ShDefaultBuilderEnhancer >> allSlotsForBuilder: aBuilder [
 
 	^ aBuilder layoutDefinition allSlots
 ]
 
-{ #category : #migrating }
+{ #category : 'migrating' }
 ShDefaultBuilderEnhancer >> beforeMigratingClass: aBuilder installer: anInstaller [
 ]
 
-{ #category : #events }
+{ #category : 'events' }
 ShDefaultBuilderEnhancer >> classCreated: builder [
 ]
 
-{ #category : #'class modifications' }
+{ #category : 'class modifications' }
 ShDefaultBuilderEnhancer >> compileMethodsFor: aBuilder [
 	aBuilder compileMethods
 ]
 
-{ #category : #'class modifications' }
+{ #category : 'class modifications' }
 ShDefaultBuilderEnhancer >> configureClass: newClass superclass: superclass withLayoutType: layoutType slots: slots [
 	newClass superclass: superclass withLayoutType: layoutType slots: slots
 ]
 
-{ #category : #'class modifications' }
+{ #category : 'class modifications' }
 ShDefaultBuilderEnhancer >> configureMetaclass: newMetaclass superclass: superclass withLayoutType: aLayoutType slots: classSlots [
 	newMetaclass superclass: superclass withLayoutType: aLayoutType slots: classSlots
 ]
 
-{ #category : #initialization }
+{ #category : 'initialization' }
 ShDefaultBuilderEnhancer >> fillBuilder: aBuilder from: aClass [
 ]
 
-{ #category : #migrating }
+{ #category : 'migrating' }
 ShDefaultBuilderEnhancer >> hasToSkipSlot: aSlot [
 	^ Class hasSlotNamed: aSlot name
 ]
 
-{ #category : #initialization }
+{ #category : 'initialization' }
 ShDefaultBuilderEnhancer >> initializeBuilder: aBuilder [
 
 	aBuilder addChangeComparer: ShSharedPoolChangeDetector.
@@ -74,41 +75,41 @@ ShDefaultBuilderEnhancer >> initializeBuilder: aBuilder [
 	aBuilder addChangeComparer: ShMetaclassChangeDetector
 ]
 
-{ #category : #events }
+{ #category : 'events' }
 ShDefaultBuilderEnhancer >> metaclassCreated: builder [
 ]
 
-{ #category : #events }
+{ #category : 'events' }
 ShDefaultBuilderEnhancer >> migrateInstancesTo: aClass installer: aShiftClassInstaller [
 
 	aShiftClassInstaller migrateInstancesTo: aClass
 ]
 
-{ #category : #events }
+{ #category : 'events' }
 ShDefaultBuilderEnhancer >> migrateToClass: aClass installer: aShiftClassInstaller [
 
 	aShiftClassInstaller migrateClassTo: aClass
 ]
 
-{ #category : #'class modifications' }
+{ #category : 'class modifications' }
 ShDefaultBuilderEnhancer >> newMetaclass: builder [
 	^ builder metaclassClass new
 ]
 
-{ #category : #'class modifications' }
+{ #category : 'class modifications' }
 ShDefaultBuilderEnhancer >> on: newClass declareClassVariables: sharedVariables sharing: sharedPoolsString [
 	newClass
 		declareClassVariables: sharedVariables;
 		sharing: sharedPoolsString
 ]
 
-{ #category : #'class modifications' }
+{ #category : 'class modifications' }
 ShDefaultBuilderEnhancer >> propagateChangesToRelatedClasses: newClass installer: installer [
 
 	newClass subclasses do: [ :e | installer remake: e ]
 ]
 
-{ #category : #'class modifications' }
+{ #category : 'class modifications' }
 ShDefaultBuilderEnhancer >> validateRedefinition: anOldClass [
 	"Subclasses can validate that the new definition is coherent with the old class"
 ]