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