"{ Package: 'stx:goodies/petitparser/compiler' }"

"{ NameSpace: Smalltalk }"

PPCNodeVisitor subclass:#PPCCodeGenerator
	instanceVariableNames:'compiler'
	classVariableNames:''
	poolDictionaries:''
	category:'PetitCompiler-Visitors'
!

!PPCCodeGenerator class methodsFor:'as yet unclassified'!

on: aPPCCompiler
	^ self new 
		compiler: aPPCCompiler;
		yourself
! !

!PPCCodeGenerator methodsFor:'accessing'!

compiler: aPPCCompiler
	compiler := aPPCCompiler 
! !

!PPCCodeGenerator methodsFor:'hooks'!

afterAccept: node retval: retval
	"return the method from compiler"
	^ self stopMethodForNode: node.
!

beforeAccept: node
	self startMethodForNode: node
!

closedDetected: node
	^ node isMarkedForInline ifFalse: [ 
		self error: 'Should not happen!!'
	]
!

openDetected: node
	^ compiler checkCache: (compiler idFor: node)
! !

!PPCCodeGenerator methodsFor:'support'!

addGuard: node
	|  guard firsts id |
	(arguments guards not or: [(guard := PPCGuard on: node) makesSense not]) ifTrue: [ ^ self].

	id := compiler idFor: node.
	firsts := (node firstSetSuchThat: [ :e | (e isKindOf: PPCTrimmingTokenNode) or: [ e isTerminal ] ]).

	
	(firsts allSatisfy: [ :e | e isKindOf: PPCTrimmingTokenNode ]) ifTrue: [  
		"If we start with trimming, we should invoke the whitespace parser"
		self compileTokenWhitespace: firsts anyOne.
		
		compiler add: 'context atEnd ifTrue: [ ^ self error ].'.
		guard id: id, '_guard'.
		guard compileGuard: compiler.
		compiler addOnLine: 'ifFalse: [ ^ self error ].'
	].

	(firsts allSatisfy: [ :e | e isTerminal ]) ifTrue: [  
		compiler add: 'context atEnd ifTrue: [ ^ self error ].'.
		guard id: id, '_guard'.
		guard compileGuard: compiler.
		compiler addOnLine: 'ifFalse: [ ^ self error ].'
	].
!

compileTokenWhitespace: node
	compiler add: 'context atWs ifFalse: ['.
	compiler indent.
		compiler call: (self visit: node whitespace).
		compiler add: 'context setWs.'.
	compiler dedent.
	compiler add: '].'.
!

