diff --git a/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st b/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st index 21c0f2f519..d2e5b759f7 100644 --- a/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st +++ b/smalltalksrc/Melchor/MLVMCCodeGenerator.class.st @@ -300,8 +300,8 @@ MLVMCCodeGenerator >> harmonizeReturnTypesIn: aSetOfTypes [ constantIntegers := aSetOfTypes select: [:element| element isInteger]. aSetOfTypes removeAll: constantIntegers. "N.B. Because of LP64 vs LLP64 issues do *not* rename #long to #sqInt or #'unsigned long' to #usqInt" - #(char short int #'long long' #'unsigned char' #'unsigned short' #'unsigned int' #'unsigned long long') - with: #(sqInt sqInt sqInt sqLong usqInt usqInt usqInt usqLong) + {#char. #short. #int. #'long long' .#'unsigned char'. #'unsigned short'. #'unsigned int'. #'unsigned long long'. TType int} + with: #(sqInt sqInt sqInt sqLong usqInt usqInt usqInt usqLong sqInt) do: [:type :replacement| (aSetOfTypes includes: type) ifTrue: [aSetOfTypes remove: type; add: replacement]]. @@ -309,7 +309,7 @@ MLVMCCodeGenerator >> harmonizeReturnTypesIn: aSetOfTypes [ usqs := aSetOfTypes select: [:t| t beginsWith: 'usq']. ^(sqs size + usqs size = aSetOfTypes size and: [sqs notEmpty - and: [sqs allSatisfy: [:t| usqs includes: 'u', t]]]) + and: [sqs allSatisfy: [:t| usqs includes: 'u', t asString]]]) ifTrue: [sqs] ifFalse: [(aSetOfTypes isEmpty and: [constantIntegers notEmpty]) ifTrue: [Set with: self defaultType] diff --git a/smalltalksrc/Slang-Tests/SlangAbstractTestCase.class.st b/smalltalksrc/Slang-Tests/SlangAbstractTestCase.class.st index f7de0d090f..fda938af69 100644 --- a/smalltalksrc/Slang-Tests/SlangAbstractTestCase.class.st +++ b/smalltalksrc/Slang-Tests/SlangAbstractTestCase.class.st @@ -14,5 +14,5 @@ SlangAbstractTestCase >> assertReturnTypeOf: aMethod equalsHarmonized: expectedT | harmonizedTypes | harmonizedTypes := ccg harmonizeReturnTypesIn: { expectedType } asSet. self assert: harmonizedTypes size = 1 description: 'There seems to be a type conflict'. - self assert: aMethod returnType equals: harmonizedTypes anyOne. + self assert: aMethod returnType asString equals: harmonizedTypes anyOne. ] diff --git a/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st b/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st index 9a05297af0..c457407a21 100644 --- a/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st +++ b/smalltalksrc/Slang-Tests/SlangBasicTranslationTest.class.st @@ -1178,6 +1178,35 @@ SlangBasicTranslationTest >> testGoto [ self assert: translation equals: 'goto lab' ] +{ #category : #'tests-inlinemethod' } +SlangBasicTranslationTest >> testInlineMethodIfExpressionWithShiftRight [ + + | translation codeGenerator inlinedMethod cast printedString | + translation := (self getTMethodFrom: #methodToBeTranslatedWithIfAndShiftRight). + inlinedMethod := ((SlangBasicTranslationTestClass >> #methodWithIfAndShiftRight:) asTranslationMethodOfClass: TMethod). + + codeGenerator := CCodeGeneratorGlobalStructure new. + codeGenerator + addMethod: translation; + addMethod: inlinedMethod; + doInlining: true. + + cast := translation asCASTIn: codeGenerator. + printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. + self assert: cast isCompoundStatement. + self assert: printedString equals: '/* SlangBasicTranslationTestClass>>#methodToBeTranslatedWithIfAndShiftRight */ +static sqInt +methodToBeTranslatedWithIfAndShiftRight(void) +{ + /* begin methodWithIfAndShiftRight: */ + ((usqInt) (((2 < 0) + ? 0 + : 2)) ) >> ((2 - 1) * 32); + return 0; +} +'. +] + { #category : #'tests-inline-builtins' } SlangBasicTranslationTest >> testInlineMethodSumArgumentsWithAnnotations [ | tMethod translation | @@ -1246,35 +1275,6 @@ methodUseParametersWithAnnotationsBuiltIntowith(unsigned int *pFrom, unsigned in }' ] -{ #category : #'tests-inlinemethod' } -SlangBasicTranslationTest >> testInlineMethodIfExpressionWithShiftRight [ - - | translation codeGenerator inlinedMethod cast printedString | - translation := (self getTMethodFrom: #methodToBeTranslatedWithIfAndShiftRight). - inlinedMethod := ((SlangBasicTranslationTestClass >> #methodWithIfAndShiftRight:) asTranslationMethodOfClass: TMethod). - - codeGenerator := CCodeGeneratorGlobalStructure new. - codeGenerator - addMethod: translation; - addMethod: inlinedMethod; - doInlining: true. - - cast := translation asCASTIn: codeGenerator. - printedString := String streamContents: [ :str | cast prettyPrintOn: str ]. - self assert: cast isCompoundStatement. - self assert: printedString equals: '/* SlangBasicTranslationTestClass>>#methodToBeTranslatedWithIfAndShiftRight */ -static sqInt -methodToBeTranslatedWithIfAndShiftRight(void) -{ - /* begin methodWithIfAndShiftRight: */ - ((usqInt) (((2 < 0) - ? 0 - : 2)) ) >> ((2 - 1) * 32); - return 0; -} -'. -] - { #category : #'tests-inlinenode' } SlangBasicTranslationTest >> testInlineNodeDoesNotInitializeReadBeforeWrittenArrayTemp [ @@ -2187,19 +2187,6 @@ SlangBasicTranslationTest >> testSendAllMask [ self assert: translation equals: '(a & 7) == 7' ] -{ #category : #'tests-builtins' } -SlangBasicTranslationTest >> testSendAnd [ - - | send | - - send := TSendNode new - setSelector: #& - receiver: (TConstantNode value: false) - arguments: { TConstantNode value: true }. - self should: [ self translate: send ] raise: TranslationError. - -] - { #category : #'tests-builtins' } SlangBasicTranslationTest >> testSendAsFloat [ @@ -6604,6 +6591,35 @@ SlangBasicTranslationTest >> testTranslateNormalVariable [ self assert: translation equals: 'someVar' ] +{ #category : #'tests-send' } +SlangBasicTranslationTest >> testTypeGuidedAnd [ + + | tMethod translation | + tMethod := self getTMethodFrom: #methodWithAndBooleanReceiver. + translation := self translate: tMethod. + + self assert: (translation includesSubstring: 'receiver && 1') +] + +{ #category : #'tests-send' } +SlangBasicTranslationTest >> testTypeGuidedbitAnd [ + + | tMethod translation | + tMethod := self getTMethodFrom: #methodWithAndIntegerReceiver. + translation := self translate: tMethod. + + self assert: (translation includesSubstring: 'receiver & 1') +] + +{ #category : #'tests-send' } +SlangBasicTranslationTest >> testTypeMismatchedAnd [ + + | method | + method := self getTMethodFrom: + #methodWithAndIntegerReceiverAndBooleanArgument. + self should: [ self translate: method ] raise: TypeError +] + { #category : #'tests-assignment' } SlangBasicTranslationTest >> testVariableAssignment [ diff --git a/smalltalksrc/Slang-Tests/SlangBasicTranslationTestClass.class.st b/smalltalksrc/Slang-Tests/SlangBasicTranslationTestClass.class.st index 6bdbaa9531..c54f91de0c 100644 --- a/smalltalksrc/Slang-Tests/SlangBasicTranslationTestClass.class.st +++ b/smalltalksrc/Slang-Tests/SlangBasicTranslationTestClass.class.st @@ -103,6 +103,12 @@ SlangBasicTranslationTestClass >> methodFromWithAnnotations: pFrom to: pTo len: ^ 0 ] +{ #category : #inline } +SlangBasicTranslationTestClass >> methodToBeTranslatedWithIfAndShiftRight [ + + self methodWithIfAndShiftRight: 2 +] + { #category : #'generation-targets' } SlangBasicTranslationTestClass >> methodUseParametersWithAnnotations: pFrom to: pTo with: anInteger [ @@ -125,12 +131,6 @@ SlangBasicTranslationTestClass >> methodUseParametersWithAnnotationsBuiltIn: pFr to: pTo ] -{ #category : #inline } -SlangBasicTranslationTestClass >> methodToBeTranslatedWithIfAndShiftRight [ - - self methodWithIfAndShiftRight: 2 -] - { #category : #inline } SlangBasicTranslationTestClass >> methodUsingSingleArrayVariable [ @@ -177,6 +177,33 @@ SlangBasicTranslationTestClass >> methodWithAnOptionPragma [ ] +{ #category : #'as yet unclassified' } +SlangBasicTranslationTestClass >> methodWithAndBooleanReceiver [ + + | receiver result | + + receiver := true. + result := receiver & true +] + +{ #category : #'as yet unclassified' } +SlangBasicTranslationTestClass >> methodWithAndIntegerReceiver [ + + | receiver result | + + receiver := 1000. + result := receiver & 1 +] + +{ #category : #'as yet unclassified' } +SlangBasicTranslationTestClass >> methodWithAndIntegerReceiverAndBooleanArgument [ + + | receiver result | + + receiver := 1000. + result := receiver & false +] + { #category : #inline } SlangBasicTranslationTestClass >> methodWithIfAndShiftRight: var [ diff --git a/smalltalksrc/Slang-Tests/SlangBasicTypeInferenceTest.class.st b/smalltalksrc/Slang-Tests/SlangBasicTypeInferenceTest.class.st index 72077a6b94..8e0ca96abf 100644 --- a/smalltalksrc/Slang-Tests/SlangBasicTypeInferenceTest.class.st +++ b/smalltalksrc/Slang-Tests/SlangBasicTypeInferenceTest.class.st @@ -53,7 +53,7 @@ SlangBasicTypeInferenceTest >> testAFalseConstantNode [ tMethod := ccg methodNamed: #aFalseConstantNode. self assert: tMethod isNotNil. - self assert: (ccg typeFor: tMethod statements first in: tMethod) equals: #int + self assert: (ccg typeFor: tMethod statements first in: tMethod) asString equals: #int ] { #category : #constant } @@ -71,7 +71,7 @@ SlangBasicTypeInferenceTest >> testANilConstantNode [ tMethod := ccg methodNamed: #aNilConstantNode. self assert: tMethod isNotNil. - self assert: (ccg typeFor: tMethod statements first in: tMethod) equals: #int + self assert: (ccg typeFor: tMethod statements first in: tMethod) asString equals: #int ] { #category : #constant } @@ -98,7 +98,7 @@ SlangBasicTypeInferenceTest >> testATrueConstantNode [ tMethod := ccg methodNamed: #aTrueConstantNode. self assert: tMethod isNotNil. - self assert: (ccg typeFor: tMethod statements first in: tMethod) equals: #int + self assert: (ccg typeFor: tMethod statements first in: tMethod) asString equals: #int ] { #category : #constant } @@ -166,8 +166,8 @@ SlangBasicTypeInferenceTest >> testReturnAFalseConstantNode [ tMethod := ccg methodNamed: #returnAFalseConstantNode. self assert: tMethod isNotNil. - self assert: (ccg typeFor: tMethod statements first in: tMethod) equals: #int. - self assert: tMethod returnType equals: #sqInt + self assert: (ccg typeFor: tMethod statements first in: tMethod) asString equals: #int. + self assert: tMethod returnType asString equals: #sqInt ] { #category : #'return-message-send' } @@ -176,9 +176,9 @@ SlangBasicTypeInferenceTest >> testReturnAFalseMessageSend [ tMethod := ccg methodNamed: #returnAFalseMessageSend. self assert: tMethod isNotNil. - self assert: (ccg typeFor: tMethod statements first in: tMethod) equals: #sqInt. - self assert: (ccg typeFor: tMethod statements first expression in: tMethod) equals: #sqInt. - self assert: tMethod returnType equals: #sqInt. + self assert: (ccg typeFor: tMethod statements first in: tMethod) asString equals: #sqInt. + self assert: (ccg typeFor: tMethod statements first expression in: tMethod) asString equals: #sqInt. + self assert: tMethod returnType asString equals: #sqInt. ] { #category : #'return-message-send' } @@ -198,7 +198,7 @@ SlangBasicTypeInferenceTest >> testReturnANilConstantNode [ tMethod := ccg methodNamed: #returnANilConstantNode. self assert: tMethod isNotNil. - self assert: (ccg typeFor: tMethod statements first in: tMethod) equals: #int. + self assert: (ccg typeFor: tMethod statements first in: tMethod) asString equals: #int. self assert: tMethod returnType equals: #sqInt ] @@ -261,8 +261,8 @@ SlangBasicTypeInferenceTest >> testReturnATrueConstantNode [ tMethod := ccg methodNamed: #returnATrueConstantNode. self assert: tMethod isNotNil. - self assert: (ccg typeFor: tMethod statements first in: tMethod) equals: #int. - self assert: tMethod returnType equals: #sqInt + self assert: (ccg typeFor: tMethod statements first in: tMethod) asString equals: #int. + self assert: tMethod returnType asString equals: #sqInt ] { #category : #'return-message-send' } @@ -271,9 +271,9 @@ SlangBasicTypeInferenceTest >> testReturnATrueMessageSend [ tMethod := ccg methodNamed: #returnATrueMessageSend. self assert: tMethod isNotNil. - self assert: (ccg typeFor: tMethod statements first in: tMethod) equals: #sqInt. - self assert: (ccg typeFor: tMethod statements first expression in: tMethod) equals: #sqInt. - self assert: tMethod returnType equals: #sqInt. + self assert: (ccg typeFor: tMethod statements first in: tMethod) asString equals: #sqInt. + self assert: (ccg typeFor: tMethod statements first expression in: tMethod) asString equals: #sqInt. + self assert: tMethod returnType asString equals: #sqInt. ] { #category : #'return-constant' } @@ -576,9 +576,9 @@ SlangBasicTypeInferenceTest >> testReturnTempFalseConstantNode [ tMethod := ccg methodNamed: #returnTempFalseConstantNode. self assert: tMethod isNotNil. - self assert: (ccg typeFor: tMethod statements first in: tMethod) equals: #int. " assignementNode " - self assert: (ccg typeFor: tMethod statements first value in: tMethod) equals: #int. " value, constantNode " - self assert: (ccg typeFor: tMethod statements first variable in: tMethod) equals: #int. " variable, temporaryNode " + self assert: (ccg typeFor: tMethod statements first in: tMethod) asString equals: #int. " assignementNode " + self assert: (ccg typeFor: tMethod statements first value in: tMethod) asString equals: #int. " value, constantNode " + self assert: (ccg typeFor: tMethod statements first variable in: tMethod) asString equals: #int. " variable, temporaryNode " self assertReturnTypeOf: tMethod equalsHarmonized: #int ] @@ -589,8 +589,8 @@ SlangBasicTypeInferenceTest >> testReturnTempFalseMessageNode [ tMethod := ccg methodNamed: #returnTempFalseMessageNode. self assert: tMethod isNotNil. - self assert: (ccg typeFor: tMethod statements first in: tMethod) equals: #sqInt. - self assert: (ccg typeFor: tMethod statements first variable in: tMethod) equals: #sqInt. + self assert: (ccg typeFor: tMethod statements first in: tMethod) asString equals: #sqInt. + self assert: (ccg typeFor: tMethod statements first variable in: tMethod) asString equals: #sqInt. self assert: tMethod returnType equals: #sqInt. ] @@ -697,7 +697,7 @@ SlangBasicTypeInferenceTest >> testReturnTempIntLesser32ConstantNode [ self assert: (ccg typeFor: tMethod statements first value in: tMethod) equals: #int. " value, constantNode " self assert: (ccg typeFor: tMethod statements first variable in: tMethod) equals: #int. " variable, temporaryNode " - self assertReturnTypeOf: tMethod equalsHarmonized: #'int' + self assertReturnTypeOf: tMethod equalsHarmonized: #int ] { #category : #'return-temp-assigned-message' } @@ -717,11 +717,11 @@ SlangBasicTypeInferenceTest >> testReturnTempNilConstantNode [ tMethod := ccg methodNamed: #returnTempNilConstantNode. self assert: tMethod isNotNil. - self assert: (ccg typeFor: tMethod statements first in: tMethod) equals: #int. " assignementNode " - self assert: (ccg typeFor: tMethod statements first value in: tMethod) equals: #int. " value, constantNode " - self assert: (ccg typeFor: tMethod statements first variable in: tMethod) equals: #int. " variable, temporaryNode " + self assert: (ccg typeFor: tMethod statements first in: tMethod) asString equals: #int. " assignementNode " + self assert: (ccg typeFor: tMethod statements first value in: tMethod) asString equals: #int. " value, constantNode " + self assert: (ccg typeFor: tMethod statements first variable in: tMethod) asString equals: #int. " variable, temporaryNode " - self assertReturnTypeOf: tMethod equalsHarmonized: #int + self assertReturnTypeOf: tMethod equalsHarmonized: #sqInt ] { #category : #'return-temp-assigned-message' } @@ -741,9 +741,9 @@ SlangBasicTypeInferenceTest >> testReturnTempSmallNegativeIntegerConstantNode [ tMethod := ccg methodNamed: #returnTempSmallNegativeIntegerConstantNode. self assert: tMethod isNotNil. - self assert: (ccg typeFor: tMethod statements first in: tMethod) equals: #int. " assignementNode " - self assert: (ccg typeFor: tMethod statements first value in: tMethod) equals: #int. " value, constantNode " - self assert: (ccg typeFor: tMethod statements first variable in: tMethod) equals: #int. " variable, temporaryNode " + self assert: (ccg typeFor: tMethod statements first in: tMethod) asString equals: #int. " assignementNode " + self assert: (ccg typeFor: tMethod statements first value in: tMethod) asString equals: #int. " value, constantNode " + self assert: (ccg typeFor: tMethod statements first variable in: tMethod) asString equals: #int. " variable, temporaryNode " self assertReturnTypeOf: tMethod equalsHarmonized: #int ] @@ -754,8 +754,8 @@ SlangBasicTypeInferenceTest >> testReturnTempSmallNegativeIntegerMessageNode [ tMethod := ccg methodNamed: #returnTempSmallNegativeIntegerMessageNode. self assert: tMethod isNotNil. - self assert: (ccg typeFor: tMethod statements first in: tMethod) equals: #sqInt. - self assert: (ccg typeFor: tMethod statements first variable in: tMethod) equals: #sqInt. + self assert: (ccg typeFor: tMethod statements first in: tMethod) asString equals: #sqInt. + self assert: (ccg typeFor: tMethod statements first variable in: tMethod) asString equals: #sqInt. self assert: tMethod returnType equals: #sqInt. ] @@ -788,9 +788,9 @@ SlangBasicTypeInferenceTest >> testReturnTempTrueConstantNode [ tMethod := ccg methodNamed: #returnTempTrueConstantNode. self assert: tMethod isNotNil. - self assert: (ccg typeFor: tMethod statements first in: tMethod) equals: #int. " assignementNode " - self assert: (ccg typeFor: tMethod statements first value in: tMethod) equals: #int. " value, constantNode " - self assert: (ccg typeFor: tMethod statements first variable in: tMethod) equals: #int. " variable, temporaryNode " + self assert: (ccg typeFor: tMethod statements first in: tMethod) asString equals: #int. " assignementNode " + self assert: (ccg typeFor: tMethod statements first value in: tMethod) asString equals: #int. " value, constantNode " + self assert: (ccg typeFor: tMethod statements first variable in: tMethod) asString equals: #int. " variable, temporaryNode " self assertReturnTypeOf: tMethod equalsHarmonized: #int ] @@ -801,7 +801,7 @@ SlangBasicTypeInferenceTest >> testReturnTempTrueMessageNode [ tMethod := ccg methodNamed: #returnTempTrueMessageNode. self assert: tMethod isNotNil. - self assert: (ccg typeFor: tMethod statements first in: tMethod) equals: #sqInt. - self assert: (ccg typeFor: tMethod statements first variable in: tMethod) equals: #sqInt. + self assert: (ccg typeFor: tMethod statements first in: tMethod) asString equals: #sqInt. + self assert: (ccg typeFor: tMethod statements first variable in: tMethod) asString equals: #sqInt. self assert: tMethod returnType equals: #sqInt. ] diff --git a/smalltalksrc/Slang/CCodeGenerator.class.st b/smalltalksrc/Slang/CCodeGenerator.class.st index 7ecb14221c..71a56b1f2d 100644 --- a/smalltalksrc/Slang/CCodeGenerator.class.st +++ b/smalltalksrc/Slang/CCodeGenerator.class.st @@ -722,6 +722,19 @@ CCodeGenerator >> cSelectorName: aSelector [ ^ cSelector ] +{ #category : #translation } +CCodeGenerator >> cVarDeclaration: var [ + + | declarationOrType | + declarationOrType := self + declarationAt: var + ifAbsent: [ self defaultType , ' ' , var ]. + + ^ declarationOrType isTType + ifTrue: [ declarationOrType declarationFor: var ] + ifFalse: [ declarationOrType ] +] + { #category : #inlining } CCodeGenerator >> cannotInline: selector [ @@ -983,7 +996,7 @@ CCodeGenerator >> declaredConstants [ { #category : #'type inference' } CCodeGenerator >> defaultType [ - ^ #int + ^ TType int ] { #category : #'compile-time-options' } @@ -1345,15 +1358,23 @@ CCodeGenerator >> exportedPrimitiveNames [ CCodeGenerator >> extractTypeFor: aVariable fromDeclaration: aVariableDeclaration [ "Eliminate inessentials from aVariableDeclaration to answer a C type without the variable, or initializations etc" + | decl | - ((aVariableDeclaration beginsWith: 'static ') - or: [aVariableDeclaration beginsWith: 'extern ']) ifTrue: - [^self extractTypeFor: aVariable fromDeclaration: (aVariableDeclaration allButFirst: 7)]. - decl := (aVariableDeclaration indexOf: $= ifAbsent: []) - ifNotNil: [:index| aVariableDeclaration copyFrom: 1 to: index - 1] - ifNil: [aVariableDeclaration]. - decl := decl copyReplaceAll: aVariable with: '' tokenish: [:ch| ch = $_ or: [ch isAlphaNumeric]]. - ^self baseTypeForType: decl + aVariableDeclaration isTType ifTrue: [ ^ aVariableDeclaration ]. + ((aVariableDeclaration beginsWith: 'static ') or: [ + aVariableDeclaration beginsWith: 'extern ' ]) ifTrue: [ + ^ self + extractTypeFor: aVariable + fromDeclaration: (aVariableDeclaration allButFirst: 7) ]. + decl := (aVariableDeclaration indexOf: $= ifAbsent: [ ]) + ifNotNil: [ :index | + aVariableDeclaration copyFrom: 1 to: index - 1 ] + ifNil: [ aVariableDeclaration ]. + decl := decl + copyReplaceAll: aVariable + with: '' + tokenish: [ :ch | ch = $_ or: [ ch isAlphaNumeric ] ]. + ^ self baseTypeForType: decl ] { #category : #'C code generator' } @@ -2145,6 +2166,24 @@ CCodeGenerator >> generateCASTIfTrueIfFalseAsArgument: tast [ ^ self generateCASTIfElseAsArgument: tast reverseArms: false ] +{ #category : #generation } +CCodeGenerator >> generateCASTInferredAnd: aTSendNode [ + + | receiverType argumentType | + receiverType := self + tTypeFor: aTSendNode receiver + in: self currentMethod. + argumentType := self + tTypeFor: aTSendNode arguments first + in: self currentMethod. + + receiverType ~= argumentType ifTrue: [ TypeError signal: 'Cannot infer & type']. + + ^ receiverType isBoolean + ifTrue: [ self generateCASTAnd: aTSendNode ] + ifFalse: [ self generateCASTBitAnd: aTSendNode ] +] + { #category : #'CAST translation' } CCodeGenerator >> generateCASTInlineCCode: aTSendNode [ @@ -3140,7 +3179,7 @@ CCodeGenerator >> initializeCASTTranslationDictionary [ castTranslationDict := Dictionary new: 200. pairs := #( - #& #forbiddenSelector: + #& #generateCASTInferredAnd: #| #forbiddenSelector: #abs #generateCASTAbs: #and: #generateCASTSequentialAnd: @@ -4293,7 +4332,7 @@ CCodeGenerator >> promoteIntegerArithmeticTypes: firstType and: secondType [ length1 := self sizeOfIntegralCType: firstType. length2 := self sizeOfIntegralCType: secondType. intSize := self sizeOfIntegralCType: #int. - (length1 < intSize and: [length2 < intSize]) ifTrue: [^#int]. "Integer promotion" + (length1 < intSize and: [length2 < intSize]) ifTrue: [^TType int]. "Integer promotion" length1 > length2 ifTrue: [^firstType]. length2 > length1 ifTrue: [^secondType]. firstType first = $u ifTrue: [^firstType]. @@ -4528,7 +4567,6 @@ CCodeGenerator >> returnPrefixFromVariable: aName [ { #category : #'type inference' } CCodeGenerator >> returnTypeForSend: sendNode in: aTMethod boundTo: aCalledMethod typeIfNil: typeIfNil [ - "Answer the return type for a send. Unbound sends default to typeIfNil. Methods with types as yet unknown have a type determined either by the kernelReturnTypes or the table below, or, if they are in neither set, then nil. @@ -4538,10 +4576,10 @@ CCodeGenerator >> returnTypeForSend: sendNode in: aTMethod boundTo: aCalledMetho be defaulted, since on a subsequent pass its type may be computable." ^ sendNode selector - caseOf: { + caseOf: { ([ #integerValueOf: ] -> [ #sqInt ]). - ([ #isIntegerObject: ] -> [ #int ]). - ([ #negated ] -> [ + ([ #isIntegerObject: ] -> [ TType int ]). + ([ #negated ] -> [ self promoteArithmeticTypes: (sendNode receiver typeFrom: self in: aTMethod) @@ -4550,18 +4588,18 @@ CCodeGenerator >> returnTypeForSend: sendNode in: aTMethod boundTo: aCalledMetho ([ #- ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). ([ #* ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). ([ #/ ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). - ([ #// ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). - ([ #\\ ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #'//' ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). + ([ #'\\' ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). ([ #rem: ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). ([ #quo: ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). "C99 Sec Bitwise shift operators ... 3 Sematics ... The integer promotions are performed on each of the operands. The type of the result is that of the promoted left operand..." - ([ #>> ] -> [ sendNode receiver typeFrom: self in: aTMethod ]). - ([ #<< ] -> [ sendNode receiver typeFrom: self in: aTMethod ]). - ([ #addressOf: ] -> [ + ([ #'>>' ] -> [ sendNode receiver typeFrom: self in: aTMethod ]). + ([ #'<<' ] -> [ sendNode receiver typeFrom: self in: aTMethod ]). + ([ #addressOf: ] -> [ (sendNode receiver typeFrom: self in: aTMethod) ifNil: [ #sqInt ] - ifNotNil: [ :type | + ifNotNil: [ :type | type , (type last isLetter ifTrue: [ ' *' ] ifFalse: [ '*' ]) ] ]). @@ -4575,7 +4613,7 @@ CCodeGenerator >> returnTypeForSend: sendNode in: aTMethod boundTo: aCalledMetho ([ #bitClear: ] -> [ self typeForArithmetic: sendNode in: aTMethod ]). ([ #bitInvert32 ] -> [ #'unsigned int' ]). - ([ #bitInvert64 ] -> [ + ([ #bitInvert64 ] -> [ self promoteArithmeticTypes: (sendNode receiver typeFrom: self in: aTMethod) @@ -4585,13 +4623,13 @@ CCodeGenerator >> returnTypeForSend: sendNode in: aTMethod boundTo: aCalledMetho ([ #byteSwapped32IfBigEndian: ] -> [ #'unsigned int' ]). ([ #byteSwapped64IfBigEndian: ] -> [ #'unsigned long long' ]). ([ #= ] -> [ #int ]). - ([ #~= ] -> [ #int ]). - ([ #== ] -> [ #int ]). - ([ #~~ ] -> [ #int ]). + ([ #'~=' ] -> [ #int ]). + ([ #'==' ] -> [ #int ]). + ([ #'~~' ] -> [ #int ]). ([ #< ] -> [ #int ]). - ([ #<= ] -> [ #int ]). + ([ #'<=' ] -> [ #int ]). ([ #> ] -> [ #int ]). - ([ #>= ] -> [ #int ]). + ([ #'>=' ] -> [ #int ]). ([ #between:and: ] -> [ #int ]). ([ #anyMask: ] -> [ #int ]). ([ #allMask: ] -> [ #int ]). @@ -4618,10 +4656,10 @@ CCodeGenerator >> returnTypeForSend: sendNode in: aTMethod boundTo: aCalledMetho ([ #signedIntToLong ] -> [ #usqInt ]). "c.f. generateSignedIntToLong:on:indent:" ([ #signedIntToShort ] -> [ #usqInt ]). "c.f. generateSignedIntToShort:on:indent:" ([ #cCoerce:to: ] - -> [ + -> [ self conventionalTypeForType: sendNode arguments last value ]). ([ #cCoerceSimple:to: ] - -> [ + -> [ self conventionalTypeForType: sendNode arguments last value ]). ([ #sizeof: ] -> [ #usqIntptr_t ]). "Technically it's a size_t but it matches on target architectures so far..." ([ #ifTrue:ifFalse: ] @@ -4637,7 +4675,7 @@ CCodeGenerator >> returnTypeForSend: sendNode in: aTMethod boundTo: aCalledMetho ([ #caseOf: ] -> [ self typeFor: sendNode arguments first in: aTMethod ]) } otherwise: [ "If there /is/ a method for sel but its return type is as yet unknown it /mustn't/ be defaulted, - since on a subsequent pass its type may be computable. Only default unbound selectors." + since on a subsequent pass its type may be computable. Only default unbound selectors." aCalledMethod ifNotNil: [ nil ] ifNil: [ typeIfNil ] ] ] @@ -4650,18 +4688,18 @@ CCodeGenerator >> returnTypeForSend: sendNode in: aTMethod ifNil: typeIfNil [ generated expessions so that inlining would not change the expression. If there is a method for sel but its return type is as yet unknown it mustn't be defaulted, since on a subsequent pass its type may be computable." - | sel methodOrNil | + | sel methodOrNil | methodOrNil := self anyMethodNamed: (sel := sendNode selector). - (methodOrNil notNil and: [methodOrNil returnType notNil]) ifTrue: - [^self baseTypeForType: methodOrNil returnType]. + (methodOrNil notNil and: [ methodOrNil returnType notNil ]) ifTrue: [ + ^ self baseTypeForType: methodOrNil returnType ]. ^ self - returnTypeForSend: sendNode - in: aTMethod - boundTo: methodOrNil - typeIfNil: typeIfNil + returnTypeForSend: sendNode + in: aTMethod + boundTo: methodOrNil + typeIfNil: typeIfNil ] { #category : #'translation support' } @@ -4999,6 +5037,17 @@ CCodeGenerator >> suppressAsmLabelsWhile: aBlock [ ^aBlock ensure: [suppressAsmLabels := oldSuppressAsmLabels] ] +{ #category : #type } +CCodeGenerator >> tTypeFor: aTVariableNode in: aTMethod [ + + | typeOrDeclaration | + typeOrDeclaration := self typeFor: aTVariableNode in: aTMethod. + + ^ typeOrDeclaration isTType + ifTrue: [ typeOrDeclaration ] + ifFalse: [ TType cType: typeOrDeclaration ] +] + { #category : #utilities } CCodeGenerator >> testInliningFor: selector as: inlineFlagOrSymbol [ "Test inlining for the method with the given selector. @@ -5043,7 +5092,7 @@ CCodeGenerator >> typeForArithmetic: sendNode in: aTMethod [ argType notNil and: [ argType last == $* ] ]) ifTrue: [ (rcvrType isNil or: [ argType isNil ]) ifTrue: [ ^ nil ]. (rcvrType last == $* and: [ argType last == $* ]) ifTrue: [ - sendNode selector == #- ifTrue: [ ^ #int ]. + sendNode selector == #- ifTrue: [ ^ TType int ]. self error: 'invalid pointer arithmetic' ]. ^ rcvrType last == $* ifTrue: [ rcvrType ] @@ -5162,8 +5211,8 @@ CCodeGenerator >> unsignedTypeForIntegralType: aCTypeString [ ifTrue: [aCTypeString] ifFalse: [(aCTypeString beginsWith: 'sq') - ifTrue: ['u' , aCTypeString] - ifFalse: ['unsigned ' , aCTypeString]] + ifTrue: ['u' , aCTypeString asString] + ifFalse: ['unsigned ' , aCTypeString asString]] ] { #category : #'C code generator' } diff --git a/smalltalksrc/Slang/CSlangPrettyPrinter.class.st b/smalltalksrc/Slang/CSlangPrettyPrinter.class.st index a8f6dea7ac..4dd65e29c1 100644 --- a/smalltalksrc/Slang/CSlangPrettyPrinter.class.st +++ b/smalltalksrc/Slang/CSlangPrettyPrinter.class.st @@ -299,7 +299,7 @@ CSlangPrettyPrinter >> visitFunctionDeclarator: aFunctionDeclarator [ CSlangPrettyPrinter >> visitFunctionDefinition: aFunction [ aFunction specifiers - do: [ :e | stream nextPutAll: e ] + do: [ :e | stream nextPutAll: e asString] separatedBy: [ stream space ]. stream cr. aFunction hasRawPrototype ifFalse: [ @@ -532,7 +532,7 @@ CSlangPrettyPrinter >> visitTernary: aTernary [ { #category : #generated } CSlangPrettyPrinter >> visitTypename: aTypename [ - stream nextPutAll: aTypename symbol + stream nextPutAll: aTypename symbol asString ] { #category : #generated } diff --git a/smalltalksrc/Slang/MLStatementListBuider.class.st b/smalltalksrc/Slang/MLStatementListBuider.class.st index 4051d4c19a..68d087ad1e 100644 --- a/smalltalksrc/Slang/MLStatementListBuider.class.st +++ b/smalltalksrc/Slang/MLStatementListBuider.class.st @@ -31,7 +31,7 @@ MLStatementListBuider >> addLinearisedStatement: expressionNode [ type := codeGenerator typeFor: expressionNode in: codeGenerator currentMethod. - declaration := type , ' ' , variable name. + declaration := type asString , ' ' , variable name. declarations at: variable name put: declaration. self addStatement: (self transformControlFlowNodeForValue: expressionNode @@ -46,7 +46,7 @@ MLStatementListBuider >> addLinearisedStatement: expressionNode [ type := codeGenerator typeFor: expressionNode in: codeGenerator currentMethod. - declaration := type , ' ' , name. + declaration := type asString, ' ' , name. declarations at: name put: declaration. assignment := TAssignmentNode diff --git a/smalltalksrc/Slang/Object.extension.st b/smalltalksrc/Slang/Object.extension.st new file mode 100644 index 0000000000..26e35a26a6 --- /dev/null +++ b/smalltalksrc/Slang/Object.extension.st @@ -0,0 +1,6 @@ +Extension { #name : #Object } + +{ #category : #'*Slang' } +Object >> isTType [ + ^false. +] diff --git a/smalltalksrc/Slang/SlangTyper.class.st b/smalltalksrc/Slang/SlangTyper.class.st index fd5ed3331d..ccbb874ee3 100644 --- a/smalltalksrc/Slang/SlangTyper.class.st +++ b/smalltalksrc/Slang/SlangTyper.class.st @@ -70,7 +70,6 @@ SlangTyper >> codeGenerator: aCCodeGenerator [ { #category : #'type inference' } SlangTyper >> inferReturnTypeFromReturnsOf: aMethod [ - "Attempt to infer the return type of the receiver from returns in the parse tree." "this for determining which returns have which return types:" @@ -86,13 +85,11 @@ SlangTyper >> inferReturnTypeFromReturnsOf: aMethod [ codeGenerator maybeBreakForTestToInline: aMethod selector in: aMethod. aMethod returnType ifNotNil: [ ^ self ]. - codeGenerator - pushScope: aMethod - while: - [| hasReturn returnTypes | - hasReturn := false. - returnTypes := Set new. - "Debug: + codeGenerator pushScope: aMethod while: [ + | hasReturn returnTypes | + hasReturn := false. + returnTypes := Set new. + "Debug: (| rettypes | rettypes := Dictionary new. parseTree nodesDo: @@ -102,8 +99,8 @@ SlangTyper >> inferReturnTypeFromReturnsOf: aMethod [ self addTypesFor: node expression to: (types := Set new) in: aCodeGen. rettypes at: node expression put: types]]. rettypes)" - aMethod parseTree nodesDo: [ :node | - node isReturn ifTrue: [ + aMethod parseTree nodesDo: [ :node | + node isReturn ifTrue: [ hasReturn := true. "If we encounter a send of an as-yet-untyped method then abort, retrying and computing the type when that method is fully typed." @@ -114,13 +111,13 @@ SlangTyper >> inferReturnTypeFromReturnsOf: aMethod [ returnTypes remove: #implicit ifAbsent: [ ]. returnTypes := codeGenerator harmonizeReturnTypesIn: returnTypes. hasReturn - ifTrue: [ - returnTypes size > 1 ifTrue: [ + ifTrue: [ + returnTypes size > 1 ifTrue: [ | message | - message := String streamContents: [ :s | + message := String streamContents: [ :s | s nextPutAll: 'conflicting return types '. returnTypes - do: [ :t | s nextPutAll: t ] + do: [ :t | s nextPutAll: t asString ] separatedBy: [ s nextPutAll: ', ' ]. s nextPutAll: ' in '; @@ -132,9 +129,9 @@ SlangTyper >> inferReturnTypeFromReturnsOf: aMethod [ codeGenerator logger newLine; show: message ]. - returnTypes size = 1 ifTrue: [ - aMethod returnType: returnTypes anyOne ] ] - ifFalse: [ + returnTypes size = 1 ifTrue: [ + aMethod returnType: returnTypes anyOne asString ] ] + ifFalse: [ aMethod returnType: (codeGenerator implicitReturnTypeFor: aMethod selector) ] ] ] @@ -211,7 +208,6 @@ SlangTyper >> inferTypesForImplicitlyTypedVariablesAndMethods [ { #category : #'type inference' } SlangTyper >> inferTypesForImplicitlyTypedVariablesIn: aMethod [ - " Infer types for untyped variables from assignments and arithmetic uses " | alreadyExplicitlyTypedOrNotToBeTyped asYetUntyped mustBeSigned newDeclarations | @@ -223,23 +219,22 @@ SlangTyper >> inferTypesForImplicitlyTypedVariablesIn: aMethod [ alreadyExplicitlyTypedOrNotToBeTyped. mustBeSigned := Set new. newDeclarations := Dictionary new. - - aMethod parseTree nodesDo: [ :node | + aMethod parseTree nodesDo: [ :node | | type var | "If there is something of the form i >= 0, then i should be signed, not unsigned." - (node isSend and: [ - (aMethod allLocals includes: (var := node receiver variableNameOrNil)) - and: [ - (#( <= < >= > ) includes: node selector) and: [ - node arguments first isConstant and: [ - node arguments first value = 0 ] ] ] ]) ifTrue: [ + (node isSend and: [ + (aMethod allLocals includes: + (var := node receiver variableNameOrNil)) and: [ + (#( <= < >= > ) includes: node selector) and: [ + node arguments first isConstant and: [ + node arguments first value = 0 ] ] ] ]) ifTrue: [ mustBeSigned add: var ]. "if an assignment to an untyped local of a known type, set the local's type to that type. Only observe known sends (methods in the current set) and typed local variables." - (node isAssignment and: [ - (aMethod allLocals includes: (var := node variable name)) and: [ - (alreadyExplicitlyTypedOrNotToBeTyped includes: var) not ] ]) + (node isAssignment and: [ + (aMethod allLocals includes: (var := node variable name)) and: [ + (alreadyExplicitlyTypedOrNotToBeTyped includes: var) not ] ]) ifTrue: [ "don't be fooled by previously inferred types" type := self tryExtractTypeFromAssignmentNode: node @@ -247,16 +242,18 @@ SlangTyper >> inferTypesForImplicitlyTypedVariablesIn: aMethod [ type ifNil: [ "Further, if the type derives from an as-yet-untyped method, we must defer." alreadyExplicitlyTypedOrNotToBeTyped add: var. - (node expression isSend and: [ - (codeGenerator methodNamed: node expression selector) notNil ]) + (node expression isSend and: [ + (codeGenerator methodNamed: node expression selector) notNil ]) ifTrue: [ newDeclarations removeKey: var ifAbsent: nil ] ] ifNotNil: [ "Merge simple types (but *don't* merge untyped vars); complex types must be defined by the programmer.""If untyped, then cannot type the variable yet. A subsequent assignment may assign a subtype of what this type ends up being" - (codeGenerator isSimpleType: type) ifTrue: [ + (codeGenerator isSimpleType: type) ifTrue: [ (asYetUntyped includes: var) - ifTrue: [ - newDeclarations at: var put: type , ' ' , var. + ifTrue: [ + newDeclarations at: var put: (type isTType + ifTrue: [ type ] + ifFalse: [ type , ' ' , var ]). asYetUntyped remove: var ] - ifFalse: [ + ifFalse: [ self mergeTypeOf: var in: newDeclarations @@ -264,15 +261,15 @@ SlangTyper >> inferTypesForImplicitlyTypedVariablesIn: aMethod [ method: aMethod ] ] ] ] ]. - mustBeSigned do: [ :var | - (newDeclarations at: var ifAbsent: nil) ifNotNil: [ :decl | + mustBeSigned do: [ :var | + (newDeclarations at: var ifAbsent: nil) ifNotNil: [ :decl | | type | type := codeGenerator extractTypeFor: var fromDeclaration: decl. - type first == $u ifTrue: [ + type first == $u ifTrue: [ newDeclarations at: var - put: (self signedTypeForIntegralType: type) , ' ' , var ] ] ]. - newDeclarations keysAndValuesDo: [ :var :decl | + put: (self signedTypeForIntegralType: type asString) , ' ' , var ] ] ]. + newDeclarations keysAndValuesDo: [ :var :decl | aMethod declarations at: var put: decl ] ] @@ -282,23 +279,33 @@ SlangTyper >> mergeTypeOf: var in: aDictionary with: newType method: tMethod [ Either assign its type, if it is as yet untyped, or merge newType with its existing type. N.B. We refuse to promote a variable that already has integral type to a floating point type. The existing plugins depend on this; one can always use an explicit type in future." + | existingType mergedType | existingType := codeGenerator - extractTypeFor: var - fromDeclaration: (aDictionary at: var ifAbsentPut: [newType, ' ', var]). - existingType ~= newType ifTrue: - [((codeGenerator isPointerCType: existingType) - or: [codeGenerator isPointerCType: newType]) - ifTrue: - [existingType = #'void *' ifTrue: [^newType]. - newType = #'void *' ifTrue: [^existingType]. - codeGenerator logger show: 'conflicting types ', existingType, ' ', newType, ' for ', var, ' in ', tMethod selector. - ^existingType] - ifFalse: - [((codeGenerator isIntegralCType: existingType) - and: [codeGenerator isFloatingPointCType: newType]) ifFalse: - [mergedType := codeGenerator promoteArithmeticTypes: existingType and: newType. - aDictionary at: var put: mergedType, ' ', var]]] + extractTypeFor: var + fromDeclaration: + (aDictionary + at: var + ifAbsentPut: [ TType cType: newType ]). + existingType ~= newType ifTrue: [ + ((codeGenerator isPointerCType: existingType) or: [ + codeGenerator isPointerCType: newType ]) + ifTrue: [ + existingType = #'void *' ifTrue: [ ^ newType ]. + newType = #'void *' ifTrue: [ ^ existingType ]. + codeGenerator logger show: + 'conflicting types ' , existingType , ' ' , newType , ' for ' + , var , ' in ' , tMethod selector. + ^ existingType ] + ifFalse: [ + ((codeGenerator isIntegralCType: existingType) and: [ + codeGenerator isFloatingPointCType: newType ]) ifFalse: [ + mergedType := codeGenerator + promoteArithmeticTypes: existingType + and: newType. + aDictionary at: var put: (mergedType isTType + ifTrue: [ mergedType ] + ifFalse: [ mergedType , ' ' , var ]) ] ] ] ] { #category : #'type inference' } diff --git a/smalltalksrc/Slang/TConstantNode.class.st b/smalltalksrc/Slang/TConstantNode.class.st index 43d79f69d4..0cc01c1da6 100644 --- a/smalltalksrc/Slang/TConstantNode.class.st +++ b/smalltalksrc/Slang/TConstantNode.class.st @@ -121,24 +121,25 @@ TConstantNode >> typeOrNilFrom: aCodeGenerator in: aTMethod [ "For integers, answer int unless the value does not fit into a 32bits signed int. In that case, answer the shortest architecture independant integer type that could hold the constant. This method must be consistent with CCodeGenerator>>cLiteralFor:" + | hb | - value isInteger - ifTrue: - [value positive - ifTrue: - [hb := value highBit. - hb < 32 ifTrue: [^#int]. - hb = 32 ifTrue: [^#'unsigned int']. - hb = 64 ifTrue: [^#'unsigned long long']. - ^#'long long'] - ifFalse: - [hb := value bitInvert highBit. - hb < 32 ifTrue: [^#int]. - ^#'long long']]. - value isFloat ifTrue: [^#double]. - (#(nil true false) includes: value) ifTrue: [^#int]. - (value isString and: [value isSymbol not]) ifTrue: [^#'char *']. - ^nil + value isInteger ifTrue: [ + value positive + ifTrue: [ + hb := value highBit. + hb < 32 ifTrue: [ ^ TType int ]. + hb = 32 ifTrue: [ ^ #'unsigned int' ]. + hb = 64 ifTrue: [ ^ #'unsigned long long' ]. + ^ #'long long' ] + ifFalse: [ + hb := value bitInvert highBit. + hb < 32 ifTrue: [ ^ TType int ]. + ^ #'long long' ] ]. + value isFloat ifTrue: [ ^ #double ]. + (#(true false) includes: value) ifTrue: [^TType boolean]. + value ifNil: [ ^ TType int ]. + (value isString and: [ value isSymbol not ]) ifTrue: [ ^ #'char *' ]. + ^ nil ] { #category : #accessing } diff --git a/smalltalksrc/Slang/TMethod.class.st b/smalltalksrc/Slang/TMethod.class.st index 25160b41f4..b706b75853 100644 --- a/smalltalksrc/Slang/TMethod.class.st +++ b/smalltalksrc/Slang/TMethod.class.st @@ -309,7 +309,7 @@ TMethod >> asCASTFunctionPrototypeIn: aCodeGen isPrototype: isPrototype [ (aCodeGen cFunctionNameFor: selector) ] ]. export - ifTrue: [ specifiers add: 'EXPORT(' , returnType , ')' ] + ifTrue: [ specifiers add: 'EXPORT(' , returnType asString , ')' ] ifFalse: [ self isStatic ifTrue: [ specifiers add: 'static' ] @@ -788,7 +788,7 @@ TMethod >> emitCFunctionPrototype: aStream generator: aCodeGen isPrototype: isPr export ifTrue: - [aStream nextPutAll: 'EXPORT('; nextPutAll: returnType; nextPut: $)] + [aStream nextPutAll: 'EXPORT('; nextPutAll: returnType asString; nextPut: $)] ifFalse: [self isStatic ifTrue: [aStream nextPutAll: 'static '] @@ -796,7 +796,7 @@ TMethod >> emitCFunctionPrototype: aStream generator: aCodeGen isPrototype: isPr [isPrototype ifTrue: [aStream nextPutAll: 'extern ']]. (isPrototype or: [inline ~~ #always]) ifFalse: [aStream nextPutAll: 'inline ']. - aStream nextPutAll: (returnType ifNil: [#sqInt])]. + aStream nextPutAll: (returnType asString ifNil: [#sqInt])]. (functionAttributes isNil or: [returnTypeIsFunctionPointer]) ifFalse: [aStream space; nextPutAll: functionAttributes]. isPrototype ifTrue: [aStream space] ifFalse: [aStream cr]. @@ -1665,8 +1665,8 @@ TMethod >> inlineSend: aSendNode directReturn: directReturn exitVar: exitVar in: ifTrue: [ type ~= #sqInt ifTrue: [ meth declarationAt: formal put: (type last = $* - ifTrue: [ type , formal ] - ifFalse: [ type , ' ' , formal ]) ] ] ] ]. + ifTrue: [ type asString , formal ] + ifFalse: [ type asString , ' ' , formal ]) ] ] ] ]. meth renameVarsForInliningInto: self except: elidedArgs in: aCodeGen. meth renameLabelsForInliningInto: self. @@ -1860,7 +1860,7 @@ TMethod >> isFunctionalIn: aCodeGen [ sqInt usqInt #'sqIntptr_t' #'usqIntptr_t' sqLong usqLong #'int *' #'unsigned int *' #'sqInt *' #'usqInt *' #'sqLong *' #'usqLong *' #'char *' #'CogMethod *' #'AbstractInstruction *' - #'FILE *') includes: returnType + #'FILE *') includes: returnType asString ] { #category : #inlining } @@ -2663,7 +2663,6 @@ TMethod >> renameLabelsUsing: aDictionary [ { #category : #'inlining support' } TMethod >> renameVariablesUsing: aDictionary [ - "Rename all variables according to old->new mappings of the given dictionary." | newDecls newProperties | @@ -2679,40 +2678,41 @@ TMethod >> renameVariablesUsing: aDictionary [ "map declarations" newDecls := declarations species new. - declarations - keysAndValuesDo: [ :oldName :decl | - (aDictionary at: oldName ifAbsent: nil) - ifNotNil: [ :newName | - | index | - index := decl findLastOccurrenceOfString: oldName startingAt: 1. - newDecls - at: newName - put: - (index ~= 0 - ifTrue: [ decl - copyReplaceFrom: index - to: index + oldName size - 1 - with: newName ] - ifFalse: [ decl ]) ] - ifNil: [ newDecls at: oldName put: decl ] ]. + declarations keysAndValuesDo: [ :oldName :decl | + (aDictionary at: oldName ifAbsent: nil) + ifNotNil: [ :newName | + | index | + index := decl isTType + ifTrue: [ 0 ] + ifFalse: [ + decl findLastOccurrenceOfString: oldName startingAt: 1 ]. + newDecls at: newName put: (index ~= 0 + ifTrue: [ + decl + copyReplaceFrom: index + to: index + oldName size - 1 + with: newName ] + ifFalse: [ decl ]) ] + ifNil: [ newDecls at: oldName put: decl ] ]. + self newDeclarations: newDecls. newProperties := properties copy. - newProperties pragmas do: [ :pragma | + newProperties pragmas do: [ :pragma | | mappedArgs | - mappedArgs := pragma arguments collect: [ :arg | + mappedArgs := pragma arguments collect: [ :arg | arg isString ifTrue: [ aDictionary at: arg ifAbsent: arg ] ifFalse: [ arg ] ]. - mappedArgs ~= pragma arguments ifTrue: [ + mappedArgs ~= pragma arguments ifTrue: [ pragma arguments: mappedArgs ] ]. self properties: newProperties. "map variable names in parse tree" - parseTree nodesDo: [ :node | - (node isVariable and: [ aDictionary includesKey: node name ]) + parseTree nodesDo: [ :node | + (node isVariable and: [ aDictionary includesKey: node name ]) ifTrue: [ node setName: (aDictionary at: node name) ]. - (node isStatementList and: [ node arguments size > 0 ]) ifTrue: [ - node setArguments: (node arguments collect: [ :arg | + (node isStatementList and: [ node arguments size > 0 ]) ifTrue: [ + node setArguments: (node arguments collect: [ :arg | aDictionary at: arg ifAbsent: [ arg ] ]) ] ] ] diff --git a/smalltalksrc/Slang/TStatementListNode.class.st b/smalltalksrc/Slang/TStatementListNode.class.st index 504aa98240..a3aba0f076 100644 --- a/smalltalksrc/Slang/TStatementListNode.class.st +++ b/smalltalksrc/Slang/TStatementListNode.class.st @@ -216,9 +216,7 @@ TStatementListNode >> asCASTIn: aBuilder prependToEnd: aNodeOrNil [ ifFalse: [ 'DECL_MAYBE_SQ_GLOBAL_STRUCT' ])) ]. (aBuilder sortStrings: self locals asSet) do: [ :var | | declaration | - declaration := aBuilder - declarationAt: var - ifAbsent: [ aBuilder defaultType, ' ' , var ]. + declaration := aBuilder cVarDeclaration: var. self flag: #TODO. "Avoid implicit variables. @@ -302,15 +300,28 @@ TStatementListNode >> children [ ^ statements ] +{ #category : #transformations } +TStatementListNode >> copyStatementsWithoutReturn [ + + self assert: self endsWithReturn. + ^ self class new + setArguments: arguments statements: (statements size = 1 + ifTrue: [ statements last expression ] + ifFalse: [ + statements allButLast , { statements last copyWithoutReturn } ]); + yourself +] + { #category : #transformations } TStatementListNode >> copyWithoutReturn [ + self assert: self endsWithReturn. - statements size = 1 ifTrue: - [^statements last expression]. - ^self class new - setArguments: arguments - statements: statements allButLast, {statements last copyWithoutReturn}; - yourself + statements size = 1 ifTrue: [ ^ statements last expression ]. + ^ self class new + setArguments: arguments + statements: + statements allButLast , { statements last copyWithoutReturn }; + yourself ] { #category : #declarations } diff --git a/smalltalksrc/Slang/TType.class.st b/smalltalksrc/Slang/TType.class.st new file mode 100644 index 0000000000..2f6057fbdd --- /dev/null +++ b/smalltalksrc/Slang/TType.class.st @@ -0,0 +1,143 @@ +Class { + #name : #TType, + #superclass : #Object, + #instVars : [ + 'cType', + 'isBoolean' + ], + #category : #'Slang-AST' +} + +{ #category : #accessing } +TType class >> boolean [ + + ^ self int + isBoolean: true; + yourself +] + +{ #category : #intantiation } +TType class >> cType: aString [ + + ^ self new + cType: aString; + yourself +] + +{ #category : #instatiation } +TType class >> int [ + ^self cType: #int. +] + +{ #category : #instatiation } +TType class >> sqInt [ + ^self cType: #sqInt. +] + +{ #category : #comparing } +TType >> = other [ + + | matchesStructure | + matchesStructure := other isTType not or: [ + self isBoolean = other isBoolean ]. + ^ self asString = other asString and: [ matchesStructure ] +] + +{ #category : #converting } +TType >> asString [ + ^cType asString. +] + +{ #category : #matching } +TType >> beginsWith: aString [ + + ^cType beginsWith: aString +] + +{ #category : #intantiation } +TType >> cType: aString [ + cType:= aString. +] + +{ #category : #declaration } +TType >> declarationFor: aVarName [ + ^self asString, ' ', aVarName. +] + +{ #category : #accessing } +TType >> findLastOccurrenceOfString: aString startingAt: anInteger [ + + ^ cType findLastOccurrenceOfString: aString startingAt: anInteger +] + +{ #category : #accessing } +TType >> first [ + ^cType first. +] + +{ #category : #comparing } +TType >> hash [ + + ^ cType hash bitXor: isBoolean hash +] + +{ #category : #testing } +TType >> includes: aCharacter [ + + ^ cType includes: aCharacter +] + +{ #category : #testing } +TType >> includesSubstring: aString [ + ^cType includesSubstring: aString. +] + +{ #category : #accessing } +TType >> indexOf: aCharacter startingAt: anInteger [ + ^cType indexOf: aCharacter startingAt: anInteger. +] + +{ #category : #accessing } +TType >> indexOfSubCollection: aString [ + + ^ cType indexOfSubCollection: aString +] + +{ #category : #initialization } +TType >> initialize [ + + self isBoolean: false +] + +{ #category : #testing } +TType >> isBoolean [ + ^isBoolean. +] + +{ #category : #accessing } +TType >> isBoolean: aBoolean [ + isBoolean := aBoolean +] + +{ #category : #testing } +TType >> isTType [ + ^true. +] + +{ #category : #accessing } +TType >> last [ + + ^ cType last +] + +{ #category : #comparing } +TType >> printOn: aStream [ + + super printOn: aStream. + aStream << ': ' << cType +] + +{ #category : #string } +TType >> withBlanksTrimmed [ + ^cType withBlanksTrimmed. +] diff --git a/smalltalksrc/Slang/TypeError.class.st b/smalltalksrc/Slang/TypeError.class.st new file mode 100644 index 0000000000..a03d7c47cd --- /dev/null +++ b/smalltalksrc/Slang/TypeError.class.st @@ -0,0 +1,5 @@ +Class { + #name : #TypeError, + #superclass : #Error, + #category : #Slang +} diff --git a/smalltalksrc/VMMakerCompatibilityForPharo6/PharoVMMaker.class.st b/smalltalksrc/VMMakerCompatibilityForPharo6/PharoVMMaker.class.st index 8aeafc92a8..428f3c7eca 100644 --- a/smalltalksrc/VMMakerCompatibilityForPharo6/PharoVMMaker.class.st +++ b/smalltalksrc/VMMakerCompatibilityForPharo6/PharoVMMaker.class.st @@ -65,6 +65,27 @@ PharoVMMaker class >> generate: anInterpreterClass outputDirectory: aDirectory [ ^ self generate: anInterpreterClass outputDirectory: aDirectory imageFormat: self defaultImageFormatName ] +{ #category : #generation } +PharoVMMaker class >> generate: anInterpreterClass outputDirectory: aDirectory imageFormat: imageFormatName [ + + Transcript + nextPutAll: 'Generating '; + nextPutAll: anInterpreterClass printString; + nextPutAll: ' in '; + nextPutAll: aDirectory printString; + nextPutAll: ' with '; + nextPutAll: imageFormatName; + nextPutAll: '...'; + newLine; + flush. + + self new + imageFormatName: imageFormatName; + outputDirectory: aDirectory; + perform: #generate , anInterpreterClass asSymbol + +] + { #category : #generation } PharoVMMaker class >> generate: anInterpreterClass outputDirectory: aDirectory options: options [