nyacc: cleaned up documentation
[mes.git] / module / nyacc / lang / c99 / util1.scm
1 ;;; lang/c/util1.scm
2 ;;;
3 ;;; Copyright (C) 2015,2016 Matthew R. Wette
4 ;;;
5 ;;; This program is free software: you can redistribute it and/or modify
6 ;;; it under the terms of the GNU General Public License as published by 
7 ;;; the Free Software Foundation, either version 3 of the License, or 
8 ;;; (at your option) any later version.
9 ;;;
10 ;;; This program is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 ;;; GNU General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU General Public License
16 ;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
17
18 ;; C parser utilities
19
20 (define-module (nyacc lang c99 util1)
21   #:export (c99-std-help
22             gen-gcc-defs
23             remove-inc-trees
24             merge-inc-trees!
25             elifify)
26   #:use-module (nyacc lang util)
27   #:use-module ((srfi srfi-1) #:select (append-reverse))
28   #:use-module (srfi srfi-2) ;; and-let*
29   #:use-module (sxml fold)
30   #:use-module (sxml match)
31   #:use-module (ice-9 popen)            ; gen-cc-defs
32   #:use-module (ice-9 rdelim)           ; gen-cc-defs
33   #:use-module (ice-9 regex)            ; gen-cc-defs
34 )
35
36 ;; include-helper for C99 std
37 (define c99-std-help
38   '(("alloca.h")
39     ("complex.h" "complex" "imaginary" "_Imaginary_I=C99_ANY" "I=C99_ANY")
40     ("ctype.h")
41     ("fenv.h" "fenv_t" "fexcept_t")
42     ("float.h" "float_t" "FLT_MAX=C99_ANY" "DBL_MAX=C99_ANY")
43     ("inttypes.h"
44      "int8_t" "uint8_t" "int16_t" "uint16_t" "int32_t" "uint32_t"
45      "int64_t" "uint64_t" "uintptr_t" "intptr_t" "intmax_t" "uintmax_t"
46      "int_least8_t" "uint_least8_t" "int_least16_t" "uint_least16_t"
47      "int_least32_t" "uint_least32_t" "int_least64_t" "uint_least64_t"
48      "imaxdiv_t")
49     ("limits.h"
50      "INT_MIN=C99_ANY" "INT_MAX=C99_ANY" "LONG_MIN=C99_ANY" "LONG_MAX=C99_ANY")
51     ("math.h" "float_t" "double_t")
52     ("regex.h" "regex_t" "regmatch_t")
53     ("setjmp.h" "jmp_buf")
54     ("signal.h" "sig_atomic_t")
55     ("stdarg.h" "va_list")
56     ("stddef.h" "ptrdiff_t" "size_t" "wchar_t")
57     ("stdint.h"
58      "int8_t" "uint8_t" "int16_t" "uint16_t" "int32_t" "uint32_t"
59      "int64_t" "uint64_t" "uintptr_t" "intptr_t" "intmax_t" "uintmax_t"
60      "int_least8_t" "uint_least8_t" "int_least16_t" "uint_least16_t"
61      "int_least32_t" "uint_least32_t" "int_least64_t" "uint_least64_t")
62     ("stdio.h" "FILE" "size_t")
63     ("stdlib.h" "div_t" "ldiv_t" "lldiv_t" "wchar_t")
64     ("string.h" "size_t")
65     ("strings.h" "size_t")
66     ("time.h" "time_t" "clock_t" "size_t")
67     ("unistd.h" "size_t" "ssize_t" "div_t" "ldiv_t")
68     ("wchar.h" "wchar_t" "wint_t" "mbstate_t" "size_t")
69     ("wctype.h" "wctrans_t" "wctype_t" "wint_t")
70     ))
71
72 ;; @deffn {Procedure} gen-gcc-defs args  [#:CC "clang"] => '(("ABC" . "123") ...)
73 ;; Generate a list of default defines produced by gcc (or clang).
74 ;; @end deffn
75 (define gen-gcc-defs
76   ;; @code{"gcc -dM -E"} will generate lines like @code{"#define ABC 123"}.
77   ;; We generate and return a list like @code{'(("ABC" . "123") ...)}.
78   (let ((rx (make-regexp "#define\\s+(\\S+)\\s+(.*)")))
79     (lambda* (args #:key (CC "gcc"))
80       (map
81        (lambda (l)
82          (let ((m (regexp-exec rx l)))
83            (cons (match:substring m 1) (match:substring m 2))))
84        (let ((ip (open-input-pipe (string-append CC " -dM -E - </dev/null"))))
85          (let iter ((lines '()) (line (read-line ip 'trim)))
86            (if (eof-object? line) lines
87                (iter (cons line lines) (read-line ip 'trim)))))))))
88
89 ;; @deffn {Procedure} remove-inc-trees tree
90 ;; Remove the trees included with cpp-include statements.
91 ;; @example
92 ;; '(... (cpp-stmt (include "<foo.h>" (trans-unit ...))) ...)
93 ;; => '(... (cpp-stmt (include "<foo.h>")) ...)
94 ;; @end example
95 ;; @end deffn
96 (define (remove-inc-trees tree)
97   (if (not (eqv? 'trans-unit (car tree))) (error "expecting c-tree"))
98   (let iter ((rslt (make-tl 'trans-unit))
99              ;;(head '(trans-unit)) (tail (cdr tree))
100              (tree (cdr tree)))
101     (cond
102      ((null? tree) (tl->list rslt))
103      ((and (eqv? 'cpp-stmt (car (car tree)))
104            (eqv? 'include (caadr (car tree))))
105       (iter (tl-append rslt `(cpp-stmt (include ,(cadadr (car tree)))))
106             (cdr tree)))
107      (else (iter (tl-append rslt (car tree)) (cdr tree))))))
108
109 ;; @deffn {Procedure} merge-inc-trees tree
110 ;; Remove the trees included with cpp-include statements.
111 ;; @example
112 ;; '(... (cpp-stmt (include "<foo.h>" (trans-unit (stmt ...))) ...)
113 ;; => '(... (stmt...) ...)
114 ;; @end example
115 ;; @end deffn
116 #;(define (Xmerge-inc-trees tree)
117   (if (not (eqv? 'trans-unit (car tree))) (error "expecting c-tree"))
118   (let iter ((rslt (make-tl 'trans-unit))
119              (tree (cdr tree)))
120     (cond
121      ((null? tree) (tl->list rslt))
122      ((and (eqv? 'cpp-stmt (caar tree)) (eqv? 'include (cadar tree)))
123       (iter (tl-extend rslt (cdr (merge-inc-trees (cdddar tree)))) (cdr tree)))
124      (else (iter (tl-append rslt (car tree)) (cdr tree))))))
125
126
127 ;; @deffn {Procedure} merge-inc-trees! tree => tree
128 ;; This will (recursively) merge code from cpp-includes into the tree.
129 ;; @example
130 ;; (trans-unit
131 ;;  (decl (a))
132 ;;  (cpp-stmt (include "<hello.h>" (trans-unit (decl (b)))))
133 ;;  (decl (c)))
134 ;; =>
135 ;; (trans-unit (decl (a)) (decl (b)) (decl (c)))
136 ;; @end example
137 ;; @end deffn
138 (define (merge-inc-trees! tree)
139
140   ;; @item find-span (trans-unit a b c) => ((a . +->) . (c . '())
141   (define (find-span tree)
142     (cond
143      ((not (pair? tree)) '())           ; maybe parse failed
144      ((not (eqv? 'trans-unit (car tree))) (error "expecting c-tree"))
145      ((null? (cdr tree)) (error "null c99-tree"))
146      (else
147       (let ((fp tree))                  ; first pair
148         (let iter ((lp tree)            ; last pair
149                    (np (cdr tree)))     ; next pair
150           (cond
151            ((null? np) (cons (cdr fp) lp))
152            ;; The following is an ugly hack to find cpp-include
153            ;; with trans-unit attached.
154            ((and-let* ((expr (car np))
155                        ((eqv? 'cpp-stmt (car expr)))
156                        ((eqv? 'include (caadr expr)))
157                        (rest (cddadr expr))
158                        ((pair? rest))
159                        (span (find-span (car rest))))
160                       (set-cdr! lp (car span))
161                       (iter (cdr span) (cdr np))))
162            (else
163             (set-cdr! lp np)
164             (iter np (cdr np)))))))))
165
166   ;; Use cons to generate a new reference:
167   ;; (cons (car tree) (car (find-span tree)))
168   ;; or not:
169   (find-span tree)
170   tree)
171
172
173 ;; @deffn {Procedure} elifify tree => tree
174 ;; This procedure will find patterns of
175 ;; @example
176 ;; (if cond-1 then-part-1
177 ;;            (if cond-2 then-part-2
178 ;;                       else-part-2
179 ;; @end example
180 ;; @noindent
181 ;; and convert to
182 ;; @example
183 ;; (if cond-1 then-part-1
184 ;;            (elif cond-2 then-part-2)
185 ;;            else-part-2
186 ;; @end example
187 ;; @end deffn
188 (define (elifify tree)
189   (define (fU tree)
190     (sxml-match tree
191       ((if ,x1 ,t1 (if ,x2 ,t2 (else-if ,x3 ,t3) . ,rest))
192        `(if ,x1 ,t1 (else-if ,x2 ,t2) (else-if ,x3 ,t3) . ,rest))
193       ((if ,x1 ,t1 (if ,x2 ,t2 . ,rest))
194        `(if ,x1 ,t1 (else-if ,x2 ,t2) . ,rest))
195       (,otherwise
196        tree)))
197   (foldt fU identity tree))
198        
199 ;; --- last line ---