--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PEGFsaState.st Fri Jul 24 15:06:54 2015 +0100
@@ -0,0 +1,455 @@
+"{ Package: 'stx:goodies/petitparser/compiler' }"
+
+"{ NameSpace: Smalltalk }"
+
+Object subclass:#PEGFsaState
+ instanceVariableNames:'name retval priority transitions final multivalue'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitCompiler-FSA'
+!
+
+!PEGFsaState methodsFor:'accessing'!
+
+destination
+ self assert: transitions size = 1.
+ ^ transitions anyOne destination
+!
+
+destinations
+ ^ (transitions collect: #destination) asIdentitySet
+!
+
+final
+ ^ final
+!
+
+final: anObject
+ final := anObject
+!
+
+multivalue
+ ^ multivalue
+!
+
+multivalue: anObject
+ multivalue := anObject
+!
+
+name
+ ^ name
+!
+
+name: anObject
+ name := anObject asString
+!
+
+prefix
+ ^ 'state'
+!
+
+priority
+ ^ priority
+!
+
+priority: anObject
+ priority := anObject
+!
+
+priorityIfNone: value
+ ^ self hasPriority ifTrue: [ self priority ] ifFalse: [ value ]
+!
+
+retval
+ ^ retval
+!
+
+retval: anObject
+ retval := anObject
+!
+
+retvalAsCollection
+ ^ self isMultivalue ifTrue: [
+ self retval
+ ] ifFalse: [
+ Array with: self retval
+ ]
+!
+
+suffix
+ ^ ''
+!
+
+transitions
+ ^ transitions
+! !
+
+!PEGFsaState methodsFor:'analysis'!
+
+reachableStates
+ | openSet |
+ openSet := IdentitySet new.
+ self reachableStatesOpenSet: openSet.
+ ^ openSet
+!
+
+reachableStatesOpenSet: openSet
+ (openSet includes: self) ifTrue: [
+ ^ self
+ ].
+
+ openSet add: self.
+
+ (self transitions) do: [ :t |
+ t destination reachableStatesOpenSet: openSet
+ ].
+
+!
+
+transitionPairs
+ | size pairs collection |
+ size := transitions size.
+ pairs := OrderedCollection new: (size - 1) * size / 2.
+
+ collection := transitions asOrderedCollection.
+
+ 1 to: (size - 1) do: [ :index1 |
+ (index1 + 1 to: size) do: [ :index2 |
+ pairs add: (PEGFsaPair new
+ first: (collection at: index1);
+ second: (collection at: index2);
+ yourself).
+ ]
+ ].
+ ^ pairs
+! !
+
+!PEGFsaState methodsFor:'comparing'!
+
+= anotherState
+ (self == anotherState) ifTrue: [ ^ true ].
+ (self class == anotherState class) ifFalse: [ ^ true ].
+
+ (name == anotherState name) ifFalse: [ ^ false ].
+ (priority == anotherState priority) ifFalse: [ ^ false ].
+ (multivalue == anotherState multivalue) ifFalse: [ ^ false ].
+ (retval = anotherState retval) ifFalse: [ ^ false ].
+ (final = anotherState final) ifFalse: [ ^ false ].
+
+ (transitions size = anotherState transitions size) ifFalse: [ ^ false ].
+ transitions do: [:t |
+ (anotherState transitions contains: [:at | at = t]) ifFalse: [ ^ false ].
+ ].
+
+ ^ true
+!
+
+canBeIsomorphicTo: anotherState
+ (name == anotherState name) ifFalse: [ ^ false ].
+ (priority == anotherState priority) ifFalse: [ ^ false ].
+ (multivalue == anotherState multivalue) ifFalse: [ ^ false ].
+ (final == anotherState final) ifFalse: [ ^ false ].
+ (transitions size == anotherState transitions size) ifFalse: [ ^ false ].
+ (retval = anotherState retval) ifFalse: [ ^ false ].
+
+ ^ true
+!
+
+equals: anotherState
+ (self == anotherState) ifTrue: [ ^ true ].
+ (anotherState class == PEGFsaState) ifFalse: [ ^ false ].
+
+ (retval = anotherState retval) ifFalse: [ ^ false ].
+ (multivalue = anotherState multivalue) ifFalse: [ ^ false ].
+ (self isFinal = anotherState isFinal) ifFalse: [ ^ false ].
+
+ (self hasPriority and: [anotherState hasPriority]) ifTrue: [
+ (priority == anotherState priority) ifFalse: [ ^ false ].
+ ].
+
+ (transitions size == anotherState transitions size) ifFalse: [ ^ false ].
+ anotherState transitions do: [ :t |
+ (transitions contains: [ :e | e equals: t]) ifFalse: [ ^ false ]
+ ].
+
+ ^ true
+!
+
+hash
+ ^ retval hash bitXor: (
+ priority hash bitXor: (
+ multivalue hash bitXor:
+ "JK: Size is not the best option here, but it one gets infinite loops otherwise"
+ transitions size hash)).
+!
+
+isIsomorphicTo: anotherState resolvedSet: set
+ (self == anotherState) ifTrue: [ ^ true ].
+
+ (name == anotherState name) ifFalse: [ ^ false ].
+ (priority == anotherState priority) ifFalse: [ ^ false ].
+ (multivalue == anotherState multivalue) ifFalse: [ ^ false ].
+ (retval = anotherState retval) ifFalse: [ ^ false ].
+ (final = anotherState final) ifFalse: [ ^ false ].
+
+ (transitions size = anotherState transitions size) ifFalse: [ ^ false ].
+ transitions do: [:t |
+ (anotherState transitions contains: [:at | t isIsomorphicto: at]) ifFalse: [ ^ false ].
+ ].
+
+ ^ true
+! !
+
+!PEGFsaState methodsFor:'copying'!
+
+postCopy
+ super postCopy.
+ transitions := (transitions collect: [ :t | t copy ]).
+ retval := retval copy.
+! !
+
+!PEGFsaState methodsFor:'gt'!
+
+gtName
+ | gtName |
+ gtName := name.
+
+ self hasPriority ifTrue: [
+ gtName := gtName asString, ',', self priority asString.
+ ].
+
+ ^ gtName
+! !
+
+!PEGFsaState methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ transitions := OrderedCollection new.
+ multivalue := false.
+! !
+
+!PEGFsaState methodsFor:'modifications'!
+
+addTransition: t
+ self assert: (transitions identityIncludes: t) not.
+ transitions add: t
+!
+
+decreasePriority
+ (self isFinal and: [ self hasPriority not ]) ifTrue: [
+ priority := 0.
+ ].
+ priority isNil ifFalse: [
+ priority := priority - 1
+ ]
+!
+
+removeTransition: t
+ self assert: (transitions includes: t).
+ transitions remove: t
+! !
+
+!PEGFsaState methodsFor:'printing'!
+
+printNameOn: aStream
+ self name isNil
+ ifTrue: [ aStream print: self hash ]
+ ifFalse: [ aStream nextPutAll: self name ]
+!
+
+printOn: aStream
+ super printOn: aStream.
+ aStream nextPut: $(.
+ self printNameOn: aStream.
+ aStream nextPut: Character space.
+ aStream nextPutAll: self identityHash asString.
+ self isFinal ifTrue: [
+ aStream nextPutAll: ' FINAL'.
+ ].
+ aStream nextPut: (Character codePoint: 32).
+ aStream nextPutAll: priority asString.
+ aStream nextPut: $)
+! !
+
+!PEGFsaState methodsFor:'testing'!
+
+canHavePPCId
+ ^ true
+!
+
+hasEqualPriorityTo: state
+ "nil - nil"
+ (self hasPriority not and: [state hasPriority not]) ifTrue: [ ^ true ].
+
+ "nil - priority"
+ (self hasPriority) ifFalse: [ ^ false ].
+
+ "priority - nil"
+ state hasPriority ifFalse: [ ^ false ].
+
+ "priority - priority"
+ ^ self priority = state priority
+!
+
+hasHigherPriorityThan: state
+ "nil - nil"
+ (self hasPriority not and: [state hasPriority not]) ifTrue: [ ^ true ].
+
+ "nil - priority"
+ (self hasPriority) ifFalse: [ ^ false ].
+
+ "priority - nil"
+ state hasPriority ifFalse: [ ^ true ].
+
+ "priority - priority"
+ ^ self priority > state priority
+!
+
+hasPriority
+ ^ priority isNil not
+!
+
+isFailure
+ ^ self isFinal and: [ retval class == PEGFsaFailure ]
+!
+
+isFinal
+ final isNil ifTrue: [ ^ false ].
+
+ final ifTrue: [
+" self assert: self hasPriority. "
+ ^ true
+ ].
+
+ ^ false
+!
+
+isMultivalue
+ ^ multivalue
+! !
+
+!PEGFsaState methodsFor:'transformation'!
+
+determinize
+ ^ self determinize: Dictionary new.
+!
+
+determinize: dictionary
+ self transitionPairs do: [ :pair |
+ self assert: (pair first destination = pair second destination) not.
+ (pair first overlapsWith: pair second) ifTrue: [
+ self determinizeOverlap: pair first second: pair second joinDictionary: dictionary
+ ]
+ ].
+!
+
+determinizeOverlap: t1 second: t2 joinDictionary: dictionary
+ | pair t1Prime t2Prime tIntersection |
+ pair := PEGFsaPair with: t1 with: t2.
+
+ (dictionary includes: pair) ifTrue: [ self error: 'should not happen'.].
+ dictionary at: pair put: nil.
+
+ tIntersection := t1 join: t2 joinDictionary: dictionary.
+ t1Prime := PEGFsaTransition new
+ destination: t1 destination;
+ characterSet: (t1 complement: t2);
+ yourself.
+ t2Prime := PEGFsaTransition new
+ destination: t2 destination;
+ characterSet: (t2 complement: t1);
+ yourself.
+
+
+ self removeTransition: t1.
+ self removeTransition: t2.
+
+ tIntersection isEpsilon ifFalse: [ self addTransition: tIntersection ].
+ t1Prime isEpsilon ifFalse: [ self addTransition: t1Prime ].
+ t2Prime isEpsilon ifFalse: [ self addTransition: t2Prime ].
+
+ dictionary at: pair put: (Array
+ with: tIntersection
+ with: t1Prime
+ with: t2Prime
+ )
+!
+
+join: state
+ ^ self join: state joinDictionary: Dictionary new
+!
+
+join: state joinDictionary: dictionary
+ | pair newState |
+ pair := PEGFsaPair with: self with: state.
+ (dictionary includesKey: pair) ifTrue: [ ^ dictionary at: pair ].
+
+ newState := PEGFsaState new.
+
+ dictionary at: pair put: newState.
+
+ self joinFinal: state newState: newState.
+ self joinPriority: state newState: newState.
+ self joinRetval: state newState: newState.
+ self joinName: state newState: newState.
+
+ newState transitions addAll: (self transitions collect: #copy).
+ newState transitions addAll: (state transitions collect: #copy).
+ newState determinize: dictionary.
+
+ ^ dictionary at: pair put: newState
+!
+
+joinFinal: state newState: newState
+ (self hasEqualPriorityTo: state) ifTrue: [
+ ^ newState final: (self isFinal or: [ state isFinal ]).
+ ].
+
+ (self hasHigherPriorityThan: state) ifTrue: [
+ ^ newState final: self isFinal.
+ ].
+
+ newState final: state isFinal.
+
+!
+
+joinName: state newState: newState
+ newState name: self name asString, '-', state name asString.
+!
+
+joinPriority: state newState: newState
+ (self hasHigherPriorityThan: state) ifTrue: [
+ newState priority: self priority.
+ ^ self
+ ].
+
+ newState priority: state priority.
+!
+
+joinRetval: state newState: newState
+ self isFinal ifFalse: [ ^ newState retval: state retval ].
+ state isFinal ifFalse: [ ^ newState retval: self retval ].
+
+ (self priority = state priority) ifTrue: [
+ newState multivalue: true.
+ ^ newState retval: { self retval . state retval }.
+ ].
+
+ "Both are final"
+ self priority isNil ifTrue: [
+ ^ newState retval: state retval.
+ ].
+
+ state priority isNil ifTrue: [
+ ^ newState retval: self retval.
+ ].
+
+ (self priority > state priority) ifTrue: [
+ ^ newState retval: self retval.
+ ].
+
+ ^ newState retval: state retval.
+! !
+