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