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