[PATCH 2/n] C TwistedPools with some issues

This implements TP in the VM, but there are some issues with class
variable initializers.  I'm not sure it's ready for merging with this
bug, but maybe it is (it is not a regression anyway).

Opinions?

Paolo

diff --git a/kernel/AbstNamespc.st b/kernel/AbstNamespc.st
index fbba3b5..12dacfd 100644
--- a/kernel/AbstNamespc.st
+++ b/kernel/AbstNamespc.st
@@ -61,25 +61,6 @@ an instance of me; it is called their `environment''. '>
     yourself)
     ]
 
-    = arg [
- "Answer whether the receiver is equal to arg. The equality test is
- by default the same as that for equal objects. = must not fail;
- answer false if the receiver cannot be compared to arg"
-
- <category: 'basic & copying'>
- <primitive: VMpr_Object_identity>
-
-    ]
-
-    hash [
- "Answer an hash value for the receiver.  This is the same as the
- object's #identityHash."
-
- <category: 'basic & copying'>
- <primitive: VMpr_Object_hash>
-
-    ]
-
     whileCurrentDo: aBlock [
  "Evaluate aBlock with the current namespace set to the receiver.
  Answer the result of the evaluation."
@@ -194,48 +175,6 @@ an instance of me; it is called their `environment''. '>
  ^class
     ]
 
-    definedKeys [
- "Answer a kind of Set containing the keys of the receiver"
-
- <category: 'overrides for superspaces'>
- | aSet value |
- aSet := self keysClass new: tally * 4 // 3.
- 1 to: self primSize
-    do:
- [:index |
- value := self primAt: index.
- value isNil ifFalse: [aSet add: value key]].
- ^aSet
-    ]
-
-    definesKey: key [
- "Answer whether the receiver defines the given key. `Defines'
- means that the receiver's superspaces, if any, are not considered."
-
- <category: 'overrides for superspaces'>
- ^super includesKey: key
-    ]
-
-    hereAt: key ifAbsent: aBlock [
- "Return the value associated to the variable named as specified
- by `key' *in this namespace*. If the key is not found search will
- *not* be carried on in superspaces and aBlock will be immediately
- evaluated."
-
- <category: 'overrides for superspaces'>
- ^super at: key ifAbsent: aBlock
-    ]
-
-    hereAt: key [
- "Return the value associated to the variable named as specified
- by `key' *in this namespace*. If the key is not found search will
- *not* be carried on in superspaces and the method will fail."
-
- <category: 'overrides for superspaces'>
- ^self hereAt: key
-    ifAbsent: [SystemExceptions.NotFound signalOn: key what: 'key']
-    ]
-
     inheritedKeys [
  "Answer a Set of all the keys in the receiver and its superspaces"
 
@@ -319,16 +258,6 @@ an instance of me; it is called their `environment''. '>
  ^aSet
     ]
 
-    allSuperspaces [
- "Answer all the receiver's superspaces in a collection"
-
- <category: 'namespace hierarchy'>
- | supers |
- supers := OrderedCollection new.
- self allSuperspacesDo: [:superspace | supers addLast: superspace].
- ^supers
-    ]
-
     allSuperspacesDo: aBlock [
  "Evaluate aBlock once for each of the receiver's superspaces"
 
@@ -365,20 +294,6 @@ an instance of me; it is called their `environment''. '>
  ^false
     ]
 
