[PATCH] Rewrite object mutation

This patch rewrites object mutation, simplifying it greatly (and fixing
bugs) by telling the mutation methods about what the new superclass will
be.  This is a really really old part of GNU Smalltalk, even predating
my maintainership; apparently it was mostly untested (it was part of the
Blox GUI in 1.1.5) and it is being exercised more because of the new
syntax and because of less common features being used---in this case,
class instance variables.

Anyway, when I modified it to fix mutate.st's XFAIL I broke it in new
interesting ways.  The changes to mutate.st are regression tests for
class mutation, so you can see what the bugs were about.

Paolo

2007-11-20  Paolo Bonzini  <[hidden email]>

        * kernel/Behavior.st: Partially undo change from
        #updateInstanceVars:shape: to
        #updateInstanceVars:numInherited:shape:.
        Add back #updateInstanceVars:shape: and add new
        #updateInstanceVars:superclass:shape:.  Return true from
        #inheritsFrom: if passed nil.  Use new keyword argument to
        include superclass variables in instVarMap.  Reverse direction of
        instVarMap.  Simplify creation of subclasses' instance variable
        array. Add here #mutate:via: (taken from kernel/Object.st)
        and use it instead of #mutate:startingAt:newClass:.
        * kernel/Object.st: Remove #mutate:startingAt:newClass:.
        * kernel/Metaclass.st: Rename "superclass" argument to
        "theSuperclass" or "newSuperclass".  Call
        #updateInstanceVars:superclass:shape:.

        * tests/mutate.st: Add minimal testcase for GTK+ loading failure.
        Test that class-instance variables are copied around correctly.
        Test that moving up the hierarchy preserves instance variables.


--- orig/kernel/Behavior.st
+++ mod/kernel/Behavior.st
@@ -54,10 +54,7 @@ method dictionary, and iterating over th
     ifTrue: [{symbol}]
     ifFalse: [instanceVariables copyWith: symbol].
  duplicated := self superclass allInstVarNames includes: symbol.
- self
-    updateInstanceVars: newInstanceVariables
-    numInherited: self superclass instSize
-    shape: self shape.
+ self updateInstanceVars: newInstanceVariables shape: self shape.
  duplicated ifTrue: [self compileAll].
  self compileAllSubclasses
     ]
@@ -77,10 +74,7 @@ method dictionary, and iterating over th
     to: index
     with: #().
  self
-    updateInstanceVars: newInstanceVariables
-    numInherited: self superclass instSize
-    shape: self shape.
- self
+    updateInstanceVars: newInstanceVariables shape: self shape;
     compileAll;
     compileAllSubclasses
     ]
@@ -98,10 +92,7 @@ method dictionary, and iterating over th
         "If instance variables change, update  instance variables and
          instance spec of the class and all its subclasses"
         variableArray = oldInstVarNames ifTrue: [^self].
-        self
-    updateInstanceVars: variableArray
-    numInherited: self superclass instSize
-    shape: self shape.
+        self updateInstanceVars: variableArray shape: self shape.
 
         "If no variable has been removed, no need to recompile"
         (oldInstVarNames allSatisfy: [:each | variableArray includes: each])
@@ -976,8 +967,9 @@ method dictionary, and iterating over th
 
  <category: 'testing the class hierarchy'>
  | sc |
+ aClass isNil ifTrue: [^true].
+
  sc := self.
-
  [sc := sc superclass.
  sc isNil] whileFalse: [sc == aClass ifTrue: [^true]].
  ^false
@@ -1015,10 +1007,7 @@ method dictionary, and iterating over th
  shape = #inherit ifTrue: [realShape := self superclass shape].
  self shape == realShape ifTrue: [^false].
  realShape isNil ifTrue: [
-            self
-        updateInstanceVars: self allInstVarNames
-        numInherited: self superclass instSize
-        shape: nil ].
+            self updateInstanceVars: self allInstVarNames shape: nil ].
  self isVariable
     ifTrue:
  [SystemExceptions.MutationError
@@ -1340,24 +1329,44 @@ method dictionary, and iterating over th
  ^true
     ]
 
