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

"{ NameSpace: Smalltalk }"

PPCNodeVisitor subclass:#PPCTokenCodeGenerator
	instanceVariableNames:'compiler scannerGenerator fsaCache'
	classVariableNames:''
	poolDictionaries:''
	category:'PetitCompiler-Visitors'
!

!PPCTokenCodeGenerator methodsFor:'accessing'!

arguments: args
    super arguments: args.
    scannerGenerator arguments: args
!

compiler
    ^ compiler
!

compiler: anObject
    compiler := anObject.
    
    scannerGenerator compiler idGen: compiler idGen.
! !

!PPCTokenCodeGenerator methodsFor:'code support'!

consumeWhitespace: node
    self assert: node isTokenNode.

    node isTrimmingTokenNode ifTrue: [ 
        compiler code: 'self consumeWhitespace.'
    ]
!

createTokenInsance: node id: idCode start: startVar end: endVar
    compiler codeTranscriptShow: 'current token type: ', idCode.
    compiler codeAssign: idCode, '.' to: 'currentTokenType'.
    compiler codeAssign: node tokenClass asString, ' on: (context collection) 
                                                            start: ', startVar, ' 
                                                            stop: ', endVar, '
                                                            value: nil.'
               to: 'currentTokenValue'.
!

scan: node start: startVar end: endVar
    node child hasName ifFalse: [ 
        node child name: node name
    ].

    compiler codeAssign: 'context position + 1.' to: startVar.
    compiler add: ((self generateScan: node child) callOn: 'scanner').
!

unorderedChoiceFromFollowSet: followSet
    | followFsas  |
    
    ^ fsaCache at: followSet ifAbsentPut: [ 
        followFsas := followSet collect: [ :followNode | 
                (followNode asFsa) 
                    name: (compiler idFor: followNode);
                    retval: (compiler idFor: followNode); 
                    yourself
        ].
        self unorderedChoiceFromFsas: followFsas.
    ]
     
!

unorderedChoiceFromFsas: fsas
    | result startState |
    result := PEGFsa new.
    startState := PEGFsaState new.
    
    result addState: startState.
    result startState: startState.

    fsas do: [ :fsa | 
        result adopt: fsa.
        result addTransitionFrom: startState to: fsa startState.
    ].

    result determinizeStandard.
    ^ result
! !

!PPCTokenCodeGenerator methodsFor:'compiling support'!

compileScanner
    ^ scannerGenerator compileScannerClass
!

retvalVar
    ^ compiler currentReturnVariable
!

startMethodForNode:node
    node isMarkedForInline ifTrue:[ 
        compiler startInline: (compiler idFor: node).
        compiler codeComment: 'BEGIN inlined code of ' , node printString.
        compiler indent.
    ] ifFalse:[ 
        compiler startMethod: (compiler idFor: node).
        compiler currentMethod category: 'generated - tokens'.
        compiler codeComment: 'GENERATED by ' , node printString.
        compiler allocateReturnVariable.
    ]
!

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

!PPCTokenCodeGenerator methodsFor:'initialization'!

initialize
    super initialize.
    
    scannerGenerator := PPCScannerCodeGenerator new.
    scannerGenerator arguments: arguments.
    
    "for the given set of nodes, remember the unordered choice fsa
        see `unorderedChoiceFromFollowSet:`
    "
    fsaCache := Dictionary new.
! !

!PPCTokenCodeGenerator methodsFor:'scanning'!

generateNextScan: node
    | epsilon followSet  anFsa |
    followSet := node followSetWithTokens.
    
    epsilon := followSet anySatisfy: [ :e | e acceptsEpsilon ].
    followSet := followSet reject: [ :e | e acceptsEpsilon ].
    epsilon ifTrue: [ followSet add: PPCEndOfFileNode instance ].
    
    anFsa := self unorderedChoiceFromFollowSet: followSet.

    anFsa name: 'nextToken_', (compiler idFor: node).
    node nextFsa: anFsa.
    ^ scannerGenerator generate: anFsa.
!

generateScan: node
    | anFsa |
    anFsa := node asFsa determinize.
    anFsa name: (compiler idFor: node).
    anFsa retval: (compiler idFor: node).
    
    ^ scannerGenerator generate: anFsa.
! !

!PPCTokenCodeGenerator methodsFor:'visiting'!

