gcc/ch/inout.c

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