"{ 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-Core'

!

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

!

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 crShow: 'Cleaning time: ',

    [	

"		self cleanGeneratedMethods: class.

        self cleanInstVars: class.

        self cleanConstants: class.

"	] timeToRun asMilliSeconds asString, 'ms'."

!

cleanConstants: class

    class constants removeAll.

!

cleanGeneratedMethods: class

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

        class methodsDo: [ :mthd |

                class removeSelector: mthd selector.

            ]

        ]

    ] ifFalse: [ 

    ]

!

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.

        "In case code hava a side effect"

    ]

!

codeClearError

    self add: 'self clearError.'.

!

codeError: errorMessage

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

!

codeHalt

    self add: 'self halt. '

!

codeHaltIfShiftPressed

    ]

!

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

   ].

!

codeReturn: code

    " - returns whatever is in code OR

      - assigns whatever is in code into the returnVariable"

   currentMethod isInline ifTrue:[ 

        self codeAssign: 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 codeAssign: (method call) to: aString.

    ]	

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

!

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 isEmpty or: [ toUse first isLetter not ])

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

!

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.

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

    ^ self pop.

!

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

!

copy: parser

    ^ parser transform: [ :p | p copy ].

!

installClassConstants

    constants keysAndValuesDo: [ :key :value |

        compiledParser constants at: key put: value

    ]

!

installMethods

    cache keysAndValuesDo: [ :key :method |

    ]

!

installVariables

    | varString |

    varString := constants keys inject: '' into: [:r :e | r, ' ', e  ].

    (self compiledParserSuperclass) 

        subclass: compiledParserName  

        instanceVariableNames: varString 

        classVariableNames: '' 

        poolDictionaries: '' 

        category: 'PetitCompiler-Generated'.

    compiledParser := Smalltalk at: compiledParserName.

! !

!PPCCompiler methodsFor:'initialization'!

initializeForCompiledClassName: aString

    self initialize.

    compilerStack := Stack new.

    cache := IdentityDictionary new.

    constants := IdentityDictionary new.

    ids := IdentityDictionary new.

    compiledParserName := aString asSymbol.

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

        | rPackageOrganizer |

        rPackageOrganizer := Smalltalk at: #RPackageOrganizer.

        rPackageOrganizer notNil ifTrue:[

            rPackageOrganizer default registerPackageNamed: 'PetitCompiler-Generated'.

        ].

    ] ifFalse: [ 

        RPackageOrganizer default registerPackageNamed: 'PetitCompiler-Generated'.