nyacc: minor 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 ;; Notes on the code design may be found in doc/nyacc/lang/c99-hg.info
19
20 ;; @section The C99 Parser Body
21 ;; This code provides the front end to the C99 parser, including the lexical
22 ;; analyzer and optional CPP processing.  In @code{'file} mode the lex'er
23 ;; passes CPP statements to the parser; in @code{'code} mode the lex'er
24 ;; parses and evaluates the CPP statements.  In the case of included files
25 ;; (e.g., via @code{#include <file.h>}) the include files are parsed if
26 ;; not in @code{inc-help}.  The a-list @code{inc-help} maps
27 ;; include file names to typenames (e.g., @code{stdio.h} to @code{FILE}) and
28 ;; CPP defines (e.g., "INT_MAX=12344").
29
30 (use-modules ((srfi srfi-9) #:select (define-record-type)))
31 (use-modules ((sxml xpath) #:select (sxpath)))
32 (use-modules (ice-9 regex))
33
34 (define-record-type cpi
35   (make-cpi-1)
36   cpi?
37   (debug cpi-debug set-cpi-debug!)      ; debug #t #f
38   (defines cpi-defs set-cpi-defs!)      ; #defines
39   (incdirs cpi-incs set-cpi-incs!)      ; #includes
40   (inc-tynd cpi-itynd set-cpi-itynd!)   ; a-l of incfile => typenames
41   (inc-defd cpi-idefd set-cpi-idefd!)   ; a-l of incfile => defines
42   (ptl cpi-ptl set-cpi-ptl!)            ; parent typename list
43   (ctl cpi-ctl set-cpi-ctl!)            ; current typename list
44   )
45
46 ;;.@deffn split-cppdef defstr => (<name> . <repl>)|((<name>  <args> . <repl>)|#f
47 ;; Convert define string to a dict item.  Examples:
48 ;; @example
49 ;; "ABC=123" => '("ABC" . "123")
50 ;; "MAX(X,Y)=((X)>(Y)?(X):(Y))" => ("MAX" ("X" "Y") . "((X)>(Y)?(X):(Y))")
51 ;; @end example
52 (define split-cppdef
53   (let ((rx1 (make-regexp "^([A-Za-z0-9_]+)\\([^)]*\\)=(.*)$"))
54         (rx2 (make-regexp "^([A-Za-z0-9_]+)=(.*)$")))
55     (lambda (defstr)
56       (let* ((m1 (regexp-exec rx1 defstr))
57              (m2 (or m1 (regexp-exec rx2 defstr))))
58         (cond
59          ((regexp-exec rx1 defstr) =>
60           (lambda (m)
61             (let* ((s1 (match:substring m1 1))
62                    (s2 (match:substring m1 2))
63                    (s3 (match:substring m1 3)))
64               (cons s1 (cons s2 s3)))))
65          ((regexp-exec rx2 defstr) =>
66           (lambda (m)
67             (let* ((s1 (match:substring m2 1))
68                    (s2 (match:substring m2 2)))
69               (cons s1 s2))))
70          (else #f))))))
71
72 ;; @deffn make-cpi debug defines incdirs inchelp
73 (define (make-cpi debug defines incdirs inchelp)
74   ;; convert inchelp into inc-file->typenames and inc-file->defines
75   ;; Any entry for an include file which contains `=' is considered
76   ;; a define; otherwise, the entry is a typename.
77
78   (define (split-helper helper)
79     (let ((file (car helper)))
80       (let iter ((tyns '()) (defs '()) (ents (cdr helper)))
81         (cond
82          ((null? ents) (values (cons file tyns) (cons file defs)))
83          ((split-cppdef (car ents)) =>
84           (lambda (def) (iter tyns (cons def defs) (cdr ents))))
85          (else (iter (cons (car ents) tyns) defs (cdr ents)))))))
86
87   (let* ((cpi (make-cpi-1)))
88     (set-cpi-debug! cpi debug)          ; print states debug 
89     (set-cpi-defs! cpi (map split-cppdef defines)) ; list of define strings
90     (set-cpi-incs! cpi incdirs)         ; list of include dir's
91     (set-cpi-ptl! cpi '())              ; list of lists of typenames
92     (set-cpi-ctl! cpi '())              ; list of typenames
93     ;; itynd idefd:
94     (let iter ((itynd '()) (idefd '()) (helpers inchelp))
95       (cond ((null? helpers)
96              (set-cpi-itynd! cpi itynd)
97              (set-cpi-idefd! cpi idefd))
98             (else
99              (call-with-values
100                  (lambda () (split-helper (car helpers)))
101                (lambda (ityns idefs)
102                  (iter (cons ityns itynd) (cons idefs idefd) (cdr helpers)))))))
103     cpi))
104
105 (define *info* (make-fluid #f))
106           
107 ;; @deffn typename? name
108 ;; Called by lexer to determine if symbol is a typename.
109 ;; Check current sibling for each generation.
110 (define (typename? name)
111   (let ((cpi (fluid-ref *info*)))
112     (if (member name (cpi-ctl cpi)) #t
113         (let iter ((ptl (cpi-ptl cpi)))
114           (if (null? ptl) #f
115               (if (member name (car ptl)) #t
116                   (iter (cdr ptl))))))))
117
118 ;; @deffn add-typename name
119 ;; Helper for @code{save-typenames}.
120 (define (add-typename name)
121   (let ((cpi (fluid-ref *info*)))
122     (set-cpi-ctl! cpi (cons name (cpi-ctl cpi)))))
123
124 (define (cpi-push)      ;; on #if
125   (let ((cpi (fluid-ref *info*)))
126     (set-cpi-ptl! cpi (cons (cpi-ctl cpi) (cpi-ptl cpi)))
127     (set-cpi-ctl! cpi '())))
128
129 (define (cpi-shift)     ;; on #elif #else
130   (set-cpi-ctl! (fluid-ref *info*) '()))
131
132 (define (cpi-pop)       ;; on #endif
133   (let ((cpi (fluid-ref *info*)))
134     (set-cpi-ctl! cpi (append (cpi-ctl cpi) (car (cpi-ptl cpi))))
135     (set-cpi-ptl! cpi (cdr (cpi-ptl cpi)))))
136
137 ;; @deffn find-new-typenames decl
138 ;; Helper for @code{save-typenames}.
139 ;; Given declaration return a list of new typenames (via @code{typedef}).
140 (define (find-new-typenames decl)
141
142   ;; like declr->ident in util2.scm
143   (define (declr->id-name declr)
144     (case (car declr)
145       ((ident) (sx-ref declr 1))
146       ((init-declr) (declr->id-name (sx-ref declr 1)))
147       ((comp-declr) (declr->id-name (sx-ref declr 1)))
148       ((array-of) (declr->id-name (sx-ref declr 1)))
149       ((ptr-declr) (declr->id-name (sx-ref declr 2)))
150       ((ftn-declr) (declr->id-name (sx-ref declr 1)))
151       ((scope) (declr->id-name (sx-ref declr 1)))
152       (else (error "coding bug: " declr))))
153        
154   (let* ((spec (sx-ref decl 1))
155          (stor (sx-find 'stor-spec spec))
156          (id-l (sx-ref decl 2)))
157     (if (and stor (eqv? 'typedef (caadr stor)))
158         (let iter ((res '()) (idl (cdr id-l)))
159           (if (null? idl) res
160               (iter (cons (declr->id-name (sx-ref (car idl) 1)) res)
161                     (cdr idl))))
162         '())))
163
164 ;; @deffn save-typenames decl
165 ;; Save the typenames for the lexical analyzer and return the decl.
166 (define (save-typenames decl)
167   ;; This finds typenames using @code{find-new-typenames} and adds via
168   ;; @code{add-typename}.  Then return the decl.
169   (for-each add-typename (find-new-typenames decl))
170   decl)
171
172 ;; ------------------------------------------------------------------------
173
174 (define (p-err . args)
175   (apply throw 'c99-error args))
176
177 ;; @deffn read-cpp-line ch => #f | (cpp-xxxx)??
178 ;; Given if ch is #\# read a cpp-statement.
179 ;; The standard implies that comments are tossed here but we keep them
180 ;; so that they can end up in the pretty-print output.
181 (define (read-cpp-line ch)
182   (if (not (eq? ch #\#)) #f
183       (let iter ((cl '()) (ch (read-char)))
184         (cond
185          ((eof-object? ch) (throw 'cpp-error "CPP lines must end in newline"))
186          ((eq? ch #\newline) (unread-char ch) (list->string (reverse cl)))
187          ((eq? ch #\\)
188           (let ((c2 (read-char)))
189             (if (eq? c2 #\newline)
190                 (iter cl (read-char))
191                 (iter (cons* c2 ch cl) (read-char)))))
192          ((eq? ch #\/) ;; swallow comments, event w/ newlines
193           (let ((c2 (read-char)))
194             (cond
195              ((eqv? c2 #\*)
196               (let iter2 ((cl2 (cons* #\* #\/ cl)) (ch (read-char)))
197                 (cond
198                  ((eq? ch #\*)
199                   (let ((c2 (read-char)))
200                     (if (eqv? c2 #\/)
201                         (iter (cons* #\/ #\* cl2) (read-char)) ;; keep comment
202                         (iter2 (cons #\* cl2) c2))))
203                  (else
204                   (iter2 (cons ch cl2) (read-char))))))
205              (else
206               (iter (cons #\/ cl) c2)))))
207          (else (iter (cons ch cl) (read-char)))))))
208
209 ;; @deffn find-file-in-dirl file dirl => path
210 (define (find-file-in-dirl file dirl)
211   (let iter ((dirl dirl))
212     (if (null? dirl) #f
213         (let ((p (string-append (car dirl) "/" file)))
214           (if (access? p R_OK) p (iter (cdr dirl)))))))
215
216 (define (def-xdef? name mode)
217   (eqv? mode 'code))
218
219 ;; @deffn gen-c-lexer [#:mode mode] [#:xdef? proc] => procedure
220 ;; Generate a context-sensitive lexer for the C99 language.  The generated
221 ;; lexical analyzer reads and passes comments and optionally CPP statements
222 ;; to the parser.  The keyword argument @var{mode} will determine if CPP
223 ;; statements are passed (@code{'file} mode) or parsed and executed
224 ;; (@code{'file} mode) as described above.  Comments will be passed as
225 ;; ``line'' comments or ``lone'' comments: lone comments appear on a line
226 ;; without code.  The @code{xdef?} keyword argument allows user to pass
227 ;; a predicate which determines whether CPP symbols in code are expanded.
228 ;; The default predicate is
229 ;; @example
230 ;; (define (def-xdef? mode name) (eqv? mode 'code))
231 ;; @end example
232 (define gen-c-lexer
233   ;; This gets ugly in order to handle cpp.
234   ;;.need to add support for num's w/ letters like @code{14L} and @code{1.3f}.
235   ;; todo: I think there is a bug wrt the comment reader because // ... \n
236   ;; will end up in same mode...  so after
237   ;; int x; // comment
238   ;; the lexer will think we are not at BOL.
239   (let* ((match-table mtab)
240          (read-ident read-c-ident)
241          (read-comm read-c-comm)
242          ;;
243          (ident-like? (make-ident-like-p read-ident))
244          ;;
245          (strtab (filter-mt string? match-table)) ; strings in grammar
246          (kwstab (filter-mt ident-like? strtab))  ; keyword strings =>
247          (keytab (map-mt string->symbol kwstab))  ; keywords in grammar
248          (chrseq (remove-mt ident-like? strtab))  ; character sequences
249          (symtab (filter-mt symbol? match-table)) ; symbols in grammar
250          (chrtab (filter-mt char? match-table))   ; characters in grammar
251          ;;
252          (read-chseq (make-chseq-reader chrseq))
253          (assc-$ (lambda (pair) (cons (assq-ref symtab (car pair)) (cdr pair))))
254          ;;
255          (t-ident (assq-ref symtab '$ident))
256          (t-typename (assq-ref symtab 'typename))
257          (xp1 (sxpath '(cpp-stmt define)))
258          (xp2 (sxpath '(decl))))
259     ;; mode: 'code|'file
260     ;; xdef?: (proc name mode) => #t|#f  : do we expand #define?
261     (lambda* (#:key (mode 'code) (xdef? #f))
262       (let ((bol #t)                  ; begin-of-line condition
263             (ppxs (list 'keep))       ; CPP execution state stack
264             (info (fluid-ref *info*)) ; assume make and run in same thread
265             (x-def? (or xdef? def-xdef?)))
266         ;; Return the first (tval . lval) pair not excluded by the CPP.
267         (lambda ()
268
269           (define (exec-cpp?) ; exec (vs pass to parser) CPP stmts?
270             (eqv? mode 'code))
271
272           (define (cpp-flow? keyw)
273             (memq keyw '(if elif else)))
274       
275           (define (add-define tree)
276             (let* ((tail (cdr tree))
277                    (name (car (assq-ref tail 'name)))
278                    (args (assq-ref tail 'args))
279                    (repl (car (assq-ref tail 'repl)))
280                    (cell (cons name (if args (cons args repl) repl))))
281               (set-cpi-defs! info (cons cell (cpi-defs info)))))
282           
283           (define (rem-define name)
284               (set-cpi-defs! info (delete name (cpi-defs info))))
285           
286           (define (apply-helper file)
287             (let* ((tyns (assoc-ref (cpi-itynd info) file))
288                    (defs (assoc-ref (cpi-idefd info) file)))
289               (when tyns
290                 (for-each add-typename tyns)
291                 (set-cpi-defs! info (append defs (cpi-defs info))))
292               tyns))
293           
294           ;; Evaluate expression text in #if of #elif statement.
295           (define (eval-cpp-cond-text text)
296             (with-throw-handler
297              'cpp-error
298              (lambda ()
299                (let* ((defs (cpi-defs info))
300                       (rhs (cpp-expand-text text defs))
301                       (exp (parse-cpp-expr rhs)))
302                  (eval-cpp-expr exp defs)))
303              (lambda (key fmt . args)
304                (report-error fmt args)
305                (throw 'c99-error "CPP error"))))
306
307           (define (inc-stmt->file stmt)
308             (let* ((arg (cadr stmt)) (len (string-length arg)))
309               (substring arg 1 (1- len))))
310
311           (define (inc-file->path file)
312             (find-file-in-dirl file (cpi-incs info)))
313
314           (define (eval-cpp-stmt-1/code stmt)
315             ;; eval control flow: states are {skip-look, keep, skip-done}
316             (case (car stmt)
317               ((if)
318                (let ((val (eval-cpp-cond-text (cadr stmt))))
319                  (if (not val) (p-err "unresolved: ~S" (cadr stmt)))
320                  (if (eq? 'keep (car ppxs))
321                      (if (zero? val)
322                          (set! ppxs (cons 'skip-look ppxs))
323                          (set! ppxs (cons 'keep ppxs)))
324                      (set! ppxs (cons 'skip-done ppxs)))))
325               ((elif)
326                (let ((val (eval-cpp-cond-text (cadr stmt))))
327                  (if (not val) (p-err "unresolved: ~S" (cadr stmt)))
328                  (case (car ppxs)
329                    ((skip-look) (if (not (zero? val)) (set-car! ppxs 'keep)))
330                    ((keep) (set-car! ppxs 'skip-done)))))
331               ((else)
332                (case (car ppxs)
333                  ((skip-look) (set-car! ppxs 'keep))
334                  ((keep) (set-car! ppxs 'skip-done))))
335               ((endif)
336                (set! ppxs (cdr ppxs)))
337               (else
338                (if (eqv? 'keep (car ppxs))
339                    (eval-cpp-stmt-2/code stmt)))))
340
341           (define (eval-cpp-stmt-2/code stmt)
342             ;; eval non-control flow
343             (case (car stmt)
344               ;; actions
345               ((include)
346                (let* ((file (inc-stmt->file stmt))
347                       (path (inc-file->path file)))
348                  (cond
349                   ((apply-helper file)) ; use helper
350                   ((not path) (p-err "not found: ~S" file)) ; file not found
351                   (else (set! bol #t) (push-input (open-input-file path))))))
352               ((define) (add-define stmt))
353               ((undef) (rem-define (cadr stmt)))
354               ((error) (p-err "error: #error ~A" (cadr stmt)))
355               ((pragma) #t) ;; ignore for now
356               (else (error "bad cpp flow stmt"))))
357
358           (define (eval-cpp-stmt-1/file stmt)
359             (case (car stmt)
360               ((if) (cpi-push))
361               ((elif else) (cpi-shift))
362               ((endif) (cpi-pop))
363               (else (eval-cpp-stmt-2/file stmt))))
364             
365           (define (eval-cpp-stmt-2/file stmt)
366             ;; eval non-control flow
367             (case (car stmt)
368               ;; includes
369               ((include)
370                (let* ((file (inc-stmt->file stmt))
371                       (path (inc-file->path file)))
372                  (cond
373                   ((apply-helper file)) ; use helper
374                   ((not path) (p-err "not found: ~S" file)) ; file not found
375                   ((with-input-from-file path run-parse) => ; include tree
376                    (lambda (tree) (for-each add-define (xp1 tree))))
377                   (else (p-err "included from ~S" path)))))
378               ((define) (add-define stmt))
379               ((undef) (rem-define (cadr stmt)))
380               ((error) #f)
381               ((pragma) #t) ;; need to work this
382               (else (error "bad cpp flow stmt"))))
383             
384           (define (eval-cpp-stmt stmt)
385             (with-throw-handler
386              'cpp-error
387              (lambda ()
388                (case mode
389                  ((code) (eval-cpp-stmt-1/code stmt))
390                  ((file) (eval-cpp-stmt-1/file stmt))))
391              (lambda (key fmt . rest)
392                (report-error fmt rest)
393                (throw 'c99-error "CPP error"))))
394
395           ;; Composition of @code{read-cpp-line} and @code{eval-cpp-line}.
396           ;; We should not be doing this!
397           (define (read-cpp-stmt ch)
398             (and=> (read-cpp-line ch) cpp-line->stmt))
399
400           (define (read-token)
401             (let iter ((ch (read-char)))
402               (cond
403                ((eof-object? ch)
404                 (if (pop-input) (iter (read-char)) (assc-$ '($end . ""))))
405                ((eq? ch #\newline) (set! bol #t) (iter (read-char)))
406                ((char-set-contains? c:ws ch) (iter (read-char)))
407                (bol
408                 (set! bol #f)
409                 (cond ;; things that depend on bol only
410                  ((read-comm ch #t) => assc-$)
411                  ((read-cpp-stmt ch) =>
412                   (lambda (stmt)
413                     (eval-cpp-stmt stmt)
414                     (case mode
415                       ((code) (iter (read-char)))
416                       ((file) (assc-$ `(cpp-stmt . ,stmt))))))
417                  (else (iter ch))))
418                ((read-ident ch) =>
419                 (lambda (name)
420                   (let ((symb (string->symbol name)))
421                     (cond
422                      ((and (x-def? name mode)
423                            (expand-cpp-macro-ref name (cpi-defs info)))
424                       => (lambda (st)
425                            (push-input (open-input-string st))
426                            (iter (read-char))))
427                      ((assq-ref keytab symb)
428                       => (lambda (t) (cons t name)))
429                      ((typename? name)
430                       (cons (assq-ref symtab 'typename) name))
431                      (else
432                       (cons (assq-ref symtab '$ident) name))))))
433                ((read-c-num ch) => assc-$)
434                ((read-c-string ch) => assc-$)
435                ((read-c-chlit ch) => assc-$)
436                ((read-comm ch #f) => assc-$)
437                ((read-chseq ch) => identity)
438                ((assq-ref chrtab ch) => (lambda (t) (cons t (string ch))))
439                ((eqv? ch #\\) ;; C allows \ at end of line to continue
440                 (let ((ch (read-char)))
441                   (cond ((eqv? #\newline ch) (iter (read-char))) ;; extend line
442                         (else (unread-char ch) (cons #\\ "\\"))))) ;; parse err
443                (else (cons ch (string ch))))))
444
445           ;; Loop between reading tokens and skipping tokens via CPP logic.
446           (let iter ((pair (read-token)))
447             (case (car ppxs)
448               ((keep)
449                pair)
450               ((skip-done skip-look)
451                (iter (read-token)))
452               ((skip1-pop)
453                (set! ppxs (cdr ppxs))
454                (iter (read-token)))))
455           )))))
456
457 ;; --- last line ---