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" - - - - - ] - - hash [ - "Answer an hash value for the receiver. This is the same as the - object's #identityHash." - - - - - ] - 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" - - - | 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." - - - ^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." - - - ^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." - - - ^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" - - - | 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" - - - | 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" - - - | 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." - - - | 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." + + + | 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." | 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" + + + + ] + + hash [ + "Answer an hash value for the receiver. This is the same as the + object's #identityHash." + + + + + ] + copy [ ^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." + + | 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" + + + | 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)." + + + ] + + definedKeys [ + "Answer a kind of Set containing the keys of the receiver" + + + | 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" + + + | space | + space := self. + + [space := space superspace. + space == aNamespace ifTrue: [^true]. + space notNil] + whileTrue + ] + + superspace [ + "Answer the receiver's superspace, which is nil for BindingDictionary." + + + ^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" - - ^{self} + + | 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)." + + + 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." + + + ^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." + + + | 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." + + + ^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." + + + | 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." + + + ^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." + + + 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 | -PoolResolution subclass: TwistedPools [ - | pools herePools | +PoolResolution subclass: DefaultPoolResolution [ + | pools | "Add poolDictionary and all superspaces to the end of the search order. Always succeed." - herePools := nil. pools addAll: poolDictionary withAllSuperspaces. ^true ] @@ -514,10 +513,8 @@ PoolResolution.'> lookupBindingOf: symbol [ "Search all pools in order (see super comment)." - 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.'> pools := OrderedSet identityNew: 7. aBehavior ifNil: [^nil]. - self addTwistedPools: aBehavior. - ] - - addTwistedPools: class [ - "Implement the twisted pool search for a real class. See - class comment." - - | 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 [ - - 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." - - | 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 | - - - - HereAssociator class >> around: namespace [ - - ^self new init: namespace; yourself - ] - - init: aNamespace [ - - namespace := aNamespace. - hasSupers := aNamespace withAllSuperspaces size > 1. - ] - - associationAt: key ifAbsent: block [ - - ^(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 @@ Exporter.st + STInST.Tests STInST.Tests.TestStandardRewrites - STInST.Tests.TestTwistedPools - STInST.Tests.TestClassicPools + STInST.Tests.TestDefaultPoolResolution + STInST.Tests.TestClassicPoolResolution RewriteTests.st PoolResolutionTests.st