C translation: header STON write

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,70 @@ CCodeGeneratorGlobalStructure >> emitGlobalStructFlagOn: aStream [
 		cr
 ]
 
+{ #category : #'CAST translation' }
+CCodeGeneratorGlobalStructure >> generateCASTWithFieldsDo: 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 typeOfVariable: aTSendNode receiver name.
+	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 typeOfVariable: aTSendNode receiver name.
+
+	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: #generateCASTWithFieldsDo:.
+
+]
+
 { #category : #public }
 CCodeGeneratorGlobalStructure >> isGlobalStructureBuild [
 	^true

smalltalksrc/Slang/SlangStructType.class.st

@@ -210,3 +210,17 @@ SlangStructType class >> typeForSelf [
 SlangStructType class >> voidStructTypeCache [
 	StructTypeNameCache := nil
 ]
+
+{ #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/VMMaker/ComposedImageWriter.class.st

@@ -7,6 +7,39 @@ Class {
 	#category : #'VMMaker-ImageFormat'
 }
 
+{ #category : #'file primitives' }
+ComposedImageWriter >> fprintf: aStream _: format [ 
+
+	<doNotGenerate>
+	^ self fprintf: aStream format: format arguments: { }
+]
+
+{ #category : #'file primitives' }
+ComposedImageWriter >> fprintf: aStream _: format _: aValue [ 
+
+	<doNotGenerate>
+	^ self fprintf: aStream format: format arguments: { aValue }
+]
+
+{ #category : #'file primitives' }
+ComposedImageWriter >> fprintf: aStream _: format _: aValue _: otherValue [
+
+	<doNotGenerate>
+	^ self fprintf: aStream format: format arguments: { aValue. otherValue }
+]
+
+{ #category : #'file primitives' }
+ComposedImageWriter >> fprintf: aStream format: aFormat arguments: arguments [
+
+	<doNotGenerate>
+	| printf |
+	printf := PrintfFormatString new setFormat: aFormat.
+
+	aStream nextPutAll: (printf
+			 printf: arguments;
+			 string)
+]
+
 { #category : #writing }
 ComposedImageWriter >> initialize [ 
 
@@ -30,6 +63,23 @@ ComposedImageWriter >> writeHeaderFile: imageFileName fromHeader: header [
 
 ]
 
+{ #category : #writing }
+ComposedImageWriter >> writeHeaderSTON: header toFile: f [
+
+	| fieldHasNilValue |
+
+	header withStructNameDo: [ :name | self fprintf: f _: '%s {\n' _: name ].
+	header withFieldsDo: [ :fieldName :fieldValue |
+		fieldValue 
+			ifNil: [ 	fieldHasNilValue := true ]
+			ifNotNil: [  
+				fieldHasNilValue := false.			
+				self fprintf: f _: '\t#%s : %ld' _: fieldName _: fieldValue ]]
+		separatedBy: [ fieldHasNilValue ifFalse: [self fprintf: f _: ',\n'] ].
+
+	self fprintf: f _: '\n}'. 
+]
+
 { #category : #api }
 ComposedImageWriter >> writeImageFile: imageFileName fromHeader: header [
 

smalltalksrc/VMMakerTests/VMImageHeaderWritingTest.class.st

@@ -157,3 +157,35 @@ VMImageHeaderWritingTest >> testWritingImageWritesCorrectSpecialObjectsArrayOop
 
 	self assert: header initialSpecialObjectsOop equals: memory specialObjectsOop
 ]
+
+{ #category : #tests }
+VMImageHeaderWritingTest >> testWritingSTONHeader [
+
+	| header writtenHeader |
+
+	imageWriterClass ~= ComposedImageWriter ifTrue: [ ^ self skip ].
+
+	header := interpreter newHeader.
+
+	writtenHeader := (self imageFileName asFileReference  / 'header.ston') contents.
+
+	self assert: writtenHeader equals: (STON toStringPretty: header).
+]
+
+{ #category : #tests }
+VMImageHeaderWritingTest >> testWritingSTONSegment [
+
+	| header writtenHeader segmentMetadata |
+
+	imageWriterClass ~= ComposedImageWriter ifTrue: [ ^ self skip ].
+
+	header := interpreter newHeader.
+
+	writtenHeader := (self imageFileName asFileReference  / 'seg0.ston') contents.
+
+	segmentMetadata := ComposedSegmentMetadataStruct new.
+	segmentMetadata segStart: header oldBaseAddr.
+	segmentMetadata segSize: header dataSize.
+
+	self assert: writtenHeader equals: (STON toStringPretty: segmentMetadata).
+]