nyacc: misc updates; see ChangeLog
[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 (define-record-type cpi
21   (make-cpi-1)
22   cpi?
23   (debug cpi-debug set-cpi-debug!)      ; debug #t #f
24   (defines cpi-defs set-cpi-defs!)      ; #defines
25   (incdirs cpi-incs set-cpi-incs!)      ; #includes
26   (tn-dict cpi-tynd set-cpi-tynd!)      ; typename dict (("<x>" foo_t ..
27   ;;
28   ;;(typnams cpi-tyns set-cpi-tyns!)    ; typedef names
29   ;;
30   (ptl cpi-ptl set-cpi-ptl!)            ; parent typename list
31   (ctl cpi-ctl set-cpi-ctl!)            ; current typename list
32   ;;
33   ;;(typdcls cpi-tdls set-cpi-tdls!)    ; typedef decls
34   )
35
36 (define std-dict
37   '(
38     ("alloca.h")
39     ("complex.h" "complex" "imaginary")
40     ("ctype.h")
41     ("fenv.h" "fenv_t" "fexcept_t")
42     ("float.h" "float_t")
43     ("inttypes.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      "imaxdiv_t")
49     ("limits.h")
50     ("math.h")
51     ("regex.h" "regex_t" "regmatch_t")
52     ("setjmp.h" "jmp_buf")
53     ("signal.h" "sig_atomic_t")
54     ("string.h" "size_t")
55     ("stdarg.h" "va_list")
56     ("stddef.h" "ptrdiff_t" "size_t" "wchar_t")
57     ("stdint.h"
58      "int8_t" "uint8_t" "int16_t" "uint16_t" "int32_t" "uint32_t"
59      "int64_t" "uint64_t" "uintptr_t" "intptr_t" "intmax_t" "uintmax_t"
60      "int_least8_t" "uint_least8_t" "int_least16_t" "uint_least16_t"
61      "int_least32_t" "uint_least32_t" "int_least64_t" "uint_least64_t")
62     ("stdio.h" "FILE" "size_t")
63     ("stdlib.h" "div_t" "ldiv_t" "lldiv_t" "wchar_t")
64     ("time.h" "time_t" "clock_t" "size_t")
65     ("unistd.h" "size_t" "ssize_t" "div_t" "ldiv_t")
66     ("wchar.h" "wchar_t" "wint_t" "mbstate_t" "size_t")
67     ("wctype.h" "wctrans_t" "wctype_t" "wint_t")
68     ))
69
70 (define (make-cpi debug defines incdirs tn-dict)
71   (let* ((cpi (make-cpi-1)))
72     (set-cpi-debug! cpi debug)
73     (set-cpi-defs! cpi defines)
74     (set-cpi-incs! cpi incdirs)
75     (set-cpi-tynd! cpi (append tn-dict std-dict))
76     (set-cpi-ptl! cpi '())              ; list of lists of strings
77     (set-cpi-ctl! cpi '())              ; list of strings ?
78     cpi))
79
80 ;; Need to have a "CPI" stack to deal with types (re)defined in multiple
81 ;; branches of a #if...#endif statement.  If we are in "code" mode then we
82 ;; may be skipping code so need to track when to shift and when not to.
83
84 (define *info* (make-fluid #f))
85
86 ;; given tyns
87 ;; cadr is next level
88 ;; caar is list of sibs
89 ;; search (caar car tyns), then (caar cadr tyns), then ...
90
91 ;; @deffn typename? name
92 ;; Called by lexer to determine if symbol is a typename.
93 ;; Check current sibling for each generation.
94 (define (typename? name)
95   ;;(simple-format #t "typename? ~S\n" name)
96   (let ((cpi (fluid-ref *info*)))
97     (when #f ;;(string=? name "SpiceInt")
98       (simple-format #t "tn? ~S  ~S\n" (cpi-ctl cpi) (cpi-ptl cpi)))
99     (if (member name (cpi-ctl cpi)) #t
100         (let iter ((ptl (cpi-ptl cpi)))
101           (if (null? ptl) #f
102               (if (member name (car ptl)) #t
103                   (iter (cdr ptl))))))))
104
105 ;; @deffn add-typename name
106 ;; Helper for @code{save-typenames}.
107 (define (add-typename name)
108   ;;(simple-format #t "add-typename ~S\n" name)
109   (let ((cpi (fluid-ref *info*)))
110     (set-cpi-ctl! cpi (cons name (cpi-ctl cpi)))
111     ;;(simple-format #t "at: ~S  ~S\n" (cpi-ctl cpi) (cpi-ptl cpi))
112     ))
113
114 (define (cpi-push)      ;; on #if
115   (let ((cpi (fluid-ref *info*)))
116     (set-cpi-ptl! cpi (cons (cpi-ctl cpi) (cpi-ptl cpi)))
117     (set-cpi-ctl! cpi '())
118     ;;(simple-format #t "pu: ~S\n" (cpi-ctl cpi))
119     ))
120
121 (define (cpi-shift)     ;; on #elif #else
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 (use-modules (ice-9 pretty-print))
133
134 ;; @deffn find-new-typenames decl
135 ;; Helper for @code{save-typenames}.
136 ;; Given declaration return a list of new typenames (via @code{typedef}).
137 (define (find-new-typenames decl)
138
139   ;; like declr->ident in util2.scm
140   (define (declr->id-name declr)
141     (case (car declr)
142       ((ident) (sx-ref declr 1))
143       ((init-declr) (declr->id-name (sx-ref declr 1)))
144       ((comp-declr) (declr->id-name (sx-ref declr 1)))
145       ((array-of) (declr->id-name (sx-ref declr 1)))
146       ((ptr-declr) (declr->id-name (sx-ref declr 2)))
147       ((ftn-declr) (declr->id-name (sx-ref declr 1)))
148       ((scope) (declr->id-name (sx-ref declr 1)))
149       (else (error "coding bug: " declr))))
150        
151   (let* ((spec (sx-ref decl 1))
152          (stor (sx-find 'stor-spec spec))
153          (id-l (sx-ref decl 2)))
154     (if (and stor (eqv? 'typedef (caadr stor)))
155         (let iter ((res '()) (idl (cdr id-l)))
156           (if (null? idl) res
157               (iter (cons (declr->id-name (sx-ref (car idl) 1)) res)
158                     (cdr idl))))
159         '())))
160
161 ;; @deffn save-typenames decl
162 ;; Save the typenames for the lexical analyzer and return the decl.
163 (define (save-typenames decl)
164   ;; This finds typenames using @code{find-new-typenames} and adds via
165   ;; @code{add-typename}.  Then return the decl.
166   (for-each add-typename (find-new-typenames decl))
167   decl)
168
169
170 ;; ------------------------------------------------------------------------
171
172 ;; @deffn read-cpp-line ch => #f | (cpp-xxxx)??
173 ;; Given if ch is #\# read a cpp-statement
174 ;; includes BUG: #define ABC 123 /* \n
175 (define (read-cpp-line ch)
176   (if (not (eq? ch #\#)) #f
177       (let iter ((cl '()) (ch (read-char)))
178         (cond
179          ((eq? ch #\newline) (list->string (reverse cl)))
180          ((eq? ch #\\)
181           (let ((c2 (read-char)))
182             (if (eq? c2 #\newline)
183                 (iter cl (read-char))
184                 (iter (cons* c2 ch cl) (read-char)))))
185          ((eq? ch #\/) ;; swallow comments, event w/ newlines
186           (let ((c2 (read-char)))
187             (cond
188              ((eqv? c2 #\*)
189               (let iter2 ((cl2 (cons* #\* #\/ cl)) (ch (read-char)))
190                 (cond
191                  ((eq? ch #\*)
192                   (let ((c2 (read-char)))
193                     (if (eqv? c2 #\/)
194                         (iter (cons* #\/ #\* cl2) (read-char)) ;; keep comment
195                         ;;(iter cl (read-char)) ;; toss comment
196                         (iter2 (cons #\* cl2) c2))))
197                  (else
198                   (iter2 (cons ch cl2) (read-char))))))
199              (else
200               (iter (cons #\/ cl) c2)))))
201          (else (iter (cons ch cl) (read-char)))))))
202
203 ;; @deffn find-file-in-dirl file dirl => path
204 (define (find-file-in-dirl file dirl)
205   (let iter ((dirl dirl))
206     (if (null? dirl) #f
207         (let ((p (string-append (car dirl) "/" file)))
208           (if (access? p R_OK) p (iter (cdr dirl)))))))
209
210
211 ;; @subsubsection CPP If-Else Processing
212 ;; States are
213 ;; @table code
214 ;; @item skip
215 ;; skip code
216 ;; @item skip-look
217 ;; skipping code, but still looking for true at this level
218 ;; @item keep
219 ;; keep code
220 ;; @item keep1
221 ;; NOT USED keep one token and pop skip-stack
222 ;; @item skip-one
223 ;; skip one token and pop skip-stack
224 ;; @end table
225
226 ;; NOTE: if file mode we usually keep #ifdefs.  The lone exception is
227 ;; @code{#if 0}
228
229 ;; @deffn gen-c-lexer [#:mode mode] => thunk
230 ;; Generate a context-sensitive lexer for the C language.
231 ;; The key-arg @var{mode} can be @code{'code} or @code{'file}.  If @code{'code}
232 ;; @enumerate
233 ;; @item
234 ;; CPP defines are expanded (future work)
235 ;; @item
236 ;; CPP if/def is executed
237 ;; @end enumerate
238 (define (def-xdef? name mode)
239   (eqv? mode 'code))
240
241 ;; @deffn gen-c-lexer [#:mode mode] [#:xdef? proc] => thunk
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     ;; ppev?: (proc ???) => #t|#f : do we eval-and-honor #if/#else ?
272     (lambda* (#:key (mode 'code) (xdef? #f))
273       (let ((bol #t)                  ; begin-of-line condition
274             (skip (list 'keep))       ; CPP skip-input stack
275             (info (fluid-ref *info*)) ; assume make and run in same thread
276             (pstk '())                ; port stack
277             (x-def? (or xdef? (lambda (name mode) (eqv? mode 'code)))))
278         ;; Return the first (tval lval) pair not excluded by the CPP.
279         (lambda ()
280
281           (define (eval-flow?)
282             (eqv? mode 'code))
283       
284           (define (add-define tree)
285             (let* ((tail (cdr tree))
286                    (name (car (assq-ref tail 'name)))
287                    (args (assq-ref tail 'args))
288                    (repl (car (assq-ref tail 'repl)))
289                    (cell (cons name (if args (cons args repl) repl))))
290               (set-cpi-defs! info (cons cell (cpi-defs info)))))
291           
292           (define (rem-define name)
293               (set-cpi-defs! info (delete name (cpi-defs info))))
294           
295           (define (exec-cpp line)
296             ;; Parse the line into a CPP stmt, execute it, and return it.
297             (let* ((stmt (read-cpp-stmt line))
298                    (perr (lambda (file)
299                            (throw 'parse-error "file not found: ~S" file))))
300               (case (car stmt)
301                 ((include)
302                  (let* ((parg (cadr stmt)) (leng (string-length parg))
303                         (file (substring parg 1 (1- leng)))
304                         (tynd (assoc-ref (cpi-tynd info) file)))
305                    (if tynd
306                        (for-each add-typename tynd)
307                        (let* ((pth (find-file-in-dirl file (cpi-incs info)))
308                               (tree (if pth ; path exists
309                                         (or (with-input-from-file pth run-parse)
310                                             (throw 'parse-error "~A" pth))
311                                         (perr file))))
312                          (for-each add-define (xp1 tree)) ; add def's 
313                          ;; Attach tree onto "include" statement.
314                          (if (pair? tree) (set! stmt (append stmt (list tree))))
315                          ))))
316                 ((define)
317                  (add-define stmt))
318                 ((undef)
319                  (rem-define (cadr stmt)))
320                 ((if) ;; and ifdef, ifndef
321                  (cpi-push)
322                  (if (eval-flow?)
323                      (let* ((defs (cpi-defs info))
324                             (rhs (cpp-expand-text (cadr stmt) defs))
325                             ;; rhs = "defined(1)" :(
326                             (exp (parse-cpp-expr rhs))
327                             (val (eval-cpp-expr exp defs)))
328                        (cond
329                         ((not val)
330                          (throw 'parse-error "unresolved: ~S" (cadr stmt)))
331                         ((zero? val)
332                          (set! skip (cons* 'skip-one 'skip-look skip)))
333                         (else
334                          (set! skip (cons* 'skip-one (car skip) skip)))))))
335                 ((elif)
336                  (if (eval-flow?)
337                      (let* ((defs (cpi-defs info))
338                             (rhs (cpp-expand-text (cadr stmt) defs))
339                             (exp (parse-cpp-expr rhs))
340                             (val (eval-cpp-expr exp defs)))
341                        (cond
342                         ((not val)
343                          (throw 'parse-error "unresolved: ~S" (cadr stmt)))
344                         ((eq? 'keep (car skip))
345                          (set! skip (cons* 'skip-one 'skip (cdr skip))))
346                         ((zero? val)
347                          (set! skip (cons* 'skip-one skip)))
348                         ((eq? 'skip-look (car skip))
349                          (cpi-shift)
350                          (set! skip (cons* 'skip-one 'keep (cdr skip))))
351                         (else
352                          (cpi-shift)
353                          (set! skip (cons* 'skip-one 'skip (cdr skip))))))
354                      (cpi-shift)))
355                 ((else)
356                  (if (eval-flow?)
357                      (cond
358                       ((eq? 'skip-look (car skip))
359                        (cpi-shift)
360                        (set! skip (cons* 'skip-one 'keep (cdr skip))))
361                       (else
362                        (set! skip (cons* 'skip-one 'skip (cdr skip)))))
363                      (cpi-shift)))
364                 ((endif)
365                  (cpi-pop)
366                  (if (eval-flow?)
367                      (set! skip (cons 'skip-one (cdr skip)))))
368                 ((error)
369                  stmt)
370                 (else
371                  (error "unhandled cpp stmt")))
372               (cons 'cpp-stmt stmt)))
373           
374           ;; Composition of @code{read-cpp-line} and @code{exec-cpp}.
375           (define (read-cpp ch)
376             (and=> (read-cpp-line ch) exec-cpp))
377
378           (define (read-token)
379             (let iter ((ch (read-char)))
380               (cond
381                ((eof-object? ch)
382                 (if (pop-input) (iter (read-char)) (assc-$ '($end . ""))))
383                ((eq? ch #\newline) (set! bol #t) (iter (read-char)))
384                ((char-set-contains? c:ws ch) (iter (read-char)))
385                (bol
386                 (cond
387                  ((read-comm ch bol) => assc-$)
388                  ((read-cpp ch) => assc-$)
389                  (else (set! bol #f) (iter ch))))
390                ((read-ident ch) =>
391                 (lambda (name)
392                   (let ((symb (string->symbol name)))
393                     (cond
394                      ((and (x-def? name mode)
395                            (expand-cpp-mref name (cpi-defs info)))
396                       => (lambda (st)
397                            (push-input (open-input-string st))
398                            (iter (read-char))))
399                      ((assq-ref keytab symb)
400                       => (lambda (t) (cons t name)))
401                      ((typename? name)
402                       (cons (assq-ref symtab 'typename) name))
403                      (else
404                       (cons (assq-ref symtab '$ident) name))))))
405                ((read-c-num ch) => assc-$)
406                ((read-c-string ch) => assc-$)
407                ((read-c-chlit ch) => assc-$)
408                ((read-comm ch bol) => assc-$)
409                ((read-chseq ch) => identity)
410                ((assq-ref chrtab ch) => (lambda (t) (cons t (string ch))))
411                ((eqv? ch #\\) ;; C allows \ at end of line to continue
412                 (let ((ch (read-char)))
413                   (cond ((eqv? #\newline ch) (iter (read-char))) ;; extend line
414                         (else (unread-char ch) (cons #\\ "\\"))))) ;; parse err
415                (else (cons ch (string ch))))))
416
417           ;; Loop between reading tokens and skipping tokens.
418           ;; The use of "delayed pop" is not clean IMO.  Cleaner way?
419           (let loop ((pair (read-token)))
420             (case (car skip)
421               ((keep) pair)
422               ((skip skip-look) (loop (read-token)))
423               ((skip-one)
424                (set! skip (cdr skip))
425                (loop (read-token)))))
426           )))))
427
428 ;; --- last line ---