-    inheritsFrom: aNamespace [
- "Answer whether aNamespace is one of the receiver's direct and
- indirect superspaces"
-
- <category: 'namespace hierarchy'>
- | space |
- space := self.
-
- [space := space superspace.
- space == aNamespace ifTrue: [^true].
- space notNil]
- whileTrue
-    ]
-
     removeSubspace: aSymbol [
  "Remove my subspace named aSymbol from the hierarchy."
 
@@ -510,29 +425,6 @@ an instance of me; it is called their `environment''. '>
  subspace allSubspacesDo: aBlock]
     ]
 
-    withAllSuperspaces [
- "Answer the receiver and all of its superspaces in a collection"
-
- <category: 'namespace hierarchy'>
- | supers |
- supers := OrderedCollection with: self.
- self allSuperspacesDo: [:superspace | supers addLast: superspace].
- ^supers
-    ]
-
-    withAllSuperspacesDo: aBlock [
- "Invokes aBlock for the receiver and all superspaces, both direct
- and indirect."
-
- <category: 'namespace hierarchy'>
- | space |
- space := self.
-
- [aBlock value: space.
- space := space superspace.
- space notNil] whileTrue
-    ]
-
     nameIn: aNamespace [
  "Answer Smalltalk code compiling to the receiver when the current
  namespace is aNamespace"
diff --git a/kernel/Behavior.st b/kernel/Behavior.st
index cab6cd7..0e703e0 100644
--- a/kernel/Behavior.st
+++ b/kernel/Behavior.st
@@ -730,17 +730,34 @@ method dictionary, and iterating over the class hierarchy.'>
  ^self superclass isNil ifTrue: [#()] ifFalse: [self superclass sharedPools]
     ]
 
+    allSharedPoolDictionariesDo: aBlock [
+        "Answer the shared pools visible from methods in the metaclass,
+         in the correct search order."
+
+        self superclass allSharedPoolDictionariesDo: aBlock
+    ]
+
+    allSharedPoolDictionaries [
+ "Return the shared pools defined by the class and any of
+ its superclasses, in the correct search order."
+
+ <category: 'accessing instances and variables'>
+ | result |
+ result := OrderedCollection new.
+ self allSharedPoolDictionariesDo: [:each | result add: each].
+ ^result
+    ]
+
     allSharedPools [
  "Return the names of the shared pools defined by the class and any of
- its superclasses"
+ its superclasses, in the correct search order."
 
  <category: 'accessing instances and variables'>
  | result |
- result := self sharedPools asSet.
- self environment
-    withAllSuperspacesDo: [:each | result add: each name asSymbol].
- self allSuperclassesDo: [:each | result addAll: each sharedPools].
- ^result asArray
+ result := OrderedCollection new.
+ self allSharedPoolDictionariesDo: [:each |
+ result add: (each nameIn: self environment)].
+ ^result
     ]
 
     subclasses [
diff --git a/kernel/BindingDict.st b/kernel/BindingDict.st
index ab03bbe..b5093ee 100644
--- a/kernel/BindingDict.st
+++ b/kernel/BindingDict.st
@@ -44,6 +44,24 @@ My keys are (expected to be) symbols, so I use == to match searched keys
 to those in the dictionary -- this is done expecting that it brings a bit
 more speed.'>
 
+    = arg [
+        "Answer whether the receiver is equal to arg. The equality test is
+         by default the same as that for equal objects. = must not fail;
+         answer false if the receiver cannot be compared to arg"
+
+        <category: 'basic & copying'>
+        <primitive: VMpr_Object_identity>
+    ]
+
+    hash [
+        "Answer an hash value for the receiver.  This is the same as the
+         object's #identityHash."
+
+        <category: 'basic & copying'>
+        <primitive: VMpr_Object_hash>
+
+    ]
+
     copy [
  <category: 'copying'>
  ^self
@@ -273,4 +291,3 @@ more speed.'>
  ^IdentityDictionary
     ]
 ]
-
diff --git a/kernel/Class.st b/kernel/Class.st
index 785f973..f78ee7e 100644
--- a/kernel/Class.st
+++ b/kernel/Class.st
@@ -616,6 +616,66 @@ the class category.'>
  ^sharedPools ifNil: [#()]
     ]
 
+    allSharedPoolDictionariesDo: aBlock [
+        "Answer the shared pools visible from methods in the metaclass,
+         in the correct search order."
+
+        | superclassSpaces |
+ "Collect those spaces that have to be skipped in the search."
+        superclassSpaces := Bag new.
+        self withAllSuperclassesDo: [:behavior |
+            behavior environment withAllSuperspacesDo: [ :each |
+                superclassSpaces add: each ]].
+
+        self withAllSuperclassesDo: [:behavior || classSpaces |
+    aBlock value: behavior classPool.
+
+    "Extract the spaces of this class from superclassSpaces into
+     classSpaces..."
+            classSpaces := IdentitySet new.
+    behavior environment withAllSuperspacesDo: [ :each |
+ classSpaces add: each.
+ superclassSpaces remove: each ].
+
+    "... and visit them."
+            self
+                allLocalSharedPoolDictionariesExcept: classSpaces
+                do: aBlock.
+
+    "Now proceed with the `natural' (non-imported spaces)."
+            behavior environment withAllSuperspacesDo: [:each |
+                (superclassSpaces includes: each)
+    ifFalse: [ aBlock value: each ]]]
+    ]
+
+    allLocalSharedPoolDictionariesExcept: white do: aBlock [
+        "Answer the result of combining the list of pools imported
+ into the receiver using a topological sort, preferring dependent
+ to prerequisite, and then left to right.  Any pool that is
+ already in white will not be answered.  white is modified."
+        <category: 'private'>
+        | grey order descend list |
+ list := self sharedPoolDictionaries.
+ list isEmpty ifTrue: [ ^self ].
+
+        grey := IdentitySet new: list size.
+        order := OrderedCollection new: list size.
+        descend := [:pool |
+            (white includes: pool) ifFalse:
+                [(grey includes: pool) ifTrue:
+                     [^SystemExceptions.InvalidValue
+                          signalOn: list
+                          reason: 'includes circular dependency'].
+
+                "#allSuperspaces is not available on all pools"
+                grey add: pool.
+                pool allSuperspaces reverseDo: descend.
+                order addFirst: pool.
+                white add: pool]].
+        list reverseDo: descend.
+        order do: aBlock
+    ]
+
     metaclassFor: classNameString [
  "Create a Metaclass object for the given class name. The metaclass
  is a subclass of the receiver's metaclass"
diff --git a/kernel/DeferBinding.st b/kernel/DeferBinding.st
index c4f03c0..160aa52 100644
--- a/kernel/DeferBinding.st
+++ b/kernel/DeferBinding.st
@@ -132,15 +132,10 @@ in the scope of a given class are used.'>
  assoc isNil ifFalse: [^assoc].
 
  "Look for the binding in the class environment."
- class withAllSuperclassesDo:
+ class allSharedPoolDictionariesDo:
  [:env |
- | pools |
- assoc := env environment associationAt: self key ifAbsent: [nil].
- assoc isNil ifFalse: [^assoc].
- pools := env sharedPoolDictionaries.
- pools do: [:each |
-    assoc := each associationAt: self key ifAbsent: [nil].
-    assoc isNil ifFalse: [^assoc]]].
+ assoc := env hereAssociationAt: self key ifAbsent: [nil].
+ assoc isNil ifFalse: [^assoc]].
 
  "Create it as a temporary."
  defaultDictionary at: self key ifAbsentPut: [nil].
