gcc/ch/inout.c

   1 /* Implement I/O-related actions for CHILL.
   2    Copyright (C) 1992, 93, 94, 98, 99, 2000 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 "rtl.h"
  26 #include "lex.h"
  27 #include "flags.h"
  28 #include "input.h"
  29 #include "assert.h"
  30 #include "toplev.h"
  31
  32 /* set non-zero if input text is forced to lowercase */
  33 extern int ignore_case;
  34
  35 /* set non-zero if special words are to be entered in uppercase */
  36 extern int special_UC;
  37
  38 static int intsize_of_charsexpr         PARAMS ((tree));
  39 static tree add_enum_to_list            PARAMS ((tree, tree));
  40 static void build_chill_io_list_type    PARAMS ((void));
  41 static void build_io_types              PARAMS ((void));
  42 static void declare_predefined_file     PARAMS ((const char *, const char *));
  43 static tree build_access_part           PARAMS ((void));
  44 static tree textlocation_mode           PARAMS ((tree));
  45 static int check_assoc                  PARAMS ((tree, int, const char *));
  46 static tree assoc_call                  PARAMS ((tree, tree, const char *));
  47 static int check_transfer               PARAMS ((tree, int, const char *));
  48 static int connect_process_optionals    PARAMS ((tree, tree *, tree *, tree));
  49 static tree connect_text                PARAMS ((tree, tree, tree, tree));
  50 static tree connect_access              PARAMS ((tree, tree, tree, tree));
  51 static int check_access                 PARAMS ((tree, int, const char *));
  52 static int check_text                   PARAMS ((tree, int, const char *));
  53 static tree get_final_type_and_range    PARAMS ((tree, tree *, tree *));
  54 static void process_io_list             PARAMS ((tree, tree *, tree *, rtx *,
  55                                                 int, int));
  56 static void check_format_string         PARAMS ((tree, tree, int));
  57 static int get_max_size                 PARAMS ((tree));
  58
  59 /* association mode */
  60 tree association_type_node;
  61 /* initialzier for association mode */
  62 tree association_init_value;
  63
  64 /* NOTE: should be same as in runtime/chillrt0.c */
  65 #define STDIO_TEXT_LENGTH    1024
  66 /* mode of stdout, stdin, stderr*/
  67 static tree stdio_type_node;
  68
  69 /* usage- and where modes */
  70 tree usage_type_node;
  71 tree where_type_node;
  72
  73 /* we have to distinguish between io-list-type for WRITETEXT
  74    and for READTEXT. WRITETEXT does not process ranges and
  75    READTEXT must get pointers to the variables.
  76    */
  77 /* variable to hold the type of the io_list */
  78 static tree chill_io_list_type = NULL_TREE;
  79
  80 /* the type for the enum tables */
  81 static tree enum_table_type = NULL_TREE;
  82
  83 /* structure to save enums for later use in compilation */
  84 typedef struct save_enum_names
  85 {
  86   struct save_enum_names  *forward;
  87   tree                    name;
  88   tree                    decl;
  89 } SAVE_ENUM_NAMES;
  90
  91 static SAVE_ENUM_NAMES *used_enum_names = (SAVE_ENUM_NAMES *)0;
  92
  93 typedef struct save_enum_values
  94 {
  95   long                    val;
  96   struct save_enum_names  *name;
  97 } SAVE_ENUM_VALUES;
  98
  99 typedef struct save_enums
 100 {
 101   struct save_enums       *forward;
 102   tree                    context;
 103   tree                    type;
 104   tree                    ptrdecl;
 105   long                    num_vals;
 106   struct save_enum_values *vals;
 107 } SAVE_ENUMS;
 108
 109 static SAVE_ENUMS       *used_enums = (SAVE_ENUMS *)0;
 110
 111 \f
 112 /* Function collects all enums are necessary to collect, makes a copy of
 113    the value and returns a VAR_DECL external to current function describing
 114    the pointer to a name table, which will be generated at the end of
 115    compilation
 116    */
 117
 118 static tree add_enum_to_list (type, context)
 119      tree  type;
 120      tree  context;
 121 {
 122   tree          tmp;
 123   SAVE_ENUMS            *wrk = used_enums;
 124   SAVE_ENUM_VALUES      *vals;
 125   SAVE_ENUM_NAMES       *names;
 126
 127   while (wrk != (SAVE_ENUMS *)0)
 128     {
 129       /* search for this enum already in use */
 130       if (wrk->context == context && wrk->type == type)
 131         {
 132           /* yes, found. look if the ptrdecl is valid in this scope */
 133           tree   var  = DECL_NAME (wrk->ptrdecl);
 134           tree   decl = lookup_name (var);
 135
 136           if (decl == NULL_TREE)
 137             {
 138               /* no, not valid in this context, declare it */
 139               decl = decl_temp1 (var, build_pointer_type (TREE_TYPE (enum_table_type)),
 140                                  0, NULL_TREE, 1, 0);
 141             }
 142           return decl;
 143         }
 144
 145       /* next one */
 146       wrk = wrk->forward;
 147     }
 148
 149   /* not yet found -- generate an entry */
 150   wrk = (SAVE_ENUMS *)xmalloc (sizeof (SAVE_ENUMS));
 151   wrk->forward = used_enums;
 152   used_enums = wrk;
 153
 154   /* generate the pointer decl */
 155   wrk->ptrdecl = get_unique_identifier ("ENUMTABPTR");
 156   wrk->ptrdecl = decl_temp1 (wrk->ptrdecl, build_pointer_type (TREE_TYPE (enum_table_type)),
 157                              0, NULL_TREE, 1, 0);
 158
 159   /* save information for later use */
 160   wrk->context = context;
 161   wrk->type = type;
 162
 163   /* insert the names and values */
 164   tmp = TYPE_FIELDS (type);
 165   wrk->num_vals = list_length (tmp);
 166   vals = (SAVE_ENUM_VALUES *)xmalloc (sizeof (SAVE_ENUM_VALUES) * wrk->num_vals);
 167   wrk->vals = vals;
 168
 169   while (tmp != NULL_TREE)
 170     {
 171       /* search if name is already in use */
 172       names = used_enum_names;
 173       while (names != (SAVE_ENUM_NAMES *)0)
 174         {
 175           if (names->name == TREE_PURPOSE (tmp))
 176             break;
 177           names = names->forward;
 178         }
 179       if (names == (SAVE_ENUM_NAMES *)0)
 180         {
 181           /* we have to insert one */
 182           names = (SAVE_ENUM_NAMES *)xmalloc (sizeof (SAVE_ENUM_NAMES));
 183           names->forward = used_enum_names;
 184           used_enum_names = names;
 185           names->decl = NULL_TREE;
 186           names->name = TREE_PURPOSE (tmp);
 187         }
 188       vals->name = names;
 189       vals->val = TREE_INT_CST_LOW (TREE_VALUE (tmp));
 190
 191       /* next entry in enum */
 192       vals++;
 193       tmp = TREE_CHAIN (tmp);
 194     }
 195
 196   /* return the generated decl */
 197   return wrk->ptrdecl;
 198 }
 199
 200 \f
 201 static void
 202 build_chill_io_list_type ()
 203 {
 204   tree list = NULL_TREE;
 205   tree result, enum1, listbase;
 206   tree io_descriptor;
 207   tree decl1, decl2;
 208   tree forcharstring, forset_W, forset_R, forboolrange;
 209
 210   tree forintrange, intunion, forsetrange, forcharrange;
 211   tree long_type, ulong_type, union_type;
 212
 213   long_type = long_integer_type_node;
 214   ulong_type = long_unsigned_type_node;
 215
 216   if (chill_io_list_type != NULL_TREE)
 217     /* already done */
 218     return;
 219
 220   /* first build the enum for the desriptor */
 221   enum1 = start_enum (NULL_TREE);
 222   result = build_enumerator (get_identifier ("__IO_UNUSED"),
 223                              NULL_TREE);
 224   list = chainon (result, list);
 225
 226   result = build_enumerator (get_identifier ("__IO_ByteVal"),
 227                              NULL_TREE);
 228   list = chainon (result, list);
 229
 230   result = build_enumerator (get_identifier ("__IO_UByteVal"),
 231                              NULL_TREE);
 232   list = chainon (result, list);
 233
 234   result = build_enumerator (get_identifier ("__IO_IntVal"),
 235                              NULL_TREE);
 236   list = chainon (result, list);
 237
 238   result = build_enumerator (get_identifier ("__IO_UIntVal"),
 239                              NULL_TREE);
 240   list = chainon (result, list);
 241
 242   result = build_enumerator (get_identifier ("__IO_LongVal"),
 243                              NULL_TREE);
 244   list = chainon (result, list);
 245
 246   result = build_enumerator (get_identifier ("__IO_ULongVal"),
 247                              NULL_TREE);
 248   list = chainon (result, list);
 249
 250   result = build_enumerator (get_identifier ("__IO_ByteLoc"),
 251                              NULL_TREE);
 252   list = chainon (result, list);
 253
 254   result = build_enumerator (get_identifier ("__IO_UByteLoc"),
 255                              NULL_TREE);
 256   list = chainon (result, list);
 257
 258   result = build_enumerator (get_identifier ("__IO_IntLoc"),
 259                              NULL_TREE);
 260   list = chainon (result, list);
 261
 262   result = build_enumerator (get_identifier ("__IO_UIntLoc"),
 263                              NULL_TREE);
 264   list = chainon (result, list);
 265
 266   result = build_enumerator (get_identifier ("__IO_LongLoc"),
 267                              NULL_TREE);
 268   list = chainon (result, list);
 269
 270   result = build_enumerator (get_identifier ("__IO_ULongLoc"),
 271                              NULL_TREE);
 272   list = chainon (result, list);
 273
 274   result = build_enumerator (get_identifier ("__IO_ByteRangeLoc"),
 275                              NULL_TREE);
 276   list = chainon (result, list);
 277
 278   result = build_enumerator (get_identifier ("__IO_UByteRangeLoc"),
 279                              NULL_TREE);
 280   list = chainon (result, list);
 281
 282   result = build_enumerator (get_identifier ("__IO_IntRangeLoc"),
 283                              NULL_TREE);
 284   list = chainon (result, list);
 285
 286   result = build_enumerator (get_identifier ("__IO_UIntRangeLoc"),
 287                              NULL_TREE);
 288   list = chainon (result, list);
 289
 290   result = build_enumerator (get_identifier ("__IO_LongRangeLoc"),
 291                              NULL_TREE);
 292   list = chainon (result, list);
 293
 294   result = build_enumerator (get_identifier ("__IO_ULongRangeLoc"),
 295                              NULL_TREE);
 296   list = chainon (result, list);
 297
 298   result = build_enumerator (get_identifier ("__IO_BoolVal"),
 299                              NULL_TREE);
 300   list = chainon (result, list);
 301
 302   result = build_enumerator (get_identifier ("__IO_BoolLoc"),
 303                              NULL_TREE);
 304   list = chainon (result, list);
 305
 306   result = build_enumerator (get_identifier ("__IO_BoolRangeLoc"),
 307                              NULL_TREE);
 308   list = chainon (result, list);
 309
 310   result = build_enumerator (get_identifier ("__IO_SetVal"),
 311                              NULL_TREE);
 312   list = chainon (result, list);
 313
 314   result = build_enumerator (get_identifier ("__IO_SetLoc"),
 315                              NULL_TREE);
 316   list = chainon (result, list);
 317
 318   result = build_enumerator (get_identifier ("__IO_SetRangeLoc"),
 319                              NULL_TREE);
 320   list = chainon (result, list);
 321
 322   result = build_enumerator (get_identifier ("__IO_CharVal"),
 323                              NULL_TREE);
 324   list = chainon (result, list);
 325
 326   result = build_enumerator (get_identifier ("__IO_CharLoc"),
 327                              NULL_TREE);
 328   list = chainon (result, list);
 329
 330   result = build_enumerator (get_identifier ("__IO_CharRangeLoc"),
 331                              NULL_TREE);
 332   list = chainon (result, list);
 333
 334   result = build_enumerator (get_identifier ("__IO_CharStrLoc"),
 335                              NULL_TREE);
 336   list = chainon (result, list);
 337
 338   result = build_enumerator (get_identifier ("__IO_CharVaryingLoc"),
 339                              NULL_TREE);
 340   list = chainon (result, list);
 341
 342   result = build_enumerator (get_identifier ("__IO_BitStrLoc"),
 343                              NULL_TREE);
 344   list = chainon (result, list);
 345
 346   result = build_enumerator (get_identifier ("__IO_RealVal"),
 347                              NULL_TREE);
 348   list = chainon (result, list);
 349
 350   result = build_enumerator (get_identifier ("__IO_RealLoc"),
 351                              NULL_TREE);
 352   list = chainon (result, list);
 353
 354   result = build_enumerator (get_identifier ("__IO_LongRealVal"),
 355                              NULL_TREE);
 356   list = chainon (result, list);
 357
 358   result = build_enumerator (get_identifier ("__IO_LongRealLoc"),
 359                              NULL_TREE);
 360   list = chainon (result, list);
 361 #if 0
 362   result = build_enumerator (get_identifier ("_IO_Pointer"),
 363                              NULL_TREE);
 364   list = chainon (result, list);
 365 #endif
 366
 367   result = finish_enum (enum1, list);
 368   pushdecl (io_descriptor = build_decl (TYPE_DECL,
 369                                         get_identifier ("__tmp_IO_enum"),
 370                                         result));
 371   /* prevent seizing/granting of the decl */
 372   DECL_SOURCE_LINE (io_descriptor) = 0;
 373   satisfy_decl (io_descriptor, 0);
 374
 375   /* build type for enum_tables */
 376   decl1 = build_decl (FIELD_DECL, get_identifier ("value"),
 377                       long_type);
 378   DECL_INITIAL (decl1) = NULL_TREE;
 379   decl2 = build_decl (FIELD_DECL, get_identifier ("name"),
 380                       build_pointer_type (char_type_node));
 381   DECL_INITIAL (decl2) = NULL_TREE;
 382   TREE_CHAIN (decl1) = decl2;
 383   TREE_CHAIN (decl2) = NULL_TREE;
 384   result = build_chill_struct_type (decl1);
 385   pushdecl (enum_table_type = build_decl (TYPE_DECL,
 386                                           get_identifier ("__tmp_IO_enum_table_type"),
 387                                           result));
 388   DECL_SOURCE_LINE (enum_table_type) = 0;
 389   satisfy_decl (enum_table_type, 0);
 390
 391   /* build type for writing a set mode */
 392   decl1 = build_decl (FIELD_DECL, get_identifier ("value"),
 393                       long_type);
 394   DECL_INITIAL (decl1) = NULL_TREE;
 395   listbase = decl1;
 396
 397   decl2 = build_decl (FIELD_DECL, get_identifier ("name_table"),
 398                       build_pointer_type (TREE_TYPE (enum_table_type)));
 399   DECL_INITIAL (decl2) = NULL_TREE;
 400   TREE_CHAIN (decl1) = decl2;
 401   decl1 = decl2;
 402   TREE_CHAIN (decl2) = NULL_TREE;
 403
 404   result = build_chill_struct_type (listbase);
 405   pushdecl (forset_W = build_decl (TYPE_DECL,
 406                                    get_identifier ("__tmp_WIO_set"),
 407                                    result));
 408   DECL_SOURCE_LINE (forset_W) = 0;
 409   satisfy_decl (forset_W, 0);
 410
 411   /* build type for charrange */
 412   decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"),
 413                       build_pointer_type (char_type_node));
 414   DECL_INITIAL (decl1) = NULL_TREE;
 415   listbase = decl1;
 416
 417   decl2 = build_decl (FIELD_DECL, get_identifier ("lower"),
 418                       long_type);
 419   DECL_INITIAL (decl2) = NULL_TREE;
 420   TREE_CHAIN (decl1) = decl2;
 421   decl1 = decl2;
 422
 423   decl2 = build_decl (FIELD_DECL, get_identifier ("upper"),
 424                       long_type);
 425   DECL_INITIAL (decl2) = NULL_TREE;
 426   TREE_CHAIN (decl1) = decl2;
 427   TREE_CHAIN (decl2) = NULL_TREE;
 428
 429   result = build_chill_struct_type (listbase);
 430   pushdecl (forcharrange = build_decl (TYPE_DECL,
 431                                        get_identifier ("__tmp_IO_charrange"),
 432                                        result));
 433   DECL_SOURCE_LINE (forcharrange) = 0;
 434   satisfy_decl (forcharrange, 0);
 435
 436   /* type for integer range */
 437   decl1 = build_tree_list (NULL_TREE,
 438                            build_decl (FIELD_DECL,
 439                                        get_identifier ("_slong"),
 440                                        long_type));
 441   listbase = decl1;
 442
 443   decl2 = build_tree_list (NULL_TREE,
 444                            build_decl (FIELD_DECL,
 445                                        get_identifier ("_ulong"),
 446                                        ulong_type));
 447   TREE_CHAIN (decl1) = decl2;
 448   TREE_CHAIN (decl2) = NULL_TREE;
 449
 450   decl1 = grok_chill_variantdefs (NULL_TREE, listbase, NULL_TREE);
 451   TREE_CHAIN (decl1) = NULL_TREE;
 452   result = build_chill_struct_type (decl1);
 453   pushdecl (intunion = build_decl (TYPE_DECL,
 454                                    get_identifier ("__tmp_IO_long"),
 455                                    result));
 456   DECL_SOURCE_LINE (intunion) = 0;
 457   satisfy_decl (intunion, 0);
 458
 459   decl1 = build_decl (FIELD_DECL,
 460                       get_identifier ("ptr"),
 461                       ptr_type_node);
 462   listbase = decl1;
 463
 464   decl2 = build_decl (FIELD_DECL,
 465                       get_identifier ("lower"),
 466                       TREE_TYPE (intunion));
 467   TREE_CHAIN (decl1) = decl2;
 468   decl1 = decl2;
 469
 470   decl2 = build_decl (FIELD_DECL,
 471                       get_identifier ("upper"),
 472                       TREE_TYPE (intunion));
 473   TREE_CHAIN (decl1) = decl2;
 474   TREE_CHAIN (decl2) = NULL_TREE;
 475
 476   result = build_chill_struct_type (listbase);
 477   pushdecl (forintrange = build_decl (TYPE_DECL,
 478                                       get_identifier ("__tmp_IO_intrange"),
 479                                       result));
 480   DECL_SOURCE_LINE (forintrange) = 0;
 481   satisfy_decl (forintrange, 0);
 482
 483   /* build structure for bool range */
 484   decl1 = build_decl (FIELD_DECL,
 485                       get_identifier ("ptr"),
 486                       ptr_type_node);
 487   DECL_INITIAL (decl1) = NULL_TREE;
 488   listbase = decl1;
 489
 490   decl2 = build_decl (FIELD_DECL,
 491                       get_identifier ("lower"),
 492                       ulong_type);
 493   DECL_INITIAL (decl2) = NULL_TREE;
 494   TREE_CHAIN (decl1) = decl2;
 495   decl1 = decl2;
 496
 497   decl2 = build_decl (FIELD_DECL,
 498                       get_identifier ("upper"),
 499                       ulong_type);
 500   DECL_INITIAL (decl2) = NULL_TREE;
 501   TREE_CHAIN (decl1) = decl2;
 502   TREE_CHAIN (decl2) = NULL_TREE;
 503
 504   result = build_chill_struct_type (listbase);
 505   pushdecl (forboolrange = build_decl (TYPE_DECL,
 506                                        get_identifier ("__tmp_RIO_boolrange"),
 507                                        result));
 508   DECL_SOURCE_LINE (forboolrange) = 0;
 509   satisfy_decl (forboolrange, 0);
 510
 511   /* build type for reading a set */
 512   decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"),
 513                       ptr_type_node);
 514   DECL_INITIAL (decl1) = NULL_TREE;
 515   listbase = decl1;
 516
 517   decl2 = build_decl (FIELD_DECL, get_identifier ("length"),
 518                       long_type);
 519   DECL_INITIAL (decl2) = NULL_TREE;
 520   TREE_CHAIN (decl1) = decl2;
 521   decl1 = decl2;
 522
 523   decl2 = build_decl (FIELD_DECL, get_identifier ("name_table"),
 524                       build_pointer_type (TREE_TYPE (enum_table_type)));
 525   DECL_INITIAL (decl2) = NULL_TREE;
 526   TREE_CHAIN (decl1) = decl2;
 527   TREE_CHAIN (decl2) = NULL_TREE;
 528
 529   result = build_chill_struct_type (listbase);
 530   pushdecl (forset_R = build_decl (TYPE_DECL,
 531                                    get_identifier ("__tmp_RIO_set"),
 532                                    result));
 533   DECL_SOURCE_LINE (forset_R) = 0;
 534   satisfy_decl (forset_R, 0);
 535
 536   /* build type for setrange */
 537   decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"),
 538                       ptr_type_node);
 539   DECL_INITIAL (decl1) = NULL_TREE;
 540   listbase = decl1;
 541
 542   decl2 = build_decl (FIELD_DECL, get_identifier ("length"),
 543                       long_type);
 544   DECL_INITIAL (decl2) = NULL_TREE;
 545   TREE_CHAIN (decl1) = decl2;
 546   decl1 = decl2;
 547
 548   decl2 = build_decl (FIELD_DECL, get_identifier ("name_table"),
 549                       build_pointer_type (TREE_TYPE (enum_table_type)));
 550   DECL_INITIAL (decl2) = NULL_TREE;
 551   TREE_CHAIN (decl1) = decl2;
 552   decl1 = decl2;
 553
 554   decl2 = build_decl (FIELD_DECL, get_identifier ("lower"),
 555                       long_type);
 556   DECL_INITIAL (decl2) = NULL_TREE;
 557   TREE_CHAIN (decl1) = decl2;
 558   decl1 = decl2;
 559
 560   decl2 = build_decl (FIELD_DECL, get_identifier ("upper"),
 561                       long_type);
 562   DECL_INITIAL (decl2) = NULL_TREE;
 563   TREE_CHAIN (decl1) = decl2;
 564   TREE_CHAIN (decl2) = NULL_TREE;
 565
 566   result = build_chill_struct_type (listbase);
 567   pushdecl (forsetrange = build_decl (TYPE_DECL,
 568                                       get_identifier ("__tmp_RIO_setrange"),
 569                                       result));
 570   DECL_SOURCE_LINE (forsetrange) = 0;
 571   satisfy_decl (forsetrange, 0);
 572
 573   /* build structure for character string */
 574   decl1 = build_decl (FIELD_DECL,
 575                       get_identifier ("string"),
 576                       build_pointer_type (char_type_node));
 577   DECL_INITIAL (decl1) = NULL_TREE;
 578   listbase = decl1;
 579
 580   decl2 = build_decl (FIELD_DECL,
 581                       get_identifier ("string_length"),
 582                       ulong_type);
 583   DECL_INITIAL (decl2) = NULL_TREE;
 584   TREE_CHAIN (decl1) = decl2;
 585   decl1 = decl2;
 586   TREE_CHAIN (decl2) = NULL_TREE;
 587
 588   result = build_chill_struct_type (listbase);
 589   pushdecl (forcharstring = build_decl (TYPE_DECL,
 590                                         get_identifier ("__tmp_IO_forcharstring"), result));
 591   DECL_SOURCE_LINE (forcharstring) = 0;
 592   satisfy_decl (forcharstring, 0);
 593
 594   /* build the union */
 595   decl1 = build_tree_list (NULL_TREE,
 596                            build_decl (FIELD_DECL,
 597                                        get_identifier ("__valbyte"),
 598                                        signed_char_type_node));
 599   listbase = decl1;
 600
 601   decl2 = build_tree_list (NULL_TREE,
 602                            build_decl (FIELD_DECL,
 603                                        get_identifier ("__valubyte"),
 604                                        unsigned_char_type_node));
 605   TREE_CHAIN (decl1) = decl2;
 606   decl1 = decl2;
 607
 608   decl2 = build_tree_list (NULL_TREE,
 609                            build_decl (FIELD_DECL,
 610                                        get_identifier ("__valint"),
 611                                        chill_integer_type_node));
 612   TREE_CHAIN (decl1) = decl2;
 613   decl1 = decl2;
 614
 615   decl2 = build_tree_list (NULL_TREE,
 616                            build_decl (FIELD_DECL,
 617                                        get_identifier ("__valuint"),
 618                                        chill_unsigned_type_node));
 619   TREE_CHAIN (decl1) = decl2;
 620   decl1 = decl2;
 621
 622   decl2 = build_tree_list (NULL_TREE,
 623                            build_decl (FIELD_DECL,
 624                                        get_identifier ("__vallong"),
 625                                        long_type));
 626   TREE_CHAIN (decl1) = decl2;
 627   decl1 = decl2;
 628
 629   decl2 = build_tree_list (NULL_TREE,
 630                            build_decl (FIELD_DECL,
 631                                        get_identifier ("__valulong"),
 632                                        ulong_type));
 633   TREE_CHAIN (decl1) = decl2;
 634   decl1 = decl2;
 635
 636   decl2 = build_tree_list (NULL_TREE,
 637                            build_decl (FIELD_DECL,
 638                                        get_identifier ("__locint"),
 639                                        ptr_type_node));
 640   TREE_CHAIN (decl1) = decl2;
 641   decl1 = decl2;
 642
 643   decl2 = build_tree_list (NULL_TREE,
 644                            build_decl (FIELD_DECL,
 645                                        get_identifier ("__locintrange"),
 646                                        TREE_TYPE (forintrange)));
 647   TREE_CHAIN (decl1) = decl2;
 648   decl1 = decl2;
 649
 650   decl2 = build_tree_list (NULL_TREE,
 651                            build_decl (FIELD_DECL,
 652                                        get_identifier ("__valbool"),
 653                                        boolean_type_node));
 654   TREE_CHAIN (decl1) = decl2;
 655   decl1 = decl2;
 656
 657   decl2 = build_tree_list (NULL_TREE,
 658                            build_decl (FIELD_DECL,
 659                                        get_identifier ("__locbool"),
 660                                        build_pointer_type (boolean_type_node)));
 661   TREE_CHAIN (decl1) = decl2;
 662   decl1 = decl2;
 663
 664   decl2 = build_tree_list (NULL_TREE,
 665                            build_decl (FIELD_DECL,
 666                                        get_identifier ("__locboolrange"),
 667                                        TREE_TYPE (forboolrange)));
 668   TREE_CHAIN (decl1) = decl2;
 669   decl1 = decl2;
 670
 671   decl2 = build_tree_list (NULL_TREE,
 672                            build_decl (FIELD_DECL,
 673                                        get_identifier ("__valset"),
 674                                        TREE_TYPE (forset_W)));
 675   TREE_CHAIN (decl1) = decl2;
 676   decl1 = decl2;
 677
 678   decl2 = build_tree_list (NULL_TREE,
 679                            build_decl (FIELD_DECL,
 680                                        get_identifier ("__locset"),
 681                                        TREE_TYPE (forset_R)));
 682   TREE_CHAIN (decl1) = decl2;
 683   decl1 = decl2;
 684
 685   decl2 = build_tree_list (NULL_TREE,
 686                            build_decl (FIELD_DECL,
 687                                        get_identifier ("__locsetrange"),
 688                                        TREE_TYPE (forsetrange)));
 689   TREE_CHAIN (decl1) = decl2;
 690   decl1 = decl2;
 691
 692   decl2 = build_tree_list (NULL_TREE,
 693                            build_decl (FIELD_DECL,
 694                                        get_identifier ("__valchar"),
 695                                        char_type_node));
 696   TREE_CHAIN (decl1) = decl2;
 697   decl1 = decl2;
 698
 699   decl2 = build_tree_list (NULL_TREE,
 700                            build_decl (FIELD_DECL,
 701                                        get_identifier ("__locchar"),
 702                                        build_pointer_type (char_type_node)));
 703   TREE_CHAIN (decl1) = decl2;
 704   decl1 = decl2;
 705
 706   decl2 = build_tree_list (NULL_TREE,
 707                            build_decl (FIELD_DECL,
 708                                        get_identifier ("__loccharrange"),
 709                                        TREE_TYPE (forcharrange)));
 710   TREE_CHAIN (decl1) = decl2;
 711   decl1 = decl2;
 712
 713   decl2 = build_tree_list (NULL_TREE,
 714                            build_decl (FIELD_DECL,
 715                                        get_identifier ("__loccharstring"),
 716                                        TREE_TYPE (forcharstring)));
 717   TREE_CHAIN (decl1) = decl2;
 718   decl1 = decl2;
 719
 720   decl2 = build_tree_list (NULL_TREE,
 721                            build_decl (FIELD_DECL,
 722                                        get_identifier ("__valreal"),
 723                                        float_type_node));
 724   TREE_CHAIN (decl1) = decl2;
 725   decl1 = decl2;
 726
 727   decl2 = build_tree_list (NULL_TREE,
 728                            build_decl (FIELD_DECL,
 729                                        get_identifier ("__locreal"),
 730                                        build_pointer_type (float_type_node)));
 731   TREE_CHAIN (decl1) = decl2;
 732   decl1 = decl2;
 733
 734   decl2 = build_tree_list (NULL_TREE,
 735                            build_decl (FIELD_DECL,
 736                                        get_identifier ("__vallongreal"),
 737                                        double_type_node));
 738   TREE_CHAIN (decl1) = decl2;
 739   decl1 = decl2;
 740
 741   decl2 = build_tree_list (NULL_TREE,
 742                            build_decl (FIELD_DECL,
 743                                        get_identifier ("__loclongreal"),
 744                                        build_pointer_type (double_type_node)));
 745   TREE_CHAIN (decl1) = decl2;
 746   decl1 = decl2;
 747
 748 #if 0
 749   decl2 = build_tree_list (NULL_TREE,
 750                            build_decl (FIELD_DECL,
 751                                        get_identifier ("__forpointer"),
 752                                        ptr_type_node));
 753   TREE_CHAIN (decl1) = decl2;
 754   decl1 = decl2;
 755 #endif
 756
 757   TREE_CHAIN (decl2) = NULL_TREE;
 758
 759   decl1 = grok_chill_variantdefs (NULL_TREE, listbase, NULL_TREE);
 760   TREE_CHAIN (decl1) = NULL_TREE;
 761   result = build_chill_struct_type (decl1);
 762   pushdecl (union_type = build_decl (TYPE_DECL,
 763                                      get_identifier ("__tmp_WIO_union"),
 764                                      result));
 765   DECL_SOURCE_LINE (union_type) = 0;
 766   satisfy_decl (union_type, 0);
 767
 768   /* now build the final structure */
 769   decl1 = build_decl (FIELD_DECL, get_identifier ("__t"),
 770                       TREE_TYPE (union_type));
 771   DECL_INITIAL (decl1) = NULL_TREE;
 772   listbase = decl1;
 773
 774   decl2 = build_decl (FIELD_DECL, get_identifier ("__descr"),
 775                       long_type);
 776
 777   TREE_CHAIN (decl1) = decl2;
 778   TREE_CHAIN (decl2) = NULL_TREE;
 779
 780   result = build_chill_struct_type (listbase);
 781   pushdecl (chill_io_list_type = build_decl (TYPE_DECL,
 782                                              get_identifier ("__tmp_IO_list"),
 783                                              result));
 784   DECL_SOURCE_LINE (chill_io_list_type) = 0;
 785   satisfy_decl (chill_io_list_type, 0);
 786 }
 787 \f
 788 /* build the ASSOCIATION, ACCESS and TEXT mode types */
 789 static void
 790 build_io_types ()
 791 {
 792   tree listbase, decl1, decl2, result, association;
 793   tree acc, txt, tloc;
 794   tree enum1, tmp;
 795
 796   /* the association mode */
 797   listbase = build_decl (FIELD_DECL,
 798                          get_identifier ("flags"),
 799                          long_unsigned_type_node);
 800   DECL_INITIAL (listbase) = NULL_TREE;
 801   decl1 = listbase;
 802
 803   decl2 = build_decl (FIELD_DECL,
 804                       get_identifier ("pathname"),
 805                       ptr_type_node);
 806   DECL_INITIAL (decl2) = NULL_TREE;
 807   TREE_CHAIN (decl1) = decl2;
 808   decl1 = decl2;
 809
 810   decl2 = build_decl (FIELD_DECL,
 811                       get_identifier ("access"),
 812                       ptr_type_node);
 813   DECL_INITIAL (decl2) = NULL_TREE;
 814   TREE_CHAIN (decl1) = decl2;
 815   decl1 = decl2;
 816
 817   decl2 = build_decl (FIELD_DECL,
 818                       get_identifier ("handle"),
 819                       integer_type_node);
 820   DECL_INITIAL (decl2) = NULL_TREE;
 821   TREE_CHAIN (decl1) = decl2;
 822   decl1 = decl2;
 823
 824   decl2 = build_decl (FIELD_DECL,
 825                       get_identifier ("bufptr"),
 826                       ptr_type_node);
 827   DECL_INITIAL (decl2) = NULL_TREE;
 828   TREE_CHAIN (decl1) = decl2;
 829   decl1 = decl2;
 830
 831   decl2 = build_decl (FIELD_DECL,
 832                       get_identifier ("syserrno"),
 833                       long_integer_type_node);
 834   DECL_INITIAL (decl2) = NULL_TREE;
 835   TREE_CHAIN (decl1) = decl2;
 836   decl1 = decl2;
 837
 838   decl2 = build_decl (FIELD_DECL,
 839                       get_identifier ("usage"),
 840                       char_type_node);
 841   DECL_INITIAL (decl2) = NULL_TREE;
 842   TREE_CHAIN (decl1) = decl2;
 843   decl1 = decl2;
 844
 845   decl2 = build_decl (FIELD_DECL,
 846                       get_identifier ("ctl_pre"),
 847                       char_type_node);
 848   DECL_INITIAL (decl2) = NULL_TREE;
 849   TREE_CHAIN (decl1) = decl2;
 850   decl1 = decl2;
 851
 852   decl2 = build_decl (FIELD_DECL,
 853                       get_identifier ("ctl_post"),
 854                       char_type_node);
 855   DECL_INITIAL (decl2) = NULL_TREE;
 856   TREE_CHAIN (decl1) = decl2;
 857   TREE_CHAIN (decl2) = NULL_TREE;
 858
 859   result = build_chill_struct_type (listbase);
 860   pushdecl (association = build_decl (TYPE_DECL,
 861                                       ridpointers[(int)RID_ASSOCIATION],
 862                                       result));
 863   DECL_SOURCE_LINE (association) = 0;
 864   satisfy_decl (association, 0);
 865   association_type_node = TREE_TYPE (association);
 866   TYPE_NAME (association_type_node) = association;
 867   CH_NOVELTY (association_type_node) = association;
 868   CH_TYPE_NONVALUE_P(association_type_node) = 1;
 869   CH_TYPE_NONVALUE_P(association) = 1;
 870
 871   /* initialiser for association type */
 872   tmp = convert (char_type_node, integer_zero_node);
 873   association_init_value =
 874     build_nt (CONSTRUCTOR, NULL_TREE,
 875       tree_cons (NULL_TREE, integer_zero_node,            /* flags */
 876         tree_cons (NULL_TREE, null_pointer_node,          /* pathname */
 877           tree_cons (NULL_TREE, null_pointer_node,        /* access */
 878             tree_cons (NULL_TREE, integer_minus_one_node, /* handle */
 879               tree_cons (NULL_TREE, null_pointer_node,    /* bufptr */
 880                 tree_cons (NULL_TREE, integer_zero_node,  /* syserrno */
 881                   tree_cons (NULL_TREE, tmp,              /* usage */
 882                     tree_cons (NULL_TREE, tmp,            /* ctl_pre */
 883                       tree_cons (NULL_TREE, tmp,          /* ctl_post */
 884                                  NULL_TREE))))))))));
 885
 886   /* the type for stdin, stdout, stderr */
 887   /* text part */
 888   decl1 = build_decl (FIELD_DECL,
 889                       get_identifier ("flags"),
 890                       long_unsigned_type_node);
 891   DECL_INITIAL (decl1) = NULL_TREE;
 892   listbase = decl1;
 893
 894   decl2 = build_decl (FIELD_DECL,
 895                       get_identifier ("text_record"),
 896                       ptr_type_node);
 897   DECL_INITIAL (decl2) = NULL_TREE;
 898   TREE_CHAIN (decl1) = decl2;
 899   decl1 = decl2;
 900
 901   decl2 = build_decl (FIELD_DECL,
 902                       get_identifier ("access_sub"),
 903                       ptr_type_node);
 904   DECL_INITIAL (decl2) = NULL_TREE;
 905   TREE_CHAIN (decl1) = decl2;
 906   decl1 = decl2;
 907
 908   decl2 = build_decl (FIELD_DECL,
 909                       get_identifier ("actual_index"),
 910                       long_unsigned_type_node);
 911   DECL_INITIAL (decl2) = NULL_TREE;
 912   TREE_CHAIN (decl1) = decl2;
 913   TREE_CHAIN (decl2) = NULL_TREE;
 914   txt = build_chill_struct_type (listbase);
 915
 916   /* access part */
 917   decl1 = build_decl (FIELD_DECL,
 918                       get_identifier ("flags"),
 919                       long_unsigned_type_node);
 920   DECL_INITIAL (decl1) = NULL_TREE;
 921   listbase = decl1;
 922
 923   decl2 = build_decl (FIELD_DECL,
 924                       get_identifier ("reclength"),
 925                       long_unsigned_type_node);
 926   DECL_INITIAL (decl2) = NULL_TREE;
 927   TREE_CHAIN (decl1) = decl2;
 928   decl1 = decl2;
 929
 930   decl2 = build_decl (FIELD_DECL,
 931                       get_identifier ("lowindex"),
 932                       long_integer_type_node);
 933   DECL_INITIAL (decl2) = NULL_TREE;
 934   TREE_CHAIN (decl1) = decl2;
 935   decl1 = decl2;
 936
 937   decl2 = build_decl (FIELD_DECL,
 938                       get_identifier ("highindex"),
 939                       long_integer_type_node);
 940   DECL_INITIAL (decl2) = NULL_TREE;
 941   TREE_CHAIN (decl1) = decl2;
 942   decl2 = decl1;
 943
 944   decl2 = build_decl (FIELD_DECL,
 945                       get_identifier ("association"),
 946                       ptr_type_node);
 947   DECL_INITIAL (decl2) = NULL_TREE;
 948   TREE_CHAIN (decl1) = decl2;
 949   decl1 = decl2;
 950
 951   decl2 = build_decl (FIELD_DECL,
 952                       get_identifier ("base"),
 953                       long_unsigned_type_node);
 954   DECL_INITIAL (decl2) = NULL_TREE;
 955   TREE_CHAIN (decl1) = decl2;
 956   decl1 = decl2;
 957
 958   decl2 = build_decl (FIELD_DECL,
 959                       get_identifier ("storelocptr"),
 960                       ptr_type_node);
 961   DECL_INITIAL (decl2) = NULL_TREE;
 962   TREE_CHAIN (decl1) = decl2;
 963   decl1 = decl2;
 964
 965   decl2 = build_decl (FIELD_DECL,
 966                       get_identifier ("rectype"),
 967                       long_integer_type_node);
 968   DECL_INITIAL (decl2) = NULL_TREE;
 969   TREE_CHAIN (decl1) = decl2;
 970   TREE_CHAIN (decl2) = NULL_TREE;
 971   acc = build_chill_struct_type (listbase);
 972
 973   /* the location */
 974   tmp = build_string_type (char_type_node, build_int_2 (STDIO_TEXT_LENGTH, 0));
 975   tloc = build_varying_struct (tmp);
 976
 977   /* now the final mode */
 978   decl1 = build_decl (FIELD_DECL, get_identifier ("txt"), txt);
 979   listbase = decl1;
 980
 981   decl2 = build_decl (FIELD_DECL, get_identifier ("acc"), acc);
 982   TREE_CHAIN (decl1) = decl2;
 983   decl1 = decl2;
 984
 985   decl2 = build_decl (FIELD_DECL, get_identifier ("tloc"), tloc);
 986   TREE_CHAIN (decl1) = decl2;
 987   decl1 = decl2;
 988
 989   decl2 = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"),
 990                            void_type_node);
 991   TREE_CHAIN (decl1) = decl2;
 992   decl1 = decl2;
 993
 994   decl2 = build_decl (CONST_DECL, get_identifier ("__textlength"),
 995                       integer_type_node);
 996   DECL_INITIAL (decl2) = build_int_2 (STDIO_TEXT_LENGTH, 0);
 997   TREE_CHAIN (decl1) = decl2;
 998   decl1 = decl2;
 999
