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

! !