Commits

Ryan Macnak committed 0d5a35e

Add access modifiers: testing that MemoryHole preserves them.

Comments (0)

Files changed (1)

AtomicInstaller4.ns3

-Newspeak3
+Newspeak3
+'Mirrors'
+class AtomicInstaller4 usingPlatform: p = NewspeakObject (
+"
+BOGUS: Rename doesn't propagate down.
 
-'Mirrors'
+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.
 
-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 vmmirror = (p Smalltalk at: #VMMirror) new.
 
-('private'
+private updateMap <IdentityMap[OldObject,NewObject]>
+private existingClasses <IdentityMap[HierarchyDepth,Set[Class]]>
+|)
+('private'
+private cleanup = (
+	updateMap: nil.
+	existingClasses: nil
+)
+private installAll = (
 
-cleanup = (
+	| 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.
+	].
 
-installAll = (
+	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].
 
-setup = (
+#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> = (
 
-'private-classes'
+	| 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"
 
-depthFor: klassArg <Class> = (
+	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."	
 
-layoutHasChangedBetween: oldClass and: newClass = (
+	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> |
 
-newClassFor: oldClass <Class> ^<Class> = (
+		| 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.
 
-processExistingClass: oldClass <Class> = (
-
-
-
-processExistingClasses = (
-
-
-
-sortClass: app <Class> = (
-
-
-
-'private-instances'
-
-processInstancesOf: oldClass <Class> withNewClass: newClass <Class> = (
-
-
-
-'private-mixins'
-
-constructorNameFrom: cmm = (
-
-
-
-methodDictionaryFor: mixin <Mixin> from: m <LowLevelMixinMirror> ^ <MethodDictionary> = (
-
-
-
-noteUpdateOf: existingMixin <Mixin|nil> to: newMixin <Mixin> = (
-
-
-
-processRep: rep <MixinRep> in: existingMixinMap <IdentityMap[MixinRep,Mixin]> = (
-
-
-
-setOrganizationFor: mixin <Mixin|ClassMixin>
-
-
-
-'public access'
-
-install: reps <List[MixinRep]> withExistingMixins: existingMixinMap <Map[MixinRep,Mixin]> = (
-
-
-
-)
+	^results "<List[Mixin]>"
+))