1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
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))
|
