From e7122bdbd50e839dd6e5617b3ce7be1e1d2f5ea2 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Wed, 22 Oct 2025 16:59:15 +0300 Subject: [PATCH] fix arrays of structs, multiple struct fields with same type --- fmt-c-writer.scm | 41 ++++++++++++++++++++++++++--------------- tests/fmt-c-writer.scm | 20 ++++++++++++++++++-- 2 files changed, 44 insertions(+), 17 deletions(-) diff --git a/fmt-c-writer.scm b/fmt-c-writer.scm index 3c2176d..e3b9dd4 100644 --- a/fmt-c-writer.scm +++ b/fmt-c-writer.scm @@ -84,7 +84,7 @@ ;; note: [...] is actually (¤ ...) after reading ;; (var c (fn ((int) (float)) void)) -> (%var (%fun void ((int) (float))) c) `(%var - ,(walk-type (flatten (third form))) + ,(walk-type (third form)) ,(atom-to-fmt-c (second form)) . ,(if (null? (drop form 3)) @@ -104,23 +104,26 @@ (('¤ . array-type) (if (integer? (last array-type)) ;; sized array - (let ((type (drop-right array-type 1)) - (size (last array-type))) - `(%array ,(walk-type (flatten type)) + (let* ((type-list (drop-right array-type 1)) + (type (if (and (list? (car type-list)) + (= 1 (length type-list))) + (car type-list) + type-list)) + (size (last array-type))) + `(%array ,(walk-type type) ,size)) ;; sugar for pointer... Do we really need it? Guess why not, ;; it's a strong semantic cue - `(%array ,(walk-type (flatten array-type))))) + `(%array ,(walk-type (if (and (list? (car array-type)) + (= 1 (length array-type))) + (car array-type) + array-type))))) (('fn arglist ret-type) `(%fun ,(walk-type ret-type) ,(walk-arglist arglist))) ;; Special case: nested structs/unions - (('struct ((field-names field-types) ...) . attrs) - `(struct ,(process-struct-fields field-names field-types) - . ,(map atom-to-fmt-c attrs))) - (('union ((field-names field-types) ...) . attrs) - `(union ,(process-struct-fields field-names field-types) - . ,(map atom-to-fmt-c attrs))) + ((or ('struct . _) + ('union . _)) (walk-struct form)) (else (type-convert-to-c form)))) @@ -181,14 +184,22 @@ (walk-fn-def form) (cons '%prototype (cdr (walk-fn-def form))))) -(define (process-struct-fields names types) - (zip (map walk-type types) (map atom-to-fmt-c names))) +(define (process-struct-fields fields) + (map (fn + (let ((type (walk-type (last x)))) + (cons type (map atom-to-fmt-c (drop-right x 1))))) + fields)) (define (walk-struct form) (match form - ((type name ((field-names field-types) ...) . attrs) + ((type (fields ...) . attrs) ; anonymous struct + `(,type ,(process-struct-fields fields) + . ,(map atom-to-fmt-c attrs))) + ((type name) ; simple 'struct whatever', like in variable def + `(,type ,(atom-to-fmt-c name))) + ((type name (fields ...) . attrs) `(,type ,(atom-to-fmt-c name) - ,(process-struct-fields field-names field-types) + ,(process-struct-fields fields) . ,(map atom-to-fmt-c attrs))) (else (error "Malformed aggregate definition " form)))) diff --git a/tests/fmt-c-writer.scm b/tests/fmt-c-writer.scm index 2c898e3..e9cf699 100644 --- a/tests/fmt-c-writer.scm +++ b/tests/fmt-c-writer.scm @@ -10,8 +10,8 @@ (walk-type '(¤ const char 512))) (test - '(%array (float 512)) - (walk-type '(¤ (float 512)))) + '(%array (float) 512) + (walk-type '(¤ (float) 512))) (test '(%array (const char) 512) @@ -102,6 +102,22 @@ '(struct no_kebab ((int a) (float f))) (walk-struct '(struct no-kebab ((a int) (f float))))) + (test + '(struct settings ((u32 x y w h) + ((%array (struct ((float r g b a))) 4) colors))) + (walk-struct + '(struct settings + ((x y w h u32) + (colors [¤ struct ((r g b a float)) 4]))))) + + (test + '(struct settings ((u32 x y w h) + ((%array (struct color ((float r g b a))) 4) colors))) + (walk-struct + '(struct settings + ((x y w h u32) + (colors [¤ struct color ((r g b a float)) 4]))))) + (test '(struct mega_kebab ((int a) ((struct ((int year) (int month) (int day))) dob)