nyacc: more CPP fixes
[mes.git] / module / nyacc / lang / c99 / body.scm
1 ;;; lang/c99/body.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 ;; @section The C99 Parser Body
19 ;; This code provides the front end to the C99 parser, including the lexical
20 ;; analyzer and optional CPP processing.  In @code{'file} mode the lex'er
21 ;; passes CPP statements to the parser; in @code{'code} mode the lex'er
22 ;; parses and evaluates the CPP statements.  In the case of included files
23 ;; (e.g., via @code{#include <file.h>}) the include files are parsed if
24 ;; not in the @code{td-dict}.  The @code{td-dict} is a dictionary that maps
25 ;; include file names to typedefs (e.g., @code{stdio.h} to @code{FILE}).
26
27 (use-modules ((srfi srfi-9) #:select (define-record-type)))
28 (use-modules ((sxml xpath) #:select (sxpath)))
29
30 (define c99-std-dict
31   '(("alloca.h")
32     ("complex.h" "complex" "imaginary")
33     ("ctype.h")
34     ("fenv.h" "fenv_t" "fexcept_t")
35     ("float.h" "float_t")
36     ("inttypes.h"
37      "int8_t" "uint8_t" "int16_t" "uint16_t" "int32_t" "uint32_t"
38      "int64_t" "uint64_t" "uintptr_t" "intptr_t" "intmax_t" "uintmax_t"
39      "int_least8_t" "uint_least8_t" "int_least16_t" "uint_least16_t"
40      "int_least32_t" "uint_least32_t" "int_least64_t" "uint_least64_t"
41      "imaxdiv_t")
42     ("limits.h")
43     ("math.h")
44     ("regex.h" "regex_t" "regmatch_t")
45     ("setjmp.h" "jmp_buf")
46     ("signal.h" "sig_atomic_t")
47     ("stdarg.h" "va_list")
48     ("stddef.h" "ptrdiff_t" "size_t" "wchar_t")
49     ("stdint.h"
50      "int8_t" "uint8_t" "int16_t" "uint16_t" "int32_t" "uint32_t"
51      "int64_t" "uint64_t" "uintptr_t" "intptr_t" "intmax_t" "uintmax_t"
52      "int_least8_t" "uint_least8_t" "int_least16_t" "uint_least16_t"
53      "int_least32_t" "uint_least32_t" "int_least64_t" "uint_least64_t")
54     ("stdio.h" "FILE" "size_t")
55     ("stdlib.h" "div_t" "ldiv_t" "lldiv_t" "wchar_t")
56     ("string.h" "size_t")
57     ("strings.h" "size_t")
58     ("time.h" "time_t" "clock_t" "size_t")
59     ("unistd.h" "size_t" "ssize_t" "div_t" "ldiv_t")
60     ("wchar.h" "wchar_t" "wint_t" "mbstate_t" "size_t")
61     ("wctype.h" "wctrans_t" "wctype_t" "wint_t")
62     ))
63
64 ;; @subsubsection CPP if-then-else Logic Block (ITLB) Processing
65 ;; The parser needs to have a "CPI" (CPP processing info) stack to deal with
66 ;; types (re)defined in multiple branches of a #if...#endif statement chain.
67 ;; If we are in "code" mode then we may be skipping code so need to track
68 ;; when to shift and when not to.
69 ;; 
70 ;; The state is contained in a stack @code{ppxs}
71 ;; States are
72 ;; @table code
73 ;; @item skip-done
74 ;; skip code
75 ;; @item skip-look
76 ;; skipping code, but still looking for true at this level
77 ;; @item keep
78 ;; keep code
79 ;; @item skip1-pop
80 ;; skip one token and pop skip-stack
81 ;; @end table
82 ;; Also, if we want to pass on all the sections of an ITLB to the parser
83 ;; we need to remove typedef names because a typedef may appear multiple
84 ;; times, as in
85 ;; @example
86 ;; #ifdef SIXTYFOURBIT
87 ;; typedef short int32_t;
88 ;; #else
89 ;; typedef long int32_t;
90 ;; #endif
91 ;; @end example
92 ;; @noindent
93 ;; To achieve this we keep a stack of valid typedefs.  On @code{#if} we push,
94 ;; on @code{#elif} we shift (i.e., pop, then push) and on @code{#endif} we pop.
95 ;;
96 ;; The grammar looks like
97 ;; @example
98 ;; (code
99 ;;  ("if" cond code "endif")
100 ;;  ("if" cond code "else" code "endif")
101 ;;  ("if" cond code elif-list "endif")
102 ;;  ("if" cond code elif-list "else" code "endif")
103 ;;  (other))
104 ;; (elif-list
105 ;;  ("elif" cond code)
106 ;;  (elif-list "elif" cond code))
107 ;; @end example
108 ;; @noindent
109
110 (define-record-type cpi
111   (make-cpi-1)
112   cpi?
113   (debug cpi-debug set-cpi-debug!)      ; debug #t #f
114   (defines cpi-defs set-cpi-defs!)      ; #defines
115   (incdirs cpi-incs set-cpi-incs!)      ; #includes
116   (tn-dict cpi-tynd set-cpi-tynd!)      ; typename dict (("<x>" foo_t ..
117   (ptl cpi-ptl set-cpi-ptl!)            ; parent typename list
118   (ctl cpi-ctl set-cpi-ctl!)            ; current typename list
119   )
120
121 (define (make-cpi debug defines incdirs tn-dict)
122   (let* ((cpi (make-cpi-1)))
123     (set-cpi-debug! cpi debug)    ; print states debug 
124     (set-cpi-defs! cpi defines)   ; list of define strings??
125     (set-cpi-incs! cpi incdirs)   ; list of include dir's
126     (set-cpi-tynd! cpi tn-dict)   ; typename dict by include-file name
127     (set-cpi-ptl! cpi '())        ; list of lists of typedef strings
128     (set-cpi-ctl! cpi '())        ; list of typedef strings
129     cpi))
130
131 (define *info* (make-fluid #f))
132
133 ;; given tyns
134 ;; cadr is next level
135 ;; caar is list of sibs
136 ;; search (caar car tyns), then (caar cadr tyns), then ...
137
138 ;; @deffn typename? name
139 ;; Called by lexer to determine if symbol is a typename.
140 ;; Check current sibling for each generation.
141 (define (typename? name)
142   (let ((cpi (fluid-ref *info*)))
143     (if (member name (cpi-ctl cpi)) #t
144         (let iter ((ptl (cpi-ptl cpi)))
145           (if (null? ptl) #f
146               (if (member name (car ptl)) #t
147                   (iter (cdr ptl))))))))
148
149 ;; @deffn add-typename name
150 ;; Helper for @code{save-typenames}.
151 (define (add-typename name)
152   (let ((cpi (fluid-ref *info*)))
153     (set-cpi-ctl! cpi (cons name (cpi-ctl cpi)))))
154
155 (define (cpi-push)      ;; on #if
156   (let ((cpi (fluid-ref *info*)))
157     (set-cpi-ptl! cpi (cons (cpi-ctl cpi) (cpi-ptl cpi)))
158     (set-cpi-ctl! cpi '())))
159
160 (define (cpi-shift)     ;; on #elif #else
161   (set-cpi-ctl! (fluid-ref *info*) '()))
162
163 (define (cpi-pop)       ;; on #endif
164   (let ((cpi (fluid-ref *info*)))
165     (set-cpi-ctl! cpi (append (cpi-ctl cpi) (car (cpi-ptl cpi))))
166     (set-cpi-ptl! cpi (cdr (cpi-ptl cpi)))))
167
168 ;; @deffn find-new-typenames decl
169 ;; Helper for @code{save-typenames}.
170 ;; Given declaration return a list of new typenames (via @code{typedef}).
171 (define (find-new-typenames decl)
172
173   ;; like declr->ident in util2.scm
174   (define (declr->id-name declr)
175     (case (car declr)
176       ((ident) (sx-ref declr 1))
177       ((init-declr) (declr->id-name (sx-ref declr 1)))
178       ((comp-declr) (declr->id-name (sx-ref declr 1)))
179       ((array-of) (declr->id-name (sx-ref declr 1)))
180       ((ptr-declr) (declr->id-name (sx-ref declr 2)))
181       ((ftn-declr) (declr->id-name (sx-ref declr 1)))
182       ((scope) (declr->id-name (sx-ref declr 1)))
183       (else (error "coding bug: " declr))))
184        
185   (let* ((spec (sx-ref decl 1))
186          (stor (sx-find 'stor-spec spec))
187          (id-l (sx-ref decl 2)))
188     (if (and stor (eqv? 'typedef (caadr stor)))
189         (let iter ((res '()) (idl (cdr id-l)))
190           (if (null? idl) res
191               (iter (cons (declr->id-name (sx-ref (car idl) 1)) res)
192                     (cdr idl))))
193         '())))
194
195 ;; @deffn save-typenames decl
196 ;; Save the typenames for the lexical analyzer and return the decl.
197 (define (save-typenames decl)
198   ;; This finds typenames using @code{find-new-typenames} and adds via
199   ;; @code{add-typename}.  Then return the decl.
200   (for-each add-typename (find-new-typenames decl))
201   decl)
202
203 ;; ------------------------------------------------------------------------
204
205 (define (p-err . args)
206   (apply throw 'c99-error args))
207
208 ;; @deffn read-cpp-line ch => #f | (cpp-xxxx)??
209 ;; Given if ch is #\# read a cpp-statement.
210 ;; The standard implies that comments are tossed here but we keep them
211 ;; so that they can end up in the pretty-print output.
212 (define (read-cpp-line ch)
213   (if (not (eq? ch #\#)) #f
214       (let iter ((cl '()) (ch (read-char)))
215         (cond
216          ((eof-object? ch) (throw 'cpp-error "CPP lines must end in newline"))
217          ((eq? ch #\newline) (unread-char ch) (list->string (reverse cl)))
218          ((eq? ch #\\)
219           (let ((c2 (read-char)))
220             (if (eq? c2 #\newline)
221                 (iter cl (read-char))
222                 (iter (cons* c2 ch cl) (read-char)))))
223          ((eq? ch #\/) ;; swallow comments, event w/ newlines
224           (let ((c2 (read-char)))
225             (cond
226              ((eqv? c2 #\*)
227               (let iter2 ((cl2 (cons* #\* #\/ cl)) (ch (read-char)))
228                 (cond
229                  ((eq? ch #\*)
230                   (let ((c2 (read-char)))
231                     (if (eqv? c2 #\/)
232                         (iter (cons* #\/ #\* cl2) (read-char)) ;; keep comment
233                         (iter2 (cons #\* cl2) c2))))
234                  (else
235                   (iter2 (cons ch cl2) (read-char))))))
236              (else
237               (iter (cons #\/ cl) c2)))))
238          (else (iter (cons ch cl) (read-char)))))))
239
240 ;; @deffn find-file-in-dirl file dirl => path
241 (define (find-file-in-dirl file dirl)
242   (let iter ((dirl dirl))
243     (if (null? dirl) #f
244         (let ((p (string-append (car dirl) "/" file)))
245           (if (access? p R_OK) p (iter (cdr dirl)))))))
246
247 (define (def-xdef? name mode)
248   (eqv? mode 'code))
249
250 ;; @deffn gen-c-lexer [#:mode mode] [#:xdef? proc] => procedure
251 ;; Generate a context-sensitive lexer for the C99 language.  The generated
252 ;; lexical analyzer reads and passes comments and optionally CPP statements
253 ;; to the parser.  The keyword argument @var{mode} will determine if CPP
254 ;; statements are passed (@code{'file} mode) or parsed and executed
255 ;; (@code{'file} mode) as described above.  Comments will be passed as
256 ;; ``line'' comments or ``lone'' comments: lone comments appear on a line
257 ;; without code.  The @code{xdef?} keyword argument allows user to pass
258 ;; a predicate which determines whether CPP symbols in code are expanded.
259 ;; The default predicate is
260 ;; @example
261 ;; (define (def-xdef? mode name) (eqv? mode 'code))
262 ;; @end example
263 (define gen-c-lexer
264   ;; This gets ugly in order to handle cpp.
265   ;;.need to add support for num's w/ letters like @code{14L} and @code{1.3f}.
266   ;; todo: I think there is a bug wrt the comment reader because // ... \n
267   ;; will end up in same mode...  so after
268   ;; int x; // comment
269   ;; the lexer will think we are not at BOL.
270   (let* ((match-table mtab)
271          (read-ident read-c-ident)
272          (read-comm read-c-comm)
273          ;;
274          (ident-like? (make-ident-like-p read-ident))
275          ;;
276          (strtab (filter-mt string? match-table)) ; strings in grammar
277          (kwstab (filter-mt ident-like? strtab))  ; keyword strings =>
278          (keytab (map-mt string->symbol kwstab))  ; keywords in grammar
279          (chrseq (remove-mt ident-like? strtab))  ; character sequences
280          (symtab (filter-mt symbol? match-table)) ; symbols in grammar
281          (chrtab (filter-mt char? match-table))   ; characters in grammar
282          ;;
283          (read-chseq (make-chseq-reader chrseq))
284          (assc-$ (lambda (pair) (cons (assq-ref symtab (car pair)) (cdr pair))))
285          ;;
286          (t-ident (assq-ref symtab '$ident))
287          (t-typename (assq-ref symtab 'typename))
288          (xp1 (sxpath '(cpp-stmt define)))
289          (xp2 (sxpath '(decl))))
290     ;; mode: 'code|'file
291     ;; xdef?: (proc name mode) => #t|#f  : do we expand #define?
292     (lambda* (#:key (mode 'code) (xdef? #f))
293       (let ((bol #t)                  ; begin-of-line condition
294             (ppxs (list 'keep))       ; CPP execution state stack
295             (info (fluid-ref *info*)) ; assume make and run in same thread
296             (x-def? (or xdef? def-xdef?)))
297         ;; Return the first (tval . lval) pair not excluded by the CPP.
298         (lambda ()
299
300           (define (exec-cpp-stmts?)     ; exec (vs pass to parser) CPP stmts?
301             (eqv? mode 'code))
302       
303           (define (add-define tree)
304             (let* ((tail (cdr tree))
305                    (name (car (assq-ref tail 'name)))
306                    (args (assq-ref tail 'args))
307                    (repl (car (assq-ref tail 'repl)))
308                    (cell (cons name (if args (cons args repl) repl))))
309               (set-cpi-defs! info (cons cell (cpi-defs info)))))
310           
311           (define (rem-define name)
312               (set-cpi-defs! info (delete name (cpi-defs info))))
313           
314           ;; Evaluate expression text in #if of #elif statement.
315           (define (eval-cpp-cond-text text)
316             (with-throw-handler
317              'cpp-error
318              (lambda ()
319                (let* ((defs (cpi-defs info))
320                       (rhs (cpp-expand-text text defs))
321                       (exp (parse-cpp-expr rhs)))
322                  (eval-cpp-expr exp defs)))
323              (lambda (key fmt . args)
324                (report-error fmt args)
325                (throw 'c99-error "CPP error"))))
326             
327           (define (eval-cpp-stmt stmt)
328             (case (car stmt)
329               ((include)
330                (let* ((parg (cadr stmt)) (leng (string-length parg))
331                       (file (substring parg 1 (1- leng)))
332                       (path (find-file-in-dirl file (cpi-incs info)))
333                       (tynd (assoc-ref (cpi-tynd info) file)))
334                  (cond
335                   (tynd (for-each add-typename tynd)) ; in dot-h dict
336                   ((not path) (p-err "not found: ~S" file))
337                   ((exec-cpp-stmts?) (push-input (open-input-file path)))
338                   (else         ; include as tree
339                    (let* ((tree (with-input-from-file path run-parse)))
340                      (if (not tree) (p-err "included from ~S" path))
341                      (for-each add-define (xp1 tree)) ; add def's 
342                      (set! stmt (append stmt (list tree)))))))
343                (if (exec-cpp-stmts?) (set! ppxs (cons 'skip1-pop ppxs))))
344               ((define)
345                (add-define stmt)
346                (if (exec-cpp-stmts?) (set! ppxs (cons 'skip1-pop ppxs))))
347               ((undef)
348                (rem-define (cadr stmt))
349                (if (exec-cpp-stmts?) (set! ppxs (cons 'skip1-pop ppxs))))
350               ((if) ;; covers (if ifdef ifndef)
351                (cond
352                 ((exec-cpp-stmts?)
353                  (let ((val (eval-cpp-cond-text (cadr stmt))))
354                    ;;(simple-format #t "if val=~S\n" val)
355                    (cond
356                     ((not val) (p-err "unresolved: ~S" (cadr stmt)))
357                     ((zero? val) (set! ppxs (cons* 'skip1-pop 'skip-look ppxs)))
358                     (else (set! ppxs (cons* 'skip1-pop (car ppxs) ppxs))))))
359                 (else (cpi-push))))
360               ((elif)
361                (cond
362                 ((exec-cpp-stmts?)
363                  (let ((val (eval-cpp-cond-text (cadr stmt))))
364                    (cond
365                     ((not val)
366                      (p-err "unresolved: ~S" (cadr stmt)))
367                     ((eq? 'keep (car ppxs))
368                      (set! ppxs (cons* 'skip1-pop 'skip-done (cdr ppxs))))
369                     ((zero? val) (set! ppxs (cons* 'skip1-pop ppxs)))
370                     ((eq? 'skip-look (car ppxs))
371                      (set! ppxs (cons* 'skip1-pop 'keep (cdr ppxs))))
372                     (else
373                      (set! ppxs (cons* 'skip1-pop 'skip-done (cdr ppxs)))))))
374                 (else (cpi-shift))))
375               ((else)
376                (cond
377                 ((exec-cpp-stmts?)
378                  (cond
379                   ((eq? 'skip-look (car ppxs))
380                    (set! ppxs (cons* 'skip1-pop 'keep (cdr ppxs))))
381                   (else
382                    (set! ppxs (cons* 'skip1-pop 'skip-done (cdr ppxs))))))
383                 (else (cpi-shift))))
384               ((endif)
385                (cond
386                 ((exec-cpp-stmts?)
387                  (set! ppxs (cons 'skip1-pop (cdr ppxs))))
388                 (else (cpi-pop))))
389               ((error)
390                (if (exec-cpp-stmts?)
391                    (report-error "error: #error ~A" (cdr stmt))))
392               ((pragma)
393                ;; standard says implementation-defined if line is expanded
394                #t)
395               (else
396                (error "unhandled cpp stmt")))
397             (case (car stmt)
398               ((pragma) (cons 'cpp-pragma (cdr stmt)))
399               (else (cons 'cpp-stmt stmt))))
400           
401           (define (eval-cpp-line line)
402             ;;(simple-format #t "eval-cpp-line: ~S\n" line)
403             (with-throw-handler
404              'cpp-error
405              (lambda () (eval-cpp-stmt (read-cpp-stmt line)))
406              (lambda (key fmt . rest)
407                (display "body.399\n")
408                (report-error fmt rest)
409                (throw 'c99-error "CPP error"))))
410
411           ;; Composition of @code{read-cpp-line} and @code{eval-cpp-line}.
412           (define (read-cpp ch)
413             (and=> (read-cpp-line ch) eval-cpp-line))
414
415           (define (read-token)
416             (let iter ((ch (read-char)))
417               (cond
418                ((eof-object? ch)
419                 (if (pop-input) (iter (read-char)) (assc-$ '($end . ""))))
420                ((eq? ch #\newline) (set! bol #t) (iter (read-char)))
421                ((char-set-contains? c:ws ch) (iter (read-char)))
422                (bol
423                 (cond
424                  ((read-comm ch bol) => assc-$)
425                  ((read-cpp ch) =>
426                   (lambda (res) ;; if '() stmt expanded so re-read
427                     ;;(simple-format #t "res=~S\n" res)
428                     (if (pair? res) (assc-$ res) (iter (read-char)))))
429                  (else (set! bol #f) (iter ch))))
430                ((read-ident ch) =>
431                 (lambda (name)
432                   ;;(simple-format #t "read-ident=>~S\n" name)
433                   (let ((symb (string->symbol name)))
434                     (cond
435                      ((and (x-def? name mode)
436                            (expand-cpp-mref name (cpi-defs info)))
437                       => (lambda (st)
438                            ;;(simple-format #t "body: st=~S\n" st)
439                            (push-input (open-input-string st))
440                            (iter (read-char))))
441                      ((assq-ref keytab symb)
442                       => (lambda (t) (cons t name)))
443                      ((typename? name)
444                       (cons (assq-ref symtab 'typename) name))
445                      (else
446                       (cons (assq-ref symtab '$ident) name))))))
447                ((read-c-num ch) => assc-$)
448                ((read-c-string ch) => assc-$)
449                ((read-c-chlit ch) => assc-$)
450                ((read-comm ch bol) => assc-$)
451                ((read-chseq ch) => identity)
452                ((assq-ref chrtab ch) => (lambda (t) (cons t (string ch))))
453                ((eqv? ch #\\) ;; C allows \ at end of line to continue
454                 (let ((ch (read-char)))
455                   (cond ((eqv? #\newline ch) (iter (read-char))) ;; extend line
456                         (else (unread-char ch) (cons #\\ "\\"))))) ;; parse err
457                (else (cons ch (string ch))))))
458
459           ;; Loop between reading tokens and skipping tokens via CPP logic.
460           (let iter ((pair (read-token)))
461             (case (car ppxs)
462               ((keep)
463                ;;(simple-format #t "lx=>~S\n" pair)
464                pair)
465               ((skip-done skip-look)
466                (iter (read-token)))
467               ((skip1-pop)
468                (set! ppxs (cdr ppxs))
469                (iter (read-token)))))
470           )))))
471   
472 ;; --- last line ---