diff -r 46dd1237b20a -r 3b81c9e53352 compiler/PEGFsaState.st --- a/compiler/PEGFsaState.st Fri Jul 31 14:07:31 2015 +0100 +++ b/compiler/PEGFsaState.st Mon Aug 17 12:56:02 2015 +0100 @@ -3,7 +3,7 @@ "{ NameSpace: Smalltalk }" Object subclass:#PEGFsaState - instanceVariableNames:'name retval priority transitions final multivalue' + instanceVariableNames:'name infos transitions' classVariableNames:'' poolDictionaries:'' category:'PetitCompiler-FSA' @@ -17,6 +17,14 @@ ^ self basicNew initialize. ! ! +!PEGFsaState class methodsFor:'as yet unclassified'! + +named: aName + ^ self new + name: aName; + yourself +! ! + !PEGFsaState methodsFor:'accessing'! destination @@ -28,20 +36,42 @@ ^ (transitions collect: #destination) asIdentitySet ! +failure: boolean + self info failure: boolean +! + final - ^ final + ^ self info final ! -final: anObject - final := anObject +final: boolean + self info final: boolean +! + +infoFor: retval + ^ infos at: retval +! + +infoFor: retval ifAbsent: block + ^ infos at: retval ifAbsent: block +! + +isFsaFailure + ^ self isFinal and: [ self info isFsaFailure ] ! multivalue - ^ multivalue + + ^ self isMultivalue + + "Modified: / 17-08-2015 / 12:03:10 / Jan Vrany " ! multivalue: anObject - multivalue := anObject + self flag: 'JK: Obsolete?'. + "multivalue := anObject" + + "Modified: / 17-08-2015 / 12:03:39 / Jan Vrany " ! name @@ -52,16 +82,16 @@ name := anObject asString ! -prefix - ^ 'state' -! - priority - ^ priority + ^ self info priority ! priority: anObject - priority := anObject + self info priority: anObject +! + +priorityFor: retval + ^ (self infoFor: retval) priority ! priorityIfNone: value @@ -69,23 +99,31 @@ ! retval - ^ retval + self assert: self isMultivalue not. + ^ infos keys anyOne ! retval: anObject - retval := anObject + | info | + info := self info. + infos removeAll. + infos at: anObject put: info. ! retvalAsCollection - ^ self isMultivalue ifTrue: [ - self retval - ] ifFalse: [ - Array with: self retval - ] + ^ infos keys +! + +retvals + ^ infos keys ! -suffix - ^ '' +retvalsAndInfosDo: twoArgBlock + infos keysAndValuesDo: twoArgBlock +! + +stateInfos + ^ infos values ! transitions @@ -94,6 +132,35 @@ !PEGFsaState methodsFor:'analysis'! +collectNonEpsilonTransitionsOf: state to: collection + state transitions do: [ :t | + t isEpsilon ifTrue: [ + self collectNonEpsilonTransitionsOf: t destination to: collection + ] ifFalse: [ + collection add: t + ] + ]. + ^ collection +! + +nonEpsilonTransitionPairs + | size pairs collection | + pairs := OrderedCollection new. + + collection := OrderedCollection new. + self collectNonEpsilonTransitionsOf: self to: collection. + size := collection size. + + 1 to: (size - 1) do: [ :index1 | + (index1 + 1 to: size) do: [ :index2 | + pairs add: (PEGFsaPair + with: (collection at: index1) + with: (collection at: index2)). + ] + ]. + ^ pairs +! + reachableStates | openSet | openSet := IdentitySet new. @@ -117,16 +184,15 @@ transitionPairs | size pairs collection | size := transitions size. - pairs := OrderedCollection new: (size - 1) * size / 2. + pairs := OrderedCollection new. 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 add: (PEGFsaPair + with: (collection at: index1) + with: (collection at: index2)). ] ]. ^ pairs @@ -136,13 +202,14 @@ = anotherState (self == anotherState) ifTrue: [ ^ true ]. - (self class == anotherState class) ifFalse: [ ^ true ]. + (self class == anotherState class) ifFalse: [ ^ false ]. (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 ]. + + (self stateInfos size == anotherState stateInfos size) ifFalse: [ ^ false ]. + self retvals do: [:retval | + ((self infoFor: retval) = (anotherState infoFor: retval ifAbsent: [ ^ false ])) ifFalse: [ ^ false ] + ]. (transitions size = anotherState transitions size) ifFalse: [ ^ false ]. transitions do: [:t | @@ -154,25 +221,35 @@ 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 ]. + + (self stateInfos size == anotherState stateInfos size) ifFalse: [ ^ false ]. + self retvals do: [:retval | + ((self infoFor: retval) = (anotherState infoFor: retval ifAbsent: [ ^ false ])) ifFalse: [ ^ false ] + ]. ^ true ! equals: anotherState + self error: 'deprecated'. + " + JK: there is a bit mess between equals, isomorphic and = + + JK: I should clean it, but the idea behind is: + - for minimization, I use equals + - for comparing, I use canBeIsomorphicTo: (because it can handle nested structures) + - I have no idea, why I override = O:) + " + (self == anotherState) ifTrue: [ ^ true ]. - (anotherState class == PEGFsaState) ifFalse: [ ^ false ]. + (self class == anotherState class) 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 ]. + (self stateInfos size == anotherState stateInfos size) ifFalse: [ ^ false ]. + self retvals do: [:retval | + ((self infoFor: retval) equals: (anotherState infoFor: retval ifAbsent: [ ^ false ])) ifFalse: [ ^ false ] ]. (transitions size == anotherState transitions size) ifFalse: [ ^ false ]. @@ -184,22 +261,20 @@ ! 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)). + "JK: Size is not the best option here, but it one gets infinite loops otherwise" + ^ infos hash bitXor: transitions size hash ! isIsomorphicTo: anotherState resolvedSet: set + self error: 'depracated?'. (self == anotherState) ifTrue: [ ^ true ]. - (name == anotherState name) ifFalse: [ ^ false ]. +" (name == anotherState name) ifFalse: [ ^ false ]. (priority == anotherState priority) ifFalse: [ ^ false ]. - (multivalue == anotherState multivalue) ifFalse: [ ^ false ]. + (multivalue == anotherState isMultivalue) 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 ]. @@ -211,22 +286,60 @@ !PEGFsaState methodsFor:'copying'! postCopy + | newInfos | super postCopy. transitions := (transitions collect: [ :t | t copy ]). - retval := retval copy. + + newInfos := IdentityDictionary new. + infos keysAndValuesDo: [ :key :value | + newInfos at: key put: value copy + ]. + + infos := newInfos. ! ! !PEGFsaState methodsFor:'gt'! gtName - | gtName | - gtName := name. - + | gtStream | + gtStream := '' writeStream. + self printNameOn: gtStream. + self hasPriority ifTrue: [ - gtName := gtName asString, ',', self priority asString. + self retvalsAndInfosDo: [ :retval :info | + gtStream nextPut: (Character codePoint: 13). + gtStream nextPutAll: retval asString. + gtStream nextPutAll: '->'. + info printOn: gtStream. + ]. ]. - ^ gtName + ^ gtStream contents trim +! ! + +!PEGFsaState methodsFor:'ids'! + +defaultName + ^ #state +! + +hasName + ^ name isNil not +! + +prefix + ^ nil +! + +suffix + ^ nil +! ! + +!PEGFsaState methodsFor:'infos'! + +info + self assert: infos size = 1. + ^ infos anyOne ! ! !PEGFsaState methodsFor:'initialization'! @@ -235,22 +348,59 @@ super initialize. transitions := OrderedCollection new. - multivalue := false. + + infos := IdentityDictionary new. + infos at: nil put: PEGFsaStateInfo new. ! ! !PEGFsaState methodsFor:'modifications'! +addInfo: info for: retval + infos removeKey: nil ifAbsent: [ "not a big deal" ]. + infos at: retval put: info +! + addTransition: t self assert: (transitions identityIncludes: t) not. transitions add: t ! decreasePriority + self decreasePriorityBy: 1. +! + +decreasePriorityBy: value (self isFinal and: [ self hasPriority not ]) ifTrue: [ - priority := 0. + self error: 'Final States Should have priority!!' ]. - priority isNil ifFalse: [ - priority := priority - 1 + + self priority isNil ifFalse: [ + self priority: self priority - value + ] +! + +join: state + ^ self join: state joinDictionary: Dictionary new +! + +mergeInfo: state into: newState + self info merge: state info into: newState info. +! + +mergeTransitions + | toRemove | + toRemove := OrderedCollection new. + self transitionPairs do:[ :pair | + (pair first destination = pair second destination) ifTrue: [ + (pair first isPredicateTransition not and: [pair second isPredicateTransition not]) ifTrue: [ + pair first mergeWith: pair second. + toRemove add: pair second. + ] + ] + ]. + + toRemove do: [ :t | + self removeTransition: t ] ! @@ -259,6 +409,94 @@ transitions remove: t ! ! +!PEGFsaState methodsFor:'modifications - determinization'! + +determinize + ^ PEGFsaAbstractDeterminizator new determinizeState: self +! + +join: state joinDictionary: dictionary + | pair newState | + self error: 'deprecated'. + pair := PEGFsaPair with: self with: state. + (dictionary includesKey: pair) ifTrue: [ ^ dictionary at: pair ]. + + newState := PEGFsaState new. + + dictionary at: pair put: newState. + + self joinRetval: state into: newState. + self joinName: state into: newState. + self joinTransitions: state into: newState. + + newState determinize: dictionary. + + ^ dictionary at: pair put: newState +! + +joinInfo: state into: newState + self info join: state info into: newState info. +! + +joinName: state into: newState + newState name: self name asString, '_', state name asString. +! + +joinRetval: state into: newState + "Different retvals cannot merge their info" + (self hasDifferentRetvalThan: state) ifTrue: [ + newState addInfo: self info for: self retval. + newState addInfo: state info for: state retval. + ^ self + ]. + + + (self hasHigherPriorityThan: state) ifTrue: [ + newState retval: self retval + ]. + + (state hasHigherPriorityThan: self) ifTrue: [ + newState retval: state retval + ]. + + (state priority == self priority) ifTrue: [ + self hasRetval ifTrue: [newState retval: self retval]. + state hasRetval ifTrue: [newState retval: state retval]. + ]. + + self joinInfo: state into: newState. +! + +joinTransitions: state into: newState + newState isMultivalue ifTrue: [ + newState transitions addAll: (self transitions collect: #copy). + newState transitions addAll: (state transitions collect: #copy). + ^ self + ]. + + newState hasPriority ifFalse: [ + newState transitions addAll: (self transitions collect: #copy). + newState transitions addAll: (state transitions collect: #copy). + ^ self + ]. + + + self assert: newState hasPriority. + + "This is a part when low priority branches are cut" + (self priority == newState priority) ifTrue: [ + newState transitions addAll: (self transitions collect: #copy). + ] ifFalse: [ + newState transitions addAll: (self transitions select: [ :t | t priority > newState priority ] thenCollect: #copy) + ]. + + (state priority == newState priority) ifTrue: [ + newState transitions addAll: (state transitions collect: #copy). + ] ifFalse: [ + newState transitions addAll: (state transitions select: [ :t | t priority > newState priority ] thenCollect: #copy) + ]. +! ! + !PEGFsaState methodsFor:'printing'! printNameOn: aStream @@ -273,11 +511,14 @@ self printNameOn: aStream. aStream nextPut: Character space. aStream nextPutAll: self identityHash asString. - self isFinal ifTrue: [ - aStream nextPutAll: ' FINAL'. + + self retvalsAndInfosDo: [ :retval :info | + retval printOn: aStream. + aStream nextPutAll: '->'. + info printOn: aStream. + aStream nextPutAll: ';'. ]. - aStream nextPut: (Character codePoint: 32). - aStream nextPutAll: priority asString. + aStream nextPut: $) ! ! @@ -287,129 +528,58 @@ ^ true ! +hasDifferentRetvalThan: anotherState + "returns true only if both hav retval and both retvals are different" + self hasRetval ifFalse: [ ^ false ]. + anotherState hasRetval ifFalse: [ ^ false ]. + + "`retval value` is called in order to obtain retval from FsaFailure (if any)" + ^ (self retval value == anotherState retval value) not +! + 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 + ^ self info hasEqualPriorityTo: state info ! 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 + ^ self info hasHigherPriorityThan: state info ! hasPriority - ^ priority isNil not + ^ self stateInfos anySatisfy: [ :info | info hasPriority ] +! + +hasRetval + ^ self retval isNil not +! + +hasZeroPriorityOnly + ^ self stateInfos allSatisfy: [ :si | si hasPriority not or: [ si priority == 0 ] ]. ! isFailure + self error: 'Obsolete?'. + " ^ self isFinal and: [ retval class == PEGFsaFailure ] + " + + "Modified: / 17-08-2015 / 12:01:54 / Jan Vrany " ! isFinal - final isNil ifTrue: [ ^ false ]. - - final ifTrue: [ -" self assert: self hasPriority. " - ^ true - ]. - - ^ false + ^ self stateInfos anySatisfy: [ :info | info isFinal ]. ! isMultivalue - ^ multivalue + ^ infos size > 1 +! + +isStub + ^ false ! ! !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 ]).