--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/compiler/PPCCompiler.st Sun Oct 26 01:03:31 2014 +0000
@@ -0,0 +1,416 @@
+"{ 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
+! !
+