Smalltalk › Gnu

[feature] make TwistedPools the default pool search order

_‹ Previous Topic Next Topic _›

Classic

List

Threaded

15 messages Options

S11001001

[feature] make TwistedPools the default pool search order

Issue status update for
http://smalltalk.gnu.org/node/206
Post a follow up:
http://smalltalk.gnu.org/project/comments/add/206

Project: GNU Smalltalk
Version: <none>
Component: STInST
Category: feature requests
Priority: normal
Assigned to: Unassigned
Reported by: S11001001
Updated by: S11001001
Status: active

I would like to make the pool search order more intuitive and likely to
do what you want in a "namespace is application" environment. My ideas
for this, and a link to the git branch, are on wiki page PoolResolution.

Missing from that are C implementation and post-compilation unit tests.

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

Paolo Bonzini-3

Re: [feature] make TwistedPools the default pool search order

S11001001

Re: [feature] make TwistedPools the default pool search order

In reply to this post by S11001001

Issue status update for
http://smalltalk.gnu.org/project/issue/206
Post a follow up:
http://smalltalk.gnu.org/project/comments/add/206

Project: GNU Smalltalk
Version: <none>
Component: STInST
Category: feature requests
Priority: normal
Assigned to: Unassigned
Reported by: S11001001
Updated by: S11001001
Status: active

1) Yes, in your specific example; however, elimination is not done as
pools are encountered, because we prefer left-to-right. For example,
in the hierarchy:

X
A
B
C

'B C' will sort to 'B A C X', whereas 'B C A' will sort to 'B C A X'.

2) It would be searching some pools too early. I wanted to allow
importing of namespaces in other hierarchies, while not thereby forcing
the early search of namespaces already imported by virtue of containing
the importing class.

Arguments can be made to reduce or increase the elimination of shared
pools. Both are discussed in the "Combination details" section, the
specific option you mention being the subject of the second and third
paragraphs.

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

Paolo Bonzini-3

Re: [feature] make TwistedPools the default pool search order

In reply to this post by S11001001

Paolo Bonzini-3

Re: [feature] make TwistedPools the default pool search order

In reply to this post by S11001001

Issue status update for
http://smalltalk.gnu.org/project/issue/206
Post a follow up:
http://smalltalk.gnu.org/project/comments/add/206

Project: GNU Smalltalk
Version: <none>
Component: STInST
Category: feature requests
Priority: normal
Assigned to: Unassigned
Reported by: S11001001
Updated by: bonzinip
Status: active
Attachment: http://smalltalk.gnu.org/files/issues/gst-twistedpools.patch (21.92 KB)

The attached patch makes TwistedPools the default pool search order
outside the VM, and consequently changes your TwistedPools class to
just use the default pool search order. All testcases still pass.

The code is heavily based on yours, with some refactoring because I
wasn't afraid of touching base classes :-) and because the search order
is implemented directly in Behavior (actually in Class).

I changed a couple of data structures. For the set of superspaces of
this class and all the superclasses' environments, I used a Bag, which
makes it easy to account for namespaces that are present multiple
times. For the topological sort, I used two IdentitySets (grey/white,
in three-color visit terminology) instead of a single dictionary.

I'll post the patch split in three to the ML too.

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

Paolo Bonzini-2

[PATCH TwistedPools 1/n] add more namespace polymorphism methods to Dictionary

This is just a preparatory patch. The final version will have
to include an abstract class, common to LookupTable and Dictionary,
so that these methods do not pollute LookupTable.

2008-04-16 Paolo Bonzini <[hidden email]>

* kernel/AbstNamespc.st: Move some methods...
* kernel/BindingDict.st: ... here (#= and #hash)
* kernel/Dictionary.st: ... and here.
---
kernel/AbstNamespc.st | 108 ------------------------------------------
kernel/BindingDict.st | 19 +++++++-
kernel/Dictionary.st | 124 +++++++++++++++++++++++++++++++++++++++++++++++-
3 files changed, 139 insertions(+), 112 deletions(-)

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/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/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']
]
]

+
--
1.5.5

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

Paolo Bonzini-2

