"{ 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 class methodsFor:'instance creation'!

new
    "return an initialized instance"

    ^ self basicNew initialize.
! !

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

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
	^ self idFor: object prefixed: prefix suffixed: '' effect: effect.
!

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


        ((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
                | rPackageOrganizer |
                rPackageOrganizer := Smalltalk at: #RPackageOrganizer.
                rPackageOrganizer notNil ifTrue:[
                        rPackageOrganizer default registerPackageNamed: 'PetitCompiler-Generated'.
                ].

      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 
      ].                
        ] ifFalse: [ 
                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 installVariablesAndMethods.

        compiledParser referringParser: parser.
        ^ compiledParser

    "Modified: / 05-11-2014 / 23:17:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

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

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

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

    "Modified: / 26-10-2014 / 22:01:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

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.

    "Created: / 30-10-2014 / 23:15:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

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

!PPCCompiler class methodsFor:'documentation'!

version_HG

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