[Help-smalltalk] [PATCH TwistedPools 2/n] implement TwistedPools in Behavior

[Paolo Bonzini]

2008-04-16  Paolo Bonzini  <address@hidden>

        * kernel/Behavior.st: Add #allSharedPoolDictionariesDo:
        and #allSharedPoolDictionaries, use it in #allSharedPools.
        * kernel/Class.st: Implement TwistedPools in
        #allSharedPoolDictionariesDo:.
        * kernel/Metaclass.st: Implement #allSharedPoolDictionariesDo:.

        * kernel/DeferBinding.st: Rely on #allSharedPoolDictionariesDo:.
---
 kernel/Behavior.st     |   29 ++++++++++++++++++----
 kernel/Class.st        |   60 ++++++++++++++++++++++++++++++++++++++++++++++++
 kernel/DeferBinding.st |   11 ++------
 kernel/Metaclass.st    |    8 ++++++
 4 files changed, 94 insertions(+), 14 deletions(-)

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/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/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"
 
-- 
1.5.5