diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-07-21 16:04:56 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-07-21 17:28:19 +0200 |
commit | 0e3df321ab2fce795bdc6b9aeb92724733cf8ee0 (patch) | |
tree | 8370e465f2b16f46f623f3e77eef4b1be2219f92 /module/c/flatten-begin.scm | |
parent | Merge call-with-tmpfile and diffs for testrunner. (diff) | |
download | calp-0e3df321ab2fce795bdc6b9aeb92724733cf8ee0.tar.gz calp-0e3df321ab2fce795bdc6b9aeb92724733cf8ee0.tar.xz |
Major work on parser.
Diffstat (limited to 'module/c/flatten-begin.scm')
-rw-r--r-- | module/c/flatten-begin.scm | 71 |
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)) |