"{ 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 firstSetWithTokens.

    
    (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
    | blockId |

    blockId := 'block_', (compiler idFor: node).
    compiler addConstant: node block as: blockId.
        
    compiler codeStoreValueOf: [ self visit: node child ] intoVariable: self retvalVar.
    compiler add: 'error ifFalse: ['.
    compiler codeReturn: blockId, ' value: ', self retvalVar.
    compiler add: '] ifTrue: ['.
    compiler codeReturn: 'failure'.
    compiler add: '].'.

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

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

    compiler codeStoreValueOf: [ self visit: node child  ] intoVariable: self retvalVar.
    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 add: '(', 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 elementVar |
    "The code is not ready for inlining"
    self assert: node isMarkedForInline not.
    
    whitespaceConsumed := false.
    firsts := node firstSetWithTokens.
        

    elementVar := compiler allocateTemporaryVariableNamed: 'element'.
    "	
        If we want to compile in guard and the choice starts with trimming token, 
        we should invoke the whitespace parser
    "
    (arguments guards and: [ firsts allSatisfy: [ :e | e isTrimmingTokenNode ] ]) ifTrue: [  
        self compileTokenWhitespace: firsts anyOne.
        whitespaceConsumed := true.
    ].
        
    1 to: node children size do: [ :idx  | |child allowGuard |
        child := node children at: idx.
        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: elementVar.
                compiler add: 'error ifFalse: [ ^ element ].'.
            compiler dedent.
            compiler add: ' ].'.
        ] ifFalse: [
            compiler add: 'self clearError.'.
            compiler codeStoreValueOf:  [self visit: child] intoVariable: elementVar.
            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!!'' ].'.
!

visitEndOfInputNode: node

    compiler codeStoreValueOf: [ self visit: node child ] intoVariable: self retvalVar.
    compiler add: 'context atEnd ifTrue: ['.
    compiler codeReturn.	
    compiler add: '] ifFalse: ['.
    compiler codeError: 'End of input expected'.
    compiler add: ']'.
!

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
    | mementoVar |

    mementoVar := compiler allocateTemporaryVariableNamed: 'memento'.
    compiler smartRemember: node child to: mementoVar.
    
    compiler codeStoreValueOf: [ self visit: node child  ] intoVariable: #whatever.
    compiler smartRestore: node child from: mementoVar.

    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>"
!

visitRecognizingSequenceNode: node
    | mementoVar |

    mementoVar := compiler allocateTemporaryVariableNamed: 'memento'.			
    compiler smartRemember: node to: mementoVar.

"	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 indent.
        compiler smartRestore: node from: mementoVar.
        compiler add: ' ^ failure .'.
        compiler dedent.
        compiler add: '].'.
    ].
!

visitSequenceNode: node

    | elementVar mementoVar |

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

    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 indent.
        compiler smartRestore: node from: mementoVar.
        compiler add: '^ failure.'.
        compiler dedent.
        compiler add: '].'.
        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: ', elementVar, '.'.
    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: '].'.
!

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.'.
!

visitTokenWhitespaceNode: node
    compiler codeStoreValueOf: [ self visit: node child ] intoVariable: #whatever.
    compiler codeReturn.
!

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

    mementoVar := compiler allocateTemporaryVariableNamed:  'memento'.

    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 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: [ 
        guard id: id, '_guard'.
        compiler add: 'context atEnd ifTrue: [ self error ].'.
        guard compileGuard: compiler.
        compiler addOnLine: 'ifFalse: [ self error ].'.
        compiler add: 'error ifFalse: ['.
        compiler indent.
    ].

    compiler codeAssign: 'context position + 1.' to: startVar.
    compiler codeStoreValueOf: [ self visit: node child ] intoVariable: #whatever.

    (arguments guards and: [(guard := PPCGuard on: node) makesSense]) ifTrue: [ 
        compiler dedent.
        compiler add: '].'.
    ].

    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.
! !