gcc/ch/grant.c

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