gcc/ch/parse.c

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