/* Implement I/O-related actions for CHILL. Copyright (C) 1992, 93, 1994, 1998, 1999 Free Software Foundation, Inc. This file is part of GNU CC. GNU CC is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. GNU CC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with GNU CC; see the file COPYING. If not, write to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #include "config.h" #include "system.h" #include "tree.h" #include "ch-tree.h" #include "rtl.h" #include "lex.h" #include "flags.h" #include "input.h" #include "assert.h" #include "toplev.h" /* set non-zero if input text is forced to lowercase */ extern int ignore_case; /* set non-zero if special words are to be entered in uppercase */ extern int special_UC; static int intsize_of_charsexpr PROTO((tree)); /* association mode */ tree association_type_node; /* initialzier for association mode */ tree association_init_value; /* NOTE: should be same as in runtime/chillrt0.c */ #define STDIO_TEXT_LENGTH 1024 /* mode of stdout, stdin, stderr*/ static tree stdio_type_node; /* usage- and where modes */ tree usage_type_node; tree where_type_node; /* we have to distinguish between io-list-type for WRITETEXT and for READTEXT. WRITETEXT does not process ranges and READTEXT must get pointers to the variables. */ /* variable to hold the type of the io_list */ static tree chill_io_list_type = NULL_TREE; /* the type for the enum tables */ static tree enum_table_type = NULL_TREE; /* structure to save enums for later use in compilation */ typedef struct save_enum_names { struct save_enum_names *forward; tree name; tree decl; } SAVE_ENUM_NAMES; static SAVE_ENUM_NAMES *used_enum_names = (SAVE_ENUM_NAMES *)0; typedef struct save_enum_values { long val; struct save_enum_names *name; } SAVE_ENUM_VALUES; typedef struct save_enums { struct save_enums *forward; tree context; tree type; tree ptrdecl; long num_vals; struct save_enum_values *vals; } SAVE_ENUMS; static SAVE_ENUMS *used_enums = (SAVE_ENUMS *)0; /* Function collects all enums are necessary to collect, makes a copy of the value and returns a VAR_DECL external to current function describing the pointer to a name table, which will be generated at the end of compilation */ static tree add_enum_to_list (type, context) tree type; tree context; { tree tmp; SAVE_ENUMS *wrk = used_enums; SAVE_ENUM_VALUES *vals; SAVE_ENUM_NAMES *names; while (wrk != (SAVE_ENUMS *)0) { /* search for this enum already in use */ if (wrk->context == context && wrk->type == type) { /* yes, found. look if the ptrdecl is valid in this scope */ char *name = IDENTIFIER_POINTER (DECL_NAME (wrk->ptrdecl)); tree var = get_identifier (name); tree decl = lookup_name (var); if (decl == NULL_TREE) { /* no, not valid in this context, declare it */ decl = decl_temp1 (var, build_pointer_type (TREE_TYPE (enum_table_type)), 0, NULL_TREE, 1, 0); } return decl; } /* next one */ wrk = wrk->forward; } /* not yet found -- generate an entry */ wrk = (SAVE_ENUMS *)xmalloc (sizeof (SAVE_ENUMS)); wrk->forward = used_enums; used_enums = wrk; /* generate the pointer decl */ wrk->ptrdecl = get_unique_identifier ("ENUMTABPTR"); wrk->ptrdecl = decl_temp1 (wrk->ptrdecl, build_pointer_type (TREE_TYPE (enum_table_type)), 0, NULL_TREE, 1, 0); /* save information for later use */ wrk->context = context; wrk->type = type; /* insert the names and values */ tmp = TYPE_FIELDS (type); wrk->num_vals = list_length (tmp); vals = (SAVE_ENUM_VALUES *)xmalloc (sizeof (SAVE_ENUM_VALUES) * wrk->num_vals); wrk->vals = vals; while (tmp != NULL_TREE) { /* search if name is already in use */ names = used_enum_names; while (names != (SAVE_ENUM_NAMES *)0) { if (names->name == TREE_PURPOSE (tmp)) break; names = names->forward; } if (names == (SAVE_ENUM_NAMES *)0) { /* we have to insert one */ names = (SAVE_ENUM_NAMES *)xmalloc (sizeof (SAVE_ENUM_NAMES)); names->forward = used_enum_names; used_enum_names = names; names->decl = NULL_TREE; names->name = TREE_PURPOSE (tmp); } vals->name = names; vals->val = TREE_INT_CST_LOW (TREE_VALUE (tmp)); /* next entry in enum */ vals++; tmp = TREE_CHAIN (tmp); } /* return the generated decl */ return wrk->ptrdecl; } static void build_chill_io_list_type () { tree list = NULL_TREE; tree result, enum1, listbase; tree io_descriptor; tree decl1, decl2; tree forcharstring, forset_W, forset_R, forboolrange; tree forintrange, intunion, forsetrange, forcharrange; tree long_type, ulong_type, union_type; long_type = long_integer_type_node; ulong_type = long_unsigned_type_node; if (chill_io_list_type != NULL_TREE) /* already done */ return; /* first build the enum for the desriptor */ enum1 = start_enum (NULL_TREE); result = build_enumerator (get_identifier ("__IO_UNUSED"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_ByteVal"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_UByteVal"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_IntVal"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_UIntVal"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_LongVal"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_ULongVal"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_ByteLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_UByteLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_IntLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_UIntLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_LongLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_ULongLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_ByteRangeLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_UByteRangeLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_IntRangeLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_UIntRangeLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_LongRangeLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_ULongRangeLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_BoolVal"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_BoolLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_BoolRangeLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_SetVal"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_SetLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_SetRangeLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_CharVal"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_CharLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_CharRangeLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_CharStrLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_CharVaryingLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_BitStrLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_RealVal"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_RealLoc"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_LongRealVal"), NULL_TREE); list = chainon (result, list); result = build_enumerator (get_identifier ("__IO_LongRealLoc"), NULL_TREE); list = chainon (result, list); #if 0 result = build_enumerator (get_identifier ("_IO_Pointer"), NULL_TREE); list = chainon (result, list); #endif result = finish_enum (enum1, list); pushdecl (io_descriptor = build_decl (TYPE_DECL, get_identifier ("__tmp_IO_enum"), result)); /* prevent seizing/granting of the decl */ DECL_SOURCE_LINE (io_descriptor) = 0; satisfy_decl (io_descriptor, 0); /* build type for enum_tables */ decl1 = build_decl (FIELD_DECL, get_identifier ("value"), long_type); DECL_INITIAL (decl1) = NULL_TREE; decl2 = build_decl (FIELD_DECL, get_identifier ("name"), build_pointer_type (char_type_node)); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; TREE_CHAIN (decl2) = NULL_TREE; result = build_chill_struct_type (decl1); pushdecl (enum_table_type = build_decl (TYPE_DECL, get_identifier ("__tmp_IO_enum_table_type"), result)); DECL_SOURCE_LINE (enum_table_type) = 0; satisfy_decl (enum_table_type, 0); /* build type for writing a set mode */ decl1 = build_decl (FIELD_DECL, get_identifier ("value"), long_type); DECL_INITIAL (decl1) = NULL_TREE; listbase = decl1; decl2 = build_decl (FIELD_DECL, get_identifier ("name_table"), build_pointer_type (TREE_TYPE (enum_table_type))); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; TREE_CHAIN (decl2) = NULL_TREE; result = build_chill_struct_type (listbase); pushdecl (forset_W = build_decl (TYPE_DECL, get_identifier ("__tmp_WIO_set"), result)); DECL_SOURCE_LINE (forset_W) = 0; satisfy_decl (forset_W, 0); /* build type for charrange */ decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"), build_pointer_type (char_type_node)); DECL_INITIAL (decl1) = NULL_TREE; listbase = decl1; decl2 = build_decl (FIELD_DECL, get_identifier ("lower"), long_type); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("upper"), long_type); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; TREE_CHAIN (decl2) = NULL_TREE; result = build_chill_struct_type (listbase); pushdecl (forcharrange = build_decl (TYPE_DECL, get_identifier ("__tmp_IO_charrange"), result)); DECL_SOURCE_LINE (forcharrange) = 0; satisfy_decl (forcharrange, 0); /* type for integer range */ decl1 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("_slong"), long_type)); listbase = decl1; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("_ulong"), ulong_type)); TREE_CHAIN (decl1) = decl2; TREE_CHAIN (decl2) = NULL_TREE; decl1 = grok_chill_variantdefs (NULL_TREE, listbase, NULL_TREE); TREE_CHAIN (decl1) = NULL_TREE; result = build_chill_struct_type (decl1); pushdecl (intunion = build_decl (TYPE_DECL, get_identifier ("__tmp_IO_long"), result)); DECL_SOURCE_LINE (intunion) = 0; satisfy_decl (intunion, 0); decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"), ptr_type_node); listbase = decl1; decl2 = build_decl (FIELD_DECL, get_identifier ("lower"), TREE_TYPE (intunion)); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("upper"), TREE_TYPE (intunion)); TREE_CHAIN (decl1) = decl2; TREE_CHAIN (decl2) = NULL_TREE; result = build_chill_struct_type (listbase); pushdecl (forintrange = build_decl (TYPE_DECL, get_identifier ("__tmp_IO_intrange"), result)); DECL_SOURCE_LINE (forintrange) = 0; satisfy_decl (forintrange, 0); /* build structure for bool range */ decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"), ptr_type_node); DECL_INITIAL (decl1) = NULL_TREE; listbase = decl1; decl2 = build_decl (FIELD_DECL, get_identifier ("lower"), ulong_type); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("upper"), ulong_type); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; TREE_CHAIN (decl2) = NULL_TREE; result = build_chill_struct_type (listbase); pushdecl (forboolrange = build_decl (TYPE_DECL, get_identifier ("__tmp_RIO_boolrange"), result)); DECL_SOURCE_LINE (forboolrange) = 0; satisfy_decl (forboolrange, 0); /* build type for reading a set */ decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"), ptr_type_node); DECL_INITIAL (decl1) = NULL_TREE; listbase = decl1; decl2 = build_decl (FIELD_DECL, get_identifier ("length"), long_type); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("name_table"), build_pointer_type (TREE_TYPE (enum_table_type))); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; TREE_CHAIN (decl2) = NULL_TREE; result = build_chill_struct_type (listbase); pushdecl (forset_R = build_decl (TYPE_DECL, get_identifier ("__tmp_RIO_set"), result)); DECL_SOURCE_LINE (forset_R) = 0; satisfy_decl (forset_R, 0); /* build type for setrange */ decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"), ptr_type_node); DECL_INITIAL (decl1) = NULL_TREE; listbase = decl1; decl2 = build_decl (FIELD_DECL, get_identifier ("length"), long_type); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("name_table"), build_pointer_type (TREE_TYPE (enum_table_type))); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("lower"), long_type); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("upper"), long_type); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; TREE_CHAIN (decl2) = NULL_TREE; result = build_chill_struct_type (listbase); pushdecl (forsetrange = build_decl (TYPE_DECL, get_identifier ("__tmp_RIO_setrange"), result)); DECL_SOURCE_LINE (forsetrange) = 0; satisfy_decl (forsetrange, 0); /* build structure for character string */ decl1 = build_decl (FIELD_DECL, get_identifier ("string"), build_pointer_type (char_type_node)); DECL_INITIAL (decl1) = NULL_TREE; listbase = decl1; decl2 = build_decl (FIELD_DECL, get_identifier ("string_length"), ulong_type); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; TREE_CHAIN (decl2) = NULL_TREE; result = build_chill_struct_type (listbase); pushdecl (forcharstring = build_decl (TYPE_DECL, get_identifier ("__tmp_IO_forcharstring"), result)); DECL_SOURCE_LINE (forcharstring) = 0; satisfy_decl (forcharstring, 0); /* build the union */ decl1 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__valbyte"), signed_char_type_node)); listbase = decl1; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__valubyte"), unsigned_char_type_node)); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__valint"), chill_integer_type_node)); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__valuint"), chill_unsigned_type_node)); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__vallong"), long_type)); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__valulong"), ulong_type)); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__locint"), ptr_type_node)); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__locintrange"), TREE_TYPE (forintrange))); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__valbool"), boolean_type_node)); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__locbool"), build_pointer_type (boolean_type_node))); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__locboolrange"), TREE_TYPE (forboolrange))); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__valset"), TREE_TYPE (forset_W))); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__locset"), TREE_TYPE (forset_R))); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__locsetrange"), TREE_TYPE (forsetrange))); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__valchar"), char_type_node)); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__locchar"), build_pointer_type (char_type_node))); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__loccharrange"), TREE_TYPE (forcharrange))); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__loccharstring"), TREE_TYPE (forcharstring))); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__valreal"), float_type_node)); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__locreal"), build_pointer_type (float_type_node))); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__vallongreal"), double_type_node)); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__loclongreal"), build_pointer_type (double_type_node))); TREE_CHAIN (decl1) = decl2; decl1 = decl2; #if 0 decl2 = build_tree_list (NULL_TREE, build_decl (FIELD_DECL, get_identifier ("__forpointer"), ptr_type_node)); TREE_CHAIN (decl1) = decl2; decl1 = decl2; #endif TREE_CHAIN (decl2) = NULL_TREE; decl1 = grok_chill_variantdefs (NULL_TREE, listbase, NULL_TREE); TREE_CHAIN (decl1) = NULL_TREE; result = build_chill_struct_type (decl1); pushdecl (union_type = build_decl (TYPE_DECL, get_identifier ("__tmp_WIO_union"), result)); DECL_SOURCE_LINE (union_type) = 0; satisfy_decl (union_type, 0); /* now build the final structure */ decl1 = build_decl (FIELD_DECL, get_identifier ("__t"), TREE_TYPE (union_type)); DECL_INITIAL (decl1) = NULL_TREE; listbase = decl1; decl2 = build_decl (FIELD_DECL, get_identifier ("__descr"), long_type); TREE_CHAIN (decl1) = decl2; TREE_CHAIN (decl2) = NULL_TREE; result = build_chill_struct_type (listbase); pushdecl (chill_io_list_type = build_decl (TYPE_DECL, get_identifier ("__tmp_IO_list"), result)); DECL_SOURCE_LINE (chill_io_list_type) = 0; satisfy_decl (chill_io_list_type, 0); } /* build the ASSOCIATION, ACCESS and TEXT mode types */ static void build_io_types () { tree listbase, decl1, decl2, result, association; tree acc, txt, tloc; tree enum1, tmp; /* the association mode */ listbase = build_decl (FIELD_DECL, get_identifier ("flags"), long_unsigned_type_node); DECL_INITIAL (listbase) = NULL_TREE; decl1 = listbase; decl2 = build_decl (FIELD_DECL, get_identifier ("pathname"), ptr_type_node); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("access"), ptr_type_node); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("handle"), integer_type_node); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("bufptr"), ptr_type_node); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("syserrno"), long_integer_type_node); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("usage"), char_type_node); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("ctl_pre"), char_type_node); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("ctl_post"), char_type_node); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; TREE_CHAIN (decl2) = NULL_TREE; result = build_chill_struct_type (listbase); pushdecl (association = build_decl (TYPE_DECL, ridpointers[(int)RID_ASSOCIATION], result)); DECL_SOURCE_LINE (association) = 0; satisfy_decl (association, 0); association_type_node = TREE_TYPE (association); TYPE_NAME (association_type_node) = association; CH_NOVELTY (association_type_node) = association; CH_TYPE_NONVALUE_P(association_type_node) = 1; CH_TYPE_NONVALUE_P(association) = 1; /* initialiser for association type */ tmp = convert (char_type_node, integer_zero_node); association_init_value = build_nt (CONSTRUCTOR, NULL_TREE, tree_cons (NULL_TREE, integer_zero_node, /* flags */ tree_cons (NULL_TREE, null_pointer_node, /* pathname */ tree_cons (NULL_TREE, null_pointer_node, /* access */ tree_cons (NULL_TREE, integer_minus_one_node, /* handle */ tree_cons (NULL_TREE, null_pointer_node, /* bufptr */ tree_cons (NULL_TREE, integer_zero_node, /* syserrno */ tree_cons (NULL_TREE, tmp, /* usage */ tree_cons (NULL_TREE, tmp, /* ctl_pre */ tree_cons (NULL_TREE, tmp, /* ctl_post */ NULL_TREE)))))))))); /* the type for stdin, stdout, stderr */ /* text part */ decl1 = build_decl (FIELD_DECL, get_identifier ("flags"), long_unsigned_type_node); DECL_INITIAL (decl1) = NULL_TREE; listbase = decl1; decl2 = build_decl (FIELD_DECL, get_identifier ("text_record"), ptr_type_node); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("access_sub"), ptr_type_node); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("actual_index"), long_unsigned_type_node); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; TREE_CHAIN (decl2) = NULL_TREE; txt = build_chill_struct_type (listbase); /* access part */ decl1 = build_decl (FIELD_DECL, get_identifier ("flags"), long_unsigned_type_node); DECL_INITIAL (decl1) = NULL_TREE; listbase = decl1; decl2 = build_decl (FIELD_DECL, get_identifier ("reclength"), long_unsigned_type_node); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("lowindex"), long_integer_type_node); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("highindex"), long_integer_type_node); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl2 = decl1; decl2 = build_decl (FIELD_DECL, get_identifier ("association"), ptr_type_node); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("base"), long_unsigned_type_node); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("storelocptr"), ptr_type_node); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("rectype"), long_integer_type_node); DECL_INITIAL (decl2) = NULL_TREE; TREE_CHAIN (decl1) = decl2; TREE_CHAIN (decl2) = NULL_TREE; acc = build_chill_struct_type (listbase); /* the location */ tmp = build_string_type (char_type_node, build_int_2 (STDIO_TEXT_LENGTH, 0)); tloc = build_varying_struct (tmp); /* now the final mode */ decl1 = build_decl (FIELD_DECL, get_identifier ("txt"), txt); listbase = decl1; decl2 = build_decl (FIELD_DECL, get_identifier ("acc"), acc); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (FIELD_DECL, get_identifier ("tloc"), tloc); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"), void_type_node); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (CONST_DECL, get_identifier ("__textlength"), integer_type_node); DECL_INITIAL (decl2) = build_int_2 (STDIO_TEXT_LENGTH, 0); TREE_CHAIN (decl1) = decl2; decl1 = decl2; decl2 = build_decl (CONST_DECL, get_identifier ("__dynamic"), integer_type_node); DECL_INITIAL (decl2) = integer_zero_node; TREE_CHAIN (decl1) = decl2; TREE_CHAIN (decl2) = NULL_TREE; result = build_chill_struct_type (listbase); pushdecl (tmp = build_decl (TYPE_DECL, get_identifier ("__stdio_text"), result)); DECL_SOURCE_LINE (tmp) = 0; satisfy_decl (tmp, 0); stdio_type_node = TREE_TYPE (tmp); CH_IS_TEXT_MODE (stdio_type_node) = 1; /* predefined usage mode */ enum1 = start_enum (NULL_TREE); listbase = NULL_TREE; result = build_enumerator ( get_identifier ((ignore_case || ! special_UC) ? "readonly" : "READONLY"), NULL_TREE); listbase = chainon (result, listbase); result = build_enumerator ( get_identifier ((ignore_case || ! special_UC) ? "writeonly" : "WRITEONLY"), NULL_TREE); listbase = chainon (result, listbase); result = build_enumerator ( get_identifier ((ignore_case || ! special_UC) ? "readwrite" : "READWRITE"), NULL_TREE); listbase = chainon (result, listbase); result = finish_enum (enum1, listbase); pushdecl (tmp = build_decl (TYPE_DECL, get_identifier ((ignore_case || ! special_UC) ? "usage" : "USAGE"), result)); DECL_SOURCE_LINE (tmp) = 0; satisfy_decl (tmp, 0); usage_type_node = TREE_TYPE (tmp); TYPE_NAME (usage_type_node) = tmp; CH_NOVELTY (usage_type_node) = tmp; /* predefined where mode */ enum1 = start_enum (NULL_TREE); listbase = NULL_TREE; result = build_enumerator ( get_identifier ((ignore_case || ! special_UC) ? "first" : "FIRST"), NULL_TREE); listbase = chainon (result, listbase); result = build_enumerator ( get_identifier ((ignore_case || ! special_UC) ? "same" : "SAME"), NULL_TREE); listbase = chainon (result, listbase); result = build_enumerator ( get_identifier ((ignore_case || ! special_UC) ? "last" : "LAST"), NULL_TREE); listbase = chainon (result, listbase); result = finish_enum (enum1, listbase); pushdecl (tmp = build_decl (TYPE_DECL, get_identifier ((ignore_case || ! special_UC) ? "where" : "WHERE"), result)); DECL_SOURCE_LINE (tmp) = 0; satisfy_decl (tmp, 0); where_type_node = TREE_TYPE (tmp); TYPE_NAME (where_type_node) = tmp; CH_NOVELTY (where_type_node) = tmp; } static void declare_predefined_file (name, assembler_name) char *name; char* assembler_name; { tree decl = build_lang_decl (VAR_DECL, get_identifier (name), stdio_type_node); DECL_ASSEMBLER_NAME (decl) = get_identifier(assembler_name); TREE_STATIC (decl) = 1; TREE_PUBLIC (decl) = 1; DECL_EXTERNAL (decl) = 1; DECL_IN_SYSTEM_HEADER (decl) = 1; make_decl_rtl (decl, 0, 1); pushdecl (decl); } /* initialisation of all IO/related functions, types, etc. */ void inout_init () { /* We temporarily reset the maximum_field_alignment to zero so the compiler's init data structures can be compatible with the run-time system, even when we're compiling with -fpack. */ extern int maximum_field_alignment; int save_maximum_field_alignment = maximum_field_alignment; extern tree chill_predefined_function_type; tree endlink = void_list_node; tree bool_ftype_ptr_ptr_int; tree ptr_ftype_ptr_ptr_int; tree luns_ftype_ptr_ptr_int; tree int_ftype_ptr_ptr_int; tree ptr_ftype_ptr_ptr_int_ptr_int_ptr_int; tree void_ftype_ptr_ptr_int_ptr_int_ptr_int; tree void_ftype_ptr_ptr_int; tree void_ftype_ptr_ptr_int_int_int_long_ptr_int; tree ptr_ftype_ptr_int_ptr_ptr_int; tree void_ftype_ptr_int_ptr_luns_ptr_int; tree void_ftype_ptr_ptr_ptr_int; tree void_ftype_ptr_int_ptr_int; tree void_ftype_ptr_int_ptr_int_ptr_int_ptr_int; maximum_field_alignment = 0; builtin_function ((ignore_case || ! special_UC) ? "associate" : "ASSOCIATE", chill_predefined_function_type, BUILT_IN_ASSOCIATE, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "connect" : "CONNECT", chill_predefined_function_type, BUILT_IN_CONNECT, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "create" : "CREATE", chill_predefined_function_type, BUILT_IN_CREATE, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "delete" : "DELETE", chill_predefined_function_type, BUILT_IN_CH_DELETE, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "disconnect" : "DISCONNECT", chill_predefined_function_type, BUILT_IN_DISCONNECT, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "dissociate" : "DISSOCIATE", chill_predefined_function_type, BUILT_IN_DISSOCIATE, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "eoln" : "EOLN", chill_predefined_function_type, BUILT_IN_EOLN, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "existing" : "EXISTING", chill_predefined_function_type, BUILT_IN_EXISTING, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "getassociation" : "GETASSOCIATION", chill_predefined_function_type, BUILT_IN_GETASSOCIATION, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "gettextaccess" : "GETTEXTASSCESS", chill_predefined_function_type, BUILT_IN_GETTEXTACCESS, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "gettextindex" : "GETTEXTINDEX", chill_predefined_function_type, BUILT_IN_GETTEXTINDEX, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "gettextrecord" : "GETTEXTRECORD", chill_predefined_function_type, BUILT_IN_GETTEXTRECORD, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "getusage" : "GETUSAGE", chill_predefined_function_type, BUILT_IN_GETUSAGE, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "indexable" : "INDEXABLE", chill_predefined_function_type, BUILT_IN_INDEXABLE, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "isassociated" : "ISASSOCIATED", chill_predefined_function_type, BUILT_IN_ISASSOCIATED, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "modify" : "MODIFY", chill_predefined_function_type, BUILT_IN_MODIFY, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "outoffile" : "OUTOFFILE", chill_predefined_function_type, BUILT_IN_OUTOFFILE, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "readable" : "READABLE", chill_predefined_function_type, BUILT_IN_READABLE, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "readrecord" : "READRECORD", chill_predefined_function_type, BUILT_IN_READRECORD, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "readtext" : "READTEXT", chill_predefined_function_type, BUILT_IN_READTEXT, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "sequencible" : "SEQUENCIBLE", chill_predefined_function_type, BUILT_IN_SEQUENCIBLE, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "settextaccess" : "SETTEXTACCESS", chill_predefined_function_type, BUILT_IN_SETTEXTACCESS, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "settextindex" : "SETTEXTINDEX", chill_predefined_function_type, BUILT_IN_SETTEXTINDEX, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "settextrecord" : "SETTEXTRECORD", chill_predefined_function_type, BUILT_IN_SETTEXTRECORD, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "variable" : "VARIABLE", chill_predefined_function_type, BUILT_IN_VARIABLE, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "writeable" : "WRITEABLE", chill_predefined_function_type, BUILT_IN_WRITEABLE, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "writerecord" : "WRITERECORD", chill_predefined_function_type, BUILT_IN_WRITERECORD, NULL_PTR); builtin_function ((ignore_case || ! special_UC) ? "writetext" : "WRITETEXT", chill_predefined_function_type, BUILT_IN_WRITETEXT, NULL_PTR); /* build function prototypes */ bool_ftype_ptr_ptr_int = build_function_type (boolean_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, endlink)))); ptr_ftype_ptr_ptr_int_ptr_int_ptr_int = build_function_type (ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, endlink)))))))); void_ftype_ptr_ptr_int = build_function_type (void_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, endlink)))); void_ftype_ptr_ptr_int_ptr_int_ptr_int = build_function_type (void_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, endlink)))))))); void_ftype_ptr_ptr_int_int_int_long_ptr_int = build_function_type (void_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, tree_cons (NULL_TREE, integer_type_node, tree_cons (NULL_TREE, integer_type_node, tree_cons (NULL_TREE, long_integer_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, endlink))))))))); ptr_ftype_ptr_ptr_int = build_function_type (ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, endlink)))); int_ftype_ptr_ptr_int = build_function_type (integer_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, endlink)))); ptr_ftype_ptr_int_ptr_ptr_int = build_function_type (ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, endlink)))))); void_ftype_ptr_int_ptr_luns_ptr_int = build_function_type (void_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, long_unsigned_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, endlink))))))); luns_ftype_ptr_ptr_int = build_function_type (long_unsigned_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, endlink)))); void_ftype_ptr_ptr_ptr_int = build_function_type (void_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, endlink))))); void_ftype_ptr_int_ptr_int = build_function_type (void_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, endlink))))); void_ftype_ptr_int_ptr_int_ptr_int_ptr_int = build_function_type (void_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, tree_cons (NULL_TREE, ptr_type_node, tree_cons (NULL_TREE, integer_type_node, endlink))))))))); builtin_function ("__associate", ptr_ftype_ptr_ptr_int_ptr_int_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__connect", void_ftype_ptr_ptr_int_int_int_long_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__create", void_ftype_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__delete", void_ftype_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__disconnect", void_ftype_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__dissociate", void_ftype_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__eoln", bool_ftype_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__existing", bool_ftype_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__getassociation", ptr_ftype_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__gettextaccess", ptr_ftype_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__gettextindex", luns_ftype_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__gettextrecord", ptr_ftype_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__getusage", int_ftype_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__indexable", bool_ftype_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__isassociated", bool_ftype_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__modify", void_ftype_ptr_ptr_int_ptr_int_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__outoffile", bool_ftype_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__readable", bool_ftype_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__readrecord", ptr_ftype_ptr_int_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__readtext_f", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__readtext_s", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__sequencible", bool_ftype_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__settextaccess", void_ftype_ptr_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__settextindex", void_ftype_ptr_int_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__settextrecord", void_ftype_ptr_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__variable", bool_ftype_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__writeable", bool_ftype_ptr_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__writerecord", void_ftype_ptr_int_ptr_luns_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__writetext_f", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int, NOT_BUILT_IN, NULL_PTR); builtin_function ("__writetext_s", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int, NOT_BUILT_IN, NULL_PTR); /* declare ASSOCIATION, ACCESS, and TEXT modes */ build_io_types (); /* declare the predefined text locations */ declare_predefined_file ((ignore_case || ! special_UC) ? "stdin" : "STDIN", "chill_stdin"); declare_predefined_file ((ignore_case || ! special_UC) ? "stdout" : "STDOUT", "chill_stdout"); declare_predefined_file ((ignore_case || ! special_UC) ? "stderr" : "STDERR", "chill_stderr"); /* last, but not least, build the chill IO-list type */ build_chill_io_list_type (); maximum_field_alignment = save_maximum_field_alignment; } /* function returns the recordmode of an ACCESS */ tree access_recordmode (access) tree access; { tree field; if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK) return NULL_TREE; if (! CH_IS_ACCESS_MODE (access)) return NULL_TREE; field = TYPE_FIELDS (access); for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) { if (TREE_CODE (field) == TYPE_DECL && DECL_NAME (field) == get_identifier ("__recordmode")) return TREE_TYPE (field); } return void_type_node; } /* function invalidates the recordmode of an ACCESS */ void invalidate_access_recordmode (access) tree access; { tree field; if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK) return; if (! CH_IS_ACCESS_MODE (access)) return; field = TYPE_FIELDS (access); for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) { if (TREE_CODE (field) == TYPE_DECL && DECL_NAME (field) == get_identifier ("__recordmode")) { TREE_TYPE (field) = error_mark_node; return; } } } /* function returns the index mode of an ACCESS if there is one, otherwise NULL_TREE */ tree access_indexmode (access) tree access; { tree field; if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK) return NULL_TREE; if (! CH_IS_ACCESS_MODE (access)) return NULL_TREE; field = TYPE_FIELDS (access); for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) { if (TREE_CODE (field) == TYPE_DECL && DECL_NAME (field) == get_identifier ("__indexmode")) return TREE_TYPE (field); } return void_type_node; } /* function returns one if an ACCESS was specified DYNAMIC, otherwise zero */ tree access_dynamic (access) tree access; { tree field; if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK) return NULL_TREE; if (! CH_IS_ACCESS_MODE (access)) return NULL_TREE; field = TYPE_FIELDS (access); for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) { if (TREE_CODE (field) == CONST_DECL) return DECL_INITIAL (field); } return integer_zero_node; } #if 0 returns a structure like STRUCT (data STRUCT (flags ULONG, reclength ULONG, lowindex LONG, highindex LONG, association PTR, base ULONG, store_loc PTR, rectype LONG), this is followed by a TYPE_DECL __recordmode recordmode ? recordmode : void_type_node TYPE_DECL __indexmode indexmode ? indexmode : void_type_node CONST_DECL __dynamic dynamic ? integer_one_node : integer_zero_node #endif static tree build_access_part () { tree listbase, decl; listbase = build_decl (FIELD_DECL, get_identifier ("flags"), long_unsigned_type_node); decl = build_decl (FIELD_DECL, get_identifier ("reclength"), long_unsigned_type_node); listbase = chainon (listbase, decl); decl = build_decl (FIELD_DECL, get_identifier ("lowindex"), long_unsigned_type_node); listbase = chainon (listbase, decl); decl = build_decl (FIELD_DECL, get_identifier ("highindex"), long_integer_type_node); listbase = chainon (listbase, decl); decl = build_decl (FIELD_DECL, get_identifier ("association"), ptr_type_node); listbase = chainon (listbase, decl); decl = build_decl (FIELD_DECL, get_identifier ("base"), long_unsigned_type_node); listbase = chainon (listbase, decl); decl = build_decl (FIELD_DECL, get_identifier ("storelocptr"), ptr_type_node); listbase = chainon (listbase, decl); decl = build_decl (FIELD_DECL, get_identifier ("rectype"), long_integer_type_node); listbase = chainon (listbase, decl); return build_chill_struct_type (listbase); } tree build_access_mode (indexmode, recordmode, dynamic) tree indexmode; tree recordmode; int dynamic; { tree type, listbase, decl, datamode; if (indexmode != NULL_TREE && TREE_CODE (indexmode) == ERROR_MARK) return error_mark_node; if (recordmode != NULL_TREE && TREE_CODE (recordmode) == ERROR_MARK) return error_mark_node; datamode = build_access_part (); type = make_node (RECORD_TYPE); listbase = build_decl (FIELD_DECL, get_identifier ("data"), datamode); TYPE_FIELDS (type) = listbase; decl = build_lang_decl (TYPE_DECL, get_identifier ("__recordmode"), recordmode == NULL_TREE ? void_type_node : recordmode); chainon (listbase, decl); decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"), indexmode == NULL_TREE ? void_type_node : indexmode); chainon (listbase, decl); decl = build_decl (CONST_DECL, get_identifier ("__dynamic"), integer_type_node); DECL_INITIAL (decl) = dynamic ? integer_one_node : integer_zero_node; chainon (listbase, decl); CH_IS_ACCESS_MODE (type) = 1; CH_TYPE_NONVALUE_P (type) = 1; return type; } #if 0 returns a structure like: STRUCT (txt STRUCT (flags ULONG, text_record PTR, access_sub PTR, actual_index LONG), acc STRUCT (flags ULONG, reclength ULONG, lowindex LONG, highindex LONG, association PTR, base ULONG, store_loc PTR, rectype LONG), tloc CHARS(textlength) VARYING; ) followed by TYPE_DECL __indexmode indexmode ? indexmode : void_type_node CONST_DECL __text_length CONST_DECL __dynamic dynamic ? integer_one_node : integer_zero_node #endif tree build_text_mode (textlength, indexmode, dynamic) tree textlength; tree indexmode; int dynamic; { tree txt, acc, listbase, decl, type, tltype; tree savedlength = textlength; if (indexmode != NULL_TREE && TREE_CODE (indexmode) == ERROR_MARK) return error_mark_node; if (textlength == NULL_TREE || TREE_CODE (textlength) == ERROR_MARK) return error_mark_node; /* build the structure */ listbase = build_decl (FIELD_DECL, get_identifier ("flags"), long_unsigned_type_node); decl = build_decl (FIELD_DECL, get_identifier ("text_record"), ptr_type_node); listbase = chainon (listbase, decl); decl = build_decl (FIELD_DECL, get_identifier ("access_sub"), ptr_type_node); listbase = chainon (listbase, decl); decl = build_decl (FIELD_DECL, get_identifier ("actual_index"), long_integer_type_node); listbase = chainon (listbase, decl); txt = build_chill_struct_type (listbase); acc = build_access_part (); type = make_node (RECORD_TYPE); listbase = build_decl (FIELD_DECL, get_identifier ("txt"), txt); TYPE_FIELDS (type) = listbase; decl = build_decl (FIELD_DECL, get_identifier ("acc"), acc); chainon (listbase, decl); /* the text location */ tltype = build_string_type (char_type_node, textlength); tltype = build_varying_struct (tltype); decl = build_decl (FIELD_DECL, get_identifier ("tloc"), tltype); chainon (listbase, decl); /* the index mode */ decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"), indexmode == NULL_TREE ? void_type_node : indexmode); chainon (listbase, decl); /* save dynamic */ decl = build_decl (CONST_DECL, get_identifier ("__textlength"), integer_type_node); if (TREE_CODE (textlength) == COMPONENT_REF) /* FIXME: we cannot use one and the same COMPONENT_REF twice, so build another one */ savedlength = build_component_ref (TREE_OPERAND (textlength, 0), TREE_OPERAND (textlength, 1)); DECL_INITIAL (decl) = savedlength; chainon (listbase, decl); /* save dynamic */ decl = build_decl (CONST_DECL, get_identifier ("__dynamic"), integer_type_node); DECL_INITIAL (decl) = dynamic ? integer_one_node : integer_zero_node; chainon (listbase, decl); CH_IS_TEXT_MODE (type) = 1; CH_TYPE_NONVALUE_P (type) = 1; return type; } tree check_text_length (length) tree length; { if (length == NULL_TREE || TREE_CODE (length) == ERROR_MARK) return length; if (TREE_TYPE (length) == NULL_TREE || !CH_SIMILAR (TREE_TYPE (length), integer_type_node)) { error ("non-integral text length"); return integer_one_node; } if (TREE_CODE (length) != INTEGER_CST) { error ("non-constant text length"); return integer_one_node; } if (compare_int_csts (LE_EXPR, length, integer_zero_node)) { error ("text length must be greater then 0"); return integer_one_node; } return length; } tree text_indexmode (text) tree text; { tree field; if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK) return NULL_TREE; if (! CH_IS_TEXT_MODE (text)) return NULL_TREE; field = TYPE_FIELDS (text); for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) { if (TREE_CODE (field) == TYPE_DECL) return TREE_TYPE (field); } return void_type_node; } tree text_dynamic (text) tree text; { tree field; if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK) return NULL_TREE; if (! CH_IS_TEXT_MODE (text)) return NULL_TREE; field = TYPE_FIELDS (text); for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) { if (TREE_CODE (field) == CONST_DECL && DECL_NAME (field) == get_identifier ("__dynamic")) return DECL_INITIAL (field); } return integer_zero_node; } tree text_length (text) tree text; { tree field; if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK) return NULL_TREE; if (! CH_IS_TEXT_MODE (text)) return NULL_TREE; field = TYPE_FIELDS (text); for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) { if (TREE_CODE (field) == CONST_DECL && DECL_NAME (field) == get_identifier ("__textlength")) return DECL_INITIAL (field); } return integer_zero_node; } static tree textlocation_mode (text) tree text; { tree field; if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK) return NULL_TREE; if (! CH_IS_TEXT_MODE (text)) return NULL_TREE; field = TYPE_FIELDS (text); for ( ; field != NULL_TREE; field = TREE_CHAIN (field)) { if (TREE_CODE (field) == FIELD_DECL && DECL_NAME (field) == get_identifier ("tloc")) return TREE_TYPE (field); } return NULL_TREE; } static int check_assoc (assoc, argnum, errmsg) tree assoc; int argnum; char *errmsg; { if (assoc == NULL_TREE || TREE_CODE (assoc) == ERROR_MARK) return 0; if (! CH_IS_ASSOCIATION_MODE (TREE_TYPE (assoc))) { error ("argument %d of %s must be of mode ASSOCIATION", argnum, errmsg); return 0; } if (! CH_LOCATION_P (assoc)) { error ("argument %d of %s must be a location", argnum, errmsg); return 0; } return 1; } tree build_chill_associate (assoc, fname, attr) tree assoc; tree fname; tree attr; { tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE, arg4 = NULL_TREE, arg5 = NULL_TREE, arg6, arg7; int had_errors = 0; tree result; /* make some checks */ if (fname == NULL_TREE || TREE_CODE (fname) == ERROR_MARK) return error_mark_node; /* check the association */ if (! check_assoc (assoc, 1, "ASSOCIATION")) had_errors = 1; else /* build a pointer to the association */ arg1 = force_addr_of (assoc); /* check the filename, must be a string */ if (CH_CHARS_TYPE_P (TREE_TYPE (fname)) || (flag_old_strings && TREE_CODE (fname) == INTEGER_CST && TREE_CODE (TREE_TYPE (fname)) == CHAR_TYPE)) { if (int_size_in_bytes (TREE_TYPE (fname)) == 0) { error ("argument 2 of ASSOCIATE must not be an empty string"); had_errors = 1; } else { arg2 = force_addr_of (fname); arg3 = size_in_bytes (TREE_TYPE (fname)); } } else if (chill_varying_string_type_p (TREE_TYPE (fname))) { arg2 = force_addr_of (build_component_ref (fname, var_data_id)); arg3 = build_component_ref (fname, var_length_id); } else { error ("argument 2 to ASSOCIATE must be a string"); had_errors = 1; } /* check attr argument, must be a string too */ if (attr == NULL_TREE) { arg4 = null_pointer_node; arg5 = integer_zero_node; } else { attr = TREE_VALUE (attr); if (attr == NULL_TREE || TREE_CODE (attr) == ERROR_MARK) had_errors = 1; else { if (CH_CHARS_TYPE_P (TREE_TYPE (attr)) || (flag_old_strings && TREE_CODE (attr) == INTEGER_CST && TREE_CODE (TREE_TYPE (attr)) == CHAR_TYPE)) { if (int_size_in_bytes (TREE_TYPE (attr)) == 0) { arg4 = null_pointer_node; arg5 = integer_zero_node; } else { arg4 = force_addr_of (attr); arg5 = size_in_bytes (TREE_TYPE (attr)); } } else if (chill_varying_string_type_p (TREE_TYPE (attr))) { arg4 = force_addr_of (build_component_ref (attr, var_data_id)); arg5 = build_component_ref (attr, var_length_id); } else { error ("argument 3 to ASSOCIATE must be a string"); had_errors = 1; } } } if (had_errors) return error_mark_node; /* other arguments */ arg6 = force_addr_of (get_chill_filename ()); arg7 = get_chill_linenumber (); result = build_chill_function_call ( lookup_name (get_identifier ("__associate")), tree_cons (NULL_TREE, arg1, tree_cons (NULL_TREE, arg2, tree_cons (NULL_TREE, arg3, tree_cons (NULL_TREE, arg4, tree_cons (NULL_TREE, arg5, tree_cons (NULL_TREE, arg6, tree_cons (NULL_TREE, arg7, NULL_TREE)))))))); TREE_TYPE (result) = build_chill_pointer_type (TREE_TYPE (assoc)); return result; } static tree assoc_call (assoc, func, name) tree assoc; tree func; char *name; { tree arg1, arg2, arg3; tree result; if (! check_assoc (assoc, 1, name)) return error_mark_node; arg1 = force_addr_of (assoc); arg2 = force_addr_of (get_chill_filename ()); arg3 = get_chill_linenumber (); result = build_chill_function_call (func, tree_cons (NULL_TREE, arg1, tree_cons (NULL_TREE, arg2, tree_cons (NULL_TREE, arg3, NULL_TREE)))); return result; } tree build_chill_isassociated (assoc) tree assoc; { tree result = assoc_call (assoc, lookup_name (get_identifier ("__isassociated")), "ISASSOCIATED"); return result; } tree build_chill_existing (assoc) tree assoc; { tree result = assoc_call (assoc, lookup_name (get_identifier ("__existing")), "EXISTING"); return result; } tree build_chill_readable (assoc) tree assoc; { tree result = assoc_call (assoc, lookup_name (get_identifier ("__readable")), "READABLE"); return result; } tree build_chill_writeable (assoc) tree assoc; { tree result = assoc_call (assoc, lookup_name (get_identifier ("__writeable")), "WRITEABLE"); return result; } tree build_chill_sequencible (assoc) tree assoc; { tree result = assoc_call (assoc, lookup_name (get_identifier ("__sequencible")), "SEQUENCIBLE"); return result; } tree build_chill_variable (assoc) tree assoc; { tree result = assoc_call (assoc, lookup_name (get_identifier ("__variable")), "VARIABLE"); return result; } tree build_chill_indexable (assoc) tree assoc; { tree result = assoc_call (assoc, lookup_name (get_identifier ("__indexable")), "INDEXABLE"); return result; } tree build_chill_dissociate (assoc) tree assoc; { tree result = assoc_call (assoc, lookup_name (get_identifier ("__dissociate")), "DISSOCIATE"); return result; } tree build_chill_create (assoc) tree assoc; { tree result = assoc_call (assoc, lookup_name (get_identifier ("__create")), "CREATE"); return result; } tree build_chill_delete (assoc) tree assoc; { tree result = assoc_call (assoc, lookup_name (get_identifier ("__delete")), "DELETE"); return result; } tree build_chill_modify (assoc, list) tree assoc; tree list; { tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE, arg4 = NULL_TREE, arg5 = NULL_TREE, arg6, arg7; int had_errors = 0, numargs; tree fname = NULL_TREE, attr = NULL_TREE; tree result; /* check the association */ if (! check_assoc (assoc, 1, "MODIFY")) had_errors = 1; else arg1 = force_addr_of (assoc); /* look how much arguments we have got */ numargs = list_length (list); switch (numargs) { case 0: break; case 1: fname = TREE_VALUE (list); break; case 2: fname = TREE_VALUE (list); attr = TREE_VALUE (TREE_CHAIN (list)); break; default: error ("Too many arguments in call to MODIFY"); had_errors = 1; break; } if (fname != NULL_TREE && fname != null_pointer_node) { if (CH_CHARS_TYPE_P (TREE_TYPE (fname)) || (flag_old_strings && TREE_CODE (fname) == INTEGER_CST && TREE_CODE (TREE_TYPE (fname)) == CHAR_TYPE)) { if (int_size_in_bytes (TREE_TYPE (fname)) == 0) { error ("argument 2 of MODIFY must not be an empty string"); had_errors = 1; } else { arg2 = force_addr_of (fname); arg3 = size_in_bytes (TREE_TYPE (fname)); } } else if (chill_varying_string_type_p (TREE_TYPE (fname))) { arg2 = force_addr_of (build_component_ref (fname, var_data_id)); arg3 = build_component_ref (fname, var_length_id); } else { error ("argument 2 to MODIFY must be a string"); had_errors = 1; } } else { arg2 = null_pointer_node; arg3 = integer_zero_node; } if (attr != NULL_TREE && attr != null_pointer_node) { if (CH_CHARS_TYPE_P (TREE_TYPE (attr)) || (flag_old_strings && TREE_CODE (attr) == INTEGER_CST && TREE_CODE (TREE_TYPE (attr)) == CHAR_TYPE)) { if (int_size_in_bytes (TREE_TYPE (attr)) == 0) { arg4 = null_pointer_node; arg5 = integer_zero_node; } else { arg4 = force_addr_of (attr); arg5 = size_in_bytes (TREE_TYPE (attr)); } } else if (chill_varying_string_type_p (TREE_TYPE (attr))) { arg4 = force_addr_of (build_component_ref (attr, var_data_id)); arg5 = build_component_ref (attr, var_length_id); } else { error ("argument 3 to MODIFY must be a string"); had_errors = 1; } } else { arg4 = null_pointer_node; arg5 = integer_zero_node; } if (had_errors) return error_mark_node; /* other arguments */ arg6 = force_addr_of (get_chill_filename ()); arg7 = get_chill_linenumber (); result = build_chill_function_call ( lookup_name (get_identifier ("__modify")), tree_cons (NULL_TREE, arg1, tree_cons (NULL_TREE, arg2, tree_cons (NULL_TREE, arg3, tree_cons (NULL_TREE, arg4, tree_cons (NULL_TREE, arg5, tree_cons (NULL_TREE, arg6, tree_cons (NULL_TREE, arg7, NULL_TREE)))))))); return result; } static int check_transfer (transfer, argnum, errmsg) tree transfer; int argnum; char *errmsg; { int result = 0; if (transfer == NULL_TREE || TREE_CODE (transfer) == ERROR_MARK) return 0; if (CH_IS_ACCESS_MODE (TREE_TYPE (transfer))) result = 1; else if (CH_IS_TEXT_MODE (TREE_TYPE (transfer))) result = 2; else { error ("argument %d of %s must be an ACCESS or TEXT mode", argnum, errmsg); return 0; } if (! CH_LOCATION_P (transfer)) { error ("argument %d of %s must be a location", argnum, errmsg); return 0; } return result; } /* define bits in an access/text flag word. NOTE: this must be consistent with runtime/iomodes.h */ #define IO_TEXTLOCATION 0x80000000 #define IO_INDEXED 0x00000001 #define IO_TEXTIO 0x00000002 #define IO_OUTOFFILE 0x00010000 /* generated initialisation code for ACCESS and TEXT. functions gets called from do_decl. */ void init_access_location (decl, type) tree decl; tree type; { tree recordmode = access_recordmode (type); tree indexmode = access_indexmode (type); int flags_init = 0; tree data = build_component_ref (decl, get_identifier ("data")); tree lowindex = integer_zero_node; tree highindex = integer_zero_node; tree rectype, reclen; /* flag word */ if (indexmode != NULL_TREE && indexmode != void_type_node) { flags_init |= IO_INDEXED; lowindex = convert (integer_type_node, TYPE_MIN_VALUE (indexmode)); highindex = convert (integer_type_node, TYPE_MAX_VALUE (indexmode)); } expand_expr_stmt ( build_chill_modify_expr ( build_component_ref (data, get_identifier ("flags")), build_int_2 (flags_init, 0))); /* record length */ if (recordmode == NULL_TREE || recordmode == void_type_node) { reclen = integer_zero_node; rectype = integer_zero_node; } else if (chill_varying_string_type_p (recordmode)) { tree fields = TYPE_FIELDS (recordmode); tree len1, len2; /* don't count any padding bytes at end of varying */ len1 = size_in_bytes (TREE_TYPE (fields)); fields = TREE_CHAIN (fields); len2 = size_in_bytes (TREE_TYPE (fields)); reclen = fold (build (PLUS_EXPR, long_integer_type_node, len1, len2)); rectype = build_int_2 (2, 0); } else { reclen = size_in_bytes (recordmode); rectype = integer_one_node; } expand_expr_stmt ( build_chill_modify_expr ( build_component_ref (data, get_identifier ("reclength")), reclen)); /* record type */ expand_expr_stmt ( build_chill_modify_expr ( build_component_ref (data, get_identifier ("rectype")), rectype)); /* the index */ expand_expr_stmt ( build_chill_modify_expr ( build_component_ref (data, get_identifier ("lowindex")), lowindex)); expand_expr_stmt ( build_chill_modify_expr ( build_component_ref (data, get_identifier ("highindex")), highindex)); /* association */ expand_expr_stmt ( build_chill_modify_expr ( build_chill_component_ref (data, get_identifier ("association")), null_pointer_node)); /* storelocptr */ expand_expr_stmt ( build_chill_modify_expr ( build_component_ref (data, get_identifier ("storelocptr")), null_pointer_node)); } void init_text_location (decl, type) tree decl; tree type; { tree indexmode = text_indexmode (type); unsigned long accessflags = 0; unsigned long textflags = IO_TEXTLOCATION; tree lowindex = integer_zero_node; tree highindex = integer_zero_node; tree data, tloc, tlocfields, len1, len2, reclen; if (indexmode != NULL_TREE && indexmode != void_type_node) { accessflags |= IO_INDEXED; lowindex = convert (integer_type_node, TYPE_MIN_VALUE (indexmode)); highindex = convert (integer_type_node, TYPE_MAX_VALUE (indexmode)); } tloc = build_component_ref (decl, get_identifier ("tloc")); /* fill access part of text location */ data = build_component_ref (decl, get_identifier ("acc")); /* flag word */ expand_expr_stmt ( build_chill_modify_expr ( build_component_ref (data, get_identifier ("flags")), build_int_2 (accessflags, 0))); /* record length, don't count any padding bytes at end of varying */ tlocfields = TYPE_FIELDS (TREE_TYPE (tloc)); len1 = size_in_bytes (TREE_TYPE (tlocfields)); tlocfields = TREE_CHAIN (tlocfields); len2 = size_in_bytes (TREE_TYPE (tlocfields)); reclen = fold (build (PLUS_EXPR, long_integer_type_node, len1, len2)); expand_expr_stmt ( build_chill_modify_expr ( build_component_ref (data, get_identifier ("reclength")), reclen)); /* the index */ expand_expr_stmt ( build_chill_modify_expr ( build_component_ref (data, get_identifier ("lowindex")), lowindex)); expand_expr_stmt ( build_chill_modify_expr ( build_component_ref (data, get_identifier ("highindex")), highindex)); /* association */ expand_expr_stmt ( build_chill_modify_expr ( build_chill_component_ref (data, get_identifier ("association")), null_pointer_node)); /* storelocptr */ expand_expr_stmt ( build_chill_modify_expr ( build_component_ref (data, get_identifier ("storelocptr")), null_pointer_node)); /* record type */ expand_expr_stmt ( build_chill_modify_expr ( build_component_ref (data, get_identifier ("rectype")), build_int_2 (2, 0))); /* VaryingChars */ /* fill text part */ data = build_component_ref (decl, get_identifier ("txt")); /* flag word */ expand_expr_stmt ( build_chill_modify_expr ( build_component_ref (data, get_identifier ("flags")), build_int_2 (textflags, 0))); /* pointer to text record */ expand_expr_stmt ( build_chill_modify_expr ( build_component_ref (data, get_identifier ("text_record")), force_addr_of (tloc))); /* pointer to the access */ expand_expr_stmt ( build_chill_modify_expr ( build_component_ref (data, get_identifier ("access_sub")), force_addr_of (build_component_ref (decl, get_identifier ("acc"))))); /* actual length */ expand_expr_stmt ( build_chill_modify_expr ( build_component_ref (data, get_identifier ("actual_index")), integer_zero_node)); /* length of text record */ expand_expr_stmt ( build_chill_modify_expr ( build_component_ref (tloc, get_identifier (VAR_LENGTH)), integer_zero_node)); } static int connect_process_optionals (optionals, whereptr, indexptr, indexmode) tree optionals; tree *whereptr; tree *indexptr; tree indexmode; { tree where = NULL_TREE, theindex = NULL_TREE; int had_errors = 0; if (optionals != NULL_TREE) { /* get the where expression */ where = TREE_VALUE (optionals); if (where == NULL_TREE || TREE_CODE (where) == ERROR_MARK) had_errors = 1; else { if (! CH_IS_WHERE_MODE (TREE_TYPE (where))) { error ("argument 4 of CONNECT must be of mode WHERE"); had_errors = 1; } where = convert (integer_type_node, where); } optionals = TREE_CHAIN (optionals); } if (optionals != NULL_TREE) { theindex = TREE_VALUE (optionals); if (theindex == NULL_TREE || TREE_CODE (theindex) == ERROR_MARK) had_errors = 1; else { if (indexmode == void_type_node) { error ("index expression for ACCESS without index"); had_errors = 1; } else if (! CH_COMPATIBLE (theindex, indexmode)) { error ("incompatible index mode"); had_errors = 1; } } } if (had_errors) return 0; *whereptr = where; *indexptr = theindex; return 1; } static tree connect_text (assoc, text, usage, optionals) tree assoc; tree text; tree usage; tree optionals; { tree where = NULL_TREE, theindex = NULL_TREE; tree indexmode = text_indexmode (TREE_TYPE (text)); tree result, what_where, have_index, what_index; /* process optionals */ if (!connect_process_optionals (optionals, &where, &theindex, indexmode)) return error_mark_node; what_where = where == NULL_TREE ? integer_zero_node : where; have_index = theindex == NULL_TREE ? integer_zero_node : integer_one_node; what_index = theindex == NULL_TREE ? integer_zero_node : convert (integer_type_node, theindex); result = build_chill_function_call ( lookup_name (get_identifier ("__connect")), tree_cons (NULL_TREE, force_addr_of (text), tree_cons (NULL_TREE, force_addr_of (assoc), tree_cons (NULL_TREE, convert (integer_type_node, usage), tree_cons (NULL_TREE, what_where, tree_cons (NULL_TREE, have_index, tree_cons (NULL_TREE, what_index, tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))))))))); return result; } static tree connect_access (assoc, transfer, usage, optionals) tree assoc; tree transfer; tree usage; tree optionals; { tree where = NULL_TREE, theindex = NULL_TREE; tree indexmode = access_indexmode (TREE_TYPE (transfer)); tree result, what_where, have_index, what_index; /* process the optionals */ if (! connect_process_optionals (optionals, &where, &theindex, indexmode)) return error_mark_node; /* now the call */ what_where = where == NULL_TREE ? integer_zero_node : where; have_index = theindex == NULL_TREE ? integer_zero_node : integer_one_node; what_index = theindex == NULL_TREE ? integer_zero_node : convert (integer_type_node, theindex); result = build_chill_function_call ( lookup_name (get_identifier ("__connect")), tree_cons (NULL_TREE, force_addr_of (transfer), tree_cons (NULL_TREE, force_addr_of (assoc), tree_cons (NULL_TREE, convert (integer_type_node, usage), tree_cons (NULL_TREE, what_where, tree_cons (NULL_TREE, have_index, tree_cons (NULL_TREE, what_index, tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))))))))); return result; } tree build_chill_connect (transfer, assoc, usage, optionals) tree transfer; tree assoc; tree usage; tree optionals; { int had_errors = 0; int what = 0; tree result = error_mark_node; if (! check_assoc (assoc, 2, "CONNECT")) had_errors = 1; /* check usage */ if (usage == NULL_TREE || TREE_CODE (usage) == ERROR_MARK) return error_mark_node; if (! CH_IS_USAGE_MODE (TREE_TYPE (usage))) { error ("argument 3 to CONNECT must be of mode USAGE"); had_errors = 1; } if (had_errors) return error_mark_node; /* look what we have got */ what = check_transfer (transfer, 1, "CONNECT"); switch (what) { case 1: /* we have an ACCESS */ result = connect_access (assoc, transfer, usage, optionals); break; case 2: /* we have a TEXT */ result = connect_text (assoc, transfer, usage, optionals); break; default: result = error_mark_node; } return result; } static int check_access (access, argnum, errmsg) tree access; int argnum; char *errmsg; { if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK) return 1; if (! CH_IS_ACCESS_MODE (TREE_TYPE (access))) { error ("argument %d of %s must be of mode ACCESS", argnum, errmsg); return 0; } if (! CH_LOCATION_P (access)) { error ("argument %d of %s must be a location", argnum, errmsg); return 0; } return 1; } tree build_chill_readrecord (access, optionals) tree access; tree optionals; { int len; tree recordmode, indexmode, dynamic, result; tree index = NULL_TREE, location = NULL_TREE; if (! check_access (access, 1, "READRECORD")) return error_mark_node; recordmode = access_recordmode (TREE_TYPE (access)); indexmode = access_indexmode (TREE_TYPE (access)); dynamic = access_dynamic (TREE_TYPE (access)); /* process the optionals */ len = list_length (optionals); if (indexmode != void_type_node) { /* we must have an index */ if (!len) { error ("Too few arguments in call to `readrecord'"); return error_mark_node; } index = TREE_VALUE (optionals); if (index == NULL_TREE || TREE_CODE (index) == ERROR_MARK) return error_mark_node; optionals = TREE_CHAIN (optionals); if (! CH_COMPATIBLE (index, indexmode)) { error ("incompatible index mode"); return error_mark_node; } } /* check the record mode, if one */ if (optionals != NULL_TREE) { location = TREE_VALUE (optionals); if (location == NULL_TREE || TREE_CODE (location) == ERROR_MARK) return error_mark_node; if (recordmode != void_type_node && ! CH_COMPATIBLE (location, recordmode)) { error ("incompatible record mode"); return error_mark_node; } if (TYPE_READONLY_PROPERTY (TREE_TYPE (location))) { error ("store location must not be READonly"); return error_mark_node; } location = force_addr_of (location); } else location = null_pointer_node; index = index == NULL_TREE ? integer_zero_node : convert (integer_type_node, index); result = build_chill_function_call ( lookup_name (get_identifier ("__readrecord")), tree_cons (NULL_TREE, force_addr_of (access), tree_cons (NULL_TREE, index, tree_cons (NULL_TREE, location, tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))))); TREE_TYPE (result) = build_chill_pointer_type (recordmode); return result; } tree build_chill_writerecord (access, optionals) tree access; tree optionals; { int had_errors = 0, len; tree recordmode, indexmode, dynamic; tree index = NULL_TREE, location = NULL_TREE; tree result; if (! check_access (access, 1, "WRITERECORD")) return error_mark_node; recordmode = access_recordmode (TREE_TYPE (access)); indexmode = access_indexmode (TREE_TYPE (access)); dynamic = access_dynamic (TREE_TYPE (access)); /* process the optionals */ len = list_length (optionals); if (indexmode != void_type_node && len != 2) { error ("Too few arguments in call to `writerecord'"); return error_mark_node; } if (indexmode != void_type_node) { index = TREE_VALUE (optionals); if (index == NULL_TREE || TREE_CODE (index) == ERROR_MARK) return error_mark_node; location = TREE_VALUE (TREE_CHAIN (optionals)); if (location == NULL_TREE || TREE_CODE (location) == ERROR_MARK) return error_mark_node; } else location = TREE_VALUE (optionals); /* check the index */ if (indexmode != void_type_node) { if (! CH_COMPATIBLE (index, indexmode)) { error ("incompatible index mode"); had_errors = 1; } } /* check the record mode */ if (recordmode == void_type_node) { error ("transfer to ACCESS without record mode"); had_errors = 1; } else if (! CH_COMPATIBLE (location, recordmode)) { error ("incompatible record mode"); had_errors = 1; } if (had_errors) return error_mark_node; index = index == NULL_TREE ? integer_zero_node : convert (integer_type_node, index); result = build_chill_function_call ( lookup_name (get_identifier ("__writerecord")), tree_cons (NULL_TREE, force_addr_of (access), tree_cons (NULL_TREE, index, tree_cons (NULL_TREE, force_addr_of (location), tree_cons (NULL_TREE, size_in_bytes (TREE_TYPE (location)), tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))))))); return result; } tree build_chill_disconnect (transfer) tree transfer; { tree result; if (! check_transfer (transfer, 1, "DISCONNECT")) return error_mark_node; result = build_chill_function_call ( lookup_name (get_identifier ("__disconnect")), tree_cons (NULL_TREE, force_addr_of (transfer), tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); return result; } tree build_chill_getassociation (transfer) tree transfer; { tree result; if (! check_transfer (transfer, 1, "GETASSOCIATION")) return error_mark_node; result = build_chill_function_call ( lookup_name (get_identifier ("__getassociation")), tree_cons (NULL_TREE, force_addr_of (transfer), tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); TREE_TYPE (result) = build_chill_pointer_type (association_type_node); return result; } tree build_chill_getusage (transfer) tree transfer; { tree result; if (! check_transfer (transfer, 1, "GETUSAGE")) return error_mark_node; result = build_chill_function_call ( lookup_name (get_identifier ("__getusage")), tree_cons (NULL_TREE, force_addr_of (transfer), tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); TREE_TYPE (result) = usage_type_node; return result; } tree build_chill_outoffile (transfer) tree transfer; { tree result; if (! check_transfer (transfer, 1, "OUTOFFILE")) return error_mark_node; result = build_chill_function_call ( lookup_name (get_identifier ("__outoffile")), tree_cons (NULL_TREE, force_addr_of (transfer), tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); return result; } static int check_text (text, argnum, errmsg) tree text; int argnum; char *errmsg; { if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK) return 0; if (! CH_IS_TEXT_MODE (TREE_TYPE (text))) { error ("argument %d of %s must be of mode TEXT", argnum, errmsg); return 0; } if (! CH_LOCATION_P (text)) { error ("argument %d of %s must be a location", argnum, errmsg); return 0; } return 1; } tree build_chill_eoln (text) tree text; { tree result; if (! check_text (text, 1, "EOLN")) return error_mark_node; result = build_chill_function_call ( lookup_name (get_identifier ("__eoln")), tree_cons (NULL_TREE, force_addr_of (text), tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); return result; } tree build_chill_gettextindex (text) tree text; { tree result; if (! check_text (text, 1, "GETTEXTINDEX")) return error_mark_node; result = build_chill_function_call ( lookup_name (get_identifier ("__gettextindex")), tree_cons (NULL_TREE, force_addr_of (text), tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); return result; } tree build_chill_gettextrecord (text) tree text; { tree textmode, result; if (! check_text (text, 1, "GETTEXTRECORD")) return error_mark_node; textmode = textlocation_mode (TREE_TYPE (text)); if (textmode == NULL_TREE) { error ("TEXT doesn't have a location"); /* FIXME */ return error_mark_node; } result = build_chill_function_call ( lookup_name (get_identifier ("__gettextrecord")), tree_cons (NULL_TREE, force_addr_of (text), tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); TREE_TYPE (result) = build_chill_pointer_type (textmode); CH_DERIVED_FLAG (result) = 1; return result; } tree build_chill_gettextaccess (text) tree text; { tree access, refaccess, acc, decl, listbase; tree tlocmode, indexmode, dynamic; tree result; extern int maximum_field_alignment; int save_maximum_field_alignment = maximum_field_alignment; if (! check_text (text, 1, "GETTEXTACCESS")) return error_mark_node; tlocmode = textlocation_mode (TREE_TYPE (text)); indexmode = text_indexmode (TREE_TYPE (text)); dynamic = text_dynamic (TREE_TYPE (text)); /* we have to build a type for the access */ acc = build_access_part (); access = make_node (RECORD_TYPE); listbase = build_decl (FIELD_DECL, get_identifier ("data"), acc); TYPE_FIELDS (access) = listbase; decl = build_lang_decl (TYPE_DECL, get_identifier ("__recordmode"), tlocmode); chainon (listbase, decl); decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"), indexmode); chainon (listbase, decl); decl = build_decl (CONST_DECL, get_identifier ("__dynamic"), integer_type_node); DECL_INITIAL (decl) = dynamic; chainon (listbase, decl); maximum_field_alignment = 0; layout_chill_struct_type (access); maximum_field_alignment = save_maximum_field_alignment; CH_IS_ACCESS_MODE (access) = 1; CH_TYPE_NONVALUE_P (access) = 1; refaccess = build_chill_pointer_type (access); result = build_chill_function_call ( lookup_name (get_identifier ("__gettextaccess")), tree_cons (NULL_TREE, force_addr_of (text), tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))); TREE_TYPE (result) = refaccess; CH_DERIVED_FLAG (result) = 1; return result; } tree build_chill_settextindex (text, expr) tree text; tree expr; { tree result; if (! check_text (text, 1, "SETTEXTINDEX")) return error_mark_node; if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) return error_mark_node; result = build_chill_function_call ( lookup_name (get_identifier ("__settextindex")), tree_cons (NULL_TREE, force_addr_of (text), tree_cons (NULL_TREE, expr, tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))))); return result; } tree build_chill_settextaccess (text, access) tree text; tree access; { tree result; tree textindexmode, accessindexmode; tree textrecordmode, accessrecordmode; if (! check_text (text, 1, "SETTEXTACCESS")) return error_mark_node; if (! check_access (access, 2, "SETTEXTACCESS")) return error_mark_node; textindexmode = text_indexmode (TREE_TYPE (text)); accessindexmode = access_indexmode (TREE_TYPE (access)); if (textindexmode != accessindexmode) { if (! chill_read_compatible (textindexmode, accessindexmode)) { error ("incompatible index mode for SETETEXTACCESS"); return error_mark_node; } } textrecordmode = textlocation_mode (TREE_TYPE (text)); accessrecordmode = access_recordmode (TREE_TYPE (access)); if (textrecordmode != accessrecordmode) { if (! chill_read_compatible (textrecordmode, accessrecordmode)) { error ("incompatible record mode for SETTEXTACCESS"); return error_mark_node; } } result = build_chill_function_call ( lookup_name (get_identifier ("__settextaccess")), tree_cons (NULL_TREE, force_addr_of (text), tree_cons (NULL_TREE, force_addr_of (access), tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))))); return result; } tree build_chill_settextrecord (text, charloc) tree text; tree charloc; { tree result; int had_errors = 0; tree tlocmode; if (! check_text (text, 1, "SETTEXTRECORD")) return error_mark_node; if (charloc == NULL_TREE || TREE_CODE (charloc) == ERROR_MARK) return error_mark_node; /* check the location */ if (! CH_LOCATION_P (charloc)) { error ("parameter 2 must be a location"); return error_mark_node; } tlocmode = textlocation_mode (TREE_TYPE (text)); if (! chill_varying_string_type_p (TREE_TYPE (charloc))) had_errors = 1; else if (int_size_in_bytes (tlocmode) != int_size_in_bytes (TREE_TYPE (charloc))) had_errors = 1; if (had_errors) { error ("incompatible modes in parameter 2"); return error_mark_node; } result = build_chill_function_call ( lookup_name (get_identifier ("__settextrecord")), tree_cons (NULL_TREE, force_addr_of (text), tree_cons (NULL_TREE, force_addr_of (charloc), tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()), tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))))); return result; } /* process iolist for READ- and WRITETEXT */ /* function walks through types as long as they are ranges, returns the type and min- and max-value form starting type. */ static tree get_final_type_and_range (item, low, high) tree item; tree *low; tree *high; { tree wrk = item; *low = TYPE_MIN_VALUE (wrk); *high = TYPE_MAX_VALUE (wrk); while (TREE_CODE (wrk) == INTEGER_TYPE && TREE_TYPE (wrk) != NULL_TREE && TREE_CODE (TREE_TYPE (wrk)) == INTEGER_TYPE && TREE_TYPE (TREE_TYPE (wrk)) != NULL_TREE) wrk = TREE_TYPE (wrk); return (TREE_TYPE (wrk)); } static void process_io_list (exprlist, iolist_addr, iolist_length, iolist_rtx, do_read, argoffset) tree exprlist; tree *iolist_addr; tree *iolist_length; rtx *iolist_rtx; int do_read; int argoffset; { tree idxlist; int idxcnt; int iolen; tree iolisttype, iolist; if (exprlist == NULL_TREE) return; iolen = list_length (exprlist); /* build indexlist for the io list */ idxlist = build_tree_list (NULL_TREE, build_chill_range_type (NULL_TREE, integer_one_node, build_int_2 (iolen, 0))); /* build the io-list type */ iolisttype = build_chill_array_type (TREE_TYPE (chill_io_list_type), idxlist, 0, NULL_TREE); /* declare the iolist */ iolist = build_decl (VAR_DECL, get_unique_identifier (do_read ? "RDTEXT" : "WRTEXT"), iolisttype); /* we want to get a variable which gets marked unused after the function call, This is a little bit tricky cause the address of this variable will be taken and therefor the variable gets moved out one level. However, we REALLY don't need this variable again. Solution: push 2 levels and do pop and free twice at the end. */ push_temp_slots (); push_temp_slots (); *iolist_rtx = assign_temp (TREE_TYPE (iolist), 0, 1, 0); DECL_RTL (iolist) = *iolist_rtx; /* process the exprlist */ idxcnt = 1; while (exprlist != NULL_TREE) { tree item = TREE_VALUE (exprlist); tree idx = build_int_2 (idxcnt++, 0); char *fieldname = 0; char *enumname = 0; tree array_ref = build_chill_array_ref_1 (iolist, idx); tree item_type; tree range_low = NULL_TREE, range_high = NULL_TREE; int have_range = 0; tree item_addr = null_pointer_node; int referable = 0; int readonly = 0; /* next value in exprlist */ exprlist = TREE_CHAIN (exprlist); if (item == NULL_TREE || TREE_CODE (item) == ERROR_MARK) continue; item_type = TREE_TYPE (item); if (item_type == NULL_TREE) { if (TREE_CODE (item) == COND_EXPR || TREE_CODE (item) == CASE_EXPR) error ("conditional expression not allowed in this context"); else error ("untyped expression as argument %d", idxcnt + 1 + argoffset); continue; } else if (TREE_CODE (item_type) == ERROR_MARK) continue; if (TREE_CODE (item_type) == REFERENCE_TYPE) { item_type = TREE_TYPE (item_type); item = convert (item_type, item); } /* check for a range */ if (TREE_CODE (item_type) == INTEGER_TYPE && TREE_TYPE (item_type) != NULL_TREE) { /* we have a range. NOTE, however, on writetext we don't process ranges */ item_type = get_final_type_and_range (item_type, &range_low, &range_high); have_range = 1; } readonly = TYPE_READONLY_PROPERTY (item_type); referable = CH_REFERABLE (item); if (referable) item_addr = force_addr_of (item); /* if we are in read and have readonly we can't do this */ if (readonly && do_read) { item_addr = null_pointer_node; referable = 0; } /* process different types */ if (TREE_CODE (item_type) == INTEGER_TYPE) { int type_size = TREE_INT_CST_LOW (TYPE_SIZE (item_type)); tree to_assign = NULL_TREE; if (do_read && referable) { /* process an integer in case of READTEXT and expression is referable and not READONLY */ to_assign = item_addr; if (have_range) { /* do it for a range */ tree t, __forxx, __ptr, __low, __high; tree what_upper, what_lower; /* determine the name in the union of lower and upper */ if (TREE_UNSIGNED (item_type)) fieldname = "_ulong"; else fieldname = "_slong"; switch (type_size) { case 8: if (TREE_UNSIGNED (item_type)) enumname = "__IO_UByteRangeLoc"; else enumname = "__IO_ByteRangeLoc"; break; case 16: if (TREE_UNSIGNED (item_type)) enumname = "__IO_UIntRangeLoc"; else enumname = "__IO_IntRangeLoc"; break; case 32: if (TREE_UNSIGNED (item_type)) enumname = "__IO_ULongRangeLoc"; else enumname = "__IO_LongRangeLoc"; break; default: error ("Cannot process %d bits integer for READTEXT argument %d.", type_size, idxcnt + 1 + argoffset); continue; } /* set up access to structure */ t = build_component_ref (array_ref, get_identifier ("__t")); __forxx = build_component_ref (t, get_identifier ("__locintrange")); __ptr = build_component_ref (__forxx, get_identifier ("ptr")); __low = build_component_ref (__forxx, get_identifier ("lower")); what_lower = build_component_ref (__low, get_identifier (fieldname)); __high = build_component_ref (__forxx, get_identifier ("upper")); what_upper = build_component_ref (__high, get_identifier (fieldname)); /* do the assignments */ expand_assignment (__ptr, item_addr, 0, 0); expand_assignment (what_lower, range_low, 0, 0); expand_assignment (what_upper, range_high, 0, 0); fieldname = 0; } else { /* no range */ fieldname = "__locint"; switch (type_size) { case 8: if (TREE_UNSIGNED (item_type)) enumname = "__IO_UByteLoc"; else enumname = "__IO_ByteLoc"; break; case 16: if (TREE_UNSIGNED (item_type)) enumname = "__IO_UIntLoc"; else enumname = "__IO_IntLoc"; break; case 32: if (TREE_UNSIGNED (item_type)) enumname = "__IO_ULongLoc"; else enumname = "__IO_LongLoc"; break; default: error ("Cannot process %d bits integer for READTEXT argument %d.", type_size, idxcnt + 1 + argoffset); continue; } } } else { /* process an integer in case of WRITETEXT */ to_assign = item; switch (type_size) { case 8: if (TREE_UNSIGNED (item_type)) { enumname = "__IO_UByteVal"; fieldname = "__valubyte"; } else { enumname = "__IO_ByteVal"; fieldname = "__valbyte"; } break; case 16: if (TREE_UNSIGNED (item_type)) { enumname = "__IO_UIntVal"; fieldname = "__valuint"; } else { enumname = "__IO_IntVal"; fieldname = "__valint"; } break; case 32: try_long: if (TREE_UNSIGNED (item_type)) { enumname = "__IO_ULongVal"; fieldname = "__valulong"; } else { enumname = "__IO_LongVal"; fieldname = "__vallong"; } break; case 64: /* convert it back to {unsigned}long. */ if (TREE_UNSIGNED (item_type)) item_type = long_unsigned_type_node; else item_type = long_integer_type_node; item = convert (item_type, item); goto try_long; default: /* This kludge is because the lexer gives literals the type long_long_{integer,unsigned}_type_node. */ if (TREE_CODE (item) == INTEGER_CST) { if (int_fits_type_p (item, long_integer_type_node)) { item_type = long_integer_type_node; item = convert (item_type, item); goto try_long; } if (int_fits_type_p (item, long_unsigned_type_node)) { item_type = long_unsigned_type_node; item = convert (item_type, item); goto try_long; } } error ("Cannot process %d bits integer WRITETEXT argument %d.", type_size, idxcnt + 1 + argoffset); continue; } } if (fieldname) { tree t, __forxx; t = build_component_ref (array_ref, get_identifier ("__t")); __forxx = build_component_ref (t, get_identifier (fieldname)); expand_assignment (__forxx, to_assign, 0, 0); } } else if (TREE_CODE (item_type) == CHAR_TYPE) { tree to_assign = NULL_TREE; if (do_read && readonly) { error ("argument %d is READonly", idxcnt + 1 + argoffset); continue; } if (do_read) { if (! referable) { error ("argument %d must be referable", idxcnt + 1 + argoffset); continue; } if (have_range) { tree t, forxx, ptr, lower, upper; t = build_component_ref (array_ref, get_identifier ("__t")); forxx = build_component_ref (t, get_identifier ("__loccharrange")); ptr = build_component_ref (forxx, get_identifier ("ptr")); lower = build_component_ref (forxx, get_identifier ("lower")); upper = build_component_ref (forxx, get_identifier ("upper")); expand_assignment (ptr, item_addr, 0, 0); expand_assignment (lower, range_low, 0, 0); expand_assignment (upper, range_high, 0, 0); fieldname = 0; enumname = "__IO_CharRangeLoc"; } else { to_assign = item_addr; fieldname = "__locchar"; enumname = "__IO_CharLoc"; } } else { to_assign = item; enumname = "__IO_CharVal"; fieldname = "__valchar"; } if (fieldname) { tree t, forxx; t = build_component_ref (array_ref, get_identifier ("__t")); forxx = build_component_ref (t, get_identifier (fieldname)); expand_assignment (forxx, to_assign, 0, 0); } } else if (TREE_CODE (item_type) == BOOLEAN_TYPE) { tree to_assign = NULL_TREE; if (do_read && readonly) { error ("argument %d is READonly", idxcnt + 1 + argoffset); continue; } if (do_read) { if (! referable) { error ("argument %d must be referable", idxcnt + 1 + argoffset); continue; } if (have_range) { tree t, forxx, ptr, lower, upper; t = build_component_ref (array_ref, get_identifier ("__t")); forxx = build_component_ref (t, get_identifier ("__locboolrange")); ptr = build_component_ref (forxx, get_identifier ("ptr")); lower = build_component_ref (forxx, get_identifier ("lower")); upper = build_component_ref (forxx, get_identifier ("upper")); expand_assignment (ptr, item_addr, 0, 0); expand_assignment (lower, range_low, 0, 0); expand_assignment (upper, range_high, 0, 0); fieldname = 0; enumname = "__IO_BoolRangeLoc"; } else { to_assign = item_addr; fieldname = "__locbool"; enumname = "__IO_BoolLoc"; } } else { to_assign = item; enumname = "__IO_BoolVal"; fieldname = "__valbool"; } if (fieldname) { tree t, forxx; t = build_component_ref (array_ref, get_identifier ("__t")); forxx = build_component_ref (t, get_identifier (fieldname)); expand_assignment (forxx, to_assign, 0, 0); } } else if (TREE_CODE (item_type) == ENUMERAL_TYPE) { /* process an enum */ tree table_name; tree context_of_type; tree t; /* determine the context of the type. if TYPE_NAME (item_type) == NULL_TREE if TREE_CODE (item) == INTEGER_CST context = NULL_TREE -- this is wrong but should work for now else context = DECL_CONTEXT (item) else context = DECL_CONTEXT (TYPE_NAME (item_type)) */ if (TYPE_NAME (item_type) == NULL_TREE) { if (TREE_CODE (item) == INTEGER_CST) context_of_type = NULL_TREE; else context_of_type = DECL_CONTEXT (item); } else context_of_type = DECL_CONTEXT (TYPE_NAME (item_type)); table_name = add_enum_to_list (item_type, context_of_type); t = build_component_ref (array_ref, get_identifier ("__t")); if (do_read && readonly) { error ("argument %d is READonly", idxcnt + 1 + argoffset); continue; } if (do_read) { if (! referable) { error ("argument %d must be referable", idxcnt + 1 + argoffset); continue; } if (have_range) { tree forxx, ptr, len, nametable, lower, upper; forxx = build_component_ref (t, get_identifier ("__locsetrange")); ptr = build_component_ref (forxx, get_identifier ("ptr")); len = build_component_ref (forxx, get_identifier ("length")); nametable = build_component_ref (forxx, get_identifier ("name_table")); lower = build_component_ref (forxx, get_identifier ("lower")); upper = build_component_ref (forxx, get_identifier ("upper")); expand_assignment (ptr, item_addr, 0, 0); expand_assignment (len, size_in_bytes (item_type), 0, 0); expand_assignment (nametable, table_name, 0, 0); expand_assignment (lower, range_low, 0, 0); expand_assignment (upper, range_high, 0, 0); enumname = "__IO_SetRangeLoc"; } else { tree forxx, ptr, len, nametable; forxx = build_component_ref (t, get_identifier ("__locset")); ptr = build_component_ref (forxx, get_identifier ("ptr")); len = build_component_ref (forxx, get_identifier ("length")); nametable = build_component_ref (forxx, get_identifier ("name_table")); expand_assignment (ptr, item_addr, 0, 0); expand_assignment (len, size_in_bytes (item_type), 0, 0); expand_assignment (nametable, table_name, 0, 0); enumname = "__IO_SetLoc"; } } else { tree forxx, value, nametable; forxx = build_component_ref (t, get_identifier ("__valset")); value = build_component_ref (forxx, get_identifier ("value")); nametable = build_component_ref (forxx, get_identifier ("name_table")); expand_assignment (value, item, 0, 0); expand_assignment (nametable, table_name, 0, 0); enumname = "__IO_SetVal"; } } else if (chill_varying_string_type_p (item_type)) { /* varying char string */ tree t = build_component_ref (array_ref, get_identifier ("__t")); tree forxx = build_component_ref (t, get_identifier ("__loccharstring")); tree string = build_component_ref (forxx, get_identifier ("string")); tree length = build_component_ref (forxx, get_identifier ("string_length")); if (do_read && readonly) { error ("argument %d is READonly", idxcnt + 1 + argoffset); continue; } if (do_read) { /* in this read case the argument must be referable */ if (! referable) { error ("argument %d must be referable", idxcnt + 1 + argoffset); continue; } } else if (! referable) { /* in the write case we create a temporary if not referable */ rtx t; tree loc = build_decl (VAR_DECL, get_unique_identifier ("WRTEXTVS"), item_type); t = assign_temp (item_type, 0, 1, 0); DECL_RTL (loc) = t; expand_assignment (loc, item, 0, 0); item_addr = force_addr_of (loc); item = loc; } expand_assignment (string, item_addr, 0, 0); if (do_read) /* we must pass the maximum length of the varying */ expand_assignment (length, size_in_bytes (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (item_type)))), 0, 0); else /* we pass the actual length of the string */ expand_assignment (length, build_component_ref (item, var_length_id), 0, 0); enumname = "__IO_CharVaryingLoc"; } else if (CH_CHARS_TYPE_P (item_type)) { /* fixed character string */ tree the_size; tree t = build_component_ref (array_ref, get_identifier ("__t")); tree forxx = build_component_ref (t, get_identifier ("__loccharstring")); tree string = build_component_ref (forxx, get_identifier ("string")); tree length = build_component_ref (forxx, get_identifier ("string_length")); if (do_read && readonly) { error ("argument %d is READonly", idxcnt + 1 + argoffset); continue; } if (do_read) { /* in this read case the argument must be referable */ if (! CH_REFERABLE (item)) { error ("argument %d must be referable", idxcnt + 1 + argoffset); continue; } else item_addr = force_addr_of (item); the_size = size_in_bytes (item_type); enumname = "__IO_CharStrLoc"; } else { if (! CH_REFERABLE (item)) { /* in the write case we create a temporary if not referable */ rtx t; int howmuchbytes; howmuchbytes = int_size_in_bytes (item_type); if (howmuchbytes != -1) { /* fixed size */ tree loc = build_decl (VAR_DECL, get_unique_identifier ("WRTEXTVS"), item_type); t = assign_temp (item_type, 0, 1, 0); DECL_RTL (loc) = t; expand_assignment (loc, item, 0, 0); item_addr = force_addr_of (loc); the_size = size_in_bytes (item_type); enumname = "__IO_CharStrLoc"; } else { tree type, string, exp, loc; if ((howmuchbytes = intsize_of_charsexpr (item)) == -1) { error ("cannot process argument %d of WRITETEXT, unknown size", idxcnt + 1 + argoffset); continue; } string = build_string_type (char_type_node, build_int_2 (howmuchbytes, 0)); type = build_varying_struct (string); loc = build_decl (VAR_DECL, get_unique_identifier ("WRTEXTCS"), type); t = assign_temp (type, 0, 1, 0); DECL_RTL (loc) = t; exp = chill_convert_for_assignment (type, item, 0); expand_assignment (loc, exp, 0, 0); item_addr = force_addr_of (loc); the_size = integer_zero_node; enumname = "__IO_CharVaryingLoc"; } } else { item_addr = force_addr_of (item); the_size = size_in_bytes (item_type); enumname = "__IO_CharStrLoc"; } } expand_assignment (string, item_addr, 0, 0); expand_assignment (length, size_in_bytes (item_type), 0, 0); } else if (CH_BOOLS_TYPE_P (item_type)) { /* we have a bitstring */ tree t = build_component_ref (array_ref, get_identifier ("__t")); tree forxx = build_component_ref (t, get_identifier ("__loccharstring")); tree string = build_component_ref (forxx, get_identifier ("string")); tree length = build_component_ref (forxx, get_identifier ("string_length")); if (do_read && readonly) { error ("argument %d is READonly", idxcnt + 1 + argoffset); continue; } if (do_read) { /* in this read case the argument must be referable */ if (! referable) { error ("argument %d must be referable", idxcnt + 1 + argoffset); continue; } } else if (! referable) { /* in the write case we create a temporary if not referable */ tree loc = build_decl (VAR_DECL, get_unique_identifier ("WRTEXTVS"), item_type); DECL_RTL (loc) = assign_temp (item_type, 0, 1, 0); expand_assignment (loc, item, 0, 0); item_addr = force_addr_of (loc); } expand_assignment (string, item_addr, 0, 0); expand_assignment (length, build_chill_length (item), 0, 0); enumname = "__IO_BitStrLoc"; } else if (TREE_CODE (item_type) == REAL_TYPE) { /* process a (long_)real */ tree t, forxx, to_assign; if (do_read && readonly) { error ("argument %d is READonly", idxcnt + 1 + argoffset); continue; } if (do_read && ! referable) { error ("argument %d must be referable", idxcnt + 1 + argoffset); continue; } if (lookup_name (ridpointers[RID_FLOAT]) == TYPE_NAME (item_type)) { /* we have a real */ if (do_read) { enumname = "__IO_RealLoc"; fieldname = "__locreal"; to_assign = item_addr; } else { enumname = "__IO_RealVal"; fieldname = "__valreal"; to_assign = item; } } else { /* we have a long_real */ if (do_read) { enumname = "__IO_LongRealLoc"; fieldname = "__loclongreal"; to_assign = item_addr; } else { enumname = "__IO_LongRealVal"; fieldname = "__vallongreal"; to_assign = item; } } t = build_component_ref (array_ref, get_identifier ("__t")); forxx = build_component_ref (t, get_identifier (fieldname)); expand_assignment (forxx, to_assign, 0, 0); } #if 0 /* don't process them for now */ else if (TREE_CODE (item_type) == POINTER_TYPE) { /* we have a pointer */ tree __t, __forxx; __t = build_component_ref (array_ref, get_identifier ("__t")); __forxx = build_component_ref (__t, get_identifier ("__forpointer")); expand_assignment (__forxx, item, 0, 0); enumname = "_IO_Pointer"; } else if (item_type == instance_type_node) { /* we have an INSTANCE */ tree __t, __forxx; __t = build_component_ref (array_ref, get_identifier ("__t")); __forxx = build_component_ref (__t, get_identifier ("__forinstance")); expand_assignment (__forxx, item, 0, 0); enumname = "_IO_Instance"; } #endif else { /* datatype is not yet implemented, issue a warning */ error ("cannot process mode of argument %d for %sTEXT.", idxcnt + 1 + argoffset, do_read ? "READ" : "WRITE"); enumname = "__IO_UNUSED"; } /* do assignment of the enum */ if (enumname) { tree descr = build_component_ref (array_ref, get_identifier ("__descr")); expand_assignment (descr, lookup_name (get_identifier (enumname)), 0, 0); } } /* set up address and length of iolist */ *iolist_addr = build_chill_addr_expr (iolist, (char *)0); *iolist_length = build_int_2 (iolen, 0); } /* check the format string */ #define LET 0x0001 #define BIN 0x0002 #define DEC 0x0004 #define OCT 0x0008 #define HEX 0x0010 #define USC 0x0020 #define BIL 0x0040 #define SPC 0x0080 #define SCS 0x0100 #define IOC 0x0200 #define EDC 0x0400 #define CVC 0x0800 #define isDEC(c) ( chartab[(c)] & DEC ) #define isCVC(c) ( chartab[(c)] & CVC ) #define isEDC(c) ( chartab[(c)] & EDC ) #define isIOC(c) ( chartab[(c)] & IOC ) #define isUSC(c) #define isXXX(c,XXX) ( chartab[(c)] & XXX ) static short int chartab[256] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, SPC, SPC, SPC, SPC, SPC, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, SPC, IOC, 0, 0, 0, 0, 0, 0, SCS, SCS, SCS, SCS+IOC, SCS, SCS+IOC, SCS, SCS+IOC, BIN+OCT+DEC+HEX, BIN+OCT+DEC+HEX, OCT+DEC+HEX, OCT+DEC+HEX, OCT+DEC+HEX, OCT+DEC+HEX, OCT+DEC+HEX, OCT+DEC+HEX, DEC+HEX, DEC+HEX, SCS, SCS, SCS+EDC, SCS+IOC, SCS+EDC, IOC, 0, LET+HEX+BIL, LET+HEX+BIL+CVC, LET+HEX+BIL+CVC, LET+HEX+BIL, LET+HEX, LET+HEX+CVC, LET, LET+BIL+CVC, LET, LET, LET, LET, LET, LET, LET+CVC, LET, LET, LET, LET, LET+EDC, LET, LET, LET, LET+EDC, LET, LET, SCS, 0, SCS, 0, USC, 0, LET+HEX, LET+HEX, LET+HEX, LET+HEX, LET+HEX, LET+HEX, LET, LET, LET, LET, LET, LET, LET, LET, LET, LET, LET, LET, LET, LET, LET, LET, LET, LET, LET, LET, 0, 0, 0, 0, 0 }; typedef enum { FormatText, FirstPercent, RepFact, ConvClause, EditClause, ClauseEnd, AfterWidth, FractWidth, FractWidthCont, ExpoWidth, ExpoWidthCont, ClauseWidth, CatchPadding, LastPercent } fcsstate_t; #define CONVERSIONCODES "CHOBF" typedef enum { DefaultConv, HexConv, OctalConv, BinaryConv, ScientConv } convcode_t; static convcode_t convcode; typedef enum { False, True, } Boolean; static unsigned long fractionwidth; #define IOCODES "/+-?!=" typedef enum { NextRecord, NextPage, CurrentLine, Prompt, Emit, EndPage } iocode_t; static iocode_t iocode; #define EDITCODES "X<>T" typedef enum { SpaceSkip, SkipLeft, SkipRight, Tabulation } editcode_t; static editcode_t editcode; static unsigned long clausewidth; static Boolean leftadjust; static Boolean overflowev; static Boolean dynamicwid; static Boolean paddingdef; static char paddingchar; static Boolean fractiondef; static Boolean exponentdef; static unsigned long exponentwidth; static unsigned long repetition; typedef enum { NormalEnd, EndAtParen, TextFailEnd } formatexit_t; /* NOTE: varibale have to be set to False before calling check_format_string */ static Boolean empty_printed; static int formstroffset; static tree check_exprlist (code, exprlist, argnum, repetition) convcode_t code; tree exprlist; int argnum; unsigned long repetition; { tree expr, type, result = NULL_TREE; while (repetition--) { if (exprlist == NULL_TREE) { if (empty_printed == False) { warning ("too few arguments for this format string"); empty_printed = True; } return NULL_TREE; } expr = TREE_VALUE (exprlist); result = exprlist = TREE_CHAIN (exprlist); if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) return result; type = TREE_TYPE (expr); if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) return result; if (TREE_CODE (type) == REFERENCE_TYPE) type = TREE_TYPE (type); if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) return result; switch (code) { case DefaultConv: /* %C, everything is allowed. Not know types are flaged later. */ break; case ScientConv: /* %F, must be a REAL */ if (TREE_CODE (type) != REAL_TYPE) warning ("type of argument %d invalid for conversion code at offset %d", argnum, formstroffset); break; case HexConv: case OctalConv: case BinaryConv: case -1: /* %H, %O, %B, and V as clause width */ if (TREE_CODE (type) != INTEGER_TYPE) warning ("type of argument %d invalid for conversion code at offset %d", argnum, formstroffset); break; default: /* there is an invalid conversion code */ break; } } return result; } static formatexit_t scanformcont (fcs, len, fcsptr, lenptr, exprlist, exprptr, firstargnum, nextargnum) char *fcs; int len; char **fcsptr; int *lenptr; tree exprlist; tree *exprptr; int firstargnum; int *nextargnum; { fcsstate_t state = FormatText; unsigned char curr; int dig; while (len--) { curr = *fcs++; formstroffset++; switch (state) { case FormatText: if (curr == '%') state = FirstPercent; break; after_first_percent: ; case FirstPercent: if (curr == '%') { state = FormatText; break; } if (curr == ')') { *lenptr = len; *fcsptr = fcs; *exprptr = exprlist; *nextargnum = firstargnum; return EndAtParen; } if (isDEC (curr)) { state = RepFact; repetition = curr - '0'; break; } repetition = 1; test_for_control_codes: ; if (isCVC (curr)) { state = ConvClause; convcode = strchr (CONVERSIONCODES, curr) - CONVERSIONCODES; leftadjust = False; overflowev = False; dynamicwid = False; paddingdef = False; paddingchar = ' '; fractiondef = False; /* fractionwidth = 0; default depends on mode ! */ exponentdef = False; exponentwidth = 3; clausewidth = 0; /* check the argument */ exprlist = check_exprlist (convcode, exprlist, firstargnum, repetition); firstargnum++; break; } if (isEDC (curr)) { state = EditClause; editcode = strchr (EDITCODES, curr) - EDITCODES; dynamicwid = False; clausewidth = editcode == Tabulation ? 0 : 1; break; } if (isIOC (curr)) { state = ClauseEnd; iocode = strchr (IOCODES, curr) - IOCODES; break; } if (curr == '(') { unsigned long times = repetition; int cntlen; char* cntfcs; tree cntexprlist; int nextarg; while (times--) { if (scanformcont (fcs, len, &cntfcs, &cntlen, exprlist, &cntexprlist, firstargnum, &nextarg) != EndAtParen ) { warning ("unmatched open paren"); break; } exprlist = cntexprlist; } fcs = cntfcs; len = cntlen; if (len < 0) len = 0; exprlist = cntexprlist; firstargnum = nextarg; state = FormatText; break; } warning ("bad format specification character (offset %d)", formstroffset); state = FormatText; /* skip one argument */ if (exprlist != NULL_TREE) exprlist = TREE_CHAIN (exprlist); break; case RepFact: if (isDEC (curr)) { dig = curr - '0'; if (repetition > (ULONG_MAX - dig)/10) { warning ("repetition factor overflow (offset %d)", formstroffset); return TextFailEnd; } repetition = repetition*10 + dig; break; } goto test_for_control_codes; case ConvClause: if (isDEC (curr)) { state = ClauseWidth; clausewidth = curr - '0'; break; } if (curr == 'L') { if (leftadjust) warning ("duplicate qualifier (offset %d)", formstroffset); leftadjust = True; break; } if (curr == 'E') { if (overflowev) warning ("duplicate qualifier (offset %d)", formstroffset); overflowev = True; break; } if (curr == 'P') { if (paddingdef) warning ("duplicate qualifier (offset %d)", formstroffset); paddingdef = True; state = CatchPadding; break; } test_for_variable_width: ; if (curr == 'V') { dynamicwid = True; state = AfterWidth; exprlist = check_exprlist (-1, exprlist, firstargnum, 1); firstargnum++; break; } goto test_for_fraction_width; case ClauseWidth: if (isDEC (curr)) { dig = curr - '0'; if (clausewidth > (ULONG_MAX - dig)/10) warning ("clause width overflow (offset %d)", formstroffset); else clausewidth = clausewidth*10 + dig; break; } /* fall through */ test_for_fraction_width: ; case AfterWidth: if (curr == '.') { if (convcode != DefaultConv && convcode != ScientConv) { warning ("no fraction (offset %d)", formstroffset); state = FormatText; break; } fractiondef = True; state = FractWidth; break; } goto test_for_exponent_width; case FractWidth: if (isDEC (curr)) { state = FractWidthCont; fractionwidth = curr - '0'; break; } else warning ("no fraction width (offset %d)", formstroffset); case FractWidthCont: if (isDEC (curr)) { dig = curr - '0'; if (fractionwidth > (ULONG_MAX - dig)/10) warning ("fraction width overflow (offset %d)", formstroffset); else fractionwidth = fractionwidth*10 + dig; break; } test_for_exponent_width: ; if (curr == ':') { if (convcode != ScientConv) { warning ("no exponent (offset %d)", formstroffset); state = FormatText; break; } exponentdef = True; state = ExpoWidth; break; } goto test_for_final_percent; case ExpoWidth: if (isDEC (curr)) { state = ExpoWidthCont; exponentwidth = curr - '0'; break; } else warning ("no exponent width (offset %d)", formstroffset); case ExpoWidthCont: if (isDEC (curr)) { dig = curr - '0'; if (exponentwidth > (ULONG_MAX - dig)/10) warning ("exponent width overflow (offset %d)", formstroffset); else exponentwidth = exponentwidth*10 + dig; break; } /* fall through */ test_for_final_percent: ; case ClauseEnd: if (curr == '%') { state = LastPercent; break; } state = FormatText; break; case CatchPadding: paddingchar = curr; state = ConvClause; break; case EditClause: if (isDEC (curr)) { state = ClauseWidth; clausewidth = curr - '0'; break; } goto test_for_variable_width; case LastPercent: if (curr == '.') { state = FormatText; break; } goto after_first_percent; default: error ("internal error in check_format_string"); } } switch (state) { case FormatText: break; case FirstPercent: case LastPercent: case RepFact: case FractWidth: case ExpoWidth: warning ("bad format specification character (offset %d)", formstroffset); break; case CatchPadding: warning ("no padding character (offset %d)", formstroffset); break; default: break; } *fcsptr = fcs; *lenptr = len; *exprptr = exprlist; *nextargnum = firstargnum; return NormalEnd; } static void check_format_string (format_str, exprlist, firstargnum) tree format_str; tree exprlist; int firstargnum; { char *x; int y, yy; tree z = NULL_TREE; if (TREE_CODE (format_str) != STRING_CST) /* do nothing if we don't have a string constant */ return; formstroffset = -1; scanformcont (TREE_STRING_POINTER (format_str), TREE_STRING_LENGTH (format_str), &x, &y, exprlist, &z, firstargnum, &yy); if (z != NULL_TREE) /* too may arguments for format string */ warning ("too many arguments for this format string"); } static int get_max_size (expr) tree expr; { if (TREE_CODE (expr) == INDIRECT_REF) { tree x = TREE_OPERAND (expr, 0); tree y = TREE_OPERAND (x, 0); return int_size_in_bytes (TREE_TYPE (y)); } else if (TREE_CODE (expr) == CONCAT_EXPR) return intsize_of_charsexpr (expr); else return int_size_in_bytes (TREE_TYPE (expr)); } static int intsize_of_charsexpr (expr) tree expr; { int op0size, op1size; if (TREE_CODE (expr) != CONCAT_EXPR) return -1; /* find maximum length of CONCAT_EXPR, this is the worst case */ op0size = get_max_size (TREE_OPERAND (expr, 0)); op1size = get_max_size (TREE_OPERAND (expr, 1)); if (op0size == -1 || op1size == -1) return -1; return op0size + op1size; } tree build_chill_writetext (text_arg, exprlist) tree text_arg, exprlist; { tree iolist_addr = null_pointer_node; tree iolist_length = integer_zero_node; tree fstr_addr; tree fstr_length; tree outstr_addr; tree outstr_length; tree fstrtype; tree outfunction; tree filename, linenumber; tree format_str = NULL_TREE, indexexpr = NULL_TREE; rtx iolist_rtx = NULL_RTX; int argoffset = 0; /* make some checks */ if (text_arg == NULL_TREE || TREE_CODE (text_arg) == ERROR_MARK) return error_mark_node; if (exprlist != NULL_TREE) { if (TREE_CODE (exprlist) != TREE_LIST) return error_mark_node; } /* check the text argument */ if (chill_varying_string_type_p (TREE_TYPE (text_arg))) { /* build outstr-addr and outstr-length assuming that this is a CHAR (n) VARYING */ outstr_addr = force_addr_of (text_arg); outstr_length = size_in_bytes (CH_VARYING_ARRAY_TYPE (TREE_TYPE (text_arg))); outfunction = lookup_name (get_identifier ("__writetext_s")); format_str = TREE_VALUE (exprlist); exprlist = TREE_CHAIN (exprlist); } else if (CH_IS_TEXT_MODE (TREE_TYPE (text_arg))) { /* we have a text mode */ tree indexmode; if (! check_text (text_arg, 1, "WRITETEXT")) return error_mark_node; indexmode = text_indexmode (TREE_TYPE (text_arg)); if (indexmode == void_type_node) { /* no index */ format_str = TREE_VALUE (exprlist); exprlist = TREE_CHAIN (exprlist); } else { /* we have an index. there must be an index argument before format string */ indexexpr = TREE_VALUE (exprlist); exprlist = TREE_CHAIN (exprlist); if (! CH_COMPATIBLE (indexexpr, indexmode)) { if (chill_varying_string_type_p (TREE_TYPE (indexexpr)) || (CH_CHARS_TYPE_P (TREE_TYPE (indexexpr)) || (flag_old_strings && TREE_CODE (indexexpr) == INTEGER_CST && TREE_CODE (TREE_TYPE (indexexpr)) == CHAR_TYPE))) error ("missing index expression"); else error ("incompatible index mode"); return error_mark_node; } if (exprlist == NULL_TREE) { error ("Too few arguments in call to `writetext'"); return error_mark_node; } format_str = TREE_VALUE (exprlist); exprlist = TREE_CHAIN (exprlist); argoffset = 1; } outstr_addr = force_addr_of (text_arg); outstr_length = convert (integer_type_node, indexexpr); outfunction = lookup_name (get_identifier ("__writetext_f")); } else { error ("argument 1 for WRITETEXT must be a TEXT or CHARS(n) VARYING location"); return error_mark_node; } /* check the format string */ fstrtype = TREE_TYPE (format_str); if (CH_CHARS_TYPE_P (fstrtype) || (flag_old_strings && TREE_CODE (format_str) == INTEGER_CST && TREE_CODE (fstrtype) == CHAR_TYPE)) { /* we have a character string */ fstr_addr = force_addr_of (format_str); fstr_length = size_in_bytes (fstrtype); } else if (chill_varying_string_type_p (TREE_TYPE (format_str))) { /* we have a varying char string */ fstr_addr = force_addr_of (build_component_ref (format_str, var_data_id)); fstr_length = build_component_ref (format_str, var_length_id); } else { error ("`format string' for WRITETEXT must be a CHARACTER string"); return error_mark_node; } empty_printed = False; check_format_string (format_str, exprlist, argoffset + 3); process_io_list (exprlist, &iolist_addr, &iolist_length, &iolist_rtx, 0, argoffset); /* tree to call the function */ filename = force_addr_of (get_chill_filename ()); linenumber = get_chill_linenumber (); expand_expr_stmt ( build_chill_function_call (outfunction, tree_cons (NULL_TREE, outstr_addr, tree_cons (NULL_TREE, outstr_length, tree_cons (NULL_TREE, fstr_addr, tree_cons (NULL_TREE, fstr_length, tree_cons (NULL_TREE, iolist_addr, tree_cons (NULL_TREE, iolist_length, tree_cons (NULL_TREE, filename, tree_cons (NULL_TREE, linenumber, NULL_TREE)))))))))); /* get rid of the iolist variable, if we have one */ if (iolist_rtx != NULL_RTX) { free_temp_slots (); pop_temp_slots (); free_temp_slots (); pop_temp_slots (); } /* return something the rest of the machinery can work with, i.e. (void)0 */ return build1 (CONVERT_EXPR, void_type_node, integer_zero_node); } tree build_chill_readtext (text_arg, exprlist) tree text_arg, exprlist; { tree instr_addr, instr_length, infunction; tree fstr_addr, fstr_length, fstrtype; tree iolist_addr = null_pointer_node; tree iolist_length = integer_zero_node; tree filename, linenumber; tree format_str = NULL_TREE, indexexpr = NULL_TREE; rtx iolist_rtx = NULL_RTX; int argoffset = 0; /* make some checks */ if (text_arg == NULL_TREE || TREE_CODE (text_arg) == ERROR_MARK) return error_mark_node; if (exprlist != NULL_TREE) { if (TREE_CODE (exprlist) != TREE_LIST) return error_mark_node; } /* check the text argument */ if (CH_CHARS_TYPE_P (TREE_TYPE (text_arg))) { instr_addr = force_addr_of (text_arg); instr_length = size_in_bytes (TREE_TYPE (text_arg)); infunction = lookup_name (get_identifier ("__readtext_s")); format_str = TREE_VALUE (exprlist); exprlist = TREE_CHAIN (exprlist); } else if (chill_varying_string_type_p (TREE_TYPE (text_arg))) { instr_addr = force_addr_of (build_component_ref (text_arg, var_data_id)); instr_length = build_component_ref (text_arg, var_length_id); infunction = lookup_name (get_identifier ("__readtext_s")); format_str = TREE_VALUE (exprlist); exprlist = TREE_CHAIN (exprlist); } else if (CH_IS_TEXT_MODE (TREE_TYPE (text_arg))) { /* we have a text mode */ tree indexmode; if (! check_text (text_arg, 1, "READTEXT")) return error_mark_node; indexmode = text_indexmode (TREE_TYPE (text_arg)); if (indexmode == void_type_node) { /* no index */ format_str = TREE_VALUE (exprlist); exprlist = TREE_CHAIN (exprlist); } else { /* we have an index. there must be an index argument before format string */ indexexpr = TREE_VALUE (exprlist); exprlist = TREE_CHAIN (exprlist); if (! CH_COMPATIBLE (indexexpr, indexmode)) { if (chill_varying_string_type_p (TREE_TYPE (indexexpr)) || (CH_CHARS_TYPE_P (TREE_TYPE (indexexpr)) || (flag_old_strings && TREE_CODE (indexexpr) == INTEGER_CST && TREE_CODE (TREE_TYPE (indexexpr)) == CHAR_TYPE))) error ("missing index expression"); else error ("incompatible index mode"); return error_mark_node; } if (exprlist == NULL_TREE) { error ("Too few arguments in call to `readtext'"); return error_mark_node; } format_str = TREE_VALUE (exprlist); exprlist = TREE_CHAIN (exprlist); argoffset = 1; } instr_addr = force_addr_of (text_arg); instr_length = convert (integer_type_node, indexexpr); infunction = lookup_name (get_identifier ("__readtext_f")); } else { error ("argument 1 for READTEXT must be a TEXT location or CHARS(n) [ VARYING ] expression"); return error_mark_node; } /* check the format string */ fstrtype = TREE_TYPE (format_str); if (CH_CHARS_TYPE_P (fstrtype)) { /* we have a character string */ fstr_addr = force_addr_of (format_str); fstr_length = size_in_bytes (fstrtype); } else if (chill_varying_string_type_p (fstrtype)) { /* we have a CHARS(n) VARYING */ fstr_addr = force_addr_of (build_component_ref (format_str, var_data_id)); fstr_length = build_component_ref (format_str, var_length_id); } else { error ("`format string' for READTEXT must be a CHARACTER string"); return error_mark_node; } empty_printed = False; check_format_string (format_str, exprlist, argoffset + 3); process_io_list (exprlist, &iolist_addr, &iolist_length, &iolist_rtx, 1, argoffset); /* build the function call */ filename = force_addr_of (get_chill_filename ()); linenumber = get_chill_linenumber (); expand_expr_stmt ( build_chill_function_call (infunction, tree_cons (NULL_TREE, instr_addr, tree_cons (NULL_TREE, instr_length, tree_cons (NULL_TREE, fstr_addr, tree_cons (NULL_TREE, fstr_length, tree_cons (NULL_TREE, iolist_addr, tree_cons (NULL_TREE, iolist_length, tree_cons (NULL_TREE, filename, tree_cons (NULL_TREE, linenumber, NULL_TREE)))))))))); /* get rid of the iolist variable, if we have one */ if (iolist_rtx != NULL_RTX) { free_temp_slots (); pop_temp_slots (); free_temp_slots (); pop_temp_slots (); } /* return something the rest of the machinery can work with, i.e. (void)0 */ return build1 (CONVERT_EXPR, void_type_node, integer_zero_node); } /* this function build all neccesary enum-tables used for WRITETEXT or READTEXT of an enum */ void build_enum_tables () { SAVE_ENUM_NAMES *names; SAVE_ENUMS *wrk; void *saveptr; /* We temporarily reset the maximum_field_alignment to zero so the compiler's init data structures can be compatible with the run-time system, even when we're compiling with -fpack. */ extern int maximum_field_alignment; int save_maximum_field_alignment; if (pass == 1) return; save_maximum_field_alignment = maximum_field_alignment; maximum_field_alignment = 0; /* output all names */ names = used_enum_names; while (names != (SAVE_ENUM_NAMES *)0) { tree var = get_unique_identifier ("ENUMNAME"); tree type; type = build_string_type (char_type_node, build_int_2 (IDENTIFIER_LENGTH (names->name) + 1, 0)); names->decl = decl_temp1 (var, type, 1, build_chill_string (IDENTIFIER_LENGTH (names->name) + 1, IDENTIFIER_POINTER (names->name)), 0, 0); names = names->forward; } /* output the tables and pointers to tables */ wrk = used_enums; while (wrk != (SAVE_ENUMS *)0) { tree varptr = wrk->ptrdecl; tree table_addr = null_pointer_node; tree init = NULL_TREE, one_entry; tree table, idxlist, tabletype, addr; SAVE_ENUM_VALUES *vals; int i; vals = wrk->vals; for (i = 0; i < wrk->num_vals; i++) { tree decl = vals->name->decl; addr = build1 (ADDR_EXPR, build_pointer_type (char_type_node), decl); TREE_CONSTANT (addr) = 1; one_entry = tree_cons (NULL_TREE, build_int_2 (vals->val, 0), tree_cons (NULL_TREE, addr, NULL_TREE)); one_entry = build_nt (CONSTRUCTOR, NULL_TREE, one_entry); init = tree_cons (NULL_TREE, one_entry, init); vals++; } /* add the terminator (name = null_pointer_node) to constructor */ one_entry = tree_cons (NULL_TREE, integer_zero_node, tree_cons (NULL_TREE, null_pointer_node, NULL_TREE)); one_entry = build_nt (CONSTRUCTOR, NULL_TREE, one_entry); init = tree_cons (NULL_TREE, one_entry, init); init = nreverse (init); init = build_nt (CONSTRUCTOR, NULL_TREE, init); TREE_CONSTANT (init) = 1; /* generate table */ idxlist = build_tree_list (NULL_TREE, build_chill_range_type (NULL_TREE, integer_zero_node, build_int_2 (wrk->num_vals, 0))); tabletype = build_chill_array_type (TREE_TYPE (enum_table_type), idxlist, 0, NULL_TREE); table = decl_temp1 (get_unique_identifier ("ENUMTAB"), tabletype, 1, init, 0, 0); table_addr = build1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (enum_table_type)), table); TREE_CONSTANT (table_addr) = 1; /* generate pointer to table */ decl_temp1 (DECL_NAME (varptr), TREE_TYPE (table_addr), 1, table_addr, 0, 0); /* free that stuff */ saveptr = wrk->forward; free (wrk->vals); free (wrk); /* next enum */ wrk = saveptr; } /* free all the names */ names = used_enum_names; while (names != (SAVE_ENUM_NAMES *)0) { saveptr = names->forward; free (names); names = saveptr; } used_enums = (SAVE_ENUMS *)0; used_enum_names = (SAVE_ENUM_NAMES *)0; maximum_field_alignment = save_maximum_field_alignment; }