gcc/ch/grant.c

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