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