'From Pharo3.0 of 18 March 2013 [Latest update: #30633] on 9 December 2013 at 11:40:00.777754 am'!
Smalltalk renameClassNamed: #PointerLayout as: #FixedLayout!

Smalltalk renameClassNamed: #LayoutWithSlots as: #PointerLayout!

!ClassDescription methodsFor: '*Slot' stamp: 'MartinDias 12/9/2013 11:38'!
layoutSized: size
	|layoutInstance layoutClass|
	layoutClass := FixedLayout.
	
	self isBits
		ifTrue: [
			self isBytes
				ifTrue: [ layoutClass := ByteLayout ].
			self isWords 
				ifTrue: [ layoutClass := WordLayout ]]
		ifFalse: [
			self isVariable ifTrue: [ layoutClass := VariableLayout ].
			self isWeak ifTrue: [ layoutClass := WeakLayout ]].
	
	layoutInstance := layoutClass new: size.
	layoutInstance host: self.
	
	^ layoutInstance! !

!ClassDescription methodsFor: '*Slot' stamp: 'MartinDias 12/9/2013 11:38'!
layoutSized: size
	|layoutInstance layoutClass|
	layoutClass := FixedLayout.
	
	self isBits
		ifTrue: [
			self isBytes
				ifTrue: [ layoutClass := ByteLayout ].
			self isWords 
				ifTrue: [ layoutClass := WordLayout ]]
		ifFalse: [
			self isVariable ifTrue: [ layoutClass := VariableLayout ].
			self isWeak ifTrue: [ layoutClass := WeakLayout ]].
	
	layoutInstance := layoutClass new: size.
	layoutInstance host: self.
	
	^ layoutInstance! !


!OldClassBuilderAdapter methodsFor: 'accessing' stamp: 'MartinDias 12/9/2013 11:38'!
layoutForType: typeSymbol
	typeSymbol = #compiledMethod 
		ifTrue: [ ^ CompiledMethodLayout ].
	typeSymbol = #bytes 
		ifTrue: [ ^ ByteLayout ].
	typeSymbol = #words 
		ifTrue: [ ^ WordLayout ].
	typeSymbol = #weak 
		ifTrue: [ ^ WeakLayout ].
	typeSymbol = #variable 
		ifTrue: [ ^ VariableLayout ].
	typeSymbol = #normal 
		ifTrue: [ ^ FixedLayout ].
	Error signal: 'Invalid layout type: ', typeSymbol asString.! !

!OldClassBuilderAdapter methodsFor: 'accessing' stamp: 'MartinDias 12/9/2013 11:38'!
layoutForType: typeSymbol
	typeSymbol = #compiledMethod 
		ifTrue: [ ^ CompiledMethodLayout ].
	typeSymbol = #bytes 
		ifTrue: [ ^ ByteLayout ].
	typeSymbol = #words 
		ifTrue: [ ^ WordLayout ].
	typeSymbol = #weak 
		ifTrue: [ ^ WeakLayout ].
	typeSymbol = #variable 
		ifTrue: [ ^ VariableLayout ].
	typeSymbol = #normal 
		ifTrue: [ ^ FixedLayout ].
	Error signal: 'Invalid layout type: ', typeSymbol asString.! !


!SlotClassBuilder methodsFor: 'initialization' stamp: 'MartinDias 12/9/2013 11:38'!
initialize
	super initialize.
	oldClasses := OrderedCollection new.
	newClasses := OrderedCollection new.
	sharedPoolsString := ''.
	sharedVariablesString := ''.
	classSlots := {}.
	slots := {}.
	layoutClass := FixedLayout.
	superclass := Object.
	classTraitComposition := {} asTraitComposition.
	traitComposition := {} asTraitComposition.! !

!SlotClassBuilder methodsFor: 'initialize-release' stamp: 'MartinDias 12/9/2013 11:38'!
build
	| oldClass metaChange classChange |
	result := oldClass := client classAt: name ifAbsent: [ ^ self buildNewClass ].

	self validateSuperChain: oldClass.
	
	metaChange := ClassModification
							modify: oldClass class
							extend: self superMetaclass
							withLayoutType: FixedLayout
							slots: classSlots
							traitComposition: classTraitComposition
							compactClassIndex: oldClass class indexIfCompact.
	
	classChange := ClassModification
							modify: oldClass
							extend: superclass
							withLayoutType: layoutClass
							slots: slots
							traitComposition: traitComposition
							compactClassIndex: oldClass indexIfCompact.
	
	self apply: metaChange.
	self apply: classChange.

	result instanceSide 
		declare: sharedVariablesString;
		sharing: sharedPoolsString.

	result isMeta ifFalse: [
		client recategorize: result to: category ].
	
	^ result instanceSide! !