visitToken: tokenNode
    |  id  startVar endVar  numberId |
    self startMethodForNode: tokenNode.

    "Tokens cannot be inlined, 
        - their result is true/false
        - the return value is always stored in currentTokenValue
        - the current token type is always stored in currentTokenType
    "
    self assert: tokenNode isMarkedForInline not.
    
    startVar := compiler allocateTemporaryVariableNamed: 'start'.
    endVar := compiler allocateTemporaryVariableNamed:  'end'.
    
    id := compiler idFor: tokenNode.
    numberId := compiler numberIdFor: id.
    
    compiler add: 'currentTokenType isNil ifFalse: [ ^ currentTokenType == ', id storeString, '].'.
    
"	compiler codeComment: 'number for: ', id storeString, ' is: ', numberId storeString.
    compiler codeIf: 'scanner match: ', numberId storeString then: [ 
        compiler codeAssign: '(scanner resultPosition: ', numberId storeString, ').' to: endVar.
        self createTokenInsance: tokenNode 
                id: id storeString 
                start: '(context position + 1)' 
                end: endVar.
        
        compiler code: 'context position: ', endVar, '.'.
        
        self consumeWhitespace: tokenNode.
        compiler codeReturn: 'true'.
    ].
    compiler codeIf: 'scanner backtracked not' then: [ 
        compiler codeReturn: 'false'.
    ].
    compiler codeComment: 'No match, no fail, scanner does not know about this...'.	
"
    compiler profileTokenRead: id.
    
"	self scan: tokenNode start: startVar end: endVar."
    "	compiler add: 'self assert: scanner isSingleMatch.'."
"	compiler codeIf: 'scanner match ' then: ["

    tokenNode child hasName ifFalse: [ 
        tokenNode child name: tokenNode name
    ].

    compiler codeAssign: 'context position + 1.' to: startVar.
    compiler codeIf: [ compiler code: ((self generateScan: tokenNode child) callOn: 'scanner') ] then: [ 
        compiler add: 'context position: scanner resultPosition.'.
        compiler codeAssign: 'context position.' to: endVar.	
        self consumeWhitespace: tokenNode.
        self createTokenInsance: tokenNode id: id storeString start: startVar end: endVar.
        compiler codeReturn: 'true'.
    ] else: [ 
        compiler code: 'scanner backtrackDistinct.'.
        compiler code: 'context position: ', startVar, ' - 1.'. 
        compiler codeReturn: 'false'.
    ].
    
    ^ self stopMethodForNode: tokenNode
!

visitTokenConsumeNode: node
    | id   nextScan |
    self startMethodForNode: node.
    id := (compiler idFor: node child).

    compiler add: 'self ', id asString, ' ifTrue: ['.
        compiler indent.

        nextScan := self generateNextScan: node.
        
        node nextFsa hasDistinctRetvals ifTrue: [ 
            compiler codeAssign: 'currentTokenValue.' to: self retvalVar.
        
            compiler add: (nextScan callOn: 'scanner'), '.'.
            compiler codeIf: 'scanner match' then: [ 
            compiler add: 'context position: scanner resultPosition.'.
                self createTokenInsance: node child 
                        id: 'scanner result' 
                        start: 'scanner position + 1' 
                        end: 'scanner resultPosition'.
                self consumeWhitespace: node child.
                compiler codeReturn.
            ] else: [ 
                compiler codeComment: 'Looks like there is an error on its way...'.
                compiler code: 'context position: scanner position.'.
                compiler codeAssign: 'nil.' to: 'currentTokenType'.
                compiler codeReturn.
            ]

        ] ifFalse: [ 
            compiler codeAssign: 'nil.' to: 'currentTokenType'.
            compiler codeReturn: 'currentTokenValue'.
        ].
        compiler dedent.

    "Token not found"
    compiler add: '] ifFalse: ['.
        compiler indent.
        compiler codeError: id asString, ' expected'.
        compiler dedent.
    compiler add: '].'.

    ^ self stopMethodForNode: node
!

visitTokenNode: node
    ^ self visitToken: node
!

visitTrimmingTokenCharacterNode: node
    |  id     |
    self startMethodForNode:node.

    "Tokens cannot be inlined, 
        - their result is true/false
        - the return value is always stored in currentTokenValue
        - the current token type is always stored in currentTokenType
    "
    self assert: node isMarkedForInline not.
    
    id := compiler idFor: node.
    
    compiler add: 'currentTokenType isNil ifFalse: [ ^ currentTokenType == ', id storeString, '].'.
    compiler profileTokenRead: id.

    compiler add: '(context peek == ', node child character storeString, ') ifFalse: [ ^ false ].'.
    compiler add: 'context next.'.

    self createTokenInsance: node id: id storeString  start: 'context position' end: 'context position'.
    self consumeWhitespace: node.
    
    compiler codeReturn: 'true'.

    ^ self stopMethodForNode: node
!

visitTrimmingTokenNode: node
    ^ self visitToken: node
! !