diff options
Diffstat (limited to 'gcc/ch/inout.c')
| -rw-r--r-- | gcc/ch/inout.c | 4691 |
1 files changed, 0 insertions, 4691 deletions
diff --git a/gcc/ch/inout.c b/gcc/ch/inout.c deleted file mode 100644 index 6049ff4..0000000 --- a/gcc/ch/inout.c +++ /dev/null @@ -1,4691 +0,0 @@ -/* Implement I/O-related actions for CHILL. - Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000 - 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 PARAMS ((tree)); -static tree add_enum_to_list PARAMS ((tree, tree)); -static void build_chill_io_list_type PARAMS ((void)); -static void build_io_types PARAMS ((void)); -static void declare_predefined_file PARAMS ((const char *, const char *)); -static tree build_access_part PARAMS ((void)); -static tree textlocation_mode PARAMS ((tree)); -static int check_assoc PARAMS ((tree, int, const char *)); -static tree assoc_call PARAMS ((tree, tree, const char *)); -static int check_transfer PARAMS ((tree, int, const char *)); -static int connect_process_optionals PARAMS ((tree, tree *, tree *, tree)); -static tree connect_text PARAMS ((tree, tree, tree, tree)); -static tree connect_access PARAMS ((tree, tree, tree, tree)); -static int check_access PARAMS ((tree, int, const char *)); -static int check_text PARAMS ((tree, int, const char *)); -static tree get_final_type_and_range PARAMS ((tree, tree *, tree *)); -static void process_io_list PARAMS ((tree, tree *, tree *, rtx *, - int, int)); -static void check_format_string PARAMS ((tree, tree, int)); -static int get_max_size PARAMS ((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 */ - tree var = DECL_NAME (wrk->ptrdecl); - 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) - const char *name; - const 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. */ - unsigned 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, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "connect" : "CONNECT", - chill_predefined_function_type, - BUILT_IN_CONNECT, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "create" : "CREATE", - chill_predefined_function_type, - BUILT_IN_CREATE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "delete" : "DELETE", - chill_predefined_function_type, - BUILT_IN_CH_DELETE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "disconnect" : "DISCONNECT", - chill_predefined_function_type, - BUILT_IN_DISCONNECT, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "dissociate" : "DISSOCIATE", - chill_predefined_function_type, - BUILT_IN_DISSOCIATE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "eoln" : "EOLN", - chill_predefined_function_type, - BUILT_IN_EOLN, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "existing" : "EXISTING", - chill_predefined_function_type, - BUILT_IN_EXISTING, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "getassociation" : "GETASSOCIATION", - chill_predefined_function_type, - BUILT_IN_GETASSOCIATION, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "gettextaccess" : "GETTEXTASSCESS", - chill_predefined_function_type, - BUILT_IN_GETTEXTACCESS, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "gettextindex" : "GETTEXTINDEX", - chill_predefined_function_type, - BUILT_IN_GETTEXTINDEX, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "gettextrecord" : "GETTEXTRECORD", - chill_predefined_function_type, - BUILT_IN_GETTEXTRECORD, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "getusage" : "GETUSAGE", - chill_predefined_function_type, - BUILT_IN_GETUSAGE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "indexable" : "INDEXABLE", - chill_predefined_function_type, - BUILT_IN_INDEXABLE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "isassociated" : "ISASSOCIATED", - chill_predefined_function_type, - BUILT_IN_ISASSOCIATED, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "modify" : "MODIFY", - chill_predefined_function_type, - BUILT_IN_MODIFY, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "outoffile" : "OUTOFFILE", - chill_predefined_function_type, - BUILT_IN_OUTOFFILE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "readable" : "READABLE", - chill_predefined_function_type, - BUILT_IN_READABLE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "readrecord" : "READRECORD", - chill_predefined_function_type, - BUILT_IN_READRECORD, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "readtext" : "READTEXT", - chill_predefined_function_type, - BUILT_IN_READTEXT, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "sequencible" : "SEQUENCIBLE", - chill_predefined_function_type, - BUILT_IN_SEQUENCIBLE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "settextaccess" : "SETTEXTACCESS", - chill_predefined_function_type, - BUILT_IN_SETTEXTACCESS, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "settextindex" : "SETTEXTINDEX", - chill_predefined_function_type, - BUILT_IN_SETTEXTINDEX, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "settextrecord" : "SETTEXTRECORD", - chill_predefined_function_type, - BUILT_IN_SETTEXTRECORD, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "variable" : "VARIABLE", - chill_predefined_function_type, - BUILT_IN_VARIABLE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "writeable" : "WRITEABLE", - chill_predefined_function_type, - BUILT_IN_WRITEABLE, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "writerecord" : "WRITERECORD", - chill_predefined_function_type, - BUILT_IN_WRITERECORD, BUILT_IN_NORMAL, NULL_PTR); - builtin_function ((ignore_case || ! special_UC) ? "writetext" : "WRITETEXT", - chill_predefined_function_type, - BUILT_IN_WRITETEXT, BUILT_IN_NORMAL, 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, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__connect", void_ftype_ptr_ptr_int_int_int_long_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__create", void_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__delete", void_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__disconnect", void_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__dissociate", void_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__eoln", bool_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__existing", bool_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__getassociation", ptr_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__gettextaccess", ptr_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__gettextindex", luns_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__gettextrecord", ptr_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__getusage", int_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__indexable", bool_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__isassociated", bool_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__modify", void_ftype_ptr_ptr_int_ptr_int_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__outoffile", bool_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__readable", bool_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__readrecord", ptr_ftype_ptr_int_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__readtext_f", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__readtext_s", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__sequencible", bool_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__settextaccess", void_ftype_ptr_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__settextindex", void_ftype_ptr_int_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__settextrecord", void_ftype_ptr_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__variable", bool_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__writeable", bool_ftype_ptr_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__writerecord", void_ftype_ptr_int_ptr_luns_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__writetext_f", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int, - 0, NOT_BUILT_IN, NULL_PTR); - builtin_function ("__writetext_s", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int, - 0, 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; -} - -/* - 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 -*/ - -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; -} - -/* - 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 -*/ -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 than 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; - const 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; - const 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; - const 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; - const 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; - const 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; - unsigned 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); - const char *fieldname = 0; - const 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; - -static tree check_exprlist PARAMS ((convcode_t, tree, int, - unsigned long)); - -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; - -static formatexit_t scanformcont PARAMS ((char *, int, char **, int *, - tree, tree *, int, int *)); - -/* 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 necessary 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. */ - unsigned 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; -} |