!SlotClassBuilder methodsFor: 'initialize-release' stamp: 'MartinDias 12/9/2013 11:38'!
buildNewClass
	| metaclass newClass |
	metaclass := Metaclass new.
	metaclass
		superclass: self superMetaclass
		withLayoutType: FixedLayout
		slots: classSlots.

	newClass := metaclass new.
	newClass setName: name.
	
	newClass
		superclass: superclass
		withLayoutType: layoutClass
		slots: slots.

	newClass declare: sharedVariablesString.
	newClass sharing: sharedPoolsString.
	
	client installTraitComposition: traitComposition on: newClass.
	client installTraitComposition: classTraitComposition on: metaclass.
	
	client classAdded: newClass inCategory: category.
	
	^ newClass! !

!SlotClassBuilder methodsFor: 'initialization' stamp: 'MartinDias 12/9/2013 11:38'!
initialize
	super initialize.
	oldClasses := OrderedCollection new.
	newClasses := OrderedCollection new.
	sharedPoolsString := ''.
	sharedVariablesString := ''.
	classSlots := {}.
	slots := {}.
	layoutClass := FixedLayout.
	superclass := Object.
	classTraitComposition := {} asTraitComposition.
	traitComposition := {} asTraitComposition.! !

!SlotClassBuilder methodsFor: 'initialize-release' stamp: 'MartinDias 12/9/2013 11:38'!
build
	| oldClass metaChange classChange |
	result := oldClass := client classAt: name ifAbsent: [ ^ self buildNewClass ].

	self validateSuperChain: oldClass.
	
	metaChange := ClassModification
							modify: oldClass class
							extend: self superMetaclass
							withLayoutType: FixedLayout
							slots: classSlots
							traitComposition: classTraitComposition
							compactClassIndex: oldClass class indexIfCompact.
	
	classChange := ClassModification
							modify: oldClass
							extend: superclass
							withLayoutType: layoutClass
							slots: slots
							traitComposition: traitComposition
							compactClassIndex: oldClass indexIfCompact.
	
	self apply: metaChange.
	self apply: classChange.

	result instanceSide 
		declare: sharedVariablesString;
		sharing: sharedPoolsString.

	result isMeta ifFalse: [
		client recategorize: result to: category ].
	
	^ result instanceSide! !

!SlotClassBuilder methodsFor: 'initialize-release' stamp: 'MartinDias 12/9/2013 11:38'!
buildNewClass
	| metaclass newClass |
	metaclass := Metaclass new.
	metaclass
		superclass: self superMetaclass
		withLayoutType: FixedLayout
		slots: classSlots.

	newClass := metaclass new.
	newClass setName: name.
	
	newClass
		superclass: superclass
		withLayoutType: layoutClass
		slots: slots.

	newClass declare: sharedVariablesString.
	newClass sharing: sharedPoolsString.
	
	client installTraitComposition: traitComposition on: newClass.
	client installTraitComposition: classTraitComposition on: metaclass.
	
	client classAdded: newClass inCategory: category.
	
	^ newClass! !


!SmallIntegerLayout methodsFor: 'extending' stamp: 'MartinDias 12/9/2013 11:38'!
extend: newScope
	^ FixedLayout new slotScope: newScope! !

!SmallIntegerLayout methodsFor: 'extending' stamp: 'MartinDias 12/9/2013 11:38'!
extend: newScope
	^ FixedLayout new slotScope: newScope! !


!EmptyLayout methodsFor: 'extending' stamp: 'MartinDias 12/9/2013 11:38'!
extend: someSlots
	^ FixedLayout new
		slotScope: (LayoutEmptyScope instance extend: someSlots)! !

!EmptyLayout methodsFor: 'extending' stamp: 'MartinDias 12/9/2013 11:38'!
extend: someSlots
	^ FixedLayout new
		slotScope: (LayoutEmptyScope instance extend: someSlots)! !


!SlotClassBuilderTest methodsFor: 'helpers-names' stamp: 'MartinDias 12/9/2013 11:38'!
layoutClassesWithSlots
	^ { FixedLayout. VariableLayout. WeakLayout }! !

!SlotClassBuilderTest methodsFor: 'helpers-names' stamp: 'MartinDias 12/9/2013 11:38'!
layoutClasses
	^ { ByteLayout. WordLayout. FixedLayout. VariableLayout. WeakLayout }! !

!SlotClassBuilderTest methodsFor: 'helpers-building' stamp: 'MartinDias 12/9/2013 11:38'!
make: anUnaryBlock
	"I build a class for testing, providing basic default values, but eventually customized by the received unary block."

	^PharoClassInstaller make: [:builder|
		builder
			superclass: Object;
			name: self aClassName;
			layoutClass: FixedLayout;
			category: self aCategory.
		anUnaryBlock value: builder
		].! !

!SlotClassBuilderTest methodsFor: 'helpers-names' stamp: 'MartinDias 12/9/2013 11:38'!
layoutClassesWithSlots
	^ { FixedLayout. VariableLayout. WeakLayout }! !

!SlotClassBuilderTest methodsFor: 'helpers-names' stamp: 'MartinDias 12/9/2013 11:38'!
layoutClasses
	^ { ByteLayout. WordLayout. FixedLayout. VariableLayout. WeakLayout }! !

