From 0e3df321ab2fce795bdc6b9aeb92724733cf8ee0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Thu, 21 Jul 2022 16:04:56 +0200
Subject: Major work on parser.

---
 module/c/flatten-begin.scm | 71 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 71 insertions(+)
 create mode 100644 module/c/flatten-begin.scm

(limited to 'module/c/flatten-begin.scm')

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))
-- 
cgit v1.2.3