nyacc: minor cpp fixes
[mes.git] / module / nyacc / lang / c99 / cpp.scm
1 ;;; lang/c/cpp.scm
2 ;;;
3 ;;; Copyright (C) 2015-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 ;; C preprocessor.  This is not complete.
19
20 (define-module (nyacc lang c99 cpp)
21   #:export (parse-cpp-stmt
22             cpp-line->stmt
23             parse-cpp-expr
24             eval-cpp-expr
25             cpp-expand-text
26             expand-cpp-macro-ref
27             )
28   #:use-module (nyacc parse)
29   #:use-module (nyacc lex)
30   #:use-module (nyacc lang util)
31   #:use-module (rnrs arithmetic bitwise)
32   #:use-module (ice-9 match)
33   )
34
35 (cond-expand
36  (guile-2)
37  (guile
38   (use-modules (ice-9 syncase)))
39  (mes))
40
41 (define c99-std-defs
42   '("__DATE__" "__FILE__" "__LINE__" "__STDC__" "__STDC_HOSTED__"
43     "__STDC_VERSION__" "__TIME__"))
44
45 (define (c99-std-def? str)
46   (let iter ((defs c99-std-defs))
47     (cond
48      ((null? defs) #f)
49      ((string=? (car defs) str) #t)
50      (else (iter (cdr defs))))))
51
52 (define (c99-std-val str)
53   (cond
54    ((string=? str "__DATE__") "M01 01 2001")
55    ((string=? str "__FILE__") "(unknown)")
56    ((string=? str "__LINE__") 0)
57    ((string=? str "__STDC__") 1)
58    ((string=? str "__STDC_HOSTED__") 0)
59    ((string=? "__STDC_VERSION__") 201701)
60    ((string=? "__TIME__") "00:00:00")
61    (else #f)))
62
63 ;; @deffn read-ellipsis ch
64 ;; read ellipsis
65 (define (read-ellipsis ch)
66   (cond
67    ((eof-object? ch) #f)
68    ((char=? ch #\.) (read-char) (read-char) "...") ; assumes correct syntax
69    (else #f)))
70
71 ;; @deffn cpp-define => (define (name "ADD") (args "X" "Y") (repl "X+Y"))
72 ;; output is like
73 ;; @code{(name "ABC") (repl "123")} or
74 ;; @code{(name "ABC") (args "X" "Y") (repl "X+Y")}
75 (define (cpp-define)
76
77   (define (p-args la) ;; parse args
78     (if (eq? la #\()
79         (let iter ((args '()) (la (skip-il-ws (read-char))))
80           (cond
81            ((eq? la #\)) (reverse args))
82            ((read-c-ident la) =>
83             (lambda (arg) (iter (cons arg args) (skip-il-ws (read-char)))))
84            ((read-ellipsis la) =>
85             (lambda (arg) (iter (cons arg args) (skip-il-ws (read-char)))))
86            ((eq? la #\,) (iter args (skip-il-ws (read-char))))))
87         (begin (if (char? la) (unread-char la)) #f)))
88
89   (define (p-rest la) ;; parse rest
90     (cond ((eof-object? la) "")
91           (else (unread-char la) (drain-input (current-input-port)))))
92
93   (let* ((name (read-c-ident (skip-il-ws (read-char))))
94          (args (or (p-args (read-char)) '()))
95          (repl (p-rest (skip-il-ws (read-char)))))
96     (if (pair? args)
97         `(define (name ,name) (args . ,args) (repl ,repl))
98         `(define (name ,name) (repl ,repl)))))
99         
100
101 ;; @deffn cpp-include
102 ;; Parse CPP include statement.
103 (define (cpp-include)
104   (let* ((beg-ch (skip-il-ws (read-char)))
105          (end-ch (if (eq? beg-ch #\<) #\> #\"))
106          (path (let iter ((cl (list beg-ch)) (ch (read-char)))
107                  (if (eq? ch end-ch) (list->string (reverse (cons ch cl)))
108                      (iter (cons ch cl) (read-char))))))
109     `(include ,path)))
110
111 ;; @deffn cpp-line->stmt line defs => (stmt-type text)
112 ;; Parse a line from a CPP statement and return a parse tree.
113 ;; @example
114 ;; (parse-cpp-stmt "define X 123") => (define "X" "123")
115 ;; (parse-cpp-stmt "if defined(A) && defined(B) && defined(C)"
116 ;; => (if "defined(A) && defined(B) && defined(C)")
117 ;; @end example
118 ;; To evaluate the @code{if} statements use @code{parse-cpp-expr} and
119 ;; @code{eval-cpp-expr}.
120 (define (cpp-line->stmt line)
121   (define (rd-ident) (read-c-ident (skip-il-ws (read-char))))
122   (define (rd-num) (and=> (read-c-num (skip-il-ws (read-char))) cdr))
123   (define (rd-rest) (let ((ch (skip-il-ws (read-char))))
124                       (if (not (eof-object? ch)) (unread-char ch))
125                       (drain-input (current-input-port))))
126   (with-input-from-string line
127     (lambda ()
128       (let ((cmd (string->symbol (read-c-ident (skip-il-ws (read-char))))))
129         (case cmd
130           ((include) (cpp-include))
131           ((define) (cpp-define))
132           ((undef) `(undef ,(rd-ident)))
133           ((ifdef)
134            `(if ,(string-append "defined(" (rd-ident) ")" (rd-rest))))
135           ((ifndef)
136            `(if ,(string-append "!defined(" (rd-ident) ")" (rd-rest))))
137           ((if elif else endif line error pragma) (list cmd (rd-rest)))
138           (else '(unknown "")))))))
139
140 (include-from-path "nyacc/lang/c99/mach.d/cpptab.scm")
141 (include-from-path "nyacc/lang/c99/mach.d/cppact.scm")
142
143 (define raw-parser
144   (make-lalr-parser
145    (list (cons 'len-v len-v) (cons 'pat-v pat-v) (cons 'rto-v rto-v)
146          (cons 'mtab mtab) (cons 'act-v act-v))))
147
148 (define (cpp-err fmt . args)
149   (apply throw 'cpp-error fmt args))
150
151 ;;.@deffn skip-il-ws ch
152 ;; Skip in-line whitespace
153 (define skip-il-ws
154   (let ((il-ws (list->char-set '(#\space #\tab))))
155     (lambda (ch)
156       (cond
157        ((eof-object? ch) ch)
158        ((char-set-contains? il-ws ch) (skip-il-ws (read-char)))
159        (else ch)))))
160
161 ;; Since we want to be able to get CPP statements with comment in tact
162 ;; (e.g., for passing to @code{pretty-print-c99}) we need to remove
163 ;; comments when parsing CPP expressions.  We convert a comm-reader
164 ;; into a comm-skipper here.  And from that generate a lexer generator.
165 (define cpp-comm-skipper
166   (let ((reader (make-comm-reader '(("/*" . "*/")))))
167     (lambda (ch)
168       (reader ch #f))))
169
170 ;; generate a lexical analyzer per string
171 (define gen-cpp-lexer
172   (make-lexer-generator mtab #:comm-skipper cpp-comm-skipper))
173
174 ;; @deffn parse-cpp-expr text => tree
175 ;; Given a string returns a cpp parse tree.  This is called by
176 ;; @code{eval-cpp-expr}.  The text will have had all CPP defined symbols
177 ;; expanded already so no identifiers should appear in the text.
178 ;; A @code{cpp-error} will be thrown if a parse error occurs.
179 (define (parse-cpp-expr text)
180   (with-throw-handler
181    'nyacc-error
182    (lambda ()
183      (with-input-from-string text
184        (lambda () (raw-parser (gen-cpp-lexer)))))
185    (lambda (key fmt . args)
186      (apply throw 'cpp-error fmt args))))
187
188 ;; @deffn eval-cpp-expr tree dict => datum
189 ;; Evaluate a tree produced from @code{parse-cpp-expr}.
190 ;; The tree passed to this routine is 
191 (define (eval-cpp-expr tree dict)
192   (letrec
193       ((tx (lambda (tr ix) (list-ref tr ix)))
194        (tx1 (lambda (tr) (tx tr 1)))
195        (ev (lambda (ex ix) (eval-expr (list-ref ex ix))))
196        (ev1 (lambda (ex) (ev ex 1)))    ; eval expr in arg 1
197        (ev2 (lambda (ex) (ev ex 2)))    ; eval expr in arg 2
198        (ev3 (lambda (ex) (ev ex 3)))    ; eval expr in arg 3
199        (eval-expr
200         (lambda (tree)
201           (case (car tree)
202             ((fixed) (string->number (tx1 tree)))
203             ((char) (char->integer (tx1 tree)))
204             ((defined) (if (assoc-ref dict (tx1 tree)) 1 0))
205             ((pre-inc post-inc) (1+ (ev1 tree)))
206             ((pre-dec post-dec) (1- (ev1 tree)))
207             ((pos) (ev1 tree))
208             ((neg) (- (ev1 tree)))
209             ((bw-not) (bitwise-not (ev1 tree)))
210             ((not) (if (zero? (ev1 tree)) 1 0))
211             ((mul) (* (ev1 tree) (ev2 tree)))
212             ((div) (/ (ev1 tree) (ev2 tree)))
213             ((mod) (modulo (ev1 tree) (ev2 tree)))
214             ((add) (+ (ev1 tree) (ev2 tree)))
215             ((sub) (- (ev1 tree) (ev2 tree)))
216             ((lshift) (bitwise-arithmetic-shift-left (ev1 tree) (ev2 tree)))
217             ((rshift) (bitwise-arithmetic-shift-right (ev1 tree) (ev2 tree)))
218             ((lt) (if (< (ev1 tree) (ev2 tree)) 1 0))
219             ((le) (if (<= (ev1 tree) (ev2 tree)) 1 0))
220             ((gt) (if (> (ev1 tree) (ev2 tree)) 1 0))
221             ((ge) (if (>= (ev1 tree) (ev2 tree)) 1 0))
222             ((equal) (if (= (ev1 tree) (ev2 tree)) 1 0))
223             ((noteq) (if (= (ev1 tree) (ev2 tree)) 0 1))
224             ((bw-or) (bitwise-ior (ev1 tree) (ev2 tree)))
225             ((bw-xor) (bitwise-xor (ev1 tree) (ev2 tree)))
226             ((bw-and) (bitwise-and (ev1 tree) (ev2 tree)))
227             ((or) (if (and (zero? (ev1 tree)) (zero? (ev2 tree))) 0 1))
228             ((and) (if (or (zero? (ev1 tree)) (zero? (ev2 tree))) 0 1))
229             ((cond-expr) (if (zero? (ev1 tree)) (ev3 tree) (ev2 tree)))
230             ((ident) (cpp-err "undefined identifier: ~S" (cadr tree)))
231             (else (error "incomplete implementation"))))))
232     (eval-expr tree)))
233
234 ;; Note: scan-cpp-input scans replacement text.  When identifiers are found
235 ;; they are tested for expansion as follows:
236 ;; @enumerate
237 ;; @item If already expanded, then ignore.
238 ;; @item If followed by @code{(}, then use @code{collect-args} to get the
239 ;; arguments and ...
240 ;; @item Otherwise insert the replacement text and continue scanning (at
241 ;; first character of new replacement text.
242 ;; @end enumerate
243
244 ;; @deffn rtokl->string tokl => string
245 ;; Convert reverse token-list to string.
246 (define (x-rtokl->string tokl)
247   ;;(let iter ((stl '()) (chl '()) (nxt #f) (tkl tokl)) ;; more efficient
248   (let iter ((stl '()) (tkl tokl))
249     (match tkl
250       ('()
251        (apply string-append stl))
252
253       ((('arg . arg) 'dhash (key . val) . rest)
254        (iter stl (acons key (string-append val arg) (list-tail tkl 3))))
255
256       (((key . val) 'dhash ('arg . arg) . rest)
257        (iter stl (acons 'arg (string-append arg val) (list-tail tkl 3))))
258
259       ((('arg . arg) 'hash . rest)
260        (iter (cons (string-append "\"" arg "\"") stl) (list-tail tkl 2)))
261
262       ((('comm . val) . rest)
263        (iter (cons (string-append "/*" val " */") stl) (cdr tkl)))
264
265       ((('ident . rval) ('ident . lval) . rest)
266        (iter (cons* " " rval stl) (cdr tkl)))
267
268       (((key . val) . rest)
269        (iter (cons val stl) (cdr tkl)))
270
271       (('space . rest)
272        (iter (cons " " stl) rest))
273
274       (((? char? ch) . rest)
275        (iter (cons (string ch) stl) rest))
276
277       (otherwise
278        (error "no match" tkl)))))
279
280 (define (y-rtokl->string tokl)
281
282   ;; Turn reverse chl into a string and insert it into the string list stl.
283   (define (add-chl chl stl)
284     (if (null? chl) stl (cons (list->string chl) stl)))
285
286   ;; Works like this: Scan through the list of tokens (key-val pairs or lone
287   ;; characters).  Lone characters are collected in a list (@code{chl}); pairs
288   ;; are converted into strings and combined with list of characters into a
289   ;; list of strings.  When done the list of strings is combined to one string.
290   (let iter ((stl '()) (chl '()) (nxt #f) (tkl tokl))
291     (cond
292      (nxt (iter (cons nxt (add-chl chl stl)) '() #f tkl))
293      ((null? tkl) (apply string-append (add-chl chl stl)))
294      ((char? (car tkl)) (iter stl (cons (car tkl) chl) nxt (cdr tkl)))
295      (else
296       (match tkl
297         ((('arg . arg) 'dhash (key . val) . rest)
298          (iter stl chl nxt
299                (acons key (string-append val arg) (list-tail tkl 3))))
300
301         (((key . val) 'dhash ('arg . arg) . rest)
302          (iter stl chl nxt
303                (acons 'arg (string-append arg val) (list-tail tkl 3))))
304
305         ((('arg . arg) 'hash . rest)
306          (iter stl chl (string-append "\"" arg "\"") (list-tail tkl 2)))
307
308         ((('comm . val) . rest)
309          (iter stl chl (string-append "/*" val " */") (cdr tkl)))
310
311         ((('ident . rval) ('ident . lval) . rest)
312          (iter stl chl (string-append " " rval) (cdr tkl)))
313
314         (((key . val) . rest)
315          (iter stl chl val rest))
316
317         (('space . rest)
318          (iter stl (cons #\space chl) nxt rest))
319
320         (otherwise
321          (error "no match" tkl)))))))
322
323 (define rtokl->string y-rtokl->string)
324   
325 ;; @deffn scan-cpp-input argd used dict end-tok => string
326 ;; Process replacement text from the input port and generate a (reversed)
327 ;; token-list.  If end-tok, stop at, and push back, @code{,} or @code{)}.
328 ;; If end-tok is @code{,} then read until @code{,} or @code{(}.
329 ;; The argument @var{argd} is a dictionary (argument name, argument
330 ;; value) pairs which will be expanded as needed.  This routine is called
331 ;; by collect-args, expand-cpp-repl and cpp-expand-text.
332 (define (scan-cpp-input argd dict used end-tok)
333   ;; Works like this: scan for tokens (comments, parens, strings, char's, etc).
334   ;; Tokens are collected in a (reverse ordered) list (tkl) and merged together
335   ;; to a string on return using @code{rtokl->string}.
336
337   ;; We just scanned "defined", now need to scan the arg to inhibit expansion.
338   ;; For example, we have scanned "defined"; we now scan "(FOO)" or "FOO", and
339   ;; return "defined(FOO)".  We use ec (end-char) as terminal char:
340   ;; #\) if starts with #( or #\nul if other.
341   (define (scan-defined-arg)
342     (let* ((ch (skip-il-ws (read-char)))
343            (ec (if (char=? ch #\() #\) #\null)))
344       (let iter ((chl '(#\())
345                  (ec ec)
346                  (ch (if (char=? ec #\)) (skip-il-ws (read-char)) ch)))
347         (cond
348          ((eof-object? ch)
349           (if (char=? ec #\null)
350               (string-append "defined" (list->string (reverse (cons #\) chl))))
351               (cpp-err "illegal argument to `defined'")))
352          ((char-set-contains? c:ir ch)
353           (iter (cons ch chl) ec (read-char)))
354          ((char=? ec #\))
355           (if (char=? #\) (skip-il-ws ch))
356               (string-append "defined" (list->string (reverse (cons #\) chl))))
357               (cpp-err "garbage in argument to `defined'")))
358          ((char=? ec #\null) ;; past identifier
359           (string-append "defined" (list->string (reverse (cons #\) chl)))))
360          (else
361           (cpp-err "illegal argument to  `defined'"))))))
362
363   ;; token list is list of
364   ;; 1) characters as char
365   ;; 2) identifiers as string
366   ;; 3) strings as '(string . <string>)
367   ;; 4) 'hash 'dhash
368   (let iter ((tkl '())          ; token list of 
369              (lvl 0)            ; level
370              (ch (read-char)))  ; next character
371     (cond
372      ;; have item to add, but first add in char's
373      ;;(nxt (iter (cons nxt (add-chl chl tkl)) '() #f lvl ch))
374      ;; If end of string or see end-ch at level 0, then return.
375      ((eof-object? ch) (rtokl->string tkl))
376      
377      ((and (eqv? end-tok ch) (zero? lvl))
378       (unread-char ch) (rtokl->string tkl))
379      ((and end-tok (char=? #\) ch) (zero? lvl))
380       (unread-char ch) (rtokl->string tkl))
381      
382      ((read-c-comm ch #f) =>
383       (lambda (cp) (iter (acons `comm (cdr cp) tkl) lvl (read-char))))
384      
385      ((char-set-contains? c:ws ch)
386       (if (and (pair? tkl) (char? (car tkl)))
387           (iter (cons 'space tkl) lvl (read-char))
388           (iter tkl lvl (read-char))))
389      
390      ((char=? #\( ch) (iter (cons ch tkl) (1+ lvl) (read-char)))
391      ((char=? #\) ch) (iter (cons ch tkl) (1- lvl) (read-char)))
392      ((char=? #\# ch)
393       (let ((ch (read-char)))
394         (if (eqv? ch #\#)
395             (iter (cons 'dhash tkl) lvl (read-char))
396             (iter (cons 'hash tkl) lvl ch))))
397      ((read-c-string ch) =>
398       (lambda (st) (iter (acons 'string (cdr st) tkl) lvl (read-char))))
399      ((read-c-ident ch) =>
400       (lambda (iden)
401         (if (equal? iden "defined")
402             ;; "defined" is a special case
403             (let ((arg (scan-defined-arg)))
404               (iter (acons 'defined arg tkl) lvl (read-char)))
405             ;; otherwise ...
406             (let* ((aval (assoc-ref argd iden))  ; lookup argument
407                    (rval (assoc-ref dict iden))) ; lookup macro def
408               (cond
409                ((member iden used)      ; name used
410                 (iter (cons iden tkl) lvl (read-char)))
411                (aval                    ; arg ref
412                 (iter (acons 'arg aval tkl) lvl (read-char)))
413                ((string? rval)          ; cpp repl
414                 (iter (acons 'string rval tkl) lvl (read-char)))
415                ((pair? rval)            ; cpp macro
416                 (let* ((argl (car rval)) (text (cdr rval))
417                        (argd (collect-args argl argd dict used))
418                        (newl (expand-cpp-repl text argd dict (cons iden used))))
419                   (iter (acons 'string newl tkl) lvl (read-char))))
420                (else                    ; normal identifier
421                 (iter (acons 'ident iden tkl) lvl (read-char))))))))
422      (else
423       (iter (cons ch tkl) lvl (read-char))))))
424
425 ;; @deffn collect-args argl argd dict used => argd
426 ;; to be documented
427 ;; I think argd is a passthrough for scan-cpp-input
428 ;; argl: list of formal arguments in #define
429 ;; argd: used? (maybe just a pass-through for scan-cpp-input
430 ;; dict: dict of macro defs
431 ;; used: list of already expanded macros
432 ;; TODO clean this up
433 ;; should be looking at #\( and eat up to matching #\)
434 (define (collect-args argl argd dict used)
435   (let iter ((argl argl) (argv '()) (ch (skip-il-ws (read-char))))
436     ;; ch should always be #\(, #\, or #\)
437     (cond
438      ((eqv? ch #\)) (reverse argv))
439      ((null? argl) (cpp-err "arg count"))
440      ((and (null? (cdr argl)) (string=? (car argl) "..."))
441       (let ((val (scan-cpp-input argd dict used #\))))
442         (iter (cdr argl) (acons "__VA_ARGS__" val argv) (read-char))))
443      ((or (eqv? ch #\() (eqv? ch #\,))
444       (let ((val (scan-cpp-input argd dict used #\,)))
445         (iter (cdr argl) (acons (car argl) val argv) (read-char))))
446      (else (error "coding error, ch=" ch)))))
447
448 ;; @deffn expand-cpp-repl
449 ;; to be documented
450 (define (expand-cpp-repl repl argd dict used)
451   (with-input-from-string repl
452     (lambda () (scan-cpp-input argd dict used #f))))
453
454 ;; @deffn cpp-expand-text text dict => string
455 (define (cpp-expand-text text dict)
456   (with-input-from-string text
457     (lambda () (scan-cpp-input '() dict '() #f))))
458
459 ;; @deffn expand-cpp-macro-ref ident dict => repl|#f
460 ;; Given an identifier seen in C99 input, this checks for associated
461 ;; definition in @var{dict} (generated from CPP defines).  If found,
462 ;; the expansion is returned as a string.  If @var{ident} refers
463 ;; to a macro with arguments, then the arguments will be read from the
464 ;; current input.  The format of the @code{dict} entries are
465 ;; @example
466 ;; ("ABC" . "123")
467 ;; ("MAX" ("X" "Y") . "((X)>(Y)?(X):(Y))")
468 ;; @end example
469 (define (expand-cpp-macro-ref ident dict . rest)
470   (let ((used (if (pair? rest) (car rest) '()))
471         (rval (assoc-ref dict ident)))
472     (cond
473      ((not rval) #f)
474      ((member ident used) ident)
475      ((string? rval)
476       (let ((expd (expand-cpp-repl rval '() dict (cons ident used))))
477         expd))
478      ((pair? rval)
479       (let* ((argl (car rval)) (repl (cdr rval))
480              (argd (collect-args argl '() dict '()))
481              (expd (expand-cpp-repl repl argd dict (cons ident used))))
482         expd))
483      ((c99-std-val ident))
484      (else #f))))
485
486 ;;; --- last line ---