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

Object subclass:#PPCCompiler

	instanceVariableNames:'compilerStack compiledParser cache inlining debug profile

	classVariableNames:''

	poolDictionaries:''

	category:'PetitCompiler-Core'

!

!PPCCompiler class methodsFor:'instance creation'!

new

    "return an initialized instance"

    ^ self basicNew initialize.

! !

!PPCCompiler methodsFor:'accessing'!

fastMode

	^ tokenMode

!

inlining

	^ inlining

!

inlining: value

	inlining := value

!

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 

!

! !

!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

	((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.

!

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.

!

dedent

	currentMethod dedent

!

indent

	currentMethod indent

!

nl

	currentMethod nl

!

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

!

startTokenMode

	tokenMode := true

!

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

	^ self idFor: object prefixed: prefix suffixed: '' effect: effect.

!

idFor: object prefixed: prefix suffixed: suffix effect: effect

	^ ids at: object ifAbsentPut: [ 

		((object isKindOf: PPCNode) and: [object name isNotNil]) ifTrue: [ 

		] 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

      compiledParser := (Smalltalk at: name ifAbsent: [ nil ]).

      compiledParser ifNil: [ 

                PPCompiledParser subclass: name

                   instanceVariableNames:''

                   classVariableNames:''

                   poolDictionaries:''

                   category:'PetitCompiler-Generated'.                

                compiledParser := Smalltalk at: name.

      ] ifNotNil: [ 

                self clean: compiledParser 

!

copy: parser

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

!

installMethods: class

	cache keysAndValuesDo: [ :key :method |

		class compileSilently: method code classified: 'generated'.

	]

!

installVariables: class

!

installVariablesAndMethods

    "Updates the class and compile generated code"

    | compiledParserClassName |

    compiledParserClassName := compiledParser name.

    self installVariables: compiledParser.

    "Now we have to refetch the class again. The reason is, that

    in (at least) Smalltalk/X modyfing a layout of a class results

    in creating a new class rather than updating an old one and migrating

    instances. Therefore, to install methods in in correct class, we have

    to refetch new version from system dictionary. On Pharo it should not harm."

    compiledParser := Smalltalk at: compiledParserClassName.

    self installMethods: compiledParser.

!

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.

	tokenMode := false.

	inlining := true.

	profile := false.

	guards := true.

! !

!PPCCompiler class methodsFor:'documentation'!

version_HG

    ^ '$Changeset: <not expanded> $'

! !