"{ Package: 'stx:goodies/smaCC' }"

"{ NameSpace: SmaCC }"

Object subclass:#SmaCCNode
	instanceVariableNames:'transitions action id'
	classVariableNames:'NextId'
	poolDictionaries:''
	category:'SmaCC-Scanner Generator'
!

SmaCCNode comment:'SmaCCNode is a node in a directed graph.

Instance Variables:
	action	<SequenceableCollection>	a collection of integers or a symbol. This contains the action to be performed when we match and can''t find a longer match.
	id	<Integer>	a unique number that allows us to sort the nodes
	transitions	<Collection of: SmaCCEdge>	our transitions

'
!


!SmaCCNode class methodsFor:'instance creation'!

new
	^(super new)
		initialize;
		yourself
! !

!SmaCCNode class methodsFor:'class initialization'!

initialize
	NextId := 0
! !

!SmaCCNode methodsFor:'compiling'!

asStatement: methodMap usingSelectorMap: aDictionary forClass: aClass 
	| stream |
	stream := WriteStream on: (String new: 128).
	self hasSimpleLoop ifTrue: [stream nextPut: $[].
	self writeMatchingCodeOn: stream usingSelectorMap: aDictionary.
	(self sortedTransitionsFor: aClass) do: 
			[:each | 
			each to == self 
				ifTrue: 
					[stream
						nextPutAll: each expression;
						nextPut: $];
						nextPutAll: ' whileTrue.';
						cr]
				ifFalse: 
					[stream
						nextPutAll: each expression;
						nextPutAll: ' ifTrue: ['.
					stream
						nextPutAll: (methodMap at: each to
									ifAbsentPut: 
										[each to 
											asStatement: methodMap
											usingSelectorMap: aDictionary
											forClass: aClass]);
						nextPutAll: '].';
						cr]].
	(transitions notEmpty or: [action isNil]) 
		ifTrue: 
			[stream
				nextPutAll: '^self reportLastMatch';
				cr].
	^stream contents
!

