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

"{ NameSpace: Smalltalk }"

Object subclass:#PPCCompiler
	instanceVariableNames:'compilerStack compiledParser cache currentMethod ids rootNode
		constants compiledParserName 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 
!

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
!

rootNode
	^ rootNode
! !

!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 = #generated ifTrue:[
				class removeSelector: mthd selector.
			]
		]
	] ifFalse: [ 
		(class allSelectorsInProtocol: #generated) do: [ :selector | 
			class removeSelectorSilently: selector ].
	]
!

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
	self flag: 'deprecated'.
	^ self smartRemember: parser to: #memento 
!

smartRemember: parser to: variableName
	parser isContextFree ifTrue: [ 
		^ variableName, ' := context lwRemember.'.
	].
	^ variableName, ':= context remember.'
!

smartRestore: parser
	self flag: 'deprecated'.
	^ self smartRestore: parser from: #memento 
!

smartRestore: parser from: mementoName
	parser isContextFree ifTrue: [ 
		^ 'context lwRestore: ', mementoName, '.'.
	].
	^ '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. '
!

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

!PPCCompiler methodsFor:'code generation - ids'!

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 := object name asLegalSelector.
			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
		]
	]
! !

!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
	(cache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ].

	currentMethod := PPCInlinedMethod new.
	currentMethod id: id.   
	currentMethod profile: arguments profile.
	currentMethod returnVariable: returnVariable.
	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: 'generated'.
	]
!

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

	PPCompiledParser 
		subclass: compiledParserName  
		instanceVariableNames: varString 
		classVariableNames: '' 
		poolDictionaries: '' 
		category: 'PetitCompiler-Generated'.

	compiledParser := Smalltalk at: compiledParserName.
!

precomputeFirstSets: root
	| firstSets |
	firstSets := root firstSets.
	
	root allNodesDo: [ :node |
		node firstSet: (firstSets at: node).
	]
	
!

precomputeFollowSets: root
	| followSets |
	followSets := root followSets.
	
	root allNodesDo: [ :node |
		node followSet: (followSets at: node).
	]
	
!

precomputeFollowSetsWithTokens: root
	| followSets |
	followSets := root followSetsSuchThat: [:e | e isTerminal or: [ e isKindOf: PPCTrimmingTokenNode ]].
	
	root allNodesDo: [ :node |
		node followSetWithTokens: (followSets at: node).
	]
	
!

toCompilerTree: parser
	^ parser asCompilerTree
! !

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

!PPCCompiler class methodsFor:'documentation'!

version_HG

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