notCharSetPredicateBody: node
	| classificationId  classification |
	self error: 'deprecated.'.
	classification := node extendClassification: node predicate classification.
	classificationId := (compiler idFor: classification prefixed: #classification).
	compiler  addConstant: classification as: classificationId.
	
	compiler addOnLine: '(', classificationId, ' at: context peek asInteger)'.
	compiler indent.
	compiler add: ' ifTrue: [ self error: '' predicate not expected'' ]'.
	compiler add: ' ifFalse: [ nil ].'.
	compiler dedent.
!

notMessagePredicateBody: node
	self error: 'deprecated'.
	compiler addOnLine: '(context peek ', node message, ')'.
	compiler indent.
	compiler add: ' ifTrue: [ self error: '' predicate not expected'' ]'.
	compiler add: ' ifFalse: [ nil ].'.
	compiler dedent.
!

predicateBody: node
	| tmpId |
	self error:'deprecated'.
	tmpId := (compiler idFor: node predicate prefixed: #predicate).
	compiler addConstant: node predicate as: tmpId.

	compiler addOnLine: '(context atEnd not and: [ ', tmpId , ' value: context uncheckedPeek])'.
	compiler indent.
	compiler add: 'ifFalse: [ self error: ''predicate not found'' ]'.
	compiler add: 'ifTrue: [ context next ].'.
	compiler dedent.	
!

retvalVar
	^ compiler currentReturnVariable 
!

startMethodForNode:node
    node isMarkedForInline ifTrue:[ 
		compiler startInline: (compiler idFor: node).
		compiler addComment: 'BEGIN inlined code of ' , node printString.
		compiler indent.
    ] ifFalse:[ 
		compiler startMethod: (compiler idFor: node).
		compiler addComment: 'GENERATED by ' , node printString.
		compiler allocateReturnVariable.
    ].

    "Created: / 23-04-2015 / 15:51:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 23-04-2015 / 19:13:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified (comment): / 23-04-2015 / 21:31:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

stopMethodForNode:aPPCNode
    ^ aPPCNode isMarkedForInline ifTrue:[ 
		compiler dedent.
		compiler add: '"END inlined code of ' , aPPCNode printString , '"'.
		compiler stopInline.
    ] ifFalse:[ 
		compiler stopMethod
    ].

    "Created: / 23-04-2015 / 15:51:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 23-04-2015 / 18:35:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!PPCCodeGenerator methodsFor:'traversing - caching'!

cache: node value: retval
	"this is compiler thing, not mine"
!

cachedDetected: node
	^ compiler checkCache: (compiler idFor: node)
!

isCached: node
	^ (compiler checkCache: (compiler idFor: node)) isNil not
! !

!PPCCodeGenerator methodsFor:'visiting'!

visitActionNode: node
	compiler addConstant: node block as: (compiler idFor: node).
        
	compiler addVariable: 'element'.
	compiler add: 'element := '.
	compiler callOnLine: (self visit: node child).
	compiler add: 'error ifFalse: [ ^ ',  (compiler idFor: node), ' value: element ].'.
	compiler add: '^ failure'.

    "Modified: / 23-04-2015 / 15:59:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

visitAndNode: node
	| mementoVar |
	
	mementoVar := compiler allocateTemporaryVariableNamed: 'memento'.
	compiler add: (compiler smartRemember: node child to: mementoVar).

	compiler codeStoreValueOf: [ self visit: node child  ] intoVariable: self retvalVar.
	compiler add: (compiler smartRestore: node child from: mementoVar).

	compiler codeReturn.

    "Modified: / 23-04-2015 / 15:59:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

visitAnyNode: node

	compiler codeReturn: 'context next ifNil: [ error := true. ].'.

    "Modified: / 23-04-2015 / 20:52:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

visitCharSetPredicateNode: node

	| classification classificationId |
	classification := node extendClassification: node predicate classification.
	classificationId := compiler idFor: classification prefixed: #classification.
	compiler addConstant: classification as: classificationId.
	
	compiler addOnLine: '(', classificationId, ' at: context peek asInteger)'.
	compiler indent.
	compiler add: 'ifFalse: [ self error: ''predicate not found'' ]'.
	compiler add: 'ifTrue: [ '.
	compiler codeReturn: 'context next'.
	compiler add: '].'.
	compiler dedent.
!

visitCharacterNode: node
	| chid |
	node character ppcPrintable ifTrue: [ 
		chid := node character storeString 
	] ifFalse: [ 
		chid := compiler idFor: node character prefixed: #char.
		compiler addConstant: (Character value: node character asInteger) as: chid .
	].
	
	compiler add: '(context peek == ', chid, ')'.
	compiler indent.
	compiler add: 'ifFalse: [ self error: ''', node character asInteger asString, ' expected'' at: context position ] '.
	compiler add: 'ifTrue: [ '.
	compiler codeReturn: 'context next'.
	compiler add: '].'.
	compiler dedent.
!

visitChild: child of: node
	|  |

	(self isOpen: child) ifTrue: [ 
		"already processing..."
		^ nil
	].

	"TODO JK: this is is wrong,.. to tired now to fix this :("
"	(self isCached: child) ifTrue: [ 
		node replace: child with: (self cachedValue: child).
		^ nil
	]. 
"
	^ self visit: child.
!

visitChoiceNode: node
	| firsts guard whitespaceConsumed |


	whitespaceConsumed := false.
	firsts := (node firstSetSuchThat: [ :e | (e isKindOf: PPCTrimmingTokenNode) or: [ e isTerminal ] ]).
        

	compiler addVariable: 'element'.
	"If we start with trimming token, we should invoke the whitespace parser"
	(firsts allSatisfy: [ :e | e isKindOf: PPCTrimmingTokenNode ]) ifTrue: [  
		self compileTokenWhitespace: firsts anyOne.
		whitespaceConsumed := true.
	].
        
	1 to: node children size do: [ :idx  | |child allowGuard |
		child := node children at: idx.
"               allowGuard := ((child isKindOf: PPCTrimmingTokenNode) and: [ whitespaceConsumed not ]) not.
"       
		allowGuard := whitespaceConsumed.
                                
		(allowGuard and: [arguments guards and: [ (guard := PPCGuard on: child) makesSense ]]) ifTrue: [         
			guard id: (compiler idFor: guard prefixed: #guard).
			guard compileGuard: compiler.
			compiler add: ' ifTrue: [ '.
			compiler indent.
				compiler add: 'self clearError.'.
				compiler codeStoreValueOf:  [self visit: child] intoVariable: 'element'.
				compiler add: 'error ifFalse: [ ^ element ].'.
			compiler dedent.
			compiler add: ' ].'.
		] ifFalse: [
			compiler add: 'self clearError.'.
			compiler codeStoreValueOf:  [self visit: child] intoVariable: 'element'.
			compiler add: 'error ifFalse: [ ^ element ].'.
		]
	].
	compiler add: '^ self error: ''no choice suitable'''.

    "Modified: / 23-04-2015 / 21:40:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

visitEndOfFileNode: node
	compiler codeReturn: 'context atEnd ifTrue: [ #EOF ] ifFalse: [ self error: ''EOF expected!!'' ].'.
!

visitForwardNode: node

	compiler codeStoreValueOf: [ self visit: node child ] intoVariable: self retvalVar.
	compiler codeReturn.
!

visitLiteralNode: node
	| positionVar encodedLiteral |
	encodedLiteral := node encodeQuotes: node literal.
	positionVar := compiler allocateTemporaryVariableNamed: 'position'.

	compiler codeAssign: 'context position.' to: positionVar.
	compiler add: '((context next: ', node literal size asString, ') = #''', encodedLiteral, ''') ifTrue: ['.
	compiler codeReturn: '#''', encodedLiteral, ''' '.
	compiler add: '] ifFalse: ['.
	compiler add: '  context position: ', positionVar, '.'.
	compiler add: '  self error: ''', encodedLiteral,  ' expected'' at: position'.
	compiler add: '].'.
!

visitMessagePredicateNode: node
	compiler add: '(context peek ', node message, ') ifFalse: ['.
	compiler add: '  self error: ''predicate not found'''.
	compiler add: '] ifTrue: [ '.
	compiler codeReturn: ' context next'.
	compiler add: '].'.

    "Modified: / 23-04-2015 / 18:39:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

visitNilNode: node

	compiler codeReturn: 'nil.'.
!

visitNotCharSetPredicateNode: node
	| classificationId  classification |
	classification := node extendClassification: node predicate classification.
	classificationId := (compiler idFor: classification prefixed: #classification).
	compiler  addConstant: classification as: classificationId.
	
	compiler addOnLine: '(', classificationId, ' at: context peek asInteger)'.
	compiler indent.
	compiler add: ' ifTrue: [ self error: '' predicate not expected'' ]'.
	compiler add: ' ifFalse: ['.
	compiler codeReturn: 'nil'.
	compiler add: '].'.
	compiler dedent.
!

visitNotLiteralNode: node
	| encodedLiteral size |
	encodedLiteral := node encodeQuotes: node literal.
	size := node literal size asString.
	
	compiler add: '((context peek: ', size, ') =#''', encodedLiteral, ''')'.
	compiler indent.
	compiler add: 'ifTrue: [ self error: ''', encodedLiteral, ' not expected'' ]'.
	compiler add: 'ifFalse: [ '.
	compiler codeReturn: 'nil' .
	compiler add: '].'.
	compiler dedent.
!

visitNotMessagePredicateNode: node
	compiler addOnLine: '(context peek ', node message, ')'.
	compiler indent.
	compiler add: ' ifTrue: [ '.
	compiler codeError: 'predicate not expected'.
	compiler add: '] ifFalse: ['.
	compiler codeReturn: 'nil'.
	compiler add: ' ].'.
	compiler dedent. 
!

visitNotNode: node


	compiler addVariable: 'memento'.
	compiler add: (compiler smartRemember: node child).
	
	compiler call: (self visit: node child).
	compiler add: (compiler smartRestore: node child).

	compiler add: '^ error ifFalse: [ self error ] ifTrue: [ self clearError. nil ]'.
!

visitOptionalNode: node
	compiler codeStoreValueOf: [ self visit: node child ] intoVariable: self retvalVar.
	compiler add: 'error ifTrue: [ '.
	compiler add: '  self clearError. '.
	compiler codeAssign: 'nil.' to: self retvalVar.
	compiler add: '].'.
	compiler codeReturn.
!

visitPluggableNode: node
	| blockId |
	blockId := compiler idFor: node block prefixed: #block.
	
	compiler addConstant: node block as: blockId.
	compiler codeReturn: blockId, ' value: context.'.
!

visitPlusNode: node
	| elementVar |
                
	elementVar := compiler allocateTemporaryVariableNamed:  'element'.
                
	compiler codeAssign: 'OrderedCollection new.' to: self retvalVar.
	compiler codeStoreValueOf: [ self visit: node child ] intoVariable: elementVar.

	compiler add: 'error ifTrue: [ self error: ''at least one occurence expected'' ] ifFalse: ['.
	compiler indent.
	    compiler add: self retvalVar , ' add: ',elementVar , '.'.
            
	    compiler codeStoreValueOf: [ self visit: node child ] intoVariable: elementVar.
	    compiler add: '[ error ] whileFalse: ['.
	    compiler indent.
	    compiler add: self retvalVar , ' add: ',elementVar , '.'.
	    compiler codeStoreValueOf: [ self visit: node child ] intoVariable: elementVar.
	    compiler dedent.
	    compiler add: '].'.
	    compiler add: 'self clearError.'.
	    compiler codeReturn: self retvalVar , ' asArray.'.         
	compiler dedent.
	compiler add: '].'.

    "Modified (comment): / 23-04-2015 / 21:30:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

visitPredicateNode: node
	| pid |
	pid := (compiler idFor: node predicate prefixed: #predicate).

	compiler addConstant: node predicate as: pid.

	compiler add: '(context atEnd not and: [ ', pid , ' value: context uncheckedPeek])'.
	compiler indent.
	compiler add: 'ifFalse: [ self error: ''predicate not found'' ]'.
	compiler add: 'ifTrue: [ ', self retvalVar ,' := context next ].'.
	compiler dedent.   
	compiler codeReturn.

    "Modified: / 23-04-2015 / 21:48:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

visitSequenceNode: node

	| elementVar mementoVar |

	elementVar := compiler allocateTemporaryVariableNamed: 'element'.
	mementoVar := compiler allocateTemporaryVariableNamed: 'memento'.

	compiler add: (compiler smartRemember: node to: mementoVar).
	compiler codeAssign: 'Array new: ', node children size asString, '.' to: self retvalVar.
	self addGuard: node.

	1 to: (node children size) do: [ :idx  | |child|
		child := node children at: idx.
		compiler codeStoreValueOf: [ self visit: child ]  intoVariable: elementVar.
        
		compiler add: 'error ifTrue: [ ', (compiler smartRestore: node) ,' ^ failure ].'.
		compiler add: self retvalVar , ' at: ', idx asString, ' put: ',elementVar,'.'.
	].
	compiler codeReturn

    "Modified: / 23-04-2015 / 22:03:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

visitStarAnyNode: node

	compiler addVariable: 'retval size'.
	compiler add: 'size := context size - context position.'.
	compiler add: 'retval := Array new: size.'.
	compiler add: '(1 to: size) do: [ :e | retval at: e put: context next ].'.
	compiler add: '^ retval'.
	
!

visitStarCharSetPredicateNode: node
	| classification classificationId |
	

	classification := node extendClassification: node predicate classification.
	classificationId := compiler idFor: classification prefixed: #classification.
	compiler addConstant: classification as: classificationId.
	
	compiler codeAssign: 'OrderedCollection new.' to: self retvalVar.	
	compiler add: '[ ', classificationId, ' at: context peek asInteger ] whileTrue: ['.
	compiler indent.
	compiler add: self retvalVar, ' add: context next.'.
	compiler dedent.
	compiler add: '].'.
   compiler codeReturn: 'retval asArray'.
!

visitStarMessagePredicateNode: node

	compiler codeAssign: 'OrderedCollection new.' to: self retvalVar.	
	compiler add: '[ context peek ', node message, ' ] whileTrue: ['.
	compiler indent.
	compiler add: self retvalVar, ' add: context next.'.
	compiler dedent.
	compiler add: '].'.
   compiler codeReturn: 'retval asArray'.
!

visitStarNode: node
	| elementVar |
	
	elementVar := compiler allocateTemporaryVariableNamed: 'element'.

	compiler codeAssign: 'OrderedCollection new.' to: self retvalVar.
	compiler codeStoreValueOf: [ self visit: node child ] intoVariable: elementVar.
	compiler add: '[ error ] whileFalse: ['.
	compiler indent.
	compiler add: self retvalVar, ' add: element.'.
	compiler codeStoreValueOf: [ self visit: node child ] intoVariable: elementVar.
	compiler dedent.
	compiler add: '].'.
	compiler codeClearError.
	compiler codeReturn: self retvalVar, ' asArray'.
!

visitSymbolActionNode: node
	| elementVar |
	
	elementVar := compiler allocateTemporaryVariableNamed: 'element'.	
	compiler codeStoreValueOf: [ self visit: node child ] intoVariable: elementVar.
	compiler add: 'error ifFalse: [ '.
	compiler codeReturn: elementVar, ' ', node block asString, '.'.
	compiler add: '] ifTrue: ['.
	compiler codeReturn: 'failure'.
	compiler add: ']'.
!

visitTokenActionNode: node
	"
		Actually, do nothing, we are in Token mode and the 
		child does not return any result and token takes only
		the input value.
	"	

	compiler add: '^ '.
	compiler callOnLine: (node child compileWith: compiler).
!

visitTokenNode: node
	| startVar endVar |
	startVar := compiler allocateTemporaryVariableNamed: 'start'.
	endVar := compiler allocateTemporaryVariableNamed: 'end'.
	
	compiler codeAssign: 'context position + 1.' to: startVar.
	compiler codeStoreValueOf: [ self visit: node child ] intoVariable: #whatever.
	compiler add: 'error ifFalse: [ '.
	compiler indent.	
	compiler codeAssign: 'context position.' to: endVar.
	
	compiler codeReturn: node tokenClass asString, ' on: (context collection) 
																start: ', startVar, '  
																stop: ', endVar, '
																value: nil.'.
	compiler dedent.
	compiler add: '].'.
!

visitTokenSequenceNode: node


	compiler addVariable: 'memento'.			
	compiler add: (compiler smartRemember: node).

"	self addGuard: compiler."

		compiler codeStoreValueOf: [ self visit: (node children at: 1) ] intoVariable: #whatever.
	compiler add: 'error ifTrue: [ ^ failure ].'.

	2 to: (node children size) do: [ :idx  | |child|
		child := node children at: idx.
		compiler codeStoreValueOf: [ self visit: child ] intoVariable: #whatever.
		compiler add: 'error ifTrue: [ ', (compiler smartRestore: node) ,' ^ failure ].'.
	].
!

visitTokenStarMessagePredicateNode: node

	compiler add: '[ context peek ', node message,' ] whileTrue: ['.
	compiler indent.
	compiler add: 'context next'.
	compiler indent.
	compiler dedent.
	compiler add: '].'.
!

visitTokenStarSeparatorNode: node

	compiler add: 'context skipSeparators.'.
!

visitTrimNode: node
	| mementoVar |
	"TODO: This ignores the TrimmingParser trimmer object!!"

	mementoVar := compiler allocateTemporaryVariableNamed:  'memento'.

	compiler add: (compiler smartRemember: node child to: mementoVar).
	compiler add: 'context skipSeparators.'.

	compiler codeStoreValueOf: [ self visit: node child ] intoVariable: self retvalVar.
	
	compiler add: 'error ifTrue: [ '.
	compiler indent.
		compiler add: (compiler smartRestore: node child from: mementoVar).
		compiler codeReturn.
	compiler dedent.
	compiler add: '] ifFalse: ['	.
		compiler indent.
		compiler add: 'context skipSeparators.'.
		compiler codeReturn.
		compiler dedent.
	compiler add: '].'.
!

visitTrimmingTokenNode: node
	|  id guard startVar endVar |

	startVar := compiler allocateTemporaryVariableNamed: 'start'.
	endVar := compiler allocateTemporaryVariableNamed:  'end'.
	
	id := compiler idFor: node.
"	(id beginsWith: 'kw') ifTrue: [ self halt. ]."
	"self compileFirstWhitespace: compiler."
	self compileTokenWhitespace: node.

	(arguments guards and: [(guard := PPCGuard on: node) makesSense]) ifTrue: [ 
		compiler add: 'context atEnd ifTrue: [ ^ self error ].'.
		guard id: id, '_guard'.
		guard compileGuard: compiler.
		compiler addOnLine: 'ifFalse: [ ^ self error ].'
	].

	compiler codeAssign: 'context position + 1.' to: startVar.
	compiler codeStoreValueOf: [ self visit: node child ] intoVariable: #whatever.
	compiler add: 'error ifFalse: [ '.
	compiler indent.	
	compiler codeAssign: 'context position.' to: endVar.
	
"	self compileSecondWhitespace: compiler."
	self compileTokenWhitespace: node.

	compiler codeReturn: node tokenClass asString, ' on: (context collection) 
																start: ', startVar, ' 
																stop: ', endVar, '
																value: nil'.
	compiler dedent.																
	compiler add: '].'
!

visitUnknownNode: node
	| compiledChild compiledParser id |

	id := compiler idFor: node.
	
	compiledParser := node parser copy.
	"Compile all the children and call compiled version of them instead of the original one"
	compiledParser children do: [ :child | 
		compiledChild := self visit: child.
		compiledParser replace: child with: compiledChild bridge.
	].
	
	compiler addConstant: compiledParser as: id. 
	
	compiler codeClearError.
	compiler add: '(', self retvalVar, ' := ', id, ' parseOn: context) isPetitFailure'.
	compiler indent.
	compiler add: ' ifTrue: [self error: retval message at: ', self retvalVar, ' position ].'.
	compiler dedent.
	compiler add: 'error := ', self retvalVar, ' isPetitFailure.'.
	compiler codeReturn.
! !