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

fix variuos struct-related issues in fmt-c

Browse Source 
There were bugs, when struct in arg list and pointers to structs among
struct fields produces such code as:

(fn puk ((arg (* struct foo))) ...) -> void puk(struct foo { *; } arg)

(struct l ((next (* struct l)))) -> struct l { struct l { *; } next };

And so on.
This commit is contained in:
alex-eg
2025-10-21 21:37:59 +03:00
committed by Pavel Kulyov
parent 3d11426165
commit 2228ab3b50
1 changed files with 40 additions and 3 deletions
Download Patch File Download Diff File Expand all files Collapse all files

43
fmt-c.scm
View File

@@ -9,6 +9,7 @@
(declare (unit fmt-c)) (declare (unit fmt-c))
(import fmt (import fmt
srfi-1
srfi-13) srfi-13)
(define (fmt-in-macro? st) (fmt-ref st 'in-macro?)) (define (fmt-in-macro? st) (fmt-ref st 'in-macro?))
@@ -557,10 +558,13 @@
;; data structures ;; data structures
(define (c-struct/aux type x . o) (define (c-struct/aux type x . o)
;; can be just pointer to SUC, need to support such case:
;; struct whatever * - body is just '*'
(let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x)) (let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x))
(body (if name (if (not (null? o)) (car o) '()) x)) (body (if name (if (not (null? o)) (car o) '()) x))
(o (if (null? o) o (cdr o)))) (o (if (null? o) o (cdr o))))
(if (not (null? body)) (if (and (not (null? body))
(not (eq? '* body)))
(c-wrap-stmt (c-wrap-stmt
(cat (cat
(c-braced-block (c-braced-block
@@ -572,7 +576,13 @@
(c-wrap-stmt (c-expr body)))))) (c-wrap-stmt (c-expr body))))))
(if (pair? o) (cat " " (apply c-begin o)) (dsp "")))) (if (pair? o) (cat " " (apply c-begin o)) (dsp ""))))
(c-wrap-stmt (c-wrap-stmt
(cat type (if (and name (not (equal? name ""))) (cat " " name) "")))))) (cat type
(if (and name (not (equal? name "")))
(cat " " name)
"")
(if (not (null? body))
(cat body)
""))))))
(define (c-struct . args) (apply c-struct/aux "struct" args)) (define (c-struct . args) (apply c-struct/aux "struct" args))
(define (c-union . args) (apply c-struct/aux "union" args)) (define (c-union . args) (apply c-struct/aux "union" args))
@@ -614,7 +624,7 @@
(define (c-param x) (define (c-param x)
(cond (cond
((procedure? x) x) ((procedure? x) x)
((pair? x) (c-type (car x) (cadr x))) ((pair? x) (c-param-type (car x) (cadr x)))
(else (error "missing type" x)))) (else (error "missing type" x))))
(define (c-field x) (define (c-field x)
@@ -688,6 +698,33 @@
(else (else
(cat (if (eq? '%pointer type) '* type) (if name (cat " " name) "")))))) (cat (if (eq? '%pointer type) '* type) (if name (cat " " name) ""))))))
(define (c-param-type type . o)
(let ((name (and (pair? o) (car o))))
(cond
((pair? type)
(case (car type)
((%fun)
(cat (c-type (cadr type) #f)
" (*" (or name "") ")("
(fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
((%array)
(let ((name (cat name "[" (if (pair? (cddr type))
(c-expr (caddr type))
"")
"]")))
(c-type (cadr type) name)))
((%pointer *)
(let ((name (cat "*" (if name (c-expr name) ""))))
(c-type (cadr type)
(if (and (pair? (cadr type)) (eq? '%array (caadr type)))
(c-paren name)
name))))
(else (fmt-join/last c-expr (lambda (x) (c-type x name)) type " "))))
((not type)
(lambda (st) ((c-type (or (fmt-default-type st) 'int) name) st)))
(else
(cat (if (eq? '%pointer type) '* type) (if name (cat " " name) ""))))))
(define (c-var type name . init) (define (c-var type name . init)
(c-wrap-stmt (c-wrap-stmt
(if (pair? init) (if (pair? init)