24e511ca8e
2002-01-11 Craig Rodrigues <rodrigc@gcc.gnu.org>
PR other/5299
* decl.c (layout_enum): Fix spelling mistake of "than".
* inout.c (check_text_length): Same.
From-SVN: r48779
4692 lines
135 KiB
C
4692 lines
135 KiB
C
/* 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;
|
||
}
|