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