-    updateInstanceVars: variableArray numInherited: numInherited shape: shape [
+    updateInstanceVars: variableArray shape: shape [
  "Update instance variables and instance spec of the class and all
- its subclasses"
+ its subclasses.  variableArray lists the new variables, including
+ inherited ones."
+ ^self
+    updateInstanceVars: variableArray
+    superclass: self superclass
+    shape: shape
+    ]
+
+    updateInstanceVars: variableArray superclass: newSuper shape: shape [
+ "Update instance variables and instance spec of the class and all
+ its subclasses.  variableArray lists the new variables, including
+ those inherited from newSuper."
 
  <category: 'private'>
- | instVarMap startOfInstanceVars endOfInstanceVars newInstanceVars oldInstVars oldClass instances |
- startOfInstanceVars := numInherited + 1.
- endOfInstanceVars := self instSize.
- newInstanceVars := variableArray copyFrom: startOfInstanceVars
-    to: variableArray size.
+ | instVarMap newInstVars oldInstVars oldClass instances oldSuper |
+
+ "Find a common superclass."
+ oldSuper := self superclass.
+ newSuper == oldSuper ifFalse: [
+    [ newSuper includesBehavior: oldSuper ] whileFalse: [
+        oldSuper := oldSuper superclass ] ].
+
+ "Make map for inherited instance variables."
  oldInstVars := self allInstVarNames.
- instVarMap := Array new: newInstanceVars size.
- startOfInstanceVars to: endOfInstanceVars
-    do:
- [:i |
- | map |
- map := newInstanceVars findLast: [:each | each = (oldInstVars at: i)].
- map > 0 ifTrue: [instVarMap at: map put: i]].
+ instVarMap := Array new: oldInstVars size.
+ 1 to: oldSuper instSize do: [ :i |
+    instVarMap at: i put: i ].
+
+ "Make map for this class's instance variables."
+ newInstVars := variableArray copyFrom: newSuper instSize + 1.
+ oldInstVars
+    from: oldSuper instSize + 1 to: oldInstVars size
+    keysAndValuesDo: [ :index :var |
+        | map |
+        map := newInstVars findLast: [:each | each = var].
+        map > 0 ifTrue: [instVarMap at: index put: map + newSuper instSize]].
 
  "Fix up all subclasses."
  self allSubclassesDo:
@@ -1367,21 +1376,16 @@ method dictionary, and iterating over th
  oldClass superclass: sc.
  instances := sc allInstances.
  instances do: [:each | each changeClassTo: oldClass].
- iv := sc allInstVarNames
-    copyReplaceFrom: startOfInstanceVars
-    to: endOfInstanceVars
-    with: newInstanceVars.
+ iv := variableArray, (sc allInstVarNames
+    copyFrom: oldInstVars size + 1
+    to: sc allInstVarNames size).
  sc setInstanceVariables: iv.
  sc setInstanceSpec: sc shape instVars: sc allInstVarNames size.
 
  "Mutate all instances of the class to conform to new memory model
  of the class."
- instances do:
- [:each |
- each
-    mutate: instVarMap
-    startAt: startOfInstanceVars
-    newClass: sc]].
+ instances do: [:each |
+    sc mutate: each via: instVarMap]].
 
  "Now update this class' instance vars"
  oldClass := Behavior new.
@@ -1390,12 +1394,36 @@ method dictionary, and iterating over th
  instances do: [:each | each changeClassTo: oldClass].
  self setInstanceVariables: variableArray.
  self setInstanceSpec: shape instVars: variableArray size.