diff --git a/kernel/Dictionary.st b/kernel/Dictionary.st
index 70fc5c7..6c91085 100644
--- a/kernel/Dictionary.st
+++ b/kernel/Dictionary.st
@@ -586,11 +586,129 @@ certain special cases.'>
  ^self findIndex: key
     ]
 
+    allSuperspaces [
+        "Answer all the receiver's superspaces in a collection"
+
+        <category: 'namespace protocol'>
+        | supers |
+        supers := OrderedCollection new.
+        self allSuperspacesDo: [:superspace | supers addLast: superspace].
+        ^supers
+    ]
+
+    allSuperspacesDo: aBlock [
+        "Evaluate aBlock once for each of the receiver's superspaces (which
+ is none for BindingDictionary)."
+
+        <category: 'namespace protocol'>
+    ]
+
+    definedKeys [
+        "Answer a kind of Set containing the keys of the receiver"
+
+        <category: 'namespace protocol'>
+        | aSet value |
+        aSet := self keysClass new: tally * 4 // 3.
+        1 to: self primSize
+            do:
+                [:index |
+                value := self primAt: index.
+                value isNil ifFalse: [aSet add: value key]].
+        ^aSet
+    ]
+
+    inheritsFrom: aNamespace [
+        "Answer whether aNamespace is one of the receiver's direct and
+         indirect superspaces"
+
+        <category: 'namespace protocol'>
+        | space |
+        space := self.
+
+        [space := space superspace.
+        space == aNamespace ifTrue: [^true].
+        space notNil]
+                whileTrue
+    ]
+
+    superspace [
+        "Answer the receiver's superspace, which is nil for BindingDictionary."
+
+        <category: 'namespace protocol'>
+        ^nil
+    ]
+
     withAllSuperspaces [
- "This method is needed by the compiler"
+        "Answer the receiver and all of its superspaces in a collection,
+ which is none for BindingDictionary"
 
- <category: 'polymorphism hacks'>
- ^{self}
+        <category: 'namespace protocol'>
+        | supers |
+        supers := OrderedCollection with: self.
+        self allSuperspacesDo: [:superspace | supers addLast: superspace].
+        ^supers
+    ]
+
+    withAllSuperspacesDo: aBlock [
+        "Invokes aBlock for the receiver and all superspaces, both direct
+         and indirect (though a BindingDictionary does not have any)."
+
+        <category: 'namespace protocol'>
+        aBlock value: self.
+        self allSuperspacesDo: aBlock
+    ]
+
+    definesKey: key [
+        "Answer whether the receiver defines the given key. `Defines'
+         means that the receiver's superspaces, if any, are not considered."
+
+        <category: 'namespace protocol'>
+ ^super includes: key
+    ]
+
+    hereAssociationAt: key ifAbsent: aBlock [
+        "Return the association for the variable named as specified
+         by `key' *in this namespace*. If the key is not found search will
+         *not* be carried on in superspaces and aBlock will be immediately
+         evaluated."
+
+        <category: 'namespace protocol'>
+ | index |
+ index := self findIndexOrNil: key.
+ ^index isNil ifTrue: [aBlock value] ifFalse: [self primAt: index]
+    ]
+
+    hereAssociationAt: key [
+        "Return the association for the variable named as specified
+         by `key' *in this namespace*. If the key is not found search will
+         *not* be carried on in superspaces and the method will fail."
+
+        <category: 'namespace protocol'>
+        ^self hereAssociationAt: key
+            ifAbsent: [SystemExceptions.NotFound signalOn: key what: 'key']
+    ]
+
+    hereAt: key ifAbsent: aBlock [
+        "Return the value associated to the variable named as specified
+         by `key' *in this namespace*. If the key is not found search will
+         *not* be carried on in superspaces and aBlock will be immediately
+         evaluated."
+
+        <category: 'namespace protocol'>
+ | index |
+ index := self findIndexOrNil: key.
+ ^index isNil ifTrue: [aBlock value] ifFalse: [(self primAt: index) value]
+    ]
+
+    hereAt: key [
+        "Return the value associated to the variable named as specified
+         by `key' *in this namespace*. If the key is not found search will
+         *not* be carried on in superspaces and the method will fail."
+
+        <category: 'namespace protocol'>
+        ^self hereAt: key
+            ifAbsent: [SystemExceptions.NotFound signalOn: key what: 'key']
     ]
 ]
 