1000   decl2 = build_decl (CONST_DECL, get_identifier ("__dynamic"),
1001                       integer_type_node);
1002   DECL_INITIAL (decl2) = integer_zero_node;
1003   TREE_CHAIN (decl1) = decl2;
1004   TREE_CHAIN (decl2) = NULL_TREE;
1005
1006   result = build_chill_struct_type (listbase);
1007   pushdecl (tmp = build_decl (TYPE_DECL,
1008                               get_identifier ("__stdio_text"),
1009                               result));
1010   DECL_SOURCE_LINE (tmp) = 0;
1011   satisfy_decl (tmp, 0);
1012   stdio_type_node = TREE_TYPE (tmp);
1013   CH_IS_TEXT_MODE (stdio_type_node) = 1;
1014
1015   /* predefined usage mode */
1016   enum1 = start_enum (NULL_TREE);
1017   listbase = NULL_TREE;
1018   result = build_enumerator (
1019             get_identifier ((ignore_case || ! special_UC) ? "readonly" : "READONLY"),
1020                              NULL_TREE);
1021   listbase = chainon (result, listbase);
1022   result = build_enumerator (
1023             get_identifier ((ignore_case || ! special_UC) ? "writeonly" : "WRITEONLY"),
1024                              NULL_TREE);
1025   listbase = chainon (result, listbase);
1026   result = build_enumerator (
1027             get_identifier ((ignore_case || ! special_UC) ? "readwrite" : "READWRITE"),
1028                              NULL_TREE);
1029   listbase = chainon (result, listbase);
1030   result = finish_enum (enum1, listbase);
1031   pushdecl (tmp = build_decl (TYPE_DECL,
1032                               get_identifier ((ignore_case || ! special_UC) ? "usage" : "USAGE"),
1033                               result));
1034   DECL_SOURCE_LINE (tmp) = 0;
1035   satisfy_decl (tmp, 0);
1036   usage_type_node = TREE_TYPE (tmp);
1037   TYPE_NAME (usage_type_node) = tmp;
1038   CH_NOVELTY (usage_type_node) = tmp;
1039
1040   /* predefined where mode */
1041   enum1 = start_enum (NULL_TREE);
1042   listbase = NULL_TREE;
1043   result = build_enumerator (
1044             get_identifier ((ignore_case || ! special_UC) ? "first" : "FIRST"),
1045                              NULL_TREE);
1046   listbase = chainon (result, listbase);
1047   result = build_enumerator (
1048             get_identifier ((ignore_case || ! special_UC) ? "same" : "SAME"),
1049                              NULL_TREE);
1050   listbase = chainon (result, listbase);
1051   result = build_enumerator (
1052             get_identifier ((ignore_case || ! special_UC) ? "last" : "LAST"),
1053                              NULL_TREE);
1054   listbase = chainon (result, listbase);
1055   result = finish_enum (enum1, listbase);
1056   pushdecl (tmp = build_decl (TYPE_DECL,
1057                               get_identifier ((ignore_case || ! special_UC) ? "where" : "WHERE"),
1058                               result));
1059   DECL_SOURCE_LINE (tmp) = 0;
1060   satisfy_decl (tmp, 0);
1061   where_type_node = TREE_TYPE (tmp);
1062   TYPE_NAME (where_type_node) = tmp;
1063   CH_NOVELTY (where_type_node) = tmp;
1064 }
1065 \f
1066 static void
1067 declare_predefined_file (name, assembler_name)
1068      const char *name;
1069      const char *assembler_name;
1070 {
1071   tree decl = build_lang_decl (VAR_DECL, get_identifier (name),
1072                                stdio_type_node);
1073   DECL_ASSEMBLER_NAME (decl) = get_identifier(assembler_name);
1074   TREE_STATIC (decl) = 1;
1075   TREE_PUBLIC (decl) = 1;
1076   DECL_EXTERNAL (decl) = 1;
1077   DECL_IN_SYSTEM_HEADER (decl) = 1;
1078   make_decl_rtl (decl, 0, 1);
1079   pushdecl (decl);
1080 }
1081 \f
1082
1083 /* initialisation of all IO/related functions, types, etc. */
1084 void
1085 inout_init ()
1086 {
1087   /* We temporarily reset the maximum_field_alignment to zero so the
1088      compiler's init data structures can be compatible with the
1089      run-time system, even when we're compiling with -fpack. */
1090   unsigned int save_maximum_field_alignment = maximum_field_alignment;
1091
1092   extern tree chill_predefined_function_type;
1093   tree endlink = void_list_node;
1094   tree bool_ftype_ptr_ptr_int;
1095   tree ptr_ftype_ptr_ptr_int;
1096   tree luns_ftype_ptr_ptr_int;
1097   tree int_ftype_ptr_ptr_int;
1098   tree ptr_ftype_ptr_ptr_int_ptr_int_ptr_int;
1099   tree void_ftype_ptr_ptr_int_ptr_int_ptr_int;
1100   tree void_ftype_ptr_ptr_int;
1101   tree void_ftype_ptr_ptr_int_int_int_long_ptr_int;
1102   tree ptr_ftype_ptr_int_ptr_ptr_int;
1103   tree void_ftype_ptr_int_ptr_luns_ptr_int;
1104   tree void_ftype_ptr_ptr_ptr_int;
1105   tree void_ftype_ptr_int_ptr_int;
1106   tree void_ftype_ptr_int_ptr_int_ptr_int_ptr_int;
1107
1108   maximum_field_alignment = 0;
1109
1110   builtin_function ((ignore_case || ! special_UC) ? "associate" : "ASSOCIATE",
1111                     chill_predefined_function_type,
1112                     BUILT_IN_ASSOCIATE, BUILT_IN_NORMAL, NULL_PTR);
1113   builtin_function ((ignore_case || ! special_UC) ? "connect" : "CONNECT",
1114                     chill_predefined_function_type,
1115                     BUILT_IN_CONNECT, BUILT_IN_NORMAL, NULL_PTR);
1116   builtin_function ((ignore_case || ! special_UC) ? "create" : "CREATE",
1117                     chill_predefined_function_type,
1118                     BUILT_IN_CREATE, BUILT_IN_NORMAL, NULL_PTR);
1119   builtin_function ((ignore_case || ! special_UC) ? "delete" : "DELETE",
1120                     chill_predefined_function_type,
1121                     BUILT_IN_CH_DELETE, BUILT_IN_NORMAL, NULL_PTR);
1122   builtin_function ((ignore_case || ! special_UC) ? "disconnect" : "DISCONNECT",
1123                     chill_predefined_function_type,
1124                     BUILT_IN_DISCONNECT, BUILT_IN_NORMAL, NULL_PTR);
1125   builtin_function ((ignore_case || ! special_UC) ? "dissociate" : "DISSOCIATE",
1126                     chill_predefined_function_type,
1127                     BUILT_IN_DISSOCIATE, BUILT_IN_NORMAL, NULL_PTR);
1128   builtin_function ((ignore_case || ! special_UC) ? "eoln" : "EOLN",
1129                     chill_predefined_function_type,
1130                     BUILT_IN_EOLN, BUILT_IN_NORMAL, NULL_PTR);
1131   builtin_function ((ignore_case || ! special_UC) ? "existing" : "EXISTING",
1132                     chill_predefined_function_type,
1133                     BUILT_IN_EXISTING, BUILT_IN_NORMAL, NULL_PTR);
1134   builtin_function ((ignore_case || ! special_UC) ? "getassociation" : "GETASSOCIATION",
1135                     chill_predefined_function_type,
1136                     BUILT_IN_GETASSOCIATION, BUILT_IN_NORMAL, NULL_PTR);
1137   builtin_function ((ignore_case || ! special_UC) ? "gettextaccess" : "GETTEXTASSCESS",
1138                     chill_predefined_function_type,
1139                     BUILT_IN_GETTEXTACCESS, BUILT_IN_NORMAL, NULL_PTR);
1140   builtin_function ((ignore_case || ! special_UC) ? "gettextindex" : "GETTEXTINDEX",
1141                     chill_predefined_function_type,
1142                     BUILT_IN_GETTEXTINDEX, BUILT_IN_NORMAL, NULL_PTR);
1143   builtin_function ((ignore_case || ! special_UC) ? "gettextrecord" : "GETTEXTRECORD",
1144                     chill_predefined_function_type,
1145                     BUILT_IN_GETTEXTRECORD, BUILT_IN_NORMAL, NULL_PTR);
1146   builtin_function ((ignore_case || ! special_UC) ? "getusage" : "GETUSAGE",
1147                     chill_predefined_function_type,
1148                     BUILT_IN_GETUSAGE, BUILT_IN_NORMAL, NULL_PTR);
1149   builtin_function ((ignore_case || ! special_UC) ? "indexable" : "INDEXABLE",
1150                     chill_predefined_function_type,
1151                     BUILT_IN_INDEXABLE, BUILT_IN_NORMAL, NULL_PTR);
1152   builtin_function ((ignore_case || ! special_UC) ? "isassociated" : "ISASSOCIATED",
1153                     chill_predefined_function_type,
1154                     BUILT_IN_ISASSOCIATED, BUILT_IN_NORMAL, NULL_PTR);
1155   builtin_function ((ignore_case || ! special_UC) ? "modify" : "MODIFY",
1156                     chill_predefined_function_type,
1157                     BUILT_IN_MODIFY, BUILT_IN_NORMAL, NULL_PTR);
1158   builtin_function ((ignore_case || ! special_UC) ? "outoffile" : "OUTOFFILE",
1159                     chill_predefined_function_type,
1160                     BUILT_IN_OUTOFFILE, BUILT_IN_NORMAL, NULL_PTR);
1161   builtin_function ((ignore_case || ! special_UC) ? "readable" : "READABLE",
1162                     chill_predefined_function_type,
1163                     BUILT_IN_READABLE, BUILT_IN_NORMAL, NULL_PTR);
1164   builtin_function ((ignore_case || ! special_UC) ? "readrecord" : "READRECORD",
1165                     chill_predefined_function_type,
1166                     BUILT_IN_READRECORD, BUILT_IN_NORMAL, NULL_PTR);
1167   builtin_function ((ignore_case || ! special_UC) ? "readtext" : "READTEXT",
1168                     chill_predefined_function_type,
1169                     BUILT_IN_READTEXT, BUILT_IN_NORMAL, NULL_PTR);
1170   builtin_function ((ignore_case || ! special_UC) ? "sequencible" : "SEQUENCIBLE",
1171                     chill_predefined_function_type,
1172                     BUILT_IN_SEQUENCIBLE, BUILT_IN_NORMAL, NULL_PTR);
1173   builtin_function ((ignore_case || ! special_UC) ? "settextaccess" : "SETTEXTACCESS",
1174                     chill_predefined_function_type,
1175                     BUILT_IN_SETTEXTACCESS, BUILT_IN_NORMAL, NULL_PTR);
1176   builtin_function ((ignore_case || ! special_UC) ? "settextindex" : "SETTEXTINDEX",
1177                     chill_predefined_function_type,
1178                     BUILT_IN_SETTEXTINDEX, BUILT_IN_NORMAL, NULL_PTR);
1179   builtin_function ((ignore_case || ! special_UC) ? "settextrecord" : "SETTEXTRECORD",
1180                     chill_predefined_function_type,
1181                     BUILT_IN_SETTEXTRECORD, BUILT_IN_NORMAL, NULL_PTR);
1182   builtin_function ((ignore_case || ! special_UC) ? "variable" : "VARIABLE",
1183                     chill_predefined_function_type,
1184                     BUILT_IN_VARIABLE, BUILT_IN_NORMAL, NULL_PTR);
1185   builtin_function ((ignore_case || ! special_UC) ? "writeable" : "WRITEABLE",
1186                     chill_predefined_function_type,
1187                     BUILT_IN_WRITEABLE, BUILT_IN_NORMAL, NULL_PTR);
1188   builtin_function ((ignore_case || ! special_UC) ? "writerecord" : "WRITERECORD",
1189                     chill_predefined_function_type,
1190                     BUILT_IN_WRITERECORD, BUILT_IN_NORMAL, NULL_PTR);
1191   builtin_function ((ignore_case || ! special_UC) ? "writetext" : "WRITETEXT",
1192                     chill_predefined_function_type,
1193                     BUILT_IN_WRITETEXT, BUILT_IN_NORMAL, NULL_PTR);
1194
1195   /* build function prototypes */
1196   bool_ftype_ptr_ptr_int =
1197     build_function_type (boolean_type_node,
1198       tree_cons (NULL_TREE, ptr_type_node,
1199         tree_cons (NULL_TREE, ptr_type_node,
1200           tree_cons (NULL_TREE, integer_type_node,
1201             endlink))));
1202   ptr_ftype_ptr_ptr_int_ptr_int_ptr_int =
1203     build_function_type (ptr_type_node,
1204       tree_cons (NULL_TREE, ptr_type_node,
1205         tree_cons (NULL_TREE, ptr_type_node,
1206           tree_cons (NULL_TREE, integer_type_node,
1207             tree_cons (NULL_TREE, ptr_type_node,
1208               tree_cons (NULL_TREE, integer_type_node,
1209                 tree_cons (NULL_TREE, ptr_type_node,
1210                   tree_cons (NULL_TREE, integer_type_node,
1211                     endlink))))))));
1212   void_ftype_ptr_ptr_int =
1213     build_function_type (void_type_node,
1214       tree_cons (NULL_TREE, ptr_type_node,
1215         tree_cons (NULL_TREE, ptr_type_node,
1216           tree_cons (NULL_TREE, integer_type_node,
1217             endlink))));
1218   void_ftype_ptr_ptr_int_ptr_int_ptr_int =
1219     build_function_type (void_type_node,
1220       tree_cons (NULL_TREE, ptr_type_node,
1221         tree_cons (NULL_TREE, ptr_type_node,
1222           tree_cons (NULL_TREE, integer_type_node,
1223             tree_cons (NULL_TREE, ptr_type_node,
1224               tree_cons (NULL_TREE, integer_type_node,
1225                 tree_cons (NULL_TREE, ptr_type_node,
1226                   tree_cons (NULL_TREE, integer_type_node,
1227                     endlink))))))));
1228   void_ftype_ptr_ptr_int_int_int_long_ptr_int =
1229     build_function_type (void_type_node,
1230       tree_cons (NULL_TREE, ptr_type_node,
1231         tree_cons (NULL_TREE, ptr_type_node,
1232           tree_cons (NULL_TREE, integer_type_node,
1233             tree_cons (NULL_TREE, integer_type_node,
1234               tree_cons (NULL_TREE, integer_type_node,
1235                 tree_cons (NULL_TREE, long_integer_type_node,
1236                   tree_cons (NULL_TREE, ptr_type_node,
1237                     tree_cons (NULL_TREE, integer_type_node,
1238                       endlink)))))))));
1239   ptr_ftype_ptr_ptr_int =
1240     build_function_type (ptr_type_node,
1241       tree_cons (NULL_TREE, ptr_type_node,
1242         tree_cons (NULL_TREE, ptr_type_node,
1243           tree_cons (NULL_TREE, integer_type_node,
1244             endlink))));
1245   int_ftype_ptr_ptr_int =
1246     build_function_type (integer_type_node,
1247       tree_cons (NULL_TREE, ptr_type_node,
1248         tree_cons (NULL_TREE, ptr_type_node,
1249           tree_cons (NULL_TREE, integer_type_node,
1250             endlink))));
1251   ptr_ftype_ptr_int_ptr_ptr_int =
1252     build_function_type (ptr_type_node,
1253       tree_cons (NULL_TREE, ptr_type_node,
1254         tree_cons (NULL_TREE, integer_type_node,
1255           tree_cons (NULL_TREE, ptr_type_node,
1256             tree_cons (NULL_TREE, ptr_type_node,
1257               tree_cons (NULL_TREE, integer_type_node,
1258                 endlink))))));
1259   void_ftype_ptr_int_ptr_luns_ptr_int =
1260     build_function_type (void_type_node,
1261       tree_cons (NULL_TREE, ptr_type_node,
1262         tree_cons (NULL_TREE, integer_type_node,
1263           tree_cons (NULL_TREE, ptr_type_node,
1264             tree_cons (NULL_TREE, long_unsigned_type_node,
1265               tree_cons (NULL_TREE, ptr_type_node,
1266                 tree_cons (NULL_TREE, integer_type_node,
1267                   endlink)))))));
1268   luns_ftype_ptr_ptr_int =
1269     build_function_type (long_unsigned_type_node,
1270       tree_cons (NULL_TREE, ptr_type_node,
1271         tree_cons (NULL_TREE, ptr_type_node,
1272           tree_cons (NULL_TREE, integer_type_node,
1273             endlink))));
1274   void_ftype_ptr_ptr_ptr_int =
1275     build_function_type (void_type_node,
1276       tree_cons (NULL_TREE, ptr_type_node,
1277         tree_cons (NULL_TREE, ptr_type_node,
1278           tree_cons (NULL_TREE, ptr_type_node,
1279             tree_cons (NULL_TREE, integer_type_node,
1280               endlink)))));
1281   void_ftype_ptr_int_ptr_int =
1282     build_function_type (void_type_node,
1283       tree_cons (NULL_TREE, ptr_type_node,
1284         tree_cons (NULL_TREE, integer_type_node,
1285           tree_cons (NULL_TREE, ptr_type_node,
1286             tree_cons (NULL_TREE, integer_type_node,
1287               endlink)))));
1288   void_ftype_ptr_int_ptr_int_ptr_int_ptr_int =
1289     build_function_type (void_type_node,
1290       tree_cons (NULL_TREE, ptr_type_node,
1291         tree_cons (NULL_TREE, integer_type_node,
1292           tree_cons (NULL_TREE, ptr_type_node,
1293             tree_cons (NULL_TREE, integer_type_node,
1294               tree_cons (NULL_TREE, ptr_type_node,
1295                 tree_cons (NULL_TREE, integer_type_node,
1296                   tree_cons (NULL_TREE, ptr_type_node,
1297                     tree_cons (NULL_TREE, integer_type_node,
1298                       endlink)))))))));
1299
1300   builtin_function ("__associate", ptr_ftype_ptr_ptr_int_ptr_int_ptr_int,
1301                     0, NOT_BUILT_IN, NULL_PTR);
1302   builtin_function ("__connect", void_ftype_ptr_ptr_int_int_int_long_ptr_int,
1303                     0, NOT_BUILT_IN, NULL_PTR);
1304   builtin_function ("__create", void_ftype_ptr_ptr_int,
1305                     0, NOT_BUILT_IN, NULL_PTR);
1306   builtin_function ("__delete", void_ftype_ptr_ptr_int,
1307                     0, NOT_BUILT_IN, NULL_PTR);
1308   builtin_function ("__disconnect", void_ftype_ptr_ptr_int,
1309                     0, NOT_BUILT_IN, NULL_PTR);
1310   builtin_function ("__dissociate", void_ftype_ptr_ptr_int,
1311                     0, NOT_BUILT_IN, NULL_PTR);
1312   builtin_function ("__eoln", bool_ftype_ptr_ptr_int,
1313                     0, NOT_BUILT_IN, NULL_PTR);
1314   builtin_function ("__existing", bool_ftype_ptr_ptr_int,
1315                     0, NOT_BUILT_IN, NULL_PTR);
1316   builtin_function ("__getassociation", ptr_ftype_ptr_ptr_int,
1317                     0, NOT_BUILT_IN, NULL_PTR);
1318   builtin_function ("__gettextaccess", ptr_ftype_ptr_ptr_int,
1319                     0, NOT_BUILT_IN, NULL_PTR);
1320   builtin_function ("__gettextindex", luns_ftype_ptr_ptr_int,
1321                     0, NOT_BUILT_IN, NULL_PTR);
1322   builtin_function ("__gettextrecord", ptr_ftype_ptr_ptr_int,
1323                     0, NOT_BUILT_IN, NULL_PTR);
1324   builtin_function ("__getusage", int_ftype_ptr_ptr_int,
1325                     0, NOT_BUILT_IN, NULL_PTR);
1326   builtin_function ("__indexable", bool_ftype_ptr_ptr_int,
1327                     0, NOT_BUILT_IN, NULL_PTR);
1328   builtin_function ("__isassociated", bool_ftype_ptr_ptr_int,
1329                     0, NOT_BUILT_IN, NULL_PTR);
1330   builtin_function ("__modify", void_ftype_ptr_ptr_int_ptr_int_ptr_int,
1331                     0, NOT_BUILT_IN, NULL_PTR);
1332   builtin_function ("__outoffile", bool_ftype_ptr_ptr_int,
1333                     0, NOT_BUILT_IN, NULL_PTR);
1334   builtin_function ("__readable", bool_ftype_ptr_ptr_int,
1335                     0, NOT_BUILT_IN, NULL_PTR);
1336   builtin_function ("__readrecord", ptr_ftype_ptr_int_ptr_ptr_int,
1337                     0, NOT_BUILT_IN, NULL_PTR);
1338   builtin_function ("__readtext_f", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int,
1339                     0, NOT_BUILT_IN, NULL_PTR);
1340   builtin_function ("__readtext_s", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int,
1341                     0, NOT_BUILT_IN, NULL_PTR);
1342   builtin_function ("__sequencible", bool_ftype_ptr_ptr_int,
1343                     0, NOT_BUILT_IN, NULL_PTR);
1344   builtin_function ("__settextaccess", void_ftype_ptr_ptr_ptr_int,
1345                     0, NOT_BUILT_IN, NULL_PTR);
1346   builtin_function ("__settextindex", void_ftype_ptr_int_ptr_int,
1347                     0, NOT_BUILT_IN, NULL_PTR);
1348   builtin_function ("__settextrecord", void_ftype_ptr_ptr_ptr_int,
1349                     0, NOT_BUILT_IN, NULL_PTR);
1350   builtin_function ("__variable", bool_ftype_ptr_ptr_int,
1351                     0, NOT_BUILT_IN, NULL_PTR);
1352   builtin_function ("__writeable", bool_ftype_ptr_ptr_int,
1353                     0, NOT_BUILT_IN, NULL_PTR);
1354   builtin_function ("__writerecord", void_ftype_ptr_int_ptr_luns_ptr_int,
1355                     0, NOT_BUILT_IN, NULL_PTR);
1356   builtin_function ("__writetext_f", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int,
1357                     0, NOT_BUILT_IN, NULL_PTR);
1358   builtin_function ("__writetext_s", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int,
1359                     0, NOT_BUILT_IN, NULL_PTR);
1360
1361   /* declare ASSOCIATION, ACCESS, and TEXT modes */
1362   build_io_types ();
1363
1364   /* declare the predefined text locations */
1365   declare_predefined_file ((ignore_case || ! special_UC) ?  "stdin" : "STDIN",
1366                            "chill_stdin");
1367   declare_predefined_file ((ignore_case || ! special_UC) ?  "stdout" : "STDOUT",
1368                            "chill_stdout");
1369   declare_predefined_file ((ignore_case || ! special_UC) ?  "stderr" : "STDERR",
1370                            "chill_stderr");
1371
1372   /* last, but not least, build the chill IO-list type */
1373   build_chill_io_list_type ();
1374
1375   maximum_field_alignment = save_maximum_field_alignment;
1376 }
1377 \f
1378 /* function returns the recordmode of an ACCESS */
1379 tree
1380 access_recordmode (access)
1381      tree access;
1382 {
1383   tree field;
1384
1385   if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
1386     return NULL_TREE;
1387   if (! CH_IS_ACCESS_MODE (access))
1388     return NULL_TREE;
1389
1390   field = TYPE_FIELDS (access);
1391   for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1392     {
1393       if (TREE_CODE (field) == TYPE_DECL &&
1394           DECL_NAME (field) == get_identifier ("__recordmode"))
1395         return TREE_TYPE (field);
1396     }
1397   return void_type_node;
1398 }
1399
1400 /* function invalidates the recordmode of an ACCESS */
1401 void
1402 invalidate_access_recordmode (access)
1403      tree access;
1404 {
1405   tree field;
1406
1407   if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
1408     return;
1409   if (! CH_IS_ACCESS_MODE (access))
1410     return;
1411
1412   field = TYPE_FIELDS (access);
1413   for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1414     {
1415       if (TREE_CODE (field) == TYPE_DECL &&
1416           DECL_NAME (field) == get_identifier ("__recordmode"))
1417         {
1418           TREE_TYPE (field) = error_mark_node;
1419           return;
1420         }
1421     }
1422 }
1423
1424 /* function returns the index mode of an ACCESS if there is one,
1425    otherwise NULL_TREE */
1426 tree
1427 access_indexmode (access)
1428      tree access;
1429 {
1430   tree field;
1431
1432   if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
1433     return NULL_TREE;
1434   if (! CH_IS_ACCESS_MODE (access))
1435     return NULL_TREE;
1436
1437   field = TYPE_FIELDS (access);
1438   for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1439     {
1440       if (TREE_CODE (field) == TYPE_DECL &&
1441           DECL_NAME (field) == get_identifier ("__indexmode"))
1442         return TREE_TYPE (field);
1443     }
1444   return void_type_node;
1445 }
1446
1447 /* function returns one if an ACCESS was specified DYNAMIC, otherwise zero */
1448 tree
1449 access_dynamic (access)
1450      tree access;
1451 {
1452   tree field;
1453
1454   if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
1455     return NULL_TREE;
1456   if (! CH_IS_ACCESS_MODE (access))
1457     return NULL_TREE;
1458
1459   field = TYPE_FIELDS (access);
1460   for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1461     {
1462       if (TREE_CODE (field) == CONST_DECL)
1463         return DECL_INITIAL (field);
1464     }
1465   return integer_zero_node;
1466 }
1467
1468 #if 0
1469    returns a structure like
1470    STRUCT (data STRUCT (flags ULONG,
1471                         reclength ULONG,
1472                         lowindex LONG,
1473                         highindex LONG,
1474                         association PTR,
1475                         base ULONG,
1476                         store_loc PTR,
1477                         rectype LONG),
1478    this is followed by a
1479    TYPE_DECL __recordmode recordmode ? recordmode : void_type_node
1480    TYPE_DECL __indexmode  indexmode  ? indexmode  : void_type_node
1481    CONST_DECL __dynamic   dynamic ? integer_one_node : integer_zero_node
1482 #endif
1483
1484 static tree
1485 build_access_part ()
1486 {
1487   tree listbase, decl;
1488
1489   listbase = build_decl (FIELD_DECL, get_identifier ("flags"),
1490                          long_unsigned_type_node);
1491   decl = build_decl (FIELD_DECL, get_identifier ("reclength"),
1492                      long_unsigned_type_node);
1493   listbase = chainon (listbase, decl);
1494   decl = build_decl (FIELD_DECL, get_identifier ("lowindex"),
1495                      long_unsigned_type_node);
1496   listbase = chainon (listbase, decl);
1497   decl = build_decl (FIELD_DECL, get_identifier ("highindex"),
1498                      long_integer_type_node);
1499   listbase = chainon (listbase, decl);
1500   decl = build_decl (FIELD_DECL, get_identifier ("association"),
1501                      ptr_type_node);
1502   listbase = chainon (listbase, decl);
1503   decl = build_decl (FIELD_DECL, get_identifier ("base"),
1504                      long_unsigned_type_node);
1505   listbase = chainon (listbase, decl);
1506   decl = build_decl (FIELD_DECL, get_identifier ("storelocptr"),
1507                      ptr_type_node);
1508   listbase = chainon (listbase, decl);
1509   decl = build_decl (FIELD_DECL, get_identifier ("rectype"),
1510                      long_integer_type_node);
1511   listbase = chainon (listbase, decl);
1512   return build_chill_struct_type (listbase);
1513 }
1514
1515 tree
1516 build_access_mode (indexmode, recordmode, dynamic)
1517      tree indexmode;
1518      tree recordmode;
1519      int dynamic;
1520 {
1521   tree type, listbase, decl, datamode;
1522
1523   if (indexmode != NULL_TREE && TREE_CODE (indexmode) == ERROR_MARK)
1524     return error_mark_node;
1525   if (recordmode != NULL_TREE && TREE_CODE (recordmode) == ERROR_MARK)
1526     return error_mark_node;
1527
1528   datamode = build_access_part ();
1529
1530   type = make_node (RECORD_TYPE);
1531   listbase = build_decl (FIELD_DECL, get_identifier ("data"),
1532                          datamode);
1533   TYPE_FIELDS (type) = listbase;
1534   decl = build_lang_decl (TYPE_DECL, get_identifier ("__recordmode"),
1535                           recordmode == NULL_TREE ? void_type_node : recordmode);
1536   chainon (listbase, decl);
1537   decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"),
1538                           indexmode == NULL_TREE ? void_type_node : indexmode);
1539   chainon (listbase, decl);
1540   decl = build_decl (CONST_DECL, get_identifier ("__dynamic"),
1541                      integer_type_node);
1542   DECL_INITIAL (decl) = dynamic ? integer_one_node : integer_zero_node;
1543   chainon (listbase, decl);
1544   CH_IS_ACCESS_MODE (type) = 1;
1545   CH_TYPE_NONVALUE_P (type) = 1;
1546   return type;
1547 }
1548 \f
1549 #if 0
1550   returns a structure like:
1551   STRUCT (txt STRUCT (flags ULONG,
1552                       text_record PTR,
1553                       access_sub PTR,
1554                       actual_index LONG),
1555           acc STRUCT (flags ULONG,
1556                       reclength ULONG,
1557                       lowindex LONG,
1558                       highindex LONG,
1559                       association PTR,
1560                       base ULONG,
1561                       store_loc PTR,
1562                       rectype LONG),
1563           tloc CHARS(textlength) VARYING;
1564           )
1565   followed by
1566   TYPE_DECL __indexmode indexmode ? indexmode : void_type_node
1567   CONST_DECL __text_length
1568   CONST_DECL __dynamic  dynamic ? integer_one_node : integer_zero_node
1569 #endif
1570 tree
1571 build_text_mode (textlength, indexmode, dynamic)
1572      tree textlength;
1573      tree indexmode;
1574      int dynamic;
1575 {
1576   tree txt, acc, listbase, decl, type, tltype;
1577   tree savedlength = textlength;
1578
1579   if (indexmode != NULL_TREE && TREE_CODE (indexmode) == ERROR_MARK)
1580     return error_mark_node;
1581   if (textlength == NULL_TREE || TREE_CODE (textlength) == ERROR_MARK)
1582     return error_mark_node;
1583
1584   /* build the structure */
1585   listbase = build_decl (FIELD_DECL, get_identifier ("flags"),
1586                          long_unsigned_type_node);
1587   decl = build_decl (FIELD_DECL, get_identifier ("text_record"),
1588                      ptr_type_node);
1589   listbase = chainon (listbase, decl);
1590   decl = build_decl (FIELD_DECL, get_identifier ("access_sub"),
1591                      ptr_type_node);
1592   listbase = chainon (listbase, decl);
1593   decl = build_decl (FIELD_DECL, get_identifier ("actual_index"),
1594                      long_integer_type_node);
1595   listbase = chainon (listbase, decl);
1596   txt = build_chill_struct_type (listbase);
1597
1598   acc = build_access_part ();
1599
1600   type = make_node (RECORD_TYPE);
1601   listbase = build_decl (FIELD_DECL, get_identifier ("txt"), txt);
1602   TYPE_FIELDS (type) = listbase;
1603   decl = build_decl (FIELD_DECL, get_identifier ("acc"), acc);
1604   chainon (listbase, decl);
1605   /* the text location */
1606   tltype = build_string_type (char_type_node, textlength);
1607   tltype = build_varying_struct (tltype);
1608   decl = build_decl (FIELD_DECL, get_identifier ("tloc"),
1609                      tltype);
1610   chainon (listbase, decl);
1611   /* the index mode */
1612   decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"),
1613                           indexmode == NULL_TREE ? void_type_node : indexmode);
1614   chainon (listbase, decl);
1615   /* save dynamic */
1616   decl = build_decl (CONST_DECL, get_identifier ("__textlength"),
1617                      integer_type_node);
1618   if (TREE_CODE (textlength) == COMPONENT_REF)
1619     /* FIXME: we cannot use one and the same COMPONENT_REF twice, so build
1620        another one */
1621     savedlength = build_component_ref (TREE_OPERAND (textlength, 0),
1622                                        TREE_OPERAND (textlength, 1));
1623   DECL_INITIAL (decl) = savedlength;
1624   chainon (listbase, decl);
1625   /* save dynamic */
1626   decl = build_decl (CONST_DECL, get_identifier ("__dynamic"),
1627                      integer_type_node);
1628   DECL_INITIAL (decl) = dynamic ? integer_one_node : integer_zero_node;
1629   chainon (listbase, decl);
1630   CH_IS_TEXT_MODE (type) = 1;
1631   CH_TYPE_NONVALUE_P (type) = 1;
1632   return type;
1633 }
1634
1635 tree
1636 check_text_length (length)
1637      tree length;
1638 {
1639   if (length == NULL_TREE || TREE_CODE (length) == ERROR_MARK)
1640     return length;
1641   if (TREE_TYPE (length) == NULL_TREE
1642       || !CH_SIMILAR (TREE_TYPE (length), integer_type_node))
1643     {
1644       error ("non-integral text length");
1645       return integer_one_node;
1646     }
1647   if (TREE_CODE (length) != INTEGER_CST)
1648     {
1649       error ("non-constant text length");
1650       return integer_one_node;
1651     }
1652   if (compare_int_csts (LE_EXPR, length, integer_zero_node))
1653     {
1654       error ("text length must be greater then 0");
1655       return integer_one_node;
1656     }
1657   return length;
1658 }
1659
1660 tree
1661 text_indexmode (text)
1662      tree text;
1663 {
1664   tree field;
1665
1666   if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
1667     return NULL_TREE;
1668   if (! CH_IS_TEXT_MODE (text))
1669     return NULL_TREE;
1670
1671   field = TYPE_FIELDS (text);
1672   for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1673     {
1674       if (TREE_CODE (field) == TYPE_DECL)
1675         return TREE_TYPE (field);
1676     }
1677   return void_type_node;
1678 }
1679
1680 tree
1681 text_dynamic (text)
1682      tree text;
1683 {
1684   tree field;
1685
1686   if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
1687     return NULL_TREE;
1688   if (! CH_IS_TEXT_MODE (text))
1689     return NULL_TREE;
1690
1691   field = TYPE_FIELDS (text);
1692   for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1693     {
1694       if (TREE_CODE (field) == CONST_DECL &&
1695           DECL_NAME (field) == get_identifier ("__dynamic"))
1696         return DECL_INITIAL (field);
1697     }
1698   return integer_zero_node;
1699 }
1700
1701 tree
1702 text_length (text)
1703      tree text;
1704 {
1705   tree field;
1706
1707   if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
1708     return NULL_TREE;
1709   if (! CH_IS_TEXT_MODE (text))
1710     return NULL_TREE;
1711
1712   field = TYPE_FIELDS (text);
1713   for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1714     {
1715       if (TREE_CODE (field) == CONST_DECL &&
1716           DECL_NAME (field) == get_identifier ("__textlength"))
1717         return DECL_INITIAL (field);
1718     }
1719   return integer_zero_node;
1720 }
1721
1722 static tree
1723 textlocation_mode (text)
1724      tree text;
1725 {
1726   tree field;
1727
1728   if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
1729     return NULL_TREE;
1730   if (! CH_IS_TEXT_MODE (text))
1731     return NULL_TREE;
1732
1733   field = TYPE_FIELDS (text);
1734   for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1735     {
1736       if (TREE_CODE (field) == FIELD_DECL &&
1737           DECL_NAME (field) == get_identifier ("tloc"))
1738         return TREE_TYPE (field);
1739     }
1740   return NULL_TREE;
1741 }
1742 \f
1743 static int
1744 check_assoc (assoc, argnum, errmsg)
1745      tree assoc;
1746      int argnum;
1747      const char *errmsg;
1748 {
1749   if (assoc == NULL_TREE || TREE_CODE (assoc) == ERROR_MARK)
1750     return 0;
1751
1752   if (! CH_IS_ASSOCIATION_MODE (TREE_TYPE (assoc)))
1753     {
1754       error ("argument %d of %s must be of mode ASSOCIATION", argnum, errmsg);
1755       return 0;
1756     }
1757   if (! CH_LOCATION_P (assoc))
1758     {
1759       error ("argument %d of %s must be a location", argnum, errmsg);
1760       return 0;
1761     }
1762   return 1;
1763 }
1764
1765 tree
1766 build_chill_associate (assoc, fname, attr)
1767      tree assoc;
1768      tree fname;
1769      tree attr;
1770 {
1771   tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE, arg4 = NULL_TREE,
1772   arg5 = NULL_TREE, arg6, arg7;
1773   int had_errors = 0;
1774   tree result;
1775
1776   /* make some checks */
1777   if (fname == NULL_TREE || TREE_CODE (fname) == ERROR_MARK)
1778     return error_mark_node;
1779
1780   /* check the association */
1781   if (! check_assoc (assoc, 1, "ASSOCIATION"))
1782     had_errors = 1;
1783   else
1784     /* build a pointer to the association */
1785     arg1 = force_addr_of (assoc);
1786
1787   /* check the filename, must be a string */
1788   if (CH_CHARS_TYPE_P (TREE_TYPE (fname)) ||
1789       (flag_old_strings && TREE_CODE (fname) == INTEGER_CST &&
1790        TREE_CODE (TREE_TYPE (fname)) == CHAR_TYPE))
1791     {
1792       if (int_size_in_bytes (TREE_TYPE (fname)) == 0)
1793         {
1794           error ("argument 2 of ASSOCIATE must not be an empty string");
1795           had_errors = 1;
1796         }
1797       else
1798         {
1799           arg2 = force_addr_of (fname);
1800           arg3 = size_in_bytes (TREE_TYPE (fname));
1801         }
1802     }
1803   else if (chill_varying_string_type_p (TREE_TYPE (fname)))
1804     {
1805       arg2 = force_addr_of (build_component_ref (fname, var_data_id));
1806       arg3 = build_component_ref (fname, var_length_id);
1807     }
1808   else
1809     {
1810       error ("argument 2 to ASSOCIATE must be a string");
1811       had_errors = 1;
1812     }
1813
1814   /* check attr argument, must be a string too */
1815   if (attr == NULL_TREE)
1816     {
1817       arg4 = null_pointer_node;
1818       arg5 = integer_zero_node;
1819     }
1820   else
1821     {
1822       attr = TREE_VALUE (attr);
1823       if (attr == NULL_TREE || TREE_CODE (attr) == ERROR_MARK)
1824         had_errors = 1;
1825       else
1826         {
1827           if (CH_CHARS_TYPE_P (TREE_TYPE (attr)) ||
1828               (flag_old_strings && TREE_CODE (attr) == INTEGER_CST &&
1829                TREE_CODE (TREE_TYPE (attr)) == CHAR_TYPE))
1830             {
1831               if (int_size_in_bytes (TREE_TYPE (attr)) == 0)
1832                 {
1833                   arg4 = null_pointer_node;
1834                   arg5 = integer_zero_node;
1835                 }
1836               else
1837                 {
1838                   arg4 = force_addr_of (attr);
1839                   arg5 = size_in_bytes (TREE_TYPE (attr));
1840                 }
1841             }
1842           else if (chill_varying_string_type_p (TREE_TYPE (attr)))
1843             {
1844               arg4 = force_addr_of (build_component_ref (attr, var_data_id));
1845               arg5 = build_component_ref (attr, var_length_id);
1846             }
1847           else
1848             {
1849               error ("argument 3 to ASSOCIATE must be a string");
1850               had_errors = 1;
1851             }
1852         }
1853     }
1854
1855   if (had_errors)
1856     return error_mark_node;
1857
1858   /* other arguments */
1859   arg6 = force_addr_of (get_chill_filename ());
1860   arg7 = get_chill_linenumber ();
1861
1862   result = build_chill_function_call (
1863      lookup_name (get_identifier ("__associate")),
1864             tree_cons (NULL_TREE, arg1,
1865               tree_cons (NULL_TREE, arg2,
1866                 tree_cons (NULL_TREE, arg3,
1867                   tree_cons (NULL_TREE, arg4,
1868                     tree_cons (NULL_TREE, arg5,
1869                       tree_cons (NULL_TREE, arg6,
1870                         tree_cons (NULL_TREE, arg7, NULL_TREE))))))));
1871
1872   TREE_TYPE (result) = build_chill_pointer_type (TREE_TYPE (assoc));
1873   return result;
1874 }
1875
1876 static tree
1877 assoc_call (assoc, func, name)
1878      tree assoc;
1879      tree func;
1880      const char *name;
1881 {
1882   tree arg1, arg2, arg3;
1883   tree result;
1884
1885   if (! check_assoc (assoc, 1, name))
1886     return error_mark_node;
1887
1888   arg1 = force_addr_of (assoc);
1889   arg2 = force_addr_of (get_chill_filename ());
1890   arg3 = get_chill_linenumber ();
1891
1892   result = build_chill_function_call (func,
1893             tree_cons (NULL_TREE, arg1,
1894               tree_cons (NULL_TREE, arg2,
1895                 tree_cons (NULL_TREE, arg3, NULL_TREE))));
1896   return result;
1897 }
1898
1899 tree
1900 build_chill_isassociated (assoc)
1901      tree assoc;
1902 {
1903   tree result = assoc_call (assoc,
1904                             lookup_name (get_identifier ("__isassociated")),
1905                             "ISASSOCIATED");
1906   return result;
1907 }
1908
1909 tree
1910 build_chill_existing (assoc)
1911      tree assoc;
1912 {
1913   tree result = assoc_call (assoc,
1914                             lookup_name (get_identifier ("__existing")),
1915                             "EXISTING");
1916   return result;
1917 }
1918
1919 tree
1920 build_chill_readable (assoc)
1921      tree assoc;
1922 {
1923   tree result = assoc_call (assoc,
1924                             lookup_name (get_identifier ("__readable")),
1925                             "READABLE");
1926   return result;
1927 }
1928
1929 tree
1930 build_chill_writeable (assoc)
1931      tree assoc;
1932 {
1933   tree result = assoc_call (assoc,
1934                             lookup_name (get_identifier ("__writeable")),
1935                             "WRITEABLE");
1936   return result;
1937 }
1938
1939 tree
1940 build_chill_sequencible (assoc)
1941      tree assoc;
1942 {
1943   tree result = assoc_call (assoc,
1944                             lookup_name (get_identifier ("__sequencible")),
1945                             "SEQUENCIBLE");
1946   return result;
1947 }
1948
1949 tree
1950 build_chill_variable (assoc)
1951      tree assoc;
1952 {
1953   tree result = assoc_call (assoc,
1954                             lookup_name (get_identifier ("__variable")),
1955                             "VARIABLE");
1956   return result;
1957 }
1958
1959 tree
1960 build_chill_indexable (assoc)
1961      tree assoc;
1962 {
1963   tree result = assoc_call (assoc,
1964                             lookup_name (get_identifier ("__indexable")),
1965                             "INDEXABLE");
1966   return result;
1967 }
1968
1969 tree
1970 build_chill_dissociate (assoc)
1971      tree assoc;
1972 {
1973   tree result = assoc_call (assoc,
1974                             lookup_name (get_identifier ("__dissociate")),
1975                             "DISSOCIATE");
1976   return result;
1977 }
1978
1979 tree
1980 build_chill_create (assoc)
1981      tree assoc;
1982 {
1983   tree result = assoc_call (assoc,
1984                             lookup_name (get_identifier ("__create")),
1985                             "CREATE");
1986   return result;
1987 }
1988
1989 tree
1990 build_chill_delete (assoc)
1991      tree assoc;
1992 {
1993   tree result = assoc_call (assoc,
1994                             lookup_name (get_identifier ("__delete")),
1995                             "DELETE");
1996   return result;
1997 }
1998
1999 tree
2000 build_chill_modify (assoc, list)
2001      tree assoc;
2002      tree list;
2003 {
2004   tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE, arg4 = NULL_TREE,
2005   arg5 = NULL_TREE, arg6, arg7;
2006   int had_errors = 0, numargs;
2007   tree fname = NULL_TREE, attr = NULL_TREE;
2008   tree result;
2009
2010   /* check the association */
2011   if (! check_assoc (assoc, 1, "MODIFY"))
2012     had_errors = 1;
2013   else
2014     arg1 = force_addr_of (assoc);
2015
2016   /* look how much arguments we have got */
2017   numargs = list_length (list);
2018   switch (numargs)
2019     {
2020     case 0:
2021       break;
2022     case 1:
2023       fname = TREE_VALUE (list);
2024       break;
2025     case 2:
2026       fname = TREE_VALUE (list);
2027       attr = TREE_VALUE (TREE_CHAIN (list));
2028       break;
2029     default:
2030       error ("Too many arguments in call to MODIFY");
2031       had_errors = 1;
2032       break;
2033     }
2034
2035   if (fname !=  NULL_TREE && fname != null_pointer_node)
2036     {
2037       if (CH_CHARS_TYPE_P (TREE_TYPE (fname)) ||
2038           (flag_old_strings && TREE_CODE (fname) == INTEGER_CST &&
2039            TREE_CODE (TREE_TYPE (fname)) == CHAR_TYPE))
2040         {
2041           if (int_size_in_bytes (TREE_TYPE (fname)) == 0)
2042             {
2043               error ("argument 2 of MODIFY must not be an empty string");
2044               had_errors = 1;
2045             }
2046           else
2047             {
2048               arg2 = force_addr_of (fname);
2049               arg3 = size_in_bytes (TREE_TYPE (fname));
2050             }
2051         }
2052       else if (chill_varying_string_type_p (TREE_TYPE (fname)))
2053         {
2054           arg2 = force_addr_of (build_component_ref (fname, var_data_id));
2055           arg3 = build_component_ref (fname, var_length_id);
2056         }
2057       else
2058         {
2059           error ("argument 2 to MODIFY must be a string");
2060           had_errors = 1;
2061         }
2062     }
2063   else
2064     {
2065       arg2 = null_pointer_node;
2066       arg3 = integer_zero_node;
2067     }
2068
2069   if (attr != NULL_TREE && attr != null_pointer_node)
2070     {
2071       if (CH_CHARS_TYPE_P (TREE_TYPE (attr)) ||
2072           (flag_old_strings && TREE_CODE (attr) == INTEGER_CST &&
2073            TREE_CODE (TREE_TYPE (attr)) == CHAR_TYPE))
2074         {
2075           if (int_size_in_bytes (TREE_TYPE (attr)) == 0)
2076             {
2077               arg4 = null_pointer_node;
2078               arg5 = integer_zero_node;
2079             }
2080           else
2081             {
2082               arg4 = force_addr_of (attr);
2083               arg5 = size_in_bytes (TREE_TYPE (attr));
2084             }
2085         }
2086       else if (chill_varying_string_type_p (TREE_TYPE (attr)))
2087         {
2088           arg4 = force_addr_of (build_component_ref (attr, var_data_id));
2089           arg5 = build_component_ref (attr, var_length_id);
2090         }
2091       else
2092         {
2093           error ("argument 3 to MODIFY must be a string");
2094           had_errors = 1;
2095         }
2096     }
2097   else
2098     {
2099       arg4 = null_pointer_node;
2100       arg5 = integer_zero_node;
2101     }
2102
2103   if (had_errors)
2104     return error_mark_node;
2105
2106   /* other arguments */
2107   arg6 = force_addr_of (get_chill_filename ());
2108   arg7 = get_chill_linenumber ();
2109
2110   result = build_chill_function_call (
2111      lookup_name (get_identifier ("__modify")),
2112             tree_cons (NULL_TREE, arg1,
2113               tree_cons (NULL_TREE, arg2,
2114                 tree_cons (NULL_TREE, arg3,
2115                   tree_cons (NULL_TREE, arg4,
2116                     tree_cons (NULL_TREE, arg5,
2117                       tree_cons (NULL_TREE, arg6,
2118                         tree_cons (NULL_TREE, arg7, NULL_TREE))))))));
2119
2120   return result;
2121 }
2122 \f
2123 static int
2124 check_transfer (transfer, argnum, errmsg)
2125      tree transfer;
2126      int argnum;
2127      const char *errmsg;
2128 {
2129   int result = 0;
2130
2131   if (transfer == NULL_TREE || TREE_CODE (transfer) == ERROR_MARK)
2132     return 0;
2133
2134   if (CH_IS_ACCESS_MODE (TREE_TYPE (transfer)))
2135     result = 1;
2136   else if (CH_IS_TEXT_MODE (TREE_TYPE (transfer)))
2137     result = 2;
2138   else
2139     {
2140       error ("argument %d of %s must be an ACCESS or TEXT mode", argnum, errmsg);
2141       return 0;
2142     }
2143   if (! CH_LOCATION_P (transfer))
2144     {
2145       error ("argument %d of %s must be a location", argnum, errmsg);
2146       return 0;
2147     }
2148   return result;
2149 }
2150
2151 /* define bits in an access/text flag word.
2152    NOTE: this must be consistent with runtime/iomodes.h */
2153 #define IO_TEXTLOCATION 0x80000000
2154 #define IO_INDEXED      0x00000001
2155 #define IO_TEXTIO       0x00000002
2156 #define IO_OUTOFFILE    0x00010000
2157 \f
2158 /* generated initialisation code for ACCESS and TEXT.
2159    functions gets called from do_decl. */
2160 void init_access_location (decl, type)
2161      tree decl;
2162      tree type;
2163 {
2164   tree recordmode = access_recordmode (type);
2165   tree indexmode = access_indexmode (type);
2166   int flags_init = 0;
2167   tree data = build_component_ref (decl, get_identifier ("data"));
2168   tree lowindex = integer_zero_node;
2169   tree highindex = integer_zero_node;
2170   tree rectype, reclen;
2171
2172   /* flag word */
2173   if (indexmode != NULL_TREE && indexmode != void_type_node)
2174     {
2175       flags_init |= IO_INDEXED;
2176       lowindex = convert (integer_type_node, TYPE_MIN_VALUE (indexmode));
2177       highindex = convert (integer_type_node, TYPE_MAX_VALUE (indexmode));
2178     }
2179
2180   expand_expr_stmt (
2181     build_chill_modify_expr (
2182       build_component_ref (data, get_identifier ("flags")),
2183         build_int_2 (flags_init, 0)));
2184
2185   /* record length */
2186   if (recordmode == NULL_TREE || recordmode == void_type_node)
2187     {
2188       reclen = integer_zero_node;
2189       rectype = integer_zero_node;
2190     }
2191   else if (chill_varying_string_type_p (recordmode))
2192     {
2193       tree fields = TYPE_FIELDS (recordmode);
2194       tree len1, len2;
2195
2196       /* don't count any padding bytes at end of varying */
2197       len1 = size_in_bytes (TREE_TYPE (fields));
2198       fields = TREE_CHAIN (fields);
2199       len2 = size_in_bytes (TREE_TYPE (fields));
2200       reclen = fold (build (PLUS_EXPR, long_integer_type_node, len1, len2));
2201       rectype = build_int_2 (2, 0);
2202     }
2203   else
2204     {
2205       reclen = size_in_bytes (recordmode);
2206       rectype = integer_one_node;
2207     }
2208   expand_expr_stmt (
2209     build_chill_modify_expr (
2210       build_component_ref (data, get_identifier ("reclength")), reclen));
2211
2212   /* record type */
2213   expand_expr_stmt (
2214     build_chill_modify_expr (
2215       build_component_ref (data, get_identifier ("rectype")), rectype));
2216
2217   /* the index */
2218   expand_expr_stmt (
2219     build_chill_modify_expr (
2220       build_component_ref (data, get_identifier ("lowindex")), lowindex));
2221   expand_expr_stmt (
2222     build_chill_modify_expr (
2223       build_component_ref (data, get_identifier ("highindex")), highindex));
2224
2225   /* association */
2226   expand_expr_stmt (
2227     build_chill_modify_expr (
2228       build_chill_component_ref (data, get_identifier ("association")),
2229         null_pointer_node));
2230
2231   /* storelocptr */
2232   expand_expr_stmt (
2233     build_chill_modify_expr (
2234       build_component_ref (data, get_identifier ("storelocptr")), null_pointer_node));
2235 }
2236
2237 void init_text_location (decl, type)
2238      tree decl;
2239      tree type;
2240 {
2241   tree indexmode = text_indexmode (type);
2242   unsigned long accessflags = 0;
2243   unsigned long textflags = IO_TEXTLOCATION;
2244   tree lowindex = integer_zero_node;
2245   tree highindex = integer_zero_node;
2246   tree data, tloc, tlocfields, len1, len2, reclen;
2247
2248   if (indexmode != NULL_TREE && indexmode != void_type_node)
2249     {
2250       accessflags |= IO_INDEXED;
2251       lowindex = convert (integer_type_node, TYPE_MIN_VALUE (indexmode));
2252       highindex = convert (integer_type_node, TYPE_MAX_VALUE (indexmode));
2253     }
2254
2255   tloc = build_component_ref (decl, get_identifier ("tloc"));
2256   /* fill access part of text location */
2257   data = build_component_ref (decl, get_identifier ("acc"));
2258   /* flag word */
2259   expand_expr_stmt (
2260     build_chill_modify_expr (
2261       build_component_ref (data, get_identifier ("flags")),
2262         build_int_2 (accessflags, 0)));
2263
2264   /* record length, don't count any padding bytes at end of varying */
2265   tlocfields = TYPE_FIELDS (TREE_TYPE (tloc));
2266   len1 = size_in_bytes (TREE_TYPE (tlocfields));
2267   tlocfields = TREE_CHAIN (tlocfields);
2268   len2 = size_in_bytes (TREE_TYPE (tlocfields));
2269   reclen = fold (build (PLUS_EXPR, long_integer_type_node, len1, len2));
2270   expand_expr_stmt (
2271     build_chill_modify_expr (
2272       build_component_ref (data, get_identifier ("reclength")),
2273         reclen));
2274
2275   /* the index */
2276   expand_expr_stmt (
2277     build_chill_modify_expr (
2278       build_component_ref (data, get_identifier ("lowindex")), lowindex));
2279   expand_expr_stmt (
2280     build_chill_modify_expr (
2281       build_component_ref (data, get_identifier ("highindex")), highindex));
2282
2283   /* association */
2284   expand_expr_stmt (
2285     build_chill_modify_expr (
2286       build_chill_component_ref (data, get_identifier ("association")),
2287         null_pointer_node));
2288
2289   /* storelocptr */
2290   expand_expr_stmt (
2291     build_chill_modify_expr (
2292       build_component_ref (data, get_identifier ("storelocptr")),
2293         null_pointer_node));
2294
2295   /* record type */
2296   expand_expr_stmt (
2297     build_chill_modify_expr (
2298       build_component_ref (data, get_identifier ("rectype")),
2299         build_int_2 (2, 0))); /* VaryingChars */
2300
2301   /* fill text part */
2302   data = build_component_ref (decl, get_identifier ("txt"));
2303   /* flag word */
2304   expand_expr_stmt (
2305     build_chill_modify_expr (
2306       build_component_ref (data, get_identifier ("flags")),
2307         build_int_2 (textflags, 0)));
2308
2309   /* pointer to text record */
2310   expand_expr_stmt (
2311     build_chill_modify_expr (
2312       build_component_ref (data, get_identifier ("text_record")),
2313         force_addr_of (tloc)));
2314
2315   /* pointer to the access */
2316   expand_expr_stmt (
2317     build_chill_modify_expr (
2318       build_component_ref (data, get_identifier ("access_sub")),
2319         force_addr_of (build_component_ref (decl, get_identifier ("acc")))));
2320
2321   /* actual length */
2322   expand_expr_stmt (
2323     build_chill_modify_expr (
2324       build_component_ref (data, get_identifier ("actual_index")),
2325         integer_zero_node));
2326
2327   /* length of text record */
2328   expand_expr_stmt (
2329     build_chill_modify_expr (
2330       build_component_ref (tloc, get_identifier (VAR_LENGTH)),
2331         integer_zero_node));
2332 }
2333 \f
2334 static int
2335 connect_process_optionals (optionals, whereptr, indexptr, indexmode)
2336      tree optionals;
2337      tree *whereptr;
2338      tree *indexptr;
2339      tree indexmode;
2340 {
2341   tree where = NULL_TREE, theindex = NULL_TREE;
2342   int had_errors = 0;
2343
2344   if (optionals != NULL_TREE)
2345     {
2346       /* get the where expression */
2347       where = TREE_VALUE (optionals);
2348       if (where == NULL_TREE || TREE_CODE (where) == ERROR_MARK)
2349         had_errors = 1;
2350       else
2351         {
2352           if (! CH_IS_WHERE_MODE (TREE_TYPE (where)))
2353             {
2354               error ("argument 4 of CONNECT must be of mode WHERE");
2355               had_errors = 1;
2356             }
2357           where = convert (integer_type_node, where);
2358         }
2359       optionals = TREE_CHAIN (optionals);
2360     }
2361   if (optionals != NULL_TREE)
2362     {
2363       theindex = TREE_VALUE (optionals);
2364       if (theindex == NULL_TREE || TREE_CODE (theindex) == ERROR_MARK)
2365         had_errors = 1;
2366       else
2367         {
2368           if (indexmode == void_type_node)
2369             {
2370               error ("index expression for ACCESS without index");
2371               had_errors = 1;
2372             }
2373           else if (! CH_COMPATIBLE (theindex, indexmode))
2374             {
2375               error ("incompatible index mode");
2376               had_errors = 1;
2377             }
2378         }
2379     }
2380   if (had_errors)
2381     return 0;
2382
2383   *whereptr = where;
2384   *indexptr = theindex;
2385   return 1;
2386 }
2387
2388 static tree
2389 connect_text (assoc, text, usage, optionals)
2390      tree assoc;
2391      tree text;
2392      tree usage;
2393      tree optionals;
2394 {
2395   tree where = NULL_TREE, theindex = NULL_TREE;
2396   tree indexmode = text_indexmode (TREE_TYPE (text));
2397   tree result, what_where, have_index, what_index;
2398
2399   /* process optionals */
2400   if (!connect_process_optionals (optionals, &where, &theindex, indexmode))
2401     return error_mark_node;
2402
2403   what_where = where == NULL_TREE ? integer_zero_node : where;
2404   have_index = theindex == NULL_TREE ? integer_zero_node
2405                                      : integer_one_node;
2406   what_index = theindex == NULL_TREE ? integer_zero_node
2407                                      : convert (integer_type_node, theindex);
2408   result = build_chill_function_call (
2409              lookup_name (get_identifier ("__connect")),
2410                tree_cons (NULL_TREE, force_addr_of (text),
2411                  tree_cons (NULL_TREE, force_addr_of (assoc),
2412                    tree_cons (NULL_TREE, convert (integer_type_node, usage),
2413                      tree_cons (NULL_TREE, what_where,
2414                        tree_cons (NULL_TREE, have_index,
2415                          tree_cons (NULL_TREE, what_index,
2416                            tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2417                              tree_cons (NULL_TREE, get_chill_linenumber (),
2418                                         NULL_TREE)))))))));
2419   return result;
2420 }
2421
2422 static tree
2423 connect_access (assoc, transfer, usage, optionals)
2424      tree assoc;
2425      tree transfer;
2426      tree usage;
2427      tree optionals;
2428 {
2429   tree where = NULL_TREE, theindex = NULL_TREE;
2430   tree indexmode = access_indexmode (TREE_TYPE (transfer));
2431   tree result, what_where, have_index, what_index;
2432
2433   /* process the optionals */
2434   if (! connect_process_optionals (optionals, &where, &theindex, indexmode))
2435     return error_mark_node;
2436
2437   /* now the call */
2438   what_where = where == NULL_TREE ? integer_zero_node : where;
2439   have_index = theindex == NULL_TREE ? integer_zero_node : integer_one_node;
2440   what_index = theindex == NULL_TREE ? integer_zero_node : convert (integer_type_node, theindex);
2441   result = build_chill_function_call (
2442              lookup_name (get_identifier ("__connect")),
2443                tree_cons (NULL_TREE, force_addr_of (transfer),
2444                  tree_cons (NULL_TREE, force_addr_of (assoc),
2445                    tree_cons (NULL_TREE, convert (integer_type_node, usage),
2446                      tree_cons (NULL_TREE, what_where,
2447                        tree_cons (NULL_TREE, have_index,
2448                          tree_cons (NULL_TREE, what_index,
2449                            tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2450                              tree_cons (NULL_TREE, get_chill_linenumber (),
2451                                         NULL_TREE)))))))));
2452   return result;
2453 }
2454
2455 tree
2456 build_chill_connect (transfer, assoc, usage, optionals)
2457      tree transfer;
2458      tree assoc;
2459      tree usage;
2460      tree optionals;
2461 {
2462   int had_errors = 0;
2463   int what = 0;
2464   tree result = error_mark_node;
2465
2466   if (! check_assoc (assoc, 2, "CONNECT"))
2467     had_errors = 1;
2468
2469   /* check usage */
2470   if (usage == NULL_TREE || TREE_CODE (usage) == ERROR_MARK)
2471     return error_mark_node;
2472
2473   if (! CH_IS_USAGE_MODE (TREE_TYPE (usage)))
2474     {
2475       error ("argument 3 to CONNECT must be of mode USAGE");
2476       had_errors = 1;
2477     }
2478   if (had_errors)
2479     return error_mark_node;
2480
2481   /* look what we have got */
2482   what = check_transfer (transfer, 1, "CONNECT");
2483   switch (what)
2484     {
2485     case 1:
2486       /* we have an ACCESS */
2487       result = connect_access (assoc, transfer, usage, optionals);
2488       break;
2489     case 2:
2490       /* we have a TEXT */
2491       result = connect_text (assoc, transfer, usage, optionals);
2492       break;
2493     default:
2494       result = error_mark_node;
2495     }
2496   return result;
2497 }
2498
2499 static int
2500 check_access (access, argnum, errmsg)
2501      tree access;
2502      int argnum;
2503      const char *errmsg;
2504 {
2505   if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
2506     return 1;
2507
2508   if (! CH_IS_ACCESS_MODE (TREE_TYPE (access)))
2509     {
2510       error ("argument %d of %s must be of mode ACCESS", argnum, errmsg);
2511       return 0;
2512     }
2513   if (! CH_LOCATION_P (access))
2514     {
2515       error ("argument %d of %s must be a location", argnum, errmsg);
2516       return 0;
2517     }
2518   return 1;
2519 }
2520
2521 tree
2522 build_chill_readrecord (access, optionals)
2523      tree access;
2524      tree optionals;
2525 {
2526   int len;
2527   tree recordmode, indexmode, dynamic, result;
2528   tree index = NULL_TREE, location = NULL_TREE;
2529
2530   if (! check_access (access, 1, "READRECORD"))
2531     return error_mark_node;
2532
2533   recordmode = access_recordmode (TREE_TYPE (access));
2534   indexmode = access_indexmode (TREE_TYPE (access));
2535   dynamic = access_dynamic (TREE_TYPE (access));
2536
2537   /* process the optionals */
2538   len = list_length (optionals);
2539   if (indexmode != void_type_node)
2540     {
2541       /* we must have an index */
2542       if (!len)
2543         {
2544           error ("Too few arguments in call to `readrecord'");
2545           return error_mark_node;
2546         }
2547       index = TREE_VALUE (optionals);
2548       if (index == NULL_TREE || TREE_CODE (index) == ERROR_MARK)
2549         return error_mark_node;
2550       optionals = TREE_CHAIN (optionals);
2551       if (! CH_COMPATIBLE (index, indexmode))
2552         {
2553           error ("incompatible index mode");
2554           return error_mark_node;
2555         }
2556     }
2557
2558   /* check the record mode, if one */
2559   if (optionals != NULL_TREE)
2560     {
2561       location = TREE_VALUE (optionals);
2562       if (location == NULL_TREE || TREE_CODE (location) == ERROR_MARK)
2563         return error_mark_node;
2564       if (recordmode != void_type_node &&
2565           ! CH_COMPATIBLE (location, recordmode))
2566         {
2567
2568           error ("incompatible record mode");
2569           return error_mark_node;
2570         }
2571       if (TYPE_READONLY_PROPERTY (TREE_TYPE (location)))
2572         {
2573           error ("store location must not be READonly");
2574           return error_mark_node;
2575         }
2576       location = force_addr_of (location);
2577     }
2578   else
2579     location = null_pointer_node;
2580
2581   index = index == NULL_TREE ? integer_zero_node : convert (integer_type_node, index);
2582   result = build_chill_function_call (
2583             lookup_name (get_identifier ("__readrecord")),
2584               tree_cons (NULL_TREE, force_addr_of (access),
2585                 tree_cons (NULL_TREE, index,
2586                   tree_cons (NULL_TREE, location,
2587                     tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2588                       tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))))));
2589
2590   TREE_TYPE (result) = build_chill_pointer_type (recordmode);
2591   return result;
2592 }
2593
2594 tree
2595 build_chill_writerecord (access, optionals)
2596      tree access;
2597      tree optionals;
2598 {
2599   int had_errors = 0, len;
2600   tree recordmode, indexmode, dynamic;
2601   tree index = NULL_TREE, location = NULL_TREE;
2602   tree result;
2603
2604   if (! check_access (access, 1, "WRITERECORD"))
2605     return error_mark_node;
2606
2607   recordmode = access_recordmode (TREE_TYPE (access));
2608   indexmode = access_indexmode (TREE_TYPE (access));
2609   dynamic = access_dynamic (TREE_TYPE (access));
2610
2611   /* process the optionals */
2612   len = list_length (optionals);
2613   if (indexmode != void_type_node && len != 2)
2614     {
2615       error ("Too few arguments in call to `writerecord'");
2616       return error_mark_node;
2617     }
2618   if (indexmode != void_type_node)
2619     {
2620       index = TREE_VALUE (optionals);
2621       if (index == NULL_TREE || TREE_CODE (index) == ERROR_MARK)
2622         return error_mark_node;
2623       location = TREE_VALUE (TREE_CHAIN (optionals));
2624       if (location == NULL_TREE || TREE_CODE (location) == ERROR_MARK)
2625         return error_mark_node;
2626     }
2627   else
2628     location = TREE_VALUE (optionals);
2629
2630   /* check the index */
2631   if (indexmode != void_type_node)
2632     {
2633       if (! CH_COMPATIBLE (index, indexmode))
2634         {
2635           error ("incompatible index mode");
2636           had_errors = 1;
2637         }
2638     }
2639   /* check the record mode */
2640   if (recordmode == void_type_node)
2641     {
2642       error ("transfer to ACCESS without record mode");
2643       had_errors = 1;
2644     }
2645   else if (! CH_COMPATIBLE (location, recordmode))
2646     {
2647       error ("incompatible record mode");
2648       had_errors = 1;
2649     }
2650   if (had_errors)
2651     return error_mark_node;
2652
2653   index = index == NULL_TREE ? integer_zero_node : convert (integer_type_node, index);
2654
2655   result = build_chill_function_call (
2656              lookup_name (get_identifier ("__writerecord")),
2657                tree_cons (NULL_TREE, force_addr_of (access),
2658                  tree_cons (NULL_TREE, index,
2659                    tree_cons (NULL_TREE, force_addr_of (location),
2660                      tree_cons (NULL_TREE, size_in_bytes (TREE_TYPE (location)),
2661                        tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2662                          tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))))));
2663   return result;
2664 }
2665
2666 tree
2667 build_chill_disconnect (transfer)
2668      tree transfer;
2669 {
2670   tree result;
2671
2672   if (! check_transfer (transfer, 1, "DISCONNECT"))
2673     return error_mark_node;
2674   result = build_chill_function_call (
2675              lookup_name (get_identifier ("__disconnect")),
2676                tree_cons (NULL_TREE, force_addr_of (transfer),
2677                  tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2678                    tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2679   return result;
2680 }
2681
2682 tree
2683 build_chill_getassociation (transfer)
2684      tree transfer;
2685 {
2686   tree result;
2687
2688   if (! check_transfer (transfer, 1, "GETASSOCIATION"))
2689     return error_mark_node;
2690
2691   result = build_chill_function_call (
2692             lookup_name (get_identifier ("__getassociation")),
2693               tree_cons (NULL_TREE, force_addr_of (transfer),
2694                 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2695                   tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2696   TREE_TYPE (result) = build_chill_pointer_type (association_type_node);
2697   return result;
2698 }
2699
2700 tree
2701 build_chill_getusage (transfer)
2702      tree transfer;
2703 {
2704   tree result;
2705
2706   if (! check_transfer (transfer, 1, "GETUSAGE"))
2707     return error_mark_node;
2708
2709   result = build_chill_function_call (
2710             lookup_name (get_identifier ("__getusage")),
2711               tree_cons (NULL_TREE, force_addr_of (transfer),
2712                 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2713                   tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2714   TREE_TYPE (result) = usage_type_node;
2715   return result;
2716 }
2717
2718 tree
2719 build_chill_outoffile (transfer)
2720      tree transfer;
2721 {
2722   tree result;
2723
2724   if (! check_transfer (transfer, 1, "OUTOFFILE"))
2725     return error_mark_node;
2726
2727   result = build_chill_function_call (
2728              lookup_name (get_identifier ("__outoffile")),
2729                tree_cons (NULL_TREE, force_addr_of (transfer),
2730                  tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2731                    tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2732   return result;
2733 }
2734 \f
2735 static int
2736 check_text (text, argnum, errmsg)
2737      tree text;
2738      int argnum;
2739      const char *errmsg;
2740 {
2741   if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
2742     return 0;
2743   if (! CH_IS_TEXT_MODE (TREE_TYPE (text)))
2744     {
2745       error ("argument %d of %s must be of mode TEXT", argnum, errmsg);
2746       return 0;
2747     }
2748   if (! CH_LOCATION_P (text))
2749     {
2750       error ("argument %d of %s must be a location", argnum, errmsg);
2751       return 0;
2752     }
2753   return 1;
2754 }
2755
2756 tree
2757 build_chill_eoln (text)
2758      tree text;
2759 {
2760   tree result;
2761
2762   if (! check_text (text, 1, "EOLN"))
2763     return error_mark_node;
2764
2765   result = build_chill_function_call (
2766              lookup_name (get_identifier ("__eoln")),
2767                tree_cons (NULL_TREE, force_addr_of (text),
2768                  tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2769                    tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2770   return result;
2771 }
2772
2773 tree
2774 build_chill_gettextindex (text)
2775      tree text;
2776 {
2777   tree result;
2778
2779   if (! check_text (text, 1, "GETTEXTINDEX"))
2780     return error_mark_node;
2781
2782   result = build_chill_function_call (
2783              lookup_name (get_identifier ("__gettextindex")),
2784                tree_cons (NULL_TREE, force_addr_of (text),
2785                  tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2786                    tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2787   return result;
2788 }
2789
2790 tree
2791 build_chill_gettextrecord (text)
2792      tree text;
2793 {
2794   tree textmode, result;
2795
2796   if (! check_text (text, 1, "GETTEXTRECORD"))
2797     return error_mark_node;
2798
2799   textmode = textlocation_mode (TREE_TYPE (text));
2800   if (textmode == NULL_TREE)
2801     {
2802       error ("TEXT doesn't have a location");  /* FIXME */
2803       return error_mark_node;
2804     }
2805   result = build_chill_function_call (
2806             lookup_name (get_identifier ("__gettextrecord")),
2807               tree_cons (NULL_TREE, force_addr_of (text),
2808                 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2809                   tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2810   TREE_TYPE (result) = build_chill_pointer_type (textmode);
2811   CH_DERIVED_FLAG (result) = 1;
2812   return result;
2813 }
2814
2815 tree
2816 build_chill_gettextaccess (text)
2817      tree text;
2818 {
2819   tree access, refaccess, acc, decl, listbase;
2820   tree tlocmode, indexmode, dynamic;
2821   tree result;
2822   unsigned int save_maximum_field_alignment = maximum_field_alignment;
2823
2824   if (! check_text (text, 1, "GETTEXTACCESS"))
2825     return error_mark_node;
2826
2827   tlocmode = textlocation_mode (TREE_TYPE (text));
2828   indexmode = text_indexmode (TREE_TYPE (text));
2829   dynamic = text_dynamic (TREE_TYPE (text));
2830
2831   /* we have to build a type for the access */
2832   acc = build_access_part ();
2833   access = make_node (RECORD_TYPE);
2834   listbase = build_decl (FIELD_DECL, get_identifier ("data"), acc);
2835   TYPE_FIELDS (access) = listbase;
2836   decl = build_lang_decl (TYPE_DECL, get_identifier ("__recordmode"),
2837                           tlocmode);
2838   chainon (listbase, decl);
2839   decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"),
2840                           indexmode);
2841   chainon (listbase, decl);
2842   decl = build_decl (CONST_DECL, get_identifier ("__dynamic"),
2843                      integer_type_node);
2844   DECL_INITIAL (decl) = dynamic;
2845   chainon (listbase, decl);
2846   maximum_field_alignment = 0;
2847   layout_chill_struct_type (access);
2848   maximum_field_alignment = save_maximum_field_alignment;
2849   CH_IS_ACCESS_MODE (access) = 1;
2850   CH_TYPE_NONVALUE_P (access) = 1;
2851
2852   refaccess = build_chill_pointer_type (access);
2853
2854   result = build_chill_function_call (
2855             lookup_name (get_identifier ("__gettextaccess")),
2856               tree_cons (NULL_TREE, force_addr_of (text),
2857                 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2858                   tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2859   TREE_TYPE (result) = refaccess;
2860   CH_DERIVED_FLAG (result) = 1;
2861   return result;
2862 }
2863
2864 tree
2865 build_chill_settextindex (text, expr)
2866      tree text;
2867      tree expr;
2868 {
2869   tree result;
2870
2871   if (! check_text (text, 1, "SETTEXTINDEX"))
2872     return error_mark_node;
2873   if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
2874     return error_mark_node;
2875   result = build_chill_function_call (
2876              lookup_name (get_identifier ("__settextindex")),
2877                tree_cons (NULL_TREE, force_addr_of (text),
2878                  tree_cons (NULL_TREE, expr,
2879                    tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2880                      tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))));
2881   return result;
2882 }
2883
2884 tree
2885 build_chill_settextaccess (text, access)
2886      tree text;
2887      tree access;
2888 {
2889   tree result;
2890   tree textindexmode, accessindexmode;
2891   tree textrecordmode, accessrecordmode;
2892
2893   if (! check_text (text, 1, "SETTEXTACCESS"))
2894     return error_mark_node;
2895   if (! check_access (access, 2, "SETTEXTACCESS"))
2896     return error_mark_node;
2897
2898   textindexmode = text_indexmode (TREE_TYPE (text));
2899   accessindexmode = access_indexmode (TREE_TYPE (access));
2900   if (textindexmode != accessindexmode)
2901     {
2902       if (! chill_read_compatible (textindexmode, accessindexmode))
2903         {
2904           error ("incompatible index mode for SETETEXTACCESS");
2905           return error_mark_node;
2906         }
2907     }
2908   textrecordmode = textlocation_mode (TREE_TYPE (text));
2909   accessrecordmode = access_recordmode (TREE_TYPE (access));
2910   if (textrecordmode != accessrecordmode)
2911     {
2912       if (! chill_read_compatible (textrecordmode, accessrecordmode))
2913         {
2914           error ("incompatible record mode for SETTEXTACCESS");
2915           return error_mark_node;
2916         }
2917     }
2918   result = build_chill_function_call (
2919              lookup_name (get_identifier ("__settextaccess")),
2920                tree_cons (NULL_TREE, force_addr_of (text),
2921                  tree_cons (NULL_TREE, force_addr_of (access),
2922                    tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2923                      tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))));
2924   return result;
2925 }
2926
2927 tree
2928 build_chill_settextrecord (text, charloc)
2929      tree text;
2930      tree charloc;
2931 {
2932   tree result;
2933   int had_errors = 0;
2934   tree tlocmode;
2935
2936   if (! check_text (text, 1, "SETTEXTRECORD"))
2937     return error_mark_node;
2938   if (charloc == NULL_TREE || TREE_CODE (charloc) == ERROR_MARK)
2939     return error_mark_node;
2940
2941   /* check the location */
2942   if (! CH_LOCATION_P (charloc))
2943     {
2944       error ("parameter 2 must be a location");
2945       return error_mark_node;
2946     }
2947   tlocmode = textlocation_mode (TREE_TYPE (text));
2948   if (! chill_varying_string_type_p (TREE_TYPE (charloc)))
2949     had_errors = 1;
2950   else if (int_size_in_bytes (tlocmode) != int_size_in_bytes (TREE_TYPE (charloc)))
2951     had_errors = 1;
2952   if (had_errors)
2953     {
2954       error ("incompatible modes in parameter 2");
2955       return error_mark_node;
2956     }
2957   result = build_chill_function_call (
2958              lookup_name (get_identifier ("__settextrecord")),
2959                tree_cons (NULL_TREE, force_addr_of (text),
2960                  tree_cons (NULL_TREE, force_addr_of (charloc),
2961                    tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2962                      tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))));
2963   return result;
2964 }
2965 \f
2966 /* process iolist for READ- and WRITETEXT */
2967
2968 /* function walks through types as long as they are ranges,
2969    returns the type and min- and max-value form starting type.
2970    */
2971
2972 static tree
2973 get_final_type_and_range (item, low, high)
2974      tree  item;
2975      tree *low;
2976      tree *high;
2977 {
2978   tree  wrk = item;
2979
2980   *low = TYPE_MIN_VALUE (wrk);
2981   *high = TYPE_MAX_VALUE (wrk);
2982   while (TREE_CODE (wrk) == INTEGER_TYPE &&
2983          TREE_TYPE (wrk) != NULL_TREE &&
2984          TREE_CODE (TREE_TYPE (wrk)) == INTEGER_TYPE &&
2985          TREE_TYPE (TREE_TYPE (wrk)) != NULL_TREE)
2986     wrk = TREE_TYPE (wrk);
2987
2988   return (TREE_TYPE (wrk));
2989 }
2990
2991 static void
2992 process_io_list (exprlist, iolist_addr, iolist_length, iolist_rtx, do_read,
2993                  argoffset)
2994      tree exprlist;
2995      tree *iolist_addr;
2996      tree *iolist_length;
2997      rtx *iolist_rtx;
2998      int do_read;
2999      int argoffset;
3000 {
3001   tree idxlist;
3002   int idxcnt;
3003   int iolen;
3004   tree iolisttype, iolist;
3005
3006   if (exprlist == NULL_TREE)
3007     return;
3008
3009   iolen = list_length (exprlist);
3010
3011   /* build indexlist for the io list */
3012   idxlist = build_tree_list (NULL_TREE,
3013                              build_chill_range_type (NULL_TREE,
3014                                                      integer_one_node,
3015                                                      build_int_2 (iolen, 0)));
3016
3017   /* build the io-list type */
3018   iolisttype = build_chill_array_type (TREE_TYPE (chill_io_list_type),
3019                                        idxlist, 0, NULL_TREE);
3020
3021   /* declare the iolist */
3022   iolist = build_decl (VAR_DECL, get_unique_identifier (do_read ? "RDTEXT" : "WRTEXT"),
3023                        iolisttype);
3024
3025   /* we want to get a variable which gets marked unused after
3026      the function call, This is a little bit tricky cause the
3027      address of this variable will be taken and therefor the variable
3028      gets moved out one level. However, we REALLY don't need this
3029      variable again. Solution: push 2 levels and do pop and free
3030      twice at the end. */
3031   push_temp_slots ();
3032   push_temp_slots ();
3033   *iolist_rtx = assign_temp (TREE_TYPE (iolist), 0, 1, 0);
3034   DECL_RTL (iolist) = *iolist_rtx;
3035
3036   /* process the exprlist */
3037   idxcnt = 1;
3038   while (exprlist != NULL_TREE)
3039     {
3040       tree item = TREE_VALUE (exprlist);
3041       tree idx = build_int_2 (idxcnt++, 0);
3042       const char *fieldname = 0;
3043       const char *enumname = 0;
3044       tree array_ref = build_chill_array_ref_1 (iolist, idx);
3045       tree item_type;
3046       tree range_low = NULL_TREE, range_high = NULL_TREE;
3047       int have_range = 0;
3048       tree item_addr = null_pointer_node;
3049       int referable = 0;
3050       int readonly = 0;
3051
3052       /* next value in exprlist */
3053       exprlist = TREE_CHAIN (exprlist);
3054       if (item == NULL_TREE || TREE_CODE (item) == ERROR_MARK)
3055         continue;
3056
3057       item_type = TREE_TYPE (item);
3058       if (item_type == NULL_TREE)
3059         {
3060           if (TREE_CODE (item) == COND_EXPR || TREE_CODE (item) == CASE_EXPR)
3061             error ("conditional expression not allowed in this context");
3062           else
3063             error ("untyped expression as argument %d", idxcnt + 1 + argoffset);
3064           continue;
3065         }
3066       else if (TREE_CODE (item_type) == ERROR_MARK)
3067         continue;
3068
3069       if (TREE_CODE (item_type) == REFERENCE_TYPE)
3070         {
3071           item_type = TREE_TYPE (item_type);
3072           item = convert (item_type, item);
3073         }
3074
3075       /* check for a range */
3076       if (TREE_CODE (item_type) == INTEGER_TYPE &&
3077           TREE_TYPE (item_type) != NULL_TREE)
3078         {
3079           /* we have a range. NOTE, however, on writetext we don't process ranges  */
3080           item_type = get_final_type_and_range (item_type,
3081                                                 &range_low, &range_high);
3082           have_range = 1;
3083         }
3084
3085       readonly = TYPE_READONLY_PROPERTY (item_type);
3086       referable = CH_REFERABLE (item);
3087       if (referable)
3088         item_addr = force_addr_of (item);
3089       /* if we are in read and have readonly we can't do this */
3090       if (readonly && do_read)
3091         {
3092           item_addr = null_pointer_node;
3093           referable = 0;
3094         }
3095
3096       /* process different types */
3097       if (TREE_CODE (item_type) == INTEGER_TYPE)
3098         {
3099           int type_size = TREE_INT_CST_LOW (TYPE_SIZE (item_type));
3100           tree to_assign = NULL_TREE;
3101
3102           if (do_read && referable)
3103             {
3104               /* process an integer in case of READTEXT and expression is
3105                  referable and not READONLY */
3106               to_assign = item_addr;
3107               if (have_range)
3108                 {
3109                   /* do it for a range */
3110                   tree t, __forxx, __ptr, __low, __high;
3111                   tree what_upper, what_lower;
3112
3113                   /* determine the name in the union of lower and upper */
3114                   if (TREE_UNSIGNED (item_type))
3115                     fieldname = "_ulong";
3116                   else
3117                     fieldname = "_slong";
3118
3119                   switch (type_size)
3120                     {
3121                     case 8:
3122                       if (TREE_UNSIGNED (item_type))
3123                         enumname = "__IO_UByteRangeLoc";
3124                       else
3125                         enumname = "__IO_ByteRangeLoc";
3126                       break;
3127                     case 16:
3128                       if (TREE_UNSIGNED (item_type))
3129                         enumname = "__IO_UIntRangeLoc";
3130                       else
3131                         enumname = "__IO_IntRangeLoc";
3132                       break;
3133                     case 32:
3134                       if (TREE_UNSIGNED (item_type))
3135                         enumname = "__IO_ULongRangeLoc";
3136                       else
3137                         enumname = "__IO_LongRangeLoc";
3138                       break;
3139                     default:
3140                       error ("Cannot process %d bits integer for READTEXT argument %d.",
3141                              type_size, idxcnt + 1 + argoffset);
3142                       continue;
3143                     }
3144
3145                   /* set up access to structure */
3146                   t = build_component_ref (array_ref,
3147                                            get_identifier ("__t"));
3148                   __forxx = build_component_ref (t, get_identifier ("__locintrange"));
3149                   __ptr = build_component_ref (__forxx, get_identifier ("ptr"));
3150                   __low = build_component_ref (__forxx, get_identifier ("lower"));
3151                   what_lower = build_component_ref (__low, get_identifier (fieldname));
3152                   __high = build_component_ref (__forxx, get_identifier ("upper"));
3153                   what_upper = build_component_ref (__high, get_identifier (fieldname));
3154
3155                   /* do the assignments */
3156                   expand_assignment (__ptr, item_addr, 0, 0);
3157                   expand_assignment (what_lower, range_low, 0, 0);
3158                   expand_assignment (what_upper, range_high, 0, 0);
3159                   fieldname = 0;
3160                 }
3161               else
3162                 {
3163                   /* no range */
3164                   fieldname = "__locint";
3165                   switch (type_size)
3166                     {
3167                     case 8:
3168                       if (TREE_UNSIGNED (item_type))
3169                         enumname = "__IO_UByteLoc";
3170                       else
3171                         enumname = "__IO_ByteLoc";
3172                       break;
3173                     case 16:
3174                       if (TREE_UNSIGNED (item_type))
3175                         enumname = "__IO_UIntLoc";
3176                       else
3177                         enumname = "__IO_IntLoc";
3178                       break;
3179                     case 32:
3180                       if (TREE_UNSIGNED (item_type))
3181                         enumname = "__IO_ULongLoc";
3182                       else
3183                         enumname = "__IO_LongLoc";
3184                       break;
3185                     default:
3186                       error ("Cannot process %d bits integer for READTEXT argument %d.",
3187                              type_size, idxcnt + 1 + argoffset);
3188                       continue;
3189                     }
3190                 }
3191             }
3192           else
3193             {
3194               /* process an integer in case of WRITETEXT */
3195               to_assign = item;
3196               switch (type_size)
3197                 {
3198                 case 8:
3199                   if (TREE_UNSIGNED (item_type))
3200                     {
3201                       enumname = "__IO_UByteVal";
3202                       fieldname = "__valubyte";
3203                     }
3204                   else
3205                     {
3206                       enumname = "__IO_ByteVal";
3207                       fieldname = "__valbyte";
3208                     }
3209                   break;
3210                 case 16:
3211                   if (TREE_UNSIGNED (item_type))
3212                     {
3213                       enumname = "__IO_UIntVal";
3214                       fieldname = "__valuint";
3215                     }
3216                   else
3217                     {
3218                       enumname = "__IO_IntVal";
3219                       fieldname = "__valint";
3220                     }
3221                   break;
3222                 case 32:
3223                 try_long:
3224                   if (TREE_UNSIGNED (item_type))
3225                     {
3226                       enumname = "__IO_ULongVal";
3227                       fieldname = "__valulong";
3228                     }
3229                   else
3230                     {
3231                       enumname = "__IO_LongVal";
3232                       fieldname = "__vallong";
3233                     }
3234                   break;
3235                 case 64:
3236                   /* convert it back to {unsigned}long. */
3237                   if (TREE_UNSIGNED (item_type))
3238                     item_type = long_unsigned_type_node;
3239                   else
3240                     item_type = long_integer_type_node;
3241                   item = convert (item_type, item);
3242                   goto try_long;
3243                 default:
3244                   /* This kludge is because the lexer gives literals
3245                      the type long_long_{integer,unsigned}_type_node.  */
3246                   if (TREE_CODE (item) == INTEGER_CST)
3247                     {
3248                       if (int_fits_type_p (item, long_integer_type_node))
3249                         {
3250                           item_type = long_integer_type_node;
3251                           item = convert (item_type, item);
3252                           goto try_long;
3253                         }
3254                       if (int_fits_type_p (item, long_unsigned_type_node))
3255                         {
3256                           item_type = long_unsigned_type_node;
3257                           item = convert (item_type, item);
3258                           goto try_long;
3259                         }
3260                     }
3261                   error ("Cannot process %d bits integer WRITETEXT argument %d.",
3262                          type_size, idxcnt + 1 + argoffset);
3263                   continue;
3264                 }
3265             }
3266           if (fieldname)
3267             {
3268               tree      t, __forxx;
3269
3270               t = build_component_ref (array_ref,
3271                                        get_identifier ("__t"));
3272               __forxx = build_component_ref (t, get_identifier (fieldname));
3273               expand_assignment (__forxx, to_assign, 0, 0);
3274             }
3275         }
3276       else if (TREE_CODE (item_type) == CHAR_TYPE)
3277         {
3278           tree  to_assign = NULL_TREE;
3279
3280           if (do_read && readonly)
3281             {
3282               error ("argument %d is READonly", idxcnt + 1 + argoffset);
3283               continue;
3284             }
3285           if (do_read)
3286             {
3287               if (! referable)
3288                 {
3289                   error ("argument %d must be referable", idxcnt + 1 + argoffset);
3290                   continue;
3291                 }
3292               if (have_range)
3293                 {
3294                   tree t, forxx, ptr, lower, upper;
3295
3296                   t = build_component_ref (array_ref, get_identifier ("__t"));
3297                   forxx = build_component_ref (t, get_identifier ("__loccharrange"));
3298                   ptr = build_component_ref (forxx, get_identifier ("ptr"));
3299                   lower = build_component_ref (forxx, get_identifier ("lower"));
3300                   upper = build_component_ref (forxx, get_identifier ("upper"));
3301                   expand_assignment (ptr, item_addr, 0, 0);
3302                   expand_assignment (lower, range_low, 0, 0);
3303                   expand_assignment (upper, range_high, 0, 0);
3304
3305                   fieldname = 0;
3306                   enumname = "__IO_CharRangeLoc";
3307                 }
3308               else
3309                 {
3310                   to_assign = item_addr;
3311                   fieldname = "__locchar";
3312                   enumname = "__IO_CharLoc";
3313                 }
3314             }
3315           else
3316             {
3317               to_assign = item;
3318               enumname = "__IO_CharVal";
3319               fieldname = "__valchar";
3320             }
3321
3322           if (fieldname)
3323             {
3324               tree t, forxx;
3325
3326               t = build_component_ref (array_ref, get_identifier ("__t"));
3327               forxx = build_component_ref (t, get_identifier (fieldname));
3328               expand_assignment (forxx, to_assign, 0, 0);
3329             }
3330         }
3331       else if (TREE_CODE (item_type) == BOOLEAN_TYPE)
3332         {
3333           tree to_assign = NULL_TREE;
3334
3335           if (do_read && readonly)
3336             {
3337               error ("argument %d is READonly", idxcnt + 1 + argoffset);
3338               continue;
3339             }
3340           if (do_read)
3341             {
3342               if (! referable)
3343                 {
3344                   error ("argument %d must be referable", idxcnt + 1 + argoffset);
3345                   continue;
3346                 }
3347               if (have_range)
3348                 {
3349                   tree t, forxx, ptr, lower, upper;
3350
3351                   t = build_component_ref (array_ref, get_identifier ("__t"));
3352                   forxx = build_component_ref (t, get_identifier ("__locboolrange"));
3353                   ptr = build_component_ref (forxx, get_identifier ("ptr"));
3354                   lower = build_component_ref (forxx, get_identifier ("lower"));
3355                   upper = build_component_ref (forxx, get_identifier ("upper"));
3356                   expand_assignment (ptr, item_addr, 0, 0);
3357                   expand_assignment (lower, range_low, 0, 0);
3358                   expand_assignment (upper, range_high, 0, 0);
3359
3360                   fieldname = 0;
3361                   enumname = "__IO_BoolRangeLoc";
3362                 }
3363               else
3364                 {
3365                   to_assign = item_addr;
3366                   fieldname = "__locbool";
3367                   enumname = "__IO_BoolLoc";
3368                 }
3369             }
3370           else
3371             {
3372               to_assign = item;
3373               enumname = "__IO_BoolVal";
3374               fieldname = "__valbool";
3375             }
3376           if (fieldname)
3377             {
3378               tree      t, forxx;
3379
3380               t = build_component_ref (array_ref, get_identifier ("__t"));
3381               forxx = build_component_ref (t, get_identifier (fieldname));
3382               expand_assignment (forxx, to_assign, 0, 0);
3383             }
3384         }
3385       else if (TREE_CODE (item_type) == ENUMERAL_TYPE)
3386         {
3387           /* process an enum */
3388           tree table_name;
3389           tree context_of_type;
3390           tree t;
3391
3392           /* determine the context of the type.
3393              if TYPE_NAME (item_type) == NULL_TREE
3394              if TREE_CODE (item) == INTEGER_CST
3395              context = NULL_TREE -- this is wrong but should work for now
3396              else
3397              context = DECL_CONTEXT (item)
3398              else
3399              context = DECL_CONTEXT (TYPE_NAME (item_type)) */
3400
3401           if (TYPE_NAME (item_type) == NULL_TREE)
3402             {
3403               if (TREE_CODE (item) == INTEGER_CST)
3404                 context_of_type = NULL_TREE;
3405               else
3406                 context_of_type = DECL_CONTEXT (item);
3407             }
3408           else
3409             context_of_type = DECL_CONTEXT (TYPE_NAME (item_type));
3410
3411           table_name = add_enum_to_list (item_type, context_of_type);
3412           t = build_component_ref (array_ref, get_identifier ("__t"));
3413
3414           if (do_read && readonly)
3415             {
3416               error ("argument %d is READonly", idxcnt + 1 + argoffset);
3417               continue;
3418             }
3419           if (do_read)
3420             {
3421               if (! referable)
3422                 {
3423                   error ("argument %d must be referable", idxcnt + 1 + argoffset);
3424                   continue;
3425                 }
3426               if (have_range)
3427                 {
3428                   tree forxx, ptr, len, nametable, lower, upper;
3429
3430                   forxx = build_component_ref (t, get_identifier ("__locsetrange"));
3431                   ptr = build_component_ref (forxx, get_identifier ("ptr"));
3432                   len = build_component_ref (forxx, get_identifier ("length"));
3433                   nametable = build_component_ref (forxx, get_identifier ("name_table"));
3434                   lower = build_component_ref (forxx, get_identifier ("lower"));
3435                   upper = build_component_ref (forxx, get_identifier ("upper"));
3436                   expand_assignment (ptr, item_addr, 0, 0);
3437                   expand_assignment (len, size_in_bytes (item_type), 0, 0);
3438                   expand_assignment (nametable, table_name, 0, 0);
3439                   expand_assignment (lower, range_low, 0, 0);
3440                   expand_assignment (upper, range_high, 0, 0);
3441
3442                   enumname = "__IO_SetRangeLoc";
3443                 }
3444               else
3445                 {
3446                   tree forxx, ptr, len, nametable;
3447
3448                   forxx = build_component_ref (t, get_identifier ("__locset"));
3449                   ptr = build_component_ref (forxx, get_identifier ("ptr"));
3450                   len = build_component_ref (forxx, get_identifier ("length"));
3451                   nametable = build_component_ref (forxx, get_identifier ("name_table"));
3452                   expand_assignment (ptr, item_addr, 0, 0);
3453                   expand_assignment (len, size_in_bytes (item_type), 0, 0);
3454                   expand_assignment (nametable, table_name, 0, 0);
3455
3456                   enumname = "__IO_SetLoc";
3457                 }
3458             }
3459           else
3460             {
3461               tree forxx, value, nametable;
3462
3463               forxx = build_component_ref (t, get_identifier ("__valset"));
3464               value = build_component_ref (forxx, get_identifier ("value"));
3465               nametable = build_component_ref (forxx, get_identifier ("name_table"));
3466               expand_assignment (value, item, 0, 0);
3467               expand_assignment (nametable, table_name, 0, 0);
3468
3469               enumname = "__IO_SetVal";
3470             }
3471         }
3472       else if (chill_varying_string_type_p (item_type))
3473         {
3474           /* varying char string */
3475           tree t = build_component_ref (array_ref, get_identifier ("__t"));
3476           tree forxx = build_component_ref (t, get_identifier ("__loccharstring"));
3477           tree string = build_component_ref (forxx, get_identifier ("string"));
3478           tree length = build_component_ref (forxx, get_identifier ("string_length"));
3479
3480           if (do_read && readonly)
3481             {
3482               error ("argument %d is READonly", idxcnt + 1 + argoffset);
3483               continue;
3484             }
3485           if (do_read)
3486             {
3487               /* in this read case the argument must be referable */
3488               if (! referable)
3489                 {
3490                   error ("argument %d must be referable", idxcnt + 1 + argoffset);
3491                   continue;
3492                 }
3493             }
3494           else if (! referable)
3495             {
3496               /* in the write case we create a temporary if not referable */
3497               rtx t;
3498               tree loc = build_decl (VAR_DECL,
3499                                      get_unique_identifier ("WRTEXTVS"),
3500                                      item_type);
3501               t = assign_temp (item_type, 0, 1, 0);
3502               DECL_RTL (loc) = t;
3503               expand_assignment (loc, item, 0, 0);
3504               item_addr = force_addr_of (loc);
3505               item = loc;
3506             }
3507
3508           expand_assignment (string, item_addr, 0, 0);
3509           if (do_read)
3510             /* we must pass the maximum length of the varying */
3511             expand_assignment (length,
3512                                size_in_bytes (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (item_type)))),
3513                                0, 0);
3514           else
3515               /* we pass the actual length of the string */
3516             expand_assignment (length,
3517                                build_component_ref (item, var_length_id),
3518                                0, 0);
3519
3520           enumname = "__IO_CharVaryingLoc";
3521         }
3522       else if (CH_CHARS_TYPE_P (item_type))
3523         {
3524           /* fixed character string */
3525           tree the_size;
3526           tree t = build_component_ref (array_ref, get_identifier ("__t"));
3527           tree forxx = build_component_ref (t, get_identifier ("__loccharstring"));
3528           tree string = build_component_ref (forxx, get_identifier ("string"));
3529           tree length = build_component_ref (forxx, get_identifier ("string_length"));
3530
3531           if (do_read && readonly)
3532             {
3533               error ("argument %d is READonly", idxcnt + 1 + argoffset);
3534               continue;
3535             }
3536           if (do_read)
3537             {
3538               /* in this read case the argument must be referable */
3539               if (! CH_REFERABLE (item))
3540                 {
3541                   error ("argument %d must be referable", idxcnt + 1 + argoffset);
3542                   continue;
3543                 }
3544               else
3545                 item_addr = force_addr_of (item);
3546               the_size = size_in_bytes (item_type);
3547               enumname = "__IO_CharStrLoc";
3548             }
3549           else
3550             {
3551               if (! CH_REFERABLE (item))
3552                 {
3553                   /* in the write case we create a temporary if not referable */
3554                   rtx t;
3555                   int howmuchbytes;
3556
3557                   howmuchbytes = int_size_in_bytes (item_type);
3558                   if (howmuchbytes != -1)
3559                     {
3560                       /* fixed size */
3561                       tree loc = build_decl (VAR_DECL,
3562                                              get_unique_identifier ("WRTEXTVS"),
3563                                              item_type);
3564                       t = assign_temp (item_type, 0, 1, 0);
3565                       DECL_RTL (loc) = t;
3566                       expand_assignment (loc, item, 0, 0);
3567                       item_addr = force_addr_of (loc);
3568                       the_size = size_in_bytes (item_type);
3569                       enumname = "__IO_CharStrLoc";
3570                     }
3571                   else
3572                     {
3573                       tree type, string, exp, loc;
3574
3575                       if ((howmuchbytes = intsize_of_charsexpr (item)) == -1)
3576                         {
3577                           error ("cannot process argument %d of WRITETEXT, unknown size",
3578                                  idxcnt + 1 + argoffset);
3579                           continue;
3580                         }
3581                       string = build_string_type (char_type_node,
3582                                                   build_int_2 (howmuchbytes, 0));
3583                       type = build_varying_struct (string);
3584                       loc = build_decl (VAR_DECL,
3585                                         get_unique_identifier ("WRTEXTCS"),
3586                                         type);
3587                       t = assign_temp (type, 0, 1, 0);
3588                       DECL_RTL (loc) = t;
3589                       exp = chill_convert_for_assignment (type, item, 0);
3590                       expand_assignment (loc, exp, 0, 0);
3591                       item_addr = force_addr_of (loc);
3592                       the_size = integer_zero_node;
3593                       enumname = "__IO_CharVaryingLoc";
3594                     }
3595                 }
3596               else
3597                 {
3598                   item_addr = force_addr_of (item);
3599                   the_size = size_in_bytes (item_type);
3600                   enumname = "__IO_CharStrLoc";
3601                 }
3602             }
3603
3604           expand_assignment (string, item_addr, 0, 0);
3605           expand_assignment (length, size_in_bytes (item_type), 0, 0);
3606
3607         }
3608       else if (CH_BOOLS_TYPE_P (item_type))
3609         {
3610           /* we have a bitstring */
3611           tree t = build_component_ref (array_ref, get_identifier ("__t"));
3612           tree forxx = build_component_ref (t, get_identifier ("__loccharstring"));
3613           tree string = build_component_ref (forxx, get_identifier ("string"));
3614           tree length = build_component_ref (forxx, get_identifier ("string_length"));
3615
3616           if (do_read && readonly)
3617             {
3618               error ("argument %d is READonly", idxcnt + 1 + argoffset);
3619               continue;
3620             }
3621           if (do_read)
3622             {
3623               /* in this read case the argument must be referable */
3624               if (! referable)
3625                 {
3626                   error ("argument %d must be referable", idxcnt + 1 + argoffset);
3627                   continue;
3628                 }
3629             }
3630           else if (! referable)
3631             {
3632               /* in the write case we create a temporary if not referable */
3633               tree loc = build_decl (VAR_DECL,
3634                                      get_unique_identifier ("WRTEXTVS"),
3635                                      item_type);
3636               DECL_RTL (loc) = assign_temp (item_type, 0, 1, 0);
3637               expand_assignment (loc, item, 0, 0);
3638               item_addr = force_addr_of (loc);
3639             }
3640
3641           expand_assignment (string, item_addr, 0, 0);
3642           expand_assignment (length, build_chill_length (item), 0, 0);
3643
3644           enumname = "__IO_BitStrLoc";
3645         }
3646       else if (TREE_CODE (item_type) == REAL_TYPE)
3647         {
3648           /* process a (long_)real */
3649           tree  t, forxx, to_assign;
3650
3651           if (do_read && readonly)
3652             {
3653               error ("argument %d is READonly", idxcnt + 1 + argoffset);
3654               continue;
3655             }
3656           if (do_read && ! referable)
3657             {
3658               error ("argument %d must be referable", idxcnt + 1 + argoffset);
3659               continue;
3660             }
3661
3662           if (lookup_name (ridpointers[RID_FLOAT]) == TYPE_NAME (item_type))
3663             {
3664               /* we have a real */
3665               if (do_read)
3666                 {
3667                   enumname = "__IO_RealLoc";
3668                   fieldname = "__locreal";
3669                   to_assign = item_addr;
3670                 }
3671               else
3672                 {
3673                   enumname = "__IO_RealVal";
3674                   fieldname = "__valreal";
3675                   to_assign = item;
3676                 }
3677             }
3678           else
3679             {
3680               /* we have a long_real */
3681               if (do_read)
3682                 {
3683                   enumname = "__IO_LongRealLoc";
3684                   fieldname = "__loclongreal";
3685                   to_assign = item_addr;
3686                 }
3687               else
3688                 {
3689                   enumname = "__IO_LongRealVal";
3690                   fieldname = "__vallongreal";
3691                   to_assign = item;
3692                 }
3693             }
3694           t = build_component_ref (array_ref, get_identifier ("__t"));
3695           forxx = build_component_ref (t, get_identifier (fieldname));
3696           expand_assignment (forxx, to_assign, 0, 0);
3697         }
3698 #if 0
3699       /* don't process them for now */
3700       else if (TREE_CODE (item_type) == POINTER_TYPE)
3701         {
3702           /* we have a pointer */
3703           tree  __t, __forxx;
3704
3705           __t = build_component_ref (array_ref, get_identifier ("__t"));
3706           __forxx = build_component_ref (__t, get_identifier ("__forpointer"));
3707           expand_assignment (__forxx, item, 0, 0);
3708           enumname = "_IO_Pointer";
3709         }
3710       else if (item_type == instance_type_node)
3711         {
3712           /* we have an INSTANCE */
3713           tree  __t, __forxx;
3714
3715           __t = build_component_ref (array_ref, get_identifier ("__t"));
3716           __forxx = build_component_ref (__t, get_identifier ("__forinstance"));
3717           expand_assignment (__forxx, item, 0, 0);
3718           enumname = "_IO_Instance";
3719         }
3720 #endif
3721       else
3722         {
3723           /* datatype is not yet implemented, issue a warning */
3724           error ("cannot process mode of argument %d for %sTEXT.", idxcnt + 1 + argoffset,
3725                  do_read ? "READ" : "WRITE");
3726           enumname = "__IO_UNUSED";
3727         }
3728
3729       /* do assignment of the enum */
3730       if (enumname)
3731         {
3732           tree descr = build_component_ref (array_ref,
3733                                             get_identifier ("__descr"));
3734           expand_assignment (descr,
3735                              lookup_name (get_identifier (enumname)), 0, 0);
3736         }
3737     }
3738
3739   /* set up address and length of iolist */
3740   *iolist_addr = build_chill_addr_expr (iolist, (char *)0);
3741   *iolist_length = build_int_2 (iolen, 0);
3742 }
3743 \f
3744 /* check the format string */
3745 #define LET 0x0001
3746 #define BIN 0x0002
3747 #define DEC 0x0004
3748 #define OCT 0x0008
3749 #define HEX 0x0010
3750 #define USC 0x0020
3751 #define BIL 0x0040
3752 #define SPC 0x0080
3753 #define SCS 0x0100
3754 #define IOC 0x0200
3755 #define EDC 0x0400
3756 #define CVC 0x0800
3757
3758 #define isDEC(c)  ( chartab[(c)] & DEC )
3759 #define isCVC(c)  ( chartab[(c)] & CVC )
3760 #define isEDC(c)  ( chartab[(c)] & EDC )
3761 #define isIOC(c)  ( chartab[(c)] & IOC )
3762 #define isUSC(c)
3763 #define isXXX(c,XXX)  ( chartab[(c)] & XXX )
3764
3765 static
3766 short int chartab[256] = {
3767   0, 0, 0, 0, 0, 0, 0, 0,
3768   0, SPC, SPC, SPC, SPC, SPC, 0, 0,
3769
3770   0, 0, 0, 0, 0, 0, 0, 0,
3771   0, 0, 0, 0, 0, 0, 0, 0,
3772
3773   SPC, IOC, 0, 0, 0, 0, 0, 0,
3774   SCS, SCS, SCS, SCS+IOC, SCS, SCS+IOC, SCS, SCS+IOC,
3775   BIN+OCT+DEC+HEX, BIN+OCT+DEC+HEX, OCT+DEC+HEX, OCT+DEC+HEX, OCT+DEC+HEX,
3776      OCT+DEC+HEX, OCT+DEC+HEX, OCT+DEC+HEX,
3777   DEC+HEX, DEC+HEX, SCS, SCS, SCS+EDC, SCS+IOC, SCS+EDC, IOC,
3778
3779   0, LET+HEX+BIL, LET+HEX+BIL+CVC, LET+HEX+BIL+CVC, LET+HEX+BIL, LET+HEX,
3780      LET+HEX+CVC, LET,
3781   LET+BIL+CVC, LET, LET, LET, LET, LET, LET, LET+CVC,
3782
3783   LET, LET, LET, LET, LET+EDC, LET, LET, LET,
3784   LET+EDC, LET, LET, SCS, 0, SCS, 0, USC,
3785
3786   0, LET+HEX, LET+HEX, LET+HEX, LET+HEX, LET+HEX, LET+HEX, LET,
3787   LET, LET, LET, LET, LET, LET, LET, LET,
3788
3789   LET, LET, LET, LET, LET, LET, LET, LET,
3790   LET, LET, LET, 0, 0, 0, 0, 0
3791 };
3792
3793 typedef enum
3794 {
3795   FormatText, FirstPercent, RepFact, ConvClause, EditClause, ClauseEnd,
3796   AfterWidth, FractWidth, FractWidthCont, ExpoWidth, ExpoWidthCont,
3797   ClauseWidth, CatchPadding, LastPercent
3798 } fcsstate_t;
3799
3800 #define CONVERSIONCODES "CHOBF"
3801 typedef enum
3802 {
3803   DefaultConv, HexConv, OctalConv, BinaryConv, ScientConv
3804 } convcode_t;
3805 static convcode_t     convcode;
3806
3807 static tree check_exprlist              PARAMS ((convcode_t, tree, int,
3808                                                 unsigned long));
3809
3810 typedef enum
3811 {
3812   False, True,
3813 } Boolean;
3814
3815 static unsigned long  fractionwidth;
3816
3817 #define IOCODES "/+-?!="
3818 typedef enum {
3819   NextRecord, NextPage, CurrentLine, Prompt, Emit, EndPage
3820 } iocode_t;
3821 static iocode_t       iocode;
3822
3823 #define EDITCODES "X<>T"
3824 typedef enum {
3825   SpaceSkip, SkipLeft, SkipRight, Tabulation
3826 } editcode_t;
3827 static editcode_t     editcode;
3828
3829 static unsigned long  clausewidth;
3830 static Boolean        leftadjust;
3831 static Boolean        overflowev;
3832 static Boolean        dynamicwid;
3833 static Boolean        paddingdef;
3834 static char           paddingchar;
3835 static Boolean        fractiondef;
3836 static Boolean        exponentdef;
3837 static unsigned long  exponentwidth;
3838 static unsigned long  repetition;
3839
3840 typedef enum {
3841   NormalEnd, EndAtParen, TextFailEnd
3842 } formatexit_t;
3843
3844 static formatexit_t scanformcont        PARAMS ((char *, int, char **, int *,
3845                                                 tree, tree *, int, int *));
3846
3847 /* NOTE: varibale have to be set to False before calling check_format_string */
3848 static Boolean empty_printed;
3849
3850 static int formstroffset;
3851
3852 static tree
3853 check_exprlist (code, exprlist, argnum, repetition)
3854      convcode_t code;
3855      tree exprlist;
3856      int argnum;
3857      unsigned long repetition;
3858 {
3859   tree expr, type, result = NULL_TREE;
3860
3861   while (repetition--)
3862     {
3863       if (exprlist == NULL_TREE)
3864         {
3865           if (empty_printed == False)
3866             {
3867               warning ("too few arguments for this format string");
3868               empty_printed = True;
3869             }
3870           return NULL_TREE;
3871         }
3872       expr = TREE_VALUE (exprlist);
3873       result = exprlist = TREE_CHAIN (exprlist);
3874       if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
3875         return result;
3876       type = TREE_TYPE (expr);
3877       if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
3878         return result;
3879       if (TREE_CODE (type) == REFERENCE_TYPE)
3880         type = TREE_TYPE (type);
3881       if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
3882         return result;
3883
3884       switch (code)
3885         {
3886         case DefaultConv:
3887           /* %C, everything is allowed. Not know types are flaged later. */
3888           break;
3889         case ScientConv:
3890           /* %F, must be a REAL */
3891           if (TREE_CODE (type) != REAL_TYPE)
3892             warning ("type of argument %d invalid for conversion code at offset %d",
3893                      argnum, formstroffset);
3894           break;
3895         case HexConv:
3896         case OctalConv:
3897         case BinaryConv:
3898         case -1:
3899           /* %H, %O, %B, and V as clause width */
3900           if (TREE_CODE (type) != INTEGER_TYPE)
3901             warning ("type of argument %d invalid for conversion code at offset %d",
3902                      argnum, formstroffset);
3903           break;
3904         default:
3905           /* there is an invalid conversion code */
3906           break;
3907         }
3908     }
3909   return result;
3910 }
3911
3912 static formatexit_t
3913 scanformcont (fcs, len, fcsptr, lenptr, exprlist, exprptr,
3914               firstargnum, nextargnum)
3915      char *fcs;
3916      int len;
3917      char **fcsptr;
3918      int *lenptr;
3919      tree exprlist;
3920      tree *exprptr;
3921      int firstargnum;
3922      int *nextargnum;
3923 {
3924   fcsstate_t state = FormatText;
3925   unsigned char curr;
3926   int dig;
3927
3928   while (len--)
3929     {
3930       curr = *fcs++;
3931       formstroffset++;
3932       switch (state)
3933         {
3934         case FormatText:
3935           if (curr == '%')
3936             state = FirstPercent;
3937           break;
3938
3939         after_first_percent: ;
3940         case FirstPercent:
3941           if (curr == '%')
3942             {
3943               state = FormatText;
3944               break;
3945             }
3946           if (curr == ')')
3947             {
3948               *lenptr = len;
3949               *fcsptr = fcs;
3950               *exprptr = exprlist;
3951               *nextargnum = firstargnum;
3952               return EndAtParen;
3953             }
3954           if (isDEC (curr))
3955             {
3956               state = RepFact;
3957               repetition = curr - '0';
3958               break;
3959             }
3960
3961           repetition = 1;
3962
3963         test_for_control_codes: ;
3964           if (isCVC (curr))
3965             {
3966               state = ConvClause;
3967               convcode = strchr (CONVERSIONCODES, curr) - CONVERSIONCODES;
3968               leftadjust = False;
3969               overflowev = False;
3970               dynamicwid = False;
3971               paddingdef = False;
3972               paddingchar = ' ';
3973               fractiondef = False;
3974               /* fractionwidth = 0; default depends on mode ! */
3975               exponentdef = False;
3976               exponentwidth = 3;
3977               clausewidth = 0;
3978               /* check the argument */
3979               exprlist = check_exprlist (convcode, exprlist, firstargnum, repetition);
3980               firstargnum++;
3981               break;
3982             }
3983           if (isEDC (curr))
3984             {
3985               state = EditClause;
3986               editcode = strchr (EDITCODES, curr) - EDITCODES;
3987               dynamicwid = False;
3988               clausewidth = editcode == Tabulation ? 0 : 1;
3989               break;
3990             }
3991           if (isIOC (curr))
3992             {
3993               state = ClauseEnd;
3994               iocode = strchr (IOCODES, curr) - IOCODES;
3995               break;
3996             }
3997           if (curr == '(')
3998             {
3999               unsigned long times = repetition;
4000               int  cntlen;
4001               char* cntfcs;
4002               tree cntexprlist;
4003               int nextarg;
4004
4005               while (times--)
4006                 {
4007                   if (scanformcont (fcs, len, &cntfcs, &cntlen,
4008                                     exprlist, &cntexprlist,
4009                                     firstargnum, &nextarg) != EndAtParen )
4010                     {
4011                       warning ("unmatched open paren");
4012                       break;
4013                     }
4014                   exprlist = cntexprlist;
4015                 }
4016               fcs = cntfcs;
4017               len = cntlen;
4018               if (len < 0)
4019                 len = 0;
4020               exprlist = cntexprlist;
4021               firstargnum = nextarg;
4022               state  = FormatText;
4023               break;
4024             }
4025           warning ("bad format specification character (offset %d)", formstroffset);
4026           state = FormatText;
4027           /* skip one argument */
4028           if (exprlist != NULL_TREE)
4029             exprlist = TREE_CHAIN (exprlist);
4030           break;
4031
4032         case RepFact:
4033           if (isDEC (curr))
4034             {
4035               dig = curr - '0';
4036               if (repetition > (ULONG_MAX - dig)/10)
4037                 {
4038                   warning ("repetition factor overflow (offset %d)", formstroffset);
4039                   return TextFailEnd;
4040                 }
4041               repetition = repetition*10 + dig;
4042               break;
4043             }
4044           goto test_for_control_codes;
4045
4046         case ConvClause:
4047           if (isDEC (curr))
4048             {
4049               state = ClauseWidth;
4050               clausewidth = curr - '0';
4051               break;
4052             }
4053           if (curr == 'L')
4054             {
4055               if (leftadjust)
4056                 warning ("duplicate qualifier (offset %d)", formstroffset);
4057               leftadjust = True;
4058               break;
4059             }
4060           if (curr == 'E')
4061             {
4062               if (overflowev)
4063                 warning ("duplicate qualifier (offset %d)", formstroffset);
4064               overflowev = True;
4065               break;
4066             }
4067           if (curr == 'P')
4068             {
4069               if (paddingdef)
4070                 warning ("duplicate qualifier (offset %d)", formstroffset);
4071               paddingdef = True;
4072               state = CatchPadding;
4073               break;
4074             }
4075
4076         test_for_variable_width: ;
4077           if (curr == 'V')
4078             {
4079               dynamicwid = True;
4080               state = AfterWidth;
4081               exprlist = check_exprlist (-1, exprlist, firstargnum, 1);
4082               firstargnum++;
4083               break;
4084             }
4085           goto test_for_fraction_width;
4086
4087         case ClauseWidth:
4088           if (isDEC (curr))
4089             {
4090               dig = curr - '0';
4091               if (clausewidth > (ULONG_MAX - dig)/10)
4092                 warning ("clause width overflow (offset %d)", formstroffset);
4093               else
4094                 clausewidth = clausewidth*10 + dig;
4095               break;
4096             }
4097           /* fall through */
4098
4099         test_for_fraction_width: ;
4100         case AfterWidth:
4101           if (curr == '.')
4102             {
4103               if (convcode != DefaultConv && convcode != ScientConv)
4104                 {
4105                   warning ("no fraction (offset %d)", formstroffset);
4106                   state = FormatText;
4107                   break;
4108                 }
4109               fractiondef = True;
4110               state = FractWidth;
4111               break;
4112             }
4113           goto test_for_exponent_width;
4114
4115         case FractWidth:
4116           if (isDEC (curr))
4117             {
4118               state = FractWidthCont;
4119               fractionwidth = curr - '0';
4120               break;
4121             }
4122           else
4123             warning ("no fraction width (offset %d)", formstroffset);
4124
4125         case FractWidthCont:
4126           if (isDEC (curr))
4127             {
4128               dig = curr - '0';
4129               if (fractionwidth > (ULONG_MAX - dig)/10)
4130                 warning ("fraction width overflow (offset %d)", formstroffset);
4131               else
4132                 fractionwidth = fractionwidth*10 + dig;
4133               break;
4134             }
4135
4136         test_for_exponent_width: ;
4137           if (curr == ':')
4138             {
4139               if (convcode != ScientConv)
4140                 {
4141                   warning ("no exponent (offset %d)", formstroffset);
4142                   state = FormatText;
4143                   break;
4144                 }
4145               exponentdef = True;
4146               state = ExpoWidth;
4147               break;
4148             }
4149           goto test_for_final_percent;
4150
4151         case ExpoWidth:
4152           if (isDEC (curr))
4153             {
4154               state = ExpoWidthCont;
4155               exponentwidth = curr - '0';
4156               break;
4157             }
4158           else
4159             warning ("no exponent width (offset %d)", formstroffset);
4160
4161         case ExpoWidthCont:
4162           if (isDEC (curr))
4163             {
4164               dig = curr - '0';
4165               if (exponentwidth > (ULONG_MAX - dig)/10)
4166                 warning ("exponent width overflow (offset %d)", formstroffset);
4167               else
4168                 exponentwidth = exponentwidth*10 + dig;
4169               break;
4170             }
4171           /* fall through  */
4172
4173         test_for_final_percent: ;
4174         case ClauseEnd:
4175           if (curr == '%')
4176             {
4177               state = LastPercent;
4178               break;
4179             }
4180
4181           state = FormatText;
4182           break;
4183
4184         case CatchPadding:
4185           paddingchar = curr;
4186           state = ConvClause;
4187           break;
4188
4189         case EditClause:
4190           if (isDEC (curr))
4191             {
4192               state = ClauseWidth;
4193               clausewidth = curr - '0';
4194               break;
4195             }
4196           goto test_for_variable_width;
4197
4198         case LastPercent:
4199           if (curr == '.')
4200             {
4201               state = FormatText;
4202               break;
4203             }
4204           goto after_first_percent;
4205
4206         default:
4207           error ("internal error in check_format_string");
4208         }
4209     }
4210
4211   switch (state)
4212     {
4213     case FormatText:
4214       break;
4215     case FirstPercent:
4216     case LastPercent:
4217     case RepFact:
4218     case FractWidth:
4219     case ExpoWidth:
4220       warning ("bad format specification character (offset %d)", formstroffset);
4221       break;
4222     case CatchPadding:
4223       warning ("no padding character (offset %d)", formstroffset);
4224       break;
4225     default:
4226       break;
4227     }
4228   *fcsptr = fcs;
4229   *lenptr = len;
4230   *exprptr = exprlist;
4231   *nextargnum = firstargnum;
4232   return NormalEnd;
4233 }
4234 static void
4235 check_format_string (format_str, exprlist, firstargnum)
4236      tree format_str;
4237      tree exprlist;
4238      int firstargnum;
4239 {
4240   char *x;
4241   int y, yy;
4242   tree z = NULL_TREE;
4243
4244   if (TREE_CODE (format_str) != STRING_CST)
4245     /* do nothing if we don't have a string constant */
4246     return;
4247
4248   formstroffset = -1;
4249   scanformcont (TREE_STRING_POINTER (format_str),
4250                 TREE_STRING_LENGTH (format_str), &x, &y,
4251                 exprlist, &z,
4252                 firstargnum, &yy);
4253   if (z != NULL_TREE)
4254     /* too  may arguments for format string */
4255     warning ("too many arguments for this format string");
4256 }
4257 \f
4258 static int
4259 get_max_size (expr)
4260      tree expr;
4261 {
4262   if (TREE_CODE (expr) == INDIRECT_REF)
4263     {
4264       tree x = TREE_OPERAND (expr, 0);
4265       tree y = TREE_OPERAND (x, 0);
4266       return int_size_in_bytes (TREE_TYPE (y));
4267     }
4268   else if (TREE_CODE (expr) == CONCAT_EXPR)
4269     return intsize_of_charsexpr (expr);
4270   else
4271     return int_size_in_bytes (TREE_TYPE (expr));
4272 }
4273
4274 static int
4275 intsize_of_charsexpr (expr)
4276      tree expr;
4277 {
4278   int op0size, op1size;
4279
4280   if (TREE_CODE (expr) != CONCAT_EXPR)
4281     return -1;
4282
4283   /* find maximum length of CONCAT_EXPR, this is the worst case */
4284   op0size = get_max_size (TREE_OPERAND (expr, 0));
4285   op1size = get_max_size (TREE_OPERAND (expr, 1));
4286   if (op0size == -1 || op1size == -1)
4287     return -1;
4288   return op0size + op1size;
4289 }
4290
4291 tree
4292 build_chill_writetext (text_arg, exprlist)
4293      tree text_arg, exprlist;
4294 {
4295   tree iolist_addr = null_pointer_node;
4296   tree iolist_length = integer_zero_node;
4297   tree fstr_addr;
4298   tree fstr_length;
4299   tree outstr_addr;
4300   tree outstr_length;
4301   tree fstrtype;
4302   tree outfunction;
4303   tree filename, linenumber;
4304   tree format_str = NULL_TREE, indexexpr = NULL_TREE;
4305   rtx  iolist_rtx = NULL_RTX;
4306   int argoffset = 0;
4307
4308   /* make some checks */
4309   if (text_arg == NULL_TREE || TREE_CODE (text_arg) == ERROR_MARK)
4310     return error_mark_node;
4311
4312   if (exprlist != NULL_TREE)
4313     {
4314       if (TREE_CODE (exprlist) != TREE_LIST)
4315         return error_mark_node;
4316     }
4317
4318   /* check the text argument */
4319   if (chill_varying_string_type_p (TREE_TYPE (text_arg)))
4320     {
4321       /* build outstr-addr and outstr-length assuming that this is a CHAR (n) VARYING */
4322       outstr_addr = force_addr_of (text_arg);
4323       outstr_length = size_in_bytes (CH_VARYING_ARRAY_TYPE (TREE_TYPE (text_arg)));
4324       outfunction = lookup_name (get_identifier ("__writetext_s"));
4325       format_str = TREE_VALUE (exprlist);
4326       exprlist = TREE_CHAIN (exprlist);
4327     }
4328   else if (CH_IS_TEXT_MODE (TREE_TYPE (text_arg)))
4329     {
4330       /* we have a text mode */
4331       tree indexmode;
4332
4333       if (! check_text (text_arg, 1, "WRITETEXT"))
4334         return error_mark_node;
4335       indexmode = text_indexmode (TREE_TYPE (text_arg));
4336       if (indexmode == void_type_node)
4337         {
4338           /* no index */
4339           format_str = TREE_VALUE (exprlist);
4340           exprlist = TREE_CHAIN (exprlist);
4341         }
4342       else
4343         {
4344           /* we have an index. there must be an index argument before format string */
4345           indexexpr = TREE_VALUE (exprlist);
4346           exprlist = TREE_CHAIN (exprlist);
4347           if (! CH_COMPATIBLE (indexexpr, indexmode))
4348             {
4349               if (chill_varying_string_type_p (TREE_TYPE (indexexpr)) ||
4350                   (CH_CHARS_TYPE_P (TREE_TYPE (indexexpr)) ||
4351                    (flag_old_strings && TREE_CODE (indexexpr) == INTEGER_CST &&
4352                     TREE_CODE (TREE_TYPE (indexexpr)) == CHAR_TYPE)))
4353                 error ("missing index expression");
4354               else
4355                 error ("incompatible index mode");
4356               return error_mark_node;
4357             }
4358           if (exprlist == NULL_TREE)
4359             {
4360               error ("Too few arguments in call to `writetext'");
4361               return error_mark_node;
4362             }
4363           format_str = TREE_VALUE (exprlist);
4364           exprlist = TREE_CHAIN (exprlist);
4365           argoffset = 1;
4366         }
4367       outstr_addr = force_addr_of (text_arg);
4368       outstr_length = convert (integer_type_node, indexexpr);
4369       outfunction = lookup_name (get_identifier ("__writetext_f"));
4370     }
4371   else
4372     {
4373       error ("argument 1 for WRITETEXT must be a TEXT or CHARS(n) VARYING location");
4374       return error_mark_node;
4375     }
4376
4377   /* check the format string */
4378   fstrtype = TREE_TYPE (format_str);
4379   if (CH_CHARS_TYPE_P (fstrtype) ||
4380       (flag_old_strings && TREE_CODE (format_str) == INTEGER_CST &&
4381        TREE_CODE (fstrtype) == CHAR_TYPE))
4382     {
4383       /* we have a character string */
4384       fstr_addr = force_addr_of (format_str);
4385       fstr_length = size_in_bytes (fstrtype);
4386     }
4387   else if (chill_varying_string_type_p (TREE_TYPE (format_str)))
4388     {
4389       /* we have a varying char string */
4390       fstr_addr
4391         = force_addr_of (build_component_ref (format_str, var_data_id));
4392       fstr_length = build_component_ref (format_str, var_length_id);
4393     }
4394   else
4395     {
4396       error ("`format string' for WRITETEXT must be a CHARACTER string");
4397       return error_mark_node;
4398     }
4399
4400   empty_printed = False;
4401   check_format_string (format_str, exprlist, argoffset + 3);
4402   process_io_list (exprlist, &iolist_addr, &iolist_length, &iolist_rtx, 0, argoffset);
4403
4404   /* tree to call the function */
4405
4406   filename = force_addr_of (get_chill_filename ());
4407   linenumber = get_chill_linenumber ();
4408
4409   expand_expr_stmt (
4410     build_chill_function_call (outfunction,
4411       tree_cons (NULL_TREE, outstr_addr,
4412         tree_cons (NULL_TREE, outstr_length,
4413           tree_cons (NULL_TREE, fstr_addr,
4414             tree_cons (NULL_TREE, fstr_length,
4415               tree_cons (NULL_TREE, iolist_addr,
4416                 tree_cons (NULL_TREE, iolist_length,
4417                   tree_cons (NULL_TREE, filename,
4418                     tree_cons (NULL_TREE, linenumber,
4419                       NULL_TREE))))))))));
4420
4421   /* get rid of the iolist variable, if we have one */
4422   if (iolist_rtx != NULL_RTX)
4423     {
4424       free_temp_slots ();
4425       pop_temp_slots ();
4426       free_temp_slots ();
4427       pop_temp_slots ();
4428     }
4429
4430   /* return something the rest of the machinery can work with,
4431      i.e. (void)0 */
4432   return build1 (CONVERT_EXPR, void_type_node, integer_zero_node);
4433 }
4434
4435 tree
4436 build_chill_readtext (text_arg, exprlist)
4437      tree text_arg, exprlist;
4438 {
4439   tree instr_addr, instr_length, infunction;
4440   tree fstr_addr, fstr_length, fstrtype;
4441   tree iolist_addr = null_pointer_node;
4442   tree iolist_length = integer_zero_node;
4443   tree filename, linenumber;
4444   tree format_str = NULL_TREE, indexexpr = NULL_TREE;
4445   rtx  iolist_rtx = NULL_RTX;
4446   int argoffset = 0;
4447
4448   /* make some checks */
4449   if (text_arg == NULL_TREE || TREE_CODE (text_arg) == ERROR_MARK)
4450     return error_mark_node;
4451
4452   if (exprlist != NULL_TREE)
4453     {
4454       if (TREE_CODE (exprlist) != TREE_LIST)
4455         return error_mark_node;
4456     }
4457
4458   /* check the text argument */
4459   if (CH_CHARS_TYPE_P (TREE_TYPE (text_arg)))
4460     {
4461       instr_addr = force_addr_of (text_arg);
4462       instr_length = size_in_bytes (TREE_TYPE (text_arg));
4463       infunction = lookup_name (get_identifier ("__readtext_s"));
4464       format_str = TREE_VALUE (exprlist);
4465       exprlist = TREE_CHAIN (exprlist);
4466     }
4467   else if (chill_varying_string_type_p (TREE_TYPE (text_arg)))
4468     {
4469       instr_addr
4470         = force_addr_of (build_component_ref (text_arg, var_data_id));
4471       instr_length = build_component_ref (text_arg, var_length_id);
4472       infunction = lookup_name (get_identifier ("__readtext_s"));
4473       format_str = TREE_VALUE (exprlist);
4474       exprlist = TREE_CHAIN (exprlist);
4475     }
4476   else if (CH_IS_TEXT_MODE (TREE_TYPE (text_arg)))
4477     {
4478       /* we have a text mode */
4479       tree indexmode;
4480
4481       if (! check_text (text_arg, 1, "READTEXT"))
4482         return error_mark_node;
4483       indexmode = text_indexmode (TREE_TYPE (text_arg));
4484       if (indexmode == void_type_node)
4485         {
4486           /* no index */
4487           format_str = TREE_VALUE (exprlist);
4488           exprlist = TREE_CHAIN (exprlist);
4489         }
4490       else
4491         {
4492           /* we have an index. there must be an index argument before format string */
4493           indexexpr = TREE_VALUE (exprlist);
4494           exprlist = TREE_CHAIN (exprlist);
4495           if (! CH_COMPATIBLE (indexexpr, indexmode))
4496             {
4497               if (chill_varying_string_type_p (TREE_TYPE (indexexpr)) ||
4498                   (CH_CHARS_TYPE_P (TREE_TYPE (indexexpr)) ||
4499                    (flag_old_strings && TREE_CODE (indexexpr) == INTEGER_CST &&
4500                     TREE_CODE (TREE_TYPE (indexexpr)) == CHAR_TYPE)))
4501                 error ("missing index expression");
4502               else
4503                 error ("incompatible index mode");
4504               return error_mark_node;
4505             }
4506           if (exprlist == NULL_TREE)
4507             {
4508               error ("Too few arguments in call to `readtext'");
4509               return error_mark_node;
4510             }
4511           format_str = TREE_VALUE (exprlist);
4512           exprlist = TREE_CHAIN (exprlist);
4513           argoffset = 1;
4514         }
4515       instr_addr = force_addr_of (text_arg);
4516       instr_length = convert (integer_type_node, indexexpr);
4517       infunction = lookup_name (get_identifier ("__readtext_f"));
4518     }
4519   else
4520     {
4521       error ("argument 1 for READTEXT must be a TEXT location or CHARS(n) [ VARYING ] expression");
4522       return error_mark_node;
4523     }
4524
4525   /* check the format string */
4526   fstrtype = TREE_TYPE (format_str);
4527   if (CH_CHARS_TYPE_P (fstrtype))
4528     {
4529       /* we have a character string */
4530       fstr_addr = force_addr_of (format_str);
4531       fstr_length = size_in_bytes (fstrtype);
4532     }
4533   else if (chill_varying_string_type_p (fstrtype))
4534     {
4535       /* we have a CHARS(n) VARYING */
4536       fstr_addr
4537         = force_addr_of (build_component_ref (format_str, var_data_id));
4538       fstr_length = build_component_ref (format_str, var_length_id);
4539     }
4540   else
4541     {
4542       error ("`format string' for READTEXT must be a CHARACTER string");
4543       return error_mark_node;
4544     }
4545
4546   empty_printed = False;
4547   check_format_string (format_str, exprlist, argoffset + 3);
4548   process_io_list (exprlist, &iolist_addr, &iolist_length, &iolist_rtx, 1, argoffset);
4549
4550   /* build the function call */
4551   filename = force_addr_of (get_chill_filename ());
4552   linenumber = get_chill_linenumber ();
4553   expand_expr_stmt (
4554     build_chill_function_call (infunction,
4555       tree_cons (NULL_TREE, instr_addr,
4556         tree_cons (NULL_TREE, instr_length,
4557           tree_cons (NULL_TREE, fstr_addr,
4558             tree_cons (NULL_TREE, fstr_length,
4559               tree_cons (NULL_TREE, iolist_addr,
4560                 tree_cons (NULL_TREE, iolist_length,
4561                   tree_cons (NULL_TREE, filename,
4562                     tree_cons (NULL_TREE, linenumber,
4563                       NULL_TREE))))))))));
4564
4565   /* get rid of the iolist variable, if we have one */
4566   if (iolist_rtx != NULL_RTX)
4567     {
4568       free_temp_slots ();
4569       pop_temp_slots ();
4570       free_temp_slots ();
4571       pop_temp_slots ();
4572     }
4573
4574   /* return something the rest of the machinery can work with,
4575      i.e. (void)0 */
4576   return build1 (CONVERT_EXPR, void_type_node, integer_zero_node);
4577 }
4578
4579 /* this function build all neccesary enum-tables used for
4580    WRITETEXT or READTEXT of an enum */
4581
4582 void build_enum_tables ()
4583 {
4584   SAVE_ENUM_NAMES       *names;
4585   SAVE_ENUMS            *wrk;
4586   void          *saveptr;
4587   /* We temporarily reset the maximum_field_alignment to zero so the
4588      compiler's init data structures can be compatible with the
4589      run-time system, even when we're compiling with -fpack. */
4590   unsigned int save_maximum_field_alignment;
4591
4592   if (pass == 1)
4593     return;
4594
4595   save_maximum_field_alignment = maximum_field_alignment;
4596   maximum_field_alignment = 0;
4597
4598   /* output all names */
4599   names = used_enum_names;
4600
4601   while (names != (SAVE_ENUM_NAMES *)0)
4602     {
4603       tree      var = get_unique_identifier ("ENUMNAME");
4604       tree      type;
4605
4606       type = build_string_type (char_type_node,
4607                                 build_int_2 (IDENTIFIER_LENGTH (names->name) + 1, 0));
4608       names->decl = decl_temp1 (var, type, 1,
4609                                 build_chill_string (IDENTIFIER_LENGTH (names->name) + 1,
4610                                                     IDENTIFIER_POINTER (names->name)),
4611                                 0, 0);
4612       names = names->forward;
4613     }
4614
4615   /* output the tables and pointers to tables */
4616   wrk = used_enums;
4617   while (wrk != (SAVE_ENUMS *)0)
4618     {
4619       tree      varptr = wrk->ptrdecl;
4620       tree      table_addr = null_pointer_node;
4621       tree      init = NULL_TREE, one_entry;
4622       tree      table, idxlist, tabletype, addr;
4623       SAVE_ENUM_VALUES  *vals;
4624       int       i;
4625
4626       vals = wrk->vals;
4627       for (i = 0; i < wrk->num_vals; i++)
4628         {
4629           tree decl = vals->name->decl;
4630           addr = build1 (ADDR_EXPR,
4631                          build_pointer_type (char_type_node),
4632                          decl);
4633           TREE_CONSTANT (addr) = 1;
4634           one_entry = tree_cons (NULL_TREE, build_int_2 (vals->val, 0),
4635                                  tree_cons (NULL_TREE, addr, NULL_TREE));
4636           one_entry = build_nt (CONSTRUCTOR, NULL_TREE, one_entry);
4637           init = tree_cons (NULL_TREE, one_entry, init);
4638           vals++;
4639         }
4640
4641       /* add the terminator (name = null_pointer_node) to constructor */
4642       one_entry = tree_cons (NULL_TREE, integer_zero_node,
4643                              tree_cons (NULL_TREE, null_pointer_node, NULL_TREE));
4644       one_entry = build_nt (CONSTRUCTOR, NULL_TREE, one_entry);
4645       init = tree_cons (NULL_TREE, one_entry, init);
4646       init = nreverse (init);
4647       init = build_nt (CONSTRUCTOR, NULL_TREE, init);
4648       TREE_CONSTANT (init) = 1;
4649
4650       /* generate table */
4651       idxlist = build_tree_list (NULL_TREE,
4652                                  build_chill_range_type (NULL_TREE,
4653                                                          integer_zero_node,
4654                                                          build_int_2 (wrk->num_vals, 0)));
4655       tabletype = build_chill_array_type (TREE_TYPE (enum_table_type),
4656                                           idxlist, 0, NULL_TREE);
4657       table = decl_temp1 (get_unique_identifier ("ENUMTAB"), tabletype,
4658                           1, init, 0, 0);
4659       table_addr = build1 (ADDR_EXPR,
4660                            build_pointer_type (TREE_TYPE (enum_table_type)),
4661                            table);
4662       TREE_CONSTANT (table_addr) = 1;
4663
4664       /* generate pointer to table */
4665       decl_temp1 (DECL_NAME (varptr), TREE_TYPE (table_addr),
4666                   1, table_addr, 0, 0);
4667
4668       /* free that stuff */
4669       saveptr = wrk->forward;
4670
4671       free (wrk->vals);
4672       free (wrk);
4673
4674       /* next enum */
4675       wrk = saveptr;
4676     }
4677
4678   /* free all the names */
4679   names = used_enum_names;
4680   while (names != (SAVE_ENUM_NAMES *)0)
4681     {
4682       saveptr = names->forward;
4683       free (names);
4684       names = saveptr;
4685     }
4686
4687   used_enums = (SAVE_ENUMS *)0;
4688   used_enum_names = (SAVE_ENUM_NAMES *)0;
4689   maximum_field_alignment = save_maximum_field_alignment;
4690 }