Composed image format: C translation

extracted/vm/include/common/sq.h

@@ -504,7 +504,7 @@ sqInt ioDisableImageWrite(void);
 
 #include "pharovm/imageAccess.h"
 
-size_t readImageFromFileStartingAt(sqImageFile f, squeakFileOffsetType imageOffset);
+sqInt readImageNamed(char* fileName);
 
 /* Clipboard (cut/copy/paste). */
 sqInt clipboardSize(void);

include/pharovm/pharo.h

@@ -81,4 +81,4 @@ void *readAddress(sqInt anExternalAddress);
 EXPORT(int) isVMRunOnWorkerThread();
 void setMaxStacksToPrint(sqInt anInteger);
 
-#define allocateMemoryBaseAddress(a, b) sqAllocateMemory(a, a, b)
+#define allocateMemoryBaseAddress(desiredSize, baseAddress) sqAllocateMemory(0, desiredSize, baseAddress)

smalltalksrc/Melchor/CCodeGeneratorGlobalStructure.class.st

@@ -13,6 +13,22 @@ Class {
 	#category : #Melchor
 }
 
+{ #category : #'CAST translation' }
+CCodeGeneratorGlobalStructure >> bindBlock: aTBlockNode withArgs: arguments [
+
+	| blockStatements argumentNames replacements |
+
+	blockStatements := aTBlockNode statements.
+	argumentNames := aTBlockNode args.
+
+	self assert: argumentNames size = arguments size.
+
+	replacements := argumentNames with: arguments collect: [ :name :value | name -> value ] .
+
+	^ blockStatements collect: [ :anStatement | 
+		  anStatement copy bindVariableUsesIn: replacements asDictionary ]
+]
+
 { #category : #'C code generator' }
 CCodeGeneratorGlobalStructure >> buildSortedVariablesCollection [
 	"Build sorted vars, end result will be sorted collection based on static usage, 
@@ -166,13 +182,110 @@ CCodeGeneratorGlobalStructure >> emitGlobalStructFlagOn: aStream [
 		cr
 ]
 
+{ #category : #'CAST translation' }
+CCodeGeneratorGlobalStructure >> generateCASTSetFieldTo: aTSendNode [ 
+
+	| structType fieldName fieldVale setFieldStatements |
+
+	self assert: aTSendNode arguments size = 2.
+
+	fieldName := aTSendNode arguments first.
+	fieldVale := aTSendNode arguments second.
+
+	structType := self structTypeFor: aTSendNode receiver.
+
+
+	setFieldStatements := structType asClass allSlots collect: [ :slot |
+		| comparison |
+
+		comparison := TSendNode 
+			receiver: (TConstantNode value: slot name asString) 
+			selector: 'strcmp:' 
+			arguments: { fieldName }.
+
+		TSendNode 
+			receiver: comparison
+			selector: 'ifTrue:' 
+			arguments: { 
+				TStmtListNode 
+					statements: { 
+						TSendNode 
+							receiver: aTSendNode receiver 
+							selector: (slot name, ':') 
+							arguments: { fieldVale } 
+					}
+			}			
+
+	].
+
+	^ CCompoundStatementNode statements: (setFieldStatements collect: [ :e | e asCASTIn: self]).
+
+]
+
+{ #category : #'CAST translation' }
+CCodeGeneratorGlobalStructure >> generateCASTWithFieldsDoSeparatedBy: aTSendNode [ 
+
+	| structType allRewrittenStatements blockSeparatorStatements fieldBlock allFieldArguments |
+
+	self assert: aTSendNode arguments size = 2.
+	self assert: aTSendNode arguments first args size = 2.
+	self assert: aTSendNode arguments second args size = 0.
+
+	fieldBlock := aTSendNode arguments first.
+	blockSeparatorStatements := aTSendNode arguments second statements.
+
+	structType := self structTypeFor: aTSendNode receiver.
+
+	allFieldArguments := structType asClass allSlots collect: [ :slot |
+		{
+			TConstantNode value: slot name asString. 
+			TSendNode receiver: aTSendNode receiver selector: slot name arguments: { }.
+		}
+	].
+
+	allRewrittenStatements := allFieldArguments collect: [ :fieldArgs |
+		(self bindBlock: fieldBlock withArgs: fieldArgs) , blockSeparatorStatements ].
+
+	^ CCompoundStatementNode statements: (allRewrittenStatements flattened collect: [ :e | e asCASTIn: self]).
+
+]
+
+{ #category : #'CAST translation' }
+CCodeGeneratorGlobalStructure >> generateCASTWithStructNameDo: aTSendNode [ 
+
+	| argumentName structType rewrittenStatements aBlock |
+
+	self assert: aTSendNode arguments size = 1.
+	self assert: aTSendNode arguments first args size = 1.
+
+	structType := self structTypeFor: aTSendNode receiver.
+
+	aBlock := aTSendNode arguments first.
+	argumentName := aTSendNode arguments first args first.
+
+	rewrittenStatements := self bindBlock: aBlock withArgs: { TConstantNode value: structType asString }.
+
+	^ CCompoundStatementNode statements: (rewrittenStatements collect: [ :e | e asCASTIn: self]).
+
+]
+
 { #category : #'C code generator' }
 CCodeGeneratorGlobalStructure >> initialize [
 	super initialize.
 	localStructDef := nil. "ignored ivar - no longer used"
 	structDefDefine := '1'
 ]
 
+{ #category : #initialization }
+CCodeGeneratorGlobalStructure >> initializeCASTTranslationDictionary [
+
+	super initializeCASTTranslationDictionary.
+
+	castTranslationDict at: #withStructNameDo: put: #generateCASTWithStructNameDo:.
+	castTranslationDict at: #withFieldsDo:separatedBy: put: #generateCASTWithFieldsDoSeparatedBy:.
+	castTranslationDict at: #setField:to: put: #generateCASTSetFieldTo:.
+]
+
 { #category : #public }
 CCodeGeneratorGlobalStructure >> isGlobalStructureBuild [
 	^true
@@ -220,3 +333,11 @@ CCodeGeneratorGlobalStructure >> structDefDefine: aString [
 '1' - which would mean always do it"
 	structDefDefine := aString
 ]
+
+{ #category : #'CAST translation' }
+CCodeGeneratorGlobalStructure >> structTypeFor: structNode [
+
+	| nodeType |
+	nodeType := self typeFor: structNode in: currentMethod.
+	^ nodeType trimRight: [ :c | { $* . $ } includes: c ]
+]

smalltalksrc/Slang-Tests/SlangMethodPrototypeTranslationTest.class.st

@@ -12,7 +12,7 @@ Class {
 SlangMethodPrototypeTranslationTest class >> testParameters [ 
 
 	^ ParametrizedTestMatrix new
-		forSelector: #translationStrategy addOptions: { #slangTranslate . #astTranslate }
+		forSelector: #translationStrategy addOptions: { #astTranslate }
 ]
 
 { #category : #helpers }

smalltalksrc/Slang/CCodeGenerator.class.st

@@ -3434,7 +3434,8 @@ CCodeGenerator >> isNode: aNode constantValueWithinRangeOfType: aType [
 { #category : #'C code generator' }
 CCodeGenerator >> isNonArgumentImplicitReceiverVariableName: aString [
 
-	^ (currentMethod definingClass implicitVariables includes: aString) 
+	^ (currentMethod definingClass isNotNil and: [ 
+		   currentMethod definingClass implicitVariables includes: aString ]) 
 		  or: [ (self typeOfVariable: aString) == #implicit ]
 ]
 
@@ -4368,7 +4369,7 @@ CCodeGenerator >> returnTypeForSend: sendNode in: aTMethod boundTo: aCalledMetho
 				 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)
+				[#addressOf:]			->	[(sendNode arguments first typeFrom: self in: aTMethod)
 												ifNil: [#sqInt]
 												ifNotNil: [:type| type, (type last isLetter ifTrue: [' *'] ifFalse: ['*'])]].
 				[#at:]					->	[self typeForDereference: sendNode in: aTMethod].
@@ -4587,6 +4588,8 @@ CCodeGenerator >> sizeOfIntegralCType: anIntegralCType [ "<String>"
 		"Standard C types"
 		['uint64_t']		->	[8].
 		['uint32_t']		->	[4].
+		['uint16_t']		->	[2].
+		['uint8_t']		->	[1].
 	}
 	otherwise:
 		[((anIntegralCType beginsWith: 'unsigned') "e.g. 'unsigned  : 8'"

smalltalksrc/Slang/SlangStructType.class.st

@@ -210,3 +210,25 @@ SlangStructType class >> typeForSelf [
 SlangStructType class >> voidStructTypeCache [
 	StructTypeNameCache := nil
 ]
+
+{ #category : #macros }
+SlangStructType >> setField: fieldName to: fieldValue [
+
+	| slot |
+	slot := self class slotNamed: fieldName.
+	slot write: fieldValue to: self
+]
+
+{ #category : #macros }
+SlangStructType >> withFieldsDo: forEachBlock separatedBy: separatorBlock [ 
+
+	self class allSlots 
+		do: [ :aSlot | forEachBlock value: aSlot name value: (aSlot read: self) ] 
+		separatedBy: separatorBlock 
+]
+
+{ #category : #macros }
+SlangStructType >> withStructNameDo: aFullBlockClosure [ 
+
+	^ aFullBlockClosure value: self class structTypeName
+]

smalltalksrc/Slang/TMethod.class.st

@@ -1472,7 +1472,7 @@ TMethod >> inlineSend: aSendNode directReturn: directReturn exitVar: exitVar in:
 		with: aSendNode args
 		do: [:formal :actual|
 			(meth declarationAt: formal ifAbsent: nil) ifNil:
-				[(self typeFor: actual in: aCodeGen) ifNotNil:
+				[(aCodeGen typeFor: actual in: self) ifNotNil:
 					[:type|
 					type ~= #sqInt ifTrue:
 						[meth declarationAt: formal put: (type last = $* ifTrue: [type, formal] ifFalse: [type, ' ', formal])]]]].
@@ -3017,9 +3017,9 @@ TMethod >> typeFor: aVariable in: aCodeGen [
 					ifTrue: [aCodeGen defaultType, ' ', varName]
 					ifFalse:
 						[(locals includes: varName) ifFalse: "don't provide type for locals"
-							[aCodeGen typeOfVariable: varName]]]) ifNotNil:
-		[:decl|
-		aCodeGen extractTypeFor: varName fromDeclaration: decl]
+							[aCodeGen typeOfVariable: varName  ]]]) 
+				ifNotNil: [:decl|
+						aCodeGen extractTypeFor: varName fromDeclaration: decl]
 ]
 
 { #category : #utilities }

smalltalksrc/VMMaker-OriginalTests/SpurImageTestResource.class.st

@@ -50,7 +50,7 @@ SpurImageTestResource >> emptyVM [
 { #category : #accessing }
 SpurImageTestResource >> initializedVM [
 	vmWithLoadedImage ifNil:
-		[vmWithLoadedImage := StackInterpreterSimulator newWithOptions: #(ObjectMemory Spur32BitMemoryManager).
+		[vmWithLoadedImage := StackInterpreterSimulator newWithOptions: #(ObjectMemory Spur32BitMemoryManager ImageReader SpurImageReader ImageWriter SpurImageWriter).
 		 vmWithLoadedImage
 			openOn: self class imageNameForTests extraMemory: 0.
 		vmWithLoadedImage objectMemory