--- a/analyzer/extensions.st Tue Mar 04 21:25:40 2014 +0100
+++ b/analyzer/extensions.st Tue Mar 04 21:25:41 2014 +0100
@@ -0,0 +1,525 @@
+"{ Package: 'stx:goodies/petitparser/analyzer' }"!
+
+!PPActionParser methodsFor:'*petitanalyzer-matching'!
+
+match: aParser inContext: aDictionary seen: anIdentitySet
+ ^ (super match: aParser inContext: aDictionary seen: anIdentitySet) and: [ self block = aParser block ]
+! !
+
+!PPDelegateParser methodsFor:'*petitanalyzer-transforming'!
+
+replace: aParser with: anotherParser
+ super replace: aParser with: anotherParser.
+ parser == aParser ifTrue: [ parser := anotherParser ]
+! !
+
+!PPEpsilonParser methodsFor:'*petitanalyzer-testing'!
+
+isNullable
+ ^ true
+! !
+
+!PPFailingParser methodsFor:'*petitanalyzer-matching'!
+
+match: aParser inContext: aDictionary seen: anIdentitySet
+ ^ (super match: aParser inContext: aDictionary seen: anIdentitySet) and: [ self message = aParser message ]
+! !
+
+!PPLimitedRepeatingParser methodsFor:'*petitanalyzer-transforming'!
+
+replace:aParser with:anotherParser
+ super replace:aParser with:anotherParser.
+ limit == aParser ifTrue:[limit := anotherParser].
+! !
+
+!PPListParser methodsFor:'*petitanalyzer-matching'!
+
+copyInContext: aDictionary seen: aSeenDictionary
+ | copy copies |
+ aSeenDictionary at: self ifPresent: [ :value | ^ value ].
+ copy := aSeenDictionary at: self put: self copy.
+ copies := OrderedCollection new.
+ parsers do: [ :each |
+ | result |
+ result := each
+ copyInContext: aDictionary
+ seen: aSeenDictionary.
+ result isCollection
+ ifTrue: [ copies addAll: result ]
+ ifFalse: [ copies add: result ] ].
+ ^ copy
+ setParsers: copies;
+ yourself
+! !
+
+!PPListParser methodsFor:'*petitanalyzer-transforming'!
+
+replace: aParser with: anotherParser
+ super replace: aParser with: anotherParser.
+ parsers keysAndValuesDo: [ :index :parser |
+ parser == aParser
+ ifTrue: [ parsers at: index put: anotherParser ] ]
+! !
+
+!PPLiteralParser methodsFor:'*petitanalyzer-matching'!
+
+match: aParser inContext: aDictionary seen: anIdentitySet
+ ^ (super match: aParser inContext: aDictionary seen: anIdentitySet) and: [ self literal = aParser literal and: [ self message = aParser message ] ]
+! !
+
+!PPOptionalParser methodsFor:'*petitanalyzer-testing'!
+
+isNullable
+ ^ true
+! !
+
+!PPParser methodsFor:'*petitanalyzer-named'!
+
+allNamedParsers
+ "Answer all the named parse nodes of the receiver."
+
+ | result |
+ result := OrderedCollection new.
+ self allNamedParsersDo: [ :parser | result addLast: parser ].
+ ^ result
+! !
+
+!PPParser methodsFor:'*petitanalyzer-named'!
+
+allNamedParsersDo: aBlock
+ "Iterate over all the named parse nodes of the receiver."
+
+ self allParsersDo: [ :each |
+ each name notNil
+ ifTrue: [ aBlock value: each ] ]
+! !
+
+!PPParser methodsFor:'*petitanalyzer-enumerating'!
+
+allParsers
+ "Answer all the parse nodes of the receiver."
+
+ | result |
+ result := OrderedCollection new.
+ self allParsersDo: [ :parser | result addLast: parser ].
+ ^ result
+! !
+
+!PPParser methodsFor:'*petitanalyzer-enumerating'!
+
+allParsersDo: aBlock
+ "Iterate over all the parse nodes of the receiver."
+
+ self allParsersDo: aBlock seen: IdentitySet new
+! !
+
+!PPParser methodsFor:'*petitanalyzer-enumerating'!
+
+allParsersDo: aBlock seen: aSet
+ "Iterate over all the parse nodes of the receiver, do not visit and follow the ones contained in aSet."
+
+ (aSet includes: self)
+ ifTrue: [ ^ self ].
+ aSet add: self.
+ aBlock value: self.
+ self children
+ do: [ :each | each allParsersDo: aBlock seen: aSet ]
+! !
+
+!PPParser methodsFor:'*petitanalyzer-matching'!
+
+copyInContext: aDictionary
+ ^ self copyInContext: aDictionary seen: IdentityDictionary new
+! !
+
+!PPParser methodsFor:'*petitanalyzer-matching'!
+
+copyInContext: aDictionary seen: aSeenDictionary
+ | copy |
+ aSeenDictionary
+ at: self
+ ifPresent: [ :value | ^ value ].
+ copy := aSeenDictionary
+ at: self
+ put: self copy.
+ copy children do: [ :each |
+ copy
+ replace: each
+ with: (each copyInContext: aDictionary seen: aSeenDictionary) ].
+ ^ copy
+! !
+
+!PPParser methodsFor:'*petitanalyzer-querying'!
+
+cycleSet
+ "Answer a set of all nodes that are within one or more cycles of left-recursion. This is generally not a problem if at least one of the nodes is memoized, but it might make the grammar very inefficient and should be avoided if possible."
+
+ | cycles |
+ cycles := IdentitySet new.
+ self cycleSet: OrderedCollection new firstSets: self firstSets into: cycles.
+ ^ cycles
+! !
+
+!PPParser methodsFor:'*petitanalyzer-private'!
+
+cycleSet: aDictionary
+ "PRIVATE: Answer the children that could be part of a cycle-set with the receiver, subclasses might restrict the number of children returned. aDictionary is pre-calcualted first-sets."
+
+ ^ self children
+! !
+
+!PPParser methodsFor:'*petitanalyzer-private'!
+
+cycleSet: aStack firstSets: aDictionary into: aSet
+ "PRIVATE: Try to find a cycle, where aStack contains the previously visited parsers. The method returns quickly when the receiver is a terminal, terminals cannot be part of a cycle. If aStack already contains the receiver, then we are in a cycle. In this case we don't process the children further and add the nodes to aSet."
+
+ | index |
+ self isTerminal
+ ifTrue: [ ^ self ].
+ (index := aStack indexOf: self) > 0
+ ifTrue: [ ^ aSet addAll: (aStack copyFrom: index to: aStack size) ].
+ aStack addLast: self.
+ (self cycleSet: aDictionary)
+ do: [ :each | each cycleSet: aStack firstSets: aDictionary into: aSet ].
+ aStack removeLast
+! !
+
+!PPParser methodsFor:'*petitanalyzer-querying'!
+
+firstSet
+ "Answer the first-set of the receiver. Note, this implementation is inefficient when called on different receivers of the same grammar, instead use #firstSets to calculate the first-sets at once."
+
+ ^ self firstSets at: self
+! !
+
+!PPParser methodsFor:'*petitanalyzer-querying'!
+
+firstSets
+ "Answer a dictionary with all the parsers reachable from the receiver as key and their first-set as value. The first-set of a parser is the list of terminal parsers that begin the parser derivable from that parser."
+
+ | firstSets |
+ firstSets := IdentityDictionary new.
+ self allParsersDo: [ :each |
+ firstSets at: each put: (each isTerminal
+ ifTrue: [ IdentitySet with: each ]
+ ifFalse: [ IdentitySet new ]).
+ each isNullable
+ ifTrue: [ (firstSets at: each) add: PPSentinel instance ] ].
+ [ | changed tally |
+ changed := false.
+ firstSets keysAndValuesDo: [ :parser :first |
+ tally := first size.
+ parser firstSets: firstSets into: first.
+ changed := changed or: [ tally ~= first size ] ].
+ changed ] whileTrue.
+ ^ firstSets
+! !
+
+!PPParser methodsFor:'*petitanalyzer-private'!
+
+firstSets: aFirstDictionary into: aSet
+ "PRIVATE: Try to add additional elements to the first-set aSet of the receiver, use the incomplete aFirstDictionary."
+
+ self children do: [ :parser | aSet addAll: (aFirstDictionary at: parser) ]
+! !
+
+!PPParser methodsFor:'*petitanalyzer-querying'!
+
+followSet
+ "Answer the follow-set of the receiver starting at the receiver. Note, this implementation is inefficient when called on different receivers of the same grammar, instead use #followSets to calculate the follow-sets at once."
+
+ ^ self followSets at: self
+! !
+
+!PPParser methodsFor:'*petitanalyzer-querying'!
+
+followSets
+ "Answer a dictionary with all the parsers reachable from the receiver as key and their follow-set as value. The follow-set of a parser is the list of terminal parsers that can appear immediately to the right of that parser."
+
+ | current previous continue firstSets followSets |
+ current := previous := 0.
+ firstSets := self firstSets.
+ followSets := IdentityDictionary new.
+ self allParsersDo: [ :each | followSets at: each put: IdentitySet new ].
+ (followSets at: self) add: PPSentinel instance.
+ [ followSets keysAndValuesDo: [ :parser :follow |
+ parser
+ followSets: followSets
+ firstSets: firstSets
+ into: follow ].
+ current := followSets
+ inject: 0
+ into: [ :result :each | result + each size ].
+ continue := previous < current.
+ previous := current.
+ continue ] whileTrue.
+ ^ followSets
+! !
+
+!PPParser methodsFor:'*petitanalyzer-private'!
+
+followSets: aFollowDictionary firstSets: aFirstDictionary into: aSet
+ "PRIVATE: Try to add additional elements to the follow-set aSet of the receiver, use the incomplete aFollowDictionary and the complete aFirstDictionary."
+
+ self children do: [ :parser | (aFollowDictionary at: parser) addAll: aSet ]
+! !
+
+!PPParser methodsFor:'*petitanalyzer-named'!
+
+innerChildren
+ "Answer the inner children of the receiver."
+
+ | result |
+ result := OrderedCollection new.
+ self innerChildrenDo: [ :parser | result addLast: parser ].
+ ^ result
+! !
+
+!PPParser methodsFor:'*petitanalyzer-named'!
+
+innerChildrenDo: aBlock
+ "Iterate over the inner children of the receiver."
+
+ self innerChildrenDo: aBlock seen: IdentitySet new
+! !
+
+!PPParser methodsFor:'*petitanalyzer-named'!
+
+innerChildrenDo: aBlock seen: aSet
+ "Iterate over the inner children of the receiver."
+
+ self children do: [ :each |
+ (aSet includes: each)
+ ifTrue: [ ^ self ].
+ aSet add: each.
+ each name isNil ifTrue: [
+ aBlock value: each.
+ each innerChildrenDo: aBlock seen: aSet ] ]
+! !
+
+!PPParser methodsFor:'*petitanalyzer-testing'!
+
+isNullable
+ "Answer true if the receiver is a nullable parser, e.g. it can successfully parse nothing."
+
+ ^ false
+! !
+
+!PPParser methodsFor:'*petitanalyzer-testing'!
+
+isTerminal
+ "Answer true if the receiver is a terminal or leaf parser, that means it does not delegate to any other parser."
+
+ ^ self children isEmpty
+! !
+
+!PPParser methodsFor:'*petitanalyzer-matching'!
+
+match: aParser inContext: aDictionary
+ ^ self match: aParser inContext: aDictionary seen: IdentitySet new
+! !
+
+!PPParser methodsFor:'*petitanalyzer-matching'!
+
+match: aParser inContext: aDictionary seen: anIdentitySet
+ "This is the default implementation to match two parsers. This code can properly handle recursion. This is code is supposed to be overridden in subclasses that add new state."
+
+ (self == aParser or: [ anIdentitySet includes: self ])
+ ifTrue: [ ^ true ].
+ anIdentitySet add: self.
+ ^ self class = aParser class and: [ self matchList: self children against: aParser children inContext: aDictionary seen: anIdentitySet ]
+! !
+
+!PPParser methodsFor:'*petitanalyzer-matching'!
+
+matchList: matchList against: parserList inContext: aDictionary seen: aSet
+ ^ self matchList: matchList index: 1 against: parserList index: 1 inContext: aDictionary seen: aSet
+! !
+
+!PPParser methodsFor:'*petitanalyzer-matching'!
+
+matchList: matchList index: matchIndex against: parserList index: parserIndex inContext: aDictionary seen: aSet
+ | parser currentIndex currentDictionary currentSeen parsers |
+ matchList size < matchIndex
+ ifTrue: [ ^ parserList size < parserIndex ].
+ parser := matchList at: matchIndex.
+ parser class = PPListPattern ifTrue: [
+ currentIndex := parserIndex - 1.
+ [ currentDictionary := aDictionary copy.
+ currentSeen := aSet copy.
+ parserList size < currentIndex or: [
+ parsers := parserList copyFrom: parserIndex to: currentIndex.
+ (currentDictionary at: parser ifAbsentPut: [ parsers ]) = parsers and: [
+ (self
+ matchList: matchList
+ index: matchIndex + 1
+ against: parserList
+ index: currentIndex + 1
+ inContext: currentDictionary
+ seen: currentSeen)
+ ifTrue: [
+ currentDictionary keysAndValuesDo: [ :key :value | aDictionary at: key put: value ].
+ ^ true ].
+ false ] ] ] whileFalse: [ currentIndex := currentIndex + 1 ].
+ ^ false ].
+ parserList size < parserIndex
+ ifTrue: [ ^ false ].
+ (parser match: (parserList at: parserIndex) inContext: aDictionary seen: aSet)
+ ifFalse: [ ^ false ].
+ ^ self
+ matchList: matchList
+ index: matchIndex + 1
+ against: parserList
+ index: parserIndex + 1
+ inContext: aDictionary
+ seen: aSet
+! !
+
+!PPParser methodsFor:'*petitanalyzer-named'!
+
+namedChildren
+ "Answer the named children of the receiver."
+
+ | result |
+ result := OrderedCollection new.
+ self namedChildrenDo: [ :parser | result addLast: parser ].
+ ^ result
+! !
+
+!PPParser methodsFor:'*petitanalyzer-named'!
+
+namedChildrenDo: aBlock
+ "Iterate over the named children of the receiver."
+
+ self namedChildrenDo: aBlock seen: IdentitySet new
+! !
+
+!PPParser methodsFor:'*petitanalyzer-named'!
+
+namedChildrenDo: aBlock seen: aSet
+ "Iterate over the named children of the receiver."
+
+ self children do: [ :each |
+ (aSet includes: each)
+ ifTrue: [ ^ self ].
+ aSet add: each.
+ each name isNil
+ ifTrue: [ each namedChildrenDo: aBlock seen: aSet ]
+ ifFalse: [ aBlock value: each ] ]
+! !
+
+!PPParser methodsFor:'*petitanalyzer-transforming'!
+
+replace: aParser with: anotherParser
+ "Replace the references of the receiver pointing to aParser with anotherParser."
+! !
+
+!PPParser methodsFor:'*petitanalyzer-transforming'!
+
+transform: aBlock
+ "Answer a copy of all parsers reachable from the receiver transformed using aBlock."
+
+ | mapping root |
+ mapping := IdentityDictionary new.
+ self allParsersDo: [ :each |
+ mapping
+ at: each
+ put: (aBlock value: each copy) ].
+ root := mapping at: self.
+ [ | changed |
+ changed := false.
+ root allParsersDo: [ :each |
+ each children do: [ :old |
+ mapping at: old ifPresent: [ :new |
+ each replace: old with: new.
+ changed := true ] ] ].
+ changed ] whileTrue.
+ ^ root
+! !
+
+!PPPluggableParser methodsFor:'*petitanalyzer-matching'!
+
+match: aParser inContext: aDictionary seen: anIdentitySet
+ ^ (super match: aParser inContext: aDictionary seen: anIdentitySet) and: [ self block = aParser block ]
+! !
+
+!PPPredicateParser methodsFor:'*petitanalyzer-matching'!
+
+match: aParser inContext: aDictionary seen: anIdentitySet
+ ^ (super match: aParser inContext: aDictionary seen: anIdentitySet) and: [ self block = aParser block and: [ self message = aParser message ] ]
+! !
+
+!PPPredicateSequenceParser methodsFor:'*petitanalyzer-matching'!
+
+match: aParser inContext: aDictionary seen: anIdentitySet
+ ^ (super match: aParser inContext: aDictionary seen: anIdentitySet) and: [ self size = aParser size ]
+! !
+
+!PPRepeatingParser methodsFor:'*petitanalyzer-testing'!
+
+isNullable
+ ^ min = 0
+! !
+
+!PPRepeatingParser methodsFor:'*petitanalyzer-matching'!
+
+match: aParser inContext: aDictionary seen: anIdentitySet
+ ^ (super match: aParser inContext: aDictionary seen: anIdentitySet) and: [ self min = aParser min and: [ self max = aParser max ] ]
+! !
+
+!PPSequenceParser methodsFor:'*petitanalyzer-private'!
+
+cycleSet: aDictionary
+ | firstSet |
+ 1 to: parsers size do: [ :index |
+ firstSet := aDictionary at: (parsers at: index).
+ (firstSet anySatisfy: [ :each | each isNullable ])
+ ifFalse: [ ^ parsers copyFrom: 1 to: index ] ].
+ ^ parsers
+! !
+
+!PPSequenceParser methodsFor:'*petitanalyzer-private'!
+
+firstSets: aFirstDictionary into: aSet
+ | nullable |
+ parsers do: [ :parser |
+ nullable := false.
+ (aFirstDictionary at: parser) do: [ :each |
+ each isNullable
+ ifTrue: [ nullable := true ]
+ ifFalse: [ aSet add: each ] ].
+ nullable
+ ifFalse: [ ^ self ] ].
+ aSet add: PPSentinel instance
+! !
+
+!PPSequenceParser methodsFor:'*petitanalyzer-private'!
+
+followSets: aFollowDictionary firstSets: aFirstDictionary into: aSet
+ parsers keysAndValuesDo: [ :index :parser |
+ | followSet firstSet |
+ followSet := aFollowDictionary at: parser.
+ index = parsers size
+ ifTrue: [ followSet addAll: aSet ]
+ ifFalse: [
+ (self class withAll: (parsers
+ copyFrom: index + 1 to: parsers size))
+ firstSets: aFirstDictionary
+ into: (firstSet := IdentitySet new).
+ (firstSet anySatisfy: [ :each | each isNullable ])
+ ifTrue: [ followSet addAll: aSet ].
+ followSet addAll: (firstSet
+ reject: [ :each | each isNullable ]) ] ]
+! !
+
+!PPTokenParser methodsFor:'*petitanalyzer-matching'!
+
+match: aParser inContext: aDictionary seen: anIdentitySet
+ ^ (super match: aParser inContext: aDictionary seen: anIdentitySet) and: [ self tokenClass = aParser tokenClass ]
+! !
+
+!stx_goodies_petitparser_analyzer class methodsFor:'documentation'!
+
+extensionsVersion_CVS
+ ^ '$Header: /cvs/stx/stx/goodies/petitparser/analyzer/extensions.st,v 1.2 2014-03-04 20:25:41 cg Exp $'
+! !