nyacc: exceptions worked on.. still need to fix #
[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 declarator
433                              ($$ `(param-decl ,(tl->list $1)
434                                                (param-declr ,$2))))
435      (declaration-specifiers abstract-declarator
436                              ($$ `(param-decl ,(tl->list $1)
437                                                (param-declr ,$2))))
438      (declaration-specifiers ($$ `(param-decl ,(tl->list $1))))
439      )
440
441     (identifier-list
442      (identifier ($$ (make-tl 'ident-list $1)))
443      (identifier-list "," identifier ($$ (tl-append $1 $3)))
444      )
445
446     (type-name                          ; S 6.7.6
447      ;; e.g., (foo_t *)
448      (specifier-qualifier-list abstract-declarator
449                                ($$ `(type-name ,(tl->list $1) ,$2)))
450      ;; e.g., (int)
451      (declaration-specifiers ($$ `(type-name ,(tl->list $1)))) 
452      )
453
454     (abstract-declarator                ; S 6.7.6
455      (pointer ($$ `(abs-declr ,$1)))
456      (pointer direct-abstract-declarator ($$ `(abs-declr ,$1 ,$2)))
457      (direct-abstract-declarator ($$ `(abs-declr ,$1)))
458      )
459
460     (direct-abstract-declarator
461      ("(" abstract-declarator ")" ($$ `(declr-scope ,$2)))
462      (direct-abstract-declarator
463       "[" type-qualifier-list assignment-expression "]"
464       ($$ `(declr-array ,$3 ,$4)))
465      (direct-abstract-declarator
466       "[" type-qualifier-list "]"
467       ($$ `(declr-array ,$1 ,$3)))
468      (direct-abstract-declarator
469       "[" assignment-expression "]"
470       ($$ `(declr-array ,$1 ,$3)))
471      (direct-abstract-declarator
472       "[" "]" ($$ `(declr-array ,$1)))
473      (direct-abstract-declarator
474       "[" "static" type-qualifier-list assignment-expression "]"
475       ($$ `(declr-array
476             ,$1 ,(tl->list (tl-insert '(stor-spec "static") $4)) ,$5)))
477      (direct-abstract-declarator
478       "[" "static" type-qualifier-list "]"
479       ($$ `(declr-array ,$1 ,(tl->list (tl-insert '(stor-spec "static") $4)))))
480      (direct-abstract-declarator
481       "[" type-qualifier-list "static" assignment-expression "]"
482       ($$ `(declr-array
483             ,$1 ,(tl->list (tl-insert '(stor-spec "static") $3)) ,$5)))
484      ;;
485      ("[" type-qualifier-list assignment-expression "]"
486       ($$ `(declr-anon-array ,$2 ,$3)))
487      ("[" type-qualifier-list "]" ($$ `(declr-anon-array ,$2)))
488      ("[" assignment-expression "]" ($$ `(declr-anon-array ,$2)))
489      ("[" "]" ($$ `(declr-anon-array)))
490      ("[" "static" type-qualifier-list assignment-expression "]"
491       ($$ `(declr-anon-array
492             ,(tl->list (tl-insert '(stor-spec "static") $3)) ,$4)))
493      ("[" "static" type-qualifier-list "]"
494       ($$ `(declr-anon-array ,(tl->list (tl-insert '(stor-spec "static") $3)))))
495      ("[" type-qualifier-list "static" assignment-expression "]"
496       ($$ `(declr-anon-array
497             ,(tl->list (tl-insert '(stor-spec "static") $2)) ,$4)))
498      (direct-abstract-declarator "[" "*" "]" ($$ `(declr-STAR ,$1)))
499      ("[" "*" "]" ($$ '(declr-STAR)))
500      (direct-abstract-declarator "(" parameter-type-list ")"
501                                  ($$ `(declr-fctn ,$1 ,(tl->list $3))))
502      (direct-abstract-declarator "(" ")" ($$ `(declr-fctn ,$1)))
503      ("(" parameter-type-list ")" ($$ `(declr-anon-fctn ,(tl->list $2))))
504      ("(" ")" ($$ '(declr-anon-fctn)))
505      )
506
507     ;;typedef-name must be hacked w/ the lexical analyzer
508     (typedef-name ('typename ($$ `(typename ,$1))))
509
510     (initializer                        ; S 6.7.9
511      (assignment-expression ($$ `(initzer ,$1)))
512      ("{" initializer-list "}" ($$ `(initzer ,(tl->list $2))))
513      ("{" initializer-list "," "}" ($$ `(initzer ,(tl->list $2))))
514      )
515
516     ;; The designation productions are from C99.
517     (initializer-list
518      (designation initializer ($$ (make-tl 'initzer-list $1 $2)))
519      (initializer ($$ (make-tl 'initzer-list $1)))
520      (initializer-list "," designation initializer ($$ (tl-append $1 $3 $4)))
521      (initializer-list "," initializer ($$ (tl-append $1 $3)))
522      )
523
524     (designation                        ; S 6.7.8
525      (designator-list "=" ($$ `(desig ,$1)))
526      )
527
528     (designator-list
529      (designator ($$ (make-tl 'desgr-list $1)))
530      (designator-list designator ($$ (tl-append $1 $2)))
531      )
532
533     (designator
534      ("[" constant-expression "]" ($$ (list 'array-dsgr $2)))
535      ("." identifier ($$ (list 'sel-dsgr $2)))
536      )
537
538     ;; statements
539     (statement
540      (labeled-statement)
541      (compound-statement)
542      (expression-statement)
543      (selection-statement)
544      (iteration-statement)
545      (jump-statement)
546      (cpp-statement)
547      )
548
549     (labeled-statement
550      (identifier ":" statement ($$ `(labeled-stmt ,$1 ,$3)))
551      ("case" constant-expression ":" statement ($$ `(case ,$2 ,$4)))
552      ("default" ":" statement ($$ `(default ,$3)))
553      )
554
555     (compound-statement
556      ("{" block-item-list "}" 
557       ($$ `(compd-stmt ,(tl->list $2))))
558      ("{" "}"
559       ($$ `(compd-stmt (block-item-list))))
560      )
561
562     (block-item-list
563      (block-item ($$ (make-tl 'block-item-list $1)))
564      (block-item-list block-item ($$ (tl-append $1 $2)))
565      )
566
567     (block-item
568      (declaration)
569      (statement)
570      )
571     
572     (expression-statement
573      (expression ";" ($$ `(expr-stmt ,$1)))
574      (";" ($$ '(expr-stmt)))
575      )
576
577     (selection-statement
578      ("if" "(" expression ")" statement ($prec 'then)
579       ($$ `(if ,$3 ,$5)))
580      ("if" "(" expression ")" statement "else" statement
581       ($$ `(if ,$3 ,$5 ,$7)))
582      ("switch" "(" expression ")" statement ($$ `(switch ,$3 ,$5)))
583      )
584
585     (iteration-statement
586      ("while" "(" expression ")" statement ($$ `(while ,$3 ,$5)))
587      ("do" statement "while" "(" expression ")" ";" ($$ `(do-while ,$2 ,$5)))
588      ("for" "(" initial-clause opt-expression ";" opt-expression ")" statement
589       ($$ `(for ,$3 ,$4 ,$6 ,$8)))
590      )
591     (initial-clause                     ; <= added for convenience
592      (expression ";")
593      (";" ($$ '(expr)))
594      (declaration))
595     (opt-expression                     ; <= added for convenience
596      ($empty ($$ '(expr)))
597      (expression))
598
599     (jump-statement                     ; S 6.8.6
600      ("goto" identifier ";" ($$ `(goto ,$2)))
601      ("continue" ";" ($$ '(continue)))
602      ("break" ";" ($$ '(break)))
603      ("return" expression ";" ($$ `(return ,$2)))
604      ("return" ";" ($$ `(return (expr))))
605      )
606
607     ;; external definitions
608     (translation-unit                   ; S 6.9
609      (external-declaration-list ($$ (tl->list $1)))
610      )
611     (external-declaration-list
612      (external-declaration ($$ (make-tl 'trans-unit $1)))
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 2))
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 ,$2 (extern-begin ,$2)
628                          ,@(sx-tail (tl->list $4) 1) (extern-end))))
629      (";" ($$ `(decl (@ (not-C99 . "GNU C")))))
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
648     ;; non-terminal leaves
649     (identifier
650      ($ident ($$ `(ident ,$1)))
651      ('cpp-ident ($$ `(ident ,$1))))
652     (constant
653      ($fixed ($$ `(fixed ,$1)))         ; integer-constant
654      ($float ($$ `(float ,$1)))         ; floating-constant
655      ($chlit ($$ `(char ,$1))))         ; char-constant
656     (string-literal
657      ($string ($$ (make-tl 'string $1))) ; string-constant
658      (string-literal $string ($$ (tl-append $1 $2))))
659     (code-comment ($code-comm ($$ `(comment ,$1))))
660     (lone-comment ($lone-comm ($$ `(comment ,$1))))
661     (cpp-statement ('cpp-stmt))
662     (pragma ('cpp-pragma))
663     )))
664
665
666 (define c99-mach
667   (compact-machine
668    (hashify-machine
669     (make-lalr-machine c99-spec))))
670
671 ;;; =====================================
672
673 ;; The following are needed by the code in pbody.scm.
674 (define len-v (assq-ref c99-mach 'len-v))
675 (define pat-v (assq-ref c99-mach 'pat-v))
676 (define rto-v (assq-ref c99-mach 'rto-v))
677 (define mtab (assq-ref c99-mach 'mtab))
678 (define act-v (vector-map
679                (lambda (ix f) (eval f (current-module)))
680                (vector-map (lambda (ix actn) (wrap-action actn))
681                            (assq-ref c99-mach 'act-v))))
682
683 (include-from-path "nyacc/lang/c99/body.scm")
684
685 (define raw-parser (make-lalr-parser c99-mach))
686
687 (define (run-parse)
688   (let ((info (fluid-ref *info*)))
689     (raw-parser (gen-c-lexer) #:debug (cpi-debug info))))
690
691 (define* (dev-parse-c99 #:key
692                         (cpp-defs '())  ; CPP defines
693                         (inc-dirs '())  ; include directories
694                         (td-dict '())   ; typedef dictionary
695                         (mode 'file)    ; mode: 'file or 'code
696                         (xdef? #f)      ; expand def function: proc name mode
697                         (debug #f))     ; debug
698   (catch
699    #t ;; 'c99-error 'cpp-error 'nyacc-error
700    (lambda ()
701      (let ((info (make-cpi debug cpp-defs (cons "." inc-dirs) td-dict)))
702        (with-fluid*
703            *info* info
704            (lambda ()
705              (raw-parser (gen-c-lexer #:mode mode #:xdef? xdef?)
706                          #:debug debug)))))
707    (lambda (key fmt . rest)
708      (report-error fmt rest)
709      #f)))
710
711 (define dev-parse-c dev-parse-c99)
712
713 ;;; =====================================
714
715 ;; @item gen-c99-files [dir] => #t
716 ;; Update or generate the files @quot{c99act.scm} and @quot{c99tab.scm}.
717 ;; These are the tables and actions for the C99 parser.
718 ;; If there are no changes to existing files, no update occurs.
719 (define (gen-c99-files . rest)
720   (define (lang-dir path)
721     (if (pair? rest) (string-append (car rest) "/" path) path))
722   (define (xtra-dir path)
723     (lang-dir (string-append "mach.d/" path)))
724
725   (write-lalr-actions c99-mach (xtra-dir "c99act.scm.new"))
726   (write-lalr-tables c99-mach (xtra-dir "c99tab.scm.new"))
727   (let ((a (move-if-changed (xtra-dir "c99act.scm.new")
728                             (xtra-dir "c99act.scm")))
729         (b (move-if-changed (xtra-dir "c99tab.scm.new")
730                             (xtra-dir "c99tab.scm"))))
731     (when (or a b) 
732       (system (string-append "touch " (lang-dir "parser.scm"))))))
733
734 ;; @item gen-c99x-files [dir] => #t
735 ;; Update or generate the files @quot{c99xact.scm} and @quot{c99xtab.scm}.
736 ;; These are the tables and actions for the C99 expression parser.
737 ;; If there are no changes to existing files, no update occurs.
738 (define (gen-c99x-files . rest)
739   (define (lang-dir path)
740     (if (pair? rest) (string-append (car rest) "/" path) path))
741   (define (xtra-dir path)
742     (lang-dir (string-append "mach.d/" path)))
743
744   (let* ((cexpr-spec (restart-spec c99-mach 'expression))
745          (cexpr-mach (compact-machine
746                       (hashify-machine
747                        (make-lalr-machine cexpr-spec)))))
748     (write-lalr-actions cexpr-mach (xtra-dir "c99xact.scm.new"))
749     (write-lalr-tables cexpr-mach (xtra-dir "c99xtab.scm.new")))
750     
751   (let ((a (move-if-changed (xtra-dir "c99xact.scm.new")
752                             (xtra-dir "c99xact.scm")))
753         (b (move-if-changed (xtra-dir "c99xtab.scm.new")
754                             (xtra-dir "c99xtab.scm"))))
755     (when (or a b) 
756       (system (string-append "touch " (lang-dir "parser.scm")))
757       #;(compile-file (lang-dir "xparser.scm"))
758       )))
759
760 ;; --- last line ---