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

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 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 |
            (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.
 		] ifTrue: [ 
        "In case code hava a side effect"
 				self add: code	
    ]
!

codeClearError
    self add: 'self clearError.'.
!

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

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 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 := 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.
            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.
    
    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
!

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

installClassConstants
    constants keysAndValuesDo: [ :key :value |
        compiledParser constants at: key put: value
    ]
!

installMethods
    cache keysAndValuesDo: [ :key :method |
        compiledParser compileSilently: method code classified: method category.
    ]
!

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

    Smalltalk at: compiledParserName ifPresent: [ :class |
        compiledParser := class.
        self clean: compiledParser.
    ].


    Transcript cr; show: 'intialized for: ', aString; cr.
! !

!PPCCompiler class methodsFor:'documentation'!

version_HG

    ^ '$Changeset: <not expanded> $'
! !