alex-eg/sex
1
0
Fork 1
Code Issues 3 Pull Requests 1 Actions Packages Projects 1 Releases Wiki Activity

optimize fmt-c-writer type unwrapping

Browse Source
This commit is contained in:
alex-eg
2025-10-30 12:22:18 +03:00
parent 03684bb687
commit 3a9300ba72
2 changed files with 17 additions and 19 deletions
Download Patch File Download Diff File Expand all files Collapse all files

20
fmt-c-writer.scm
View File

@@ -46,6 +46,12 @@
(unkebabify atom) (unkebabify atom)
atom)))) atom))))
(define (maybe-unwrap-type type)
(if (and (list? type)
(= 1 (length type)))
(car type)
type))
(define (make-field-access form) (define (make-field-access form)
(assert (assert
(= 2 (length form)) "Wrong field access format") (= 2 (length form)) "Wrong field access format")
@@ -111,19 +117,13 @@
(if (integer? (last array-type)) (if (integer? (last array-type))
;; sized array ;; sized array
(let* ((type-list (drop-right array-type 1)) (let* ((type-list (drop-right array-type 1))
(type (if (and (list? (car type-list)) (type (maybe-unwrap-type type-list))
(= 1 (length type-list)))
(car type-list)
type-list))
(size (last array-type))) (size (last array-type)))
`(%array ,(walk-type type) `(%array ,(walk-type type)
,size)) ,size))
;; sugar for pointer... Do we really need it? Guess why not, ;; sugar for pointer... Do we really need it? Guess why not,
;; it's a strong semantic cue ;; it's a strong semantic cue
`(%array ,(walk-type (if (and (list? (car array-type)) `(%array ,(walk-type (maybe-unwrap-type array-type)))))
(= 1 (length array-type)))
(car array-type)
array-type)))))
(('fn arglist ret-type) (('fn arglist ret-type)
`(%fun ,(walk-type ret-type) ,(walk-arglist arglist))) `(%fun ,(walk-type ret-type) ,(walk-arglist arglist)))
@@ -179,9 +179,7 @@
;; 1 element args are always type ;; 1 element args are always type
((_) (walk-type x)) ((_) (walk-type x))
((var . type) (append (list (walk-type (if (= 1 (length type)) ((var . type) (append (list (walk-type (maybe-unwrap-type type)))
(car type)
type)))
(list (walk-type var)))))) (list (walk-type var))))))
form)) form))

16
tests/fmt-c-writer.scm
View File

@@ -26,7 +26,7 @@
(walk-type '(¤ (const char)))) (walk-type '(¤ (const char))))
(test (test
'(%array (float) 8) '(%array float 8)
(walk-type '(¤ float 8))) (walk-type '(¤ float 8)))
(test (test
@@ -40,16 +40,16 @@
(walk-type '(const * const char))) (walk-type '(const * const char)))
(test (test
'(%fun void ((int) (float) (struct what *))) '(%fun void ((int) (float) (%array (struct what * const))))
(walk-type '(fn ((int) (float) (* struct what)) void))) (walk-type '(fn ((int) (float) (¤ (const * struct what))) void)))
(test (test
'(%fun void ((int) (%array (float)) (struct what *))) '(%fun void ((int) (%array float) (%array (struct what * const))))
(walk-type '(fn ((int) (¤ float) (* struct what)) void))) (walk-type '(fn ((int) (¤ float) (¤ (const * struct what))) void)))
;;; Variable defs ;;; Variable defs
(test (test
'(%var (%array (float) 8) a) '(%var (%array float 8) a)
(walk-var '(var a (¤ float 8)))) (walk-var '(var a (¤ float 8))))
(test (test
@@ -82,7 +82,7 @@
;;; Fn defs ;;; Fn defs
(test (test
'(%fun void puk ((int) (%array (float) 8))) '(%fun void puk ((int) (%array float 8)))
(walk-fn-def '(fn puk ((int) (¤ float 8)) void))) (walk-fn-def '(fn puk ((int) (¤ float 8)) void)))
(test (test
@@ -129,7 +129,7 @@
(test (test
'(struct mega_kebab ((int a) '(struct mega_kebab ((int a)
((struct ((int year) (int month) (int day))) dob) ((struct ((int year) (int month) (int day))) dob)
((%fun int ((int) (%array (int)))) min))) ((%fun int ((int) (%array int))) min)))
(walk-struct '(struct mega-kebab (walk-struct '(struct mega-kebab
((a int) ((a int)
(dob (struct ((year int) (dob (struct ((year int)