2008-04-16 Paolo Bonzini <bonzini gnu.org>
* 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
_______________________________________________
help-smalltalk mailing list
help-smalltalkgnu.org
http://lists.gnu.org/mailman/listinfo/help-smalltalk
|
