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

"{ NameSpace: Smalltalk }"

Object subclass:#PPCCompiler

	instanceVariableNames:'compilerStack compiledParser cache currentMethod ids constants

		compiledParserName compiledParserSuperclass returnVariable

		arguments'

	classVariableNames:''

	poolDictionaries:''

	category:'PetitCompiler-Compiler'

!

!PPCCompiler class methodsFor:'instance creation'!

new

    "return an initialized instance"

    ^ self basicNew initializeForCompiledClassName: 'PPGeneratedParser'

!

newForCompiledClassName: aString

    "return an initialized instance"

	self halt: 'deprecated'.

    ^ self basicNew initializeForCompiledClassName: aString

!

on: aPPCArguments

    "return an initialized instance"

    ^ self basicNew

		arguments: aPPCArguments;

		initializeForCompiledClassName: aPPCArguments name

! !

!PPCCompiler methodsFor:'accessing'!

arguments: args

    arguments := args

!

compiledParser

    ^ compiledParser 

!

compiledParserSuperclass

    ^ compiledParserSuperclass ifNil: [ PPCompiledParser ]

!

currentMethod

    ^ currentMethod 

!

currentNonInlineMethod

    ^ compilerStack 

        detect:[:m | m isInline not ] 

        ifNone:[ self error: 'No non-inlined method']

    "Created: / 23-04-2015 / 17:33:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

currentReturnVariable

    ^ currentMethod returnVariable 

!

ids

    ^ ids

! !

!PPCCompiler methodsFor:'cleaning'!

clean: class

