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 ---