a first version of Slang with no type conflict and an exception if one appear

smalltalksrc/BaselineOfVMMaker/BaselineOfVMMaker.class.st

@@ -19,12 +19,14 @@ BaselineOfVMMaker >> baseline: spec [
 				package: 'Slang' with: [
 					spec requires: #( 'CAST' )
 				];
-				package: 'Slang-Tests' with: [
-					spec requires: #('Slang') ].
 
 			"Melchor is a VM-oriented Slang"
-			spec package: 'Melchor' with: [
-				spec requires: #('Slang' 'Slang-Tests') ].
+			package: 'Melchor' with: [
+				spec requires: #('Slang') ];
+
+			package: 'Slang-Tests' with: [
+					spec requires: #('Slang' 'Melchor') ].
+
 
 			"External Dependencies"
 			spec baseline: 'SmaCC-GLR' with: [ 

smalltalksrc/Slang-Tests/MLVMCCodeGeneratorConflictMock.class.st

@@ -0,0 +1,22 @@
+Class {
+	#name : #MLVMCCodeGeneratorConflictMock,
+	#superclass : #MLVMCCodeGenerator,
+	#instVars : [
+		'slangTyper'
+	],
+	#category : #'Slang-Tests'
+}
+
+{ #category : #'type inference' }
+MLVMCCodeGeneratorConflictMock >> inferTypes [
+	slangTyper  := 	SlangTyperConflictMock new
+		codeGenerator: self.
+	(slangTyper)
+		stopOnErrors: stopOnErrors;
+		inferTypes
+]
+
+{ #category : #accessing }
+MLVMCCodeGeneratorConflictMock >> slangTyper [ 
+	^ slangTyper
+]

smalltalksrc/Slang-Tests/SLTranslationTest.class.st

@@ -0,0 +1,5 @@
+Class {
+	#name : #SLTranslationTest,
+	#superclass : #SlangAbstractTestCase,
+	#category : #'Slang-Tests'
+}

smalltalksrc/Slang-Tests/SlangBasicTypeInferenceTest.class.st

@@ -28,14 +28,25 @@ There is only one possible type by node, no ambiguities.
 Class {
 	#name : #SlangBasicTypeInferenceTest,
 	#superclass : #SlangAbstractTestCase,
+	#instVars : [
+		'conflictException'
+	],
 	#category : #'Slang-Tests'
 }
 
+{ #category : #helpers }
+SlangBasicTypeInferenceTest >> inferTypes [
+	conflictException := OrderedCollection new.
+	[ ccg inferTypes ]
+		on: SlangReturnTypeConflictException
+		do: [ :ex | conflictException add: ex ]
+]
+
 { #category : #running }
 SlangBasicTypeInferenceTest >> setUp [
 	super setUp.
 	ccg addClass: SlangBasicTypeInferenceTestClass.
-	ccg inferTypes.
+	self inferTypes.
 ]
 
 { #category : #constant }
@@ -603,52 +614,84 @@ SlangBasicTypeInferenceTest >> testReturnMultipleLongIntNotWorking [
 
 { #category : #'return-multiple-type' }
 SlangBasicTypeInferenceTest >> testReturnStringAndIntIfTrue1 [
-	"conflict so default to sqInt"
-	| tMethod |
+	"a conflict appear, the type are not harmonized"
+
+	| tMethod expectedConflict |
 	tMethod := ccg methodNamed: #returnStringAndIntInIfTrue1.
-
-	self assert: tMethod isNotNil.
-	self assert: tMethod returnType equals: #sqInt
+	expectedConflict := Set new.
+	expectedConflict
+		add: #'char *';
+		add: #sqInt.
+	self
+		assert: (ccg slangTyper conflictRecord at: tMethod)
+		equals: expectedConflict.
+	self assert: tMethod isNotNil
 ]
 
 { #category : #'return-multiple-type' }
 SlangBasicTypeInferenceTest >> testReturnStringAndIntIfTrue2 [
-	"conflict so default to sqInt"
-	| tMethod |
+	"a conflict appear, the type are not harmonized"
+
+	| tMethod expectedConflict |
 	tMethod := ccg methodNamed: #returnStringAndIntInIfTrue2.
-
-	self assert: tMethod isNotNil.
-	self assert: tMethod returnType equals: #sqInt
+	expectedConflict := Set new.
+	expectedConflict
+		add: #'char *';
+		add: #sqInt.
+	self
+		assert: (ccg slangTyper conflictRecord at: tMethod)
+		equals: expectedConflict.
+	self assert: tMethod isNotNil
 ]
 
 { #category : #'return-multiple-type' }
 SlangBasicTypeInferenceTest >> testReturnStringAndIntInIfTrueifFalse1 [
-	"conflict so default to sqInt"
-	| tMethod |
+	"a conflict appear, the type are not harmonized"
+
+	| tMethod expectedConflict |
 	tMethod := ccg methodNamed: #returnStringAndIntInIfTrueifFalse1.
-
-	self assert: tMethod isNotNil.
-	self assert: tMethod returnType equals: #sqInt
+	expectedConflict := Set new.
+	expectedConflict
+		add: #'char *';
+		add: #sqInt.
+	self
+		assert: (ccg slangTyper conflictRecord at: tMethod)
+		equals: expectedConflict.
+	self assert: tMethod isNotNil
 ]
 
 { #category : #'return-multiple-type' }
 SlangBasicTypeInferenceTest >> testReturnStringAndIntInIfTrueifFalse2 [
-	"conflict so default to sqInt"
-	| tMethod |
+	"a conflict appear, the type are not harmonized"
+
+	| tMethod expectedConflict |
 	tMethod := ccg methodNamed: #returnStringAndIntInIfTrueifFalse2.
-
-	self assert: tMethod isNotNil.
-	self assert: tMethod returnType equals: #sqInt
+	expectedConflict := Set new.
+	expectedConflict
+		add: #'char *';
+		add: #sqInt.
+	self
+		assert: (ccg slangTyper conflictRecord at: tMethod)
+		equals: expectedConflict.
+
+	self assert: tMethod isNotNil
 ]
 
 { #category : #'return-multiple-type' }
 SlangBasicTypeInferenceTest >> testReturnStringAndIntInIfTrueifFalse3 [
-	"conflict so default to sqInt"
-	| tMethod |
+	"a conflict appear, the type are not harmonized"
+
+	| tMethod expectedConflict |
 	tMethod := ccg methodNamed: #returnStringAndIntInIfTrueifFalse3.
-
-	self assert: tMethod isNotNil.
-	self assert: tMethod returnType equals: #sqInt
+	expectedConflict := Set new.
+	expectedConflict
+		add: #'char *';
+		add: #sqInt.
+	self
+		assert: (ccg slangTyper conflictRecord at: tMethod)
+		equals: expectedConflict.
+
+	self assert: tMethod isNotNil
 ]
 
 { #category : #'return-temp-assigned-const' }
@@ -928,14 +971,17 @@ SlangBasicTypeInferenceTest >> testUnsignedIntInASignedExpressionNotWorking [
 { #category : #'return-signed' }
 SlangBasicTypeInferenceTest >> testUnsignedIntInASignedOperation [
 	"Slang will try to signed a variable if it is present in an iteration with a comparator (>,<,>=,<=) in its expression, here i is first automatically typed as unsigned int but change its type to int eventually"
+
 	| tMethod ccg2 |
-	ccg2 := MLVMCCodeGenerator new.
+	ccg2 := MLVMCCodeGeneratorConflictMock new.
 	ccg2 vmMaker: VMMaker new.
 	ccg2 vmMaker vmmakerConfiguration: VMMakerConfiguration.
 	ccg2 addClass: SlangBasicTypeInferenceTestClass.
 	tMethod := ccg2 methodNamed: #unsignedIntInASignedOperation.
 	self assert: tMethod isNotNil.
-	self assert: (ccg2 typeFor: tMethod statements first in: tMethod) equals: #'unsigned int'.
+	self
+		assert: (ccg2 typeFor: tMethod statements first in: tMethod)
+		equals: #'unsigned int'.
 	ccg2 inferTypes.
 	self assert: tMethod returnType equals: #sqInt
 ]

smalltalksrc/Slang-Tests/SlangTyperConflictMock.class.st

@@ -0,0 +1,39 @@
+Class {
+	#name : #SlangTyperConflictMock,
+	#superclass : #SlangTyper,
+	#instVars : [
+		'conflictRecord'
+	],
+	#category : #'Slang-Tests'
+}
+
+{ #category : #setting }
+SlangTyperConflictMock >> conflictAt: aMethod put: aCollectionOfType [
+	conflictRecord ifNil: [ self resetConflictRecord ].
+	conflictRecord at: aMethod put: aCollectionOfType
+
+]
+
+{ #category : #accessing }
+SlangTyperConflictMock >> conflictFor: aMethod [
+	^ conflictRecord  at: aMethod ifAbsent: [ nil ]
+]
+
+{ #category : #accessing }
+SlangTyperConflictMock >> conflictRecord [
+
+	^ conflictRecord
+]
+
+{ #category : #setting }
+SlangTyperConflictMock >> resetConflictRecord [
+
+	conflictRecord := Dictionary new
+]
+
+{ #category : #exceptions }
+SlangTyperConflictMock >> throwConflictExceptionIn: aMethod with: returnTypes [
+	"does nothing expect recording the error to prevent interrupting the execution during tests"
+
+	self conflictAt: aMethod put: returnTypes
+]

smalltalksrc/Slang/SlangReturnTypeConflictException.class.st

@@ -0,0 +1,23 @@
+Class {
+	#name : #SlangReturnTypeConflictException,
+	#superclass : #SlangTyperException,
+	#category : #Slang
+}
+
+{ #category : #exceptions }
+SlangReturnTypeConflictException class >> signalConflictIn: aMethod with: aCollectionOfType [
+
+	| message |
+	message := String streamContents: [ :s |
+		           s nextPutAll: 'conflicting return types '.
+		           aCollectionOfType
+			           do: [ :t | s nextPutAll: t ]
+			           separatedBy: [ s nextPutAll: ', ' ].
+		           s
+			           nextPutAll: ' in ';
+			           nextPutAll: aMethod definingClass name;
+			           nextPutAll: ' >> ';
+			           nextPutAll: aMethod selector;
+			           cr ].
+	self signal: message
+]

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,27 +111,12 @@ SlangTyper >> inferReturnTypeFromReturnsOf: aMethod [
 		returnTypes remove: #implicit ifAbsent: [  ].
 		returnTypes := codeGenerator harmonizeReturnTypesIn: returnTypes.
 		hasReturn
-			ifTrue: [ 
-				returnTypes size > 1 ifTrue: [ 
-					| message |
-					message := String streamContents: [ :s | 
-						           s nextPutAll: 'conflicting return types '.
-						           returnTypes
-							           do: [ :t | s nextPutAll: t ]
-							           separatedBy: [ s nextPutAll: ', ' ].
-						           s
-							           nextPutAll: ' in ';
-							           nextPutAll: aMethod definingClass name;
-							           nextPutAll: ' >> ';
-							           nextPutAll: aMethod selector;
-							           cr ].
-					Notification signal: message.
-					codeGenerator logger
-						newLine;
-						show: message ].
-				returnTypes size = 1 ifTrue: [ 
+			ifTrue: [
+				returnTypes size > 1 ifTrue: [
+					self throwConflictExceptionIn: aMethod with: returnTypes ].
+				returnTypes size = 1 ifTrue: [
 					aMethod returnType: returnTypes anyOne ] ]
-			ifFalse: [ 
+			ifFalse: [
 				aMethod returnType:
 					(codeGenerator implicitReturnTypeFor: aMethod selector) ] ]
 ]
@@ -325,6 +307,14 @@ SlangTyper >> stopOnErrors: anObject [
 	stopOnErrors := anObject
 ]
 
+{ #category : #exceptions }
+SlangTyper >> throwConflictExceptionIn: aMethod with: returnTypes [
+
+	SlangReturnTypeConflictException
+		signalConflictIn: aMethod
+		with: returnTypes
+]
+
 { #category : #'type inference' }
 SlangTyper >> tryExtractTypeFromAssignmentNode: node inMethod: aMethod [
 

smalltalksrc/Slang/SlangTyperException.class.st

@@ -0,0 +1,5 @@
+Class {
+	#name : #SlangTyperException,
+	#superclass : #Error,
+	#category : #Slang
+}

smalltalksrc/VMMaker/CoInterpreter.class.st

@@ -503,6 +503,7 @@ CoInterpreter >> activateNewFullClosure: blockClosure method: theMethod numArgs:
 	"Similar to activateNewMethod but for Closure and newMethod."
 	| numCopied methodHeader inInterpreter |
 	<inline: true>
+	<returnTypeC: #void>
 	self assert: theMethod = (objectMemory fetchPointer: FullClosureCompiledBlockIndex ofObject: blockClosure).
 	methodHeader := self rawHeaderOf: theMethod.
 	(self isCogMethodReference: methodHeader) ifTrue:

smalltalksrc/VMMaker/InterpreterPrimitives.class.st

@@ -2015,14 +2015,16 @@ InterpreterPrimitives >> primitiveGreaterThanLargeIntegers [
 
 { #category : #'memory space primitives' }
 InterpreterPrimitives >> primitiveGrowMemoryByAtLeast [
+
 	<option: #SpurObjectMemory>
 	| ammount |
 	ammount := self stackTop.
-	(objectMemory isIntegerObject: ammount) ifFalse:
-		[^self primitiveFailFor: PrimErrBadArgument].
-	(objectMemory growOldSpaceByAtLeast: (objectMemory integerValueOf: ammount))
-		ifNil: [self primitiveFailFor: PrimErrNoMemory]
-		ifNotNil: [:segSize| self pop: 2 thenPushInteger: segSize]
+	(objectMemory isIntegerObject: ammount) ifFalse: [
+		^ self primitiveFailFor: PrimErrBadArgument ].
+	(objectMemory growOldSpaceByAtLeast:
+		 (objectMemory integerValueOf: ammount) = 0)
+		ifTrue: [ self primitiveFailFor: PrimErrNoMemory ]
+		ifFalse: [ :segSize | self pop: 2 thenPushInteger: segSize ]
 ]
 
 { #category : #'arithmetic integer primitives' }