gcc/ch/inout.c

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