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

equal deleted inserted replaced

-:54b3bc9e3987
+:20598d7ce9fa
 "{ Package: 'stx:goodies/petitparser/compiler' }"
 "{ NameSpace: Smalltalk }"
 Object subclass:#PPCCompiler
-	instanceVariableNames:'compilerStack compiledParser cache inlining debug profile
+	instanceVariableNames:'compilerStack compiledParser cache currentMethod ids rootNode
-		currentMethod guards ids tokenMode rootNode'
+		constants compiledParserName returnVariable arguments'
 	classVariableNames:''
 	poolDictionaries:''
 	category:'PetitCompiler-Core'
 !
 !PPCCompiler class methodsFor:'instance creation'!
 new
 "return an initialized instance"
-^ self basicNew initialize.
+^ self basicNew initializeForCompiledClassName: 'PPGeneratedParser'
+!
+newForCompiledClassName: aString
+"return an initialized instance"
+	self halt: 'deprecated'.
+^ self basicNew initializeForCompiledClassName: aString
+!
+on: aPPCArguments
+"return an initialized instance"
+^ self basicNew
+		arguments: aPPCArguments;
+		initializeForCompiledClassName: aPPCArguments name
 ! !
 !PPCCompiler methodsFor:'accessing'!
-inlining
+arguments: args
-	^ inlining
+	arguments := args
 !
-inlining: value
+compiledParser
-	inlining := value
+	^ compiledParser
 !
