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