[PATCH TwistedPools 2/n] implement TwistedPools in Behavior

In reply to this post by Paolo Bonzini-3

2008-04-16 Paolo Bonzini <[hidden email]>

* 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
[hidden email]
http://lists.gnu.org/mailman/listinfo/help-smalltalk

Paolo Bonzini-2

[PATCH TwistedPools 3/n] class renaming, and changing TwistedPools to use the default pool resolution

In reply to this post by Paolo Bonzini-3

2008-04-16 Paolo Bonzini <[hidden email]>

* PoolResolutionTests.st: Rename TestTwistedPools to
TestDefaultPoolResolution, TestClassicPools to
TestClassicPoolResolution, TwistedPools to
DefaultPoolResolution, ClassicPools to ClassicPoolResolution
* STSymTable.st: Likewise. Remove HereAssociator and herePools.
In DefaultPoolResolution, use #allSharedPoolDictionariesDo:
instead of implementing TwistedPools manually.
* package.xml: Adjust for naming changes.
---
packages/stinst/parser/PoolResolutionTests.st | 22 +++---
packages/stinst/parser/STSymTable.st | 100 ++-----------------------
packages/stinst/parser/package.xml | 5 +-
3 files changed, 21 insertions(+), 106 deletions(-)

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

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

S11001001

Re: [feature] make TwistedPools the default pool search order

In reply to this post by S11001001

Issue status update for
http://smalltalk.gnu.org/project/issue/206
Post a follow up:
http://smalltalk.gnu.org/project/comments/add/206

Project: GNU Smalltalk
Version: <none>
Component: STInST
Category: feature requests
Priority: normal
Assigned to: Unassigned
Reported by: S11001001
Updated by: S11001001
Status: active

I added a fix for inherited class/shared pools and a test for it in
c097acd. Also in c097acd is a new, failing test, fixed in b69098a, to
eliminate only the /direct superclass's/ namespaces from
the namespace walk while searching pools. (See step #4 on
PoolResolution).

> For the set of superspaces of this class and
> all the superclasses' environments

While it is convenient, it doesn't match the expectation of step #4,
illustrated by the new test case, which is also why TwistedPools
originally used superclass environment withAllSuperspaces asSet to make
the sole set of namespace walk eliminations.

The unfortunate detail of this alternative, and thus a slight bug
introduced in b69098a, is that it may answer some namespaces multiple
times. OrderedSet did the right thing, so I could ignore the issue,
but #allSharedPoolDictionariesDo: isn't necessarily building a set. Of
course, the order is still right, so it doesn't affect a leftmost-first
variable search at all.

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

Paolo Bonzini-3

Re: [feature] make TwistedPools the default pool search order

In reply to this post by S11001001

S11001001

Re: [feature] make TwistedPools the default pool search order

In reply to this post by S11001001

Paolo Bonzini-3

Re: [feature] make TwistedPools the default pool search order

In reply to this post by S11001001

Issue status update for
http://smalltalk.gnu.org/project/issue/206
Post a follow up:
http://smalltalk.gnu.org/project/comments/add/206

Project: GNU Smalltalk
Version: <none>
Component: STInST
Category: feature requests
Priority: normal
Assigned to: Unassigned
Reported by: S11001001
Updated by: bonzinip
Status: active

ok, that's good. I could find in GCC a nice implementation of
IdentitySet, and with that it was quite easy to implement TwistedPools
in the VM. It is in my personal git repo.

Tests pass, but still, two more eyes can only do best. And there is
also some pleaing for help:

/* Add POOLOOP and all of its superspaces to the list in the
right order (Stephen, please help me... :-). */

It's actually just a matter of copying from the right wiki page, if you
don't have time I can do it.

Thanks again for noticing the need for this feature, for the precise
description of the problem and (as usual) for the high quality of your
code and your reviews.

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

Paolo Bonzini-3

Re: [feature] make TwistedPools the default pool search order

In reply to this post by S11001001

S11001001

Re: [feature] make TwistedPools the default pool search order

In reply to this post by S11001001

Paolo Bonzini-3

Re: [feature] make TwistedPools the default pool search order

In reply to this post by S11001001