-parameters: associations
+currentNonInlineMethod
-	| key value |
+	^ compilerStack
-	associations do: [ :ass |
+	    detect:[:m | m isInline not ]
-		key := ass key.
+	    ifNone:[ self error: 'No non-inlined method']
-		value := ass value.
+"Created: / 23-04-2015 / 17:33:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-		(key = #profile) ifTrue: [ profile := value ].
+!
-		(key = #inline) ifTrue: [ inlining := value ].
-		(key = #guards) ifTrue: [ guards := value ].
+currentReturnVariable
-	]
+	^ currentMethod returnVariable
 !
-profile
+ids
-	^ profile
+	^ ids
-!
-profile: aBoolean
-	profile := aBoolean
 !
 rootNode
 	^ rootNode
 ! !
 clean: class
 "	Transcript crShow: 'Cleaning time: ',
 	[
 "		self cleanGeneratedMethods: class.
 		self cleanInstVars: class.
-		self cleanParsers: class.
 		self cleanConstants: class.
 "	] timeToRun asMilliSeconds asString, 'ms'."
 !
 cleanConstants: class
 addComment: string
 	currentMethod add: '"', string, '"'.
 !
 addConstant: value as: name
-	compiledParser addConstant: value as: name.
+	constants at: name put: value
 !
 addOnLine: string
 	currentMethod addOnLine: string.
 !
 addVariable: name
-	currentMethod addVariable: name.
+^ self currentNonInlineMethod addVariable: name
+"Modified: / 23-04-2015 / 17:34:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 !
 call: anotherMethod
 	currentMethod add: anotherMethod call.
 !
 nl
 	currentMethod nl
 !
 smartRemember: parser
+	self flag: 'deprecated'.
 	^ self smartRemember: parser to: #memento
 !
 smartRemember: parser to: variableName
 	parser isContextFree ifTrue: [
 	].
 	^ variableName, ':= context remember.'
 !
 smartRestore: parser
+	self flag: 'deprecated'.
 	^ self smartRestore: parser from: #memento
 !
 smartRestore: parser from: mementoName
 	parser isContextFree ifTrue: [
 		^ 'context lwRestore: ', mementoName, '.'.
 	].
 	^ 'context restore: ', mementoName, '.'.
 ! !
+!PPCCompiler methodsFor:'code generation - coding'!
+codeAssign: code to: variable
+	self assert: variable isNil not.
+	"TODO JK: Hack alert, whatever is magic constant!!"
+	(variable == #whatever) ifFalse: [
+		"Do not assign, if somebody does not care!!"
+		self add: variable ,' := ', code.
+	] ifTrue: [
+		"In case code hava a side effect"
+		self add: code
+	]
+!
+codeClearError
+	self add: 'self clearError.'.
+!
+codeError: errorMessage
+	self add: 'self error: ''', errorMessage, '''.'
+!
+codeHalt
+	self add: 'self halt. '
+!
+codeReturn
+currentMethod isInline ifTrue: [
+		"If inlined, the return variable already holds the value"
+	] ifFalse: [
+		self add: '^ ', currentMethod returnVariable
+].
+"Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+"Modified: / 23-04-2015 / 20:51:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+codeReturn: code
+	" - returns whatever is in code OR
+	  - assigns whatever is in code into the returnVariable"
+currentMethod isInline ifTrue:[
+		self codeAssign: code to: currentMethod returnVariable.
+] ifFalse: [
+		self add: '^ ', code
+	]
+"Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+"Modified: / 23-04-2015 / 20:51:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+codeStoreValueOf: aBlock intoVariable: aString
+	| tmpVarirable method |
+	self assert: aBlock isBlock.
+	self assert: aString isNil not.
+	tmpVarirable := returnVariable.
+	returnVariable := aString.
+	method := [
+		aBlock value
+	] ensure: [
+		returnVariable := tmpVarirable
+	].
+	method isInline ifTrue: [
+		self callOnLine: method
+	] ifFalse: [
+		self codeAssign: (method call) to: aString.
+	]
+	"Created: / 23-04-2015 / 18:21:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
 !PPCCompiler methodsFor:'code generation - ids'!
+idFor: object
+	self assert: (object isKindOf: PPCNode).
+	^ self idFor: object prefixed: object prefix suffixed: object suffix effect: #none
+!
 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 id |
+	| name 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: [
-			"Halt if: [ object name = #smalltalk_ws ]."
+			"Do not use prefix, if there is a name"
-"			(object name = #smalltalk_ws) ifTrue: [Transcript crShow: 'NEW st_ws'].
+			name := object name asLegalSelector.
-"
+			id := (name, suffix) asSymbol.
-			id := (object name, suffix) asSymbol.
 			"Make sure, that the generated ID is uniqe!!"
-			((ids values select: [ :e | e = id ]) isEmpty) ifTrue: [ id ]
+			(ids includes: id) ifTrue: [
-			ifFalse: [
+				(id, '_', ids size asString) asSymbol
-				body := ids size asString.
+			] ifFalse: [
-				(id, '_', body) asSymbol
+				id
 			]
 		] ifFalse: [
-			body := ids size asString.
+			(prefix, '_', (ids size asString), suffix) asSymbol
-			(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 := compiledParser ifNotNil: [ compiledParser compiledMethodAt: id ifAbsent: [ nil ] ].
 	method ifNotNil: [ ^ PPCCompiledMethod new id: id; yourself ].
 	^ self cachedValue: id
 !
 pop
-| retval |
+	| retval |
-retval := compilerStack pop.
+	retval := compilerStack pop.
-compilerStack isEmpty ifFalse: [ currentMethod := compilerStack top ].
+	currentMethod := compilerStack isEmpty
-^ retval
+		ifTrue: [ nil ]
+		ifFalse: [ compilerStack top ].
+	^ retval
 "Modified: / 21-11-2014 / 12:27:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 !
 push
 "Modified: / 21-11-2014 / 12:27:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 !
 startInline: id
-	| sender |
+	(cache includesKey: id) ifTrue: [ self error: 'OOOUPS!!' ].
 	currentMethod := PPCInlinedMethod new.
 	currentMethod id: id.
-	currentMethod profile: self profile.
+	currentMethod profile: arguments profile.
+	currentMethod returnVariable: returnVariable.
 	self push.
+"Modified: / 23-04-2015 / 18:28:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-	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.
+	currentMethod profile: arguments profile.
 	self push.
 	self cache: id as: currentMethod.
-	sender := thisContext sender receiver.
+"Modified: / 23-04-2015 / 18:36:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
-	self addComment: 'START of method generated by ', sender asString.
 !
 stopInline
-	| sender |
-	sender := thisContext sender receiver.
-	self addComment: 'STOP inlining by ', sender asString.
 	^ self pop.
+"Modified: / 23-04-2015 / 18:28:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 !
 stopMethod
-	| sender |
-	sender := thisContext sender receiver.
-	self addComment: 'END of method generated by ', sender asString.
 	self cache: currentMethod methodName as: currentMethod.
+	arguments profile ifTrue: [ Transcript crShow: currentMethod code ].
 	^ self pop.
+"Modified: / 23-04-2015 / 18:36:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 !
 top
 	^ compilerStack top
 ! !
+!PPCCompiler methodsFor:'code generation - variables'!
+allocateReturnVariable
+"Return a new variable to store parsed value"
+^ currentMethod allocateReturnVariable
+"Created: / 23-04-2015 / 17:58:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+"Modified (comment): / 23-04-2015 / 21:12:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+allocateTemporaryVariableNamed: preferredName
+"Allocate a new variable with (preferably) given name.
+Returns a real variable name that should be used."
+^ self currentNonInlineMethod allocateTemporaryVariableNamed: preferredName
+"Created: / 23-04-2015 / 17:33:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
 !PPCCompiler methodsFor:'compiling'!
-compile: aPPParser as: name
+compileParser
-	^ self compile: aPPParser as: name params: #()
+	self installVariables.
-!
+	self installMethods.
+	self installClassConstants.
-compile: aPPParser as: name params: params
-	| parser |
+	^ compiledParser
-	parser := self copy: aPPParser.
+!
-	parser := self toCompilerTree: parser.
-	parser := self optimize: parser params: params.
+copy: parser
-	parser := self compileTree: parser as: name parser: aPPParser params: params.
+	^ parser transform: [ :p | p copy ].
-	^ parser
+!
-!
+installClassConstants
+	constants keysAndValuesDo: [ :key :value |
-compileTree: compilerTree as: name parser: parser params: params
+		compiledParser constants at: key put: value
-	|  |
+	]
-	params do: [ :p |
+!
-		(p key = #guards) ifTrue: [ self guards: p value ].
-	].
+installMethods
+	cache keysAndValuesDo: [ :key :method |
+		compiledParser compileSilently: method code classified: 'generated'.
+	]
+!
+installVariables
+	| varString |
+	varString := constants keys inject: '' into: [:r :e | r, ' ', e  ].
+	PPCompiledParser
+		subclass: compiledParserName
+		instanceVariableNames: varString
+		classVariableNames: ''
+		poolDictionaries: ''
+		category: 'PetitCompiler-Generated'.
+	compiledParser := Smalltalk at: compiledParserName.
+!
+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
+! !
+!PPCCompiler methodsFor:'initialization'!
+initializeForCompiledClassName: aString
+	self initialize.
+	compilerStack := Stack new.
+	cache := IdentityDictionary new.
+	constants := IdentityDictionary new.
+	ids := IdentityDictionary new.
+	compiledParserName := aString asSymbol.
 	((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.
+	Smalltalk at: compiledParserName ifPresent: [ :class |
-	rootNode := compilerTree.
+		compiledParser := class.
-	self precomputeFirstSets: rootNode.
+		self clean: compiledParser.
-	self precomputeFollowSets: rootNode.
+	].
-	self precomputeFollowSetsWithTokens: rootNode.
-	self startMethod: #start.
-	self add: '^ '.
-	self callOnLine: (compilerTree compileWith: self).
-	self stopMethod.
-	self installVariablesAndMethods.
-	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: '' poolDictionaries: '' category: 'PetitCompiler-Generated'.
-!
-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
-!
-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
-! !
-!PPCCompiler methodsFor:'guard'!
-guards
-	^ guards
-!
-guards: aBoolean
-	guards := aBoolean
-! !
-!PPCCompiler methodsFor:'initialization'!
-initialize
-	super initialize.
-	compilerStack := Stack new.
-	cache := IdentityDictionary new.
-	ids := Dictionary new.
-	tokenMode := false.
-	inlining := true.
-	profile := false.
-	guards := true.
 ! !
 !PPCCompiler class methodsFor:'documentation'!
 version_HG

changeset 438	20598d7ce9fa
parent 428	b879012e366e
child 443	2c87ed364404
child 452	9f4558b3be66