+
diff --git a/kernel/Metaclass.st b/kernel/Metaclass.st
index bb991e3..e480b32 100644
--- a/kernel/Metaclass.st
+++ b/kernel/Metaclass.st
@@ -77,6 +77,14 @@ it should be...the Smalltalk metaclass system is strange and complex.'>
  ^nil
     ]
 
+    allSharedPoolsDo: aBlock [
+ "Answer the shared pools visible from methods in the metaclass,
+ in the correct search order."
+
+ <category: 'delegation'>
+ self asClass allSharedPoolsDo: aBlock
+    ]
+
     category [
  "Answer the class category"
 
diff --git a/packages/stinst/parser/PoolResolutionTests.st b/packages/stinst/parser/PoolResolutionTests.st
index a7f4a24..3e5872f 100644
--- a/packages/stinst/parser/PoolResolutionTests.st
+++ b/packages/stinst/parser/PoolResolutionTests.st
@@ -29,10 +29,8 @@
 |
  ======================================================================"
 
-Eval [
-    Tests addSubspace: #MyLibrary; addSubspace: #MyProject.
-    MyProject addSubspace: #MyLibWrapper.
-]
+Tests addSubspace: #MyLibrary; addSubspace: #MyProject.
+MyProject addSubspace: #MyLibWrapper.
 
 Namespace current: STInST.Tests.MyLibrary [
 
@@ -76,7 +74,7 @@ MyLibrary.Foo subclass: Baz [
 
 Namespace current: STInST.Tests [
 
-TestCase subclass: TestTwistedPools [
+TestCase subclass: TestDefaultPoolResolution [
     | foo bar baz |
 
     assertVariable: symbol of: pools is: value description: str [
@@ -87,9 +85,9 @@ TestCase subclass: TestTwistedPools [
     ]
 
     setUp [
- foo := TwistedPools of: MyLibrary.Foo.
- bar := TwistedPools of: MyLibrary.Bar.
- baz := TwistedPools of: MyProject.MyLibWrapper.Baz.
+ foo := DefaultPoolResolution of: MyLibrary.Foo.
+ bar := DefaultPoolResolution of: MyLibrary.Bar.
+ baz := DefaultPoolResolution of: MyProject.MyLibWrapper.Baz.
     ]
 
     testClassPoolFirst [
@@ -110,7 +108,7 @@ TestCase subclass: TestTwistedPools [
     ]
 ]
 
-TestCase subclass: TestClassicPools [
+TestCase subclass: TestClassicPoolResolution [
     | foo bar baz |
 
     assertVariable: symbol of: pools is: value description: str [
@@ -121,9 +119,9 @@ TestCase subclass: TestClassicPools [
     ]
 
     setUp [
- foo := ClassicPools of: MyLibrary.Foo.
- bar := ClassicPools of: MyLibrary.Bar.
- baz := ClassicPools of: MyProject.MyLibWrapper.Baz.
+ foo := ClassicPoolResolution of: MyLibrary.Foo.
+ bar := ClassicPoolResolution of: MyLibrary.Bar.
+ baz := ClassicPoolResolution of: MyProject.MyLibWrapper.Baz.
     ]
 
     testNamespaceFirst [
diff --git a/packages/stinst/parser/STSymTable.st b/packages/stinst/parser/STSymTable.st
index 9180444..359aece 100644
--- a/packages/stinst/parser/STSymTable.st
+++ b/packages/stinst/parser/STSymTable.st
@@ -453,7 +453,7 @@ use compiling methods for that class.'>
 
 
 
-PoolResolution subclass: ClassicPools [
+PoolResolution subclass: ClassicPoolResolution [
     | pools |
     <comment: 'I provide shared pool variable resolution as it was
 before the PoolResolution hierarchy was added, and TwistedPools became
@@ -494,8 +494,8 @@ default.'>
 
 
 
-PoolResolution subclass: TwistedPools [
-    | pools herePools |
+PoolResolution subclass: DefaultPoolResolution [
+    | pools |
     <comment: 'I provide a "namespace is application" oriented method
 of shared pool searching, intended to be more intuitive for those who
 expect things to be found in their own namespace first. This is more
@@ -506,7 +506,6 @@ PoolResolution.'>
  "Add poolDictionary and all superspaces to the end of the
  search order. Always succeed."
  <category: 'accessing'>
- herePools := nil.
  pools addAll: poolDictionary withAllSuperspaces.
  ^true
     ]
@@ -514,10 +513,8 @@ PoolResolution.'>
     lookupBindingOf: symbol [
  "Search all pools in order (see super comment)."
  <category: 'accessing'>
- herePools isNil ifTrue: [herePools := pools collect: [:pool |
-    HereAssociator around: pool]].
- herePools do: [:pool |
-    (pool associationAt: symbol ifAbsent: [nil])
+ pools do: [:pool |
+    (pool hereAssociationAt: symbol ifAbsent: [nil])
  ifNotNil: [:assoc | ^assoc]].
  ^nil
     ]
@@ -526,89 +523,8 @@ PoolResolution.'>
  <category: 'initializing'>
  pools := OrderedSet identityNew: 7.
  aBehavior ifNil: [^nil].
- self addTwistedPools: aBehavior.
-    ]
-
-    addTwistedPools: class [
- "Implement the twisted pool search for a real class.  See
- class comment."
- <category: 'private'>
- | withSuperspaces nextSuperspaces isCommonSpace |
- "build with a single inheritance walk"
- class withAllSuperclassesDo: [:class |
-    class classPool isEmpty ifFalse: [pools add: class classPool].
-    withSuperspaces := class environment withAllSuperspaces.
-    (self combineInheritablePools: class sharedPoolDictionaries
-  reject: [:pool | withSuperspaces identityIncludes: pool])
- do: [:pool | pools add: pool].
-    "only take spaces that aren't in the superclass's spaces"
-    isCommonSpace := class superclass ifNil: [[:space | false]]
-                ifNotNil: [:superclass |
-    nextSuperspaces :=
- superclass environment withAllSuperspaces asSet.
-            [:space | nextSuperspaces includes: space]].
-    self addPoolsLast: withSuperspaces until: isCommonSpace]
-    ]
-
-    addPoolsLast: newPools until: invPredicate [
- <category: 'private'>
- newPools do: [:pool |
-    (invPredicate value: pool) ifTrue: [^newPools].
-    pools add: pool].
- ^newPools
-    ]
-
-    combineInheritablePools: list reject: invPredicate [
- "Answer the result of combining the list of pools using a
- topological sort, preferring dependent to prerequisite, and
- then left to right.  Any pool that passes invPredicate will
- not be answered."
- <category: 'private'>
- | visitState order descend |
- visitState := IdentityDictionary new: list size.
- order := OrderedCollection new: list size.
- descend := [:pool | | state |
-    state := visitState at: pool ifAbsent: [nil].
-    #visiting == state ifTrue:
- [SystemExceptions.InvalidValue
-     signalOn: list
-     reason: 'includes circular dependency'].
-    (state isNil and: [(invPredicate value: pool) not]) ifTrue:
- [visitState at: pool put: #visiting.
- "#allSuperspaces is not available on all pools"
- pool withAllSuperspaces allButFirst reverseDo: descend.
- order addFirst: pool.
- visitState at: pool put: #visited]].
- list reverseDo: descend.
- ^order
-    ]
-]
-
-
-
-Object subclass: HereAssociator [
-    | namespace hasSupers |
-
-    <comment: 'I exist purely to help TwistedPools, and am not meant
-to make sense as a good independent protocol, even though I borrow
-from dictionaries.'>
-
-    HereAssociator class >> around: namespace [
- <category: 'methods for TwistedPools'>
- ^self new init: namespace; yourself
-    ]
-
-    init: aNamespace [
- <category: 'methods for TwistedPools'>
- namespace := aNamespace.
- hasSupers := aNamespace withAllSuperspaces size > 1.
-    ]
-
-    associationAt: key ifAbsent: block [
- <category: 'methods for TwistedPools'>
- ^(hasSupers not or: [namespace definesKey: key])
-    ifTrue: [namespace associationAt: key ifAbsent: block]
-    ifFalse: block
+ aBehavior allSharedPoolDictionariesDo: [ :each |
+    each isEmpty ifFalse: [ pools add: each ] ]
     ]
 ]
 
@@ -636,6 +552,6 @@ Metaclass extend [
 
 Eval [
     STSymbolTable initialize.
-    PoolResolution current: TwistedPools.
+    PoolResolution current: DefaultPoolResolution.
 ]
 
diff --git a/packages/stinst/parser/package.xml b/packages/stinst/parser/package.xml
index 333f838..2d43b4c 100644
--- a/packages/stinst/parser/package.xml
+++ b/packages/stinst/parser/package.xml
@@ -21,9 +21,10 @@
   <filein>Exporter.st</filein>
 
   <test>
+   <namespace>STInST.Tests</namespace>
    <sunit>STInST.Tests.TestStandardRewrites</sunit>
-   <sunit>STInST.Tests.TestTwistedPools</sunit>
-   <sunit>STInST.Tests.TestClassicPools</sunit>
+   <sunit>STInST.Tests.TestDefaultPoolResolution</sunit>
+   <sunit>STInST.Tests.TestClassicPoolResolution</sunit>
    <filein>RewriteTests.st</filein>
    <filein>PoolResolutionTests.st</filein>
   </test>

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

Paolo Bonzini <[hidden email]> writes:
> This implements TP in the VM, but there are some issues with class
> variable initializers.  I'm not sure it's ready for merging with this
> bug, but maybe it is (it is not a regression anyway).

I think this is broader than the tests indicate, and maybe worth looking
at separately, so I created issue #211 for it.

--
But you know how reluctant paranormal phenomena are to reveal
themselves when skeptics are present. --Robert Sheaffer, SkI 9/2003


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