gcc/ch/parse.c

   1 /* Parser for GNU CHILL (CCITT High-Level Language)  -*- C -*-
   2    Copyright (C) 1992, 1993, 1998, 1999 Free Software Foundation, Inc.
   3
   4 This file is part of GNU CC.
   5
   6 GNU CC is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 2, or (at your option)
   9 any later version.
  10
  11 GNU CC is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with GNU CC; see the file COPYING.  If not, write to
  18 the Free Software Foundation, 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21 /*
  22  * This is a two-pass parser.  In pass 1, we collect declarations,
  23  * ignoring actions and most expressions.  We store only the
  24  * declarations and close, open and re-lex the input file to save
  25  * main memory.  We anticipate that the compiler will be processing
  26  * *very* large single programs which are mechanically generated,
  27  * and so we want to store a minimum of information between passes.
  28  *
  29  * yylex detects the end of the main input file and returns the
  30  * END_PASS_1 token.  We then re-initialize each CHILL compiler
  31  * module's global variables and re-process the input file. The
  32  * grant file is output.  If the user has requested it, GNU CHILL
  33  * exits at this time - its only purpose was to generate the grant
  34  * file. Optionally, the compiler may exit if errors were detected
  35  * in pass 1.
  36  *
  37  * As each symbol scope is entered, we install its declarations into
  38  * the symbol table. Undeclared types and variables are announced
  39  * now.
  40  *
  41  * Then code is generated.
  42  */
  43
  44 #include "config.h"
  45 #include "system.h"
  46 #include "tree.h"
  47 #include "ch-tree.h"
  48 #include "lex.h"
  49 #include "actions.h"
  50 #include "tasking.h"
  51 #include "parse.h"
  52 #include "toplev.h"
  53
  54 /* Since parsers are distinct for each language, put the
  55    language string definition here.  (fnf) */
  56 char *language_string = "GNU CHILL";
  57
  58 /* Common code to be done before expanding any action. */
  59 #define INIT_ACTION { \
  60         if (! ignoring) emit_line_note (input_filename, lineno); }
  61
  62 /* Pop a scope for an ON handler. */
  63 #define POP_USED_ON_CONTEXT pop_handler(1)
  64
  65 /* Pop a scope for an ON handler that wasn't there. */
  66 #define POP_UNUSED_ON_CONTEXT pop_handler(0)
  67
  68 #define PUSH_ACTION push_action()
  69
  70 /* Cause the `yydebug' variable to be defined.  */
  71 #define YYDEBUG 1
  72
  73 extern struct rtx_def* gen_label_rtx          PROTO((void));
  74 extern void emit_jump                         PROTO((struct rtx_def *));
  75 extern struct rtx_def* emit_label             PROTO((struct rtx_def *));
  76
  77 /* This is a hell of a lot easier than getting expr.h included in
  78    by parse.c.  */
  79 extern struct rtx_def *expand_expr      PROTO((tree, struct rtx_def *,
  80                                                enum machine_mode, int));
  81
  82 static int parse_action                         PROTO((void));
  83
  84 extern int  lineno;
  85 extern char *input_filename;
  86 extern tree generic_signal_type_node;
  87 extern tree signal_code;
  88 extern int all_static_flag;
  89 extern int ignore_case;
  90
  91 #if 0
  92 static int  quasi_signal = 0;  /* 1 if processing a quasi signal decl */
  93 #endif
  94
  95 int parsing_newmode;                       /* 0 while parsing SYNMODE;
  96                                               1 while parsing NEWMODE. */
  97 int expand_exit_needed = 0;
  98
  99 /* Gets incremented if we see errors such that we don't want to run pass 2. */
 100
 101 int serious_errors = 0;
 102
 103 static tree current_fieldlist;
 104
 105 /* We don't care about expressions during pass 1, except while we're
 106    parsing the RHS of a SYN definition, or while parsing a mode that
 107    we need.  NOTE:  This also causes mode expressions to be ignored. */
 108 int  ignoring = 1;              /* 1 to ignore expressions */
 109
 110 /* True if we have seen an action not in a (user) function. */
 111 int seen_action = 0;
 112 int build_constructor = 0;
 113
 114 /* The action_nesting_level of the current procedure body. */
 115 int proc_action_level = 0;
 116
 117 /* This is the identifier of the label that prefixes the current action,
 118    or NULL if there was none.  It is cleared at the end of an action,
 119    or when starting a nested action list, so get it while you can! */
 120 static tree label      = NULL_TREE;        /* for statement labels */
 121
 122 #if 0
 123 static tree current_block;
 124 #endif
 125
 126 int in_pseudo_module = 0;
 127 int pass = 0;                           /* 0 for init_decl_processing,
 128                                            1 for pass 1, 2 for pass 2 */
 129 \f
 130 /* re-initialize global variables for pass 2 */
 131 static void
 132 ch_parse_init ()
 133 {
 134   expand_exit_needed = 0;
 135   label = NULL_TREE;             /* for statement labels */
 136   current_module = NULL;
 137   in_pseudo_module = 0;
 138 }
 139
 140 static void
 141 check_end_label (start, end)
 142      tree start, end;
 143 {
 144   if (end != NULL_TREE)
 145     {
 146       if (start == NULL_TREE && pass == 1)
 147         error ("there was no start label to match the end label '%s'",
 148                IDENTIFIER_POINTER(end));
 149       else if (start != end && pass == 1)
 150         error ("start label '%s' does not match end label '%s'",
 151                IDENTIFIER_POINTER(start),
 152                IDENTIFIER_POINTER(end));
 153     }
 154 }
 155
 156
 157 /*
 158  * given a tree which is an id, a type or a decl,
 159  * return the associated type, or issue an error and
 160  * return error_mark_node.
 161  */
 162 tree
 163 get_type_of (id_or_decl)
 164      tree id_or_decl;
 165 {
 166   tree type = id_or_decl;
 167
 168   if (id_or_decl == NULL_TREE
 169       || TREE_CODE (id_or_decl) == ERROR_MARK)
 170     return error_mark_node;
 171
 172   if (pass == 1 || ignoring == 1)
 173     return id_or_decl;
 174
 175   if (TREE_CODE (type) == IDENTIFIER_NODE)
 176     {
 177       type = lookup_name (id_or_decl);
 178       if (type == NULL_TREE)
 179         {
 180           error ("`%s' not declared", IDENTIFIER_POINTER (id_or_decl));
 181           type = error_mark_node;
 182         }
 183     }
 184   if (TREE_CODE (type) == TYPE_DECL)
 185     type = TREE_TYPE (type);
 186   return type;           /* was a type all along */
 187 }
 188
 189
 190 static void
 191 end_function ()
 192 {
 193   if (CH_DECL_PROCESS (current_function_decl))
 194     {
 195       /* finishing a process */
 196       if (! ignoring)
 197         {
 198           tree result =
 199             build_chill_function_call
 200               (lookup_name (get_identifier ("__stop_process")),
 201                NULL_TREE);
 202           expand_expr_stmt (result);
 203           emit_line_note (input_filename, lineno);
 204         }
 205     }
 206   else
 207     {
 208       /* finishing a procedure.. */
 209       if (! ignoring)
 210         {
 211           if (result_never_set
 212               && TREE_CODE (TREE_TYPE (TREE_TYPE (current_function_decl)))
 213               != VOID_TYPE)
 214             warning ("No RETURN or RESULT in procedure");
 215           chill_expand_return (NULL_TREE, 1);
 216         }
 217     }
 218   finish_chill_function ();
 219   pop_chill_function_context ();
 220 }
 221
 222 static tree
 223 build_prefix_clause (id)
 224      tree id;
 225 {
 226   if (!id)
 227     {
 228       if (current_module && current_module->name)
 229         { char *module_name = IDENTIFIER_POINTER (current_module->name);
 230           if (module_name[0] && module_name[0] != '_')
 231             return current_module->name;
 232         }
 233       error ("PREFIXED clause with no prelix in unlabeled module");
 234     }
 235   return id;
 236 }
 237
 238 void
 239 possibly_define_exit_label (label)
 240      tree label;
 241 {
 242   if (label)
 243     define_label (input_filename, lineno, munge_exit_label (label));
 244 }
 245
 246 #define MAX_LOOK_AHEAD 2
 247 static enum terminal terminal_buffer[MAX_LOOK_AHEAD+1];
 248 YYSTYPE yylval;
 249 static YYSTYPE val_buffer[MAX_LOOK_AHEAD+1];
 250
 251 /*enum terminal current_token, lookahead_token;*/
 252
 253 #define TOKEN_NOT_READ dummy_last_terminal
 254
 255 #ifdef __GNUC__
 256 __inline__
 257 #endif
 258 static enum terminal
 259 PEEK_TOKEN()
 260 {
 261   if (terminal_buffer[0] == TOKEN_NOT_READ)
 262     {
 263       terminal_buffer[0] = yylex();
 264       val_buffer[0] = yylval;
 265     }
 266   return terminal_buffer[0];
 267 }
 268 #define PEEK_TREE() val_buffer[0].ttype
 269 #define PEEK_TOKEN1() peek_token_(1)
 270 #define PEEK_TOKEN2() peek_token_(2)
 271 static int
 272 peek_token_ (i)
 273      int i;
 274 {
 275   if (i > MAX_LOOK_AHEAD)
 276     fatal ("internal error - too much lookahead");
 277   if (terminal_buffer[i] == TOKEN_NOT_READ)
 278     {
 279       terminal_buffer[i] = yylex();
 280       val_buffer[i] = yylval;
 281     }
 282   return terminal_buffer[i];
 283 }
 284
 285 static void
 286 pushback_token (code, node)
 287      int code;
 288      tree node;
 289 {
 290   int i;
 291   if (terminal_buffer[MAX_LOOK_AHEAD] != TOKEN_NOT_READ)
 292     fatal ("internal error - cannot pushback token");
 293   for (i = MAX_LOOK_AHEAD; i > 0; i--)
 294     {
 295       terminal_buffer[i] = terminal_buffer[i - 1];
 296       val_buffer[i] = val_buffer[i - 1];
 297   }
 298   terminal_buffer[0] = code;
 299   val_buffer[0].ttype = node;
 300 }
 301
 302 static void
 303 forward_token_()
 304 {
 305   int i;
 306   for (i = 0; i < MAX_LOOK_AHEAD; i++)
 307     {
 308       terminal_buffer[i] = terminal_buffer[i+1];
 309       val_buffer[i] = val_buffer[i+1];
 310     }
 311   terminal_buffer[MAX_LOOK_AHEAD] = TOKEN_NOT_READ;
 312 }
 313 #define FORWARD_TOKEN() forward_token_()
 314
 315 /* Skip the next token.
 316    if it isn't TOKEN, the parser is broken. */
 317
 318 void
 319 require(token)
 320      enum terminal token;
 321 {
 322   if (PEEK_TOKEN() != token)
 323     {
 324       char buf[80];
 325       sprintf (buf, "internal parser error - expected token %d", (int)token);
 326       fatal(buf);
 327     }
 328   FORWARD_TOKEN();
 329 }
 330
 331 int
 332 check_token (token)
 333      enum terminal token;
 334 {
 335   if (PEEK_TOKEN() != token)
 336     return 0;
 337   FORWARD_TOKEN ();
 338   return 1;
 339 }
 340
 341 /* return 0 if expected token was not found,
 342    else return 1.
 343 */
 344 int
 345 expect(token, message)
 346      enum terminal token;
 347      char *message;
 348 {
 349   if (PEEK_TOKEN() != token)
 350     {
 351       if (pass == 1)
 352         error(message ? message : "syntax error");
 353       return 0;
 354     }
 355   else
 356     FORWARD_TOKEN();
 357   return 1;
 358 }
 359
 360 /* define a SYNONYM __PROCNAME__ (__procname__) which holds
 361    the name of the current procedure.
 362    This should be quit the same as __FUNCTION__ in C */
 363 static void
 364 define__PROCNAME__ ()
 365 {
 366   char *fname;
 367   tree string;
 368   tree procname;
 369
 370   if (current_function_decl == NULL_TREE)
 371     fname = "toplevel";
 372   else
 373     fname = IDENTIFIER_POINTER (DECL_NAME (current_function_decl));
 374
 375   string = build_chill_string (strlen (fname), fname);
 376   procname = get_identifier (ignore_case ? "__procname__" : "__PROCNAME__");
 377   push_syndecl (procname, NULL_TREE, string);
 378 }
 379
 380 /* Forward declarations. */
 381 static tree parse_expression ();
 382 static tree parse_primval ();
 383 static tree parse_mode PROTO((void));
 384 static tree parse_opt_mode PROTO((void));
 385 static tree parse_untyped_expr ();
 386 static tree parse_opt_untyped_expr ();
 387 static int parse_definition PROTO((int));
 388 static void parse_opt_actions ();
 389 static void parse_body PROTO((void));
 390 static tree parse_if_expression_body PROTO((void));
 391 static tree parse_opt_handler PROTO((void));
 392
 393 static tree
 394 parse_opt_name_string (allow_all)
 395      int allow_all; /* 1 if ALL is allowed as a postfix */
 396 {
 397   enum terminal token = PEEK_TOKEN();
 398   tree name;
 399   if (token != NAME)
 400     {
 401       if (token == ALL && allow_all)
 402         {
 403           FORWARD_TOKEN ();
 404           return ALL_POSTFIX;
 405         }
 406       return NULL_TREE;
 407     }
 408   name = PEEK_TREE();
 409   for (;;)
 410     {
 411       FORWARD_TOKEN ();
 412       token = PEEK_TOKEN();
 413       if (token != '!')
 414         return name;
 415       FORWARD_TOKEN();
 416       token = PEEK_TOKEN();
 417       if (token == ALL && allow_all)
 418         return get_identifier3(IDENTIFIER_POINTER (name), "!", "*");
 419       if (token != NAME)
 420         {
 421           if (pass == 1)
 422             error ("'%s!' is not followed by an identifier",
 423                    IDENTIFIER_POINTER (name));
 424           return name;
 425         }
 426       name = get_identifier3(IDENTIFIER_POINTER(name),
 427                              "!", IDENTIFIER_POINTER(PEEK_TREE()));
 428     }
 429 }
 430
 431 static tree
 432 parse_simple_name_string ()
 433 {
 434   enum terminal token = PEEK_TOKEN();
 435   tree name;
 436   if (token != NAME)
 437     {
 438       error ("expected a name here");
 439       return error_mark_node;
 440     }
 441   name = PEEK_TREE ();
 442   FORWARD_TOKEN ();
 443   return name;
 444 }
 445
 446 static tree
 447 parse_name_string ()
 448 {
 449   tree name = parse_opt_name_string (0);
 450   if (name)
 451     return name;
 452   if (pass == 1)
 453     error ("expected a name string here");
 454   return error_mark_node;
 455 }
 456
 457 static tree
 458 parse_defining_occurrence ()
 459 {
 460   if (PEEK_TOKEN () == NAME)
 461     {
 462       tree id = PEEK_TREE();
 463       FORWARD_TOKEN ();
 464       return id;
 465     }
 466   return NULL;
 467 }
 468
 469 /* Matches: <name_string>
 470    Returns if pass 1: the identifier.
 471    Returns if pass 2: a decl or value for identifier. */
 472
 473 static tree
 474 parse_name ()
 475 {
 476   tree name = parse_name_string ();
 477   if (pass == 1 || ignoring)
 478     return name;
 479   else
 480     {
 481       tree decl = lookup_name (name);
 482       if (decl == NULL_TREE)
 483         {
 484           error ("`%s' undeclared", IDENTIFIER_POINTER (name));
 485           return error_mark_node;
 486         }
 487       else if (TREE_CODE (TREE_TYPE (decl)) == ERROR_MARK)
 488         return error_mark_node;
 489       else if (TREE_CODE (decl) == CONST_DECL)
 490         return DECL_INITIAL (decl);
 491       else if (TREE_CODE (TREE_TYPE (decl)) == REFERENCE_TYPE)
 492         return convert_from_reference (decl);
 493       else
 494         return decl;
 495     }
 496 }
 497
 498 static tree
 499 parse_optlabel()
 500 {
 501   tree label = parse_defining_occurrence();
 502   if (label != NULL)
 503     expect(COLON, "expected a ':' here");
 504   return label;
 505 }
 506
 507 static void
 508 parse_semi_colon ()
 509 {
 510   enum terminal token = PEEK_TOKEN ();
 511   if (token == SC)
 512     FORWARD_TOKEN ();
 513   else if (pass == 1)
 514     (token == END ? pedwarn : error) ("expected ';' here");
 515   label = NULL_TREE;
 516 }
 517
 518 static void
 519 parse_opt_end_label_semi_colon (start_label)
 520      tree start_label;
 521 {
 522   if (PEEK_TOKEN() == NAME)
 523     {
 524       tree end_label = parse_name_string ();
 525       check_end_label (start_label, end_label);
 526     }
 527   parse_semi_colon ();
 528 }
 529
 530 static void
 531 parse_modulion (label)
 532      tree label;
 533 {
 534   tree module_name;
 535
 536   label = set_module_name (label);
 537   module_name = push_module (label, 0);
 538   FORWARD_TOKEN();
 539
 540   push_action ();
 541   parse_body();
 542   expect(END, "expected END here");
 543   parse_opt_handler ();
 544   parse_opt_end_label_semi_colon (label);
 545   find_granted_decls ();
 546   pop_module ();
 547 }
 548
 549 static void
 550 parse_spec_module (label)
 551      tree label;
 552 {
 553   int save_ignoring = ignoring;
 554
 555   push_module (set_module_name (label), 1);
 556   ignoring = pass == 2;
 557   FORWARD_TOKEN(); /* SKIP SPEC */
 558   expect (MODULE, "expected 'MODULE' here");
 559
 560   while (parse_definition (1)) { }
 561   if (parse_action ())
 562     error ("action not allowed in SPEC MODULE");
 563   expect(END, "expected END here");
 564   parse_opt_end_label_semi_colon (label);
 565   find_granted_decls ();
 566   pop_module ();
 567   ignoring = save_ignoring;
 568 }
 569
 570 /* Matches:  <name_string> ( "," <name_string> )*
 571    Returns either a single IDENTIFIER_NODE,
 572    or a chain (TREE_LIST) of IDENTIFIER_NODES.
 573    (Since a single identifier is the common case, we avoid wasting space
 574    (twice, once for each pass) with extra TREE_LIST nodes in that case.)
 575    (Will not return NULL_TREE even if ignoring is true.) */
 576
 577 static tree
 578 parse_defining_occurrence_list ()
 579 {
 580   tree chain = NULL_TREE;
 581   tree name = parse_defining_occurrence ();
 582   if (name == NULL_TREE)
 583     {
 584       error("missing defining occurrence");
 585       return NULL_TREE;
 586     }
 587   if (! check_token (COMMA))
 588     return name;
 589   chain = build_tree_list (NULL_TREE, name);
 590   for (;;)
 591     {
 592       name = parse_defining_occurrence ();
 593       if (name == NULL)
 594         {
 595           error ("bad defining occurrence following ','");
 596           break;
 597         }
 598       chain = tree_cons (NULL_TREE, name, chain);
 599       if (! check_token (COMMA))
 600         break;
 601     }
 602   return nreverse (chain);
 603 }
 604
 605 static void
 606 parse_mode_definition (is_newmode)
 607      int is_newmode;
 608 {
 609   tree mode, names;
 610   int save_ignoring = ignoring;
 611   ignoring = pass == 2;
 612   names = parse_defining_occurrence_list ();
 613   expect (EQL, "missing '=' in mode definition");
 614   mode = parse_mode ();
 615   if (names == NULL_TREE || TREE_CODE (names) == TREE_LIST)
 616     {
 617       for ( ; names != NULL_TREE; names = TREE_CHAIN (names))
 618         push_modedef (names, mode, is_newmode);
 619     }
 620   else
 621     push_modedef (names, mode, is_newmode);
 622   ignoring = save_ignoring;
 623 }
 624
 625 void
 626 parse_mode_definition_statement (is_newmode)
 627      int is_newmode;
 628 {
 629   FORWARD_TOKEN (); /* skip SYNMODE or NEWMODE */
 630   parse_mode_definition (is_newmode);
 631   while (PEEK_TOKEN () == COMMA)
 632     {
 633       FORWARD_TOKEN ();
 634       parse_mode_definition (is_newmode);
 635     }
 636   parse_semi_colon ();
 637 }
 638
 639 static void
 640 parse_synonym_definition ()
 641 { tree expr = NULL_TREE;
 642   tree names = parse_defining_occurrence_list ();
 643   tree mode = parse_opt_mode ();
 644   if (! expect (EQL, "missing '=' in synonym definition"))
 645     mode = error_mark_node;
 646   else
 647     {
 648       if (mode)
 649         expr = parse_untyped_expr ();
 650       else
 651         expr = parse_expression ();
 652     }
 653   if (names == NULL_TREE || TREE_CODE (names) == TREE_LIST)
 654     {
 655       for ( ; names != NULL_TREE; names = TREE_CHAIN (names))
 656         push_syndecl (names, mode, expr);
 657     }
 658   else
 659     push_syndecl (names, mode, expr);
 660 }
 661
 662 static void
 663 parse_synonym_definition_statement()
 664 {
 665   int save_ignoring= ignoring;
 666   ignoring = pass == 2;
 667   require (SYN);
 668   parse_synonym_definition ();
 669   while (PEEK_TOKEN () == COMMA)
 670     {
 671       FORWARD_TOKEN ();
 672       parse_synonym_definition ();
 673     }
 674   ignoring = save_ignoring;
 675   parse_semi_colon ();
 676 }
 677
 678 /* Attempts to match: "(" <exception list> ")" ":".
 679    Return NULL_TREE on failure, and non-NULL on success.
 680    On success, if pass 1, return a TREE_LIST of IDENTIFIER_NODEs. */
 681
 682 static tree
 683 parse_on_exception_list ()
 684 {
 685   tree name;
 686   tree list = NULL_TREE;
 687   int tok1 = PEEK_TOKEN ();
 688   int tok2 = PEEK_TOKEN1 ();
 689
 690   /* This requires a lot of look-ahead, because we cannot
 691      easily a priori distinguish an exception-list from an expression. */
 692   if (tok1 != LPRN || tok2 != NAME)
 693     {
 694       if (tok1 == NAME && tok2 == COLON && pass == 1)
 695         error ("missing '(' in exception list");
 696       return 0;
 697     }
 698   require (LPRN);
 699   name = parse_name_string ();
 700   if (PEEK_TOKEN () == RPRN && PEEK_TOKEN1 () == COLON)
 701     {
 702       /* Matched: '(' <name_string> ')' ':' */
 703       FORWARD_TOKEN (); FORWARD_TOKEN ();
 704       return pass == 1 ? build_tree_list (NULL_TREE, name) : name;
 705     }
 706   if (PEEK_TOKEN() == COMMA)
 707     {
 708       if (pass == 1)
 709         list = build_tree_list (NULL_TREE, name);
 710       while (check_token (COMMA))
 711         {
 712           tree old_names = list;
 713           name = parse_name_string ();
 714           if (pass == 1)
 715             {
 716               for ( ; old_names != NULL_TREE; old_names = TREE_CHAIN (old_names))
 717                 {
 718                   if (TREE_VALUE (old_names) == name)
 719                     {
 720                       error ("ON exception names must be unique");
 721                       goto continue_parsing;
 722                     }
 723                 }
 724               list = tree_cons (NULL_TREE, name, list);
 725             continue_parsing:
 726               ;
 727             }
 728         }
 729       if (! check_token (RPRN) || ! check_token(COLON))
 730         error ("syntax error in exception list");
 731       return pass == 1 ? nreverse (list) : name;
 732     }
 733   /* Matched: '(' name_string
 734      but it doesn't match the syntax of an exception list.
 735      It could be the beginning of an expression, so back up. */
 736   pushback_token (NAME, name);
 737   pushback_token (LPRN, 0);
 738   return NULL_TREE;
 739 }
 740
 741 static void
 742 parse_on_alternatives ()
 743 {
 744   for (;;)
 745     {
 746       tree except_list = parse_on_exception_list ();
 747       if (except_list != NULL)
 748         chill_handle_on_labels (except_list);
 749       else if (parse_action ())
 750         expand_exit_needed = 1;
 751       else
 752         break;
 753     }
 754 }
 755
 756 static tree
 757 parse_opt_handler ()
 758 {
 759   if (! check_token (ON))
 760     {
 761       POP_UNUSED_ON_CONTEXT;
 762       return NULL_TREE;
 763     }
 764   if (check_token (END))
 765     {
 766       pedwarn ("empty ON-condition");
 767       POP_UNUSED_ON_CONTEXT;
 768       return NULL_TREE;
 769     }
 770   if (! ignoring)
 771     {
 772       chill_start_on ();
 773       expand_exit_needed = 0;
 774     }
 775   if (PEEK_TOKEN () != ELSE)
 776     {
 777       parse_on_alternatives ();
 778       if (! ignoring && expand_exit_needed)
 779         expand_exit_something ();
 780     }
 781   if (check_token (ELSE))
 782     {
 783       chill_start_default_handler ();
 784       label = NULL_TREE;
 785       parse_opt_actions ();
 786       if (! ignoring)
 787         {
 788           emit_line_note (input_filename, lineno);
 789           expand_exit_something ();
 790         }
 791     }
 792   expect (END, "missing 'END' after");
 793   if (! ignoring)
 794     chill_finish_on ();
 795   POP_USED_ON_CONTEXT;
 796   return integer_zero_node;
 797 }
 798
 799 static void
 800 parse_loc_declaration (in_spec_module)
 801      int in_spec_module;
 802 {
 803   tree names = parse_defining_occurrence_list ();
 804   int save_ignoring = ignoring;
 805   int is_static, lifetime_bound;
 806   tree mode, init_value = NULL_TREE;
 807   int loc_decl = 0;
 808
 809   ignoring = pass == 2;
 810   mode = parse_mode ();
 811   ignoring = save_ignoring;
 812   is_static = check_token (STATIC);
 813   if (check_token (BASED))
 814     {
 815       expect(LPRN, "BASED must be followed by (NAME)");
 816       do_based_decls (names, mode, parse_name_string ());
 817       expect(RPRN, "BASED must be followed by (NAME)");
 818       return;
 819     }
 820   if (check_token (LOC))
 821     {
 822       /* loc-identity declaration */
 823       if (pass == 1)
 824         mode = build_chill_reference_type (mode);
 825       loc_decl = 1;
 826     }
 827   lifetime_bound = check_token (INIT);
 828   if (lifetime_bound && loc_decl)
 829     {
 830       if (pass == 1)
 831         error ("INIT not allowed at loc-identity declaration");
 832       lifetime_bound = 0;
 833     }
 834   if (PEEK_TOKEN () == ASGN || PEEK_TOKEN() == EQL)
 835     {
 836       save_ignoring = ignoring;
 837       ignoring = pass == 1;
 838       if (PEEK_TOKEN() == EQL)
 839         {
 840           if (pass == 1)
 841             error ("'=' used where ':=' is required");
 842         }
 843       FORWARD_TOKEN();
 844       if (! lifetime_bound)
 845         push_handler ();
 846       init_value = parse_untyped_expr ();
 847       if (in_spec_module)
 848         {
 849           error ("initialization is not allowed in spec module");
 850           init_value = NULL_TREE;
 851         }
 852       if (! lifetime_bound)
 853         parse_opt_handler ();
 854       ignoring = save_ignoring;
 855     }
 856   if (init_value == NULL_TREE && loc_decl && pass == 1)
 857     error ("loc-identity declaration without initialisation");
 858   do_decls (names, mode,
 859             is_static || global_bindings_p ()
 860             /* the variable becomes STATIC if all_static_flag is set and
 861                current functions doesn't have the RECURSIVE attribute */
 862             || (all_static_flag && !CH_DECL_RECURSIVE (current_function_decl)),
 863             lifetime_bound, init_value, in_spec_module);
 864
 865   /* Free any temporaries we made while initializing the decl.  */
 866   free_temp_slots ();
 867 }
 868
 869 static void
 870 parse_declaration_statement (in_spec_module)
 871      int in_spec_module;
 872 {
 873   int save_ignoring = ignoring;
 874   ignoring = pass == 2;
 875   require (DCL);
 876   parse_loc_declaration (in_spec_module);
 877   while (PEEK_TOKEN () == COMMA)
 878     {
 879       FORWARD_TOKEN ();
 880       parse_loc_declaration (in_spec_module);
 881     }
 882   ignoring = save_ignoring;
 883   parse_semi_colon ();
 884 }
 885
 886 tree
 887 parse_optforbid ()
 888 {
 889   if (check_token (FORBID) == 0)
 890     return NULL_TREE;
 891   if (check_token (ALL))
 892     return ignoring ? NULL_TREE : build_int_2 (-1, -1);
 893 #if 0
 894   if (check_token (LPRN))
 895     {
 896       tree list = parse_forbidlist ();
 897       expect (RPRN, "missing ')' after FORBID list");
 898       return list;
 899     }
 900 #endif
 901   error ("bad syntax following FORBID");
 902   return NULL_TREE;
 903 }
 904
 905 /* Matches: <grant postfix> or <seize postfix>
 906    Returns: A (singleton) TREE_LIST. */
 907
 908 tree
 909 parse_postfix (grant_or_seize)
 910      enum terminal grant_or_seize;
 911 {
 912   tree name = parse_opt_name_string (1);
 913   tree forbid = NULL_TREE;
 914   if (name == NULL_TREE)
 915     {
 916       error ("expected a postfix name here");
 917       name = error_mark_node;
 918     }
 919   if (grant_or_seize == GRANT)
 920     forbid = parse_optforbid ();
 921   return build_tree_list (forbid, name);
 922 }
 923
 924 tree
 925 parse_postfix_list (grant_or_seize)
 926      enum terminal grant_or_seize;
 927 {
 928   tree list = parse_postfix (grant_or_seize);
 929   while (check_token (COMMA))
 930     list = chainon (list, parse_postfix (grant_or_seize));
 931   return list;
 932 }
 933
 934 void
 935 parse_rename_clauses (grant_or_seize)
 936      enum terminal grant_or_seize;
 937 {
 938   for (;;)
 939     {
 940       tree rename_old_prefix, rename_new_prefix, postfix;
 941       require (LPRN);
 942       rename_old_prefix = parse_opt_name_string (0);
 943       expect (ARROW, "missing '->' in rename clause");
 944       rename_new_prefix = parse_opt_name_string (0);
 945       expect (RPRN,  "missing ')' in rename clause");
 946       expect ('!',  "missing '!' in rename clause");
 947       postfix = parse_postfix (grant_or_seize);
 948
 949       if (grant_or_seize == GRANT)
 950         chill_grant (rename_old_prefix, rename_new_prefix,
 951                      TREE_VALUE (postfix), TREE_PURPOSE (postfix));
 952       else
 953         chill_seize (rename_old_prefix, rename_new_prefix,
 954                      TREE_VALUE (postfix));
 955
 956       if (PEEK_TOKEN () != COMMA)
 957         break;
 958       FORWARD_TOKEN ();
 959       if (PEEK_TOKEN () != LPRN)
 960         {
 961           error ("expected another rename clause");
 962           break;
 963         }
 964     }
 965 }
 966
 967 static tree
 968 parse_opt_prefix_clause ()
 969 {
 970   if (check_token (PREFIXED) == 0)
 971     return NULL_TREE;
 972   return build_prefix_clause (parse_opt_name_string (0));
 973 }
 974
 975 void
 976 parse_grant_statement ()
 977 {
 978   require (GRANT);
 979   if (PEEK_TOKEN () == LPRN)
 980     parse_rename_clauses (GRANT);
 981   else
 982     {
 983       tree window = parse_postfix_list (GRANT);
 984       tree new_prefix = parse_opt_prefix_clause ();
 985       tree t;
 986       for (t = window; t; t = TREE_CHAIN (t))
 987         chill_grant (NULL_TREE, new_prefix, TREE_VALUE (t), TREE_PURPOSE (t));
 988     }
 989 }
 990
 991 void
 992 parse_seize_statement ()
 993 {
 994   require (SEIZE);
 995   if (PEEK_TOKEN () == LPRN)
 996     parse_rename_clauses (SEIZE);
 997   else
 998     {
 999       tree seize_window = parse_postfix_list (SEIZE);
1000       tree old_prefix = parse_opt_prefix_clause ();
1001       tree t;
1002       for (t = seize_window; t; t = TREE_CHAIN (t))
1003         chill_seize (old_prefix, NULL_TREE, TREE_VALUE (t));
1004     }
1005 }
1006
1007 /* In pass 1, this returns a TREE_LIST, one node for each parameter.
1008    In pass 2, we get a list of PARM_DECLs chained together.
1009    In either case, the list is in reverse order. */
1010
1011 static tree
1012 parse_param_name_list ()
1013 {
1014   tree list = NULL_TREE;
1015   do
1016     {
1017       tree new_link;
1018       tree name = parse_defining_occurrence ();
1019       if (name == NULL_TREE)
1020         {
1021           error ("syntax error in parameter name list");
1022           return list;
1023         }
1024       if (pass == 1)
1025         new_link = build_tree_list (NULL_TREE, name);
1026       /* else if (current_module->is_spec_module) ; nothing */
1027       else  /* pass == 2 */
1028         {
1029           new_link = make_node (PARM_DECL);
1030           DECL_NAME (new_link) = name;
1031           DECL_ASSEMBLER_NAME (new_link) = name;
1032         }
1033
1034       TREE_CHAIN (new_link) = list;
1035       list = new_link;
1036     } while (check_token (COMMA));
1037   return list;
1038 }
1039
1040 static tree
1041 parse_param_attr ()
1042 {
1043   tree attr;
1044   switch (PEEK_TOKEN ())
1045     {
1046     case PARAMATTR:          /* INOUT is returned here */
1047       attr = PEEK_TREE ();
1048       FORWARD_TOKEN ();
1049       return attr;
1050     case IN:
1051       FORWARD_TOKEN ();
1052       return ridpointers[(int) RID_IN];
1053     case LOC:
1054       FORWARD_TOKEN ();
1055       return ridpointers[(int) RID_LOC];
1056 #if 0
1057     case DYNAMIC:
1058       FORWARD_TOKEN ();
1059       return ridpointers[(int) RID_DYNAMIC];
1060 #endif
1061     default:
1062       return NULL_TREE;
1063     }
1064 }
1065
1066 /* We wrap CHILL array parameters in a STRUCT.  The original parameter
1067    name is unpacked from the struct at get_identifier time */
1068
1069 /* In pass 1, returns list of types; in pass 2: chain of PARM_DECLs. */
1070
1071 static tree
1072 parse_formpar ()
1073 {
1074   tree names = parse_param_name_list ();
1075   tree mode = parse_mode ();
1076   tree paramattr = parse_param_attr ();
1077   return chill_munge_params (nreverse (names), mode, paramattr);
1078 }
1079
1080 /*
1081  * Note: build_process_header depends upon the *exact*
1082  * representation of STRUCT fields and of formal parameter
1083  * lists.  If either is changed, build_process_header will
1084  * also need change.  Push_extern_process is affected as well.
1085  */
1086 static tree
1087 parse_formparlist ()
1088 {
1089   tree list = NULL_TREE;
1090   if (PEEK_TOKEN() == RPRN)
1091     return NULL_TREE;
1092   for (;;)
1093     {
1094       list = chainon (list, parse_formpar ());
1095       if (! check_token (COMMA))
1096         break;
1097     }
1098   return list;
1099 }
1100
1101 static tree
1102 parse_opt_result_spec ()
1103 {
1104   tree mode;
1105   int is_nonref, is_loc, is_dynamic;
1106   if (!check_token (RETURNS))
1107     return void_type_node;
1108   expect (LPRN, "expected '(' after RETURNS");
1109   mode = parse_mode ();
1110   is_nonref = check_token (NONREF);
1111   is_loc = check_token (LOC);
1112   is_dynamic = check_token (DYNAMIC);
1113   if (is_nonref && !is_loc)
1114     error ("NONREF specific without LOC in result attribute");
1115   if (is_dynamic && !is_loc)
1116     error ("DYNAMIC specific without LOC in result attribute");
1117   mode = get_type_of (mode);
1118   if (is_loc && ! ignoring)
1119     mode = build_chill_reference_type (mode);
1120   expect (RPRN, "expected ')' after RETURNS");
1121   return mode;
1122 }
1123
1124 static tree
1125 parse_opt_except ()
1126 {
1127   tree list = NULL_TREE;
1128   if (!check_token (EXCEPTIONS))
1129     return NULL_TREE;
1130   expect (LPRN, "expected '(' after EXCEPTIONS");
1131   do
1132     {
1133       tree except_name = parse_name_string ();
1134       tree name;
1135       for (name = list; name != NULL_TREE; name = TREE_CHAIN (name))
1136         if (TREE_VALUE (name) == except_name && pass == 1)
1137           {
1138             error ("exception names must be unique");
1139             break;
1140           }
1141       if (name == NULL_TREE && !ignoring)
1142         list = tree_cons (NULL_TREE, except_name, list);
1143     } while (check_token (COMMA));
1144   expect (RPRN, "expected ')' after EXCEPTIONS");
1145   return list;
1146 }
1147
1148 static tree
1149 parse_opt_recursive ()
1150 {
1151   if (check_token (RECURSIVE))
1152     return ridpointers[RID_RECURSIVE];
1153   else
1154     return NULL_TREE;
1155 }
1156
1157 static tree
1158 parse_procedureattr ()
1159 {
1160   tree generality;
1161   tree optrecursive;
1162   switch (PEEK_TOKEN ())
1163     {
1164     case GENERAL:
1165       FORWARD_TOKEN ();
1166       generality = ridpointers[RID_GENERAL];
1167       break;
1168     case SIMPLE:
1169       FORWARD_TOKEN ();
1170       generality = ridpointers[RID_SIMPLE];
1171       break;
1172     case INLINE:
1173       FORWARD_TOKEN ();
1174       generality = ridpointers[RID_INLINE];
1175       break;
1176     default:
1177       generality = NULL_TREE;
1178     }
1179   optrecursive = parse_opt_recursive ();
1180   if (pass != 1)
1181     return NULL_TREE;
1182   if (generality)
1183     generality = build_tree_list (NULL_TREE, generality);
1184   if (optrecursive)
1185     generality = tree_cons (NULL_TREE, optrecursive, generality);
1186   return generality;
1187 }
1188
1189 /* Parse the body and last part of a procedure or process definition. */
1190
1191 static void
1192 parse_proc_body (name, exceptions)
1193      tree name;
1194      tree exceptions;
1195 {
1196   int save_proc_action_level = proc_action_level;
1197   proc_action_level = action_nesting_level;
1198   if (exceptions != NULL_TREE)
1199     /* set up a handler for reraising exceptions */
1200     push_handler ();
1201   push_action ();
1202   define__PROCNAME__ ();
1203   parse_body ();
1204   proc_action_level = save_proc_action_level;
1205   expect (END, "'END' was expected here");
1206   parse_opt_handler ();
1207   if (exceptions != NULL_TREE)
1208     chill_reraise_exceptions (exceptions);
1209   parse_opt_end_label_semi_colon (name);
1210   end_function ();
1211 }
1212
1213 static void
1214 parse_procedure_definition (in_spec_module)
1215      int in_spec_module;
1216 {
1217   int save_ignoring = ignoring;
1218   tree name = parse_defining_occurrence ();
1219   tree params, result, exceptlist, attributes;
1220   int save_chill_at_module_level = chill_at_module_level;
1221   chill_at_module_level = 0;
1222   if (!in_spec_module)
1223     ignoring = pass == 2;
1224   require (COLON); require (PROC);
1225   expect (LPRN, "missing '(' after PROC");
1226   params = parse_formparlist ();
1227   expect (RPRN, "missing ')' in PROC");
1228   result = parse_opt_result_spec ();
1229   exceptlist = parse_opt_except ();
1230   attributes = parse_procedureattr ();
1231   ignoring = save_ignoring;
1232   if (in_spec_module)
1233     {
1234       expect (END, "missing 'END'");
1235       parse_opt_end_label_semi_colon (name);
1236       push_extern_function (name, result, params, exceptlist, 0);
1237       return;
1238     }
1239   push_chill_function_context ();
1240   start_chill_function (name, result, params, exceptlist, attributes);
1241   current_module->procedure_seen = 1;
1242   parse_proc_body (name, TYPE_RAISES_EXCEPTIONS (TREE_TYPE (current_function_decl)));
1243   chill_at_module_level = save_chill_at_module_level;
1244 }
1245
1246 static tree
1247 parse_processpar ()
1248 {
1249   tree names = parse_defining_occurrence_list ();
1250   tree mode = parse_mode ();
1251   tree paramattr = parse_param_attr ();
1252
1253   if (names && TREE_CODE (names) == IDENTIFIER_NODE)
1254     names = build_tree_list (NULL_TREE, names);
1255   return tree_cons (tree_cons (paramattr, mode, NULL_TREE), names, NULL_TREE);
1256 }
1257
1258 static tree
1259 parse_processparlist ()
1260 {
1261   tree list = NULL_TREE;
1262   if (PEEK_TOKEN() == RPRN)
1263     return NULL_TREE;
1264   for (;;)
1265     {
1266       list = chainon (list, parse_processpar ());
1267       if (! check_token (COMMA))
1268         break;
1269     }
1270   return list;
1271 }
1272
1273 static void
1274 parse_process_definition (in_spec_module)
1275      int in_spec_module;
1276 {
1277   int save_ignoring = ignoring;
1278   tree name = parse_defining_occurrence ();
1279   tree params;
1280   tree tmp;
1281   if (!in_spec_module)
1282     ignoring = 0;
1283   require (COLON); require (PROCESS);
1284   expect (LPRN, "missing '(' after PROCESS");
1285   params = parse_processparlist (in_spec_module);
1286   expect (RPRN, "missing ')' in PROCESS");
1287   ignoring = save_ignoring;
1288   if (in_spec_module)
1289     {
1290       expect (END, "missing 'END'");
1291       parse_opt_end_label_semi_colon (name);
1292       push_extern_process (name, params, NULL_TREE, 0);
1293       return;
1294     }
1295   tmp = build_process_header (name, params);
1296   parse_proc_body (name, NULL_TREE);
1297   build_process_wrapper (name, tmp);
1298 }
1299
1300 static void
1301 parse_signal_definition ()
1302 {
1303   tree signame = parse_defining_occurrence ();
1304   tree modes = NULL_TREE;
1305   tree dest = NULL_TREE;
1306
1307   if (check_token (EQL))
1308     {
1309       expect (LPRN, "missing '(' after 'SIGNAL <name> ='");
1310       for (;;)
1311         {
1312           tree mode = parse_mode ();
1313           modes = tree_cons (NULL_TREE, mode, modes);
1314           if (! check_token (COMMA))
1315             break;
1316         }
1317       expect (RPRN, "missing ')'");
1318       modes = nreverse (modes);
1319     }
1320
1321   if (check_token (TO))
1322     {
1323       tree decl;
1324       int save_ignoring = ignoring;
1325       ignoring = 0;
1326       decl = parse_name ();
1327       ignoring = save_ignoring;
1328       if (pass > 1)
1329         {
1330           if (decl == NULL_TREE
1331               || TREE_CODE (decl) == ERROR_MARK
1332               || TREE_CODE (decl) != FUNCTION_DECL
1333               || !CH_DECL_PROCESS (decl))
1334             error ("must specify a PROCESS name");
1335           else
1336             dest = decl;
1337         }
1338     }
1339
1340   if (! global_bindings_p ())
1341     error ("SIGNAL must be in global reach");
1342   else
1343     {
1344       tree struc =  build_signal_struct_type (signame, modes, dest);
1345       tree decl =
1346         generate_tasking_code_variable (signame,
1347                                         &signal_code,
1348                                         current_module->is_spec_module);
1349       /* remember the code variable in the struct type */
1350       DECL_TASKING_CODE_DECL (struc) = (struct lang_decl *)decl;
1351       CH_DECL_SIGNAL (struc) = 1;
1352       add_taskstuff_to_list (decl, "_TT_Signal",
1353                              current_module->is_spec_module ?
1354                              NULL_TREE : signal_code, struc, NULL_TREE);
1355     }
1356
1357 }
1358
1359 static void
1360 parse_signal_definition_statement ()
1361 {
1362   int save_ignoring = ignoring;
1363   ignoring = pass == 2;
1364   require (SIGNAL);
1365   for (;;)
1366     {
1367       parse_signal_definition ();
1368       if (! check_token (COMMA))
1369         break;
1370       if (PEEK_TOKEN () == SC)
1371         {
1372           error ("syntax error while parsing signal definition statement");
1373           break;
1374         }
1375     }
1376   parse_semi_colon ();
1377   ignoring = save_ignoring;
1378 }
1379
1380 static int
1381 parse_definition (in_spec_module)
1382      int in_spec_module;
1383 {
1384   switch (PEEK_TOKEN ())
1385     {
1386     case NAME:
1387       if (PEEK_TOKEN1() == COLON)
1388         {
1389           if (PEEK_TOKEN2() == PROC)
1390             {
1391               parse_procedure_definition (in_spec_module);
1392               return 1;
1393             }
1394           else if (PEEK_TOKEN2() == PROCESS)
1395             {
1396               parse_process_definition (in_spec_module);
1397               return 1;
1398             }
1399         }
1400       return 0;
1401     case DCL:
1402       parse_declaration_statement(in_spec_module);
1403       break;
1404     case GRANT:
1405       parse_grant_statement ();
1406       break;
1407     case NEWMODE:
1408       parse_mode_definition_statement(1);
1409       break;
1410     case SC:
1411       label = NULL_TREE;
1412       FORWARD_TOKEN();
1413       return 1;
1414     case SEIZE:
1415       parse_seize_statement ();
1416       break;
1417     case SIGNAL:
1418       parse_signal_definition_statement ();
1419       break;
1420     case SYN:
1421       parse_synonym_definition_statement();
1422       break;
1423     case SYNMODE:
1424       parse_mode_definition_statement(0);
1425       break;
1426     default:
1427       return 0;
1428     }
1429   return 1;
1430 }
1431
1432 static void
1433 parse_then_clause ()
1434 {
1435   expect (THEN, "expected 'THEN' after 'IF'");
1436   if (! ignoring)
1437     emit_line_note (input_filename, lineno);
1438   parse_opt_actions ();
1439 }
1440
1441 static void
1442 parse_opt_else_clause ()
1443 {
1444   while (check_token (ELSIF))
1445     {
1446       tree cond = parse_expression ();
1447       if (! ignoring)
1448         expand_start_elseif (truthvalue_conversion (cond));
1449       parse_then_clause ();
1450     }
1451   if (check_token (ELSE))
1452     {
1453       if (! ignoring)
1454         { emit_line_note (input_filename, lineno);
1455           expand_start_else ();
1456         }
1457       parse_opt_actions ();
1458     }
1459 }
1460
1461 static tree parse_expr_list ()
1462 {
1463   tree expr = parse_expression ();
1464   tree list = ignoring ? NULL_TREE : build_tree_list (NULL_TREE, expr);
1465   while (check_token (COMMA))
1466     {
1467       expr = parse_expression ();
1468       if (! ignoring)
1469         list = tree_cons (NULL_TREE, expr, list);
1470     }
1471   return list;
1472 }
1473
1474 static tree
1475 parse_range_list_clause ()
1476 {
1477   tree name = parse_opt_name_string (0);
1478   if (name == NULL_TREE)
1479     return NULL_TREE;
1480   while (check_token (COMMA))
1481     {
1482       name = parse_name_string (0);
1483     }
1484   if (check_token (SC))
1485     {
1486       sorry ("case range list");
1487       return error_mark_node;
1488     }
1489   pushback_token (NAME, name);
1490   return NULL_TREE;
1491 }
1492
1493 static void
1494 pushback_paren_expr (expr)
1495      tree expr;
1496 {
1497   if (pass == 1 && !ignoring)
1498     expr = build1 (PAREN_EXPR, NULL_TREE, expr);
1499   pushback_token (EXPR, expr);
1500 }
1501
1502 /* Matches: <case label> */
1503
1504 static tree
1505 parse_case_label ()
1506 {
1507   tree expr;
1508   if (check_token (ELSE))
1509     return case_else_node;
1510   /* Does this also handle the case of a mode name?  FIXME */
1511   expr = parse_expression ();
1512   if (check_token (COLON))
1513     {
1514       tree max_expr = parse_expression ();
1515       if (! ignoring)
1516         expr = build (RANGE_EXPR, NULL_TREE, expr, max_expr);
1517     }
1518   return expr;
1519 }
1520
1521 /* Parses:  <case_label_list>
1522    Fails if not followed by COMMA or COLON.
1523    If it fails, it backs up if needed, and returns NULL_TREE.
1524    IN_TUPLE is true if we are parsing a tuple element,
1525    and 0 if we are parsing a case label specification. */
1526
1527 static tree
1528 parse_case_label_list (selector, in_tuple)
1529      tree selector;
1530      int in_tuple;
1531 {
1532   tree expr, list;
1533   if (! check_token (LPRN))
1534     return NULL_TREE;
1535   if (check_token (MUL))
1536     {
1537       expect (RPRN, "missing ')' after '*' case label list");
1538       if (ignoring)
1539         return integer_zero_node;
1540       expr = build (RANGE_EXPR, NULL_TREE, NULL_TREE, NULL_TREE);
1541       expr = build_tree_list (NULL_TREE, expr);
1542       return expr;
1543     }
1544   expr = parse_case_label ();
1545   if (check_token (RPRN))
1546     {
1547       if ((in_tuple || PEEK_TOKEN () != COMMA) && PEEK_TOKEN () != COLON)
1548         {
1549           /* Ooops!  It looks like it was the start of an action or
1550              unlabelled tuple element,  and not a case label, so back up. */
1551           if (expr != NULL_TREE && TREE_CODE (expr) == RANGE_EXPR)
1552             {
1553               error ("misplaced colon in case label");
1554               expr = error_mark_node;
1555             }
1556           pushback_paren_expr (expr);
1557           return NULL_TREE;
1558         }
1559       list = build_tree_list (NULL_TREE, expr);
1560       if (expr == case_else_node && selector != NULL_TREE)
1561         ELSE_LABEL_SPECIFIED (selector) = 1;
1562       return list;
1563     }
1564   list = build_tree_list (NULL_TREE, expr);
1565   if (expr == case_else_node && selector != NULL_TREE)
1566     ELSE_LABEL_SPECIFIED (selector) = 1;
1567
1568   while (check_token (COMMA))
1569     {
1570       expr = parse_case_label ();
1571       list = tree_cons (NULL_TREE, expr, list);
1572       if (expr == case_else_node && selector != NULL_TREE)
1573         ELSE_LABEL_SPECIFIED (selector) = 1;
1574     }
1575   expect (RPRN, "missing ')' at end of case label list");
1576   return nreverse (list);
1577 }
1578
1579 /* Parses:  <case_label_specification>
1580    Must be followed by a COLON.
1581    If it fails, it backs up if needed, and returns NULL_TREE. */
1582
1583 static tree
1584 parse_case_label_specification (selectors)
1585      tree selectors;
1586 {
1587   tree list_list = NULL_TREE;
1588   tree list;
1589   list = parse_case_label_list (selectors, 0);
1590   if (list == NULL_TREE)
1591     return NULL_TREE;
1592   list_list = build_tree_list (NULL_TREE, list);
1593   while (check_token (COMMA))
1594     {
1595       if (selectors != NULL_TREE)
1596         selectors = TREE_CHAIN (selectors);
1597       list = parse_case_label_list (selectors, 0);
1598       if (list == NULL_TREE)
1599         {
1600           error ("unrecognized case label list after ','");
1601           return list_list;
1602         }
1603       list_list = tree_cons (NULL_TREE, list, list_list);
1604     }
1605   return nreverse (list_list);
1606 }
1607
1608 static void
1609 parse_single_dimension_case_action (selector)
1610      tree selector;
1611 {
1612   int  no_completeness_check = 0;
1613
1614 /* The case label/action toggle.  It is 0 initially, and when an action
1615    was last seen.  It is 1 integer_zero_node when a label was last seen. */
1616   int caseaction_flag = 0;
1617
1618   if (! ignoring)
1619     {
1620       expand_exit_needed = 0;
1621       selector = check_case_selector (selector);
1622       expand_start_case (1, selector, TREE_TYPE (selector), "CASE statement");
1623       push_momentary ();
1624     }
1625
1626   for (;;)
1627     {
1628       tree label_spec = parse_case_label_specification (selector);
1629       if (label_spec != NULL_TREE)
1630         {
1631           expect (COLON, "missing ':' in case alternative");
1632           if (! ignoring)
1633             {
1634               no_completeness_check |= chill_handle_single_dimension_case_label (
1635                 selector, label_spec, &expand_exit_needed, &caseaction_flag);
1636             }
1637         }
1638       else if (parse_action ())
1639         {
1640           expand_exit_needed = 1;
1641           caseaction_flag = 0;
1642         }
1643       else
1644         break;
1645     }
1646
1647   if (! ignoring)
1648     {
1649       if (expand_exit_needed || caseaction_flag == 1)
1650         expand_exit_something ();
1651     }
1652   if (check_token (ELSE))
1653     {
1654       if (! ignoring)
1655           chill_handle_case_default ();
1656       parse_opt_actions ();
1657       if (! ignoring)
1658         {
1659           emit_line_note (input_filename, lineno);
1660           expand_exit_something ();
1661         }
1662     }
1663   else if (! ignoring && TREE_CODE (selector) != ERROR_MARK &&
1664            ! no_completeness_check)
1665     check_missing_cases (TREE_TYPE (selector));
1666
1667   expect (ESAC, "missing 'ESAC' after 'CASE'");
1668   if (! ignoring)
1669     {
1670       expand_end_case (selector);
1671       pop_momentary ();
1672     }
1673 }
1674
1675 static void
1676 parse_multi_dimension_case_action (selector)
1677      tree selector;
1678 {
1679   struct rtx_def *begin_test_label = 0, *end_case_label = 0, *new_label;
1680   tree action_labels = NULL_TREE;
1681   tree tests = NULL_TREE;
1682   int  save_lineno = lineno;
1683   char *save_filename = input_filename;
1684
1685   /* We can't compute the range of an (ELSE) label until all of the CASE
1686      label specifications have been seen, however, the code for the actions
1687      between them is generated on the fly. We can still generate everything in
1688      one pass is we use the following form:
1689
1690      Compile a CASE of the form
1691
1692        case S1,...,Sn of
1693          (X11),...,(X1n): A1;
1694                ...
1695          (Xm1),...,(Xmn): Am;
1696          else             Ae;
1697        esac;
1698
1699      into:
1700
1701        goto L0;
1702        L1:   A1;  goto L99;
1703           ...
1704        Lm:   Am;  goto L99;
1705        Le:   Ae;  goto L99;
1706        L0:
1707        T1 := s1; ...; Tn := Sn;
1708        if (T1 = X11 and ... and Tn = X1n) GOTO L1;
1709           ...
1710        if (T1 = Xm1 and ... and Tn = Xmn) GOTO Lm;
1711        GOTO Le;
1712        L99;
1713    */
1714
1715   if (! ignoring)
1716     {
1717       selector = check_case_selector_list (selector);
1718       begin_test_label = gen_label_rtx ();
1719       end_case_label   = gen_label_rtx ();
1720       emit_jump (begin_test_label);
1721     }
1722
1723   for (;;)
1724     {
1725       tree label_spec = parse_case_label_specification (selector);
1726       if (label_spec != NULL_TREE)
1727         {
1728           expect (COLON, "missing ':' in case alternative");
1729           if (! ignoring)
1730             {
1731               tests = tree_cons (label_spec, NULL_TREE, tests);
1732
1733               if (action_labels != NULL_TREE)
1734                 emit_jump (end_case_label);
1735
1736               new_label = gen_label_rtx ();
1737               emit_label (new_label);
1738               emit_line_note (input_filename, lineno);
1739               action_labels = tree_cons (NULL_TREE, NULL_TREE, action_labels);
1740               TREE_CST_RTL (action_labels) = new_label;
1741             }
1742         }
1743       else if (! parse_action ())
1744         {
1745           if (action_labels != NULL_TREE)
1746             emit_jump (end_case_label);
1747           break;
1748         }
1749     }
1750
1751   if (check_token (ELSE))
1752     {
1753       if (! ignoring)
1754         {
1755           new_label = gen_label_rtx ();
1756           emit_label (new_label);
1757           emit_line_note (input_filename, lineno);
1758           action_labels = tree_cons (NULL_TREE, NULL_TREE, action_labels);
1759           TREE_CST_RTL (action_labels) = new_label;
1760         }
1761       parse_opt_actions ();
1762       if (! ignoring)
1763         emit_jump (end_case_label);
1764     }
1765
1766   expect (ESAC, "missing 'ESAC' after 'CASE'");
1767
1768   if (! ignoring)
1769     {
1770       emit_label (begin_test_label);
1771       emit_line_note (save_filename, save_lineno);
1772       if (tests != NULL_TREE)
1773         {
1774           tree cond;
1775           tests = nreverse (tests);
1776           action_labels = nreverse (action_labels);
1777           compute_else_ranges (selector, tests);
1778
1779           cond = build_multi_case_selector_expression (selector, TREE_PURPOSE (tests));
1780           expand_start_cond (truthvalue_conversion (cond), label ? 1 : 0);
1781           emit_jump (TREE_CST_RTL (action_labels));
1782
1783           for (tests = TREE_CHAIN (tests), action_labels = TREE_CHAIN (action_labels);
1784                tests != NULL_TREE && action_labels != NULL_TREE;
1785                tests = TREE_CHAIN (tests), action_labels = TREE_CHAIN (action_labels))
1786             {
1787               cond =
1788                 build_multi_case_selector_expression (selector, TREE_PURPOSE (tests));
1789               expand_start_elseif (truthvalue_conversion (cond));
1790               emit_jump (TREE_CST_RTL (action_labels));
1791             }
1792           if (action_labels != NULL_TREE)
1793             {
1794               expand_start_else ();
1795               emit_jump (TREE_CST_RTL (action_labels));
1796             }
1797           expand_end_cond ();
1798         }
1799       emit_label (end_case_label);
1800     }
1801 }
1802
1803 static void
1804 parse_case_action (label)
1805      tree label;
1806 {
1807   tree selector;
1808   int  multi_dimension_case = 0;
1809
1810   require (CASE);
1811   selector = parse_expr_list ();
1812   selector = nreverse (selector);
1813   expect (OF, "missing 'OF' after 'CASE'");
1814   parse_range_list_clause ();
1815
1816   PUSH_ACTION;
1817   if (label)
1818     pushlevel (1);
1819
1820   if (! ignoring)
1821     {
1822       expand_exit_needed = 0;
1823       if (TREE_CODE (selector) == TREE_LIST)
1824         {
1825           if (TREE_CHAIN (selector) != NULL_TREE)
1826             multi_dimension_case = 1;
1827           else
1828             selector = TREE_VALUE (selector);
1829         }
1830     }
1831
1832   /* We want to use the regular CASE support for the single dimension case. The
1833      multi dimension case requires different handling. Note that when "ignoring"
1834      is true we parse using the single dimension code. This is OK since it will
1835      still parse correctly. */
1836   if (multi_dimension_case)
1837     parse_multi_dimension_case_action (selector);
1838   else
1839     parse_single_dimension_case_action (selector);
1840
1841   if (label)
1842     {
1843       possibly_define_exit_label (label);
1844       poplevel (0, 0, 0);
1845     }
1846 }
1847
1848 /* Matches: [ <asm_operand> { "," <asm_operand> }* ],
1849    where <asm_operand> = STRING '(' <expression> ')'
1850    These are the operands other than the first string and colon
1851    in  asm ("addextend %2,%1": "=dm" (x), "0" (y), "g" (*x))  */
1852
1853 static tree
1854 parse_asm_operands ()
1855 {
1856   tree list = NULL_TREE;
1857   if (PEEK_TOKEN () != STRING)
1858     return NULL_TREE;
1859   for (;;)
1860     {
1861       tree string, expr;
1862       if (PEEK_TOKEN () != STRING)
1863         {
1864           error ("bad ASM operand");
1865           return list;
1866         }
1867       string = PEEK_TREE();
1868       FORWARD_TOKEN ();
1869       expect (LPRN, "missing '(' in ASM operand");
1870       expr = parse_expression ();
1871       expect (RPRN, "missing ')' in ASM operand");
1872       list = tree_cons (string, expr, list);
1873       if (! check_token (COMMA))
1874         break;
1875     }
1876   return nreverse (list);
1877 }
1878
1879 /* Matches:  STRING { ',' STRING }* */
1880
1881 static tree
1882 parse_asm_clobbers ()
1883 {
1884   tree list = NULL_TREE;
1885   for (;;)
1886     {
1887       tree string;
1888       if (PEEK_TOKEN () != STRING)
1889         {
1890           error ("bad ASM operand");
1891           return list;
1892         }
1893       string = PEEK_TREE();
1894       FORWARD_TOKEN ();
1895       list = tree_cons (NULL_TREE, string, list);
1896       if (! check_token (COMMA))
1897         break;
1898     }
1899   return list;
1900 }
1901
1902 void
1903 ch_expand_asm_operands (string, outputs, inputs, clobbers, vol, filename, line)
1904      tree string, outputs, inputs, clobbers;
1905      int vol;
1906      char *filename;
1907      int line;
1908 {
1909   int noutputs = list_length (outputs);
1910   register int i;
1911   /* o[I] is the place that output number I should be written.  */
1912   register tree *o = (tree *) alloca (noutputs * sizeof (tree));
1913   register tree tail;
1914
1915   if (TREE_CODE (string) == ADDR_EXPR)
1916     string = TREE_OPERAND (string, 0);
1917   if (TREE_CODE (string) != STRING_CST)
1918     {
1919       error ("asm template is not a string constant");
1920       return;
1921     }
1922
1923   /* Record the contents of OUTPUTS before it is modified.  */
1924   for (i = 0, tail = outputs; tail; tail = TREE_CHAIN (tail), i++)
1925     o[i] = TREE_VALUE (tail);
1926
1927 #if 0
1928   /* Perform default conversions on array and function inputs.  */
1929   /* Don't do this for other types--
1930      it would screw up operands expected to be in memory.  */
1931   for (i = 0, tail = inputs; tail; tail = TREE_CHAIN (tail), i++)
1932     if (TREE_CODE (TREE_TYPE (TREE_VALUE (tail))) == ARRAY_TYPE
1933         || TREE_CODE (TREE_TYPE (TREE_VALUE (tail))) == FUNCTION_TYPE)
1934       TREE_VALUE (tail) = default_conversion (TREE_VALUE (tail));
1935 #endif
1936
1937   /* Generate the ASM_OPERANDS insn;
1938      store into the TREE_VALUEs of OUTPUTS some trees for
1939      where the values were actually stored.  */
1940   expand_asm_operands (string, outputs, inputs, clobbers, vol, filename, line);
1941
1942   /* Copy all the intermediate outputs into the specified outputs.  */
1943   for (i = 0, tail = outputs; tail; tail = TREE_CHAIN (tail), i++)
1944     {
1945       if (o[i] != TREE_VALUE (tail))
1946         {
1947           expand_expr (build_chill_modify_expr (o[i], TREE_VALUE (tail)),
1948                        0, VOIDmode, 0);
1949           free_temp_slots ();
1950         }
1951       /* Detect modification of read-only values.
1952          (Otherwise done by build_modify_expr.)  */
1953       else
1954         {
1955           tree type = TREE_TYPE (o[i]);
1956           if (TYPE_READONLY (type)
1957               || ((TREE_CODE (type) == RECORD_TYPE
1958                    || TREE_CODE (type) == UNION_TYPE)
1959                   && TYPE_FIELDS_READONLY (type)))
1960             warning ("readonly location modified by 'asm'");
1961         }
1962     }
1963
1964   /* Those MODIFY_EXPRs could do autoincrements.  */
1965   emit_queue ();
1966 }
1967
1968 static void
1969 parse_asm_action ()
1970 {
1971   tree insn;
1972   require (ASM_KEYWORD);
1973   expect (LPRN, "missing '('");
1974   PUSH_ACTION;
1975   if (!ignoring)
1976     emit_line_note (input_filename, lineno);
1977   insn = parse_expression ();
1978   if (check_token (COLON))
1979     {
1980       tree output_operand, input_operand, clobbered_regs;
1981       output_operand = parse_asm_operands ();
1982       if (check_token (COLON))
1983         input_operand = parse_asm_operands ();
1984       else
1985         input_operand = NULL_TREE;
1986       if (check_token (COLON))
1987         clobbered_regs = parse_asm_clobbers ();
1988       else
1989         clobbered_regs = NULL_TREE;
1990       expect (RPRN, "missing ')'");
1991       if (!ignoring)
1992         ch_expand_asm_operands (insn, output_operand, input_operand,
1993                                 clobbered_regs, FALSE,
1994                                 input_filename, lineno);
1995     }
1996   else
1997     {
1998       expect (RPRN, "missing ')'");
1999       STRIP_NOPS (insn);
2000       if (ignoring) { }
2001       else if ((TREE_CODE (insn) == ADDR_EXPR
2002            && TREE_CODE (TREE_OPERAND (insn, 0)) == STRING_CST)
2003           || TREE_CODE (insn) == STRING_CST)
2004         expand_asm (insn);
2005       else
2006         error ("argument of `asm' is not a constant string");
2007     }
2008 }
2009
2010 static void
2011 parse_begin_end_block (label)
2012      tree label;
2013 {
2014   require (BEGINTOKEN);
2015 #if 0
2016   /* don't make a linenote at BEGIN */
2017   INIT_ACTION;
2018 #endif
2019   pushlevel (1);
2020   if (! ignoring)
2021     {
2022       clear_last_expr ();
2023       push_momentary ();
2024       expand_start_bindings (label ? 1 : 0);
2025     }
2026   push_handler ();
2027   parse_body ();
2028   expect (END, "missing 'END'");
2029   /* Note that the opthandler comes before the poplevel
2030      - hence a handler is in the scope of the block. */
2031   parse_opt_handler ();
2032   possibly_define_exit_label (label);
2033   if (! ignoring)
2034     {
2035       emit_line_note (input_filename, lineno);
2036       expand_end_bindings (getdecls (), kept_level_p (), 0);
2037     }
2038   poplevel (kept_level_p (), 0, 0);
2039   if (! ignoring)
2040     pop_momentary ();
2041   parse_opt_end_label_semi_colon (label);
2042 }
2043
2044 static void
2045 parse_if_action (label)
2046      tree label;
2047 {
2048   tree cond;
2049   require (IF);
2050   PUSH_ACTION;
2051   cond = parse_expression ();
2052   if (label)
2053     pushlevel (1);
2054   if (! ignoring)
2055     {
2056       expand_start_cond (truthvalue_conversion (cond),
2057                          label ? 1 : 0);
2058     }
2059   parse_then_clause ();
2060   parse_opt_else_clause ();
2061   expect (FI, "expected 'FI' after 'IF'");
2062   if (! ignoring)
2063     {
2064       emit_line_note (input_filename, lineno);
2065       expand_end_cond ();
2066     }
2067   if (label)
2068     {
2069       possibly_define_exit_label  (label);
2070       poplevel (0, 0, 0);
2071     }
2072 }
2073
2074 /* Matches:  <iteration>  (as in a <for control>). */
2075
2076 static void
2077 parse_iteration ()
2078 {
2079   tree loop_counter = parse_defining_occurrence ();
2080   if (check_token (ASGN))
2081     {
2082       tree start_value = parse_expression ();
2083       tree step_value
2084         = check_token (BY) ? parse_expression () : NULL_TREE;
2085       int going_down = check_token (DOWN);
2086       tree end_value;
2087       if (check_token (TO))
2088         end_value = parse_expression ();
2089       else
2090         {
2091           error ("expected 'TO' in step enumeration");
2092           end_value = error_mark_node;
2093         }
2094       if (!ignoring)
2095         build_loop_iterator (loop_counter, start_value, step_value,
2096                              end_value, going_down, 0, 0);
2097     }
2098   else
2099     {
2100       int going_down = check_token (DOWN);
2101       tree expr;
2102       if (check_token (IN))
2103         expr = parse_expression ();
2104       else
2105         {
2106           error ("expected 'IN' in FOR control here");
2107           expr = error_mark_node;
2108         }
2109       if (!ignoring)
2110         {
2111           tree low_bound, high_bound;
2112           if (expr && TREE_CODE (expr) == TYPE_DECL)
2113             {
2114               expr = TREE_TYPE (expr);
2115               /* FIXME: expr must be an array or powerset */
2116               low_bound = convert (expr, TYPE_MIN_VALUE (expr));
2117               high_bound = convert (expr, TYPE_MAX_VALUE (expr));
2118             }
2119           else
2120             {
2121               low_bound = expr;
2122               high_bound = NULL_TREE;
2123             }
2124           build_loop_iterator (loop_counter, low_bound,
2125                                NULL_TREE, high_bound,
2126                                going_down, 1, 0);
2127         }
2128     }
2129 }
2130
2131 /* Matches: '(' <event list> ')' ':'.
2132    Or; returns NULL_EXPR. */
2133
2134 static tree
2135 parse_delay_case_event_list ()
2136 {
2137   tree event_list = NULL_TREE;
2138   tree event;
2139   if (! check_token (LPRN))
2140     return NULL_TREE;
2141   event = parse_expression ();
2142   if (PEEK_TOKEN () == ')' && PEEK_TOKEN1 () != ':')
2143     {
2144       /* Oops. */
2145       require (RPRN);
2146       pushback_paren_expr (event);
2147       return NULL_TREE;
2148     }
2149   for (;;)
2150     {
2151       if (! ignoring)
2152         event_list = tree_cons (NULL_TREE, event, event_list);
2153       if (! check_token (COMMA))
2154         break;
2155       event = parse_expression ();
2156     }
2157   expect (RPRN, "missing ')'");
2158   expect (COLON, "missing ':'");
2159   return ignoring ? error_mark_node : event_list;
2160 }
2161
2162 static void
2163 parse_delay_case_action (label)
2164      tree label;
2165 {
2166   tree label_cnt = NULL_TREE, set_location, priority;
2167   tree combined_event_list = NULL_TREE;
2168   require (DELAY);
2169   require (CASE);
2170   PUSH_ACTION;
2171   pushlevel (1);
2172   expand_exit_needed = 0;
2173   if (check_token (SET))
2174     {
2175       set_location = parse_expression ();
2176       parse_semi_colon ();
2177     }
2178   else
2179     set_location = NULL_TREE;
2180   if (check_token (PRIORITY))
2181     {
2182       priority = parse_expression ();
2183       parse_semi_colon ();
2184     }
2185   else
2186     priority = NULL_TREE;
2187   if (! ignoring)
2188     label_cnt = build_delay_case_start (set_location, priority);
2189   for (;;)
2190     {
2191       tree event_list = parse_delay_case_event_list ();
2192       if (event_list)
2193         {
2194           if (! ignoring )
2195             {
2196               int if_or_elseif = combined_event_list == NULL_TREE;
2197               build_delay_case_label (event_list, if_or_elseif);
2198               combined_event_list = chainon (combined_event_list, event_list);
2199             }
2200         }
2201       else if (parse_action ())
2202         {
2203           if (! ignoring)
2204             {
2205               expand_exit_needed = 1;
2206               if (combined_event_list == NULL_TREE)
2207                 error ("missing DELAY CASE alternative");
2208             }
2209         }
2210       else
2211         break;
2212     }
2213   expect (ESAC, "missing 'ESAC' in DELAY CASE'");
2214   if (! ignoring)
2215     build_delay_case_end (combined_event_list);
2216   possibly_define_exit_label (label);
2217   poplevel (0, 0, 0);
2218 }
2219
2220 static void
2221 parse_do_action (label)
2222      tree label;
2223 {
2224   tree condition;
2225   int token;
2226   require (DO);
2227   if (check_token (WITH))
2228     {
2229       tree list = NULL_TREE;
2230       for (;;)
2231         {
2232           tree name = parse_primval ();
2233           if (! ignoring && TREE_CODE (name) != ERROR_MARK)
2234             {
2235               if (TREE_CODE (TREE_TYPE (name)) == REFERENCE_TYPE)
2236                 name = convert (TREE_TYPE (TREE_TYPE (name)), name);
2237               else
2238                 {
2239                   int is_loc = chill_location (name);
2240                   if (is_loc == 1) /* This is probably not possible */
2241                     warning ("non-referable location in DO WITH");
2242
2243                   if (is_loc > 1)
2244                     name = build_chill_arrow_expr (name, 1);
2245                   name = decl_temp1 (get_identifier ("__with_element"),
2246                                      TREE_TYPE (name),
2247                                      0, name, 0, 0);
2248                   if (is_loc > 1)
2249                     name = build_chill_indirect_ref (name, NULL_TREE, 0);
2250
2251                 }
2252               if (TREE_CODE (TREE_TYPE (name)) != RECORD_TYPE)
2253                 error ("WITH element must be of STRUCT mode");
2254               else
2255                 list = tree_cons (NULL_TREE, name, list);
2256             }
2257           if (! check_token (COMMA))
2258             break;
2259         }
2260       pushlevel (1);
2261       push_action ();
2262       for (list = nreverse (list); list != NULL_TREE; list = TREE_CHAIN (list))
2263         shadow_record_fields (TREE_VALUE (list));
2264
2265       parse_semi_colon ();
2266       parse_opt_actions ();
2267       expect (OD, "missing 'OD' in 'DO WITH'");
2268       if (! ignoring)
2269         emit_line_note (input_filename, lineno);
2270       possibly_define_exit_label (label);
2271       parse_opt_handler ();
2272       parse_opt_end_label_semi_colon (label);
2273       poplevel (0, 0, 0);
2274       return;
2275     }
2276   token = PEEK_TOKEN();
2277   if (token != FOR && token != WHILE)
2278     {
2279       push_handler ();
2280       parse_opt_actions ();
2281       expect (OD, "Missing 'OD' after 'DO'");
2282       parse_opt_handler ();
2283       parse_opt_end_label_semi_colon (label);
2284       return;
2285     }
2286   if (! ignoring)
2287     emit_line_note (input_filename, lineno);
2288   push_loop_block ();
2289   if (check_token (FOR))
2290     {
2291       if (check_token (EVER))
2292         {
2293           if (!ignoring)
2294             build_loop_iterator (NULL_TREE, NULL_TREE,
2295                                  NULL_TREE, NULL_TREE,
2296                                  0, 0, 1);
2297         }
2298       else
2299         {
2300           parse_iteration ();
2301           while (check_token (COMMA))
2302             parse_iteration ();
2303         }
2304     }
2305   else if (!ignoring)
2306     build_loop_iterator (NULL_TREE, NULL_TREE,
2307                          NULL_TREE, NULL_TREE,
2308                          0, 0, 1);
2309
2310   begin_loop_scope ();
2311   if (! ignoring)
2312     build_loop_start (label);
2313   condition = check_token (WHILE) ? parse_expression () : NULL_TREE;
2314   if (! ignoring)
2315     top_loop_end_check (condition);
2316   parse_semi_colon ();
2317   parse_opt_actions ();
2318   if (! ignoring)
2319     build_loop_end ();
2320   expect (OD, "Missing 'OD' after 'DO'");
2321   /* Note that the handler is inside the reach of the DO. */
2322   parse_opt_handler ();
2323   end_loop_scope (label);
2324   pop_loop_block ();
2325   parse_opt_end_label_semi_colon (label);
2326 }
2327
2328 /* Matches: '(' <signal name> [ 'IN' <defining occurrence list> ']' ')' ':'
2329    or: '(' <buffer location> IN (defining occurrence> ')' ':'
2330    or: returns NULL_TREE. */
2331
2332 static tree
2333 parse_receive_spec ()
2334 {
2335   tree val;
2336   tree name_list = NULL_TREE;
2337   if (!check_token (LPRN))
2338     return NULL_TREE;
2339   val = parse_primval ();
2340   if (check_token (IN))
2341     {
2342 #if 0
2343       if (flag_local_loop_counter)
2344         name_list = parse_defining_occurrence_list ();
2345       else
2346 #endif
2347         {
2348           for (;;)
2349             {
2350               tree loc = parse_primval ();
2351               if (! ignoring)
2352                 name_list = tree_cons (NULL_TREE, loc, name_list);
2353               if (! check_token (COMMA))
2354                 break;
2355             }
2356         }
2357     }
2358   if (! check_token (RPRN))
2359     {
2360       error ("missing ')' in signal/buffer receive alternative");
2361       return NULL_TREE;
2362     }
2363   if (check_token (COLON))
2364     {
2365       if (ignoring || val == NULL_TREE || TREE_CODE (val) == ERROR_MARK)
2366         return error_mark_node;
2367       else
2368         return build_receive_case_label (val, name_list);
2369     }
2370
2371   /* We saw: '(' <primitive value> ')' not followed by ':'.
2372      Presumably the start of an action.  Backup and fail. */
2373   if (name_list != NULL_TREE)
2374     error ("misplaced 'IN' in signal/buffer receive alternative");
2375   pushback_paren_expr (val);
2376   return NULL_TREE;
2377 }
2378
2379 /* To understand the code generation for this, see ch-tasking.c,
2380    and the 2-page comments preceding the
2381    build_chill_receive_case_start () definition. */
2382
2383 static void
2384 parse_receive_case_action (label)
2385      tree label;
2386 {
2387   tree instance_location;
2388   tree have_else_actions;
2389   int spec_seen = 0;
2390   tree alt_list = NULL_TREE;
2391   require (RECEIVE);
2392   require (CASE);
2393   push_action ();
2394   pushlevel (1);
2395   if (! ignoring)
2396     {
2397       expand_exit_needed = 0;
2398     }
2399
2400   if (check_token (SET))
2401     {
2402       instance_location = parse_expression ();
2403       parse_semi_colon ();
2404     }
2405   else
2406     instance_location = NULL_TREE;
2407   if (! ignoring)
2408     instance_location = build_receive_case_start (instance_location);
2409
2410   for (;;)
2411     {
2412       tree receive_spec = parse_receive_spec ();
2413       if (receive_spec)
2414         {
2415           if (! ignoring)
2416             alt_list = tree_cons (NULL_TREE, receive_spec, alt_list);
2417           spec_seen++;
2418         }
2419       else if (parse_action ())
2420         {
2421           if (! spec_seen && pass == 1)
2422             error ("missing RECEIVE alternative");
2423           if (! ignoring)
2424             expand_exit_needed = 1;
2425           spec_seen = 1;
2426         }
2427       else
2428         break;
2429     }
2430   if (check_token (ELSE))
2431     {
2432       if (! ignoring)
2433         {
2434           emit_line_note (input_filename, lineno);
2435           if (build_receive_case_if_generated ())
2436             expand_start_else ();
2437         }
2438       parse_opt_actions ();
2439       have_else_actions = integer_one_node;
2440     }
2441   else
2442     have_else_actions = integer_zero_node;
2443   expect (ESAC, "missing 'ESAC' matching 'RECEIVE CASE'");
2444   if (! ignoring)
2445     {
2446       build_receive_case_end (nreverse (alt_list), have_else_actions);
2447     }
2448   possibly_define_exit_label (label);
2449   poplevel (0, 0, 0);
2450 }
2451
2452 static void
2453 parse_send_action ()
2454 {
2455   tree signal = NULL_TREE;
2456   tree buffer = NULL_TREE;
2457   tree value_list;
2458   tree with_expr, to_expr, priority;
2459   require (SEND);
2460   /* The tricky part is distinguishing between a SEND buffer action,
2461      and a SEND signal action. */
2462   if (pass != 2 || PEEK_TOKEN () != NAME)
2463     {
2464       /* If this is pass 2, it's a SEND buffer action.
2465          If it's pass 1, we don't care. */
2466       buffer = parse_primval ();
2467     }
2468   else
2469     {
2470       /* We have to specifically check for signalname followed by
2471          a '(', since we allow a signalname to be used (syntactically)
2472          as a "function". */
2473       tree name = parse_name ();
2474       if (TREE_CODE (name) == TYPE_DECL && CH_DECL_SIGNAL (name))
2475         signal = name; /* It's a SEND signal action! */
2476       else
2477         {
2478           /* It's not a legal SEND signal action.
2479              Back up and try as a SEND buffer action. */
2480           pushback_token (EXPR, name);
2481           buffer = parse_primval ();
2482         }
2483     }
2484   if (check_token (LPRN))
2485     {
2486       value_list = NULL_TREE;
2487       for (;;)
2488         {
2489           tree expr = parse_untyped_expr ();
2490           if (! ignoring)
2491             value_list = tree_cons (NULL_TREE, expr, value_list);
2492           if (! check_token (COMMA))
2493             break;
2494         }
2495       value_list = nreverse (value_list);
2496       expect (RPRN, "missing ')'");
2497     }
2498   else
2499     value_list = NULL_TREE;
2500   if (check_token (WITH))
2501     with_expr = parse_expression ();
2502   else
2503     with_expr = NULL_TREE;
2504   if (check_token (TO))
2505     to_expr = parse_expression ();
2506   else
2507     to_expr = NULL_TREE;
2508   if (check_token (PRIORITY))
2509     priority = parse_expression ();
2510   else
2511     priority = NULL_TREE;
2512   PUSH_ACTION;
2513   if (ignoring)
2514     return;
2515
2516   if (signal)
2517     { /* It's a <send signal action>! */
2518       tree sigdesc = build_signal_descriptor (signal, value_list);
2519       if (sigdesc != NULL_TREE && TREE_CODE (sigdesc) != ERROR_MARK)
2520         {
2521           tree sendto = to_expr ? to_expr : IDENTIFIER_SIGNAL_DEST (signal);
2522           expand_send_signal (sigdesc, with_expr,
2523                               sendto, priority, DECL_NAME (signal));
2524         }
2525     }
2526   else
2527     {
2528       /* all checks are done in expand_send_buffer */
2529       expand_send_buffer (buffer, value_list, priority, with_expr, to_expr);
2530     }
2531 }
2532
2533 static void
2534 parse_start_action ()
2535 {
2536   tree name, copy_number, param_list, startset;
2537   require (START);
2538   name = parse_name_string ();
2539   expect (LPRN, "missing '(' in START action");
2540   PUSH_ACTION;
2541   /* copy number is a required parameter */
2542   copy_number = parse_expression ();
2543   if (!ignoring
2544       && (copy_number == NULL_TREE
2545           || TREE_CODE (copy_number) == ERROR_MARK
2546           || TREE_CODE (TREE_TYPE (copy_number)) != INTEGER_TYPE))
2547     {
2548       error ("PROCESS copy number must be integer");
2549       copy_number = integer_zero_node;
2550     }
2551   if (check_token (COMMA))
2552     param_list = parse_expr_list (); /* user parameters */
2553   else
2554     param_list = NULL_TREE;
2555   expect (RPRN, "missing ')'");
2556   startset = check_token (SET) ? parse_primval () : NULL;
2557   build_start_process (name, copy_number, param_list, startset);
2558 }
2559
2560 static void
2561 parse_opt_actions ()
2562 {
2563   while (parse_action ()) ;
2564 }
2565
2566 static int
2567 parse_action ()
2568 {
2569   tree label = NULL_TREE;
2570   tree expr, rhs, loclist;
2571   enum tree_code op;
2572
2573   if (current_function_decl == global_function_decl
2574       && PEEK_TOKEN () != SC
2575       && PEEK_TOKEN () != END)
2576     seen_action = 1, build_constructor = 1;
2577
2578   if (PEEK_TOKEN () == NAME && PEEK_TOKEN1 () == COLON)
2579     {
2580       label = parse_defining_occurrence ();
2581       require (COLON);
2582       INIT_ACTION;
2583       define_label (input_filename, lineno, label);
2584     }
2585
2586   switch (PEEK_TOKEN ())
2587     {
2588     case AFTER:
2589       {
2590         int delay;
2591         require (AFTER);
2592         expr = parse_primval ();
2593         delay = check_token (DELAY);
2594         expect (IN, "missing 'IN'");
2595         push_action ();
2596         pushlevel (1);
2597         build_after_start (expr, delay);
2598         parse_opt_actions ();
2599         expect (TIMEOUT, "missing 'TIMEOUT'");
2600         build_after_timeout_start ();
2601         parse_opt_actions ();
2602         expect (END, "missing 'END'");
2603         build_after_end ();
2604         possibly_define_exit_label (label);
2605         poplevel (0, 0, 0);
2606       }
2607       goto bracketed_action;
2608     case ASM_KEYWORD:
2609       parse_asm_action ();
2610       goto no_handler_action;
2611     case ASSERT:
2612       require (ASSERT);
2613       PUSH_ACTION;
2614       expr = parse_expression ();
2615       if (! ignoring)
2616         { tree assertfail = ridpointers[(int) RID_ASSERTFAIL];
2617           expr = build (TRUTH_ORIF_EXPR, void_type_node, expr,
2618                         build_cause_exception (assertfail, 0));
2619           expand_expr_stmt (fold (expr));
2620         }
2621       goto handler_action;
2622     case AT:
2623       require (AT);
2624       PUSH_ACTION;
2625       expr = parse_primval ();
2626       expect (IN, "missing 'IN'");
2627       pushlevel (1);
2628       if (! ignoring)
2629         build_at_action (expr);
2630       parse_opt_actions ();
2631       expect (TIMEOUT, "missing 'TIMEOUT'");
2632       if (! ignoring)
2633         expand_start_else ();
2634       parse_opt_actions ();
2635       expect (END, "missing 'END'");
2636       if (! ignoring)
2637         expand_end_cond ();
2638       possibly_define_exit_label (label);
2639       poplevel (0, 0, 0);
2640       goto bracketed_action;
2641     case BEGINTOKEN:
2642       parse_begin_end_block (label);
2643       return 1;
2644     case CASE:
2645       parse_case_action (label);
2646       goto bracketed_action;
2647     case CAUSE:
2648       require (CAUSE);
2649       expr = parse_name_string ();
2650       PUSH_ACTION;
2651       if (! ignoring && TREE_CODE (expr) != ERROR_MARK)
2652         expand_cause_exception (expr);
2653       goto no_handler_action;
2654     case CONTINUE:
2655       require (CONTINUE);
2656       expr = parse_expression ();
2657       PUSH_ACTION;
2658       if (! ignoring)
2659         expand_continue_event (expr);
2660       goto handler_action;
2661     case CYCLE:
2662       require (CYCLE);
2663       PUSH_ACTION;
2664       expr = parse_primval ();
2665       expect (IN, "missing 'IN' after 'CYCLE'");
2666       pushlevel (1);
2667       /* We a tree list where TREE_VALUE is the label
2668          and TREE_PURPOSE is the variable denotes the timeout id. */
2669       expr = build_cycle_start (expr);
2670       parse_opt_actions ();
2671       expect (END, "missing 'END'");
2672       if (! ignoring)
2673         build_cycle_end (expr);
2674       possibly_define_exit_label (label);
2675       poplevel (0, 0, 0);
2676       goto bracketed_action;
2677     case DELAY:
2678       if (PEEK_TOKEN1 () == CASE)
2679         {
2680           parse_delay_case_action (label);
2681           goto bracketed_action;
2682         }
2683       require (DELAY);
2684       PUSH_ACTION;
2685       expr = parse_primval ();
2686       rhs = check_token (PRIORITY) ? parse_expression () : NULL_TREE;
2687       if (! ignoring)
2688         build_delay_action (expr, rhs);
2689       goto handler_action;
2690     case DO:
2691       parse_do_action (label);
2692       return 1;
2693     case EXIT:
2694       require (EXIT);
2695       expr = parse_name_string ();
2696       PUSH_ACTION;
2697       lookup_and_handle_exit (expr);
2698       goto no_handler_action;
2699     case GOTO:
2700       require (GOTO);
2701       expr = parse_name_string ();
2702       PUSH_ACTION;
2703       lookup_and_expand_goto (expr);
2704       goto no_handler_action;
2705     case IF:
2706       parse_if_action (label);
2707       goto bracketed_action;
2708     case RECEIVE:
2709       if (PEEK_TOKEN1 () != CASE)
2710         return 0;
2711       parse_receive_case_action (label);
2712       goto bracketed_action;
2713     case RESULT:
2714       require (RESULT);
2715       PUSH_ACTION;
2716       expr = parse_untyped_expr ();
2717       if (! ignoring)
2718         chill_expand_result (expr, 1);
2719       goto handler_action;
2720     case RETURN:
2721       require (RETURN);
2722       PUSH_ACTION;
2723       expr = parse_opt_untyped_expr ();
2724       if (! ignoring)
2725         {
2726           /* Do this as RESULT expr and RETURN to get exceptions */
2727           chill_expand_result (expr, 0);
2728           expand_goto_except_cleanup (proc_action_level);
2729           chill_expand_return (NULL_TREE, 0);
2730         }
2731       if (expr)
2732         goto handler_action;
2733       else
2734         goto no_handler_action;
2735     case SC:
2736       require (SC);
2737       return 1;
2738     case SEND:
2739       parse_send_action ();
2740       goto handler_action;
2741     case START:
2742       parse_start_action ();
2743       goto handler_action;
2744     case STOP:
2745       require (STOP);
2746       PUSH_ACTION;
2747       if (! ignoring)
2748         { tree func = lookup_name (get_identifier ("__stop_process"));
2749           tree result = build_chill_function_call (func, NULL_TREE);
2750           expand_expr_stmt (result);
2751         }
2752       goto no_handler_action;
2753     case CALL:
2754       require (CALL);
2755       /* Fall through to here ... */
2756     case EXPR:
2757     case LPRN:
2758     case NAME:
2759       /* This handles calls and assignments. */
2760       PUSH_ACTION;
2761       expr = parse_primval ();
2762       switch (PEEK_TOKEN ())
2763         {
2764         case END:
2765           parse_semi_colon ();  /* Emits error message. */
2766         case ON:
2767         case SC:
2768           if (!ignoring && TREE_CODE (expr) != ERROR_MARK)
2769             {
2770               if (TREE_CODE (expr) != CALL_EXPR
2771                   && TREE_TYPE (expr) != void_type_node
2772                   && ! TREE_SIDE_EFFECTS (expr))
2773                 {
2774                   if (TREE_CODE (expr) == FUNCTION_DECL)
2775                     error ("missing parenthesis for procedure call");
2776                   else
2777                     error ("expression is not an action");
2778                   expr = error_mark_node;
2779                 }
2780               else
2781                 expand_expr_stmt (expr);
2782             }
2783           goto handler_action;
2784         default:
2785           loclist
2786             = ignoring ? NULL_TREE : build_tree_list (NULL_TREE, expr);
2787           while (PEEK_TOKEN () == COMMA)
2788             {
2789               FORWARD_TOKEN ();
2790               expr = parse_primval ();
2791               if (!ignoring && TREE_CODE (expr) != ERROR_MARK)
2792                 loclist = tree_cons (NULL_TREE, expr, loclist);
2793             }
2794         }
2795       switch (PEEK_TOKEN ())
2796         {
2797         case OR:        op = BIT_IOR_EXPR;      break;
2798         case XOR:       op = BIT_XOR_EXPR;      break;
2799         case ORIF:      op = TRUTH_ORIF_EXPR;   break;
2800         case AND:       op = BIT_AND_EXPR;      break;
2801         case ANDIF:     op = TRUTH_ANDIF_EXPR;  break;
2802         case PLUS:      op = PLUS_EXPR;         break;
2803         case SUB:       op = MINUS_EXPR;        break;
2804         case CONCAT:    op = CONCAT_EXPR;       break;
2805         case MUL:       op = MULT_EXPR;         break;
2806         case DIV:       op = TRUNC_DIV_EXPR;    break;
2807         case MOD:       op = FLOOR_MOD_EXPR;    break;
2808         case REM:       op = TRUNC_MOD_EXPR;    break;
2809
2810         default:
2811           error ("syntax error in action");
2812         case SC:  case ON:
2813         case ASGN:      op = NOP_EXPR;          break;
2814           ;
2815         }
2816
2817       /* Looks like it was an assignment action. */
2818       FORWARD_TOKEN ();
2819       if (op != NOP_EXPR)
2820         expect (ASGN, "expected ':=' here");
2821       rhs = parse_untyped_expr ();
2822       if (!ignoring)
2823         expand_assignment_action (loclist, op, rhs);
2824       goto handler_action;
2825
2826     default:
2827       return 0;
2828     }
2829
2830  bracketed_action:
2831   /* We've parsed a bracketed action. */
2832   parse_opt_handler ();
2833   parse_opt_end_label_semi_colon (label);
2834   return 1;
2835
2836  no_handler_action:
2837   if (parse_opt_handler () != NULL_TREE && pass == 1)
2838     error ("no handler is permitted on this action.");
2839   parse_semi_colon ();
2840   return 1;
2841
2842  handler_action:
2843   parse_opt_handler ();
2844   parse_semi_colon ();
2845   return 1;
2846 }
2847
2848 static void
2849 parse_body ()
2850 {
2851  again:
2852   while (parse_definition (0)) ;
2853
2854   while (parse_action ()) ;
2855
2856   if (parse_definition (0))
2857     {
2858       if (pass == 1)
2859         pedwarn ("definition follows action");
2860       goto again;
2861     }
2862 }
2863
2864 static tree
2865 parse_opt_untyped_expr ()
2866 {
2867   switch (PEEK_TOKEN ())
2868     {
2869     case ON:
2870     case END:
2871     case SC:
2872     case COMMA:
2873     case COLON:
2874     case RPRN:
2875       return NULL_TREE;
2876     default:
2877       return parse_untyped_expr ();
2878     }
2879 }
2880
2881 static tree
2882 parse_call (function)
2883      tree function;
2884 {
2885   tree arg1, arg2, arg_list = NULL_TREE;
2886   enum terminal tok;
2887   require (LPRN);
2888   arg1 = parse_opt_untyped_expr ();
2889   if (arg1 != NULL_TREE)
2890     {
2891       tok = PEEK_TOKEN ();
2892       if (tok == UP || tok == COLON)
2893         {
2894           FORWARD_TOKEN ();
2895 #if 0
2896           /* check that arg1 isn't untyped (or mode);*/
2897 #endif
2898           arg2 = parse_expression ();
2899           expect (RPRN, "expected ')' to terminate slice");
2900           if (ignoring)
2901             return integer_zero_node;
2902           else if (tok == UP)
2903             return build_chill_slice_with_length (function, arg1, arg2);
2904           else
2905             return build_chill_slice_with_range (function, arg1, arg2);
2906         }
2907       if (!ignoring)
2908         arg_list = build_tree_list (NULL_TREE, arg1);
2909       while (check_token (COMMA))
2910         {
2911           arg2 = parse_untyped_expr ();
2912           if (!ignoring)
2913             arg_list = tree_cons (NULL_TREE, arg2, arg_list);
2914         }
2915     }
2916
2917   expect (RPRN, "expected ')' here");
2918   return ignoring ? function
2919     : build_generalized_call (function, nreverse (arg_list));
2920 }
2921
2922 /* Matches:  <field name list>
2923    Returns:  A list of IDENTIFIER_NODEs (or NULL_TREE if ignoring),
2924    in reverse order. */
2925
2926 static tree
2927 parse_tuple_fieldname_list ()
2928 {
2929   tree list = NULL_TREE;
2930   do
2931     {
2932       tree name;
2933       if (!check_token (DOT))
2934         {
2935           error ("bad tuple field name list");
2936           return NULL_TREE;
2937         }
2938       name = parse_simple_name_string ();
2939       list = ignoring ? NULL_TREE : tree_cons (NULL_TREE, name, list);
2940     }  while (check_token (COMMA));
2941   return list;
2942 }
2943
2944 /* Returns one or nore TREE_LIST nodes, in reverse order. */
2945
2946 static tree
2947 parse_tuple_element ()
2948 {
2949   /* The tupleelement chain is built in reverse order,
2950      and put in forward order when the list is used.  */
2951   tree value, label;
2952   if (PEEK_TOKEN () == DOT)
2953     {
2954       /* Parse a labelled structure tuple. */
2955       tree list = parse_tuple_fieldname_list (), field;
2956       expect (COLON, "missing ':' in tuple");
2957       value = parse_untyped_expr ();
2958       if (ignoring)
2959         return NULL_TREE;
2960       /* FIXME:  Should use save_expr(value), but that
2961          confuses nested calls to digest_init! */
2962       /* Re-use the list of field names as a list of name-value pairs. */
2963       for (field = list; field != NULL_TREE; field = TREE_CHAIN (field))
2964         { tree field_name = TREE_VALUE (field);
2965           TREE_PURPOSE (field) = field_name;
2966           TREE_VALUE (field) = value;
2967           TUPLE_NAMED_FIELD (field) = 1;
2968         }
2969       return list;
2970     }
2971
2972   label = parse_case_label_list (NULL_TREE, 1);
2973   if (label)
2974     {
2975       expect (COLON, "missing ':' in tuple");
2976       value = parse_untyped_expr ();
2977       if (ignoring || label == NULL_TREE)
2978         return NULL_TREE;
2979       if (TREE_CODE (label) != TREE_LIST)
2980         {
2981           error ("invalid syntax for label in tuple");
2982           return NULL_TREE;
2983         }
2984       else
2985         {
2986           /* FIXME:  Should use save_expr(value), but that
2987              confuses nested calls to digest_init! */
2988           tree link = label;
2989           for (; link != NULL_TREE; link = TREE_CHAIN (link))
2990             { tree index = TREE_VALUE (link);
2991               if (pass == 1 && TREE_CODE (index) != TREE_LIST)
2992                 index = build1 (PAREN_EXPR, NULL_TREE, index);
2993               TREE_VALUE (link) = value;
2994               TREE_PURPOSE (link) = index;
2995             }
2996           return nreverse (label);
2997         }
2998     }
2999
3000   value = parse_untyped_expr ();
3001   if (check_token (COLON))
3002     {
3003       /* A powerset range [or possibly a labeled Array?] */
3004       tree value2 = parse_untyped_expr ();
3005       return ignoring ? NULL_TREE : build_tree_list (value, value2);
3006     }
3007   return ignoring ? NULL_TREE : build_tree_list (NULL_TREE, value);
3008 }
3009
3010 /* Matches:  a COMMA-separated list of tuple elements.
3011    Returns a list (of TREE_LIST nodes). */
3012 static tree
3013 parse_opt_element_list ()
3014 {
3015   tree list = NULL_TREE;
3016   if (PEEK_TOKEN () == RPC)
3017     return NULL_TREE;
3018   for (;;)
3019     {
3020       tree element = parse_tuple_element ();
3021       list = chainon (element, list); /* Built in reverse order */
3022       if (PEEK_TOKEN () == RPC)
3023         break;
3024       if (!check_token (COMMA))
3025         {
3026           error ("bad syntax in tuple");
3027           return NULL_TREE;
3028         }
3029     }
3030   return nreverse (list);
3031 }
3032
3033 /* Parses: '[' elements ']'
3034    If modename is non-NULL it prefixed the tuple.  */
3035
3036 static tree
3037 parse_tuple (modename)
3038      tree modename;
3039 {
3040   tree list;
3041   require (LPC);
3042   list = parse_opt_element_list ();
3043   expect (RPC, "missing ']' after tuple");
3044   if (ignoring)
3045     return integer_zero_node;
3046   list =  build_nt (CONSTRUCTOR, NULL_TREE, list);
3047   if (modename == NULL_TREE)
3048     return list;
3049   else if (pass == 1)
3050     TREE_TYPE (list) = modename;
3051   else if (TREE_CODE (modename) != TYPE_DECL)
3052     {
3053       error ("non-mode name before tuple");
3054       return error_mark_node;
3055     }
3056   else
3057     list = chill_expand_tuple (TREE_TYPE (modename), list);
3058   return list;
3059 }
3060
3061 static tree
3062 parse_primval ()
3063 {
3064   tree val;
3065   switch (PEEK_TOKEN ())
3066     {
3067     case NUMBER:
3068     case FLOATING:
3069     case STRING:
3070     case SINGLECHAR:
3071     case BITSTRING:
3072     case CONST:
3073     case EXPR:
3074       val = PEEK_TREE();
3075       FORWARD_TOKEN ();
3076       break;
3077     case THIS:
3078       val = build_chill_function_call (PEEK_TREE (), NULL_TREE);
3079       FORWARD_TOKEN ();
3080       break;
3081     case LPRN:
3082       FORWARD_TOKEN ();
3083       val = parse_expression ();
3084       expect (RPRN, "missing right parenthesis");
3085       if (pass == 1 && ! ignoring)
3086         val = build1 (PAREN_EXPR, NULL_TREE, val);
3087       break;
3088     case LPC:
3089       val = parse_tuple (NULL_TREE);
3090       break;
3091     case NAME:
3092       val = parse_name ();
3093       if (PEEK_TOKEN() == LPC)
3094         val = parse_tuple (val); /* Matched:  <mode_name> <tuple> */
3095       break;
3096     default:
3097       if (!ignoring)
3098         error ("invalid expression/location syntax");
3099       val = error_mark_node;
3100     }
3101   for (;;)
3102     {
3103       tree name, args;
3104       switch (PEEK_TOKEN ())
3105         {
3106         case DOT:
3107           FORWARD_TOKEN ();
3108           name = parse_simple_name_string ();
3109           val = ignoring ? val : build_chill_component_ref (val, name);
3110           continue;
3111         case ARROW:
3112           FORWARD_TOKEN ();
3113           name = parse_opt_name_string (0);
3114           val = ignoring ? val : build_chill_indirect_ref (val, name, 1);
3115           continue;
3116         case LPRN:
3117           /* The SEND buffer action syntax is ambiguous, at least when
3118              parsed left-to-right.  In the example 'SEND foo(v) ...' the
3119              phrase 'foo(v)' could be a buffer location procedure call
3120              (which then must be followed by the value to send).
3121              On the other hand, if 'foo' is a buffer, stop parsing
3122              after 'foo', and let parse_send_action pick up '(v) as
3123              the value ot send.
3124
3125              We handle the ambiguity for SEND signal action differently,
3126              since we allow (as an extension) a signal to be used as
3127              a "function" (see build_generalized_call). */
3128           if (TREE_TYPE (val) != NULL_TREE
3129               && CH_IS_BUFFER_MODE (TREE_TYPE (val)))
3130             return val;
3131           val = parse_call (val);
3132           continue;
3133         case STRING:
3134         case BITSTRING:
3135         case SINGLECHAR:
3136         case NAME:
3137           /* Handle string repetition. (See comment in parse_operand5.) */
3138           args = parse_primval ();
3139           val = ignoring ? val : build_generalized_call (val, args);
3140           continue;
3141         default:
3142           break;
3143         }
3144       break;
3145     }
3146   return val;
3147 }
3148
3149 static tree
3150 parse_operand6 ()
3151 {
3152   if (check_token (RECEIVE))
3153     {
3154       tree location ATTRIBUTE_UNUSED = parse_primval ();
3155       sorry ("RECEIVE expression");
3156       return integer_one_node;
3157     }
3158   else if (check_token (ARROW))
3159     {
3160       tree location = parse_primval ();
3161       return ignoring ? location : build_chill_arrow_expr (location, 0);
3162     }
3163   else
3164     return parse_primval();
3165 }
3166
3167 static tree
3168 parse_operand5()
3169 {
3170   enum tree_code op;
3171   /* We are supposed to be looking for a <string repetition operator>,
3172      but in general we can't distinguish that from a parenthesized
3173      expression.  This is especially difficult if we allow the
3174      string operand to be a constant expression (as requested by
3175      some users), and not just a string literal.
3176      Consider:  LPRN expr RPRN LPRN expr RPRN
3177      Is that a function call or string repetition?
3178      Instead, we handle string repetition in parse_primval,
3179      and build_generalized_call. */
3180   tree rarg;
3181   switch (PEEK_TOKEN())
3182     {
3183     case NOT:  op = BIT_NOT_EXPR; break;
3184     case SUB:  op = NEGATE_EXPR; break;
3185     default:
3186       op = NOP_EXPR;
3187     }
3188     if (op != NOP_EXPR)
3189       FORWARD_TOKEN();
3190     rarg = parse_operand6();
3191     return (op == NOP_EXPR || ignoring) ? rarg
3192       : build_chill_unary_op (op, rarg);
3193 }
3194
3195 static tree
3196 parse_operand4 ()
3197 {
3198   tree larg = parse_operand5(), rarg;
3199   enum tree_code op;
3200   for (;;)
3201     {
3202       switch (PEEK_TOKEN())
3203         {
3204         case MUL:  op = MULT_EXPR; break;
3205         case DIV:  op = TRUNC_DIV_EXPR; break;
3206         case MOD:  op = FLOOR_MOD_EXPR; break;
3207         case REM:  op = TRUNC_MOD_EXPR; break;
3208         default:
3209         return larg;
3210         }
3211       FORWARD_TOKEN();
3212       rarg = parse_operand5();
3213       if (!ignoring)
3214         larg = build_chill_binary_op (op, larg, rarg);
3215     }
3216 }
3217
3218 static tree
3219 parse_operand3 ()
3220 {
3221   tree larg = parse_operand4 (), rarg;
3222   enum tree_code op;
3223   for (;;)
3224     {
3225       switch (PEEK_TOKEN())
3226         {
3227         case PLUS:   op = PLUS_EXPR; break;
3228         case SUB:    op = MINUS_EXPR; break;
3229         case CONCAT: op = CONCAT_EXPR; break;
3230         default:
3231         return larg;
3232         }
3233       FORWARD_TOKEN();
3234       rarg = parse_operand4();
3235       if (!ignoring)
3236         larg = build_chill_binary_op (op, larg, rarg);
3237     }
3238 }
3239
3240 static tree
3241 parse_operand2 ()
3242 {
3243   tree larg = parse_operand3 (), rarg;
3244   enum tree_code op;
3245   for (;;)
3246     {
3247       if (check_token (IN))
3248         {
3249           rarg = parse_operand3();
3250           if (! ignoring)
3251             larg = build_chill_binary_op (SET_IN_EXPR, larg, rarg);
3252         }
3253       else
3254         {
3255           switch (PEEK_TOKEN())
3256             {
3257             case GT:  op = GT_EXPR; break;
3258             case GTE: op = GE_EXPR; break;
3259             case LT:  op = LT_EXPR; break;
3260             case LTE: op = LE_EXPR; break;
3261             case EQL: op = EQ_EXPR; break;
3262             case NE:  op = NE_EXPR; break;
3263             default:
3264               return larg;
3265             }
3266           FORWARD_TOKEN();
3267           rarg = parse_operand3();
3268           if (!ignoring)
3269             larg = build_compare_expr (op, larg, rarg);
3270         }
3271     }
3272 }
3273
3274 static tree
3275 parse_operand1 ()
3276 {
3277   tree larg = parse_operand2 (), rarg;
3278   enum tree_code op;
3279   for (;;)
3280     {
3281       switch (PEEK_TOKEN())
3282         {
3283         case AND:   op = BIT_AND_EXPR; break;
3284         case ANDIF: op = TRUTH_ANDIF_EXPR; break;
3285         default:
3286           return larg;
3287         }
3288       FORWARD_TOKEN();
3289       rarg = parse_operand2();
3290       if (!ignoring)
3291         larg = build_chill_binary_op (op, larg, rarg);
3292     }
3293 }
3294
3295 static tree
3296 parse_operand0 ()
3297 {
3298   tree larg = parse_operand1(), rarg;
3299   enum tree_code op;
3300   for (;;)
3301     {
3302       switch (PEEK_TOKEN())
3303         {
3304         case OR:  op = BIT_IOR_EXPR; break;
3305         case XOR:  op = BIT_XOR_EXPR; break;
3306         case ORIF:  op = TRUTH_ORIF_EXPR; break;
3307         default:
3308           return larg;
3309         }
3310       FORWARD_TOKEN();
3311       rarg = parse_operand1();
3312       if (!ignoring)
3313         larg = build_chill_binary_op (op, larg, rarg);
3314     }
3315 }
3316
3317 static tree
3318 parse_expression ()
3319 {
3320     return parse_operand0 ();
3321 }
3322
3323 static tree
3324 parse_case_expression ()
3325 {
3326   tree selector_list;
3327   tree else_expr;
3328   tree case_expr;
3329   tree case_alt_list = NULL_TREE;
3330
3331   require (CASE);
3332   selector_list = parse_expr_list ();
3333   selector_list = nreverse (selector_list);
3334
3335   expect (OF, "missing 'OF'");
3336   while (PEEK_TOKEN () == LPRN)
3337     {
3338       tree label_spec = parse_case_label_specification (selector_list);
3339       tree sub_expr;
3340       expect (COLON, "missing ':' in value case alternative");
3341       sub_expr = parse_expression ();
3342       expect (SC, "missing ';'");
3343       if (! ignoring)
3344         case_alt_list = tree_cons (label_spec, sub_expr, case_alt_list);
3345     }
3346   if (check_token (ELSE))
3347     {
3348       else_expr = parse_expression ();
3349       if (check_token (SC) && pass == 1)
3350         warning("there should not be a ';' here");
3351     }
3352   else
3353     else_expr = NULL_TREE;
3354   expect (ESAC, "missing 'ESAC' in 'CASE' expression");
3355
3356   if (ignoring)
3357     return integer_zero_node;
3358
3359   /* If this is a multi dimension case, then transform it into an COND_EXPR
3360      here. This must be done before store_expr is called since it has some
3361      special handling for COND_EXPR expressions. */
3362   if (TREE_CHAIN (selector_list) != NULL_TREE)
3363     {
3364       case_alt_list = nreverse (case_alt_list);
3365       compute_else_ranges (selector_list, case_alt_list);
3366       case_expr =
3367         build_chill_multi_dimension_case_expr (selector_list, case_alt_list, else_expr);
3368     }
3369   else
3370     case_expr = build_chill_case_expr (selector_list, case_alt_list, else_expr);
3371
3372   return case_expr;
3373 }
3374
3375 static tree
3376 parse_then_alternative ()
3377 {
3378   expect (THEN, "missing 'THEN' in 'IF' expression");
3379   return parse_expression ();
3380 }
3381
3382 static tree
3383 parse_else_alternative ()
3384 {
3385   if (check_token (ELSIF))
3386     return parse_if_expression_body ();
3387   else if (check_token (ELSE))
3388     return parse_expression ();
3389   error ("missing ELSE/ELSIF in IF expression");
3390   return error_mark_node;
3391 }
3392
3393 /* Matches: <boolean expression> <then alternative> <else alternative> */
3394
3395 static tree
3396 parse_if_expression_body ()
3397 {
3398   tree bool_expr, then_expr, else_expr;
3399   bool_expr = parse_expression ();
3400   then_expr = parse_then_alternative ();
3401   else_expr = parse_else_alternative ();
3402   if (ignoring)
3403     return integer_zero_node;
3404   else
3405     return build_nt (COND_EXPR, bool_expr, then_expr, else_expr);
3406 }
3407
3408 static tree
3409 parse_if_expression ()
3410 {
3411   tree expr;
3412   require (IF);
3413   expr = parse_if_expression_body ();
3414   expect (FI, "missing 'FI' at end of conditional expression");
3415   return expr;
3416 }
3417
3418 /* An <untyped_expr> is a superset of <expr>.  It also includes
3419    <conditional expressions> and untyped <tuples>, whose types
3420    are not given by their constituents.  Hence, these are only
3421    allowed in certain contexts that expect a certain type.
3422    You should call convert() to fix up the <untyped_expr>. */
3423
3424 static tree
3425 parse_untyped_expr ()
3426 {
3427   tree val;
3428   switch (PEEK_TOKEN())
3429     {
3430     case IF:
3431       return parse_if_expression ();
3432     case CASE:
3433       return parse_case_expression ();
3434     case LPRN:
3435       switch (PEEK_TOKEN1())
3436         {
3437         case IF:
3438         case CASE:
3439           if (pass == 1)
3440             pedwarn ("conditional expression not allowed inside parentheses");
3441           goto skip_lprn;
3442         case LPC:
3443           if (pass == 1)
3444             pedwarn ("mode-less tuple not allowed inside parentheses");
3445         skip_lprn:
3446           FORWARD_TOKEN ();
3447           val = parse_untyped_expr ();
3448           expect (RPRN, "missing ')'");
3449           return val;
3450         default: ;
3451           /* fall through */
3452         }
3453     default:
3454       return parse_operand0 ();
3455     }
3456 }
3457
3458 /* Matches:  <index mode> */
3459
3460 static tree
3461 parse_index_mode ()
3462 {
3463   /* This is another one that is nasty to parse!
3464    Let's feel our way ahead ... */
3465   tree lower, upper;
3466   if (PEEK_TOKEN () == NAME)
3467     {
3468       tree name = parse_name ();
3469       switch (PEEK_TOKEN ())
3470         {
3471         case COMMA:
3472         case RPRN:
3473         case SC: /* An error */
3474           /* This can only (legally) be a discrete mode name. */
3475           return name;
3476         case LPRN:
3477           /* This could be named discrete range,
3478              a cast, or some other expression (maybe). */
3479           require (LPRN);
3480           lower = parse_expression ();
3481           if (check_token (COLON))
3482             {
3483               upper = parse_expression ();
3484               expect (RPRN, "missing ')'");
3485               /* Matched: <mode_name> '(' <expr> ':' <expr> ')' */
3486               if (ignoring)
3487                 return NULL_TREE;
3488               else
3489                 return build_chill_range_type (name, lower, upper);
3490             }
3491           /* Looks like a cast or procedure call or something.
3492              Backup, and try again. */
3493           pushback_token (EXPR, lower);
3494           pushback_token (LPRN, NULL_TREE);
3495           lower = parse_call (name);
3496           goto parse_literal_range_colon;
3497         default:
3498           /* This has to be the start of an expression. */
3499           pushback_token (EXPR, name);
3500           goto parse_literal_range;
3501         }
3502     }
3503   /* It's not a name.  But it could still be a discrete mode. */
3504   lower = parse_opt_mode ();
3505   if (lower)
3506     return lower;
3507  parse_literal_range:
3508   /* Nope, it's a discrete literal range. */
3509   lower = parse_expression ();
3510  parse_literal_range_colon:
3511   expect (COLON, "expected ':' here");
3512
3513   upper = parse_expression ();
3514   return ignoring ? NULL_TREE
3515     : build_chill_range_type (NULL_TREE, lower, upper);
3516 }
3517
3518 static tree
3519 parse_set_mode ()
3520 {
3521   int  set_name_cnt = 0;          /* count of named set elements */
3522   int  set_is_numbered = 0;     /* TRUE if set elements have explicit values */
3523   int  set_is_not_numbered = 0;
3524   tree list = NULL_TREE;
3525   tree mode = ignoring ? void_type_node : start_enum (NULL_TREE);
3526   require (SET);
3527   expect (LPRN, "missing left parenthesis after SET");
3528   for (;;)
3529     {
3530       tree name, value = NULL_TREE;
3531       if (check_token (MUL))
3532         name = NULL_TREE;
3533       else
3534         {
3535           name = parse_defining_occurrence ();
3536           if (check_token (EQL))
3537             {
3538               value = parse_expression ();
3539               set_is_numbered = 1;
3540             }
3541           else
3542             set_is_not_numbered = 1;
3543           set_name_cnt++;
3544         }
3545       name = build_enumerator (name, value);
3546       if (pass == 1)
3547         list = chainon (name, list);
3548       if (! check_token (COMMA))
3549         break;
3550     }
3551   expect (RPRN, "missing right parenthesis after SET");
3552   if (!ignoring)
3553     {
3554       if (set_is_numbered && set_is_not_numbered)
3555         /* Z.200 doesn't allow mixed numbered and unnumbered set elements,
3556            but we can do it. Print a warning */
3557         pedwarn ("mixed numbered and unnumbered set elements is not standard");
3558       mode = finish_enum (mode, list);
3559       if (set_name_cnt == 0)
3560         error ("SET mode must define at least one named value");
3561       CH_ENUM_IS_NUMBERED(mode) = set_is_numbered ? 1 : 0;
3562     }
3563   return mode;
3564 }
3565
3566 /* parse layout POS:
3567    returns a tree with following layout
3568
3569                 treelist
3570        pupose=treelist  value=NULL_TREE (to indicate POS)
3571      pupose=word  value=treelist | NULL_TREE
3572            pupose=startbit  value=treelist | NULL_TREE
3573                       purpose=                      value=
3574                integer_zero | integer_one    length | endbit
3575 */
3576 static tree
3577 parse_pos ()
3578 {
3579   tree word;
3580   tree startbit = NULL_TREE, endbit = NULL_TREE;
3581   tree what = NULL_TREE;
3582
3583   require (LPRN);
3584   word = parse_untyped_expr ();
3585   if (check_token (COMMA))
3586     {
3587       startbit = parse_untyped_expr ();
3588       if (check_token (COMMA))
3589         {
3590           what = integer_zero_node;
3591           endbit = parse_untyped_expr ();
3592         }
3593       else if (check_token (COLON))
3594         {
3595           what = integer_one_node;
3596           endbit = parse_untyped_expr ();
3597         }
3598     }
3599   require (RPRN);
3600
3601   /* build the tree as described above */
3602   if (what != NULL_TREE)
3603     what = tree_cons (what, endbit, NULL_TREE);
3604   if (startbit != NULL_TREE)
3605     startbit = tree_cons (startbit, what, NULL_TREE);
3606   endbit = tree_cons (word, startbit, NULL_TREE);
3607   return tree_cons (endbit, NULL_TREE, NULL_TREE);
3608 }
3609
3610 /* parse layout STEP
3611    returns a tree with the following layout
3612
3613                 treelist
3614      pupose=NULL_TREE value=treelist (to indicate STEP)
3615          pupose=POS(see baove)  value=stepsize | NULL_TREE
3616 */
3617 static tree
3618 parse_step ()
3619 {
3620   tree pos;
3621   tree stepsize = NULL_TREE;
3622
3623   require (LPRN);
3624   require (POS);
3625   pos = parse_pos ();
3626   if (check_token (COMMA))
3627     stepsize = parse_untyped_expr ();
3628   require (RPRN);
3629   TREE_VALUE (pos) = stepsize;
3630   return tree_cons (NULL_TREE, pos, NULL_TREE);
3631 }
3632
3633 /* returns layout for fields or array elements.
3634    NULL_TREE            no layout specified
3635    integer_one_node     PACK specified
3636    integer_zero_node    NOPACK specified
3637    tree_list PURPOSE    POS
3638    tree_list VALUE      STEP
3639 */
3640 static tree
3641 parse_opt_layout (in)
3642      int in;     /* 0 ... parse structure, 1 ... parse array */
3643 {
3644   tree val = NULL_TREE;
3645
3646   if (check_token (PACK))
3647     {
3648       return integer_one_node;
3649     }
3650   else if (check_token (NOPACK))
3651     {
3652       return integer_zero_node;
3653     }
3654   else if (check_token (POS))
3655     {
3656       val = parse_pos ();
3657       if (in == 1 && pass == 1)
3658         {
3659           error ("POS not allowed for ARRAY");
3660           val = NULL_TREE;
3661         }
3662       return val;
3663     }
3664   else if (check_token (STEP))
3665     {
3666       val = parse_step ();
3667       if (in == 0 && pass == 1)
3668         {
3669           error ("STEP not allowed in field definition");
3670           val = NULL_TREE;
3671         }
3672       return val;
3673     }
3674   else
3675     return NULL_TREE;
3676 }
3677
3678 static tree
3679 parse_field_name_list ()
3680 {
3681   tree chain = NULL_TREE;
3682   tree name = parse_defining_occurrence ();
3683   if (name == NULL_TREE)
3684     {
3685       error("missing field name");
3686       return NULL_TREE;
3687     }
3688   chain = build_tree_list (NULL_TREE, name);
3689   while (check_token (COMMA))
3690     {
3691       name = parse_defining_occurrence ();
3692       if (name == NULL)
3693         {
3694           error ("bad field name following ','");
3695           break;
3696         }
3697       if (! ignoring)
3698         chain = tree_cons (NULL_TREE, name, chain);
3699     }
3700   return chain;
3701 }
3702
3703 /* Matches: <fixed field> or <variant field>, i.e.:
3704    <field name defining occurrence list> <mode> [ <field layout> ].
3705    Returns:  A chain of FIELD_DECLs.
3706    NULL_TREE is returned if ignoring is true or an error is seen. */
3707
3708 static tree
3709 parse_fixed_field ()
3710 {
3711   tree field_names = parse_field_name_list ();
3712   tree mode = parse_mode ();
3713   tree layout = parse_opt_layout (0);
3714   return ignoring ? NULL_TREE
3715     : grok_chill_fixedfields (field_names, mode, layout);
3716 }
3717
3718
3719 /* Matches: [ <variant field> { "," <variant field> }* ]
3720    Returns:  A chain of FIELD_DECLs.
3721    NULL_TREE is returned if ignoring is true or an error is seen. */
3722
3723 static tree
3724 parse_variant_field_list ()
3725 {
3726   tree fields = NULL_TREE;
3727   if (PEEK_TOKEN () != NAME)
3728     return NULL_TREE;
3729   for (;;)
3730     {
3731       fields = chainon (fields, parse_fixed_field ());
3732       if (PEEK_TOKEN () != COMMA || PEEK_TOKEN1 () != NAME)
3733         break;
3734       require (COMMA);
3735     }
3736   return fields;
3737 }
3738
3739 /* Matches: <variant alternative>
3740    Returns a TREE_LIST node, whose TREE_PURPOSE (if non-NULL) is the label,
3741    and whose TREE_VALUE is the list of FIELD_DECLs. */
3742
3743 static tree
3744 parse_variant_alternative ()
3745 {
3746   tree labels;
3747
3748   if (PEEK_TOKEN () == LPRN)
3749     labels = parse_case_label_specification (NULL_TREE);
3750   else
3751     labels = NULL_TREE;
3752   if (! check_token (COLON))
3753     {
3754       error ("expected ':' in structure variant alternative");
3755       return NULL_TREE;
3756     }
3757
3758   /* We now read a list a variant fields, until we come to the end
3759      of the variant alternative.  But since both variant fields
3760      *and* variant alternatives are separated by COMMAs,
3761      we will have to look ahead to distinguish the start of a variant
3762      field from the start of a new variant alternative.
3763      We use the fact that a variant alternative must start with
3764      either a LPRN or a COLON, while a variant field must start with a NAME.
3765      This look-ahead is handled by parse_simple_fields. */
3766   return build_tree_list (labels, parse_variant_field_list ());
3767 }
3768
3769 /* Parse <field> (which is <fixed field> or <alternative field>).
3770    Returns:  A chain of FIELD_DECLs (or NULL_TREE on error or if ignoring). */
3771
3772 static tree
3773 parse_field ()
3774 {
3775   if (check_token (CASE))
3776     {
3777       tree tag_list = NULL_TREE, variants, opt_variant_else;
3778       if (PEEK_TOKEN () == NAME)
3779         {
3780           tag_list = nreverse (parse_field_name_list ());
3781           if (pass == 1)
3782             tag_list = lookup_tag_fields (tag_list, current_fieldlist);
3783         }
3784       expect (OF, "missing 'OF' in alternative structure field");
3785
3786       variants = parse_variant_alternative ();
3787       while (check_token (COMMA))
3788         variants = chainon (parse_variant_alternative (), variants);
3789       variants = nreverse (variants);
3790
3791       if (check_token (ELSE))
3792         opt_variant_else = parse_variant_field_list ();
3793       else
3794         opt_variant_else = NULL_TREE;
3795       expect (ESAC, "missing 'ESAC' following alternative structure field");
3796       if (ignoring)
3797         return NULL_TREE;
3798       return grok_chill_variantdefs (tag_list, variants, opt_variant_else);
3799     }
3800   else if (PEEK_TOKEN () == NAME)
3801     return parse_fixed_field ();
3802   else
3803     {
3804       if (pass == 1)
3805         error ("missing field");
3806       return NULL_TREE;
3807     }
3808 }
3809
3810 static tree
3811 parse_structure_mode ()
3812 {
3813   tree save_fieldlist = current_fieldlist;
3814   tree fields;
3815   require (STRUCT);
3816   expect (LPRN, "expected '(' after STRUCT");
3817   current_fieldlist = fields = parse_field ();
3818   while (check_token (COMMA))
3819     fields = chainon (fields, parse_field ());
3820   expect (RPRN, "expected ')' after STRUCT");
3821   current_fieldlist = save_fieldlist;
3822   return ignoring ? void_type_node : build_chill_struct_type (fields);
3823 }
3824
3825 static tree
3826 parse_opt_queue_size ()
3827 {
3828   if (check_token (LPRN))
3829     {
3830       tree size = parse_expression ();
3831       expect (RPRN, "missing ')'");
3832       return size;
3833     }
3834   else
3835     return NULL_TREE;
3836 }
3837
3838 static tree
3839 parse_procedure_mode ()
3840 {
3841   tree param_types = NULL_TREE, result_spec, except_list, recursive;
3842   require (PROC);
3843   expect (LPRN, "missing '(' after PROC");
3844   if (! check_token (RPRN))
3845     {
3846       for (;;)
3847         {
3848           tree pmode = parse_mode ();
3849           tree paramattr = parse_param_attr ();
3850           if (! ignoring)
3851             {
3852               pmode = get_type_of (pmode);
3853               param_types = tree_cons (paramattr, pmode, param_types);
3854             }
3855           if (! check_token (COMMA))
3856             break;
3857         }
3858       expect (RPRN, "missing ')' after PROC");
3859     }
3860   result_spec = parse_opt_result_spec ();
3861   except_list = parse_opt_except ();
3862   recursive = parse_opt_recursive ();
3863   if (ignoring)
3864     return void_type_node;
3865   return build_chill_pointer_type (build_chill_function_type
3866                                    (result_spec, nreverse (param_types),
3867                                     except_list, recursive));
3868 }
3869
3870 /* Matches: <mode>
3871    A NAME will be assumed to be a <mode name>, and thus a <mode>.
3872    Returns NULL_TREE if no mode is seen.
3873    (If ignoring is true, the return value may be an arbitrary tree node,
3874    but will be non-NULL if something that could be a mode is seen.) */
3875
3876 static tree
3877 parse_opt_mode ()
3878 {
3879   switch (PEEK_TOKEN ())
3880     {
3881     case ACCESS:
3882       {
3883         tree index_mode, record_mode;
3884         int dynamic = 0;
3885         require (ACCESS);
3886         if (check_token (LPRN))
3887           {
3888             index_mode = parse_index_mode ();
3889             expect (RPRN, "mssing ')'");
3890           }
3891         else
3892           index_mode = NULL_TREE;
3893         record_mode = parse_opt_mode ();
3894         if (record_mode)
3895           dynamic = check_token (DYNAMIC);
3896         return ignoring ? void_type_node
3897                         : build_access_mode (index_mode, record_mode, dynamic);
3898       }
3899     case ARRAY:
3900       {
3901         tree index_list = NULL_TREE, base_mode;
3902         int varying;
3903         int num_index_modes = 0;
3904         int i;
3905         tree layouts = NULL_TREE;
3906         FORWARD_TOKEN ();
3907         expect (LPRN, "missing '(' after ARRAY");
3908         for (;;)
3909           {
3910             tree index = parse_index_mode ();
3911             num_index_modes++;
3912             if (!ignoring)
3913               index_list = tree_cons (NULL_TREE, index, index_list);
3914             if (! check_token (COMMA))
3915               break;
3916           }
3917         expect (RPRN, "missing ')' after ARRAY");
3918         varying = check_token (VARYING);
3919         base_mode = parse_mode ();
3920         /* Allow a layout specification for each index mode */
3921         for (i = 0; i < num_index_modes; ++i)
3922           {
3923           tree new_layout = parse_opt_layout (1);
3924           if (new_layout == NULL_TREE)
3925             break;
3926           if (!ignoring)
3927             layouts = tree_cons (NULL_TREE, new_layout, layouts);
3928           }
3929         if (ignoring)
3930           return base_mode;
3931         return build_chill_array_type (get_type_of (base_mode),
3932                                        index_list, varying, layouts);
3933       }
3934     case ASSOCIATION:
3935       require (ASSOCIATION);
3936       return association_type_node;
3937     case BIN:
3938       { tree length;
3939         FORWARD_TOKEN();
3940         expect (LPRN, "missing left parenthesis after BIN");
3941         length = parse_expression ();
3942         expect (RPRN, "missing right parenthesis after BIN");
3943         return ignoring ? void_type_node :  build_chill_bin_type (length);
3944       }
3945     case BOOLS:
3946       {
3947         tree length;
3948         FORWARD_TOKEN ();
3949         expect (LPRN, "missing '(' after BOOLS");
3950         length = parse_expression ();
3951         expect (RPRN, "missing ')' after BOOLS");
3952         if (check_token (VARYING))
3953           error ("VARYING bit-strings not implemented");
3954         return ignoring ? void_type_node : build_bitstring_type (length);
3955       }
3956     case BUFFER:
3957       {
3958         tree qsize, element_mode;
3959         require (BUFFER);
3960         qsize = parse_opt_queue_size ();
3961         element_mode = parse_mode ();
3962         return ignoring ? element_mode
3963           : build_buffer_type (element_mode, qsize);
3964       }
3965     case CHARS:
3966       {
3967         tree length;
3968         int varying;
3969         tree type;
3970         FORWARD_TOKEN ();
3971         expect (LPRN, "missing '(' after CHARS");
3972         length = parse_expression ();
3973         expect (RPRN, "missing ')' after CHARS");
3974         varying = check_token (VARYING);
3975         if (ignoring)
3976           return void_type_node;
3977         type = build_string_type (char_type_node, length);
3978         if (varying)
3979           type = build_varying_struct (type);
3980         return type;
3981       }
3982     case EVENT:
3983       {
3984         tree qsize;
3985         require (EVENT);
3986         qsize = parse_opt_queue_size ();
3987         return ignoring ? void_type_node : build_event_type (qsize);
3988       }
3989     case NAME:
3990       {
3991         tree mode = get_type_of (parse_name ());
3992         if (check_token (LPRN))
3993           {
3994             tree min_value = parse_expression ();
3995             if (check_token (COLON))
3996               {
3997                 tree max_value = parse_expression ();
3998                 expect (RPRN, "syntax error - expected ')'");
3999                 /* Matched: <mode_name> '(' <expr> ':' <expr> ')' */
4000                 if (ignoring)
4001                   return mode;
4002                 else
4003                   return build_chill_range_type (mode, min_value, max_value);
4004               }
4005             if (check_token (RPRN))
4006               {
4007                 int varying = check_token (VARYING);
4008                 if (! ignoring)
4009                   {
4010                     if (mode == char_type_node || varying)
4011                       {
4012                         if (mode != char_type_node
4013                             && mode != ridpointers[(int) RID_CHAR])
4014                           error ("strings must be composed of chars");
4015                         mode = build_string_type (char_type_node, min_value);
4016                         if (varying)
4017                           mode  = build_varying_struct (mode);
4018                       }
4019                     else
4020                       {
4021                         /* Parameterized mode,
4022                            or old-fashioned CHAR(N) string declaration.. */
4023                         tree pmode = make_node (LANG_TYPE);
4024                         TREE_TYPE (pmode) = mode;
4025                         TYPE_DOMAIN (pmode) = min_value;
4026                         mode = pmode;
4027                       }
4028                   }
4029               }
4030           }
4031         return mode;
4032       }
4033     case POWERSET:
4034       { tree mode;
4035         FORWARD_TOKEN ();
4036         mode = parse_mode ();
4037          if (ignoring || TREE_CODE (mode) == ERROR_MARK)
4038            return mode;
4039         return build_powerset_type (get_type_of (mode));
4040       }
4041     case PROC:
4042       return parse_procedure_mode ();
4043     case RANGE:
4044       { tree low, high;
4045         FORWARD_TOKEN();
4046         expect (LPRN, "missing left parenthesis after RANGE");
4047         low = parse_expression ();
4048         expect (COLON, "missing colon");
4049         high = parse_expression ();
4050         expect (RPRN, "missing right parenthesis after RANGE");
4051         return ignoring ? void_type_node
4052           :  build_chill_range_type (NULL_TREE, low, high);
4053       }
4054     case READ:
4055         FORWARD_TOKEN ();
4056         {
4057           tree mode2 = get_type_of (parse_mode ());
4058           if (ignoring || TREE_CODE (mode2) == ERROR_MARK)
4059             return mode2;
4060           if (mode2
4061               && TREE_CODE_CLASS (TREE_CODE (mode2)) == 'd'
4062               && CH_IS_BUFFER_MODE (mode2))
4063             {
4064               error ("BUFFER modes may not be readonly");
4065               return mode2;
4066             }
4067           if (mode2
4068               && TREE_CODE_CLASS (TREE_CODE (mode2)) == 'd'
4069               && CH_IS_EVENT_MODE (mode2))
4070             {
4071               error ("EVENT modes may not be readonly");
4072               return mode2;
4073             }
4074           return build_readonly_type (mode2);
4075
4076       }
4077     case REF:
4078       { tree mode;
4079         FORWARD_TOKEN ();
4080         mode = parse_mode ();
4081          if (ignoring)
4082            return mode;
4083         mode = get_type_of (mode);
4084         return (TREE_CODE (mode) == ERROR_MARK) ? mode
4085           : build_chill_pointer_type (mode);
4086       }
4087     case SET:
4088       return parse_set_mode ();
4089     case SIGNAL:
4090       if (pedantic)
4091         error ("SIGNAL is not a valid mode");
4092       return generic_signal_type_node;
4093     case STRUCT:
4094       return parse_structure_mode ();
4095     case TEXT:
4096       {
4097         tree length, index_mode;
4098         int dynamic;
4099         require (TEXT);
4100         expect (LPRN, "missing '('");
4101         length = parse_expression ();
4102         expect (RPRN, "missing ')'");
4103         /* FIXME:  This should actually look for an optional index_mode,
4104            but that is tricky to do. */
4105         index_mode = parse_opt_mode ();
4106         dynamic = check_token (DYNAMIC);
4107         return ignoring ? void_type_node
4108                         : build_text_mode (length, index_mode, dynamic);
4109       }
4110     case USAGE:
4111       require (USAGE);
4112       return usage_type_node;
4113     case WHERE:
4114       require (WHERE);
4115       return where_type_node;
4116     default:
4117       return NULL_TREE;
4118     }
4119 }
4120
4121 static tree
4122 parse_mode ()
4123 {
4124  tree mode = parse_opt_mode ();
4125  if (mode == NULL_TREE)
4126    {
4127      if (pass == 1)
4128        error ("syntax error - missing mode");
4129      mode = error_mark_node;
4130    }
4131  return mode;
4132 }
4133
4134 static void
4135 parse_program()
4136 {
4137   /* Initialize global variables for current pass. */
4138   int i;
4139   expand_exit_needed = 0;
4140   label = NULL_TREE;             /* for statement labels */
4141   current_module = NULL;
4142   current_function_decl = NULL_TREE;
4143   in_pseudo_module = 0;
4144
4145   for (i = 0; i <= MAX_LOOK_AHEAD; i++)
4146     terminal_buffer[i] = TOKEN_NOT_READ;
4147
4148 #if 0
4149   /* skip some junk */
4150   while (PEEK_TOKEN() == HEADEREL)
4151     FORWARD_TOKEN();
4152 #endif
4153
4154   start_outer_function ();
4155
4156   for (;;)
4157     {
4158       tree label = parse_optlabel ();
4159       if (PEEK_TOKEN() == MODULE || PEEK_TOKEN() == REGION)
4160         parse_modulion (label);
4161       else if (PEEK_TOKEN() == SPEC)
4162         parse_spec_module (label);
4163       else break;
4164     }
4165
4166   finish_outer_function ();
4167 }
4168
4169 void
4170 parse_pass_1_2()
4171 {
4172   parse_program();
4173   if (PEEK_TOKEN() != END_PASS_1)
4174     {
4175       error ("syntax error - expected a module or end of file");
4176       serious_errors++;
4177     }
4178   chill_finish_compile ();
4179   if (serious_errors)
4180     exit (FATAL_EXIT_CODE);
4181   switch_to_pass_2 ();
4182   ch_parse_init ();
4183   except_init_pass_2 ();
4184   ignoring = 0;
4185   parse_program();
4186   chill_finish_compile ();
4187 }
4188
4189 int yyparse ()
4190 {
4191   parse_pass_1_2 ();
4192   return 0;
4193 }
4194
4195 /*
4196  * We've had an error.  Move the compiler's state back to
4197  * the global binding level.  This prevents the loop in
4198  * compile_file in toplev.c from looping forever, since the
4199  * CHILL poplevel() has *no* effect on the value returned by
4200  * global_bindings_p().
4201  */
4202 void
4203 to_global_binding_level ()
4204 {
4205   while (! global_bindings_p ())
4206     current_function_decl = DECL_CONTEXT (current_function_decl);
4207   serious_errors++;
4208 }
4209
4210 #if 1
4211 int yydebug;
4212 /* Sets the value of the 'yydebug' variable to VALUE.
4213    This is a function so we don't have to have YYDEBUG defined
4214    in order to build the compiler.  */
4215 void
4216 set_yydebug (value)
4217      int value;
4218 {
4219 #if YYDEBUG != 0
4220   yydebug = value;
4221 #else
4222   warning ("YYDEBUG not defined.");
4223 #endif
4224 }
4225 #endif