- instances do:
- [:each |
- each
-    mutate: instVarMap
-    startAt: startOfInstanceVars
-    newClass: self]
+ instances do: [:each |
+    self mutate: each via: instVarMap]
+    ]
+
+    mutate: object via: instVarMap [
+        "Private - Mutate object to a new class representation. instVarMap
+         maps from old instVarAt: indices to new instVarAt:put: indices.
+         start is the first instance variable to change."
+
+        <category: 'private'>
+        | aCopy mappedValue end adjustment |
+        aCopy := object class isVariable
+                    ifTrue: [self basicNew: object basicSize]
+                    ifFalse: [self basicNew].
+
+        "Copy old instance variables to their new positions using instVarMap."
+        1 to: instVarMap size do: [:i |
+            mappedValue := instVarMap at: i.
+            mappedValue notNil
+                ifTrue: [aCopy instVarAt: mappedValue put: (object instVarAt: i)]].
+
+        "If mutating a subclass, instVarMap is smaller than `object class instSize';
+         in this case, everything after it must be copied."
+        adjustment := self instSize - object class instSize.
+        instVarMap size + 1 to: object class instSize
+            do: [:i | aCopy instVarAt: i + adjustment put: (object instVarAt: i)].
+
+        "Copy the indexed variables, if any."
+        1 to: object basicSize do: [:i | aCopy basicAt: i put: (object basicAt: i)].
+        ^object become: aCopy
     ]
 
     isBehavior [


--- orig/kernel/Metaclass.st
+++ mod/kernel/Metaclass.st
@@ -161,15 +161,15 @@ it should be...the Smalltalk metaclass s
  ^self instanceClass pragmaHandlerFor: aSymbol
     ]
 
