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