1 files changed, 71 insertions, 0 deletions
diff --git a/module/c/flatten-begin.scm b/module/c/flatten-begin.scm
new file mode 100644
index 00000000..7543a5ac
--- /dev/null
+++ b/module/c/flatten-begin.scm
@@ -0,0 +1,71 @@
+(define-module (c flatten-begin)
+  :use-module (srfi srfi-1)
+  :use-module (ice-9 match)
+  :use-module (ice-9 control)
+  :export (flatten-begin remove-invalid-struct-like-declarations))
+
+(define (flatten-begin-1 forms)
+  (append-map
+   (lambda (form)
+     (match form
+       (('begin x ...) x)
+       (x (list x))))
+   forms))
+
+(define (flatten-begin form)
+  (match form
+    (`(begin ,x) (flatten-begin x))
+    (`(let () ,('let '() x ...)) `(let () ,(flatten-begin x)))
+    (('begin forms ...)
+     `(begin ,@(map flatten-begin
+                    (flatten-begin-1 forms))))
+    (('let '() forms ...)
+     `(let () ,@(map flatten-begin
+                     (flatten-begin-1 forms))))
+    ;; switch already has to traverse subforms in order to find its labels.
+    ;; See (for example) Duff's device
+    ;; (`(switch ,x (begin ,('let '() forms ...)))
+    ;;  `(let () (switch ,(flatten-begin x)
+    ;;                   ,@(map flatten-begin (flatten-begin-1 forms)))))
+    ((x ...) (map flatten-begin x))
+    (x x)))
+
+
+
+;; [A]
+;; ((type (struct
+;;            (named s)
+;;          (struct-declaration-list
+;;           (struct-declarator-list
+;;            (named x
+;;                   (specifier-qualifier-list
+;;                    (type int))))))))))
+
+
+(define (tree-valid? tree abandon)
+  (match tree
+    (`(struct-like-declaration ((type ,('struct body ...))))
+     `(struct-like-declaration ((type (struct ,@(tree-valid? body abandon))))))
+    (`(struct-like-declaration ((type ,('union body ...))))
+     `(struct-like-declaration ((type (union ,@(tree-valid? body abandon))))))
+    (('struct-like-declaration body ...)
+     (abandon #f))
+    (('struct-declaration-list body ...)
+     ;; Filters out case [A]
+     (for-each (match-lambda
+                 (`(specifier-qualifier-list (type ,((or 'struct 'union) body ...)))
+                  'noop)
+                 (('specifier-qualifier-list body ...)
+                  (abandon #f))
+                 (_ 'noop))
+               body)
+     `(struct-declaration-list ,@(tree-valid? body abandon)))
+    ((a b ...)
+     (cons (tree-valid? a abandon)
+           (tree-valid? b abandon)))
+    (x x)))
+
+(define (remove-invalid-struct-like-declarations lst)
+  (filter-map (lambda (tree)
+                (call/ec (lambda (abandon) (tree-valid? tree abandon))))
+              lst))