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