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

Object subclass:#PPCCompiler
	instanceVariableNames:'compilerStack compiledParser cache inlining debug profile
		currentMethod lastMethod guards ids updateContextMethod tokenMode'
	classVariableNames:''
	poolDictionaries:''
	category:'PetitCompiler-Core'
!

PPCCompiler comment:''
!

!PPCCompiler methodsFor:'accessing'!

fastMode
	^ tokenMode
!

inlining
	^ inlining
!

inlining: value
	inlining := value
!

lastMethod
	^ lastMethod 
!

parameters: associations
	| key value |
	associations do: [ :ass |
		key := ass key.
		value := ass value.
		
		(key = #profile) ifTrue: [ profile := value ].
		(key = #inline) ifTrue: [ inlining := value ].
		(key = #guards) ifTrue: [ guards := value ].
	]
!

profile
	^ profile
!

profile: aBoolean
	profile := aBoolean 
!

startInline: id
	self push.
	
	currentMethod := PPCInlinedMethod new.
	currentMethod id: id.	
	currentMethod profile: self profile.
! !

!PPCCompiler methodsFor:'cleaning'!

clean: class
"	Transcript crShow: 'Cleaning time: ',
	[	
"		self cleanGeneratedMethods: class.
		self cleanInstVars: class.
		self cleanParsers: class.
		self cleanConstants: class.
"	] timeToRun asMilliSeconds asString, 'ms'."
!

cleanConstants: class
	class constants removeAll.
!

cleanGeneratedMethods: class
	(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.
!

addConstant: value as: name
	compiledParser addConstant: value as: name.
!

addOnLine: string
	currentMethod addOnLine: string.
!

addVariable: name
	currentMethod addVariable: name.
!

allowInline
	currentMethod allowInline
!

cache: id as: value
	cache at: id put: value.
!

cachedValue: id
	^ cache at: id ifAbsent: [ nil ]
!

call: anotherMethod
	currentMethod add: anotherMethod call.
!

callOnLine: anotherMethod
	currentMethod addOnLine: anotherMethod call.
!

checkCache: id
	| method value |
	"Check if method is already compiled/hand written"
	method := compiledParser compiledMethodAt: id ifAbsent: [ nil ].
	method ifNotNil: [ ^ lastMethod := PPCCompiledMethod new id: id; yourself ].
	
	^ (value := self cachedValue: id) ifNotNil: [ lastMethod := value ].
!

dedent
	currentMethod dedent
!

indent
	currentMethod indent
!

nl
	currentMethod nl
!

pop
	| array |
	array := compilerStack pop.
	currentMethod := array first	
!

push
	| array |
	array := { currentMethod }.
	compilerStack push: array.
	(compilerStack size > 500 )ifTrue: [ self error: 'unless it is very complex grammar, there is an error somewhere' ]
!

smartRemember: parser
	^ self smartRemember: parser to: #memento 
!

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

smartRestore: parser
	^ self smartRestore: parser from: #memento 
!

smartRestore: parser from: mementoName
	parser isContextFree ifTrue: [ 
		^ 'context lwRestore: ', mementoName, '.'.
	].
	^ 'context restore: ', mementoName, '.'.
!

startMethod: id
	|  sender |
	(cache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ].
	self push.
	
	
	currentMethod := PPCMethod new.
	currentMethod id: id.
	currentMethod profile: self profile.	
	self cache: id as: currentMethod.
	
	sender := thisContext sender receiver.
	self add: '"Method generated from ', sender asString, '"'.
!

startTokenMode
	tokenMode := true
!

stopInline
	| sender |
	sender := thisContext sender receiver.
	self add: '"Inlined by ', sender asString, '"'.
	lastMethod := currentMethod.
	currentMethod := nil.
	self pop.
!

stopMethod
	self cache: currentMethod methodName as: currentMethod.
	lastMethod := currentMethod.
	currentMethod := nil.
	self pop.
!

stopTokenMode
	tokenMode := false
! !

!PPCCompiler methodsFor:'code generation - ids'!

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

idFor: object prefixed: prefix effect: effect
	| body suffix |
	^ ids at: object ifAbsentPut: [ 
		suffix := self fastMode ifTrue: [ '_fast' ] ifFalse: [ '' ].
		((object isKindOf: PPCNode) and: [object name isNotNil]) ifTrue: [ 
			 (object name, suffix) asSymbol
		] ifFalse: [ 
			body := ids size asString.
			(prefix asString, '_', body, suffix) asSymbol
		]
	]
!

idFor: object prefixed: prefix suffixed: suffix effect: effect
	| body |
	^ ids at: object ifAbsentPut: [ 
		((object isKindOf: PPCNode) and: [object name isNotNil]) ifTrue: [ 
			 (object name, suffix) asSymbol
		] ifFalse: [ 
			body := ids size asString.
			(prefix asString, '_', body, suffix) asSymbol
		]
	]
! !

!PPCCompiler methodsFor:'compiling'!

compile: aPPParser as: name
	^ self compile: aPPParser as: name params: #()
!

compile: aPPParser as: name params: params
	| parser |
	parser := self copy: aPPParser.
	parser := self toCompilerTree: parser.
	parser := self optimize: parser params: params.
	parser := self compileTree: parser as: name parser: aPPParser params: params.
	^ parser
	
!

compileTree: compilerTree as: name parser: parser params: params
	|  |
	params do: [ :p | 
		(p key = #guards) ifTrue: [ self guards: p value ].
	].	

	"
		To create a new Package so that a new classes are not in PetitCompiler package.
		TODO JK: This is HACK, needs some more interoperable approach
	"
	RPackageOrganizer default registerPackageNamed: 'PetitCompiler-Generated'.
	compiledParser := (Smalltalk at: name ifAbsent: [ nil ]).
	compiledParser ifNil: [ 
							PPCompiledParser subclass: name.
							compiledParser := Smalltalk at: name.
							compiledParser category: 'PetitCompiler-Generated'							
						] ifNotNil: [ 
							self clean: compiledParser 
						].	
	compiledParser constants removeAll.
	

	
	self startMethod: #start.
	self add: '^ '.
	self callOnLine: (compilerTree compileWith: self).
	self stopMethod.

	self installMethodsAndVariables: compiledParser.

	compiledParser referringParser: parser.
	^ compiledParser
!

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

installMethods: class
	cache keysAndValuesDo: [ :key :method |
		class compileSilently: method code classified: 'generated'.
	]
!

installMethodsAndVariables: class
	
	self installVariables: class.
	self installMethods: class.	
	
!

installVariables: class
	| string |
	string := class constants keys inject: '' into: [:r :e | r, ' ', e  ].
	PPCompiledParser subclass: class name instanceVariableNames: string classVariableNames: '' category: 'PetitCompiler-Generated'.
!

optimize: parser params: params
	| retval |
	retval := parser optimizeTree: params.
	retval checkTree.
	^ retval
!

toCompilerTree: parser
	^ parser asCompilerTree
! !

!PPCCompiler methodsFor:'guard'!

addSequenceGuard: parser

	| firsts  guardSet guardSetId |
	(self guards not or: [(guardSet := self guardCharSet: parser) isNil]) ifTrue: [ ^ self].

	firsts := (parser firstSetSuchThat: [ :e | (e isKindOf: PPTokenParser) or: [ e isTerminal ] ]).
	
	"If we start with PPTokenParser, we should invoke the whitespace parser"
	(firsts allSatisfy: [ :e | e isKindOf: PPTokenParser ]) ifTrue: [  
		guardSetId := (self idFor: guardSet prefixed: #guard).
		self addConstant: guardSet as: guardSetId.
		self add: 'wsParser parseOn: context.'.
		self add: 'context atEnd ifTrue: [ ^ self error ].'.
		self add: '(', guardSetId, ' value: context peek) ifFalse: [ ^ self error ].'.
	].

	(firsts allSatisfy: [ :e | e isTerminal ]) ifTrue: [  
		guardSetId := (self idFor: guardSet prefixed: #guard).
		self addConstant: guardSet as: guardSetId.
		self add: 'context atEnd ifTrue: [ ^ self error ].'.
		self add: '(', guardSetId, ' value: context peek) ifFalse: [ ^ self error ].'.
	].
!

guardCharSet: parser
	| fs charSet   |
	"No Guards fro trimming parser so far"
	(parser firstSetSuchThat: [ :e | e isKindOf: PPCTrimNode ]) isEmpty ifFalse: [ ^ nil ].

	"Makes no sense to do guard for epsilon parse"
	(parser acceptsEpsilon) ifTrue: [ ^ nil ].

	fs := parser firstSet.
	fs do: [ :p |
		"If we can accept epsilon guard does not make sense"
		p isNullable ifTrue: [ ^ nil ].
	].
	
	charSet := PPCharSetPredicate on: [:char | fs anySatisfy: [:e | (e firstCharParser parse: char asString) isPetitFailure not ]].
	^ charSet
!

guards
	^ guards
!

guards: aBoolean
	guards := aBoolean
! !

!PPCCompiler methodsFor:'initialization'!

initialize
	super initialize.
	compilerStack := Stack new.
	cache := IdentityDictionary new.
	ids := IdentityDictionary new.
	
	tokenMode := false.
	inlining := true.
	profile := false.
	guards := true.
! !

!PPCCompiler methodsFor:'ppcmethod protocol'!

bridge
	^ PPCBridge on: lastMethod methodName.
!

call
	^ lastMethod call
!

canInline
	^ lastMethod canInline
! !