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

!

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> $'

! !