Portability: Removed tests/asserts referring to BlockClosure
Due to historical reasons, there's no BlockClosure in Smalltalk/X,
the class is named Block. Conversely, there's no Block in Squeak/Pharo.
"{ Package: 'stx:goodies/petitparser/compiler' }"
"{ NameSpace: Smalltalk }"
Object subclass:#PPCCodeGen
instanceVariableNames:'clazz options'
classVariableNames:''
poolDictionaries:''
category:'PetitCompiler-Compiler-Codegen'
!
!PPCCodeGen class methodsFor:'instance creation'!
new
"return an initialized instance"
^ self on: PPCCompilationOptions new
"Modified: / 07-09-2015 / 10:22:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
on: aPPCArguments
"return an initialized instance"
^ self basicNew
initialize;
options: aPPCArguments
! !
!PPCCodeGen methodsFor:'accessing'!
clazz
^ clazz
!
clazz: aPPCClass
clazz := aPPCClass
!
currentMethod
^ clazz currentMethod
!
idGen
^ clazz idGen
!
idGen: idGenerator
^ clazz idGen: idGenerator
!
ids
^ clazz idGen ids
!
methodCategory
^ 'generated'
!
options: args
options := args
! !
!PPCCodeGen methodsFor:'caching'!
cacheMethod: method as: id
^ clazz store: method as: id
!
cachedMethod: id
^ clazz cachedMethod: id
!
cachedMethod: id ifPresent: aBlock
^ clazz cachedMethod: id ifPresent: aBlock
! !
!PPCCodeGen methodsFor:'code'!
code: aStringOrBlockOrRBParseNode
clazz currentMethod code: aStringOrBlockOrRBParseNode
"Created: / 01-06-2015 / 23:49:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeAssert: aCode
self code: 'self assert: (', aCode, ').'.
!
codeBlock: contents
clazz currentMethod codeBlock: contents
"Created: / 01-06-2015 / 22:35:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeCall: aMethod
self assert: (aMethod isKindOf: PPCMethod).
self code: aMethod call.
!
codeCallOnLine: aMethod
self assert: (aMethod isKindOf: PPCMethod).
self codeOnLine: aMethod call.
!
codeDot
self codeOnLine: '.'.
"Created: / 16-06-2015 / 06:09:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeNl
self code: ''.
!
codeOnLine:aStringOrBlockOrRBParseNode
clazz currentMethod codeOnLine: aStringOrBlockOrRBParseNode
"Created: / 01-06-2015 / 23:49:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeReturn
clazz currentMethod isInline ifTrue: [
"If inlined, the return variable already holds the value"
] ifFalse: [
options profile ifTrue:[
self codeProfileStop.
].
self code: '^ ', clazz currentMethod returnVariable
].
"Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 01-06-2015 / 21:49:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeReturn: code
" - returns whatever is in code OR
- assigns whatever is in code into the returnVariable"
clazz currentMethod isInline ifTrue:[
self codeEvaluateAndAssign: code to: clazz currentMethod returnVariable.
] ifFalse: [
options profile ifTrue:[
self codeProfileStop.
].
self code: '^ '.
self codeOnLine: code
]
"Created: / 23-04-2015 / 18:01:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 01-06-2015 / 21:48:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeReturnParsedValueOf: aBlock
| method |
method := clazz parsedValueOf: aBlock to: clazz currentReturnVariable.
method isInline ifTrue:[
self codeCallOnLine: method.
self codeReturn: clazz currentReturnVariable.
] ifFalse:[
self codeReturn: method call.
]
"Created: / 23-04-2015 / 18:21:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!PPCCodeGen methodsFor:'code assignment'!
codeAssign: stringOrBlock to: variable
self assert: variable isNil not.
stringOrBlock isString ifTrue: [
^ self codeAssignString: stringOrBlock to: variable
] ifFalse:[
^ self codeAssignParsedValueOf: stringOrBlock to: variable
].
!
codeAssignParsedValueOf:aBlock to: variable
| method |
method := clazz parsedValueOf: aBlock to: variable .
method isInline ifTrue:[
self codeCallOnLine:method
] ifFalse:[
self codeAssignString: (method call) to: variable.
]
"Created: / 23-04-2015 / 18:21:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeAssignString: string 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 code: variable ,' := ', string.
]
!
codeEvaluate: selector argument: argument on: 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 code: variable, ' ', selector,' ', argument.
] ifTrue: [
"In case argument has a side effect"
self code: argument
]
!
codeEvaluateAndAssign: stringOrBlock to: variable
"Contrary to codeAssign:to: I always put code onto the stream"
stringOrBlock isString ifTrue: [
self codeEvaluateAndAssignString: stringOrBlock to: variable
] ifFalse: [
self codeEvaluateAndAssignParsedValueOf: stringOrBlock to: variable
]
!
codeEvaluateAndAssignParsedValueOf: aBlock to: variable
| method |
method := clazz parsedValueOf: aBlock to: variable .
method isInline ifFalse: [
self codeEvaluateAndAssignString: method call to: variable.
] ifTrue: [
"if inlined, the variable is already filled in, just call it"
self code: method call
]
!
codeEvaluateAndAssignString: string to: variable
"Contrary to codeAssign:to: I always put code onto the stream"
self assert: string isString.
self assert: variable isNil not.
"TODO JK: Hack alert, whatever is magic constant!!"
(variable == #whatever) ifFalse: [
self codeAssignString: string to: variable
] ifTrue: [
"In case code has a side effect"
self code: string.
]
! !
!PPCCodeGen methodsFor:'code debugging'!
codeComment: string
self code: '"', string, '"'.
!
codeHalt
self code: 'self halt. '
!
codeHaltIfShiftPressed
options debug ifTrue: [
((Smalltalk respondsTo: #isSmalltalkX) and:[Smalltalk isSmalltalkX]) ifFalse:[
self code: 'Halt ifShiftPressed.'
]
]
"Modified: / 10-05-2015 / 07:39:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeProfileStart
self code: 'context methodInvoked: #', clazz currentMethod methodName, '.'
"Created: / 01-06-2015 / 21:17:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeProfileStop
self code: 'context methodFinished: #', clazz currentMethod methodName, '.'
"Created: / 01-06-2015 / 21:19:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeTranscriptShow: text
(options profile) ifTrue: [
self code: 'Transcript show: ', text storeString, '; cr.'.
]
!
profileTokenRead: tokenName
options profile ifTrue: [
self code: 'context tokenRead: ', tokenName storeString, '.'
]
! !
!PPCCodeGen methodsFor:'code error handling'!
codeClearError
self code: 'error := false.'.
!
codeError
self code: 'self error: ''message notspecified''.'.
!
codeError: errorMessage
self code: 'self error: ''', errorMessage, '''.'
!
codeError: errorMessage at: position
self code: 'self error: ''', errorMessage, ''' at: ', position asString, '.'
!
codeIfErrorThen: then
^ self codeIf: 'error' then: then else: nil
"Created: / 16-06-2015 / 06:06:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeIfErrorThen: then else: else
^ self codeIf: 'error' then: then else: else
"Created: / 16-06-2015 / 06:05:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!PPCCodeGen methodsFor:'code primitives'!
add: string
self error: 'deprecated?'.
clazz currentMethod add: string.
!
addConstant: value as: name
clazz addConstant: value as: name
!
addOnLine: string
self error: 'deprecated'.
clazz currentMethod addOnLine: string.
!
addVariable: name
^ clazz currentNonInlineMethod addVariable: name
"Modified: / 23-04-2015 / 17:34:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
call: anotherMethod
self error: 'deprecated?'.
clazz currentMethod add: anotherMethod call.
!
callOnLine: anotherMethod
self error: 'deprecated?'.
clazz currentMethod addOnLine: anotherMethod call.
!
dedent
clazz currentMethod dedent
!
indent
clazz currentMethod indent
! !
!PPCCodeGen methodsFor:'code structures'!
codeIf: condition then: then
self codeIf: condition then: then else: nil
"Created: / 16-06-2015 / 06:07:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
codeIf: condition then: then else: else
self
code: '(';
codeOnLine: condition;
codeOnLine: ')'.
then notNil ifTrue:[
self
codeOnLine:' ifTrue: ';
codeBlock: then.
].
else notNil ifTrue:[
self
codeOnLine:' ifFalse: ';
codeBlock: else.
].
self codeDot.
"Created: / 01-06-2015 / 22:43:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 16-06-2015 / 06:09:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!PPCCodeGen methodsFor:'ids'!
idFor: anObject
^ clazz idFor: anObject
!
idFor: anObject defaultName: defaultName
^ clazz idFor: anObject defaultName: defaultName
!
numberIdFor: object
^ clazz numberIdFor: object
! !
!PPCCodeGen methodsFor:'initialization'!
initialize
super initialize.
clazz := PPCClass new.
! !
!PPCCodeGen methodsFor:'support'!
startInline
^ clazz startInline
"Modified: / 01-06-2015 / 21:48:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
startInline: id
^ clazz startInline: id
"Modified: / 01-06-2015 / 21:48:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
startMethod: id
clazz startMethod: id category: self methodCategory.
options profile ifTrue:[
self codeProfileStart.
].
!
stopInline
^ clazz stopInline
"Modified: / 01-06-2015 / 21:37:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
stopMethod
^ clazz stopInline
"Modified: / 01-06-2015 / 21:38:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!PPCCodeGen methodsFor:'variables'!
allocateReturnVariable
^ clazz allocateReturnVariableNamed: 'retval'
"Created: / 23-04-2015 / 18:03:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 15-06-2015 / 17:52:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
allocateReturnVariableNamed: name
^ clazz allocateReturnVariableNamed: name
!
allocateTemporaryVariableNamed: preferredName
"Allocate a new variable with (preferably) given name.
Returns a real variable name that should be used."
^ clazz allocateTemporaryVariableNamed: preferredName
"Created: / 23-04-2015 / 17:33:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
currentReturnVariable
^ clazz currentReturnVariable
! !