-    name: className environment: aNamespace subclassOf: superclass [
+    name: className environment: aNamespace subclassOf: theSuperclass [
  "Private - create a full featured class and install it, or change the
  superclass or shape of an existing one; instance variable names,
  class variable names and pool dictionaries are left untouched."
 
  <category: 'basic'>
  | aClass variableArray |
- variableArray := superclass notNil
-    ifTrue: [superclass allInstVarNames]
+ variableArray := theSuperclass notNil
+    ifTrue: [theSuperclass allInstVarNames]
     ifFalse: [#()].
 
  "Look for an existing metaclass"
@@ -179,7 +179,7 @@ it should be...the Smalltalk metaclass s
  [^self
     newMeta: className
     environment: aNamespace
-    subclassOf: superclass
+    subclassOf: theSuperclass
     instanceVariableArray: variableArray
     shape: nil
     classPool: BindingDictionary new
@@ -189,7 +189,7 @@ it should be...the Smalltalk metaclass s
  ^self
     name: className
     environment: aNamespace
-    subclassOf: superclass
+    subclassOf: theSuperclass
     instanceVariableArray: variableArray
     shape: aClass shape
     classPool: aClass classPool
@@ -197,7 +197,7 @@ it should be...the Smalltalk metaclass s
     category: aClass category
     ]
 
-    name: newName environment: aNamespace subclassOf: superclass instanceVariableNames: stringOfInstVarNames shape: shape classVariableNames: stringOfClassVarNames poolDictionaries: stringOfPoolNames category: categoryName [
+    name: newName environment: aNamespace subclassOf: theSuperclass instanceVariableNames: stringOfInstVarNames shape: shape classVariableNames: stringOfClassVarNames poolDictionaries: stringOfPoolNames category: categoryName [
  "Private - parse the instance and class variables, and the pool
  dictionaries, then create the class."
 
@@ -206,8 +206,8 @@ it should be...the Smalltalk metaclass s
 
  | variableArray classVarDict sharedPoolNames |
  variableArray := self parseInstanceVariableString: stringOfInstVarNames.
- variableArray := superclass notNil
-    ifTrue: [superclass allInstVarNames , variableArray]
+ variableArray := theSuperclass notNil
+    ifTrue: [theSuperclass allInstVarNames , variableArray]
     ifFalse: [variableArray].
  classVarDict := self parse: stringOfClassVarNames
     toDictionary: BindingDictionary new.
@@ -215,7 +215,7 @@ it should be...the Smalltalk metaclass s
  ^self
     name: newName asSymbol
     environment: aNamespace
-    subclassOf: superclass
+    subclassOf: theSuperclass
     instanceVariableArray: variableArray
     shape: shape
     classPool: classVarDict
@@ -223,7 +223,7 @@ it should be...the Smalltalk metaclass s
     category: categoryName
     ]
 
-    name: className environment: aNamespace subclassOf: superclass instanceVariableArray: variableArray shape: shape classPool: classVarDict poolDictionaries: sharedPoolNames category: categoryName [
+    name: className environment: aNamespace subclassOf: newSuperclass instanceVariableArray: variableArray shape: shape classPool: classVarDict poolDictionaries: sharedPoolNames category: categoryName [
  "Private - create a full featured class and install it, or change an
  existing one"
 
@@ -240,7 +240,7 @@ it should be...the Smalltalk metaclass s
  [^self
     newMeta: className
     environment: aNamespace
-    subclassOf: superclass
+    subclassOf: newSuperclass
     instanceVariableArray: variableArray
     shape: realShape
     classPool: classVarDict
@@ -252,7 +252,7 @@ it should be...the Smalltalk metaclass s
     ifFalse:
  [SystemExceptions.MutationError
     signal: 'Cannot change shape of variable class']].
- superclass isUntrusted & self class isUntrusted not
+ newSuperclass isUntrusted & self class isUntrusted not
     ifTrue:
  [SystemExceptions.MutationError
     signal: 'Cannot move trusted class below untrusted superclass'].
@@ -278,7 +278,7 @@ it should be...the Smalltalk metaclass s
  [aClass instanceCount > 0 ifTrue: [ObjectMemory globalGarbageCollect].
  aClass
     updateInstanceVars: variableArray
-    numInherited: superclass instSize
+    superclass: newSuperclass
     shape: realShape].
 
  "Now add/remove pool dictionaries.  FIXME: They may affect name binding,
@@ -296,29 +296,29 @@ it should be...the Smalltalk metaclass s
     ifFalse:
  [aClass removeSharedPool: dict.
  needToRecompileMetaclasses := true]]].
- aClass superclass ~~ superclass
+ aClass superclass ~~ newSuperclass
     ifTrue:
  ["Mutate the class if the set of class-instance variables changes."
 
- self superclass allInstVarNames ~= superclass class allInstVarNames
+ self superclass allInstVarNames ~= newSuperclass class allInstVarNames
     ifTrue:
  [aClass class
     updateInstanceVars:
- superclass class allInstVarNames,
+ newSuperclass class allInstVarNames,
  aClass class instVarNames
-    numInherited: superclass class instSize
+    superclass: newSuperclass class
     shape: aClass class shape].
 
  "Fix references between classes..."
  aClass superclass removeSubclass: aClass.
- superclass addSubclass: aClass.
- aClass superclass: superclass.
+ newSuperclass addSubclass: aClass.
+ aClass superclass: newSuperclass.
  needToRecompileClasses := true.
 
  "...and between metaclasses..."
  self superclass removeSubclass: self.
- superclass class addSubclass: self.
- self superclass: superclass class.
+ newSuperclass class addSubclass: self.
+ self superclass: newSuperclass class.
  needToRecompileMetaclasses := true].
  aClass category: categoryName.
 
@@ -340,7 +340,7 @@ it should be...the Smalltalk metaclass s
  ^aClass
     ]
 
-    newMeta: className environment: aNamespace subclassOf: superclass instanceVariableArray: arrayOfInstVarNames shape: shape classPool: classVarDict poolDictionaries: sharedPoolNames category: categoryName [
+    newMeta: className environment: aNamespace subclassOf: theSuperclass instanceVariableArray: arrayOfInstVarNames shape: shape classPool: classVarDict poolDictionaries: sharedPoolNames category: categoryName [
  "Private - create a full featured class and install it"
 
  <category: 'basic'>
@@ -349,17 +349,17 @@ it should be...the Smalltalk metaclass s
  classVarDict environment: aClass.
  instanceClass := aClass.
  aNamespace at: className put: aClass.
- superclass isNil ifFalse: [superclass addSubclass: aClass].
+ theSuperclass isNil ifFalse: [theSuperclass addSubclass: aClass].
  Behavior flushCache.
  ^aClass
-    superclass: superclass;
+    superclass: theSuperclass;
     setName: className;
     setEnvironment: aNamespace;
     setInstanceVariables: arrayOfInstVarNames;
     setInstanceSpec: shape instVars: arrayOfInstVarNames size;
     setClassVariables: classVarDict;
     setSharedPools: sharedPoolNames;
-    makeUntrusted: superclass isUntrusted;
+    makeUntrusted: theSuperclass isUntrusted;
     category: categoryName;
     yourself
     ]
@@ -417,10 +417,10 @@ it should be...the Smalltalk metaclass s
  aStream nextPutAll: ' class'
     ]
 
-    initMetaclass: superclass [
+    initMetaclass: theSuperclass [
  <category: 'private'>
- instanceVariables := superclass allInstVarNames.
- instanceSpec := superclass instanceSpec
+ instanceVariables := theSuperclass allInstVarNames.
+ instanceSpec := theSuperclass instanceSpec
     ]
 
     parsePools: aString in: aNamespace [


--- orig/kernel/Object.st
+++ mod/kernel/Object.st
@@ -744,37 +744,6 @@ All classes in the system are subclasses
  ^name
     ]
 
-    mutate: instVarMap startAt: start newClass: class [
- "Private - Mutate object to a new class representation. instVarMap
- maps between old instVarAt: indices and new instVarAt:put: indices.
- start is the first instance variable to change."
-
- <category: 'private'>
- | aCopy mappedValue end adjustment |
- adjustment := self class instSize - class instSize.
- aCopy := self class isVariable
-    ifTrue: [class basicNew: self basicSize]
-    ifFalse: [class basicNew].
- end := instVarMap size + start - 1.
-
- "Copy the instance variables, if any"
- 1 to: start - 1 do: [:i | aCopy instVarAt: i put: (self instVarAt: i)].
-
- "Copy old instance variables to their new positions using instVarMap"
- start to: end
-    do:
- [:i |
- mappedValue := instVarMap at: i - start + 1.
- mappedValue notNil
-    ifTrue: [aCopy instVarAt: i put: (self instVarAt: mappedValue)]].
- end + 1 to: class instSize
-    do: [:i | aCopy instVarAt: i put: (self instVarAt: i + adjustment)].
-
- "Copy the indexed variables, if any."
- 1 to: self basicSize do: [:i | aCopy basicAt: i put: (self basicAt: i)].
- ^self become: aCopy
-    ]
-
     allOwners [
  "Return an Array of Objects that point to the receiver."
 


--- orig/tests/mutate.ok
+++ mod/tests/mutate.ok
@@ -99,6 +99,11 @@ returned value is true
 Recompiling classes...
 
 Execution begins...
+Smalltalk
+returned value is SystemDictionary new: 512 "<0>"
+Recompiling classes...
+
+Execution begins...
 (#a #b #c )
 returned value is Array new: 3 "<0>"
 
@@ -109,3 +114,7 @@ returned value is Array new: 4 "<0>"
 Execution begins...
 (#a #d )
 returned value is Array new: 2 "<0>"
+
+Execution begins...
+Recompiling classes...
+returned value is 'abc'


--- orig/tests/mutate.st
+++ mod/tests/mutate.st
@@ -124,6 +124,13 @@ Eval [ (C shape -> C classPool keys asAr
 Eval [ C class compile: 'foo [ ^MutationError ]' ]
 Eval [ C foo == SystemExceptions.MutationError ]
 
+"Test mutating the class when the new superclass has additional class-instance
+ variables"
+CObject subclass: CFoo [ ]
+CStruct subclass: CFoo [ ]
+Eval [ CFoo environment printNl ]
+
+"Test adding variables with multiple |...| blocks or with extend."
 Object subclass: Foo [ | a | ]
 Foo subclass: Bar [ | xyz | ]
 Foo subclass: Bar [ | b | | c | ]
@@ -131,3 +138,20 @@ Eval [ Bar allInstVarNames printNl ]
 Foo extend [ | d | ]
 Eval [ Bar allInstVarNames printNl ]
 Eval [ Foo allInstVarNames printNl ]
+
+"Test moving to an upper superclass, but preserving instance variables
+ because they are specified in the instanceVariableNames: keyword."
+Association subclass: Blah [ ]
+Eval [
+    | blah |
+    blah := Blah new.
+    blah value: 'abc'.
+    Object
+ subclass: #Blah
+ instanceVariableNames: 'key value'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: ''.
+
+    blah instVarAt: 2
+]





_______________________________________________
help-smalltalk mailing list
[hidden email]
http://lists.gnu.org/mailman/listinfo/help-smalltalk