"{ 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:'private'!

withAllVariableNodesOf: anRBProgramNode do: aBlock

    "Enumerate all chilren of `anRBProgramNode` (including itself)

     and evaluate `aBlock` for each variable node.

     This is a replacement for Smalltalk/X's RBProgramNode>>variableNodesDo:

     which is not present in Pharo"

    anRBProgramNode isVariable ifTrue:[ 

        aBlock value: anRBProgramNode.

        ^ self.

    ].

    anRBProgramNode children do:[:each | 

        self withAllVariableNodesOf: each do: aBlock

    ].

    "Created: / 18-06-2015 / 22:02:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!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 blockNeedsCollection blockMatches childValueVars |

    blockNode := node block sourceNode copy.

    self assert: blockNode arguments size == 1.

    blockNodesVar := blockNode arguments first .

    blockBody := blockNode body.

    "Now, analyze block body, search for all references to

     block arg <barg> and check if in all cases it's used 

     in one of the following patterns:

        * <barg> first , <barg> second, ... , <barg> sixth

        * <barg> at: <integer constant>

     If so, then the block code can be inlined and the intermediate

     result collection need not to be created. Keep this information

     in temporary `blockNeedsCollection`. 

     During the analysis, remember all nodes that matches the pattern

     in a dictionary `blockMatches` mapping the node to actual temporary

     variable where the node is used. This will be later used for block's node

     rewriting"

    blockNeedsCollection := true.

    node child isSequenceNode ifTrue:[

        blockNeedsCollection := false.

        blockMatches := IdentityDictionary new."Must use IDENTITY dict as nodes have overwritten their #=!!!!!!"

        childValueVars := node child preferredChildrenVariableNames.

        self withAllVariableNodesOf: blockBody do:[:variableNode| 

            variableNode name = blockNodesVar name ifTrue:[ 

                "Check if variable node matches..."

                variableNode parent isMessage ifTrue:[ 

                    | parent |

                    parent := variableNode parent.

                    "Check for <barg> at: <number>"

                    ((parent selector == #at:) and:[ parent arguments first isLiteralNumber ]) ifTrue:[ 

                        blockMatches at: parent put: (childValueVars at: parent arguments first value).

                    ] ifFalse:[ 

                        "Check for <barg> first / second / ..."

                        | i |

                        i := #(first second third fourth fifth sixth) indexOf: parent selector.

                        i ~~ 0 ifTrue:[ 

                            blockMatches at: parent put: (childValueVars at: i).

                        ] ifFalse:[ 

                            blockNeedsCollection := true.

                        ].

                    ].

                ] ifFalse:[ 

                    blockNeedsCollection := true.

                ].

            ].

        ].

    ].

    blockNeedsCollection ifTrue:[

        "Bad, we have to use the collection.

         Replace all references to blockNodeVar to retvalVar..."

            variableNode name = blockNodesVar name ifTrue:[ 

            ].

        ].

    ] ifFalse:[ 

        "Good, can avoid intermediate collection.

         Replace references to collection with corresponding temporary variable"

        ].

        node child returnParsedObjectsAsCollection: false. 

    ].

    "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 codeIfErrorThen: [ 

        compiler codeReturn: 'failure'. 

    ] else: [

        compiler code: blockBody.    

    ]

!

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: '].'.