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