"	Transcript show: ('Cleaning time: ',

    [	

"		self cleanGeneratedMethods: class.

        self cleanInstVars: class.

        self cleanConstants: class.

"	] timeToRun asMilliSeconds asString, 'ms'); cr. "

!

cleanConstants: class

    class constants removeAll.

!

cleanGeneratedMethods: class

    ((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[

        class methodsDo: [ :mthd |

            (mthd category beginsWith: 'generated') ifTrue:[

                class removeSelector: mthd selector.

            ]

        ]

    ] ifFalse: [ 

        (class allProtocolsUpTo: class) do: [ :protocol |

            (protocol beginsWith: 'generated') ifTrue: [ 

                class removeProtocol: protocol.

            ]

        ]

    ]

!

cleanInstVars: class

    class class instanceVariableNames: ''.

!

cleanParsers: class

    class parsers removeAll.

! !

!PPCCompiler methodsFor:'code generation'!

add: string

    currentMethod add: string.

!

addComment: string

    currentMethod add: '"', string, '"'.

!

addConstant: value as: name

    constants at: name put: value

!

addOnLine: string

    currentMethod addOnLine: string.

!

addVariable: name

    ^ self currentNonInlineMethod addVariable: name

    "Modified: / 23-04-2015 / 17:34:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

call: anotherMethod

    currentMethod add: anotherMethod call.

!

callOnLine: anotherMethod

    currentMethod addOnLine: anotherMethod call.

!

dedent

    currentMethod dedent

!

indent

    currentMethod indent

!

nl

    currentMethod nl

!

smartRemember: parser to: variableName 

    parser isContextFree ifTrue: [ 

        self 	codeAssign: 'context lwRemember.' 

                to: variableName.

    ] ifFalse: [ 

        self  codeAssign: 'context remember.'

                to: variableName.

    ]

!

smartRestore: parser from: mementoName

    parser isContextFree ifTrue: [ 

        self add: 'context lwRestore: ', mementoName, '.'.

    ] ifFalse: [ 

        self add: 'context restore: ', mementoName, '.'.

    ]

! !

!PPCCompiler methodsFor:'code generation - coding'!

codeAssign: code to: variable

    self assert: variable isNil not.

    "TODO JK: Hack alert, whatever is magic constant!!"

    (variable == #whatever) ifFalse: [ 

        "Do not assign, if somebody does not care!!"

        self add: variable ,' := ', code.

    ]

!

codeClearError

    self add: 'self clearError.'.

!

codeError

    self add: 'self error: ''message notspecified''.'.

!

codeError: errorMessage

    self add: 'self error: ''', errorMessage, '''.'

!

codeError: errorMessage at: position

    self add: 'self error: ''', errorMessage, ''' at: ', position asString, '.'

!

codeEvaluate: selector argument: argument on: variable

    self assert: variable isNil not.

    "TODO JK: Hack alert, whatever is magic constant!!"

    (variable == #whatever) ifFalse: [ 

        "Do not assign, if somebody does not care!!"

        self add: variable, ' ', selector,' ', argument.

 	] ifTrue: [ 

        "In case argument has a side effect"

 		self add: argument	

    ]

!

codeEvaluateAndAssign: argument to: variable

    self assert: variable isNil not.

    "TODO JK: Hack alert, whatever is magic constant!!"

    (variable == #whatever) ifFalse: [ 

        "Do not assign, if somebody does not care!!"

        self add: variable ,' := ', argument.

    ] ifTrue: [ 

        "In case an argument has a side effect"

 		self add: argument.	

    ]

!

codeHalt

    self add: 'self halt. '

!

codeHaltIfShiftPressed

    arguments debug ifTrue: [

        ((Smalltalk respondsTo: #isSmalltalkX) and:[Smalltalk isSmalltalkX]) ifFalse:[  

            self add: 'Halt ifShiftPressed.'

        ]

    ]

    "Modified: / 10-05-2015 / 07:39:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

codeNextToken

    self add: 'self nextToken.'

    "Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"

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

!

codeReturn

   currentMethod isInline ifTrue: [

				"If inlined, the return variable already holds the value"

		] ifFalse: [

				self add: '^ ', currentMethod returnVariable  

   ].

	"Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"

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

!

codeReturn: code

    " - returns whatever is in code OR

      - assigns whatever is in code into the returnVariable"

   currentMethod isInline ifTrue:[ 

        self codeEvaluateAndAssign: code to: currentMethod returnVariable. 

   ] ifFalse: [ 

        self add: '^ ', code 		

    ]

    "Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"

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

!

codeStoreValueOf: aBlock intoVariable: aString

    | tmpVarirable method |

    self assert: aBlock isBlock.

    self assert: aString isNil not.

    tmpVarirable := returnVariable.

    returnVariable := aString.

    method := [  

        aBlock value 

    ] ensure: [ 

        returnVariable := tmpVarirable 

    ].

    method isInline ifTrue: [ 

        self callOnLine: method 

    ] ifFalse: [ 

        self codeEvaluateAndAssign: (method call) to: aString.

    ]	

    "Created: / 23-04-2015 / 18:21:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

codeTokenGuard: node ifFalse: codeBlock

    | guard id |

    guard := PPCTokenGuard on: node.

    (guard makesSense) ifTrue: [ 

        id := self idFor: guard firstToken.

        self add: 'self ', id asString, ' ifFalse: ['.

            self indent.

            codeBlock value.

            self dedent.

        self add: '].'.

    ]

!

codeTranscriptShow: text

    (arguments profile) ifTrue: [ 

        self add: 'Transcript show: ', text storeString, '; cr.'.

    ]

! !

!PPCCompiler methodsFor:'code generation - ids'!

asSelector: string

    "e.g. '234znak 43 ) 2' asLegalSelector = #v234znak432"

    | toUse |

    toUse := string select: [:char | char isAlphaNumeric or: [ char = $_ ] ].

    (toUse isEmpty or: [ toUse first isLetter not ])

        ifTrue: [ toUse := 'v', toUse ].

    toUse first isUppercase ifFalse:[

        toUse := toUse copy.

        toUse at: 1 put: toUse first asLowercase

    ].

    ^toUse

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

!

idFor: object

    self assert: (object isKindOf: PPCNode).

    ^ self idFor: object prefixed: object prefix suffixed: object suffix effect: #none

!

idFor: object prefixed: prefix

    ^ self idFor: object prefixed: prefix effect: #none

!

idFor: object prefixed: prefix effect: effect

    ^ self idFor: object prefixed: prefix suffixed: '' effect: effect.

!

idFor: object prefixed: prefix suffixed: suffix effect: effect

    | name id |

    ^ ids at: object ifAbsentPut: [ 

        ((object isKindOf: PPCNode) and: [object name isNotNil]) ifTrue: [ 

            "Do not use prefix, if there is a name"

            name := self asSelector: (object name asString).

            id := (name, suffix) asSymbol.

            "Make sure, that the generated ID is uniqe!!"

            (ids includes: id) ifTrue: [ 

                (id, '_', ids size asString) asSymbol 

            ] ifFalse: [ 

                id

            ]

        ] ifFalse: [ 

            (prefix, '_', (ids size asString), suffix) asSymbol

        ]

    ]

!

idFor: object suffixed: suffix

    self assert: (object isKindOf: PPCNode) description: 'Shold use PPCNode for ids'.

    ^ self idFor: object prefixed: object prefix suffixed: suffix effect: #none

! !

!PPCCompiler methodsFor:'code generation - profiling'!

profileTokenRead: tokenName

    arguments profile ifTrue: [ 

        self add: 'context tokenRead: ', tokenName storeString, '.'

    ]

! !

!PPCCompiler methodsFor:'code generation - support'!

cache: id as: value

    cache at: id put: value.

!

cachedValue: id

    ^ cache at: id ifAbsent: [ nil ]

!

checkCache: id

    | method  |

    "Check if method is hand written"

    method := compiledParser ifNotNil: [ compiledParser compiledMethodAt: id ifAbsent: [ nil ] ].

    method ifNotNil: [ ^ PPCCompiledMethod new id: id; yourself ].

    ^ self cachedValue: id

!

pop

    | retval |

    retval := compilerStack pop.

    currentMethod := compilerStack isEmpty 

        ifTrue: [ nil ]

        ifFalse: [ compilerStack top ].

    ^ retval

    "Modified: / 21-11-2014 / 12:27:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

push

    compilerStack push: currentMethod.

    (compilerStack size > 500 )ifTrue: [ self error: 'unless it is very complex grammar, there is an error somewhere' ]

    "Modified: / 21-11-2014 / 12:27:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

startInline: id

    | indentationLevel |

    (cache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ].

    indentationLevel := currentMethod indentationLevel.

    currentMethod := PPCInlinedMethod new.

    currentMethod id: id.   

    currentMethod profile: arguments profile.

    currentMethod returnVariable: returnVariable.

    currentMethod indentationLevel: indentationLevel.

    self push.

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

!

startMethod: id

    (cache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ].

    currentMethod := PPCMethod new.

    currentMethod id: id.

    currentMethod profile: arguments profile.    

    self push.      

    self cache: id as: currentMethod.

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

!

stopInline

    ^ self pop.

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

!

stopMethod

    self cache: currentMethod methodName as: currentMethod.

    "arguments profile ifTrue: [ Transcript show: currentMethod code; cr. ]."

    ^ self pop.

    "Modified: / 01-05-2015 / 14:18:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

top

    ^ compilerStack top

! !

!PPCCompiler methodsFor:'code generation - variables'!

allocateReturnVariable

    "Return a new variable to store parsed value"

   ^ currentMethod allocateReturnVariable 

    "Created: / 23-04-2015 / 17:58:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"

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

!

allocateTemporaryVariableNamed: preferredName 

    "Allocate a new variable with (preferably) given name.

     Returns a real variable name that should be used."

    ^ self currentNonInlineMethod allocateTemporaryVariableNamed: preferredName

    "Created: / 23-04-2015 / 17:33:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!PPCCompiler methodsFor:'compiling'!

compileParser

    self installVariables.

    self installMethods.

    self installClassConstants.

    ^ compiledParser