gcc/ch/grant.c

   1 /* Implement grant-file output & seize-file input for CHILL.
   2    Copyright (C) 1992, 1993, 1994, 1995, 1996, 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 #include "config.h"
  23 #include "system.h"
  24 #include "tree.h"
  25 #include "ch-tree.h"
  26 #include "lex.h"
  27 #include "flags.h"
  28 #include "actions.h"
  29 #include "input.h"
  30 #include "rtl.h"
  31 #include "tasking.h"
  32 #include "toplev.h"
  33 #include "output.h"
  34 #include "target.h"
  35
  36 #define APPEND(X,Y) X = append (X, Y)
  37 #define PREPEND(X,Y) X = prepend (X, Y);
  38 #define FREE(x) strfree (x)
  39 #define ALLOCAMOUNT     10000
  40 /* may be we can handle this in a more exciting way,
  41    but this also should work for the moment */
  42 #define MAYBE_NEWLINE(X)                       \
  43 do                                             \
  44 {                                              \
  45   if (X->len && X->str[X->len - 1] != '\n')    \
  46     APPEND (X, ";\n");                         \
  47 } while (0)
  48
  49 extern tree process_type;
  50 extern char *asm_file_name;
  51 extern char *dump_base_name;
  52
  53 /* forward declarations */
  54
  55 /* variable indicates compilation at module level */
  56 int chill_at_module_level = 0;
  57
  58
  59 /* mark that a SPEC MODULE was generated */
  60 static int spec_module_generated = 0;
  61
  62 /* define a faster string handling */
  63 typedef struct
  64 {
  65   char  *str;
  66   int           len;
  67   int           allocated;
  68 } MYSTRING;
  69
  70 /* structure used for handling multiple grant files */
  71 char    *grant_file_name;
  72 MYSTRING        *gstring = NULL;
  73 MYSTRING        *selective_gstring = NULL;
  74
  75 static MYSTRING *decode_decl                PARAMS ((tree));
  76 static MYSTRING *decode_constant            PARAMS ((tree));
  77 static void      grant_one_decl             PARAMS ((tree));
  78 static MYSTRING *get_type                   PARAMS ((tree));
  79 static MYSTRING *decode_mode                PARAMS ((tree));
  80 static MYSTRING *decode_prefix_rename       PARAMS ((tree));
  81 static MYSTRING *decode_constant_selective  PARAMS ((tree, tree));
  82 static MYSTRING *decode_mode_selective      PARAMS ((tree, tree));
  83 static MYSTRING *get_type_selective         PARAMS ((tree, tree));
  84 static MYSTRING *decode_decl_selective      PARAMS ((tree, tree));
  85 static MYSTRING *newstring                  PARAMS ((const char *));
  86 static void strfree                         PARAMS ((MYSTRING *));
  87 static MYSTRING *append                     PARAMS ((MYSTRING *, const char *));
  88 static MYSTRING *prepend                    PARAMS ((MYSTRING *, const char *));
  89 static void grant_use_seizefile             PARAMS ((const char *));
  90 static MYSTRING *decode_layout              PARAMS ((tree));
  91 static MYSTRING *grant_array_type           PARAMS ((tree));
  92 static MYSTRING *grant_array_type_selective PARAMS ((tree, tree));
  93 static MYSTRING *get_tag_value              PARAMS ((tree));
  94 static MYSTRING *get_tag_value_selective    PARAMS ((tree, tree));
  95 static MYSTRING *print_enumeral             PARAMS ((tree));
  96 static MYSTRING *print_enumeral_selective   PARAMS ((tree, tree));
  97 static MYSTRING *print_integer_type         PARAMS ((tree));
  98 static tree find_enum_parent                PARAMS ((tree, tree));
  99 static MYSTRING *print_integer_selective    PARAMS ((tree, tree));
 100 static MYSTRING *print_struct               PARAMS ((tree));
 101 static MYSTRING *print_struct_selective     PARAMS ((tree, tree));
 102 static MYSTRING *print_proc_exceptions      PARAMS ((tree));
 103 static MYSTRING *print_proc_tail            PARAMS ((tree, tree, int));
 104 static MYSTRING *print_proc_tail_selective  PARAMS ((tree, tree, tree));
 105 static tree find_in_decls                   PARAMS ((tree, tree));
 106 static int in_ridpointers                   PARAMS ((tree));
 107 static void grant_seized_identifier         PARAMS ((tree));
 108 static void globalize_decl                  PARAMS ((tree));
 109 static void grant_one_decl_selective        PARAMS ((tree, tree));
 110 static int compare_memory_file              PARAMS ((const char *, const char *));
 111 static int search_in_list                   PARAMS ((tree, tree));
 112 static int really_grant_this                PARAMS ((tree, tree));
 113
 114 /* list of the VAR_DECLs of the module initializer entries */
 115 tree      module_init_list = NULL_TREE;
 116
 117 /* handle different USE_SEIZE_FILE's in case of selective granting */
 118 typedef struct SEIZEFILELIST
 119 {
 120   struct SEIZEFILELIST *next;
 121   tree filename;
 122   MYSTRING *seizes;
 123 } seizefile_list;
 124
 125 static seizefile_list *selective_seizes = 0;
 126
 127 \f
 128 static MYSTRING *
 129 newstring (str)
 130     const char  *str;
 131 {
 132     MYSTRING    *tmp = (MYSTRING *) xmalloc (sizeof (MYSTRING));
 133     unsigned    len = strlen (str);
 134
 135     tmp->allocated = len + ALLOCAMOUNT;
 136     tmp->str = xmalloc ((unsigned)tmp->allocated);
 137     strcpy (tmp->str, str);
 138     tmp->len = len;
 139     return (tmp);
 140 }
 141
 142 static void
 143 strfree (str)
 144     MYSTRING    *str;
 145 {
 146     free (str->str);
 147     free (str);
 148 }
 149
 150 static MYSTRING *
 151 append (inout, in)
 152     MYSTRING    *inout;
 153     const char  *in;
 154 {
 155     int inlen = strlen (in);
 156     int amount = ALLOCAMOUNT;
 157
 158     if (inlen >= amount)
 159       amount += inlen;
 160     if ((inout->len + inlen) >= inout->allocated)
 161         inout->str = xrealloc (inout->str, inout->allocated += amount);
 162     strcpy (inout->str + inout->len, in);
 163     inout->len += inlen;
 164     return (inout);
 165 }
 166
 167 static MYSTRING *
 168 prepend (inout, in)
 169     MYSTRING    *inout;
 170     const char  *in;
 171 {
 172   MYSTRING *res = inout;
 173   if (strlen (in))
 174     {
 175       res = newstring (in);
 176       res = APPEND (res, inout->str);
 177       FREE (inout);
 178     }
 179   return res;
 180 }
 181 \f
 182 static void
 183 grant_use_seizefile (seize_filename)
 184      const char *seize_filename;
 185 {
 186   APPEND (gstring, "<> USE_SEIZE_FILE \"");
 187   APPEND (gstring, seize_filename);
 188   APPEND (gstring, "\" <>\n");
 189 }
 190
 191 static MYSTRING *
 192 decode_layout (layout)
 193     tree layout;
 194 {
 195   tree temp;
 196   tree stepsize = NULL_TREE;
 197   int  was_step = 0;
 198   MYSTRING *result = newstring ("");
 199   MYSTRING *work;
 200
 201   if (layout == integer_zero_node) /* NOPACK */
 202     {
 203       APPEND (result, " NOPACK");
 204       return result;
 205     }
 206
 207   if (layout == integer_one_node) /* PACK */
 208     {
 209       APPEND (result, " PACK");
 210       return result;
 211     }
 212
 213   APPEND (result, " ");
 214   temp = layout;
 215   if (TREE_PURPOSE (temp) == NULL_TREE)
 216     {
 217       APPEND (result, "STEP(");
 218       was_step = 1;
 219       temp = TREE_VALUE (temp);
 220       stepsize = TREE_VALUE (temp);
 221     }
 222   APPEND (result, "POS(");
 223
 224   /* Get the starting word */
 225   temp = TREE_PURPOSE (temp);
 226   work = decode_constant (TREE_PURPOSE (temp));
 227   APPEND (result, work->str);
 228   FREE (work);
 229
 230   temp = TREE_VALUE (temp);
 231   if (temp != NULL_TREE)
 232     {
 233       /* Get the starting bit */
 234       APPEND (result, ", ");
 235       work = decode_constant (TREE_PURPOSE (temp));
 236       APPEND (result, work->str);
 237       FREE (work);
 238
 239       temp = TREE_VALUE (temp);
 240       if (temp != NULL_TREE)
 241         {
 242           /* Get the length or the ending bit */
 243           tree what = TREE_PURPOSE (temp);
 244           if (what == integer_zero_node) /* length */
 245             {
 246               APPEND (result, ", ");
 247             }
 248           else
 249             {
 250               APPEND (result, ":");
 251             }
 252           work = decode_constant (TREE_VALUE (temp));
 253           APPEND (result, work->str);
 254           FREE (work);
 255         }
 256     }
 257   APPEND (result, ")");
 258
 259   if (was_step)
 260     {
 261       if (stepsize != NULL_TREE)
 262         {
 263           APPEND (result, ", ");
 264           work = decode_constant (stepsize);
 265           APPEND (result, work->str);
 266           FREE (work);
 267         }
 268       APPEND (result, ")");
 269     }
 270
 271   return result;
 272 }
 273
 274 static MYSTRING *
 275 grant_array_type (type)
 276      tree type;
 277 {
 278   MYSTRING      *result = newstring ("");
 279   MYSTRING      *mode_string;
 280   tree           layout;
 281   int            varying = 0;
 282
 283   if (chill_varying_type_p (type))
 284     {
 285       varying = 1;
 286       type = CH_VARYING_ARRAY_TYPE (type);
 287     }
 288   if (CH_STRING_TYPE_P (type))
 289     {
 290       tree fields = TYPE_DOMAIN (type);
 291       tree maxval = TYPE_MAX_VALUE (fields);
 292
 293       if (TREE_CODE (TREE_TYPE (type)) == CHAR_TYPE)
 294         APPEND (result, "CHARS (");
 295       else
 296         APPEND (result, "BOOLS (");
 297       if (TREE_CODE (maxval) == INTEGER_CST)
 298         {
 299           char  wrk[20];
 300           sprintf (wrk, HOST_WIDE_INT_PRINT_DEC,
 301                    TREE_INT_CST_LOW (maxval) + 1);
 302           APPEND (result, wrk);
 303         }
 304       else if (TREE_CODE (maxval) == MINUS_EXPR
 305                && TREE_OPERAND (maxval, 1) == integer_one_node)
 306         {
 307           mode_string = decode_constant (TREE_OPERAND (maxval, 0));
 308           APPEND (result, mode_string->str);
 309           FREE (mode_string);
 310         }
 311       else
 312         {
 313           mode_string = decode_constant (maxval);
 314           APPEND (result, mode_string->str);
 315           FREE (mode_string);
 316           APPEND (result, "+1");
 317         }
 318       APPEND (result, ")");
 319       if (varying)
 320         APPEND (result, " VARYING");
 321       return result;
 322     }
 323
 324   APPEND (result, "ARRAY (");
 325   if (TREE_CODE (TYPE_DOMAIN (type)) == INTEGER_TYPE
 326      && TREE_TYPE (TYPE_DOMAIN (type)) == ridpointers[(int) RID_RANGE])
 327     {
 328       mode_string = decode_constant (TYPE_MIN_VALUE (TYPE_DOMAIN (type)));
 329       APPEND (result, mode_string->str);
 330       FREE (mode_string);
 331
 332       APPEND (result, ":");
 333       mode_string = decode_constant (TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
 334       APPEND (result, mode_string->str);
 335       FREE (mode_string);
 336     }
 337   else
 338     {
 339       mode_string = decode_mode (TYPE_DOMAIN (type));
 340       APPEND (result, mode_string->str);
 341       FREE (mode_string);
 342     }
 343   APPEND (result, ") ");
 344   if (varying)
 345     APPEND (result, "VARYING ");
 346
 347   mode_string = get_type (TREE_TYPE (type));
 348   APPEND (result, mode_string->str);
 349   FREE (mode_string);
 350
 351   layout = TYPE_ATTRIBUTES (type);
 352   if (layout != NULL_TREE)
 353     {
 354       mode_string = decode_layout (layout);
 355       APPEND (result, mode_string->str);
 356       FREE (mode_string);
 357     }
 358
 359   return result;
 360 }
 361
 362 static MYSTRING *
 363 grant_array_type_selective (type, all_decls)
 364      tree type;
 365      tree all_decls;
 366 {
 367   MYSTRING      *result = newstring ("");
 368   MYSTRING      *mode_string;
 369   int            varying = 0;
 370
 371   if (chill_varying_type_p (type))
 372     {
 373       varying = 1;
 374       type = CH_VARYING_ARRAY_TYPE (type);
 375     }
 376   if (CH_STRING_TYPE_P (type))
 377     {
 378       tree fields = TYPE_DOMAIN (type);
 379       tree maxval = TYPE_MAX_VALUE (fields);
 380
 381       if (TREE_CODE (maxval) != INTEGER_CST)
 382         {
 383           if (TREE_CODE (maxval) == MINUS_EXPR
 384               && TREE_OPERAND (maxval, 1) == integer_one_node)
 385             {
 386               mode_string = decode_constant_selective (TREE_OPERAND (maxval, 0), all_decls);
 387               if (mode_string->len)
 388                 APPEND (result, mode_string->str);
 389               FREE (mode_string);
 390             }
 391           else
 392             {
 393               mode_string = decode_constant_selective (maxval, all_decls);
 394               if (mode_string->len)
 395                 APPEND (result, mode_string->str);
 396               FREE (mode_string);
 397             }
 398         }
 399       return result;
 400     }
 401
 402   if (TREE_CODE (TYPE_DOMAIN (type)) == INTEGER_TYPE
 403      && TREE_TYPE (TYPE_DOMAIN (type)) == ridpointers[(int) RID_RANGE])
 404     {
 405       mode_string = decode_constant_selective (TYPE_MIN_VALUE (TYPE_DOMAIN (type)), all_decls);
 406       if (mode_string->len)
 407         APPEND (result, mode_string->str);
 408       FREE (mode_string);
 409
 410       mode_string = decode_constant_selective (TYPE_MAX_VALUE (TYPE_DOMAIN (type)), all_decls);
 411       if (mode_string->len)
 412         {
 413           MAYBE_NEWLINE (result);
 414           APPEND (result, mode_string->str);
 415         }
 416       FREE (mode_string);
 417     }
 418   else
 419     {
 420       mode_string = decode_mode_selective (TYPE_DOMAIN (type), all_decls);
 421       if (mode_string->len)
 422         APPEND (result, mode_string->str);
 423       FREE (mode_string);
 424     }
 425
 426   mode_string = get_type_selective (TREE_TYPE (type),  all_decls);
 427   if (mode_string->len)
 428     {
 429       MAYBE_NEWLINE (result);
 430       APPEND (result, mode_string->str);
 431     }
 432   FREE (mode_string);
 433
 434   return result;
 435 }
 436 \f
 437 static MYSTRING *
 438 get_tag_value (val)
 439     tree        val;
 440 {
 441   MYSTRING      *result;
 442
 443   if (TREE_CODE (val) == CONST_DECL && DECL_NAME (val))
 444     {
 445       result = newstring (IDENTIFIER_POINTER (DECL_NAME (val)));
 446     }
 447   else if (TREE_CODE (val) == CONST_DECL)
 448     {
 449       /* it's a synonym -- get the value */
 450       result = decode_constant (DECL_INITIAL (val));
 451     }
 452   else
 453     {
 454       result = decode_constant (val);
 455     }
 456   return (result);
 457 }
 458
 459 static MYSTRING *
 460 get_tag_value_selective (val, all_decls)
 461     tree        val;
 462     tree        all_decls;
 463 {
 464   MYSTRING      *result;
 465
 466   if (TREE_CODE (val) == CONST_DECL && DECL_NAME (val))
 467       result = newstring ("");
 468   else if (TREE_CODE (val) == CONST_DECL)
 469     {
 470       /* it's a synonym -- get the value */
 471       result = decode_constant_selective (DECL_INITIAL (val), all_decls);
 472     }
 473   else
 474     {
 475       result = decode_constant_selective (val, all_decls);
 476     }
 477   return (result);
 478 }
 479 \f
 480 static MYSTRING *
 481 print_enumeral (type)
 482      tree type;
 483 {
 484   MYSTRING      *result = newstring ("");
 485   tree  fields;
 486
 487 #if 0
 488   if (TYPE_LANG_SPECIFIC (type) == NULL)
 489 #endif
 490     {
 491
 492       APPEND (result, "SET (");
 493       for (fields = TYPE_VALUES (type);
 494            fields != NULL_TREE;
 495            fields = TREE_CHAIN (fields))
 496         {
 497           if (TREE_PURPOSE (fields) == NULL_TREE)
 498             APPEND (result, "*");
 499           else
 500             {
 501               tree decl = TREE_VALUE (fields);
 502               APPEND (result, IDENTIFIER_POINTER (TREE_PURPOSE (fields)));
 503               if (TREE_CODE (decl) == CONST_DECL && DECL_INITIAL (decl))
 504                 {
 505                   MYSTRING *val_string = decode_constant (DECL_INITIAL (decl));
 506                   APPEND (result, " = ");
 507                   APPEND (result, val_string->str);
 508                   FREE (val_string);
 509                 }
 510             }
 511           if (TREE_CHAIN (fields) != NULL_TREE)
 512             APPEND (result, ",\n     ");
 513         }
 514       APPEND (result, ")");
 515     }
 516   return result;
 517 }
 518
 519 static MYSTRING *
 520 print_enumeral_selective (type, all_decls)
 521      tree type;
 522      tree all_decls;
 523 {
 524   MYSTRING      *result = newstring ("");
 525   tree  fields;
 526
 527   for (fields = TYPE_VALUES (type);
 528        fields != NULL_TREE;
 529        fields = TREE_CHAIN (fields))
 530     {
 531       if (TREE_PURPOSE (fields) != NULL_TREE)
 532         {
 533           tree decl = TREE_VALUE (fields);
 534           if (TREE_CODE (decl) == CONST_DECL && DECL_INITIAL (decl))
 535             {
 536               MYSTRING *val_string = decode_constant_selective (DECL_INITIAL (decl), all_decls);
 537               if (val_string->len)
 538                 APPEND (result, val_string->str);
 539               FREE (val_string);
 540             }
 541         }
 542     }
 543   return result;
 544 }
 545 \f
 546 static MYSTRING *
 547 print_integer_type (type)
 548      tree type;
 549 {
 550   MYSTRING *result = newstring ("");
 551   MYSTRING *mode_string;
 552   const char *name_ptr;
 553   tree      base_type;
 554
 555   if (TREE_TYPE (type))
 556     {
 557       mode_string = decode_mode (TREE_TYPE (type));
 558       APPEND (result, mode_string->str);
 559       FREE (mode_string);
 560
 561       APPEND (result, "(");
 562       mode_string = decode_constant (TYPE_MIN_VALUE (type));
 563       APPEND (result, mode_string->str);
 564       FREE (mode_string);
 565
 566       if (TREE_TYPE (type) != ridpointers[(int) RID_BIN])
 567         {
 568           APPEND (result, ":");
 569           mode_string = decode_constant (TYPE_MAX_VALUE (type));
 570           APPEND (result, mode_string->str);
 571           FREE (mode_string);
 572         }
 573
 574       APPEND (result, ")");
 575       return result;
 576     }
 577   /* We test TYPE_MAIN_VARIANT because pushdecl often builds
 578      a copy of a built-in type node, which is logically id-
 579      entical but has a different address, and the same
 580      TYPE_MAIN_VARIANT. */
 581   /* FIXME this should not be needed! */
 582
 583   base_type = TREE_TYPE (type) ? TREE_TYPE (type) : type;
 584
 585   if (TREE_UNSIGNED (base_type))
 586     {
 587       if (base_type == chill_unsigned_type_node
 588           || TYPE_MAIN_VARIANT(base_type) ==
 589              TYPE_MAIN_VARIANT (chill_unsigned_type_node))
 590         name_ptr = "UINT";
 591       else if (base_type == long_integer_type_node
 592                || TYPE_MAIN_VARIANT(base_type) ==
 593                   TYPE_MAIN_VARIANT (long_unsigned_type_node))
 594         name_ptr = "ULONG";
 595       else if (type == unsigned_char_type_node
 596                || TYPE_MAIN_VARIANT(base_type) ==
 597                   TYPE_MAIN_VARIANT (unsigned_char_type_node))
 598         name_ptr = "UBYTE";
 599       else if (type == duration_timing_type_node
 600                || TYPE_MAIN_VARIANT (base_type) ==
 601                   TYPE_MAIN_VARIANT (duration_timing_type_node))
 602         name_ptr = "DURATION";
 603       else if (type == abs_timing_type_node
 604                || TYPE_MAIN_VARIANT (base_type) ==
 605                   TYPE_MAIN_VARIANT (abs_timing_type_node))
 606         name_ptr = "TIME";
 607       else
 608         name_ptr = "UINT";
 609     }
 610   else
 611     {
 612       if (base_type == chill_integer_type_node
 613           || TYPE_MAIN_VARIANT (base_type) ==
 614              TYPE_MAIN_VARIANT (chill_integer_type_node))
 615         name_ptr = "INT";
 616       else if (base_type == long_integer_type_node
 617                || TYPE_MAIN_VARIANT (base_type) ==
 618                   TYPE_MAIN_VARIANT (long_integer_type_node))
 619         name_ptr = "LONG";
 620       else if (type == signed_char_type_node
 621                || TYPE_MAIN_VARIANT (base_type) ==
 622                   TYPE_MAIN_VARIANT (signed_char_type_node))
 623         name_ptr = "BYTE";
 624       else
 625         name_ptr = "INT";
 626     }
 627
 628   APPEND (result, name_ptr);
 629
 630   /* see if we have a range */
 631   if (TREE_TYPE (type) != NULL)
 632     {
 633       mode_string = decode_constant (TYPE_MIN_VALUE (type));
 634       APPEND (result, mode_string->str);
 635       FREE (mode_string);
 636       APPEND (result, ":");
 637       mode_string = decode_constant (TYPE_MAX_VALUE (type));
 638       APPEND (result, mode_string->str);
 639       FREE (mode_string);
 640     }
 641
 642   return result;
 643 }
 644
 645 static tree
 646 find_enum_parent (enumname, all_decls)
 647      tree enumname;
 648      tree all_decls;
 649 {
 650   tree wrk;
 651
 652   for (wrk = all_decls; wrk != NULL_TREE; wrk = TREE_CHAIN (wrk))
 653     {
 654       if (TREE_TYPE (wrk) != NULL_TREE && TREE_CODE (wrk) != CONST_DECL &&
 655           TREE_CODE (TREE_TYPE (wrk)) == ENUMERAL_TYPE)
 656         {
 657           tree list;
 658           for (list = TYPE_VALUES (TREE_TYPE (wrk)); list != NULL_TREE; list = TREE_CHAIN (list))
 659             {
 660               if (DECL_NAME (TREE_VALUE (list)) == enumname)
 661                 return wrk;
 662             }
 663         }
 664     }
 665   return NULL_TREE;
 666 }
 667
 668 static MYSTRING *
 669 print_integer_selective (type, all_decls)
 670      tree type;
 671      tree all_decls;
 672 {
 673   MYSTRING *result = newstring ("");
 674   MYSTRING *mode_string;
 675
 676   if (TREE_TYPE (type))
 677     {
 678       mode_string = decode_mode_selective (TREE_TYPE (type), all_decls);
 679       if (mode_string->len)
 680         APPEND (result, mode_string->str);
 681       FREE (mode_string);
 682
 683       if (TREE_TYPE (type) == ridpointers[(int)RID_RANGE] &&
 684           TREE_CODE (TYPE_MIN_VALUE (type)) == IDENTIFIER_NODE &&
 685           TREE_CODE (TYPE_MAX_VALUE (type)) == IDENTIFIER_NODE)
 686         {
 687           /* we have a range of a set. Find parant mode and write it
 688              to SPEC MODULE. This will loose if the parent mode was SEIZED from
 689              another file.*/
 690           tree minparent = find_enum_parent (TYPE_MIN_VALUE (type), all_decls);
 691           tree maxparent = find_enum_parent (TYPE_MAX_VALUE (type), all_decls);
 692
 693           if (minparent != NULL_TREE)
 694             {
 695               if (! CH_ALREADY_GRANTED (minparent))
 696                 {
 697                   mode_string = decode_decl (minparent);
 698                   if (mode_string->len)
 699                     APPEND (result, mode_string->str);
 700                   FREE (mode_string);
 701                   CH_ALREADY_GRANTED (minparent) = 1;
 702                 }
 703             }
 704           if (minparent != maxparent && maxparent != NULL_TREE)
 705             {
 706               if (!CH_ALREADY_GRANTED (maxparent))
 707                 {
 708                   mode_string = decode_decl (maxparent);
 709                   if (mode_string->len)
 710                     {
 711                       MAYBE_NEWLINE (result);
 712                       APPEND (result, mode_string->str);
 713                     }
 714                   FREE (mode_string);
 715                   CH_ALREADY_GRANTED (maxparent) = 1;
 716                 }
 717             }
 718         }
 719       else
 720         {
 721           mode_string = decode_constant_selective (TYPE_MIN_VALUE (type), all_decls);
 722           if (mode_string->len)
 723             {
 724               MAYBE_NEWLINE (result);
 725               APPEND (result, mode_string->str);
 726             }
 727           FREE (mode_string);
 728
 729           mode_string = decode_constant_selective (TYPE_MAX_VALUE (type), all_decls);
 730           if (mode_string->len)
 731             {
 732               MAYBE_NEWLINE (result);
 733               APPEND (result, mode_string->str);
 734             }
 735           FREE (mode_string);
 736         }
 737       return result;
 738     }
 739
 740   /* see if we have a range */
 741   if (TREE_TYPE (type) != NULL)
 742     {
 743       mode_string = decode_constant_selective (TYPE_MIN_VALUE (type), all_decls);
 744       if (mode_string->len)
 745         APPEND (result, mode_string->str);
 746       FREE (mode_string);
 747
 748       mode_string = decode_constant_selective (TYPE_MAX_VALUE (type), all_decls);
 749       if (mode_string->len)
 750         {
 751           MAYBE_NEWLINE (result);
 752           APPEND (result, mode_string->str);
 753         }
 754       FREE (mode_string);
 755     }
 756
 757   return result;
 758 }
 759 \f
 760 static MYSTRING *
 761 print_struct (type)
 762      tree type;
 763 {
 764   MYSTRING      *result = newstring ("");
 765   MYSTRING      *mode_string;
 766   tree  fields;
 767
 768   if (chill_varying_type_p (type))
 769     {
 770       mode_string = grant_array_type (type);
 771       APPEND (result, mode_string->str);
 772       FREE (mode_string);
 773     }
 774   else
 775     {
 776       fields = TYPE_FIELDS (type);
 777
 778       APPEND (result, "STRUCT (");
 779       while (fields != NULL_TREE)
 780         {
 781           if (TREE_CODE (TREE_TYPE (fields)) == UNION_TYPE)
 782             {
 783               tree variants;
 784               /* Format a tagged variant record type.  */
 785               APPEND (result, " CASE ");
 786               if (TYPE_TAGFIELDS (TREE_TYPE (fields)) != NULL_TREE)
 787                 {
 788                   tree tag_list = TYPE_TAGFIELDS (TREE_TYPE (fields));
 789                   for (;;)
 790                     {
 791                       tree tag_name = DECL_NAME (TREE_VALUE (tag_list));
 792                       APPEND (result, IDENTIFIER_POINTER (tag_name));
 793                       tag_list = TREE_CHAIN (tag_list);
 794                       if (tag_list == NULL_TREE)
 795                         break;
 796                       APPEND (result, ", ");
 797                     }
 798                 }
 799               APPEND (result, " OF\n");
 800               variants = TYPE_FIELDS (TREE_TYPE (fields));
 801
 802               /* Each variant is a FIELD_DECL whose type is an anonymous
 803                  struct within the anonymous union.  */
 804               while (variants != NULL_TREE)
 805                 {
 806                   tree tag_list = TYPE_TAG_VALUES (TREE_TYPE (variants));
 807                   tree struct_elts = TYPE_FIELDS (TREE_TYPE (variants));
 808
 809                   while (tag_list != NULL_TREE)
 810                     {
 811                       tree tag_values = TREE_VALUE (tag_list);
 812                       APPEND (result, "   (");
 813                       while (tag_values != NULL_TREE)
 814                         {
 815                           mode_string = get_tag_value (TREE_VALUE (tag_values));
 816                           APPEND (result, mode_string->str);
 817                           FREE (mode_string);
 818                           if (TREE_CHAIN (tag_values) != NULL_TREE)
 819                             {
 820                               APPEND (result, ",\n    ");
 821                               tag_values = TREE_CHAIN (tag_values);
 822                             }
 823                           else break;
 824                         }
 825                       APPEND (result, ")");
 826                       tag_list = TREE_CHAIN (tag_list);
 827                       if (tag_list)
 828                         APPEND (result, ",");
 829                       else
 830                         break;
 831                     }
 832                   APPEND (result, " : ");
 833
 834                   while (struct_elts != NULL_TREE)
 835                     {
 836                       mode_string = decode_decl (struct_elts);
 837                       APPEND (result, mode_string->str);
 838                       FREE (mode_string);
 839
 840                       if (TREE_CHAIN (struct_elts) != NULL_TREE)
 841                         APPEND (result, ",\n     ");
 842                       struct_elts = TREE_CHAIN (struct_elts);
 843                     }
 844
 845                   variants = TREE_CHAIN (variants);
 846                   if (variants != NULL_TREE
 847                       && TREE_CHAIN (variants) == NULL_TREE
 848                       && DECL_NAME (variants) == ELSE_VARIANT_NAME)
 849                     {
 850                       tree else_elts = TYPE_FIELDS (TREE_TYPE (variants));
 851                       APPEND (result, "\n   ELSE ");
 852                       while (else_elts != NULL_TREE)
 853                         {
 854                           mode_string = decode_decl (else_elts);
 855                           APPEND (result, mode_string->str);
 856                           FREE (mode_string);
 857                           if (TREE_CHAIN (else_elts) != NULL_TREE)
 858                             APPEND (result, ",\n     ");
 859                           else_elts = TREE_CHAIN (else_elts);
 860                         }
 861                       break;
 862                     }
 863                   if (variants != NULL_TREE)
 864                     APPEND (result, ",\n");
 865                 }
 866
 867               APPEND (result, "\n   ESAC");
 868             }
 869           else
 870             {
 871               mode_string = decode_decl (fields);
 872               APPEND (result, mode_string->str);
 873               FREE (mode_string);
 874             }
 875
 876           fields = TREE_CHAIN (fields);
 877           if (fields != NULL_TREE)
 878             APPEND (result, ",\n    ");
 879         }
 880       APPEND (result, ")");
 881     }
 882   return result;
 883 }
 884
 885 static MYSTRING *
 886 print_struct_selective (type, all_decls)
 887      tree type;
 888      tree all_decls;
 889 {
 890   MYSTRING      *result = newstring ("");
 891   MYSTRING      *mode_string;
 892   tree  fields;
 893
 894   if (chill_varying_type_p (type))
 895     {
 896       mode_string = grant_array_type_selective (type, all_decls);
 897       if (mode_string->len)
 898         APPEND (result, mode_string->str);
 899       FREE (mode_string);
 900     }
 901   else
 902     {
 903       fields = TYPE_FIELDS (type);
 904
 905       while (fields != NULL_TREE)
 906         {
 907           if (TREE_CODE (TREE_TYPE (fields)) == UNION_TYPE)
 908             {
 909               tree variants;
 910               /* Format a tagged variant record type.  */
 911
 912               variants = TYPE_FIELDS (TREE_TYPE (fields));
 913
 914               /* Each variant is a FIELD_DECL whose type is an anonymous
 915                  struct within the anonymous union.  */
 916               while (variants != NULL_TREE)
 917                 {
 918                   tree tag_list = TYPE_TAG_VALUES (TREE_TYPE (variants));
 919                   tree struct_elts = TYPE_FIELDS (TREE_TYPE (variants));
 920
 921                   while (tag_list != NULL_TREE)
 922                     {
 923                       tree tag_values = TREE_VALUE (tag_list);
 924                       while (tag_values != NULL_TREE)
 925                         {
 926                           mode_string = get_tag_value_selective (TREE_VALUE (tag_values),
 927                                                                  all_decls);
 928                           if (mode_string->len)
 929                             {
 930                               MAYBE_NEWLINE (result);
 931                               APPEND (result, mode_string->str);
 932                             }
 933                           FREE (mode_string);
 934                           if (TREE_CHAIN (tag_values) != NULL_TREE)
 935                               tag_values = TREE_CHAIN (tag_values);
 936                           else break;
 937                         }
 938                       tag_list = TREE_CHAIN (tag_list);
 939                       if (!tag_list)
 940                         break;
 941                     }
 942
 943                   while (struct_elts != NULL_TREE)
 944                     {
 945                       mode_string = decode_decl_selective (struct_elts, all_decls);
 946                       if (mode_string->len)
 947                         {
 948                           MAYBE_NEWLINE (result);
 949                           APPEND (result, mode_string->str);
 950                         }
 951                       FREE (mode_string);
 952
 953                       struct_elts = TREE_CHAIN (struct_elts);
 954                     }
 955
 956                   variants = TREE_CHAIN (variants);
 957                   if (variants != NULL_TREE
 958                       && TREE_CHAIN (variants) == NULL_TREE
 959                       && DECL_NAME (variants) == ELSE_VARIANT_NAME)
 960                     {
 961                       tree else_elts = TYPE_FIELDS (TREE_TYPE (variants));
 962                       while (else_elts != NULL_TREE)
 963                         {
 964                           mode_string = decode_decl_selective (else_elts, all_decls);
 965                           if (mode_string->len)
 966                             {
 967                               MAYBE_NEWLINE (result);
 968                               APPEND (result, mode_string->str);
 969                             }
 970                           FREE (mode_string);
 971                           else_elts = TREE_CHAIN (else_elts);
 972                         }
 973                       break;
 974                     }
 975                 }
 976             }
 977           else
 978             {
 979               mode_string = decode_decl_selective (fields, all_decls);
 980               APPEND (result, mode_string->str);
 981               FREE (mode_string);
 982             }
 983
 984           fields = TREE_CHAIN (fields);
 985         }
 986     }
 987   return result;
 988 }
 989 \f
 990 static MYSTRING *
 991 print_proc_exceptions (ex)
 992      tree ex;
 993 {
 994   MYSTRING      *result = newstring ("");
 995
 996   if (ex != NULL_TREE)
 997     {
 998       APPEND (result, "\n  EXCEPTIONS (");
 999       for ( ; ex != NULL_TREE; ex = TREE_CHAIN (ex))
1000         {
1001           APPEND (result, IDENTIFIER_POINTER (TREE_VALUE (ex)));
1002           if (TREE_CHAIN (ex) != NULL_TREE)
1003             APPEND (result, ",\n    ");
1004         }
1005       APPEND (result, ")");
1006     }
1007   return result;
1008 }
1009
1010 static MYSTRING *
1011 print_proc_tail (type, args, print_argnames)
1012      tree type;
1013      tree args;
1014      int print_argnames;
1015 {
1016   MYSTRING      *result = newstring ("");
1017   MYSTRING      *mode_string;
1018   int count = 0;
1019   int stopat = list_length (args) - 3;
1020
1021   /* do the argument modes */
1022   for ( ; args != NULL_TREE;
1023        args = TREE_CHAIN (args), count++)
1024     {
1025       char buf[20];
1026       tree argmode = TREE_VALUE (args);
1027       tree attribute = TREE_PURPOSE (args);
1028
1029       if (argmode == void_type_node)
1030         continue;
1031
1032       /* if we have exceptions don't print last 2 arguments */
1033       if (TYPE_RAISES_EXCEPTIONS (type) && count == stopat)
1034         break;
1035
1036       if (count)
1037         APPEND (result, ",\n       ");
1038       if (print_argnames)
1039         {
1040           sprintf(buf, "arg%d ", count);
1041           APPEND (result, buf);
1042         }
1043
1044       if (attribute == ridpointers[(int) RID_LOC])
1045         argmode = TREE_TYPE (argmode);
1046       mode_string = get_type (argmode);
1047       APPEND (result, mode_string->str);
1048       FREE (mode_string);
1049
1050       if (attribute != NULL_TREE)
1051         {
1052           sprintf (buf, " %s", IDENTIFIER_POINTER (attribute));
1053           APPEND (result, buf);
1054         }
1055     }
1056   APPEND (result, ")");
1057
1058   /* return type */
1059   {
1060     tree retn_type = TREE_TYPE (type);
1061
1062     if (retn_type != NULL_TREE
1063         && TREE_CODE (retn_type) != VOID_TYPE)
1064       {
1065         mode_string = get_type (retn_type);
1066         APPEND (result, "\n  RETURNS (");
1067         APPEND (result, mode_string->str);
1068         FREE (mode_string);
1069         if (TREE_CODE (retn_type) == REFERENCE_TYPE)
1070           APPEND (result, " LOC");
1071         APPEND (result, ")");
1072       }
1073   }
1074
1075   mode_string = print_proc_exceptions (TYPE_RAISES_EXCEPTIONS (type));
1076   APPEND (result, mode_string->str);
1077   FREE (mode_string);
1078
1079   return result;
1080 }
1081
1082 static MYSTRING *
1083 print_proc_tail_selective (type, args, all_decls)
1084      tree type;
1085      tree args;
1086      tree all_decls;
1087 {
1088   MYSTRING      *result = newstring ("");
1089   MYSTRING      *mode_string;
1090   int count = 0;
1091   int stopat = list_length (args) - 3;
1092
1093   /* do the argument modes */
1094   for ( ; args != NULL_TREE;
1095        args = TREE_CHAIN (args), count++)
1096     {
1097       tree argmode = TREE_VALUE (args);
1098       tree attribute = TREE_PURPOSE (args);
1099
1100       if (argmode == void_type_node)
1101         continue;
1102
1103       /* if we have exceptions don't process last 2 arguments */
1104       if (TYPE_RAISES_EXCEPTIONS (type) && count == stopat)
1105         break;
1106
1107       if (attribute == ridpointers[(int) RID_LOC])
1108         argmode = TREE_TYPE (argmode);
1109       mode_string = get_type_selective (argmode, all_decls);
1110       if (mode_string->len)
1111         {
1112           MAYBE_NEWLINE (result);
1113           APPEND (result, mode_string->str);
1114         }
1115       FREE (mode_string);
1116     }
1117
1118   /* return type */
1119   {
1120     tree retn_type = TREE_TYPE (type);
1121
1122     if (retn_type != NULL_TREE
1123         && TREE_CODE (retn_type) != VOID_TYPE)
1124       {
1125         mode_string = get_type_selective (retn_type, all_decls);
1126         if (mode_string->len)
1127           {
1128             MAYBE_NEWLINE (result);
1129             APPEND (result, mode_string->str);
1130           }
1131         FREE (mode_string);
1132       }
1133   }
1134
1135   return result;
1136 }
1137 \f
1138 /* output a mode (or type). */
1139
1140 static MYSTRING *
1141 decode_mode (type)
1142     tree type;
1143 {
1144   MYSTRING      *result = newstring ("");
1145   MYSTRING      *mode_string;
1146
1147   switch ((enum chill_tree_code)TREE_CODE (type))
1148     {
1149     case TYPE_DECL:
1150       if (DECL_NAME (type))
1151         {
1152           APPEND (result, IDENTIFIER_POINTER (DECL_NAME (type)));
1153           return result;
1154         }
1155       type = TREE_TYPE (type);
1156       break;
1157
1158     case IDENTIFIER_NODE:
1159       APPEND (result, IDENTIFIER_POINTER (type));
1160       return result;
1161
1162     case LANG_TYPE:
1163       /* LANG_TYPE are only used until satisfy is done,
1164          as place-holders for 'READ T', NEWMODE/SYNMODE modes,
1165          parameterised modes, and old-fashioned CHAR(N). */
1166       if (TYPE_READONLY (type))
1167         APPEND (result, "READ ");
1168
1169       mode_string = get_type (TREE_TYPE (type));
1170       APPEND (result, mode_string->str);
1171       if (TYPE_DOMAIN (type) != NULL_TREE)
1172         {
1173           /* Parameterized mode,
1174              or old-fashioned CHAR(N) string declaration.. */
1175           APPEND (result, "(");
1176           mode_string = decode_constant (TYPE_DOMAIN (type));
1177           APPEND (result, mode_string->str);
1178           APPEND (result, ")");
1179         }
1180       FREE (mode_string);
1181       break;
1182
1183     case ARRAY_TYPE:
1184       mode_string = grant_array_type (type);
1185       APPEND (result, mode_string->str);
1186       FREE (mode_string);
1187       break;
1188
1189     case BOOLEAN_TYPE:
1190       APPEND (result, "BOOL");
1191       break;
1192
1193     case CHAR_TYPE:
1194       APPEND (result, "CHAR");
1195       break;
1196
1197     case ENUMERAL_TYPE:
1198       mode_string = print_enumeral (type);
1199       APPEND (result, mode_string->str);
1200       FREE (mode_string);
1201       break;
1202
1203     case FUNCTION_TYPE:
1204       {
1205         tree args = TYPE_ARG_TYPES (type);
1206
1207         APPEND (result, "PROC (");
1208
1209         mode_string = print_proc_tail (type, args, 0);
1210         APPEND (result, mode_string->str);
1211         FREE (mode_string);
1212       }
1213       break;
1214
1215     case INTEGER_TYPE:
1216       mode_string = print_integer_type (type);
1217       APPEND (result, mode_string->str);
1218       FREE (mode_string);
1219       break;
1220
1221     case RECORD_TYPE:
1222       if (CH_IS_INSTANCE_MODE (type))
1223         {
1224           APPEND (result, "INSTANCE");
1225           return result;
1226         }
1227       else if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type))
1228         { tree bufsize = max_queue_size (type);
1229           APPEND (result, CH_IS_BUFFER_MODE (type) ? "BUFFER " : "EVENT ");
1230           if (bufsize != NULL_TREE)
1231             {
1232               APPEND (result, "(");
1233               mode_string = decode_constant (bufsize);
1234               APPEND (result, mode_string->str);
1235               APPEND (result, ") ");
1236               FREE (mode_string);
1237             }
1238           if (CH_IS_BUFFER_MODE (type))
1239             {
1240               mode_string = decode_mode (buffer_element_mode (type));
1241               APPEND (result, mode_string->str);
1242               FREE (mode_string);
1243             }
1244           break;
1245         }
1246       else if (CH_IS_ACCESS_MODE (type))
1247         {
1248           tree indexmode, recordmode, dynamic;
1249
1250           APPEND (result, "ACCESS");
1251           recordmode = access_recordmode (type);
1252           indexmode = access_indexmode (type);
1253           dynamic = access_dynamic (type);
1254
1255           if (indexmode != void_type_node)
1256             {
1257               mode_string = decode_mode (indexmode);
1258               APPEND (result, " (");
1259               APPEND (result, mode_string->str);
1260               APPEND (result, ")");
1261               FREE (mode_string);
1262             }
1263           if (recordmode != void_type_node)
1264             {
1265               mode_string = decode_mode (recordmode);
1266               APPEND (result, " ");
1267               APPEND (result, mode_string->str);
1268               FREE (mode_string);
1269             }
1270           if (dynamic != integer_zero_node)
1271             APPEND (result, " DYNAMIC");
1272           break;
1273         }
1274       else if (CH_IS_TEXT_MODE (type))
1275         {
1276           tree indexmode, dynamic, length;
1277
1278           APPEND (result, "TEXT (");
1279           length = text_length (type);
1280           indexmode = text_indexmode (type);
1281           dynamic = text_dynamic (type);
1282
1283           mode_string = decode_constant (length);
1284           APPEND (result, mode_string->str);
1285           FREE (mode_string);
1286           APPEND (result, ")");
1287           if (indexmode != void_type_node)
1288             {
1289               APPEND (result, " ");
1290               mode_string = decode_mode (indexmode);
1291               APPEND (result, mode_string->str);
1292               FREE (mode_string);
1293             }
1294           if (dynamic != integer_zero_node)
1295             APPEND (result, " DYNAMIC");
1296           return result;
1297         }
1298       mode_string = print_struct (type);
1299       APPEND (result, mode_string->str);
1300       FREE (mode_string);
1301       break;
1302
1303     case POINTER_TYPE:
1304       if (TREE_CODE (TREE_TYPE (type)) == VOID_TYPE)
1305         APPEND (result, "PTR");
1306       else
1307         {
1308           if (TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
1309             {
1310               mode_string = get_type (TREE_TYPE (type));
1311               APPEND (result, mode_string->str);
1312               FREE (mode_string);
1313             }
1314           else
1315             {
1316               APPEND (result, "REF ");
1317               mode_string = get_type (TREE_TYPE (type));
1318               APPEND (result, mode_string->str);
1319               FREE (mode_string);
1320             }
1321         }
1322       break;
1323
1324     case REAL_TYPE:
1325       if (TREE_INT_CST_LOW (TYPE_SIZE (type)) == 32)
1326         APPEND (result, "REAL");
1327       else
1328         APPEND (result, "LONG_REAL");
1329       break;
1330
1331     case SET_TYPE:
1332       if (CH_BOOLS_TYPE_P (type))
1333         mode_string = grant_array_type (type);
1334       else
1335         {
1336           APPEND (result, "POWERSET ");
1337           mode_string = get_type (TYPE_DOMAIN (type));
1338         }
1339       APPEND (result, mode_string->str);
1340       FREE (mode_string);
1341       break;
1342
1343     case REFERENCE_TYPE:
1344       mode_string = get_type (TREE_TYPE (type));
1345       APPEND (result, mode_string->str);
1346       FREE (mode_string);
1347       break;
1348
1349     default:
1350       APPEND (result, "/* ---- not implemented ---- */");
1351       break;
1352     }
1353
1354   return (result);
1355 }
1356
1357 static tree
1358 find_in_decls (id, all_decls)
1359      tree id;
1360      tree all_decls;
1361 {
1362   tree wrk;
1363
1364   for (wrk = all_decls; wrk != NULL_TREE; wrk = TREE_CHAIN (wrk))
1365     {
1366       if (DECL_NAME (wrk) == id || DECL_POSTFIX (wrk) == id)
1367         return wrk;
1368     }
1369   return NULL_TREE;
1370 }
1371
1372 static int
1373 in_ridpointers (id)
1374      tree id;
1375 {
1376   int i;
1377   for (i = RID_UNUSED; i < RID_MAX; i++)
1378     {
1379       if (id == ridpointers[i])
1380         return 1;
1381     }
1382   return 0;
1383 }
1384
1385 static void
1386 grant_seized_identifier (decl)
1387      tree decl;
1388 {
1389   seizefile_list *wrk = selective_seizes;
1390   MYSTRING *mode_string;
1391
1392   CH_ALREADY_GRANTED (decl) = 1;
1393
1394   /* comes from a SPEC MODULE in the module */
1395   if (DECL_SEIZEFILE (decl) == NULL_TREE)
1396     return;
1397
1398   /* search file already in process */
1399   while (wrk != 0)
1400     {
1401       if (wrk->filename == DECL_SEIZEFILE (decl))
1402         break;
1403       wrk = wrk->next;
1404     }
1405   if (!wrk)
1406     {
1407       wrk = (seizefile_list *)xmalloc (sizeof (seizefile_list));
1408       wrk->next = selective_seizes;
1409       selective_seizes = wrk;
1410       wrk->filename = DECL_SEIZEFILE (decl);
1411       wrk->seizes = newstring ("<> USE_SEIZE_FILE \"");
1412       APPEND (wrk->seizes, IDENTIFIER_POINTER (DECL_SEIZEFILE (decl)));
1413       APPEND (wrk->seizes, "\" <>\n");
1414     }
1415   APPEND (wrk->seizes, "SEIZE ");
1416   mode_string = decode_prefix_rename (decl);
1417   APPEND (wrk->seizes, mode_string->str);
1418   FREE (mode_string);
1419   APPEND (wrk->seizes, ";\n");
1420 }
1421
1422 static MYSTRING *
1423 decode_mode_selective (type, all_decls)
1424     tree type;
1425     tree all_decls;
1426 {
1427   MYSTRING      *result = newstring ("");
1428   MYSTRING      *mode_string;
1429   tree decl;
1430
1431   switch ((enum chill_tree_code)TREE_CODE (type))
1432     {
1433     case TYPE_DECL:
1434       /* FIXME: could this ever happen ?? */
1435       if (DECL_NAME (type))
1436         {
1437           FREE (result);
1438           result = decode_mode_selective (DECL_NAME (type), all_decls);
1439           return result;
1440         }
1441       break;
1442
1443     case IDENTIFIER_NODE:
1444       if (in_ridpointers (type))
1445         /* it's a predefined, we must not search the whole list */
1446         return result;
1447
1448       decl = find_in_decls (type, all_decls);
1449       if (decl != NULL_TREE)
1450         {
1451           if (CH_ALREADY_GRANTED (decl))
1452             /* already processed */
1453             return result;
1454
1455           if (TREE_CODE (decl) == ALIAS_DECL && DECL_POSTFIX (decl) != NULL_TREE)
1456             {
1457               /* If CH_DECL_GRANTED, decl was granted into this scope, and
1458                  so wasn't in the source code. */
1459               if (!CH_DECL_GRANTED (decl))
1460                 {
1461                   grant_seized_identifier (decl);
1462                 }
1463             }
1464           else
1465             {
1466               result = decode_decl (decl);
1467               mode_string = decode_decl_selective (decl, all_decls);
1468               if (mode_string->len)
1469                 {
1470                   PREPEND (result, mode_string->str);
1471                 }
1472               FREE (mode_string);
1473             }
1474         }
1475       return result;
1476
1477     case LANG_TYPE:
1478       mode_string = get_type_selective (TREE_TYPE (type), all_decls);
1479       APPEND (result, mode_string->str);
1480       FREE (mode_string);
1481       break;
1482
1483     case ARRAY_TYPE:
1484       mode_string = grant_array_type_selective (type, all_decls);
1485       APPEND (result, mode_string->str);
1486       FREE (mode_string);
1487       break;
1488
1489     case BOOLEAN_TYPE:
1490       return result;
1491       break;
1492
1493     case CHAR_TYPE:
1494       return result;
1495       break;
1496
1497     case ENUMERAL_TYPE:
1498       mode_string = print_enumeral_selective (type, all_decls);
1499       if (mode_string->len)
1500         APPEND (result, mode_string->str);
1501       FREE (mode_string);
1502       break;
1503
1504     case FUNCTION_TYPE:
1505       {
1506         tree args = TYPE_ARG_TYPES (type);
1507
1508         mode_string = print_proc_tail_selective (type, args, all_decls);
1509         if (mode_string->len)
1510           APPEND (result, mode_string->str);
1511         FREE (mode_string);
1512       }
1513       break;
1514
1515     case INTEGER_TYPE:
1516       mode_string = print_integer_selective (type, all_decls);
1517       if (mode_string->len)
1518         APPEND (result, mode_string->str);
1519       FREE (mode_string);
1520       break;
1521
1522     case RECORD_TYPE:
1523       if (CH_IS_INSTANCE_MODE (type))
1524         {
1525           return result;
1526         }
1527       else if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type))
1528         {
1529           tree bufsize = max_queue_size (type);
1530           if (bufsize != NULL_TREE)
1531             {
1532               mode_string = decode_constant_selective (bufsize, all_decls);
1533               if (mode_string->len)
1534                 APPEND (result, mode_string->str);
1535               FREE (mode_string);
1536             }
1537           if (CH_IS_BUFFER_MODE (type))
1538             {
1539               mode_string = decode_mode_selective (buffer_element_mode (type), all_decls);
1540               if (mode_string->len)
1541                 {
1542                   MAYBE_NEWLINE (result);
1543                   APPEND (result, mode_string->str);
1544                 }
1545               FREE (mode_string);
1546             }
1547           break;
1548         }
1549       else if (CH_IS_ACCESS_MODE (type))
1550         {
1551           tree indexmode = access_indexmode (type);
1552           tree recordmode = access_recordmode (type);
1553
1554           if (indexmode != void_type_node)
1555             {
1556               mode_string = decode_mode_selective (indexmode, all_decls);
1557               if (mode_string->len)
1558                 {
1559                   if (result->len && result->str[result->len - 1] != '\n')
1560                     APPEND (result, ";\n");
1561                   APPEND (result, mode_string->str);
1562                 }
1563               FREE (mode_string);
1564             }
1565           if (recordmode != void_type_node)
1566             {
1567               mode_string = decode_mode_selective (recordmode, all_decls);
1568               if (mode_string->len)
1569                 {
1570                   if (result->len && result->str[result->len - 1] != '\n')
1571                     APPEND (result, ";\n");
1572                   APPEND (result, mode_string->str);
1573                 }
1574               FREE (mode_string);
1575             }
1576           break;
1577         }
1578       else if (CH_IS_TEXT_MODE (type))
1579         {
1580           tree indexmode = text_indexmode (type);
1581           tree length = text_length (type);
1582
1583           mode_string = decode_constant_selective (length, all_decls);
1584           if (mode_string->len)
1585             APPEND (result, mode_string->str);
1586           FREE (mode_string);
1587           if (indexmode != void_type_node)
1588             {
1589               mode_string = decode_mode_selective (indexmode, all_decls);
1590               if (mode_string->len)
1591                 {
1592                   if (result->len && result->str[result->len - 1] != '\n')
1593                     APPEND (result, ";\n");
1594                   APPEND (result, mode_string->str);
1595                 }
1596               FREE (mode_string);
1597             }
1598           break;
1599         }
1600       mode_string = print_struct_selective (type, all_decls);
1601       if (mode_string->len)
1602         {
1603           MAYBE_NEWLINE (result);
1604           APPEND (result, mode_string->str);
1605         }
1606       FREE (mode_string);
1607       break;
1608
1609     case POINTER_TYPE:
1610       if (TREE_CODE (TREE_TYPE (type)) == VOID_TYPE)
1611         break;
1612       else
1613         {
1614           if (TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
1615             {
1616               mode_string = get_type_selective (TREE_TYPE (type), all_decls);
1617               if (mode_string->len)
1618                 APPEND (result, mode_string->str);
1619               FREE (mode_string);
1620             }
1621           else
1622             {
1623               mode_string = get_type_selective (TREE_TYPE (type), all_decls);
1624               if (mode_string->len)
1625                 APPEND (result, mode_string->str);
1626               FREE (mode_string);
1627             }
1628         }
1629       break;
1630
1631     case REAL_TYPE:
1632       return result;
1633       break;
1634
1635     case SET_TYPE:
1636       if (CH_BOOLS_TYPE_P (type))
1637         mode_string = grant_array_type_selective (type, all_decls);
1638       else
1639         mode_string = get_type_selective (TYPE_DOMAIN (type), all_decls);
1640       if (mode_string->len)
1641         APPEND (result, mode_string->str);
1642       FREE (mode_string);
1643       break;
1644
1645     case REFERENCE_TYPE:
1646       mode_string = get_type_selective (TREE_TYPE (type), all_decls);
1647       if (mode_string->len)
1648         APPEND (result, mode_string->str);
1649       FREE (mode_string);
1650       break;
1651
1652     default:
1653       APPEND (result, "/* ---- not implemented ---- */");
1654       break;
1655     }
1656
1657   return (result);
1658 }
1659 \f
1660 static MYSTRING *
1661 get_type (type)
1662     tree        type;
1663 {
1664   if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
1665     return newstring ("");
1666
1667   return (decode_mode (type));
1668 }
1669
1670 static MYSTRING *
1671 get_type_selective (type, all_decls)
1672     tree        type;
1673     tree        all_decls;
1674 {
1675   if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
1676     return newstring ("");
1677
1678   return (decode_mode_selective (type, all_decls));
1679 }
1680
1681 #if 0
1682 static int
1683 is_forbidden (str, forbid)
1684     tree        str;
1685     tree        forbid;
1686 {
1687   if (forbid == NULL_TREE)
1688     return (0);
1689
1690   if (TREE_CODE (forbid) == INTEGER_CST)
1691     return (1);
1692
1693   while (forbid != NULL_TREE)
1694     {
1695       if (TREE_VALUE (forbid) == str)
1696         return (1);
1697       forbid = TREE_CHAIN (forbid);
1698     }
1699   /* nothing found */
1700   return (0);
1701 }
1702 #endif
1703
1704 static MYSTRING *
1705 decode_constant (init)
1706      tree       init;
1707 {
1708   MYSTRING *result = newstring ("");
1709   MYSTRING *tmp_string;
1710   tree      type = TREE_TYPE (init);
1711   tree  val = init;
1712   const char *op;
1713   char  wrk[256];
1714   MYSTRING *mode_string;
1715
1716   switch ((enum chill_tree_code)TREE_CODE (val))
1717     {
1718     case CALL_EXPR:
1719       tmp_string = decode_constant (TREE_OPERAND (val, 0));
1720       APPEND (result, tmp_string->str);
1721       FREE (tmp_string);
1722       val = TREE_OPERAND (val, 1);  /* argument list */
1723       if (val != NULL_TREE && TREE_CODE (val) != TREE_LIST)
1724         {
1725           APPEND (result, " ");
1726           tmp_string = decode_constant (val);
1727           APPEND (result, tmp_string->str);
1728           FREE (tmp_string);
1729         }
1730       else
1731         {
1732           APPEND (result, " (");
1733           if (val != NULL_TREE)
1734             {
1735               for (;;)
1736                 {
1737                   tmp_string = decode_constant (TREE_VALUE (val));
1738                   APPEND (result, tmp_string->str);
1739                   FREE (tmp_string);
1740                   val = TREE_CHAIN (val);
1741                   if (val == NULL_TREE)
1742                     break;
1743                   APPEND (result, ", ");
1744                 }
1745             }
1746           APPEND (result, ")");
1747         }
1748       return result;
1749
1750     case NOP_EXPR:
1751       /* Generate an "expression conversion" expression (a cast). */
1752       tmp_string = decode_mode (type);
1753
1754       APPEND (result, tmp_string->str);
1755       FREE (tmp_string);
1756       APPEND (result, "(");
1757       val = TREE_OPERAND (val, 0);
1758       type = TREE_TYPE (val);
1759
1760       /* If the coercee is a tuple, make sure it is prefixed by its mode. */
1761       if (TREE_CODE (val) == CONSTRUCTOR
1762         && !CH_BOOLS_TYPE_P (type) && !chill_varying_type_p (type))
1763         {
1764           tmp_string = decode_mode (type);
1765           APPEND (result, tmp_string->str);
1766           FREE (tmp_string);
1767           APPEND (result, " ");
1768         }
1769
1770       tmp_string = decode_constant (val);
1771       APPEND (result, tmp_string->str);
1772       FREE (tmp_string);
1773       APPEND (result, ")");
1774       return result;
1775
1776     case IDENTIFIER_NODE:
1777       APPEND (result, IDENTIFIER_POINTER (val));
1778       return result;
1779
1780     case PAREN_EXPR:
1781       APPEND (result, "(");
1782       tmp_string = decode_constant (TREE_OPERAND (val, 0));
1783       APPEND (result, tmp_string->str);
1784       FREE (tmp_string);
1785       APPEND (result, ")");
1786       return result;
1787
1788     case UNDEFINED_EXPR:
1789       APPEND (result, "*");
1790       return result;
1791
1792     case PLUS_EXPR:        op = "+";       goto binary;
1793     case MINUS_EXPR:       op = "-";       goto binary;
1794     case MULT_EXPR:        op = "*";       goto binary;
1795     case TRUNC_DIV_EXPR:   op = "/";       goto binary;
1796     case FLOOR_MOD_EXPR:   op = " MOD ";   goto binary;
1797     case TRUNC_MOD_EXPR:   op = " REM ";   goto binary;
1798     case CONCAT_EXPR:      op = "//";      goto binary;
1799     case BIT_IOR_EXPR:     op = " OR ";    goto binary;
1800     case BIT_XOR_EXPR:     op = " XOR ";   goto binary;
1801     case TRUTH_ORIF_EXPR:  op = " ORIF ";  goto binary;
1802     case BIT_AND_EXPR:     op = " AND ";   goto binary;
1803     case TRUTH_ANDIF_EXPR: op = " ANDIF "; goto binary;
1804     case GT_EXPR:          op = ">";       goto binary;
1805     case GE_EXPR:          op = ">=";      goto binary;
1806     case SET_IN_EXPR:      op = " IN ";    goto binary;
1807     case LT_EXPR:          op = "<";       goto binary;
1808     case LE_EXPR:          op = "<=";      goto binary;
1809     case EQ_EXPR:          op = "=";       goto binary;
1810     case NE_EXPR:          op = "/=";      goto binary;
1811     case RANGE_EXPR:
1812       if (TREE_OPERAND (val, 0) == NULL_TREE)
1813         {
1814           APPEND (result, TREE_OPERAND (val, 1) == NULL_TREE ? "*" : "ELSE");
1815           return result;
1816         }
1817       op = ":";       goto binary;
1818     binary:
1819       tmp_string = decode_constant (TREE_OPERAND (val, 0));
1820       APPEND (result, tmp_string->str);
1821       FREE (tmp_string);
1822       APPEND (result, op);
1823       tmp_string = decode_constant (TREE_OPERAND (val, 1));
1824       APPEND (result, tmp_string->str);
1825       FREE (tmp_string);
1826       return result;
1827
1828     case REPLICATE_EXPR:
1829       APPEND (result, "(");
1830       tmp_string = decode_constant (TREE_OPERAND (val, 0));
1831       APPEND (result, tmp_string->str);
1832       FREE (tmp_string);
1833       APPEND (result, ")");
1834       tmp_string = decode_constant (TREE_OPERAND (val, 1));
1835       APPEND (result, tmp_string->str);
1836       FREE (tmp_string);
1837       return result;
1838
1839     case NEGATE_EXPR:     op = "-";     goto unary;
1840     case BIT_NOT_EXPR:    op = " NOT "; goto unary;
1841     case ADDR_EXPR:       op = "->"; goto unary;
1842     unary:
1843       APPEND (result, op);
1844       tmp_string = decode_constant (TREE_OPERAND (val, 0));
1845       APPEND (result, tmp_string->str);
1846       FREE (tmp_string);
1847       return result;
1848
1849     case INTEGER_CST:
1850       APPEND (result, display_int_cst (val));
1851       return result;
1852
1853     case REAL_CST:
1854 #ifndef REAL_IS_NOT_DOUBLE
1855       sprintf (wrk, "%.20g", TREE_REAL_CST (val));
1856 #else
1857       REAL_VALUE_TO_DECIMAL (TREE_REAL_CST (val), "%.20g", wrk);
1858 #endif
1859       APPEND (result, wrk);
1860       return result;
1861
1862     case STRING_CST:
1863       {
1864         const char *ptr = TREE_STRING_POINTER (val);
1865         int i = TREE_STRING_LENGTH (val);
1866         APPEND (result, "\"");
1867         while (--i >= 0)
1868           {
1869             char buf[10];
1870             unsigned char c = *ptr++;
1871             if (c == '^')
1872               APPEND (result, "^^");
1873             else if (c == '"')
1874               APPEND (result, "\"\"");
1875             else if (c == '\n')
1876               APPEND (result, "^J");
1877             else if (c < ' ' || c > '~')
1878               {
1879                 sprintf (buf, "^(%u)", c);
1880                 APPEND (result, buf);
1881               }
1882             else
1883               {
1884                 buf[0] = c;
1885                 buf[1] = 0;
1886                 APPEND (result, buf);
1887               }
1888           }
1889         APPEND (result, "\"");
1890         return result;
1891       }
1892
1893     case CONSTRUCTOR:
1894       val = TREE_OPERAND (val, 1);
1895       if (type != NULL && TREE_CODE (type) == SET_TYPE
1896           && CH_BOOLS_TYPE_P (type))
1897         {
1898           /* It's a bitstring. */
1899           tree domain = TYPE_DOMAIN (type);
1900           tree domain_max = TYPE_MAX_VALUE (domain);
1901           char *buf;
1902           register char *ptr;
1903           int len;
1904           if (TREE_CODE (domain_max) != INTEGER_CST
1905               || (val && TREE_CODE (val) != TREE_LIST))
1906             goto fail;
1907
1908           len = TREE_INT_CST_LOW (domain_max) + 1;
1909           if (TREE_CODE (init) != CONSTRUCTOR)
1910             goto fail;
1911           buf = (char *) alloca (len + 10);
1912           ptr = buf;
1913           *ptr++ = ' ';
1914           *ptr++ = 'B';
1915           *ptr++ = '\'';
1916           if (get_set_constructor_bits (init, ptr, len))
1917             goto fail;
1918           for (; --len >= 0; ptr++)
1919             *ptr += '0';
1920           *ptr++ = '\'';
1921           *ptr = '\0';
1922           APPEND (result, buf);
1923           return result;
1924         }
1925       else
1926         { /* It's some kind of tuple */
1927           if (type != NULL_TREE)
1928             {
1929               mode_string = get_type (type);
1930               APPEND (result, mode_string->str);
1931               FREE (mode_string);
1932               APPEND (result, " ");
1933             }
1934           if (val == NULL_TREE
1935               || TREE_CODE (val) == ERROR_MARK)
1936             APPEND (result, "[ ]");
1937           else if (TREE_CODE (val) != TREE_LIST)
1938             goto fail;
1939           else
1940             {
1941               APPEND (result, "[");
1942               for ( ; ; )
1943                 {
1944                   tree lo_val = TREE_PURPOSE (val);
1945                   tree hi_val = TREE_VALUE (val);
1946                   MYSTRING *val_string;
1947                   if (TUPLE_NAMED_FIELD (val))
1948                     APPEND(result, ".");
1949                   if (lo_val != NULL_TREE)
1950                     {
1951                       val_string = decode_constant (lo_val);
1952                       APPEND (result, val_string->str);
1953                       FREE (val_string);
1954                       APPEND (result, ":");
1955                     }
1956                   val_string = decode_constant (hi_val);
1957                   APPEND (result, val_string->str);
1958                   FREE (val_string);
1959                   val = TREE_CHAIN (val);
1960                   if (val == NULL_TREE)
1961                     break;
1962                   APPEND (result, ", ");
1963                 }
1964               APPEND (result, "]");
1965             }
1966         }
1967       return result;
1968     case COMPONENT_REF:
1969       {
1970         tree op1;
1971
1972         mode_string = decode_constant (TREE_OPERAND (init, 0));
1973         APPEND (result, mode_string->str);
1974         FREE (mode_string);
1975         op1 = TREE_OPERAND (init, 1);
1976         if (TREE_CODE (op1) != IDENTIFIER_NODE)
1977           {
1978             error ("decode_constant: invalid component_ref");
1979             break;
1980           }
1981         APPEND (result, ".");
1982         APPEND (result, IDENTIFIER_POINTER (op1));
1983         return result;
1984       }
1985     fail:
1986       error ("decode_constant: mode and value mismatch");
1987       break;
1988     default:
1989       error ("decode_constant: cannot decode this mode");
1990       break;
1991     }
1992   return result;
1993 }
1994
1995 static MYSTRING *
1996 decode_constant_selective (init, all_decls)
1997      tree       init;
1998      tree       all_decls;
1999 {
2000   MYSTRING *result = newstring ("");
2001   MYSTRING *tmp_string;
2002   tree      type = TREE_TYPE (init);
2003   tree  val = init;
2004   MYSTRING *mode_string;
2005
2006   switch ((enum chill_tree_code)TREE_CODE (val))
2007     {
2008     case CALL_EXPR:
2009       tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
2010       if (tmp_string->len)
2011         APPEND (result, tmp_string->str);
2012       FREE (tmp_string);
2013       val = TREE_OPERAND (val, 1);  /* argument list */
2014       if (val != NULL_TREE && TREE_CODE (val) != TREE_LIST)
2015         {
2016           tmp_string = decode_constant_selective (val, all_decls);
2017           if (tmp_string->len)
2018             {
2019               MAYBE_NEWLINE (result);
2020               APPEND (result, tmp_string->str);
2021             }
2022           FREE (tmp_string);
2023         }
2024       else
2025         {
2026           if (val != NULL_TREE)
2027             {
2028               for (;;)
2029                 {
2030                   tmp_string = decode_constant_selective (TREE_VALUE (val), all_decls);
2031                   if (tmp_string->len)
2032                     {
2033                       MAYBE_NEWLINE (result);
2034                       APPEND (result, tmp_string->str);
2035                     }
2036                   FREE (tmp_string);
2037                   val = TREE_CHAIN (val);
2038                   if (val == NULL_TREE)
2039                     break;
2040                 }
2041             }
2042         }
2043       return result;
2044
2045     case NOP_EXPR:
2046       /* Generate an "expression conversion" expression (a cast). */
2047       tmp_string = decode_mode_selective (type, all_decls);
2048       if (tmp_string->len)
2049         APPEND (result, tmp_string->str);
2050       FREE (tmp_string);
2051       val = TREE_OPERAND (val, 0);
2052       type = TREE_TYPE (val);
2053
2054       /* If the coercee is a tuple, make sure it is prefixed by its mode. */
2055       if (TREE_CODE (val) == CONSTRUCTOR
2056         && !CH_BOOLS_TYPE_P (type) && !chill_varying_type_p (type))
2057         {
2058           tmp_string = decode_mode_selective (type, all_decls);
2059           if (tmp_string->len)
2060             APPEND (result, tmp_string->str);
2061           FREE (tmp_string);
2062         }
2063
2064       tmp_string = decode_constant_selective (val, all_decls);
2065       if (tmp_string->len)
2066         APPEND (result, tmp_string->str);
2067       FREE (tmp_string);
2068       return result;
2069
2070     case IDENTIFIER_NODE:
2071       tmp_string = decode_mode_selective (val, all_decls);
2072       if (tmp_string->len)
2073         APPEND (result, tmp_string->str);
2074       FREE (tmp_string);
2075       return result;
2076
2077     case PAREN_EXPR:
2078       tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
2079       if (tmp_string->len)
2080         APPEND (result, tmp_string->str);
2081       FREE (tmp_string);
2082       return result;
2083
2084     case UNDEFINED_EXPR:
2085       return result;
2086
2087     case PLUS_EXPR:
2088     case MINUS_EXPR:
2089     case MULT_EXPR:
2090     case TRUNC_DIV_EXPR:
2091     case FLOOR_MOD_EXPR:
2092     case TRUNC_MOD_EXPR:
2093     case CONCAT_EXPR:
2094     case BIT_IOR_EXPR:
2095     case BIT_XOR_EXPR:
2096     case TRUTH_ORIF_EXPR:
2097     case BIT_AND_EXPR:
2098     case TRUTH_ANDIF_EXPR:
2099     case GT_EXPR:
2100     case GE_EXPR:
2101     case SET_IN_EXPR:
2102     case LT_EXPR:
2103     case LE_EXPR:
2104     case EQ_EXPR:
2105     case NE_EXPR:
2106       goto binary;
2107     case RANGE_EXPR:
2108       if (TREE_OPERAND (val, 0) == NULL_TREE)
2109           return result;
2110
2111     binary:
2112       tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
2113       if (tmp_string->len)
2114         APPEND (result, tmp_string->str);
2115       FREE (tmp_string);
2116       tmp_string = decode_constant_selective (TREE_OPERAND (val, 1), all_decls);
2117       if (tmp_string->len)
2118         {
2119           MAYBE_NEWLINE (result);
2120           APPEND (result, tmp_string->str);
2121         }
2122       FREE (tmp_string);
2123       return result;
2124
2125     case REPLICATE_EXPR:
2126       tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
2127       if (tmp_string->len)
2128         APPEND (result, tmp_string->str);
2129       FREE (tmp_string);
2130       tmp_string = decode_constant_selective (TREE_OPERAND (val, 1), all_decls);
2131       if (tmp_string->len)
2132         {
2133           MAYBE_NEWLINE (result);
2134           APPEND (result, tmp_string->str);
2135         }
2136       FREE (tmp_string);
2137       return result;
2138
2139     case NEGATE_EXPR:
2140     case BIT_NOT_EXPR:
2141     case ADDR_EXPR:
2142       tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
2143       if (tmp_string->len)
2144         APPEND (result, tmp_string->str);
2145       FREE (tmp_string);
2146       return result;
2147
2148     case INTEGER_CST:
2149       return result;
2150
2151     case REAL_CST:
2152       return result;
2153
2154     case STRING_CST:
2155       return result;
2156
2157     case CONSTRUCTOR:
2158       val = TREE_OPERAND (val, 1);
2159       if (type != NULL && TREE_CODE (type) == SET_TYPE
2160           && CH_BOOLS_TYPE_P (type))
2161           /* It's a bitstring. */
2162           return result;
2163       else
2164         { /* It's some kind of tuple */
2165           if (type != NULL_TREE)
2166             {
2167               mode_string = get_type_selective (type, all_decls);
2168               if (mode_string->len)
2169                 APPEND (result, mode_string->str);
2170               FREE (mode_string);
2171             }
2172           if (val == NULL_TREE
2173               || TREE_CODE (val) == ERROR_MARK)
2174             return result;
2175           else if (TREE_CODE (val) != TREE_LIST)
2176             goto fail;
2177           else
2178             {
2179               for ( ; ; )
2180                 {
2181                   tree lo_val = TREE_PURPOSE (val);
2182                   tree hi_val = TREE_VALUE (val);
2183                   MYSTRING *val_string;
2184                   if (lo_val != NULL_TREE)
2185                     {
2186                       val_string = decode_constant_selective (lo_val, all_decls);
2187                       if (val_string->len)
2188                         APPEND (result, val_string->str);
2189                       FREE (val_string);
2190                     }
2191                   val_string = decode_constant_selective (hi_val, all_decls);
2192                   if (val_string->len)
2193                     {
2194                       MAYBE_NEWLINE (result);
2195                       APPEND (result, val_string->str);
2196                     }
2197                   FREE (val_string);
2198                   val = TREE_CHAIN (val);
2199                   if (val == NULL_TREE)
2200                     break;
2201                 }
2202             }
2203         }
2204       return result;
2205     case COMPONENT_REF:
2206       {
2207         mode_string = decode_constant_selective (TREE_OPERAND (init, 0), all_decls);
2208         if (mode_string->len)
2209           APPEND (result, mode_string->str);
2210         FREE (mode_string);
2211         return result;
2212       }
2213     fail:
2214       error ("decode_constant_selective: mode and value mismatch");
2215       break;
2216     default:
2217       error ("decode_constant_selective: cannot decode this mode");
2218       break;
2219     }
2220   return result;
2221 }
2222 \f
2223 /* Assuming DECL is an ALIAS_DECL, return its prefix rename clause. */
2224
2225 static MYSTRING *
2226 decode_prefix_rename (decl)
2227     tree decl;
2228 {
2229   MYSTRING *result = newstring ("");
2230   if (DECL_OLD_PREFIX (decl) || DECL_NEW_PREFIX (decl))
2231     {
2232       APPEND (result, "(");
2233       if (DECL_OLD_PREFIX (decl))
2234         APPEND (result, IDENTIFIER_POINTER (DECL_OLD_PREFIX (decl)));
2235       APPEND (result, "->");
2236       if (DECL_NEW_PREFIX (decl))
2237         APPEND (result, IDENTIFIER_POINTER (DECL_NEW_PREFIX (decl)));
2238       APPEND (result, ")!");
2239     }
2240   if (DECL_POSTFIX_ALL (decl))
2241     APPEND (result, "ALL");
2242   else
2243     APPEND (result, IDENTIFIER_POINTER  (DECL_POSTFIX (decl)));
2244   return result;
2245 }
2246
2247 static MYSTRING *
2248 decode_decl (decl)
2249     tree decl;
2250 {
2251   MYSTRING *result = newstring ("");
2252   MYSTRING *mode_string;
2253   tree      type;
2254
2255   switch ((enum chill_tree_code)TREE_CODE (decl))
2256     {
2257     case VAR_DECL:
2258     case BASED_DECL:
2259       APPEND (result, "DCL ");
2260       APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
2261       APPEND (result, " ");
2262       mode_string = get_type (TREE_TYPE (decl));
2263       APPEND (result, mode_string->str);
2264       FREE (mode_string);
2265       if ((enum chill_tree_code)TREE_CODE (decl) == BASED_DECL)
2266         {
2267           APPEND (result, " BASED (");
2268           APPEND (result, IDENTIFIER_POINTER (DECL_ABSTRACT_ORIGIN (decl)));
2269           APPEND (result, ")");
2270         }
2271       break;
2272
2273     case TYPE_DECL:
2274       if (CH_DECL_SIGNAL (decl))
2275         {
2276           /* this is really a signal */
2277           tree fields = TYPE_FIELDS (TREE_TYPE (decl));
2278           tree signame = DECL_NAME (decl);
2279           tree sigdest;
2280
2281           APPEND (result, "SIGNAL ");
2282           APPEND (result, IDENTIFIER_POINTER (signame));
2283           if (IDENTIFIER_SIGNAL_DATA (signame))
2284             {
2285               APPEND (result, " = (");
2286               for ( ; fields != NULL_TREE;
2287                    fields = TREE_CHAIN (fields))
2288                 {
2289                   MYSTRING *mode_string;
2290
2291                   mode_string = get_type (TREE_TYPE (fields));
2292                   APPEND (result, mode_string->str);
2293                   FREE (mode_string);
2294                   if (TREE_CHAIN (fields) != NULL_TREE)
2295                     APPEND (result, ", ");
2296                 }
2297               APPEND (result, ")");
2298             }
2299           sigdest = IDENTIFIER_SIGNAL_DEST (signame);
2300           if (sigdest != NULL_TREE)
2301             {
2302               APPEND (result, " TO ");
2303               APPEND (result, IDENTIFIER_POINTER (DECL_NAME (sigdest)));
2304             }
2305         }
2306       else
2307         {
2308           /* avoid defining a mode as itself */
2309           if (CH_NOVELTY (TREE_TYPE (decl)) == decl)
2310             APPEND (result, "NEWMODE ");
2311           else
2312             APPEND (result, "SYNMODE ");
2313           APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
2314           APPEND (result, " = ");
2315           mode_string = decode_mode (TREE_TYPE (decl));
2316           APPEND (result, mode_string->str);
2317           FREE (mode_string);
2318         }
2319       break;
2320
2321     case FUNCTION_DECL:
2322       {
2323         tree    args;
2324
2325         type = TREE_TYPE (decl);
2326         args = TYPE_ARG_TYPES (type);
2327
2328         APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
2329
2330         if (CH_DECL_PROCESS (decl))
2331           APPEND (result, ": PROCESS (");
2332         else
2333           APPEND (result, ": PROC (");
2334
2335         args = TYPE_ARG_TYPES (type);
2336
2337         mode_string = print_proc_tail (type, args, 1);
2338         APPEND (result, mode_string->str);
2339         FREE (mode_string);
2340
2341         /* generality */
2342         if (CH_DECL_GENERAL (decl))
2343           APPEND (result, " GENERAL");
2344         if (CH_DECL_SIMPLE (decl))
2345           APPEND (result, " SIMPLE");
2346         if (DECL_INLINE (decl))
2347           APPEND (result, " INLINE");
2348         if (CH_DECL_RECURSIVE (decl))
2349           APPEND (result, " RECURSIVE");
2350         APPEND (result, " END");
2351       }
2352       break;
2353
2354     case FIELD_DECL:
2355       APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
2356       APPEND (result, " ");
2357       mode_string = get_type (TREE_TYPE (decl));
2358       APPEND (result, mode_string->str);
2359       FREE (mode_string);
2360       if (DECL_INITIAL (decl) != NULL_TREE)
2361         {
2362           mode_string = decode_layout (DECL_INITIAL (decl));
2363           APPEND (result, mode_string->str);
2364           FREE (mode_string);
2365         }
2366 #if 0
2367       if (is_forbidden (DECL_NAME (decl), forbid))
2368         APPEND (result, " FORBID");
2369 #endif
2370       break;
2371
2372     case CONST_DECL:
2373       if (DECL_INITIAL (decl) == NULL_TREE
2374           || TREE_CODE (DECL_INITIAL (decl)) == ERROR_MARK)
2375         break;
2376       APPEND (result, "SYN ");
2377       APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
2378       APPEND (result, " ");
2379       mode_string = get_type (TREE_TYPE (decl));
2380       APPEND (result, mode_string->str);
2381       FREE (mode_string);
2382       APPEND (result, " = ");
2383       mode_string = decode_constant (DECL_INITIAL (decl));
2384       APPEND (result, mode_string->str);
2385       FREE (mode_string);
2386       break;
2387
2388     case ALIAS_DECL:
2389       /* If CH_DECL_GRANTED, decl was granted into this scope, and
2390          so wasn't in the source code. */
2391       if (!CH_DECL_GRANTED (decl))
2392         {
2393           static int restricted = 0;
2394
2395           if (DECL_SEIZEFILE (decl) != use_seizefile_name
2396               && DECL_SEIZEFILE (decl))
2397             {
2398               use_seizefile_name = DECL_SEIZEFILE (decl);
2399               restricted = use_seizefile_name == NULL_TREE ? 0 : CH_USE_SEIZEFILE_RESTRICTED (use_seizefile_name);
2400               if (! restricted)
2401                 grant_use_seizefile (IDENTIFIER_POINTER (use_seizefile_name));
2402               mark_use_seizefile_written (use_seizefile_name);
2403             }
2404           if (! restricted)
2405             {
2406               APPEND (result, "SEIZE ");
2407               mode_string = decode_prefix_rename (decl);
2408               APPEND (result, mode_string->str);
2409               FREE (mode_string);
2410             }
2411         }
2412       break;
2413
2414     default:
2415       APPEND (result, "----- not implemented ------");
2416       break;
2417     }
2418   return (result);
2419 }
2420
2421 static MYSTRING *
2422 decode_decl_selective (decl, all_decls)
2423     tree decl;
2424     tree all_decls;
2425 {
2426   MYSTRING *result = newstring ("");
2427   MYSTRING *mode_string;
2428   tree      type;
2429
2430   if (CH_ALREADY_GRANTED (decl))
2431     /* do nothing */
2432     return result;
2433
2434   CH_ALREADY_GRANTED (decl) = 1;
2435
2436   switch ((int)TREE_CODE (decl))
2437     {
2438     case VAR_DECL:
2439     case BASED_DECL:
2440       mode_string = get_type_selective (TREE_TYPE (decl), all_decls);
2441       if (mode_string->len)
2442         APPEND (result, mode_string->str);
2443       FREE (mode_string);
2444       if ((enum chill_tree_code)TREE_CODE (decl) == BASED_DECL)
2445         {
2446           mode_string = decode_mode_selective (DECL_ABSTRACT_ORIGIN (decl), all_decls);
2447           if (mode_string->len)
2448             PREPEND (result, mode_string->str);
2449           FREE (mode_string);
2450         }
2451       break;
2452
2453     case TYPE_DECL:
2454       if (CH_DECL_SIGNAL (decl))
2455         {
2456           /* this is really a signal */
2457           tree fields = TYPE_FIELDS (TREE_TYPE (decl));
2458           tree signame = DECL_NAME (decl);
2459           tree sigdest;
2460
2461           if (IDENTIFIER_SIGNAL_DATA (signame))
2462             {
2463               for ( ; fields != NULL_TREE;
2464                    fields = TREE_CHAIN (fields))
2465                 {
2466                   MYSTRING *mode_string;
2467
2468                   mode_string = get_type_selective (TREE_TYPE (fields),
2469                                                     all_decls);
2470                   if (mode_string->len)
2471                     APPEND (result, mode_string->str);
2472                   FREE (mode_string);
2473                 }
2474             }
2475           sigdest = IDENTIFIER_SIGNAL_DEST (signame);
2476           if (sigdest != NULL_TREE)
2477             {
2478               mode_string = decode_mode_selective (DECL_NAME (sigdest), all_decls);
2479               if (mode_string->len)
2480                 {
2481                   MAYBE_NEWLINE (result);
2482                   APPEND (result, mode_string->str);
2483                 }
2484               FREE (mode_string);
2485             }
2486         }
2487       else
2488         {
2489           /* avoid defining a mode as itself */
2490           mode_string = decode_mode_selective (TREE_TYPE (decl), all_decls);
2491           APPEND (result, mode_string->str);
2492           FREE (mode_string);
2493         }
2494       break;
2495
2496     case FUNCTION_DECL:
2497       {
2498         tree    args;
2499
2500         type = TREE_TYPE (decl);
2501         args = TYPE_ARG_TYPES (type);
2502
2503         args = TYPE_ARG_TYPES (type);
2504
2505         mode_string = print_proc_tail_selective (type, args, all_decls);
2506         if (mode_string->len)
2507           APPEND (result, mode_string->str);
2508         FREE (mode_string);
2509       }
2510       break;
2511
2512     case FIELD_DECL:
2513       mode_string = get_type_selective (TREE_TYPE (decl), all_decls);
2514       if (mode_string->len)
2515         APPEND (result, mode_string->str);
2516       FREE (mode_string);
2517       break;
2518
2519     case CONST_DECL:
2520       if (DECL_INITIAL (decl) == NULL_TREE
2521           || TREE_CODE (DECL_INITIAL (decl)) == ERROR_MARK)
2522         break;
2523       mode_string = get_type_selective (TREE_TYPE (decl), all_decls);
2524       if (mode_string->len)
2525         APPEND (result, mode_string->str);
2526       FREE (mode_string);
2527       mode_string = decode_constant_selective (DECL_INITIAL (decl), all_decls);
2528       if (mode_string->len)
2529         {
2530           MAYBE_NEWLINE (result);
2531           APPEND (result, mode_string->str);
2532         }
2533       FREE (mode_string);
2534       break;
2535
2536     }
2537   MAYBE_NEWLINE (result);
2538   return (result);
2539 }
2540
2541 static void
2542 globalize_decl (decl)
2543     tree        decl;
2544 {
2545   if (!TREE_PUBLIC (decl) && DECL_NAME (decl) &&
2546       (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL))
2547     {
2548       const char *name = XSTR (XEXP (DECL_RTL (decl), 0), 0);
2549
2550       if (!first_global_object_name)
2551         first_global_object_name = name + (name[0] == '*');
2552       ASM_GLOBALIZE_LABEL (asm_out_file, name);
2553     }
2554 }
2555
2556
2557 static void
2558 grant_one_decl (decl)
2559     tree        decl;
2560 {
2561   MYSTRING      *result;
2562
2563   if (DECL_SOURCE_LINE (decl) == 0)
2564     return;
2565   result = decode_decl (decl);
2566   if (result->len)
2567     {
2568       APPEND (result, ";\n");
2569       APPEND (gstring, result->str);
2570     }
2571   FREE (result);
2572 }
2573
2574 static void
2575 grant_one_decl_selective (decl, all_decls)
2576      tree decl;
2577      tree all_decls;
2578 {
2579   MYSTRING *result;
2580   MYSTRING *fixups;
2581
2582   tree     d = DECL_ABSTRACT_ORIGIN (decl);
2583
2584   if (CH_ALREADY_GRANTED (d))
2585     /* already done */
2586     return;
2587
2588   result = decode_decl (d);
2589   if (!result->len)
2590     {
2591       /* nothing to do */
2592       FREE (result);
2593       return;
2594     }
2595
2596   APPEND (result, ";\n");
2597
2598   /* now process all undefined items in the decl */
2599   fixups = decode_decl_selective (d, all_decls);
2600   if (fixups->len)
2601     {
2602       PREPEND (result, fixups->str);
2603     }
2604   FREE (fixups);
2605
2606   /* we have finished a decl */
2607   APPEND (selective_gstring, result->str);
2608   FREE (result);
2609 }
2610
2611 static int
2612 compare_memory_file (fname, buf)
2613     const char  *fname;
2614     const char  *buf;
2615 {
2616   FILE  *fb;
2617   int           c;
2618
2619   /* check if we have something to write */
2620   if (!buf || !strlen (buf))
2621     return (0);
2622
2623   if ((fb = fopen (fname, "r")) == NULL)
2624     return (1);
2625
2626   while ((c = getc (fb)) != EOF)
2627     {
2628       if (c != *buf++)
2629         {
2630           fclose (fb);
2631           return (1);
2632         }
2633     }
2634   fclose (fb);
2635   return (*buf ? 1 : 0);
2636 }
2637
2638 void
2639 write_grant_file ()
2640 {
2641   FILE  *fb;
2642
2643   /* We only write out the grant file if it has changed,
2644      to avoid changing its time-stamp and triggering an
2645      unnecessary 'make' action.  Return if no change. */
2646   if (gstring == NULL || !spec_module_generated ||
2647       !compare_memory_file (grant_file_name, gstring->str))
2648     return;
2649
2650   fb = fopen (grant_file_name, "w");
2651   if (fb == NULL)
2652     fatal_io_error ("can't open %s", grant_file_name);
2653
2654   /* write file. Due to problems with record sizes on VAX/VMS
2655      write string to '\n' */
2656 #ifdef VMS
2657   /* do it this way for VMS, cause of problems with
2658      record sizes */
2659   p = gstring->str;
2660   while (*p)
2661     {
2662       p1 = strchr (p, '\n');
2663       c = *++p1;
2664       *p1 = '\0';
2665       fprintf (fb, "%s", p);
2666       *p1 = c;
2667       p = p1;
2668     }
2669 #else
2670   /* faster way to write */
2671   if (write (fileno (fb), gstring->str, gstring->len) < 0)
2672     {
2673       int save_errno = errno;
2674
2675       unlink (grant_file_name);
2676       errno = save_errno;
2677       fatal_io_error ("can't write to %s", grant_file_name);
2678     }
2679 #endif
2680   fclose (fb);
2681 }
2682
2683
2684 /* handle grant statement */
2685
2686 void
2687 set_default_grant_file ()
2688 {
2689     char        *p, *tmp;
2690     const char  *fname;
2691
2692     if (dump_base_name)
2693       fname = dump_base_name; /* Probably invoked via gcc */
2694     else
2695       { /* Probably invoked directly (not via gcc) */
2696         fname = asm_file_name;
2697         if (!fname)
2698           fname = main_input_filename ? main_input_filename : input_filename;
2699         if (!fname)
2700           return;
2701       }
2702
2703     p = strrchr (fname, '.');
2704     if (!p)
2705     {
2706         tmp = (char *) alloca (strlen (fname) + 10);
2707         strcpy (tmp, fname);
2708     }
2709     else
2710     {
2711         int     i = p - fname;
2712
2713         tmp = (char *) alloca (i + 10);
2714         strncpy (tmp, fname, i);
2715         tmp[i] = '\0';
2716     }
2717     strcat (tmp, ".grt");
2718     default_grant_file = build_string (strlen (tmp), tmp);
2719
2720     grant_file_name = TREE_STRING_POINTER (default_grant_file);
2721
2722     if (gstring == NULL)
2723       gstring = newstring ("");
2724     if (selective_gstring == NULL)
2725       selective_gstring = newstring ("");
2726 }
2727
2728 /* Make DECL visible under the name NAME in the (fake) outermost scope. */
2729
2730 void
2731 push_granted (name, decl)
2732      tree name ATTRIBUTE_UNUSED, decl ATTRIBUTE_UNUSED;
2733 {
2734 #if 0
2735   IDENTIFIER_GRANTED_VALUE (name) = decl;
2736   granted_decls = tree_cons (name, decl, granted_decls);
2737 #endif
2738 }
2739
2740 void
2741 chill_grant (old_prefix, new_prefix, postfix, forbid)
2742      tree old_prefix;
2743      tree new_prefix;
2744      tree postfix;
2745      tree forbid;
2746 {
2747   if (pass == 1)
2748     {
2749 #if 0
2750       tree old_name = old_prefix == NULL_TREE ? postfix
2751         : get_identifier3 (IDENTIFIER_POINTER (old_prefix),
2752                            "!", IDENTIFIER_POINTER (postfix));
2753       tree new_name = new_prefix == NULL_TREE ? postfix
2754         : get_identifier3 (IDENTIFIER_POINTER (new_prefix),
2755                            "!", IDENTIFIER_POINTER (postfix));
2756 #endif
2757       tree alias = build_alias_decl (old_prefix, new_prefix, postfix);
2758       CH_DECL_GRANTED (alias) = 1;
2759       DECL_SEIZEFILE (alias) = current_seizefile_name;
2760       TREE_CHAIN (alias) = current_module->granted_decls;
2761       current_module->granted_decls = alias;
2762
2763       if (forbid)
2764         warning ("FORBID is not yet implemented");  /* FIXME */
2765     }
2766 }
2767 \f
2768 /* flag GRANT ALL only once. Avoids search in case of GRANT ALL. */
2769 static int grant_all_seen = 0;
2770
2771 /* check if a decl is in the list of granted decls. */
2772 static int
2773 search_in_list (name, granted_decls)
2774     tree name;
2775     tree granted_decls;
2776 {
2777   tree vars;
2778
2779   for (vars = granted_decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
2780     if (DECL_SOURCE_LINE (vars))
2781       {
2782         if (DECL_POSTFIX_ALL (vars))
2783           {
2784             grant_all_seen = 1;
2785             return 1;
2786           }
2787         else if (name == DECL_NAME (vars))
2788           return 1;
2789       }
2790   /* not found */
2791   return 0;
2792 }
2793
2794 static int
2795 really_grant_this (decl, granted_decls)
2796     tree decl;
2797     tree granted_decls;
2798 {
2799   /* we never grant labels at module level */
2800   if ((enum chill_tree_code)TREE_CODE (decl) == LABEL_DECL)
2801     return 0;
2802
2803   if (grant_all_seen)
2804     return 1;
2805
2806   switch ((enum chill_tree_code)TREE_CODE (decl))
2807     {
2808     case VAR_DECL:
2809     case BASED_DECL:
2810     case FUNCTION_DECL:
2811       return search_in_list (DECL_NAME (decl), granted_decls);
2812     case ALIAS_DECL:
2813     case CONST_DECL:
2814       return 1;
2815     case TYPE_DECL:
2816       if (CH_DECL_SIGNAL (decl))
2817         return search_in_list (DECL_NAME (decl), granted_decls);
2818       else
2819         return 1;
2820     default:
2821       break;
2822     }
2823
2824   /* this nerver should happen */
2825   error_with_decl (decl, "function \"really_grant_this\" called for `%s'.");
2826   return 1;
2827 }
2828 \f
2829 /* Write a SPEC MODULE using the declarations in the list DECLS. */
2830 static int header_written = 0;
2831 #define HEADER_TEMPLATE "--\n-- WARNING: this file was generated by\n\
2832 -- GNUCHILL version %s\n-- based on gcc version %s\n--\n"
2833
2834 void
2835 write_spec_module (decls, granted_decls)
2836      tree decls;
2837      tree granted_decls;
2838 {
2839   tree   vars;
2840   char   *hdr;
2841
2842   if (granted_decls == NULL_TREE)
2843     return;
2844
2845   use_seizefile_name = NULL_TREE;
2846
2847   if (!header_written)
2848     {
2849       hdr = (char*) alloca (strlen (gnuchill_version)
2850                             + strlen (version_string)
2851                             + sizeof (HEADER_TEMPLATE) /* includes \0 */);
2852       sprintf (hdr, HEADER_TEMPLATE, gnuchill_version, version_string);
2853       APPEND (gstring, hdr);
2854       header_written = 1;
2855     }
2856   APPEND (gstring, IDENTIFIER_POINTER (current_module->name));
2857   APPEND (gstring, ": SPEC MODULE\n");
2858
2859   /* first of all we look for GRANT ALL specified */
2860   search_in_list (NULL_TREE, granted_decls);
2861
2862   if (grant_all_seen != 0)
2863     {
2864       /* write all identifiers to grant file */
2865       for (vars = decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
2866         {
2867           if (DECL_SOURCE_LINE (vars))
2868             {
2869               if (DECL_NAME (vars))
2870                 {
2871                   if ((TREE_CODE (vars) != CONST_DECL || !CH_DECL_ENUM (vars)) &&
2872                       really_grant_this (vars, granted_decls))
2873                     grant_one_decl (vars);
2874                 }
2875               else if (DECL_POSTFIX_ALL (vars))
2876                 {
2877                   static int restricted = 0;
2878
2879                   if (DECL_SEIZEFILE (vars) != use_seizefile_name
2880                       && DECL_SEIZEFILE (vars))
2881                     {
2882                       use_seizefile_name = DECL_SEIZEFILE (vars);
2883                       restricted = use_seizefile_name == NULL_TREE ? 0 : CH_USE_SEIZEFILE_RESTRICTED (use_seizefile_name);
2884                       if (! restricted)
2885                         grant_use_seizefile (IDENTIFIER_POINTER (use_seizefile_name));
2886                       mark_use_seizefile_written (use_seizefile_name);
2887                     }
2888                   if (! restricted)
2889                     {
2890                       APPEND (gstring, "SEIZE ALL;\n");
2891                     }
2892                 }
2893             }
2894         }
2895     }
2896   else
2897     {
2898       seizefile_list *wrk, *x;
2899
2900       /* do a selective write to the grantfile. This will reduce the
2901          size of a grantfile and speed up compilation of
2902          modules depending on this grant file */
2903
2904       if (selective_gstring == 0)
2905         selective_gstring = newstring ("");
2906
2907       /* first of all process all SEIZE ALL's */
2908       for (vars = decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
2909         {
2910           if (DECL_SOURCE_LINE (vars)
2911               && DECL_POSTFIX_ALL (vars))
2912             grant_seized_identifier (vars);
2913         }
2914
2915       /* now walk through granted decls */
2916       granted_decls = nreverse (granted_decls);
2917       for (vars = granted_decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
2918         {
2919           grant_one_decl_selective (vars, decls);
2920         }
2921       granted_decls = nreverse (granted_decls);
2922
2923       /* append all SEIZES */
2924       wrk = selective_seizes;
2925       while (wrk != 0)
2926         {
2927           x = wrk->next;
2928           APPEND (gstring, wrk->seizes->str);
2929           FREE (wrk->seizes);
2930           free (wrk);
2931           wrk = x;
2932         }
2933       selective_seizes = 0;
2934
2935       /* append generated string to grant file */
2936       APPEND (gstring, selective_gstring->str);
2937       FREE (selective_gstring);
2938       selective_gstring = NULL;
2939     }
2940
2941   for (vars = granted_decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
2942     if (DECL_SOURCE_LINE (vars))
2943       {
2944         MYSTRING *mode_string = decode_prefix_rename (vars);
2945         APPEND (gstring, "GRANT ");
2946         APPEND (gstring, mode_string->str);
2947         FREE (mode_string);
2948         APPEND (gstring, ";\n");
2949       }
2950
2951   APPEND (gstring, "END;\n");
2952   spec_module_generated = 1;
2953
2954   /* initialize this for next spec module */
2955   grant_all_seen = 0;
2956 }
2957 \f
2958 /*
2959  * after the dark comes, after all of the modules are at rest,
2960  * we tuck the compilation unit to bed...  A story in pass 1
2961  * and a hug-and-a-kiss goodnight in pass 2.
2962  */
2963 void
2964 chill_finish_compile ()
2965 {
2966   tree global_list;
2967   tree chill_init_function;
2968
2969   tasking_setup ();
2970   build_enum_tables ();
2971
2972   /* We only need an initializer function for the source file if
2973      a) there's module-level code to be called, or
2974      b) tasking-related stuff to be initialized. */
2975   if (module_init_list != NULL_TREE || tasking_list != NULL_TREE)
2976     {
2977       extern tree initializer_type;
2978       static tree chill_init_name;
2979
2980       /* declare the global initializer list */
2981       global_list = do_decl (get_identifier ("_ch_init_list"),
2982                              build_chill_pointer_type (initializer_type), 1, 0,
2983                              NULL_TREE, 1);
2984
2985       /* Now, we're building the function which is the *real*
2986          constructor - if there's any module-level code in this
2987          source file, the compiler puts the file's initializer entry
2988          onto the global initializer list, so each module's body code
2989          will eventually get called, after all of the processes have
2990          been started up.  */
2991
2992       /* This is better done in pass 2 (when first_global_object_name
2993          may have been set), but that is too late.
2994          Perhaps rewrite this so nothing is done in pass 1. */
2995       if (pass == 1)
2996         {
2997           /* If we don't do this spoof, we get the name of the first
2998              tasking_code variable, and not the file name. */
2999           char *q;
3000           const char *tmp = first_global_object_name;
3001           first_global_object_name = NULL;
3002           chill_init_name = get_file_function_name ('I');
3003           first_global_object_name = tmp;
3004
3005           /* strip off the file's extension, if any. */
3006           q = strrchr (IDENTIFIER_POINTER (chill_init_name), '.');
3007           if (q)
3008             *q = '\0';
3009         }
3010
3011       start_chill_function (chill_init_name, void_type_node, NULL_TREE,
3012                             NULL_TREE, NULL_TREE);
3013       TREE_PUBLIC (current_function_decl) = 1;
3014       chill_init_function = current_function_decl;
3015
3016       /* For each module that we've compiled, that had module-level
3017          code to be called, add its entry to the global initializer
3018          list. */
3019
3020       if (pass == 2)
3021         {
3022           tree module_init;
3023
3024           for (module_init = module_init_list;
3025                module_init != NULL_TREE;
3026                module_init = TREE_CHAIN (module_init))
3027             {
3028               tree init_entry      = TREE_VALUE (module_init);
3029
3030               /* assign module_entry.next := _ch_init_list; */
3031               expand_expr_stmt (
3032                 build_chill_modify_expr (
3033                   build_component_ref (init_entry,
3034                     get_identifier ("__INIT_NEXT")),
3035                       global_list));
3036
3037               /* assign _ch_init_list := &module_entry; */
3038               expand_expr_stmt (
3039                 build_chill_modify_expr (global_list,
3040                   build1 (ADDR_EXPR, ptr_type_node, init_entry)));
3041             }
3042         }
3043
3044       tasking_registry ();
3045
3046       make_decl_rtl (current_function_decl, NULL, 1);
3047
3048       finish_chill_function ();
3049
3050       if (pass == 2 && targetm.have_ctors_dtors)
3051         (* targetm.asm_out.constructor)
3052           (XEXP (DECL_RTL (chill_init_function), 0), DEFAULT_INIT_PRIORITY);
3053
3054       /* ready now to link decls onto this list in pass 2. */
3055       module_init_list = NULL_TREE;
3056       tasking_list = NULL_TREE;
3057     }
3058 }
3059
3060