hg/stx-goodies-petitparser: comparison compiler/PPCCompiler.st

equal deleted inserted replaced

-:b2f2f15cef26
+:7e08b31e0dae
 "{ Package: 'stx:goodies/petitparser/compiler' }"
 Object subclass:#PPCCompiler
 	instanceVariableNames:'compilerStack compiledParser cache inlining debug profile
-		currentMethod lastMethod guards ids updateContextMethod tokenMode'
+		currentMethod guards ids tokenMode rootNode'
 	classVariableNames:''
 	poolDictionaries:''
 	category:'PetitCompiler-Core'
 !
 	^ inlining
 !
 inlining: value
 	inlining := value
-!
-lastMethod
-	^ lastMethod
 !
 parameters: associations
 	| key value |
 	associations do: [ :ass |
 profile: aBoolean
 	profile := aBoolean
 !
-startInline: id
+rootNode
-	self push.
+	^ rootNode
-	currentMethod := PPCInlinedMethod new.
-	currentMethod id: id.
-	currentMethod profile: self profile.
 ! !
 !PPCCompiler methodsFor:'cleaning'!
 clean: class
 add: string
 	currentMethod add: string.
 !
+addComment: string
+	currentMethod add: '"', string, '"'.
+!
 addConstant: value as: name
 	compiledParser addConstant: value as: name.
 !
 addOnLine: string
 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
 !
 		^ '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 effect: effect
 	^ self idFor: object prefixed: prefix suffixed: '' effect: effect.
 !
 idFor: object prefixed: prefix suffixed: suffix effect: effect
-	| body |
+	| body id |
+	"Halt if: [ (object isKindOf: PPCNode) and: [object name = #smalltalk_ws ] ]."
+"	((object isKindOf: PPCNode) and: [object name = #smalltalk_ws ])  ifTrue: [ Transcript crShow: 'st_ws' ].
+"
 	^ ids at: object ifAbsentPut: [
 		((object isKindOf: PPCNode) and: [object name isNotNil]) ifTrue: [
-			 (object name, suffix) asSymbol
+			"Halt if: [ object name = #smalltalk_ws ]."
+"			(object name = #smalltalk_ws) ifTrue: [Transcript crShow: 'NEW st_ws'].
+"
+			id := (object name, suffix) asSymbol.
+			"Make sure, that the generated ID is uniqe!!"
+			((ids values select: [ :e | e = id ]) isEmpty) ifTrue: [ id ]
+			ifFalse: [
+				body := ids size asString.
+				(id, '_', body) asSymbol
+			]
 		] ifFalse: [
 			body := ids size asString.
 			(prefix asString, '_', body, suffix) asSymbol
 		]
 	]
+! !
+!PPCCompiler methodsFor:'code generation - support'!
+checkCache: id
+	| method  |
+	"Check if method is hand written"
+	method := compiledParser compiledMethodAt: id ifAbsent: [ nil ].
+	method ifNotNil: [ ^ PPCCompiledMethod new id: id; yourself ].
+	^ self cachedValue: id
+!
+pop
+| retval |
+retval := compilerStack pop.
+compilerStack isEmpty ifFalse: [ currentMethod := compilerStack top ].
+^ retval
+"Modified: / 21-11-2014 / 12:27:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+push
+compilerStack push: currentMethod.
+(compilerStack size > 500 )ifTrue: [ self error: 'unless it is very complex grammar, there is an error somewhere' ]
+"Modified: / 21-11-2014 / 12:27:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+startInline: id
+	| sender |
+	currentMethod := PPCInlinedMethod new.
+	currentMethod id: id.
+	currentMethod profile: self profile.
+	self push.
+	sender := thisContext sender receiver.
+	self addComment: 'START inlining by ', sender asString.
+!
+startMethod: id
+	|  sender |
+	(cache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ].
+	currentMethod := PPCMethod new.
+	currentMethod id: id.
+	currentMethod profile: self profile.
+	self push.
+	self cache: id as: currentMethod.
+	sender := thisContext sender receiver.
+	self addComment: 'START of method generated by ', sender asString.
+!
+stopInline
+	| sender |
+	sender := thisContext sender receiver.
+	self addComment: 'STOP inlining by ', sender asString.
+	^ self pop.
+!
+stopMethod
+	| sender |
+	sender := thisContext sender receiver.
+	self addComment: 'END of method generated by ', sender asString.
+	self cache: currentMethod methodName as: currentMethod.
+	^ self pop.
+!
+top
+	^ compilerStack top
 ! !
 !PPCCompiler methodsFor:'compiling'!
 compile: aPPParser as: name
 	^ parser
 !
 compileTree: compilerTree as: name parser: parser params: params
-|  |
+	|  |
-params do: [ :p |
+	params do: [ :p |
-(p key = #guards) ifTrue: [ self guards: p value ].
+		(p key = #guards) ifTrue: [ self guards: p value ].
-].
+	].
-((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
+	((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[
-| rPackageOrganizer |
+		| rPackageOrganizer |
-rPackageOrganizer := Smalltalk at: #RPackageOrganizer.
+		rPackageOrganizer := Smalltalk at: #RPackageOrganizer.
-rPackageOrganizer notNil ifTrue:[
+		rPackageOrganizer notNil ifTrue:[
-rPackageOrganizer default registerPackageNamed: 'PetitCompiler-Generated'.
+			rPackageOrganizer default registerPackageNamed: 'PetitCompiler-Generated'.
-].
+		].
 compiledParser := (Smalltalk at: name ifAbsent: [ nil ]).
 compiledParser ifNil: [
 PPCompiledParser subclass: name
 instanceVariableNames:''
 poolDictionaries:''
 category:'PetitCompiler-Generated'.
 compiledParser := Smalltalk at: name.
 ] ifNotNil: [
 self clean: compiledParser
 ].
-] ifFalse: [
+	] ifFalse: [
-RPackageOrganizer default registerPackageNamed: 'PetitCompiler-Generated'.
+		RPackageOrganizer default registerPackageNamed: 'PetitCompiler-Generated'.
-compiledParser := (Smalltalk at: name ifAbsent: [ nil ]).
+		compiledParser := (Smalltalk at: name ifAbsent: [ nil ]).
-compiledParser ifNil: [
+		compiledParser ifNil: [
-PPCompiledParser subclass: name.
+							PPCompiledParser subclass: name.
-compiledParser := Smalltalk at: name.
+							compiledParser := Smalltalk at: name.
-compiledParser category: 'PetitCompiler-Generated'
+							compiledParser category: 'PetitCompiler-Generated'
-] ifNotNil: [
+							] ifNotNil: [
-self clean: compiledParser
+								self clean: compiledParser
-].
+							].
-].
+	].
-compiledParser constants removeAll.
+	compiledParser constants removeAll.
+	rootNode := compilerTree.
-self startMethod: #start.
+	self precomputeFirstSets: rootNode.
-self add: '^ '.
+	self precomputeFollowSets: rootNode.
-self callOnLine: (compilerTree compileWith: self).
+	self precomputeFollowSetsWithTokens: rootNode.
-self stopMethod.
+	self startMethod: #start.
-self installVariablesAndMethods.
+	self add: '^ '.
+	self callOnLine: (compilerTree compileWith: self).
-compiledParser referringParser: parser.
+	self stopMethod.
-^ compiledParser
+	self installVariablesAndMethods.
-"Modified: / 05-11-2014 / 23:17:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+	compiledParser referringParser: parser.
+	^ compiledParser
 !
 copy: parser
 	^ parser transform: [ :p | p copy ].
 !
 		class compileSilently: method code classified: 'generated'.
 	]
 !
 installVariables: class
-| string |
+	| string |
-string := class constants keys inject: '' into: [:r :e | r, ' ', e  ].
+	string := class constants keys inject: '' into: [:r :e | r, ' ', e  ].
-PPCompiledParser subclass: class name instanceVariableNames: string classVariableNames: '' poolDictionaries:'' category: 'PetitCompiler-Generated'.
+	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"
 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
+!
+precomputeFirstSets: root
+	| firstSets |
+	firstSets := root firstSets.
+	root allNodesDo: [ :node |
+		node firstSet: (firstSets at: node).
+	]
+!
+precomputeFollowSets: root
+	| followSets |
+	followSets := root followSets.
+	root allNodesDo: [ :node |
+		node followSet: (followSets at: node).
+	]
+!
+precomputeFollowSetsWithTokens: root
+	| followSets |
+	followSets := root followSetsSuchThat: [:e | e isTerminal or: [ e isKindOf: PPCTrimmingTokenNode ]].
+	root allNodesDo: [ :node |
+		node followSetWithTokens: (followSets at: node).
+	]
 !
 toCompilerTree: parser
 	^ parser asCompilerTree
 ! !
 initialize
 	super initialize.
 	compilerStack := Stack new.
 	cache := IdentityDictionary new.
-	ids := IdentityDictionary new.
+	ids := Dictionary 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> $'

changeset 421	7e08b31e0dae
parent 415	f30eb7ea54cd
child 422	116d2b2af905