eb717142a733e44a02ac2b9364c49ec791ee0e0a
[mes.git] / module / nyacc / lang / c99 / cppbody.scm
1 ;;; nyacc/lang/c99/cppbody.scm
2 ;;;
3 ;;; Copyright (C) 2016-2017 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 (use-modules (ice-9 match))
19
20 (define c99-std-defs
21   '("__DATE__" "__FILE__" "__LINE__" "__STDC__" "__STDC_HOSTED__"
22     "__STDC_VERSION__" "__TIME__"))
23
24 (define (c99-std-def? str)
25   (let iter ((defs c99-std-defs))
26     (cond
27      ((null? defs) #f)
28      ((string=? (car defs) str) #t)
29      (else (iter (cdr defs))))))
30
31 (define (c99-std-val str)
32   (cond
33    ((string=? str "__DATE__") "M01 01 2001")
34    ((string=? str "__FILE__") "(unknown)")
35    ((string=? str "__LINE__") 0)
36    ((string=? str "__STDC__") 1)
37    ((string=? str "__STDC_HOSTED__") 0)
38    ((string=? "__STDC_VERSION__") 201701)
39    ((string=? "__TIME__") "00:00:00")
40    (else #f)))
41
42 (define (cpp-err fmt . args)
43   (apply throw 'cpp-error fmt args))
44
45 ;;.@deffn skip-il-ws ch
46 ;; Skip in-line whitespace
47 (define skip-il-ws
48   (let ((il-ws (list->char-set '(#\space #\tab))))
49     (lambda (ch)
50       (cond
51        ((eof-object? ch) ch)
52        ((char-set-contains? il-ws ch) (skip-il-ws (read-char)))
53        (else ch)))))
54
55 ;; Since we want to be able to get CPP statements with comment in tact
56 ;; (e.g., for passing to @code{pretty-print-c99}) we need to remove
57 ;; comments when parsing CPP expressions.  We convert a comm-reader
58 ;; into a comm-skipper here.  And from that generate a lexer generator.
59 (define cpp-comm-skipper
60   (let ((reader (make-comm-reader '(("/*" . "*/")))))
61     (lambda (ch)
62       (reader ch #f))))
63
64 ;; generate a lexical analyzer per string
65 (define gen-cpp-lexer
66   (make-lexer-generator mtab #:comm-skipper cpp-comm-skipper))
67
68 ;; @deffn parse-cpp-expr text => tree
69 ;; Given a string returns a cpp parse tree.  This is called by
70 ;; @code{eval-cpp-expr}.  The text will have had all CPP defined symbols
71 ;; expanded already so no identifiers should appear in the text.
72 ;; A @code{cpp-error} will be thrown if a parse error occurs.
73 (define (parse-cpp-expr text)
74   (with-throw-handler
75    'nyacc-error
76    (lambda ()
77      (with-input-from-string text
78        (lambda () (raw-parser (gen-cpp-lexer)))))
79    (lambda (key fmt . args)
80      (apply throw 'cpp-error fmt args))))
81
82 ;; @deffn eval-cpp-expr tree dict => datum
83 ;; Evaluate a tree produced from @code{parse-cpp-expr}.
84 ;; The tree passed to this routine is 
85 (define (eval-cpp-expr tree dict)
86   (letrec
87       ((tx (lambda (tr ix) (list-ref tr ix)))
88        (tx1 (lambda (tr) (tx tr 1)))
89        (ev (lambda (ex ix) (eval-expr (list-ref ex ix))))
90        (ev1 (lambda (ex) (ev ex 1)))    ; eval expr in arg 1
91        (ev2 (lambda (ex) (ev ex 2)))    ; eval expr in arg 2
92        (ev3 (lambda (ex) (ev ex 3)))    ; eval expr in arg 3
93        (eval-expr
94         (lambda (tree)
95           (case (car tree)
96             ((fixed) (string->number (tx1 tree)))
97             ((char) (char->integer (tx1 tree)))
98             ((defined) (if (assoc-ref dict (tx1 tree)) 1 0))
99             ((pre-inc post-inc) (1+ (ev1 tree)))
100             ((pre-dec post-dec) (1- (ev1 tree)))
101             ((pos) (ev1 tree))
102             ((neg) (- (ev1 tree)))
103             ((bw-not) (bitwise-not (ev1 tree)))
104             ((not) (if (zero? (ev1 tree)) 1 0))
105             ((mul) (* (ev1 tree) (ev2 tree)))
106             ((div) (/ (ev1 tree) (ev2 tree)))
107             ((mod) (modulo (ev1 tree) (ev2 tree)))
108             ((add) (+ (ev1 tree) (ev2 tree)))
109             ((sub) (- (ev1 tree) (ev2 tree)))
110             ((lshift) (bitwise-arithmetic-shift-left (ev1 tree) (ev2 tree)))
111             ((rshift) (bitwise-arithmetic-shift-right (ev1 tree) (ev2 tree)))
112             ((lt) (if (< (ev1 tree) (ev2 tree)) 1 0))
113             ((le) (if (<= (ev1 tree) (ev2 tree)) 1 0))
114             ((gt) (if (> (ev1 tree) (ev2 tree)) 1 0))
115             ((ge) (if (>= (ev1 tree) (ev2 tree)) 1 0))
116             ((equal) (if (= (ev1 tree) (ev2 tree)) 1 0))
117             ((noteq) (if (= (ev1 tree) (ev2 tree)) 0 1))
118             ((bw-or) (bitwise-ior (ev1 tree) (ev2 tree)))
119             ((bw-xor) (bitwise-xor (ev1 tree) (ev2 tree)))
120             ((bw-and) (bitwise-and (ev1 tree) (ev2 tree)))
121             ((or) (if (and (zero? (ev1 tree)) (zero? (ev2 tree))) 0 1))
122             ((and) (if (or (zero? (ev1 tree)) (zero? (ev2 tree))) 0 1))
123             ((cond-expr) (if (zero? (ev1 tree)) (ev3 tree) (ev2 tree)))
124             ((ident) (cpp-err "undefined identifier: ~S" (cadr tree)))
125             (else (error "incomplete implementation"))))))
126     (eval-expr tree)))
127
128 ;; Note: scan-cpp-input scans replacement text.  When identifiers are found
129 ;; they are tested for expansion as follows:
130 ;; @enumerate
131 ;; @item If already expanded, then ignore.
132 ;; @item If followed by @code{(}, then use @code{collect-args} to get the
133 ;; arguments and ...
134 ;; @item Otherwise insert the replacement text and continue scanning (at
135 ;; first character of new replacement text.
136 ;; @end enumerate
137
138 ;; @deffn rtokl->string tokl => string
139 ;; Convert reverse token-list to string.
140 (define (rtokl->string tokl)
141   ;; need to cover: comm ident string arg
142   ;;(let iter ((stl '()) (chl '()) (nxt #f) (tkl tokl)) ;; more efficient
143   (let iter ((stl '()) (tkl tokl))
144     (match tkl
145       ('()
146        (apply string-append stl))
147
148       ((('arg . arg) 'dhash (key . val) . rest)
149        (iter (cons (string-append val arg) stl) (list-tail tkl 3)))
150
151       (((key . val) 'dhash ('arg . arg) . rest)
152        (iter (cons (string-append arg val) stl) (list-tail tkl 3)))
153
154       ((('arg . arg) 'hash . rest)
155        (iter (cons (string-append "\"" arg "\"") stl) (list-tail tkl 2)))
156
157       ((('comm . val) . rest)
158        (iter (cons (string-append "/*" val " */") stl) (cdr tkl)))
159
160       ((('ident . rval) ('ident . lval) . rest)
161        (iter (cons* " " rval stl) (cdr tkl)))
162
163       (((key . val) . rest)
164        (iter (cons val stl) (cdr tkl)))
165
166       (((? char? ch) . rest)
167        (iter (cons (string ch) stl) rest))
168
169       (otherwise
170        (error "no match" tkl)))))
171
172 ;; @deffn scan-cpp-input argd used dict end-tok => string
173 ;; Process replacement text from the input port and generate a (reversed)
174 ;; token-list.  If end-tok, stop at, and push back, @code{,} or @code{)}.
175 ;; If end-tok is @code{,} then read until @code{,} or @code{(}.
176 ;; The argument @var{argd} is a dictionary (argument name, argument
177 ;; value) pairs which will be expanded as needed.  This routine is called
178 ;; by collect-args, expand-cpp-repl and cpp-expand-text.
179 (define (scan-cpp-input argd dict used end-tok)
180   ;; Works like this: scan for tokens (comments, parens, strings, char's, etc).
181   ;; Tokens are collected in a (reverse ordered) list (tkl) and merged together
182   ;; to a string on return using @code{rtokl->string}.
183
184   ;; Turn reverse chl into a string and insert it into the string list stl.
185   (define (add-chl chl stl)
186     (if (null? chl) stl (cons (list->string (reverse chl)) stl)))
187
188   (define conjoin string-append)
189
190   ;; We just scanned "defined", now need to scan the arg to inhibit expansion.
191   ;; For example, we have scanned "defined"; we now scan "(FOO)" or "FOO", and
192   ;; return "defined(FOO)".  We use ec (end-char) as terminal char:
193   ;; #\) if starts with #( or #\nul if other.
194   (define (scan-defined-arg)
195     (let* ((ch (skip-il-ws (read-char)))
196            (ec (if (char=? ch #\() #\) #\null)))
197       (let iter ((chl '(#\()) (ec ec) (ch (if (char=? ec #\)) (read-char) ch)))
198         (cond
199          ((eof-object? ch)
200           (if (char=? ec #\null)
201               (string-append "defined" (list->string (reverse (cons #\) chl))))
202               (cpp-err "illegal argument to `defined'")))
203          ((char-set-contains? c:ir ch)
204           (iter (cons ch chl) ec (read-char)))
205          ((char=? ec #\))
206           (if (char=? #\) (skip-il-ws ch))
207               (string-append "defined" (list->string (reverse (cons #\) chl))))
208               (cpp-err "garbage in argument to `defined'")))
209          ((char=? ec #\null) ;; past identifier
210           (string-append "defined" (list->string (reverse (cons #\) chl)))))
211          (else
212           (cpp-err "illegal argument to  `defined'"))))))
213
214   (let iter ((tkl '())          ; token list (as list of strings)
215              (lvl 0)            ; level
216              (ch (read-char)))  ; next character
217     (cond
218      ;; have item to add, but first add in char's
219      ;;(nxt (iter (cons nxt (add-chl chl tkl)) '() #f lvl ch))
220      ;; If end of string or see end-ch at level 0, then return.
221      ((eof-object? ch) (rtokl->string tkl))
222      
223      ((and (eqv? end-tok ch) (zero? lvl))
224       (unread-char ch) (rtokl->string tkl))
225      ((and end-tok (char=? #\) ch) (zero? lvl))
226       (unread-char ch) (rtokl->string tkl))
227      
228      ((read-c-comm ch #f) =>
229       (lambda (cp) (iter (acons `comm cp tkl) lvl (read-char))))
230      
231      ((char-set-contains? c:ws ch) (iter tkl lvl (read-char)))
232      ((char=? #\( ch) (iter (cons ch tkl) (1+ lvl) (read-char)))
233      ((char=? #\) ch) (iter (cons ch tkl) (1- lvl) (read-char)))
234      ((char=? #\# ch)
235       (let ((ch (read-char)))
236         (if (eqv? ch #\#)
237             (iter (cons 'dhash tkl) lvl (read-char))
238             (iter (cons 'hash tkl) lvl ch))))
239      ((read-c-string ch) =>
240       (lambda (st) (iter (acons 'string st tkl) lvl (read-char))))
241      ((read-c-ident ch) =>
242       (lambda (iden)
243         (if (equal? iden "defined")
244             ;; "defined" is a special case
245             (let ((arg (scan-defined-arg)))
246               (iter (acons 'defined arg tkl) lvl (read-char)))
247             ;; otherwise ...
248             (let* ((aval (assoc-ref argd iden))  ; lookup argument
249                    (rval (assoc-ref dict iden))) ; lookup macro def
250               (cond
251                ((member iden used)      ; name used
252                 (iter (cons iden tkl) lvl (read-char)))
253                (aval                    ; arg ref
254                 (iter (acons 'arg aval tkl) lvl (read-char)))
255                ((string? rval)          ; cpp repl
256                 (iter (acons 'string rval tkl) lvl (read-char)))
257                ((pair? rval)            ; cpp macro
258                 (let* ((argl (car rval)) (text (cdr rval))
259                        (argd (collect-args argl argd dict used))
260                        (newl (expand-cpp-repl text argd dict (cons iden used))))
261                   (iter (acons 'string newl tkl) lvl (read-char))))
262                (else                    ; normal identifier
263                 (iter (acons 'ident iden tkl) lvl (read-char))))))))
264      (else
265       (iter (cons ch tkl) lvl (read-char))))))
266
267 ;; @deffn collect-args argl argd dict used => argd
268 ;; to be documented
269 ;; I think argd is a passthrough for scan-cpp-input
270 ;; argl: list of formal arguments in #define
271 ;; argd: used? (maybe just a pass-through for scan-cpp-input
272 ;; dict: dict of macro defs
273 ;; used: list of already expanded macros
274 ;; TODO clean this up
275 ;; should be looking at #\( and eat up to matching #\)
276 (define (collect-args argl argd dict used)
277   (let iter ((argl argl) (argv '()) (ch (skip-il-ws (read-char))))
278     ;; ch should always be #\(, #\, or #\)
279     (cond
280      ((eqv? ch #\)) (reverse argv))
281      ((null? argl) (cpp-err "arg count"))
282      ((and (null? (cdr argl)) (string=? (car argl) "..."))
283       (let ((val (scan-cpp-input argd dict used #\))))
284         (iter (cdr argl) (acons "__VA_ARGS__" val argv) (read-char))))
285      ((or (eqv? ch #\() (eqv? ch #\,))
286       (let ((val (scan-cpp-input argd dict used #\,)))
287         (iter (cdr argl) (acons (car argl) val argv) (read-char))))
288      (else (error "coding error, ch=" ch)))))
289
290 ;; @deffn expand-cpp-repl
291 ;; to be documented
292 (define (expand-cpp-repl repl argd dict used)
293   (with-input-from-string repl
294     (lambda () (scan-cpp-input argd dict used #f))))
295
296 ;; @deffn cpp-expand-text text dict => string
297 (define (cpp-expand-text text dict)
298   (with-input-from-string text
299     (lambda () (scan-cpp-input '() dict '() #f))))
300
301 ;; @deffn expand-cpp-mref ident dict => repl|#f
302 ;; Given an identifier seen in C99 input, this checks for associated
303 ;; definition in @var{dict} (generated from CPP defines).  If found,
304 ;; the expansion is returned as a string.  If @var{ident} refers
305 ;; to a macro with arguments, then the arguments will be read from the
306 ;; current input.
307 (define (expand-cpp-mref ident dict . rest)
308   (let ((used (if (pair? rest) (car rest) '()))
309         (rval (assoc-ref dict ident)))
310     (cond
311      ((not rval) #f)
312      ((member ident used) ident)
313      ((string? rval)
314       (let ((expd (expand-cpp-repl rval '() dict (cons ident used))))
315         expd))
316      ((pair? rval)
317       (let* ((argl (car rval)) (repl (cdr rval))
318              (argd (collect-args argl '() dict '()))
319              (expd (expand-cpp-repl repl argd dict (cons ident used))))
320         expd)))))
321
322 ;;; --- last line ---