compileInto: aClass usingSelectorMap: aDictionary 
	| methodNodes methodMap index |
	methodNodes := self statesToMakeIntoMethods.
	methodMap := self methodNameMapFor: methodNodes.
	index := 0.
	methodNodes do: 
			[:each | 
			| stream |
			stream := WriteStream on: (String new: 1000).
			stream
				nextPutAll: (each == self 
							ifTrue: ['scanForToken']
							ifFalse: ['scan' , (index := index + 1) printString]);
				cr.
			stream nextPutAll: (each 
						asStatement: methodMap
						usingSelectorMap: aDictionary
						forClass: aClass).
			aClass 
				compile: (self optimizedParseTreeFor: stream contents) formattedCode
				classified: #'generated-scanner']
!

methodNameMapFor: methodNodes 
	| index methodMap |
	methodMap := IdentityDictionary new.
	index := 0.
	methodNodes do: 
			[:value | 
			methodMap at: value
				put: (value == self 
						ifTrue: ['^self scanForToken']
						ifFalse: ['^self scan' , (index := index + 1) printString])].
	^methodMap
!

needsSeparateMethod
	^self allStates size > 20
!

optimizationRewriter
	| rewriter |
	rewriter := ParseTreeRewriter new.
	rewriter
		replace: 'Core.Character' with: 'Character';
		replace: '`@.Stmts1.
				[`@.Stmts2.
				currentCharacter ~~ `#l] whileTrue.
				currentCharacter == `#l ifTrue: [`@.Stmts3].
				`@.Stmts4'
			with: '`@.Stmts1.
				[`@.Stmts2.
				currentCharacter ~~ `#l] whileTrue.
				`@.Stmts3';
		replaceMethod: '`name
							`@.Stmts1.
							`@a ifTrue: [`@.Stmts2.
									^self `name].
							`@.Stmts3'
			with: '`name
				[`@.Stmts1.
				`@a] whileTrue: [`@.Stmts2].
				`@.Stmts3';
		replace: '`@.Stmts1.
				currentCharacter isLiteral ifTrue: [`@.Stmts2].
				`@.Stmts3'
			with: '`@.Stmts1.
				`@.Stmts2';
"		replace: '``@.Stmts1.
				(`@a ifTrue: [``@.Stmts2]) `{:node :dictionary | | index myStatements |
						index := node parent statements indexOf: node.
						myStatements := node parent statements.
						dictionary at: #size put: ``@.Stmts2 size - (myStatements size - index).
						index ~~  myStatements size and: [``@.Stmts2 size >= (myStatements size - index) and: [
							(index + 1 to: myStatements size) allSatisfy: [:each | 
								(myStatements at: each) = (``@.Stmts2 at: ``@.Stmts2 size - (myStatements size - each))]]]
						}.
				``@.Stmts3'
			with: '``@.Stmts1.
				`{:dictionary | RBMessageNode receiver: `@a selector: #ifTrue: arguments: (Array with: (RBBlockNode body: (RBSequenceNode statements: (``@.Stmts2 copyFrom: 1 to: (dictionary at: #size)))))}.
				``@.Stmts3';"
		replace: '`@.Stmts1.
				`.Stmt.
				`@.Stmts.
				`@a ifTrue: [self step. `.Stmt. `@.Stmts].
				`@.Stmts2'
			with: '`@.Stmts1.
				`@a ifTrue: [self step].
				`.Stmt.
				`@.Stmts.
				`@.Stmts2'.
	^rewriter
!

optimizedParseTreeFor: aString 
	| tree rewriter |
	tree := RBParser parseMethod: aString.
	rewriter := self optimizationRewriter.
	[rewriter executeTree: tree] whileTrue: [tree := rewriter tree].
	^tree
!

sortedTransitionsFor: aClass
	| frequencies |
	frequencies := (aClass realClass ifNil: [SmaCCScanner]) frequencyTable.
	^transitions asSortedCollection: 
			[:a :b | 
			| aFrequency bFrequency |
			aFrequency := a characters inject: 0
						into: [:sum :each | sum + (frequencies at: each asInteger \\ frequencies size + 1)].
			bFrequency := b characters inject: 0
						into: [:sum :each | sum + (frequencies at: each asInteger \\ frequencies size + 1)].
			aFrequency > bFrequency 
				or: [aFrequency = bFrequency and: [a characters first < b characters first]]]
!

statesToMakeIntoMethods
	| allStates incoming |
	allStates := self allStates.
	incoming := Dictionary new.
	allStates do: 
			[:each | 
			each transitions do: 
					[:edge | 
					each ~~ edge to 
						ifTrue: [(incoming at: edge to ifAbsentPut: [Set new]) add: each]]].
	^(allStates asOrderedCollection select: 
			[:each | 
			self == each or: 
					[each isTerminalNode not and: 
							[(incoming at: each ifAbsent: [#()]) size > 1 
								or: [each needsSeparateMethod]]]]) 
		asSortedCollection: [:a :b | a id < b id]
!

writeMatchingCodeOn: aStream usingSelectorMap: aDictionary 
	| matchedItem |
	action size > 0 
		ifTrue: 
			[matchedItem := aDictionary at: action first ifAbsent: [action asArray].
			aStream nextPutAll: (transitions isEmpty 
						ifTrue: ['^self recordAndReportMatch:']
						ifFalse: ['self recordMatch: ']).
			matchedItem isSymbol 
				ifTrue: [aStream nextPutAll: matchedItem storeString]
				ifFalse: 
					[aStream nextPutAll: '#('.
					matchedItem do: [:each | aStream nextPutAll: each storeString]
						separatedBy: [aStream nextPut: $ ].
					aStream nextPut: $)].
			aStream
				nextPut: $.;
				cr].
	transitions notEmpty 
		ifTrue: 
			[aStream
				nextPutAll: 'self step.';
				cr]
! !

!SmaCCNode methodsFor:'converting'!

asDFA
	self asDFA: IdentitySet new merged: Dictionary new.
	self removeDuplicateNodes.
	^self
! !

!SmaCCNode methodsFor:'edges'!

addEdgeTo: endNode 
	transitions add: (SmaCCEdge to: endNode on: nil)
!

addEdgeTo: endNode on: characterCollection 
	transitions add: (SmaCCEdge to: endNode on: characterCollection)
! !

!SmaCCNode methodsFor:'initialize-release'!

action: anObject 
	anObject isNil ifTrue: [^self].
	action := anObject isSymbol 
				ifTrue: [anObject]
				ifFalse: [SortedCollection with: anObject]
!

initialize
	id := NextId := NextId + 1.
	transitions := SortedCollection new
! !

!SmaCCNode methodsFor:'printing'!

printOn: aStream 
	aStream
		nextPutAll: self class name;
		nextPut: $(;
		nextPutAll: id printString;
		nextPut: $)
! !

!SmaCCNode methodsFor:'private'!

action
	^action
!

addActions: aCollection 
	aCollection isNil ifTrue: [^self].
	action isNil 
		ifTrue: 
			[action := aCollection copy.
			^self].
	action isSymbol ifTrue: [^self].
	aCollection isSymbol ifTrue: [^action := aCollection].
	aCollection 
		do: [:each | (action includes: each) ifFalse: [action add: each]]
!

allCharacterTransitions: aSet into: aNode 
	| index each |
	(aSet includes: self) ifTrue: [^#()].
	aSet add: self.
	aNode addActions: action.
	index := 1.
	[index <= transitions size] whileTrue: 
			[each := transitions at: index.
			index := index + 1.
			each isEpsilonTransition 
				ifTrue: [each to allCharacterTransitions: aSet into: aNode]
				ifFalse: 
					[(aNode transitions includes: each) ifFalse: [aNode transitions add: each]]]
!

allCharacterTransitionsAndActionsInto: aNode 
	| seen |
	seen := IdentitySet new.
	self allCharacterTransitions: seen into: aNode
!

allStates
	| nodes |
	nodes := Set new.
	self allStatesInto: nodes.
	^nodes
!

allStatesInto: aSet 
	(aSet includes: self) ifTrue: [^self].
	aSet add: self.
	transitions do: [:each | each to allStatesInto: aSet]
!

asDFA: aSet merged: aDictionary 
	| newTransitions |
	(aSet includes: self) ifTrue: [^self].
	aSet add: self.
	newTransitions := OrderedCollection new: transitions size.
	transitions do: 
			[:each | 
			| existingEdges new |
			new := each copy.
			existingEdges := newTransitions select: [:edge | edge conflictsWith: each].
			existingEdges do: 
					[:existing | 
					| node newChars existingChars chars |
					node := aDictionary 
								at: (SortedCollection with: existing to id with: new to id) asArray
								ifAbsentPut: 
									[node := self class new.
									node transitions: ((Set 
												withAll: (existing to transitions collect: [:edge | edge copy]))
												addAll: (new to transitions collect: [:edge | edge copy]);
												yourself).
									node mergeCharacterTransitions.
									node addActions: existing to action.
									node addActions: new to action.
									node].
					newChars := new characters.
					chars := newChars select: [:char | existing includesCharacter: char].
					chars notEmpty 
						ifTrue: [newTransitions addFirst: (SmaCCEdge to: node on: chars)].
					existingChars := existing characters.
					existing removeCharacters: newChars.
					new removeCharacters: existingChars.
					existing isEmpty ifTrue: [newTransitions remove: existing]].
			new isEmpty ifFalse: [newTransitions add: new]].
	transitions := newTransitions.
	transitions do: [:each | each to asDFA: aSet merged: aDictionary]
!

asNFAWithoutEpsilonTransitions
	| seen node |
	node := self class new.
	self allCharacterTransitionsAndActionsInto: node.
	seen := IdentitySet new.
	node asNFAWithoutEpsilonTransitions: seen.
	seen := IdentitySet new.
	node removeEpsilonTransitions: seen.
	node cleanUp.
	^node
!

asNFAWithoutEpsilonTransitions: aSet 
	| index each |
	(aSet includes: self) ifTrue: [^self].
	aSet add: self.
	index := 1.
	[index <= transitions size] whileTrue: 
			[each := transitions at: index.
			index := index + 1.
			each isEpsilonTransition 
				ifTrue: [each to allCharacterTransitionsAndActionsInto: self]
				ifFalse: [each to asNFAWithoutEpsilonTransitions: aSet]]
!

cleanUp
	self removeDuplicateNodes.
	self mergeAllTransitions
!

id
	^id
!

mergeAllTransitions
	| nodes |
	nodes := self allStates.
	nodes do: [:each | each mergeCharacterTransitions]
!

mergeCharacterTransitions
	| toMap |
	toMap := IdentityDictionary new.
	transitions copy do: 
			[:each | 
			(toMap includesKey: each to) 
				ifTrue: 
					[(toMap at: each to) mergeWith: each.
					transitions removeIdentical: (transitions detect:[:e|e = each])
					]
				ifFalse: [toMap at: each to put: each]]
!

removeDuplicateEdges
	transitions := transitions asSet asSortedCollection
!

removeDuplicateNodes
	| nodes |
	
	[nodes := self allStates.
	nodes do: 
			[:each | 
			each
				mergeCharacterTransitions;
				removeDuplicateEdges].
	self removeDuplicateNodes: nodes] 
			whileTrue
!

removeDuplicateNodes: aCollection 
	| merged nodePartition |
	merged := false.
	nodePartition := Dictionary new.
	aCollection do: 
			[:each | 
			(nodePartition at: (Array with: each transitions size with: each action)
				ifAbsentPut: [OrderedCollection new]) add: each].
	nodePartition do: 
			[:each | 
			| seen |
			seen := OrderedCollection new.
			each do: 
					[:node | 
					| existingNode |
					existingNode := seen 
								detect: [:otherNode | otherNode transitionsMatch: node]
								ifNone: [nil].
					existingNode isNil 
						ifTrue: [seen add: node]
						ifFalse: 
							[merged := true.
							node oneWayBecome: existingNode]]].
	^merged
!

removeEpsilonTransitions: aSet 
	(aSet includes: self) ifTrue: [^self].
	aSet add: self.
	transitions copy 
		do: [:each | each isEpsilonTransition ifTrue: [transitions remove: each]].
	transitions do: [:each | each to removeEpsilonTransitions: aSet]
!

transitions
	^transitions
!

transitions: aCollection 
	transitions := aCollection asSortedCollection
!

transitionsMatch: aNode 
	^aNode transitions allSatisfy: 
			[:each | 
			(transitions includes: each) or: 
					[each to = aNode and: 
							[each characters 
								= (transitions detect: [:edge | edge to = self] ifNone: [^false]) 
										characters]]]
! !

!SmaCCNode methodsFor:'public'!

hasSimpleLoop
	^transitions anySatisfy: [:each | each to == self]
!

isTerminalNode
	^transitions isEmpty or: [transitions size = 1 and: [self hasSimpleLoop]]
!

simulate: aStream 
	| char |
	aStream atEnd ifTrue: [^action].
	char := aStream next.
	transitions 
		do: [:each | (each characters includes: char) ifTrue: [^each to simulate: aStream]].
	^action
! !

!SmaCCNode class methodsFor:'documentation'!

version
    ^ '$Header: /opt/data/cvs/stx/goodies/smaCC/SmaCC__SmaCCNode.st,v 1.1 2006-02-09 21:17:46 vranyj1 Exp $'
!

version_SVN
    ^ '$Id$'
! !

SmaCCNode initialize!