nyacc: fixed c99/CPP bug: need to skip space before lparen
[mes.git] / module / nyacc / lang / c99 / cppbody.scm
1 ;;; nyacc/lang/c99/cppbody.scm
2 ;;;
3 ;;; Copyright (C) 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 (define gen-cpp-lexer (make-lexer-generator mtab))
19
20 ;; @deffn parse-cpp-expr text => tree
21 ;; Given a string returns a cpp parse tree.  This is called by
22 ;; @code{parse-cpp-stmt} and @code{eval-cpp-expr}.  The latter because the
23 ;; parsed expression may include terms which are cpp-defined
24 ;; and should be evaluated lazy mode.
25 (define (parse-cpp-expr text)
26   (with-input-from-string text
27     (lambda () (raw-parser (gen-cpp-lexer)))))
28
29 ;; @deffn eval-cpp-expr tree dict => datum
30 ;; Evaluate a tree produced from
31 ;; This should be updated to use @code{expand-cpp-def}.  See below.
32 (use-modules (ice-9 pretty-print))
33 (define (eval-cpp-expr tree dict)
34   ;;(display "eval-cpp-expr:\n") (pretty-print tree)
35   (letrec
36       ((tx (lambda (tr ix) (list-ref tr ix)))
37        (tx1 (lambda (tr) (tx tr 1)))
38        (ev (lambda (ex ix) (eval-expr (list-ref ex ix))))
39        (ev1 (lambda (ex) (ev ex 1)))
40        (ev2 (lambda (ex) (ev ex 2)))
41        (ev3 (lambda (ex) (ev ex 3)))
42        #;(parse-and-eval
43         (lambda (str)
44           (if (not (string? str)) (throw 'parse-error "cpp-eval"))
45           (let ((idtr (parse-cpp-expr str)))
46             (eval-cpp-expr idtr dict))))
47        (eval-expr
48         (lambda (tree)
49           (case (car tree)
50             ;;((ident) (parse-and-eval (assoc-ref dict (tx1 tree))))
51             ((fixed) (string->number (tx1 tree)))
52             ((char) (char->integer (tx1 tree)))
53             ((defined) (if (assoc-ref dict (tx1 tree)) 1 0))
54             ;;
55             ((pre-inc post-inc) (1+ (ev1 tree)))
56             ((pre-dec post-dec) (1- (ev1 tree)))
57             ((pos) (ev1 tree))
58             ((neg) (- (ev1 tree)))
59             ((bw-not) (bitwise-not (ev1 tree)))
60             ((not) (if (zero? (ev1 tree)) 1 0))
61             ((mul) (* (ev1 tree) (ev2 tree)))
62             ((div) (/ (ev1 tree) (ev2 tree)))
63             ((mod) (modulo (ev1 tree) (ev2 tree)))
64             ((add) (+ (ev1 tree) (ev2 tree)))
65             ((sub) (- (ev1 tree) (ev2 tree)))
66             ((lshift) (bitwise-arithmetic-shift-left (ev1 tree) (ev2 tree)))
67             ((rshift) (bitwise-arithmetic-shift-right (ev1 tree) (ev2 tree)))
68             ((lt) (if (< (ev1 tree) (ev2 tree)) 1 0))
69             ((le) (if (<= (ev1 tree) (ev2 tree)) 1 0))
70             ((gt) (if (> (ev1 tree) (ev2 tree)) 1 0))
71             ((ge) (if (>= (ev1 tree) (ev2 tree)) 1 0))
72             ((equal) (if (= (ev1 tree) (ev2 tree)) 1 0))
73             ((noteq) (if (= (ev1 tree) (ev2 tree)) 0 1))
74             ((bw-or) (bitwise-ior (ev1 tree) (ev2 tree)))
75             ((bw-xor) (bitwise-xor (ev1 tree) (ev2 tree)))
76             ((bw-and) (bitwise-and (ev1 tree) (ev2 tree)))
77             ((or) (if (and (zero? (ev1 tree)) (zero? (ev2 tree))) 0 1))
78             ((and) (if (or (zero? (ev1 tree)) (zero? (ev2 tree))) 0 1))
79             ((cond-expr) (if (zero? (ev1 tree)) (ev3 tree) (ev2 tree)))
80             (else (error "incomplete implementation"))))))
81     (catch 'parse-error
82            (lambda () (eval-expr tree))
83            (lambda () #f))))
84
85
86 ;; @deffn scan-cpp-input argd used dict for-argl => string
87 ;; Process the replacement text and generate a (reversed) token-list.
88 ;; If for-argl, stop at, and push back, @code{,} or @code{)}.
89 (define (scan-cpp-input argd dict used for-argl)
90   ;; Works like this: scan tokens (comments, parens, strings, char's, etc).
91   ;; Tokens (i.e., strings) are collected in a (reverse ordered) list (stl)
92   ;; and merged together on return.  Lone characters are collected in the
93   ;; list @code{chl}.  Once a non-char token is found the character list is
94   ;; converted to a string and added to the string list first, followed by
95   ;; the new token.
96
97   ;; Turn reverse chl into a string and insert it into the string list stl.
98   (define (add-chl chl stl)
99     (if (null? chl) stl (cons (list->string (reverse chl)) stl)))
100
101   ;; We just scanned "defined", not need to scan the arg to inhibit expansion.
102   ;; E.g., scanned "defined", now scan "(FOO)", and return "defined(FOO)".
103   (define (scan-defined)
104     (let iter ((chl '()) (ch (read-char)))
105       (cond ((eof-object? ch) (throw 'parse-error "bad CPP defined"))
106             ((char=? #\) ch)
107              (string-append "defined" (list->string (reverse (cons ch chl)))))
108             (else (iter (cons ch chl) (read-char))))))
109   
110   ;; 
111   (let iter ((stl '())          ; string list (i.e., tokens)
112              (chl '())          ; char-list (current list of input chars)
113              (nxt #f)           ; next string 
114              (lvl 0)            ; level
115              (ch (read-char)))  ; next character
116     ;;(simple-format #t "iter stl=~S chl=~S nxt=~S ch=~S\n" stl chl nxt ch)
117     (cond
118      ;; have item to add, but first add in char's
119      (nxt (iter (cons nxt (add-chl chl stl)) '() #f lvl ch))
120      ;; If end of string or see end-ch at level 0, then return.
121      ((eof-object? ch)  ;; CHECK (ab++)
122       (apply string-append (reverse (add-chl chl stl))))
123      ((and for-argl (memq ch '(#\) #\,)) (zero? lvl))
124       (unread-char ch) (apply string-append (reverse (add-chl chl stl))))
125      ((read-c-comm ch #f) =>
126       (lambda (cp) (iter stl chl (string-append "/*" (cdr cp) "*/")
127                          lvl (read-char))))
128      ((char=? #\( ch) (iter stl (cons ch chl) nxt (1+ lvl) (read-char)))
129      ((char=? #\) ch) (iter stl (cons ch chl) nxt (1- lvl) (read-char)))
130      ((char=? #\# ch)
131       (let ((ch (read-char)))
132         (if (eqv? ch #\#)
133             (iter (cons "##" stl) chl #f lvl (read-char))
134             (iter (cons "#" stl) chl #f lvl ch))))
135      ((read-c-string ch) =>
136       (lambda (st) (iter stl chl st lvl (read-char))))
137      ((read-c-ident ch) =>
138       (lambda (iden)
139         ;;(simple-format #t "    iden=~S\n" iden)
140         (if (equal? iden "defined")
141             ;; "defined" is a special case
142             (iter stl chl (scan-defined) lvl (read-char))
143             ;; otherwise ...
144             (let* ((aval (assoc-ref argd iden))  ; lookup argument
145                    (rval (assoc-ref dict iden))) ; lookup macro def
146               (cond
147                ((member iden used)      ; name used
148                 (iter stl chl iden lvl (read-char)))
149                (aval                    ; arg ref
150                 (iter stl chl aval lvl (read-char)))
151                ((string? rval)          ; cpp repl
152                 (iter stl chl rval lvl (read-char)))
153                ((pair? rval)            ; cpp macro
154                 (let* ((argl (car rval)) (text (cdr rval))
155                        (argv (collect-args argd dict used))
156                        (argd (map cons argl argv))
157                        (newl (expand-cpp-repl text argd dict (cons iden used))))
158                   (iter stl chl newl lvl (read-char))))
159                (else                    ; normal identifier
160                 (iter stl chl iden lvl (read-char))))))))
161      (else
162       (iter stl (cons ch chl) #f lvl (read-char))))))
163   
164 (define (collect-args argd dict used)
165   ;;(simple-format #t "collect-args\n")
166   (if (not (eqv? (skip-ws (read-char)) #\())
167       (let ((fn (or (port-filename (current-input-port)) "(unknown)"))
168             (ln (1+ (port-line (current-input-port)))))
169         (throw 'parse-error "~A:~A: CPP expecting `('" fn ln)))
170   (let iter ((argl (list (scan-cpp-input argd dict used #t))))
171     ;;(simple-format #t "args: ~S\n" argl)
172     (let ((ch (read-char)))
173       (if (eqv? ch #\)) (reverse argl)
174           (iter (cons (scan-cpp-input argd dict used #t) argl))))))
175     
176 (define (expand-cpp-repl repl argd dict used)
177   ;;(simple-format #t "expand-cpp-repl repl=~S argd=~S\n" repl argd)
178   (with-input-from-string repl
179     (lambda () (scan-cpp-input argd dict used #f))))
180
181 ;; @deffn cpp-expand-text text dict => string
182 (define (cpp-expand-text text dict)
183   ;;(simple-format #t "cpp-expand-text: ~S\n" text)
184   (with-input-from-string text
185     (lambda () (scan-cpp-input '() dict '() #f))))
186
187 ;; @deffn expand-cpp-mref ident dict => repl|#f
188 ;; Given an identifier seen in C99 input, this checks for associated
189 ;; definition in @var{dict} (generated from CPP defines).  If found,
190 ;; the expansion is returned as a string.  If @var{ident} refers
191 ;; to a macro with arguments, then the arguments will be read from the
192 ;; current input.
193 (define (expand-cpp-mref ident dict . rest)
194
195   (let ((used (if (pair? rest) (car rest) '()))
196         (rval (assoc-ref dict ident)))
197     (cond
198      ((not rval) #f)
199      ((member ident used) ident)
200      ((string? rval)
201       (let ((expd (expand-cpp-repl rval '() dict (cons ident used))))
202         ;;(simple-format #t "expand ~S => ~S\n" ident expd)
203         expd))
204      ((pair? rval)
205       (let* ((args (car rval)) (repl (cdr rval))
206              (argv (collect-args '() dict '()))
207              (argd (map cons args argv))
208              (expd (expand-cpp-repl repl argd dict (cons ident used))))
209         ;;(simple-format #t "expand ~S => ~S\n" ident expd)
210         expd)))))
211
212 ;;; --- last line ---