!SlotClassBuilderTest methodsFor: 'helpers-building' stamp: 'MartinDias 12/9/2013 11:38'!
make: anUnaryBlock
	"I build a class for testing, providing basic default values, but eventually customized by the received unary block."

	^PharoClassInstaller make: [:builder|
		builder
			superclass: Object;
			name: self aClassName;
			layoutClass: FixedLayout;
			category: self aCategory.
		anUnaryBlock value: builder
		].! !


!SlotAnnouncementsTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testClassAddedAnnouncedOnlyOnce
	self assertOnlyOneAnnouncementOf: ClassAdded within: [
		"We create a new class without slots"
		self makeWithLayout: FixedLayout.
	]! !

!SlotAnnouncementsTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testClassAddedAnnounced
	SystemAnnouncer uniqueInstance weak on: ClassAdded send: #saveAnnouncement: to: self.
	
	aClass := self makeWithLayout: FixedLayout.
	
	self assert: announcement classAdded equals: aClass.! !

!SlotAnnouncementsTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testClassModifiedAnnouncedOnlyOnce
	
	self assertOnlyOneAnnouncementOf: ClassModifiedClassDefinition within: [
		
		"We create a new class without slots"
		self makeWithLayout: FixedLayout.
		
		"now we extend it with slots.  The class definition should've changed"
		self makeWithLayout: FixedLayout andSlots: { #aSlot }.
	]! !

!SlotAnnouncementsTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testClassModifiedAnnounced
	| classAdded classModified |
	SystemAnnouncer uniqueInstance weak on: ClassModifiedClassDefinition send: #saveAnnouncementOnce: to: self.
	
	"We create a new class without slots"
	classAdded := self makeWithLayout: FixedLayout.
	
	"now we extend it with slots.  The class definition should've changed"
	classModified := self makeWithLayout: FixedLayout andSlots: { #aSlot }.
	
	self assert: announcement newClassDefinition equals: classModified.
	self assert: announcement oldClassDefinition allInstVarNames equals: classAdded allInstVarNames.! !

!SlotAnnouncementsTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testClassFormatChangedAnnounced
	| classAdded classModified |
	SystemAnnouncer uniqueInstance weak on: ClassModifiedClassDefinition send: #saveAnnouncementOnce: to: self.
	
	"We create a new class without slots"
	classAdded := self makeWithLayout: FixedLayout.
	
	"now we extend it with slots.  The class definition should've changed"
	classModified := self makeWithLayout: WeakLayout.
	
	self assert: announcement newClassDefinition equals: classModified.
	self assert: announcement oldClassDefinition format equals: classAdded format.
	self assert: announcement newClassDefinition format equals: classModified format.! !

!SlotAnnouncementsTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testClassAddedAnnouncedOnlyOnce
	self assertOnlyOneAnnouncementOf: ClassAdded within: [
		"We create a new class without slots"
		self makeWithLayout: FixedLayout.
	]! !

!SlotAnnouncementsTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testClassAddedAnnounced
	SystemAnnouncer uniqueInstance weak on: ClassAdded send: #saveAnnouncement: to: self.
	
	aClass := self makeWithLayout: FixedLayout.
	
	self assert: announcement classAdded equals: aClass.! !

!SlotAnnouncementsTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testClassModifiedAnnouncedOnlyOnce
	
	self assertOnlyOneAnnouncementOf: ClassModifiedClassDefinition within: [
		
		"We create a new class without slots"
		self makeWithLayout: FixedLayout.
		
		"now we extend it with slots.  The class definition should've changed"
		self makeWithLayout: FixedLayout andSlots: { #aSlot }.
	]! !

!SlotAnnouncementsTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testClassModifiedAnnounced
	| classAdded classModified |
	SystemAnnouncer uniqueInstance weak on: ClassModifiedClassDefinition send: #saveAnnouncementOnce: to: self.
	
	"We create a new class without slots"
	classAdded := self makeWithLayout: FixedLayout.
	
	"now we extend it with slots.  The class definition should've changed"
	classModified := self makeWithLayout: FixedLayout andSlots: { #aSlot }.
	
	self assert: announcement newClassDefinition equals: classModified.
	self assert: announcement oldClassDefinition allInstVarNames equals: classAdded allInstVarNames.! !

!SlotAnnouncementsTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testClassFormatChangedAnnounced
	| classAdded classModified |
	SystemAnnouncer uniqueInstance weak on: ClassModifiedClassDefinition send: #saveAnnouncementOnce: to: self.
	
	"We create a new class without slots"
	classAdded := self makeWithLayout: FixedLayout.
	
	"now we extend it with slots.  The class definition should've changed"
	classModified := self makeWithLayout: WeakLayout.
	
	self assert: announcement newClassDefinition equals: classModified.
	self assert: announcement oldClassDefinition format equals: classAdded format.
	self assert: announcement newClassDefinition format equals: classModified format.! !


!SlotBasicTest methodsFor: 'tests-basic' stamp: 'MartinDias 12/9/2013 11:38'!
testNewPointerClassWithSlots

	aClass := self 
		makeWithLayout: FixedLayout
		andSlots: { #id. #name }.
	
	self assert: (aClass instVarNames includes: 'id').
	self assert: (aClass instVarNames includes: 'name').! !

!SlotBasicTest methodsFor: 'tests-basic' stamp: 'MartinDias 12/9/2013 11:38'!
testNewPointerClass

	aClass := self makeWithLayout: FixedLayout.
	
	self deny: aClass isCompact.
	self assert: aClass isPointers.
	self assert: aClass isFixed.
	self assert: aClass instVarNames isEmpty.! !

!SlotBasicTest methodsFor: 'tests-basic' stamp: 'MartinDias 12/9/2013 11:38'!
testNewPointerClassWithSlots

	aClass := self 
		makeWithLayout: FixedLayout
		andSlots: { #id. #name }.
	
	self assert: (aClass instVarNames includes: 'id').
	self assert: (aClass instVarNames includes: 'name').! !

!SlotBasicTest methodsFor: 'tests-basic' stamp: 'MartinDias 12/9/2013 11:38'!
testNewPointerClass

	aClass := self makeWithLayout: FixedLayout.
	
	self deny: aClass isCompact.
	self assert: aClass isPointers.
	self assert: aClass isFixed.
	self assert: aClass instVarNames isEmpty.! !


!SlotIntegrationTest methodsFor: 'tests-compact index' stamp: 'MartinDias 12/9/2013 11:38'!
testBecomeCompactAndUncompact

	| originalCompactClassesArray |
	aClass := self makeWithLayout: FixedLayout.	
	self assert: aClass indexIfCompact equals: 0.
	originalCompactClassesArray := Smalltalk compactClassesArray copy.

	[ 
		
	"The class becomes compact, so we are not in the original state."	
	aClass becomeCompact.
	self assert: aClass indexIfCompact > 0.
	self deny: Smalltalk compactClassesArray = originalCompactClassesArray. 
	
	] ensure: [ 

	"The class becomes uncompact, so we are back in the original state."
	aClass becomeUncompact.
	self assert: aClass indexIfCompact equals: 0. 
	self assert: Smalltalk compactClassesArray equals: originalCompactClassesArray. 
	
	].

! !

!SlotIntegrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testCopyPreservesLayout

	aClass := self makeWithLayout: FixedLayout.
	anotherClass := aClass copy.
	
	self deny: anotherClass layout isNil.
	self assert: aClass layout host == aClass.
	self assert: anotherClass layout host == anotherClass.! !

!SlotIntegrationTest methodsFor: 'tests-compact index' stamp: 'MartinDias 12/9/2013 11:38'!
testBecomeCompactAndUncompact

	| originalCompactClassesArray |
	aClass := self makeWithLayout: FixedLayout.	
	self assert: aClass indexIfCompact equals: 0.
	originalCompactClassesArray := Smalltalk compactClassesArray copy.

	[ 
		
	"The class becomes compact, so we are not in the original state."	
	aClass becomeCompact.
	self assert: aClass indexIfCompact > 0.
	self deny: Smalltalk compactClassesArray = originalCompactClassesArray. 
	
	] ensure: [ 

	"The class becomes uncompact, so we are back in the original state."
	aClass becomeUncompact.
	self assert: aClass indexIfCompact equals: 0. 
	self assert: Smalltalk compactClassesArray equals: originalCompactClassesArray. 
	
	].

! !

!SlotIntegrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testCopyPreservesLayout

	aClass := self makeWithLayout: FixedLayout.
	anotherClass := aClass copy.
	
	self deny: anotherClass layout isNil.
	self assert: aClass layout host == aClass.
	self assert: anotherClass layout host == anotherClass.! !


!SlotLayoutExtensionTest methodsFor: 'tests-valid extensions' stamp: 'MartinDias 12/9/2013 11:38'!
testVariableCanExtendPointer

	self should: [ :builder | 
			builder layoutClass: FixedLayout ]
		extendWith: [ :builder | 
			builder layoutClass: VariableLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests-valid extensions' stamp: 'MartinDias 12/9/2013 11:38'!
testPointerCanExtendVariable

	self should: [ :builder | 
			builder layoutClass: VariableLayout ]
		extendWith: [ :builder | 
			builder layoutClass: FixedLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests-valid extensions' stamp: 'MartinDias 12/9/2013 11:38'!
testPointerCanExtendPointer

	self should: [ :builder | 
			builder layoutClass: FixedLayout ]
		extendWith: [ :builder | 
			builder layoutClass: FixedLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests-invalid extensions' stamp: 'MartinDias 12/9/2013 11:38'!
testByteCannotExtendPointerWithFields

	self shouldnt: [ :builder | 
			builder 
				layoutClass: FixedLayout;
				slots: { #a }. ]
		extendWith: [ :builder | 
			builder layoutClass: ByteLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests-invalid extensions' stamp: 'MartinDias 12/9/2013 11:38'!
testPointerCannotExtendByte

	self shouldnt: [ :builder | 
			builder layoutClass: ByteLayout ]
		extendWith: [ :builder | 
			builder layoutClass: FixedLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests-invalid extensions' stamp: 'MartinDias 12/9/2013 11:38'!
testPointerCannotExtendWord

	self shouldnt: [ :builder | 
			builder layoutClass: WordLayout ]
		extendWith: [ :builder | 
			builder layoutClass: FixedLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests-invalid extensions' stamp: 'MartinDias 12/9/2013 11:38'!
testWordCannotExtendPointerWithFields

	self shouldnt: [ :builder | 
			builder 
				layoutClass: FixedLayout;
				slots: { #a } ]
		extendWith: [ :builder | 
			builder layoutClass: WordLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests-valid extensions' stamp: 'MartinDias 12/9/2013 11:38'!
testVariableCanExtendPointer

	self should: [ :builder | 
			builder layoutClass: FixedLayout ]
		extendWith: [ :builder | 
			builder layoutClass: VariableLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests-valid extensions' stamp: 'MartinDias 12/9/2013 11:38'!
testPointerCanExtendVariable

	self should: [ :builder | 
			builder layoutClass: VariableLayout ]
		extendWith: [ :builder | 
			builder layoutClass: FixedLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests-valid extensions' stamp: 'MartinDias 12/9/2013 11:38'!
testPointerCanExtendPointer

	self should: [ :builder | 
			builder layoutClass: FixedLayout ]
		extendWith: [ :builder | 
			builder layoutClass: FixedLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests-invalid extensions' stamp: 'MartinDias 12/9/2013 11:38'!
testByteCannotExtendPointerWithFields

	self shouldnt: [ :builder | 
			builder 
				layoutClass: FixedLayout;
				slots: { #a }. ]
		extendWith: [ :builder | 
			builder layoutClass: ByteLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests-invalid extensions' stamp: 'MartinDias 12/9/2013 11:38'!
testPointerCannotExtendByte

	self shouldnt: [ :builder | 
			builder layoutClass: ByteLayout ]
		extendWith: [ :builder | 
			builder layoutClass: FixedLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests-invalid extensions' stamp: 'MartinDias 12/9/2013 11:38'!
testPointerCannotExtendWord

	self shouldnt: [ :builder | 
			builder layoutClass: WordLayout ]
		extendWith: [ :builder | 
			builder layoutClass: FixedLayout ]! !

!SlotLayoutExtensionTest methodsFor: 'tests-invalid extensions' stamp: 'MartinDias 12/9/2013 11:38'!
testWordCannotExtendPointerWithFields

	self shouldnt: [ :builder | 
			builder 
				layoutClass: FixedLayout;
				slots: { #a } ]
		extendWith: [ :builder | 
			builder layoutClass: WordLayout ]! !


!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testChangeLayoutTypeToByte
	aClass := self 
		makeWithLayout: FixedLayout
		andSlots: { #id. #name }.
	"Change the layout of the class from pointer to bytes"
	aClass := self makeWithLayout: ByteLayout.
	
	aClass layout checkIntegrity.
	
	self assert: aClass layout isBits.
	self assert: aClass instVarNames isEmpty.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testChangeLayoutTypeFromByte

	aClass := self makeWithLayout: ByteLayout.
	"Change the layout of the class from bytes to pointer"
	aClass := self 
		makeWithLayout: FixedLayout 
		andSlots: { #id. #name }.
	
	aClass layout checkIntegrity.
	
	self deny: aClass layout isBits.
	self assert: aClass instVarNames equals: { #id. #name }.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testAddSlotPropagateAndMigrate
	"We create a class without slots and a subclass, and create an instance of the latter; then we add a slot to superclass and check the instance can hold a value."

	| superclass subclass |
	superclass := self makeWithLayout: FixedLayout.
	subclass := self make: [ :builder |
		builder 
			superclass: superclass;
			name: self anotherClassName.
		 ].
	
	superclass layout checkIntegrity.
	subclass layout checkIntegrity.
	
	instance := subclass new.
	
	"now we extend it with slots.  The class definition should've changed"
	superclass := self makeWithLayout: FixedLayout andSlots: { #aSlot }.
	
	"it should have an instance variable"
	instance instVarNamed: 'aSlot' put: 42.
	self assert: (instance instVarNamed: 'aSlot') equals: 42.
	superclass layout checkIntegrity.
	subclass layout checkIntegrity.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testSwitchSlotsAndMigrate

	aClass := self makeWithLayout: FixedLayout andSlots: { #a. #b }.
	aClass 
		compile: 'a ^a';
		compile: 'b ^b'.

	instance := aClass new.
	instance instVarNamed: #a put: $A.
	instance instVarNamed: #b put: $B.

	"now we switch the slots. The class definition should've changed"
	self makeWithLayout: FixedLayout andSlots: { #b. #a }.

	self assert: (instance instVarAt: 1) equals: $B.
	self assert: (instance instVarAt: 2) equals: $A.
	
	self assert: (instance instVarNamed: #a) equals: $A.
	self assert: (instance instVarNamed: #b) equals: $B.

	"it should have migrated methods"
	self assert: instance a equals: $A.
	self assert: instance b equals: $B.
	aClass layout checkIntegrity.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testReshapeByteVariableToPointerPropagatesToDeepHierarchy

	"create the original hierarchy"
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			superclass: Object;
			layoutClass: ByteLayout ]. 

	anotherClass := self make: [ :builder |
		builder 
			name:self anotherClassName;
			superclass: aClass;
			layoutClass: ByteLayout ].

	yetAnotherClass := self make: [ :builder |
		builder 
			name:self yetAnotherClassName;
			superclass: anotherClass;
			layoutClass: ByteLayout ].

	yetYetAnotherClass := self make: [ :builder |
		builder 
			name:self yetYetAnotherClassName;
			superclass: yetAnotherClass;
			layoutClass: ByteLayout ].

	"all the classes in the hierarchy should be of type variable byte"
	{ aClass. anotherClass. yetAnotherClass. yetYetAnotherClass } do: [ :each | 
		each layout checkIntegrity.
		self assert: each isVariable.
		self assert: each isBytes. ].
	
	"change the top superclass"	
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			superclass: Object;
			layoutClass: FixedLayout;
			slots: { #x } ]. 

	"all the classes in the hierarchy should be reshaped as fixed"
	{ aClass. anotherClass. yetAnotherClass. yetYetAnotherClass } do: [ :each | 
		each layout checkIntegrity.
		self assert: each isFixed description: each name, ' was not reshaped.'.
		self assert: each isPointers description: each name, ' was not reshaped.' ].! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testAddSlotAndMigrate
	"We create a class without slots and create an instance; then we add a slot and check the instance can hold a value."
	aClass := self makeWithLayout: FixedLayout.
	
	instance := aClass new.
	
	"now we extend it with slots.  The class definition should've changed"
	self makeWithLayout: FixedLayout andSlots: { #aSlot }.
	
	"it should have an instance variable"
	instance instVarAt: 1 put: 125.
	aClass layout checkIntegrity.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testRedefineSuperclass
	"This case reproduces a MNU found loading Moose."

	| superclass class |
	superclass := self makeWithLayout: FixedLayout.
	class := self make: [ :builder |
		builder 
			superclass: superclass;
			layoutClass: ByteLayout;
			name: self anotherClassName.
		 ].

	self makeWithLayout: FixedLayout.

	superclass layout checkIntegrity.
	class layout checkIntegrity.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testSuperclassChangeLayoutType
	"This case reproduces a MNU found loading Moose."

	| superclass class |
	superclass := self makeWithLayout: ByteLayout.
	class := self make: [ :builder |
		builder 
			superclass: superclass;
			layoutClass: ByteLayout;
			name: self anotherClassName.
		 ].
	"Change the layout of the superclass from bytes to pointer"
	self makeWithLayout: FixedLayout.

	superclass layout checkIntegrity.
	class layout checkIntegrity.
	
	self deny: superclass layout isBits.
	self assert: class layout isBits.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testShiftSlotAndMigrate

	aClass := self makeWithLayout: FixedLayout andSlots: { #a. #c }.
	aClass compile: 'a ^a'.
	aClass compile: 'c ^c'.
	
	instance := aClass new.
	instance instVarNamed: #a put: 1.
	instance instVarNamed: #c put: 3.

	"now we extend it with slots.  The class definition should've changed"
	self makeWithLayout: FixedLayout andSlots: { #a. #b. #c }.

	"it should have added an instance variable with nil in the middle"
	self assert: (instance instVarAt: 1) equals: 1.
	self assert: (instance instVarAt: 2) equals: nil.
	self assert: (instance instVarAt: 3) equals: 3.
	
	self assert: (instance instVarNamed: #a) equals: 1.
	self assert: (instance instVarNamed: #b) equals: nil.
	self assert: (instance instVarNamed: #c) equals: 3.
	
	"it should have migrated methods"
	self assert: instance a equals: 1.
	self assert: instance c equals: 3.
	aClass layout checkIntegrity.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testReshapePointerToByteVariablePropagatesToDeepHierarchy

	"create the original hierarchy"
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			superclass: Object;
			layoutClass: FixedLayout ]. 

	anotherClass := self make: [ :builder |
		builder 
			name:self anotherClassName;
			superclass: aClass;
			layoutClass: FixedLayout ].

	yetAnotherClass := self make: [ :builder |
		builder 
			name:self yetAnotherClassName;
			superclass: anotherClass;
			layoutClass: FixedLayout ].

	yetYetAnotherClass := self make: [ :builder |
		builder 
			name:self yetYetAnotherClassName;
			superclass: yetAnotherClass;
			layoutClass: FixedLayout ].

	"all the classes in the hierarchy should be of type fixed pointers"
	{ aClass. anotherClass. yetAnotherClass. yetYetAnotherClass } do: [ :each | 
		each layout checkIntegrity.
		self assert: each isFixed.
		self assert: each isPointers. ].
	
	"change the top superclass"	
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			superclass: Object;
			layoutClass: ByteLayout ]. 

	"all the classes in the hierarchy should be reshaped as fixed"
	{ aClass. anotherClass. yetAnotherClass. yetYetAnotherClass } do: [ :each | 
		each layout checkIntegrity.
		self assert: each isVariable description: each name, ' was not reshaped.'.
		self assert: each isBytes description: each name, ' was not reshaped.' ].! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testRemoveSlotAndMigrate
	"We create a class with a slot and create an instance; then we remove the slot and check the instance doesn't hold the value."
	aClass := self makeWithLayout: FixedLayout andSlots: { #aSlot }.

	instance := aClass new.
	"it should have an instance variable"
	instance instVarAt: 1 put: 125.
	
	"now we extend it with slots.  The class definition should've changed"
	self makeWithLayout: FixedLayout.
	
	self should: [ instance instVarAt: 1 ] raise: Error.
	aClass layout checkIntegrity.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testChangingFormatKeepsMethod

	aClass := self make: [ :builder | 
		builder 
			name: self aClassName;
			layoutClass: FixedLayout ].

	aClass compile: 'a ^self'.
	self assert: (aClass methodDictionary includesKey: #a).
	
	anotherClass := self make: [ :builder | 
		builder 
			name: self aClassName;
			layoutClass: VariableLayout .
			].

	self assert: (anotherClass methodDictionary includesKey: #a).
	aClass layout checkIntegrity.
	anotherClass layout checkIntegrity.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testChangeLayoutTypeToByte
	aClass := self 
		makeWithLayout: FixedLayout
		andSlots: { #id. #name }.
	"Change the layout of the class from pointer to bytes"
	aClass := self makeWithLayout: ByteLayout.
	
	aClass layout checkIntegrity.
	
	self assert: aClass layout isBits.
	self assert: aClass instVarNames isEmpty.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testChangeLayoutTypeFromByte

	aClass := self makeWithLayout: ByteLayout.
	"Change the layout of the class from bytes to pointer"
	aClass := self 
		makeWithLayout: FixedLayout 
		andSlots: { #id. #name }.
	
	aClass layout checkIntegrity.
	
	self deny: aClass layout isBits.
	self assert: aClass instVarNames equals: { #id. #name }.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testAddSlotPropagateAndMigrate
	"We create a class without slots and a subclass, and create an instance of the latter; then we add a slot to superclass and check the instance can hold a value."

	| superclass subclass |
	superclass := self makeWithLayout: FixedLayout.
	subclass := self make: [ :builder |
		builder 
			superclass: superclass;
			name: self anotherClassName.
		 ].
	
	superclass layout checkIntegrity.
	subclass layout checkIntegrity.
	
	instance := subclass new.
	
	"now we extend it with slots.  The class definition should've changed"
	superclass := self makeWithLayout: FixedLayout andSlots: { #aSlot }.
	
	"it should have an instance variable"
	instance instVarNamed: 'aSlot' put: 42.
	self assert: (instance instVarNamed: 'aSlot') equals: 42.
	superclass layout checkIntegrity.
	subclass layout checkIntegrity.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testSwitchSlotsAndMigrate

	aClass := self makeWithLayout: FixedLayout andSlots: { #a. #b }.
	aClass 
		compile: 'a ^a';
		compile: 'b ^b'.

	instance := aClass new.
	instance instVarNamed: #a put: $A.
	instance instVarNamed: #b put: $B.

	"now we switch the slots. The class definition should've changed"
	self makeWithLayout: FixedLayout andSlots: { #b. #a }.

	self assert: (instance instVarAt: 1) equals: $B.
	self assert: (instance instVarAt: 2) equals: $A.
	
	self assert: (instance instVarNamed: #a) equals: $A.
	self assert: (instance instVarNamed: #b) equals: $B.

	"it should have migrated methods"
	self assert: instance a equals: $A.
	self assert: instance b equals: $B.
	aClass layout checkIntegrity.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testReshapeByteVariableToPointerPropagatesToDeepHierarchy

	"create the original hierarchy"
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			superclass: Object;
			layoutClass: ByteLayout ]. 

	anotherClass := self make: [ :builder |
		builder 
			name:self anotherClassName;
			superclass: aClass;
			layoutClass: ByteLayout ].

	yetAnotherClass := self make: [ :builder |
		builder 
			name:self yetAnotherClassName;
			superclass: anotherClass;
			layoutClass: ByteLayout ].

	yetYetAnotherClass := self make: [ :builder |
		builder 
			name:self yetYetAnotherClassName;
			superclass: yetAnotherClass;
			layoutClass: ByteLayout ].

	"all the classes in the hierarchy should be of type variable byte"
	{ aClass. anotherClass. yetAnotherClass. yetYetAnotherClass } do: [ :each | 
		each layout checkIntegrity.
		self assert: each isVariable.
		self assert: each isBytes. ].
	
	"change the top superclass"	
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			superclass: Object;
			layoutClass: FixedLayout;
			slots: { #x } ]. 

	"all the classes in the hierarchy should be reshaped as fixed"
	{ aClass. anotherClass. yetAnotherClass. yetYetAnotherClass } do: [ :each | 
		each layout checkIntegrity.
		self assert: each isFixed description: each name, ' was not reshaped.'.
		self assert: each isPointers description: each name, ' was not reshaped.' ].! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testAddSlotAndMigrate
	"We create a class without slots and create an instance; then we add a slot and check the instance can hold a value."
	aClass := self makeWithLayout: FixedLayout.
	
	instance := aClass new.
	
	"now we extend it with slots.  The class definition should've changed"
	self makeWithLayout: FixedLayout andSlots: { #aSlot }.
	
	"it should have an instance variable"
	instance instVarAt: 1 put: 125.
	aClass layout checkIntegrity.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testRedefineSuperclass
	"This case reproduces a MNU found loading Moose."

	| superclass class |
	superclass := self makeWithLayout: FixedLayout.
	class := self make: [ :builder |
		builder 
			superclass: superclass;
			layoutClass: ByteLayout;
			name: self anotherClassName.
		 ].

	self makeWithLayout: FixedLayout.

	superclass layout checkIntegrity.
	class layout checkIntegrity.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testSuperclassChangeLayoutType
	"This case reproduces a MNU found loading Moose."

	| superclass class |
	superclass := self makeWithLayout: ByteLayout.
	class := self make: [ :builder |
		builder 
			superclass: superclass;
			layoutClass: ByteLayout;
			name: self anotherClassName.
		 ].
	"Change the layout of the superclass from bytes to pointer"
	self makeWithLayout: FixedLayout.

	superclass layout checkIntegrity.
	class layout checkIntegrity.
	
	self deny: superclass layout isBits.
	self assert: class layout isBits.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testShiftSlotAndMigrate

	aClass := self makeWithLayout: FixedLayout andSlots: { #a. #c }.
	aClass compile: 'a ^a'.
	aClass compile: 'c ^c'.
	
	instance := aClass new.
	instance instVarNamed: #a put: 1.
	instance instVarNamed: #c put: 3.

	"now we extend it with slots.  The class definition should've changed"
	self makeWithLayout: FixedLayout andSlots: { #a. #b. #c }.

	"it should have added an instance variable with nil in the middle"
	self assert: (instance instVarAt: 1) equals: 1.
	self assert: (instance instVarAt: 2) equals: nil.
	self assert: (instance instVarAt: 3) equals: 3.
	
	self assert: (instance instVarNamed: #a) equals: 1.
	self assert: (instance instVarNamed: #b) equals: nil.
	self assert: (instance instVarNamed: #c) equals: 3.
	
	"it should have migrated methods"
	self assert: instance a equals: 1.
	self assert: instance c equals: 3.
	aClass layout checkIntegrity.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testReshapePointerToByteVariablePropagatesToDeepHierarchy

	"create the original hierarchy"
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			superclass: Object;
			layoutClass: FixedLayout ]. 

	anotherClass := self make: [ :builder |
		builder 
			name:self anotherClassName;
			superclass: aClass;
			layoutClass: FixedLayout ].

	yetAnotherClass := self make: [ :builder |
		builder 
			name:self yetAnotherClassName;
			superclass: anotherClass;
			layoutClass: FixedLayout ].

	yetYetAnotherClass := self make: [ :builder |
		builder 
			name:self yetYetAnotherClassName;
			superclass: yetAnotherClass;
			layoutClass: FixedLayout ].

	"all the classes in the hierarchy should be of type fixed pointers"
	{ aClass. anotherClass. yetAnotherClass. yetYetAnotherClass } do: [ :each | 
		each layout checkIntegrity.
		self assert: each isFixed.
		self assert: each isPointers. ].
	
	"change the top superclass"	
	aClass := self make: [ :builder |
		builder 
			name: self aClassName;
			superclass: Object;
			layoutClass: ByteLayout ]. 

	"all the classes in the hierarchy should be reshaped as fixed"
	{ aClass. anotherClass. yetAnotherClass. yetYetAnotherClass } do: [ :each | 
		each layout checkIntegrity.
		self assert: each isVariable description: each name, ' was not reshaped.'.
		self assert: each isBytes description: each name, ' was not reshaped.' ].! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testRemoveSlotAndMigrate
	"We create a class with a slot and create an instance; then we remove the slot and check the instance doesn't hold the value."
	aClass := self makeWithLayout: FixedLayout andSlots: { #aSlot }.

	instance := aClass new.
	"it should have an instance variable"
	instance instVarAt: 1 put: 125.
	
	"now we extend it with slots.  The class definition should've changed"
	self makeWithLayout: FixedLayout.
	
	self should: [ instance instVarAt: 1 ] raise: Error.
	aClass layout checkIntegrity.! !

!SlotMigrationTest methodsFor: 'tests' stamp: 'MartinDias 12/9/2013 11:38'!
testChangingFormatKeepsMethod

	aClass := self make: [ :builder | 
		builder 
			name: self aClassName;
			layoutClass: FixedLayout ].

	aClass compile: 'a ^self'.
	self assert: (aClass methodDictionary includesKey: #a).
	
	anotherClass := self make: [ :builder | 
		builder 
			name: self aClassName;
			layoutClass: VariableLayout .
			].

	self assert: (anotherClass methodDictionary includesKey: #a).
	aClass layout checkIntegrity.
	anotherClass layout checkIntegrity.! !