gcc/ch/parse.c

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