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

"{ NameSpace: Smalltalk }"

PPCNodeVisitor subclass:#PPCCodeGenerator

	instanceVariableNames:'compiler'

	classVariableNames:''

	poolDictionaries:''

	category:'PetitCompiler-Visitors'

!

!PPCCodeGenerator class methodsFor:'as yet unclassified'!

new

    ^ self basicNew

        initialize;

        yourself 

!

on: aPPCCompiler

    ^ self new 

        compiler: aPPCCompiler;

        yourself

! !

!PPCCodeGenerator methodsFor:'accessing'!

compiler: aPPCCompiler

    compiler := aPPCCompiler 

!

guards

    ^ arguments guards

! !

!PPCCodeGenerator methodsFor:'guards'!

addGuard: node ifTrue: trueBlock ifFalse: falseBlock

    |  guard id |

    (self guards not or: [(guard := PPCGuard on: node) makesSense not]) ifTrue: [ ^ false].

    id := compiler idFor: node.

"	falseBlock isNil ifFalse: [ 

        compiler add: 'context atEnd'.

        compiler addOnLine: ' ifTrue: ['.

        compiler indent.

        falseBlock value.

        compiler dedent.

        compiler addOnLine: '].'.

    ]."

    guard id: (compiler idFor: guard prefixed: #guard).

    guard compileGuard: compiler.

    trueBlock isNil ifFalse: [ 

        compiler addOnLine: ' ifTrue: ['.

        compiler indent.

        trueBlock value.

        compiler dedent.

        falseBlock isNil 	ifTrue: [ compiler addOnLine: '].' ]

                              	ifFalse: [ compiler add: ']'. ]

    ].

    falseBlock isNil ifFalse: [ 

        compiler addOnLine: ' ifFalse: ['.

        compiler indent.

        falseBlock value.

        compiler dedent.

        compiler addOnLine: '].'.

    ].

    ^ true

!

addGuardTrimming: node

    |  guard firsts id |

    (self guards not or: [(guard := PPCGuard on: node) makesSense not]) ifTrue: [ ^ false].

    id := compiler idFor: node.

    firsts := node firstSetWithTokens.

    (firsts allSatisfy: [ :e | e isTrimmingTokenNode ]) ifTrue: [  

        "If we start with trimming, we should invoke the whitespace parser"

        self compileTokenWhitespace: firsts anyOne.

        ^ true

    ].

    ^ false

! !

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

compileTokenWhitespace: node

    compiler add: 'context atWs ifFalse: ['.

    compiler indent.

        compiler 

              codeAssignParsedValueOf:[ self visit:node whitespace ]

              to:#whatever.

        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

    "Modified: / 15-06-2015 / 18:20:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

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 (format): / 15-06-2015 / 18:03:07 / 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

    | blockNode blockBody blockNodesVar |

    blockNode := node block ast copy.

    self assert: blockNode arguments size == 1.

    blockNodesVar := blockNode arguments first .

    blockBody := blockNode body.

    "Replace all references to blockNodeVar to retvalVar..."

    blockBody variableNodesDo:[:variableNode| 

        variableNode name = blockNodesVar name ifTrue:[ 

            variableNode token value: self retvalVar.

        ].

    ].

    "Block return value is return value of last statement.

     So if the method is not inline, make last statement a return.

        if the method is inline, make it assignment to retvalVar."

    blockBody statements notEmpty ifTrue:["Care for empty blocks - [:t | ] !!"

        compiler currentMethod isInline ifTrue:[ 

            |  assignment |

            assignment := RBAssignmentNode variable: (RBVariableNode named: self retvalVar) value:  blockBody statements last.

            blockBody replaceNode: blockBody statements last withNode: assignment.

        ] ifFalse:[  

            | return |

            return := RBReturnNode value: blockBody statements last.

            blockBody replaceNode: blockBody statements last withNode: return.

        ].

    ].

    compiler 

          codeAssignParsedValueOf:[ self visit:node child ]

          to:self retvalVar.

    compiler codeIf: 'error' then: [ 

        compiler codeReturn: 'failure'. 

    ] else: [

        compiler code: blockBody.    

    ]

    "Modified: / 15-06-2015 / 17:08:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

visitAndNode: node

    | mementoVar |

    mementoVar := compiler allocateTemporaryVariableNamed: 'memento'.

    compiler smartRemember: node child to: mementoVar.

    compiler 

          codeAssignParsedValueOf:[ self visit:node child ]

          to: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: ['.

    compiler codeError: '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: ['.

    compiler indent.

    compiler codeError: node character asInteger asString, ' expected'.

    compiler dedent.

    compiler add: '] ifTrue: [ '.

    compiler indent.

    compiler codeReturn: 'context next'.

    compiler dedent.

    compiler add: '].'.

    compiler dedent.

!

visitChild: child of: node

    |  |

    (self isOpen: child) ifTrue: [ 

        "already processing..."

        ^ nil

    ].

    ^ self visit: child.

!

visitChoiceNode: node

    |  whitespaceConsumed allowGuard elementVar coding |

    elementVar := compiler allocateTemporaryVariableNamed: 'element'.

    whitespaceConsumed := self addGuardTrimming: node.

    allowGuard := whitespaceConsumed.

    allowGuard ifTrue:[

        coding := 

            [ :children :index |

                self addGuard: (children at: index) ifTrue: [ 

                    compiler add: 'self clearError.'.

                    compiler 

                          codeAssignParsedValueOf:[ self visit:(children at:index) ]

                          to:elementVar.

                    compiler add: 'error ifFalse: [ '.

                    compiler codeReturn: elementVar.  

                    compiler add: ' ].'.

                ] ifFalse:[ 

                    compiler add: 'error := true.'.

                ].

                compiler add: 'error ifTrue:[ '.

                index < children size ifTrue:[ 

                    coding value: children value: index + 1.

                ] ifFalse:[ 

                    compiler codeError: 'no choice suitable'.

                ].

                compiler add: '] '.

        ]

    ] ifFalse:[ 

        coding := 

            [ :children :index |

                index <= children size ifTrue:[ 

                    compiler add: 'self clearError.'.

                    compiler 

                          codeAssignParsedValueOf:[ self visit:(children at:index) ]

                          to:elementVar.

                    compiler add: 'error ifFalse: [ '.

                    compiler codeReturn: elementVar.  

                    compiler add: ' ].'.

                    coding value: children value: index + 1.

                ] ifFalse:[ 

                    compiler codeError: 'no choice suitable'.

                ].

            ]

    ].

    coding value: node children value: 1.

    "Modified: / 29-05-2015 / 07:17:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

visitEndOfFileNode: node

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

!

visitEndOfInputNode: node

    compiler 

          codeAssignParsedValueOf:[ self visit:node child ]

          to:self retvalVar.

    compiler add: 'context atEnd ifTrue: ['.

    compiler codeReturn.        

    compiler add: '] ifFalse: ['.

    compiler codeError: 'End of input expected'.

    compiler add: '].'.

    "Modified: / 26-05-2015 / 19:03:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

visitForwardNode: node

    compiler 

          codeAssignParsedValueOf:[ self visit:node child ]

          to: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 indent.

        compiler add: 'context position: ', positionVar, '.'.

        compiler codeError: encodedLiteral,  ' expected' at: positionVar.

    compiler dedent.

    compiler add: '].'.

!

visitMappedActionNode: node

    | child blockNode blockBody |

    child := node child.

    blockNode := node block ast copy.

    blockBody := blockNode body.

    "Block return value is return value of last statement.

     So if the method is not inline, make last statement a return.

        if the method is inline, make it assignment to retvalVar."

    compiler currentMethod isInline ifTrue:[ 

        |  assignment |

        assignment := RBAssignmentNode variable: (RBVariableNode named: self retvalVar) value:  blockBody statements last.

        blockBody replaceNode: blockBody statements last withNode: assignment.

    ] ifFalse:[  

        | return |

        return := RBReturnNode value: blockBody statements last.

        blockBody replaceNode: blockBody statements last withNode: return.

    ].

    child isSequenceNode ifTrue:[  

        child isMarkedForInline ifTrue:[ 

            child preferredChildrenVariableNames: blockNode argumentNames.

            child returnParsedObjectsAsCollection: false.

        ].

    ] ifFalse:[ 

        "Child is not a sequence so it 'returns' only one object.

         Therefore the block takes only one argument and it's value

         is value of child's retval.

         In the block, replace all references to block argument to

         my retvalVar. "

        | blockArg |

        blockArg := blockNode arguments first.

        blockBody variableNodesDo:[:variableNode| 

            variableNode name = blockArg name ifTrue:[ 

                variableNode token value: self retvalVar.

            ].

        ]. 

    ].

    compiler codeAssignParsedValueOf: [ self visit: child ] to: self retvalVar.

    compiler codeIf: 'error' then: [ 

        compiler codeReturn: 'failure'. 

    ] else: [

        "If the child is sequence and not inlined, extract

         nodes from returned collection into used-to-be block variables"

        (child isSequenceNode and:[ child returnParsedObjectsAsCollection ]) ifTrue:[

            blockNode arguments withIndexDo:[ :arg :idx |

                node child isMarkedForInline ifFalse:[ 

                    compiler allocateTemporaryVariableNamed: arg name.

                    compiler codeAssign: (self retvalVar , ' at: ', idx printString) to: arg name.

                ].

                compiler addOnLine: '.'; nl.

            ].

        ].

        compiler code: blockBody.    

    ]

    "Created: / 02-06-2015 / 17:28:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 15-06-2015 / 19:03:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

visitMessagePredicateNode: node

    compiler add: '(context peek ', node message, ') ifFalse: ['.

    compiler codeError: '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>"

!