(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))