Source

newspeak / AtomicInstaller4.ns3

The default branch has multiple heads

Full commit
Newspeak3
'Mirrors'
class AtomicInstaller4 usingPlatform: p = NewspeakObject (
"
BOGUS: Rename doesn't propagate down.

AA -> BB
but 
AA`Nested stays AA`Nested should be BB`Nested

"|
private IdentityMap = p IdentityDictionary.
private IdentitySet = p IdentitySet.
private Mixin = p kernel Mixin.
private ClassMixin = p kernel ClassMixin.
private MethodDictionary = p MethodDictionary.
private ClassOrganizer = p ClassOrganizer.

private vmmirror = (p Smalltalk at: #VMMirror) new.

private updateMap <IdentityMap[OldObject,NewObject]>
private existingClasses <IdentityMap[HierarchyDepth,Set[Class]]>
|)
('private'
private cleanup = (
	updateMap: nil.
	existingClasses: nil
)
private installAll = (

	| oldObjects newObjects i |	
	oldObjects:: Array new: updateMap size.
	newObjects:: Array new: updateMap size.
	i: 1.

	updateMap keysAndValuesDo: [:oldObj :newObj |
		oldObjects at: i put: oldObj.
		newObjects at: i put: newObj.
		i: i + 1.
	].

	oldObjects elementsForwardIdentityToEvenIfImmutable: newObjects. "one way become"
)
private setup = (
	updateMap: IdentityMap new.
	existingClasses: IdentityMap new.
)'private-classes'
private depthFor: klassArg <Class> = (
	| klass d |
	d: 0.
	klass: klassArg.
	[klass isNil] whileFalse: [klass: klass superclass. d: d+1].
	^d
)
private layoutHasChangedBetween: oldClass and: newClass = (
	^oldClass instVarNames ~= newClass instVarNames
)
private newClassFor: oldClass <Class> ^<Class> = (
	
	| newSuperclass newMixin newClass |

	newSuperclass:: updateMap at: oldClass superclass ifAbsent: [oldClass superclass].
	newMixin:: updateMap at: oldClass mixin ifAbsent: [oldClass mixin].

#BOGUS yourself. "Name not quite right.  Should reflect new name, but should keep the same form as the old name if it's like This`9087#450 "
	newClass:: newMixin apply: newSuperclass withName: newMixin simpleName.
	newClass enclosingObjectSlot: oldClass enclosingObjectSlot.
	newClass class enclosingObjectSlot: oldClass class enclosingObjectSlot.
	"organization and category: they live in the mixin"

	^newClass
)
private processExistingClass: oldClass <Class> = (
	| newClass <Class> |
	newClass:: newClassFor: oldClass.
	
	updateMap at: oldClass put: newClass.
	updateMap at: oldClass class put: newClass class.
		
	(layoutHasChangedBetween: oldClass and: newClass) 
		ifTrue:[processInstancesOf: oldClass withNewClass: newClass]
)
private processExistingClasses = (
	"Process superclasses before subclasses"
	existingClasses keys asSortedCollection do:[: k <Integer> |
		(existingClasses at: k) do:[:c <Class> | processExistingClass: c]
	].
)
private sortClass: app <Class> = (
	| classes depth |
	depth:: depthFor: app.
	classes:: existingClasses at: depth ifAbsentPut: [IdentitySet new].
	classes add: app.
	app subclassesDo: [:sc | sortClass: sc].
)'private-instances'
private processInstancesOf: oldClass <Class> withNewClass: newClass <Class> = (

	| oldInstVarNames newInstVarNames sharedInstVarNames |
	
	oldInstVarNames:: oldClass allInstVarNames.
	newInstVarNames:: newClass allInstVarNames.
	
	sharedInstVarNames:: oldInstVarNames select:[:n <String> | newInstVarNames includes: n ].
	"find intersection of slots names between oldObj and newObj"

	oldClass allInstancesDo:[:oldObj | | newObj |
		
		newObj:: newClass basicNew.
		
		"copy state from oldObj to newObj"
		
		sharedInstVarNames do: [:n <String> | 
			| oldIndex newIndex val |
			oldIndex:: oldInstVarNames indexOf: n.
			newIndex:: newInstVarNames indexOf: n.
			val:: vmmirror namedSlotOf: oldObj at: oldIndex ifFail: [self halt].
			vmmirror namedSlotOf: newObj at: newIndex put: val ifFail: [self halt].
		]. 

		updateMap at: oldObj put: newObj.
	].
)'private-mixins'
private constructorNameFrom: cmm = (
	^(cmm lowLevelMirror classMixin methods mirrors
		detect: [:mirror | mirror isConstructor] ifNone: [self halt.^nil "shouldn't happen but does"]) simpleName.
)
private methodDictionaryFor: mixin <Mixin> from: m <LowLevelMixinMirror> ^ <MethodDictionary> = (
	| md <MethodDictionary> methods <List[LowLevelMethodMirror]> |
	methods:: m methods collect:[:mtd <LowLevelMethodMirror> | mtd].
	md:: MethodDictionary new: methods size.
	methods do:[:cm <LowLevelMethodMirror> | 
		#BOGUS yourself. "This will cause calls back to the mixin to save the source, which are currently ignored."
		cm klass: mixin.  
		md at: cm selector put: cm compiledMethod
		].
	^md
)
private noteUpdateOf: existingMixin <Mixin|nil> to: newMixin <Mixin> = (
	
	existingMixin isNil ifTrue: [^self].
	
	updateMap at: existingMixin put: newMixin.
	updateMap at: existingMixin classMixin put: newMixin classMixin.
	
	existingMixin applications do: [:app | sortClass: app].
)
private processRep: rep <MixinRep> in: existingMixinMap <IdentityMap[MixinRep,Mixin]> = (
	
	|
	mixin <Mixin>
	classMixin <ClassMixin>
	cmm <CompiledMethodMirror>
	llmm <LowLevelMixinMirror>
	|
	rep isArray ifFalse: [self halt. ^rep]. "If a builder includes a Mixin instead of a MixinRep, it means don't delete and don't mutate."	

	mixin:: Mixin new.
	classMixin:: ClassMixin new.
	
	cmm:: rep first.
	mixin cachedHeaderSource: cmm header.
	mixin cachedConstructorName: (constructorNameFrom: cmm).
	mixin category: cmm category.
	llmm:: cmm lowLevelMirror.
	
	mixin name: llmm name.
	mixin classMixin: classMixin.
	mixin methodDictionary: (methodDictionaryFor: mixin from: llmm).
	mixin slots: (llmm instVars collect:[:ivm <InstanceVariableMirror> | {ivm name. true"mutable"}]).
	
	classMixin instanceMixin: mixin.
	classMixin methodDictionary: (methodDictionaryFor: classMixin from: llmm classMixin).

	setOrganizationFor: mixin basedOn: llmm.
	setOrganizationFor: classMixin basedOn: llmm classMixin.
	
	noteUpdateOf: (existingMixinMap at: rep ifAbsent: nil) to: mixin.
	
	rep last do: [:nestedRep <MixinRep> |

		| nestedMixin <Mixin> |
		nestedRep isArray not ifTrue: [
			self halt.
			nestedMixin:: nestedRep.
			mixin nestedMixins at: nestedMixin name put: nestedMixin.
			"Do not set enclosing mixin here for an existing Mixin: that would be non-atomic!"
		] ifFalse: [
			nestedMixin:: processRep: nestedRep in: existingMixinMap.
			mixin nestedMixins at: nestedMixin name put: nestedMixin.
			nestedMixin enclosingMixin: mixin.
			nestedMixin classMixin enclosingMixin: mixin. "? double check this"
		].
	].
	
	^mixin
)
private setOrganizationFor: mixin <Mixin|ClassMixin>
basedOn: lm <LowLevelMixinMirror> = (
	| nonSyntheticMethods <LowLevelMethodMirror> |
	nonSyntheticMethods:: (lm methods select: [ :mt | mt isSynthetic not]).
	
	"manually set organization, excluding synthetic methods"
	mixin organization: (ClassOrganizer defaultList: (nonSyntheticMethods collect: [:ea | ea selector])).

	"classify (non-synthetic) elements if mirror includes category information"
	(nonSyntheticMethods 
		select: [ :um | um metadata includesKey: #category ])
		do: [ :cm | mixin organization
						classify: cm selector
						under: (cm metadata at: #category) ].
)'public access'
public install: reps <List[MixinRep]> withExistingMixins: existingMixinMap <Map[MixinRep,Mixin]> = (
	
	| results |
	setup.
	results:: reps collect: [:rep | processRep: rep in: existingMixinMap].
	processExistingClasses.
	installAll.
	Object flushCache. "Clear all lookup caches"
	cleanup.

	^results "<List[Mixin]>"
))