nyacc: misc updates; see ChangeLog
[mes.git] / module / nyacc / lang / c99 / mach.scm
1 ;;; lang/c99/mach.scm
2 ;;;
3 ;;; Copyright (C) 2015,2016 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 generator: based on ISO-C99; with comments and CPP statements
19
20 (define-module (nyacc lang c99 mach)
21   #:export (c99-spec c99-mach dev-parse-c dev-parse-c99
22             gen-c99-files gen-c99x-files)
23   #:use-module (nyacc lang c99 cpp)
24   #:use-module (nyacc lang util)
25   #:use-module (nyacc lalr)
26   #:use-module (nyacc parse)
27   #:use-module (nyacc lex)
28   #:use-module (nyacc util)
29   #:use-module ((srfi srfi-9) #:select (define-record-type))
30   #:use-module ((srfi srfi-43) #:select (vector-map))
31   #:use-module ((sxml xpath) #:select (sxpath))
32   )
33
34 ;; @item c99-spec
35 ;; This variable is the specification a-list for the hacked ISO C99 language.
36 ;; Run this through @code{make-lalr-machine} to get an a-list for the
37 ;; automaton.  The grammar is modified to parse CPP statements and comments.
38 ;; The output of the end parser will be a SXML tree (w/o the @code{*TOP*} node.
39 (define c99-spec
40   (lalr-spec
41    (notice lang-crn-lic)
42    (prec< 'then "else")        ; "then/else" SR-conflict resolution
43    (prec< 'imp                 ; "implied type" SR-conflict resolution
44           "char" "short" "int" "long"
45           "float" "double" "_Complex")
46    (start translation-unit-proxy)
47    (grammar
48
49     (translation-unit-proxy (translation-unit ($$ (tl->list $1))))
50
51     ;; expressions
52     (primary-expression                 ; S 6.5.1
53      (identifier ($$ `(p-expr ,$1)))
54      (constant ($$ `(p-expr ,$1)))
55      (string-literal ($$ `(p-expr ,(tl->list $1))))
56      ("(" expression ")" ($$ $2))
57      )
58
59     (postfix-expression                 ; S 6.5.2
60      (primary-expression)
61      (postfix-expression "[" expression "]" ($$ `(array-ref ,$3 ,$1)))
62      (postfix-expression "(" argument-expression-list ")"
63                          ($$ `(fctn-call ,$1 ,(tl->list $3))))
64      (postfix-expression "(" ")" ($$ `(fctn-call ,$1 (expr-list))))
65      (postfix-expression "." identifier ($$ `(d-sel ,$3 ,$1)))
66      (postfix-expression "->" identifier ($$ `(i-sel ,$3 ,$1)))
67      (postfix-expression "++" ($$ `(post-inc ,$1)))
68      (postfix-expression "--" ($$ `(post-dec ,$1)))
69      ("(" type-name ")" "{" initializer-list "}"
70       ($$ `(comp-lit ,$2 ,(tl->list $5))))
71      ("(" type-name ")" "{" initializer-list "," "}"
72       ($$ `(comp-lit ,$2 ,(tl->list $5))))
73      )
74
75     (argument-expression-list
76      (assignment-expression ($$ (make-tl 'expr-list $1)))
77      (argument-expression-list "," assignment-expression ($$ (tl-append $1 $3)))
78      ;; The following is a modification to deal with using abstract declarations
79      ;; as arguments to CPP macros (e.g., see offsetof in <stddef.h>).
80      (arg-expr-hack ($$ (make-tl 'expr-list $1)))
81      (argument-expression-list "," arg-expr-hack ($$ (tl-append $1 $3)))
82      )
83     (arg-expr-hack
84      (declaration-specifiers
85       abstract-declarator ($$ `(param-decl ,(tl->list $1) $2)))
86      (declaration-specifiers ($$ `(param-decl ,(tl->list $1)))))
87
88     (unary-expression
89      (postfix-expression)               ; S 6.5.3
90      ("++" unary-expression ($$ `(pre-inc ,$2)))
91      ("--" unary-expression ($$ `(pre-dec ,$2)))
92      (unary-operator cast-expression ($$ (list $1 $2)))
93      ("sizeof" unary-expression ($$ `(sizeof-expr ,$2)))
94      ("sizeof" "(" type-name ")" ($$ `(sizeof-type ,$3)))
95      )
96     (unary-operator ("&" ($$ 'ref-to)) ("*" ($$ 'de-ref))
97                     ("+" ($$ 'pos)) ("-" ($$ 'neg))
98                     ("~" ($$ 'bitwise-not)) ("!" ($$ 'not)))
99
100     (cast-expression                    ; S 6.5.4
101      (unary-expression)
102      ("(" type-name ")" cast-expression ($$ `(cast ,$2 ,$4)))
103      )
104
105     (multiplicative-expression          ; S 6.5.5
106      (cast-expression)
107      (multiplicative-expression "*" cast-expression ($$ `(mul ,$1 ,$3)))
108      (multiplicative-expression "/" cast-expression ($$ `(div ,$1 ,$3)))
109      (multiplicative-expression "%" cast-expression ($$ `(mod ,$1 ,$3)))
110      )
111
112     (additive-expression                ; S 6.5.6
113      (multiplicative-expression)
114      (additive-expression "+" multiplicative-expression ($$ `(add ,$1 ,$3)))
115      (additive-expression "-" multiplicative-expression ($$ `(sub ,$1 ,$3)))
116      )
117
118     (shift-expression                   ; S 6.5.7
119      (additive-expression)
120      (shift-expression "<<" additive-expression ($$ `(lshift ,$1 ,$3)))
121      (shift-expression ">>" additive-expression ($$ `(rshift ,$1 ,$3)))
122      )
123
124     (relational-expression              ; S 6.5.8
125      (shift-expression)
126      (relational-expression "<" shift-expression ($$ `(lt ,$1 ,$3)))
127      (relational-expression ">" shift-expression ($$ `(gt ,$1 ,$3)))
128      (relational-expression "<=" shift-expression ($$ `(le ,$1 ,$3)))
129      (relational-expression ">=" shift-expression ($$ `(ge ,$1 ,$3)))
130      )
131     
132     (equality-expression                ; S 6.5.9
133      (relational-expression)
134      (equality-expression "==" relational-expression ($$ `(eq ,$1 ,$3)))
135      (equality-expression "!=" relational-expression ($$ `(ne ,$1 ,$3)))
136      )
137
138     ;; called AND-expression
139     (bitwise-and-expression             ; S 6.5.10
140      (equality-expression)
141      (bitwise-and-expression "&" equality-expression
142                              ($$ `(bitwise-and ,$1 ,$3)))
143      )
144
145     ;; called exclusive-OR-expression
146     (bitwise-xor-expression             ; S 6.5.11
147      (bitwise-and-expression)
148      (bitwise-xor-expression "^" bitwise-and-expression
149                              ($$ `(bitwise-xor ,$1 ,$3)))
150      )
151
152     ;; called inclusive-OR-expression
153     (bitwise-or-expression              ; S 6.5.12
154      (bitwise-xor-expression)
155      (bitwise-or-expression "|" bitwise-xor-expression
156                             ($$ `(bitwise-or ,$1 ,$3)))
157      )
158
159     (logical-and-expression             ; S 6.5.13
160      (bitwise-or-expression)
161      (logical-and-expression "&&" bitwise-or-expression
162                              ($$ `(and ,$1 ,$3)))
163      )
164
165     (logical-or-expression              ; 6.5.14
166      (logical-and-expression)
167      (logical-or-expression "||" logical-and-expression
168                             ($$ `(or ,$1 ,$3)))
169      )
170     
171     (conditional-expression
172      (logical-or-expression)
173      (logical-or-expression "?" expression ":" conditional-expression
174                             ($$ `(cond-expr ,$1 ,$3 ,$5)))
175      )
176
177     (assignment-expression              ; S 6.5.16
178      (conditional-expression)
179      (unary-expression assignment-operator assignment-expression
180                        ($$ `(assn-expr ,$1 (op ,$2) ,$3)))
181      )
182     (assignment-operator
183      ("=") ("+=") ("-=") ("*=") ("/=") ("%=")
184      ("<<=") (">>=") ("&=") ("^=") ("|="))
185
186     (expression                         ; S 6.5.17
187      (assignment-expression)
188      (expression "," assignment-expression
189                  ($$ (if (eqv? 'comma-expr (sx-tag $1))
190                          (append $1 (list $3))
191                          `(comma-expr ,$1 ,$3))))
192      )
193
194     (constant-expression                ; S 6.6
195      (conditional-expression)
196      )
197
198     ;; declarations
199     (declaration
200      (declaration-specifiers
201       init-declarator-list
202       ($$ (save-typenames `(decl ,(tl->list $1) ,(tl->list $2))))
203       ";" opt-code-comment
204       ($$ (if (pair? $5) (append $3 (list $5)) $3)))
205      (declaration-specifiers
206       ";" opt-code-comment
207       ($$ (if (pair? $3)
208               `(decl ,(tl->list $1) ,(list $3))
209               `(decl ,(tl->list $1)))))
210      )
211
212     (declaration-specifiers             ; S 6.7
213      ;; storage-class-specifier declaration-specifiers_opt
214      (storage-class-specifier ($$ (make-tl 'decl-spec-list $1)))
215      (storage-class-specifier declaration-specifiers ($$ (tl-insert $2 $1)))
216      ;; type-specifier declaration-specifiers_opt
217      (type-specifier ($$ (make-tl 'decl-spec-list $1)))
218      (type-specifier declaration-specifiers ($$ (tl-insert $2 $1)))
219      ;; type-qualifier declaration-specifiers_opt
220      (type-qualifier ($$ (make-tl 'decl-spec-list $1)))
221      (type-qualifier declaration-specifiers ($$ (tl-insert $2 $1)))
222      ;; function-specifier declaration-specifiers_opt
223      (function-specifier ($$ (make-tl 'decl-spec-list $1)))
224      (function-specifier declaration-specifiers ($$ (tl-insert $2 $1)))
225      )
226
227     (init-declarator-list               ; S 6.7
228      (init-declarator ($$ (make-tl 'init-declr-list $1)))
229      (init-declarator-list "," init-declarator ($$ (tl-append $1 $3)))
230      )
231
232     (init-declarator                    ; S 6.7
233      (declarator ($$ `(init-declr ,$1)))
234      (declarator "=" initializer ($$ `(init-declr ,$1 ,$3)))
235      )
236
237     (storage-class-specifier            ; S 6.7.1
238      ("auto" ($$ '(stor-spec (auto))))
239      ("extern" ($$ '(stor-spec (extern))))
240      ("register" ($$ '(stor-spec (register))))
241      ("static" ($$ '(stor-spec (static))))
242      ("typedef" ($$ '(stor-spec (typedef))))
243      )
244
245     (type-specifier                     ; S 6.7.2
246      ("void" ($$ '(type-spec (void))))
247      (fixed-type-specifier ($$ `(type-spec ,$1))) ; I made this up
248      (float-type-specifier ($$ `(type-spec ,$1))) ; I made this up
249      ("_Bool" ($$/ref 's5.1.5-01 '(type-spec (fixed-type "_Bool"))))
250      (complex-type-specifier ($$ `(type-spec ,$1))) ; I made this up
251      (struct-or-union-specifier ($$ `(type-spec ,$1)))
252      (enum-specifier ($$ `(type-spec ,$1)))
253      (typedef-name ($$ `(type-spec ,$1)))
254      )
255
256     (fixed-type-specifier
257      ("short" ($prec 'imp) ($$ '(fixed-type "short")))
258      ("short" "int" ($$ '(fixed-type "short int")))
259      ("signed" "short" ($prec 'imp) ($$ '(fixed-type "signed short")))
260      ("signed" "short" "int" ($$ '(fixed-type "signed short int")))
261      ("int" ($$ '(fixed-type "int")))
262      ("signed" ($prec 'imp) ($$ '(fixed-type "signed")))
263      ("signed" "int" ($$ '(fixed-type "signed int")))
264      ("long" ($prec 'imp) ($$ '(fixed-type "long")))
265      ("long" "int" ($$ '(fixed-type "long int")))
266      ("signed" "long" ($prec 'imp) ($$ '(fixed-type "signed long")))
267      ("signed" "long" "int" ($$ '(fixed-type "signed long int")))
268      ("long" "long" ($prec 'imp) ($$ '(fixed-type "long long")))
269      ("long" "long" "int" ($$ '(fixed-type "long long int")))
270      ("signed" "long" "long" ($prec 'imp)
271       ($$ '(fixed-type "signed long long")))
272      ("signed" "long" "long" "int" ($$ '(fixed-type "signed long long int")))
273      ("unsigned" "short" "int" ($$ '(fixed-type "unsigned short int")))
274      ("unsigned" "short" ($prec 'imp) ($$ '(fixed-type "unsigned short")))
275      ("unsigned" "int" ($$ '(fixed-type "unsigned int")))
276      ("unsigned" ($prec 'imp) ($$ '(fixed-type "unsigned")))
277      ("unsigned" "long" "int" ($$ '(fixed-type "unsigned long")))
278      ("unsigned" "long" ($prec 'imp) ($$ '(fixed-type "unsigned long")))
279      ("unsigned" "long" "long" "int"
280       ($$ '(fixed-type "unsigned long long int")))
281      ("unsigned" "long" "long" ($prec 'imp)
282       ($$ '(fixed-type "unsigned long long")))
283      ("char" ($$ '(fixed-type "char")))
284      ("signed" "char" ($$ '(fixed-type "signed char")))
285      ("unsigned" "char" ($$ '(fixed-type "unsigned char"))))
286     (float-type-specifier
287      ("float" ($prec 'imp) ($$ '(float-type "float")))
288      ("double" ($prec 'imp) ($$ '(float-type "double")))
289      ("long" "double" ($$ '(float-type "long double"))))
290     (complex-type-specifier
291      ("_Complex" ($$ '(complex-type "_Complex")))
292      ("float" "_Complex" ($$ '(complex-type "float _Complex")))
293      ("double" "_Complex" ($$ '(complex-type "double _Complex")))
294      ("long" "double" "_Complex" ($$ '(complex-type "long double _Complex")))
295      )
296
297     ;; This one modified: split out struct-or-union = "struct"|"union"
298     (struct-or-union-specifier          ; S 6.7.2.1
299      ("struct" ident-like "{" struct-declaration-list "}"
300       ($$ `(struct-def ,$2 ,(tl->list $4))))
301      ("struct" "{" struct-declaration-list "}"
302       ($$ `(struct-def ,(tl->list $3))))
303      ("struct" ident-like ($$ `(struct-ref ,$2)))
304      ("union" ident-like "{" struct-declaration-list "}"
305       ($$ `(union-def ,$2 ,(tl->list $4))))
306      ("union" "{" struct-declaration-list "}"
307       ($$ `(union-def ,(tl->list $3))))
308      ("union" ident-like ($$ `(union-ref ,$2)))
309      )
310     ;; because name following struct/union can be indentifier or typeref
311     (ident-like (identifier) (typedef-name ($$ `(ident ,(cdr $1)))))
312
313     ;; Calling this field-list in the parse tree.
314     (struct-declaration-list            ; S 6.7.2.1
315      (struct-declaration ($$ (make-tl 'field-list $1)))
316      (lone-comment ($$ (make-tl 'field-list $1)))
317      (struct-declaration-list struct-declaration ($$ (tl-append $1 $2)))
318      (struct-declaration-list lone-comment ($$ (tl-append $1 $2)))
319      )
320
321     (struct-declaration                 ; S 6.7.2.1
322      (specifier-qualifier-list
323       struct-declarator-list ";" opt-code-comment
324       ($$ (if (pair? $4)
325               `(comp-decl ,(tl->list $1) ,(tl->list $2) ,$4)
326               `(comp-decl ,(tl->list $1) ,(tl->list $2)))))
327      )
328      
329     (specifier-qualifier-list           ; S 6.7.2.1
330      (type-specifier specifier-qualifier-list ($$ (tl-insert $2 $1)))
331      (type-specifier ($$ (make-tl 'decl-spec-list $1)))
332      (type-qualifier specifier-qualifier-list ($$ (tl-insert $2 $1)))
333      (type-qualifier ($$ (make-tl 'decl-spec-list $1)))
334      )
335
336     (struct-declarator-list             ; S 6.7.2.1
337      (struct-declarator ($$ (make-tl 'comp-declr-list $1)))
338      (struct-declarator-list "," struct-declarator ($$ (tl-append $1 $3)))
339      )
340
341     (struct-declarator                  ; S 6.7.2.1
342      (declarator ($$ `(comp-declr ,$1)))
343      (declarator ":" constant-expression ($$ `(comp-declr (bit-field ,$1 ,$3))))
344      (":" constant-expression ($$ `(comp-declr (bit-field ,$2))))
345      )
346
347     (enum-specifier                     ; S 6.7.2.2
348      ("enum" identifier "{" enumerator-list "}"
349       ($$ `(enum-def ,$2 ,(tl->list $4))))
350      ("enum" identifier "{" enumerator-list "," "}"
351       ($$ `(enum-def ,$2 ,(tl->list $4))))
352      ("enum" "{" enumerator-list "}" ($$ `(enum-def ,(tl->list $3))))
353      ("enum" "{" enumerator-list "," "}" ($$ `(enum-def ,(tl->list $3))))
354      ("enum" identifier ($$ `(enum-ref ,$2)))
355      )
356
357     ;; keeping old enum-def-list in parse tree
358     (enumerator-list                    ; S 6.7.2.2
359      (enumerator ($$ (make-tl 'enum-def-list $1)))
360      (enumerator-list "," enumerator ($$ (tl-append $1 $3)))
361      )
362
363     ;; Had to change enumeration-constant => identifier
364     (enumerator                         ; S 6.7.2.2
365      (identifier ($$ `(enum-defn ,$1)))
366      (identifier "=" constant-expression ($$ `(enum-defn ,$1 ,$3)))
367      )
368
369     (type-qualifier
370      ("const" ($$ `(type-qual ,$1)))
371      ("volatile" ($$ `(type-qual ,$1)))
372      ("restrict" ($$ `(type-qual ,$1)))
373      )
374
375     (function-specifier ("inline" ($$ `(fctn-spec ,$1))))
376     
377     (declarator
378      (pointer direct-declarator ($$ `(ptr-declr ,$1 ,$2)))
379      (direct-declarator)
380      )
381
382     (direct-declarator
383      (identifier ($$ $1))
384      ("(" declarator ")" ($$ `(scope ,$2)))
385
386      (direct-declarator
387       "[" type-qualifier-list assignment-expression "]"
388       ($$ `(array-of ,$1 ,$3 ,$4)))
389      (direct-declarator "[" type-qualifier-list "]" ($$ `(array-of ,$1 ,$3)))
390      (direct-declarator "[" assignment-expression "]" ($$ `(array-of ,$1 ,$3)))
391      (direct-declarator "[" "]" ($$ `(array-of ,$1)))
392      (direct-declarator
393       "[" "static" type-qualifier-list assignment-expression "]"
394       ($$ `(array-of ,$1 ,(tl->list (tl-insert '(stor-spec "static") $4)) ,$5)))
395      (direct-declarator
396       "[" type-qualifier-list "static" assignment-expression "]"
397       ($$ `(array-of ,$1 ,(tl->list (tl-insert '(stor-spec "static") $3)) ,$5)))
398      (direct-declarator
399       "[" type-qualifier-list "*" "]"   ; variable length array
400       ($$ `(array-of ,$1 ,$3 (var-len))))
401      (direct-declarator
402       "[" "*" "]"                       ; variable length array
403       ($$ `(array-of ,$1 (var-len))))
404      (direct-declarator "(" parameter-type-list ")"
405                         ($$ `(ftn-declr ,$1 ,(tl->list $3))))
406      (direct-declarator "(" identifier-list ")"
407                         ($$ `(ftn-declr ,$1 ,(tl->list $3))))
408      (direct-declarator "(" ")" ($$ `(ftn-declr ,$1 (param-list))))
409      )
410
411     (pointer
412      ("*" type-qualifier-list ($$ `(pointer ,(tl->list $2))))
413      ("*" ($$ '(pointer)))
414      ("*" type-qualifier-list pointer ($$ `(pointer ,(tl->list $2) ,$3)))
415      ("*" pointer ($$ `(pointer ,$2)))
416      )
417
418     ;; But put in tree as decl-spec-list
419     (type-qualifier-list
420      (type-qualifier ($$ (make-tl 'decl-spec-list $1)))
421      (type-qualifier-list type-qualifier ($$ (tl-append $1 $2)))
422      )
423
424     (parameter-type-list
425      (parameter-list ($$ $1))
426      (parameter-list "," "..." ($$ (tl-append $1 '(ellipsis))))
427      )
428
429     (parameter-list
430      (parameter-declaration ($$ (make-tl 'param-list $1)))
431      (parameter-list "," parameter-declaration ($$ (tl-append $1 $3)))
432      )
433
434     (parameter-declaration
435      (declaration-specifiers declarator
436                              ($$ `(param-decl ,(tl->list $1)
437                                                (param-declr ,$2))))
438      (declaration-specifiers abstract-declarator
439                              ($$ `(param-decl ,(tl->list $1)
440                                                (param-declr ,$2))))
441      (declaration-specifiers ($$ `(param-decl ,(tl->list $1))))
442      )
443
444     (identifier-list
445      (identifier ($$ (make-tl 'ident-list $1)))
446      (identifier-list "," identifier ($$ (tl-append $1 $3)))
447      )
448
449     (type-name                          ; S 6.7.6
450      ;; e.g., (foo_t *)
451      (specifier-qualifier-list abstract-declarator
452                                ($$ `(type-name ,(tl->list $1) ,$2)))
453      ;; e.g., (int)
454      (declaration-specifiers ($$ `(type-name ,(tl->list $1)))) 
455      )
456
457     (abstract-declarator                ; S 6.7.6
458      (pointer ($$ `(abs-declr ,$1)))
459      (pointer direct-abstract-declarator ($$ `(abs-declr ,$1 ,$2)))
460      (direct-abstract-declarator ($$ `(abs-declr ,$1)))
461      )
462
463     (direct-abstract-declarator
464      ("(" abstract-declarator ")" ($$ `(declr-scope ,$2)))
465      (direct-abstract-declarator
466       "[" type-qualifier-list assignment-expression "]"
467       ($$ `(declr-array ,$3 ,$4)))
468      (direct-abstract-declarator
469       "[" type-qualifier-list "]"
470       ($$ `(declr-array ,$1 ,$3)))
471      (direct-abstract-declarator
472       "[" assignment-expression "]"
473       ($$ `(declr-array ,$1 ,$3)))
474      (direct-abstract-declarator
475       "[" "]" ($$ `(declr-array ,$1)))
476      (direct-abstract-declarator
477       "[" "static" type-qualifier-list assignment-expression "]"
478       ($$ `(declr-array
479             ,$1 ,(tl->list (tl-insert '(stor-spec "static") $4)) ,$5)))
480      (direct-abstract-declarator
481       "[" "static" type-qualifier-list "]"
482       ($$ `(declr-array ,$1 ,(tl->list (tl-insert '(stor-spec "static") $4)))))
483      (direct-abstract-declarator
484       "[" type-qualifier-list "static" assignment-expression "]"
485       ($$ `(declr-array
486             ,$1 ,(tl->list (tl-insert '(stor-spec "static") $3)) ,$5)))
487      ;;
488      ("[" type-qualifier-list assignment-expression "]"
489       ($$ `(declr-anon-array ,$2 ,$3)))
490      ("[" type-qualifier-list "]" ($$ `(declr-anon-array ,$2)))
491      ("[" assignment-expression "]" ($$ `(declr-anon-array ,$2)))
492      ("[" "]" ($$ `(declr-anon-array)))
493      ("[" "static" type-qualifier-list assignment-expression "]"
494       ($$ `(declr-anon-array
495             ,(tl->list (tl-insert '(stor-spec "static") $3)) ,$4)))
496      ("[" "static" type-qualifier-list "]"
497       ($$ `(declr-anon-array ,(tl->list (tl-insert '(stor-spec "static") $3)))))
498      ("[" type-qualifier-list "static" assignment-expression "]"
499       ($$ `(declr-anon-array
500             ,(tl->list (tl-insert '(stor-spec "static") $2)) ,$4)))
501      (direct-abstract-declarator "[" "*" "]" ($$ `(declr-STAR ,$1)))
502      ("[" "*" "]" ($$ '(declr-STAR)))
503      (direct-abstract-declarator "(" parameter-type-list ")"
504                                  ($$ `(declr-fctn ,$1 ,(tl->list $3))))
505      (direct-abstract-declarator "(" ")" ($$ `(declr-fctn ,$1)))
506      ("(" parameter-type-list ")" ($$ `(declr-anon-fctn ,(tl->list $2))))
507      ("(" ")" ($$ '(declr-anon-fctn)))
508      )
509
510     ;;typedef-name must be hacked w/ the lexical analyzer
511     (typedef-name ('typename ($$ `(typename ,$1))))
512
513     (initializer                        ; S 6.7.8
514      (assignment-expression ($$ `(initzer ,$1)))
515      ("{" initializer-list "}" ($$ `(initzer ,(tl->list $2))))
516      ("{" initializer-list "," "}" ($$ `(initzer ,(tl->list $2))))
517      )
518
519     ;; The designation productions are from C99.
520     (initializer-list
521      (designation initializer ($$ (make-tl 'initzer-list $1 $2)))
522      (initializer ($$ (make-tl 'initzer-list $1)))
523      (initializer-list "," designation initializer ($$ (tl-append $1 $3 $4)))
524      (initializer-list "," initializer ($$ (tl-append $1 $3)))
525      )
526
527     (designation                        ; S 6.7.8
528      (designator-list "=" ($$ `(desig ,$1)))
529      )
530
531     (designator-list
532      (designator ($$ (make-tl 'desgr-list $1)))
533      (designator-list designator ($$ (tl-append $1 $2)))
534      )
535
536     (designator
537      ("[" constant-expression "]" ($$ (list 'array-dsgr $2)))
538      ("." identifier ($$ (list 'sel-dsgr $2)))
539      )
540
541     ;; statements
542     (statement
543      (labeled-statement)
544      (compound-statement)
545      (expression-statement)
546      (selection-statement)
547      (iteration-statement)
548      (jump-statement)
549      (cpp-statement)
550      )
551
552     (labeled-statement
553      (identifier ":" statement ($$ `(labeled-stmt ,$1 ,$3)))
554      ("case" constant-expression ":" statement ($$ `(case ,$2 ,$4)))
555      ("default" ":" statement ($$ `(default ,$3)))
556      )
557
558     (compound-statement
559      ("{" block-item-list "}" 
560       ($$ `(compd-stmt ,(tl->list $2))))
561      ("{" "}"
562       ($$ `(compd-stmt (block-item-list))))
563      )
564
565     (block-item-list
566      (block-item ($$ (make-tl 'block-item-list $1)))
567      (block-item-list block-item ($$ (tl-append $1 $2)))
568      )
569
570     (block-item
571      (declaration)
572      (statement)
573      )
574     
575     (expression-statement
576      (expression ";" ($$ `(expr-stmt ,$1)))
577      (";" ($$ '(expr-stmt)))
578      )
579
580     (selection-statement
581      ("if" "(" expression ")" statement ($prec 'then)
582       ($$ `(if ,$3 ,$5)))
583      ("if" "(" expression ")" statement "else" statement
584       ($$ `(if ,$3 ,$5 ,$7)))
585      ("switch" "(" expression ")" statement ($$ `(switch ,$3 ,$5)))
586      )
587
588     (iteration-statement
589      ("while" "(" expression ")" statement ($$ `(while ,$3 ,$5)))
590      ("do" statement "while" "(" expression ")" ";" ($$ `(do-while ,$2 ,$5)))
591      ("for" "(" initial-clause opt-expression ";" opt-expression ")" statement
592       ($$ `(for ,$3 ,$4 ,$6 ,$8)))
593      )
594     (initial-clause                     ; <= added for convenience
595      (expression ";")
596      (";" ($$ '(expr)))
597      (declaration))
598     (opt-expression                     ; <= added for convenience
599      ($empty ($$ '(expr)))
600      (expression))
601
602     (jump-statement                     ; S 6.8.6
603      ("goto" identifier ";" ($$ `(goto $2)))
604      ("continue" ";" ($$ '(continue)))
605      ("break" ";" ($$ '(break)))
606      ("return" expression ";" ($$ `(return ,$2)))
607      ("return" ";" ($$ `(return (expr))))
608      )
609
610     ;; external definitions
611     (translation-unit
612      (external-declaration ($$ (make-tl 'trans-unit $1)))
613      (translation-unit
614       external-declaration
615       ($$ (cond ((eqv? 'trans-unit (car $2))
616                  (let* ((t1 (tl-append $1 '(extern-C-begin)))
617                         (t2 (tl-extend t1 (cdr $2)))
618                         (t3 (tl-append t2 '(extern-C-end))))
619                    t3))
620                 (else (tl-append $1 $2)))))
621      )
622
623     (external-declaration
624      (function-definition)
625      (declaration)
626      (lone-comment)
627      (cpp-statement)
628      ;; The following is a kludge to deal with @code{extern "C" @{}.
629      ("extern" $string "{" translation-unit "}" ($$ (tl->list $4)))
630      )
631     
632     (function-definition
633      (declaration-specifiers
634       declarator declaration-list compound-statement
635       ($$ `(knr-fctn-defn ,(tl->list $1) ,$2 ,(tl->list $3) ,$4)))
636      (declaration-specifiers
637       declarator compound-statement
638       ($$ `(fctn-defn ,(tl->list $1) ,$2 ,$3)))
639      )
640     
641     (declaration-list
642      (declaration ($$ (make-tl $1)))
643      (declaration-list declaration ($$ (tl-append $1 $2)))
644      )
645
646     (opt-code-comment () (code-comment))
647     ;;(opt-lone-comment () (lone-comment))
648     ;;(opt-comment () (code-comment) (lone-comment))
649
650     ;; non-terminal leaves
651     (identifier
652      ($ident ($$ `(ident ,$1)))
653      ('cpp-ident ($$ `(ident ,$1))))
654     (constant
655      ($fixed ($$ `(fixed ,$1)))         ; integer-constant
656      ($float ($$ `(float ,$1)))         ; floating-constant
657      ($chlit ($$ `(char ,$1))))         ; char-constant
658     (string-literal
659      ($string ($$ (make-tl 'string $1))) ; string-constant
660      (string-literal $string ($$ (tl-append $1 $2))))
661     (code-comment ($code-comm ($$ `(comment ,$1))))
662     (lone-comment ($lone-comm ($$ `(comment ,$1))))
663     (cpp-statement ('cpp-stmt ($$ `(cpp-stmt ,$1))))
664
665     )))
666
667
668 (define c99-mach
669   (compact-machine
670    (hashify-machine
671     (make-lalr-machine c99-spec))))
672
673 ;;; =====================================
674
675 ;; The following are needed by the code in pbody.scm.
676 (define len-v (assq-ref c99-mach 'len-v))
677 (define pat-v (assq-ref c99-mach 'pat-v))
678 (define rto-v (assq-ref c99-mach 'rto-v))
679 (define mtab (assq-ref c99-mach 'mtab))
680 (define act-v (vector-map
681                (lambda (ix f) (eval f (current-module)))
682                (vector-map (lambda (ix actn) (wrap-action actn))
683                            (assq-ref c99-mach 'act-v))))
684
685 (include-from-path "nyacc/lang/c99/body.scm")
686
687 (define raw-parser (make-lalr-parser c99-mach))
688
689 (define (run-parse)
690   (let ((info (fluid-ref *info*)))
691     (raw-parser (gen-c-lexer) #:debug (cpi-debug info))))
692
693 (define* (dev-parse-c99 #:key
694                         (cpp-defs '())  ; CPP defines
695                         (inc-dirs '())  ; include directories
696                         (td-dict '())   ; typedef dictionary
697                         (mode 'file)    ; mode: 'file or 'code
698                         (xdef? #f)      ; expand def function: proc name mode
699                         (debug #f))     ; debug
700   (catch
701    'parse-error
702    (lambda ()
703      (let ((info (make-cpi debug cpp-defs (cons "." inc-dirs) td-dict)))
704        (with-fluid* *info* info
705                     (lambda ()
706                       (raw-parser (gen-c-lexer #:mode mode #:xdef? xdef?)
707                                   #:debug debug)))))
708    (lambda (key fmt . rest)
709      (apply simple-format (current-error-port) (string-append fmt "\n") rest)
710      #f)))
711
712 (define dev-parse-c dev-parse-c99)
713
714 ;;; =====================================
715
716 ;; @item gen-c99-files [dir] => #t
717 ;; Update or generate the files @quot{c99act.scm} and @quot{c99tab.scm}.
718 ;; These are the tables and actions for the C99 parser.
719 ;; If there are no changes to existing files, no update occurs.
720 (define (gen-c99-files . rest)
721   (define (lang-dir path)
722     (if (pair? rest) (string-append (car rest) "/" path) path))
723   (define (xtra-dir path)
724     (lang-dir (string-append "mach.d/" path)))
725
726   (write-lalr-actions c99-mach (xtra-dir "c99act.scm.new"))
727   (write-lalr-tables c99-mach (xtra-dir "c99tab.scm.new"))
728   (let ((a (move-if-changed (xtra-dir "c99act.scm.new")
729                             (xtra-dir "c99act.scm")))
730         (b (move-if-changed (xtra-dir "c99tab.scm.new")
731                             (xtra-dir "c99tab.scm"))))
732     (when (or a b) 
733       (system (string-append "touch " (lang-dir "parser.scm")))
734       #;(compile-file (lang-dir "parser.scm"))
735       )))
736
737 ;; @item gen-c99x-files [dir] => #t
738 ;; Update or generate the files @quot{c99xact.scm} and @quot{c99xtab.scm}.
739 ;; These are the tables and actions for the C99 expression parser.
740 ;; If there are no changes to existing files, no update occurs.
741 (define (gen-c99x-files . rest)
742   (define (lang-dir path)
743     (if (pair? rest) (string-append (car rest) "/" path) path))
744   (define (xtra-dir path)
745     (lang-dir (string-append "mach.d/" path)))
746
747   (let* ((cexpr-spec (restart-spec c99-mach 'expression))
748          (cexpr-mach (compact-machine
749                       (hashify-machine
750                        (make-lalr-machine cexpr-spec)))))
751     (write-lalr-actions cexpr-mach (xtra-dir "c99xact.scm.new"))
752     (write-lalr-tables cexpr-mach (xtra-dir "c99xtab.scm.new")))
753     
754   (let ((a (move-if-changed (xtra-dir "c99xact.scm.new")
755                             (xtra-dir "c99xact.scm")))
756         (b (move-if-changed (xtra-dir "c99xtab.scm.new")
757                             (xtra-dir "c99xtab.scm"))))
758     (when (or a b) 
759       (system (string-append "touch " (lang-dir "parser.scm")))
760       #;(compile-file (lang-dir "xparser.scm"))
761       )))
762
763 ;; --- last line ---