MatCat.OpenSource/8sa1-gcc
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fix INTEGER*8 subscripts, add -fflatten-arrays

Browse Source 
From-SVN: r26948
This commit is contained in:
Craig Burley 1999-05-15 15:46:16 +00:00 committed by Craig Burley
parent 1907bb7c74
commit ff852b4454
9 changed files with 248 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
gcc/f/ChangeLog
View File

@ -1,3 +1,31 @@
Thu May 13 12:23:20 1999 Craig Burley <craig@jcb-sc.com>
Fix INTEGER*8 subscripts in array references:
* com.c (ffecom_subscript_check_): Convert low, high, and
element as necessary to make comparison work.
(ffecom_arrayref_): Do more of the work.
Properly handle subscript expr that's wider than int,
if pointers are wider than int.
(ffecom_expr_): Leave more work to ffecom_arrayref_.
(ffecom_init_0): Record sizes of pointers and ints for
convenience.
Use set_sizetype etc. as done by gcc front end.
(ffecom_ptr_to_expr): Leave more work to ffecom_arrayref_.
* expr.c (ffeexpr_finished_): Don't convert INTEGER subscript
expressions in run-time contexts.
(ffeexpr_token_elements_, ffeexpr_token_substring_1_): Cope with
non-default INTEGER subscript expressions.
* news.texi: Announce.
Finish accepting -fflatten-arrays option:
* com.c (ffecom_arrayref_): Flatten references if requested.
* g77.texi: Describe.
* lang-options.h: Allow.
* news.texi: Announce.
* top.c, top.h: Recognize.
* version.c: Bump version.
Wed May 12 07:30:05 1999 Craig Burley <craig@jcb-sc.com>
* com.c (lang_init_options): Disable back end's maintenance

178
gcc/f/com.c
View File

@ -556,6 +556,8 @@ static tree
static bool ffecom_member_namelisted_; /* _member_phase1_ namelisted? */
static bool ffecom_doing_entry_ = FALSE;
static bool ffecom_transform_only_dummies_ = FALSE;
static int ffecom_typesize_pointer_;
static int ffecom_typesize_integer1_;
/* Holds pointer-to-function expressions. */
@ -628,8 +630,9 @@ static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
it would be best to do something here to figure out automatically
from other information what type to use. */
/* NOTE: g77 currently doesn't use these; see setting of sizetype and
change that if you need to. -- jcb 09/01/91. */
#ifndef SIZE_TYPE
#define SIZE_TYPE "long unsigned int"
#endif
#define ffecom_concat_list_count_(catlist) ((catlist).count)
#define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
@ -766,6 +769,19 @@ ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
if (element == error_mark_node)
return element;
if (TREE_TYPE (low) != TREE_TYPE (element))
{
if (TYPE_PRECISION (TREE_TYPE (low))
> TYPE_PRECISION (TREE_TYPE (element)))
element = convert (TREE_TYPE (low), element);
else
{
low = convert (TREE_TYPE (element), low);
if (high)
high = convert (TREE_TYPE (element), high);
}
}
element = ffecom_save_tree (element);
cond = ffecom_2 (LE_EXPR, integer_type_node,
low,
@ -889,10 +905,10 @@ ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
/* Return the computed element of an array reference.
`item' is the array or a pointer to the array. It must be a pointer
to the array if ffe_is_flat_arrays ().
`expr' is the original opARRAYREF expression.
`want_ptr' is non-zero if `item' is a pointer to the element, instead of
`item' is NULL_TREE, or the transformed pointer to the array.
`expr' is the original opARRAYREF expression, which is transformed
if `item' is NULL_TREE.
`want_ptr' is non-zero if a pointer to the element, instead of
the element itself, is to be returned. */
static tree
@ -901,11 +917,15 @@ ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
ffebld dims[FFECOM_dimensionsMAX];
int i;
int total_dims;
int flatten = 0 /* ~~~ ffe_is_flat_arrays () */;
int need_ptr = want_ptr || flatten;
int flatten = ffe_is_flatten_arrays ();
int need_ptr;
tree array;
tree element;
tree tree_type;
tree tree_type_x;
char *array_name;
ffetype type;
ffebld list;
if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
@ -915,33 +935,84 @@ ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
/* Build up ARRAY_REFs in reverse order (since we're column major
here in Fortran land). */
for (i = 0, expr = ffebld_right (expr);
expr != NULL;
expr = ffebld_trail (expr))
dims[i++] = ffebld_head (expr);
for (i = 0, list = ffebld_right (expr);
list != NULL;
++i, list = ffebld_trail (list))
{
dims[i] = ffebld_head (list);
type = ffeinfo_type (ffebld_basictype (dims[i]),
ffebld_kindtype (dims[i]));
if (! flatten
&& ffecom_typesize_pointer_ > ffecom_typesize_integer1_
&& ffetype_size (type) > ffecom_typesize_integer1_)
/* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
pointers and 32-bit integers. Do the full 64-bit pointer
arithmetic, for codes using arrays for nonstandard heap-like
work. */
flatten = 1;
}
total_dims = i;
need_ptr = want_ptr || flatten;
if (! item)
{
if (need_ptr)
item = ffecom_ptr_to_expr (ffebld_left (expr));
else
item = ffecom_expr (ffebld_left (expr));
if (item == error_mark_node)
return item;
if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
&& ! mark_addressable (item))
return error_mark_node;
}
if (item == error_mark_node)
return item;
if (need_ptr)
{
tree min;
for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
i >= 0;
--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
{
element = ffecom_expr (dims[i]);
min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
if (ffe_is_subscript_check ())
element = ffecom_subscript_check_ (array, element, i, total_dims,
array_name);
if (element == error_mark_node)
return element;
/* Widen integral arithmetic as desired while preserving
signedness. */
tree_type = TREE_TYPE (element);
tree_type_x = tree_type;
if (tree_type
&& GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
&& TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
if (TREE_TYPE (min) != tree_type_x)
min = convert (tree_type_x, min);
if (TREE_TYPE (element) != tree_type_x)
element = convert (tree_type_x, element);
item = ffecom_2 (PLUS_EXPR,
build_pointer_type (TREE_TYPE (array)),
item,
size_binop (MULT_EXPR,
size_in_bytes (TREE_TYPE (array)),
convert (sizetype,
fold (build (MINUS_EXPR,
TREE_TYPE (TYPE_MIN_VALUE (TYPE_DOMAIN (array))),
element,
TYPE_MIN_VALUE (TYPE_DOMAIN (array)))))));
fold (build (MINUS_EXPR,
tree_type_x,
element,
min))));
}
if (! want_ptr)
{
@ -962,6 +1033,20 @@ ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
if (ffe_is_subscript_check ())
element = ffecom_subscript_check_ (array, element, i, total_dims,
array_name);
if (element == error_mark_node)
return element;
/* Widen integral arithmetic as desired while preserving
signedness. */
tree_type = TREE_TYPE (element);
tree_type_x = tree_type;
if (tree_type
&& GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
&& TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
element = convert (tree_type_x, element);
item = ffecom_2 (ARRAY_REF,
TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
item,
@ -2064,6 +2149,8 @@ ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
/* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
if (start == NULL)
{
if (end == NULL)
@ -3245,24 +3332,7 @@ ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
return t;
case FFEBLD_opARRAYREF:
{
if (0 /* ~~~~~ ffe_is_flat_arrays () */)
t = ffecom_ptr_to_expr (ffebld_left (expr));
else
t = ffecom_expr (ffebld_left (expr));
if (t == error_mark_node)
return t;
if ((ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING)
&& !mark_addressable (t))
return error_mark_node; /* Make sure non-const ref is to
non-reg. */
t = ffecom_arrayref_ (t, expr, 0);
return t;
}
return ffecom_arrayref_ (NULL_TREE, expr, 0);
case FFEBLD_opUPLUS:
left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
@ -11608,12 +11678,6 @@ ffecom_init_0 ()
}
}
/* Set the sizetype before we do anything else. This _should_ be the
first type we create. */
t = make_unsigned_type (POINTER_SIZE);
assert (t == sizetype);
#if FFECOM_GCC_INCLUDE
ffecom_initialize_char_syntax_ ();
#endif
@ -11658,9 +11722,6 @@ ffecom_init_0 ()
pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
long_long_unsigned_type_node));
error_mark_node = make_node (ERROR_MARK);
TREE_TYPE (error_mark_node) = error_mark_node;
short_integer_type_node = make_signed_type (SHORT_TYPE_SIZE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
short_integer_type_node));
@ -11669,6 +11730,17 @@ ffecom_init_0 ()
pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
short_unsigned_type_node));
/* Set the sizetype before we make other types. This *should* be the
first type we create. */
set_sizetype
(TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
ffecom_typesize_pointer_
= TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
error_mark_node = make_node (ERROR_MARK);
TREE_TYPE (error_mark_node) = error_mark_node;
/* Define both `signed char' and `unsigned char'. */
signed_char_type_node = make_signed_type (CHAR_TYPE_SIZE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
@ -11787,6 +11859,7 @@ ffecom_init_0 ()
TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
type);
ffetype_set_kind (base_type, 1, type);
ffecom_typesize_integer1_ = ffetype_size (type);
assert (ffetype_size (type) == sizeof (ffetargetInteger1));
ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
@ -12798,20 +12871,7 @@ ffecom_ptr_to_expr (ffebld expr)
return item;
case FFEBLD_opARRAYREF:
{
item = ffecom_ptr_to_expr (ffebld_left (expr));
if (item == error_mark_node)
return item;
if ((ffebld_where (expr) == FFEINFO_whereFLEETING)
&& !mark_addressable (item))
return error_mark_node; /* Make sure non-const ref is to
non-reg. */
item = ffecom_arrayref_ (item, expr, 1);
}
return item;
return ffecom_arrayref_ (NULL_TREE, expr, 1);
case FFEBLD_opCONTER:

61
gcc/f/expr.c
View File

@ -12267,6 +12267,48 @@ again: /* :::::::::::::::::::: */
case FFEEXPR_contextINDEX_:
case FFEEXPR_contextSFUNCDEFINDEX_:
if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
break;
switch ((expr == NULL) ? FFEINFO_basictypeNONE
: ffeinfo_basictype (info))
{
case FFEINFO_basictypeNONE:
error = FALSE;
break;
case FFEINFO_basictypeLOGICAL:
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
/* Fall through. */
case FFEINFO_basictypeREAL:
case FFEINFO_basictypeCOMPLEX:
if (ffe_is_pedantic ())
{
error = TRUE;
break;
}
/* Fall through. */
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
error = FALSE;
expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
break;
case FFEINFO_basictypeINTEGER:
/* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
unmolested. Leave it to downstream to handle kinds. */
break;
default:
error = TRUE;
break;
}
break; /* expr==NULL ok for substring; element case
caught by callback. */
case FFEEXPR_contextRETURN:
if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
break;
@ -12303,8 +12345,7 @@ again: /* :::::::::::::::::::: */
error = TRUE;
break;
}
break; /* expr==NULL ok for substring; element case
caught by callback. */
break;
case FFEEXPR_contextDO:
if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
@ -18602,7 +18643,8 @@ ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
ffeexpr_stack_->immediate = FALSE;
break;
}
if (ffebld_op (expr) == FFEBLD_opCONTER)
if (ffebld_op (expr) == FFEBLD_opCONTER
&& ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT)
{
val = ffebld_constant_integerdefault (ffebld_conter (expr));
@ -18913,26 +18955,33 @@ ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
ffetargetIntegerDefault last_val;
ffetargetCharacterSize size;
ffetargetCharacterSize strop_size_max;
bool first_known;
string = ffeexpr_stack_->exprstack;
strop = string->u.operand;
info = ffebld_info (strop);
if ((first == NULL) || (ffebld_op (first) == FFEBLD_opCONTER))
if (first == NULL
|| (ffebld_op (first) == FFEBLD_opCONTER
&& ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT))
{ /* The starting point is known. */
first_val = (first == NULL) ? 1
: ffebld_constant_integerdefault (ffebld_conter (first));
first_known = TRUE;
}
else
{ /* Assume start of the entity. */
first_val = 1;
first_known = FALSE;
}
if ((last != NULL) && (ffebld_op (last) == FFEBLD_opCONTER))
if (last != NULL
&& (ffebld_op (last) == FFEBLD_opCONTER
&& ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT))
{ /* The ending point is known. */
last_val = ffebld_constant_integerdefault (ffebld_conter (last));
if ((first == NULL) || (ffebld_op (first) == FFEBLD_opCONTER))
if (first_known)
{ /* The beginning point is a constant. */
if (first_val <= last_val)
size = last_val - first_val + 1;

18
gcc/f/g77.texi
View File

@ -2,7 +2,7 @@
@c %**start of header
@setfilename g77.info
@set last-update 1999-05-10
@set last-update 1999-05-13
@set copyrights-g77 1995-1999
@include root.texi
@ -1470,7 +1470,7 @@ by type. Explanations are in the following sections.
-fdebug-kludge -femulate-complex
-falias-check -fargument-alias
-fargument-noalias -fno-argument-noalias-global
-fno-globals
-fno-globals -fflatten-arrays
-fsubscript-check -ff2c-subscript-check
@end smallexample
@end table
@ -3372,6 +3372,20 @@ that are currently believed to not
likely to result in the compiler later crashing
or producing incorrect code.
@cindex -fflatten-arrays option
@item -fflatten-arrays
@cindex array performance
@cindex arrays, flattening
Use back end's C-like constructs
(pointer plus offset)
instead of its @code{ARRAY_REF} construct
to handle all array references.
@emph{Note:} This option is not supported.
It is intended for use only by @code{g77} developers,
to evaluate code-generation issues.
It might be removed at any time.
@cindex -fsubscript-check option
@cindex -ff2c-subscript-check option
@item -fsubscript-check

2
gcc/f/lang-options.h
View File

@ -51,6 +51,8 @@ FTNOPT( "-ff2c", "" )
FTNOPT( "-fno-f2c", "f2c-compatible code need not be generated" )
FTNOPT( "-ff2c-library", "" )
FTNOPT( "-fno-f2c-library", "Unsupported; do not generate libf2c-calling code" )
FTNOPT( "-fflatten-arrays", "Unsupported; affects code-generation of arrays" )
FTNOPT( "-fno-flatten-arrays", "" )
FTNOPT( "-ffree-form", "Program is written in Fortran-90-ish free form" )
FTNOPT( "-fno-free-form", "" )
FTNOPT( "-ffixed-form", "" )

20
gcc/f/news.texi
View File

@ -9,7 +9,7 @@
@c in the standalone derivations of this file (e.g. NEWS).
@set copyrights-news 1995-1999
@set last-update-news 1999-05-12
@set last-update-news 1999-05-13
@include root.texi
@ -164,6 +164,15 @@ to type @code{INTEGER(KIND=2)}
For example, @samp{INTEGER*8 J; J = 4E10} now works as documented.
@end ifclear
@ifclear USERVISONLY
@item
@code{g77} no longer truncates @code{INTEGER(KIND=2)}
(usually @code{INTEGER*8})
subscript expressions when evaluating array references
on systems with pointers widers than @code{INTEGER(KIND=1)}
(such as Alphas).
@end ifclear
@ifclear USERVISONLY
@item
@code{g77} no longer generates bad code
@ -278,6 +287,15 @@ and not @code{SAVE}'d.
a C-language concept,
when performing operations such as the @code{SqRt} intrinsic.
@ifclear USERVISONLY
@item
@code{g77} developers can temporarily use
the @samp{-fflatten-arrays} option
to compare how the compiler handles code generation
using C-like constructs as compared to the
Fortran-like method constructs normally used.
@end ifclear
@ifclear USERVISONLY
@item
A substantial portion of the @code{g77} front end's code-generation component

5
gcc/f/top.c
View File

@ -74,6 +74,7 @@ bool ffe_is_dollar_ok_ = FFETARGET_defaultIS_DOLLAR_OK;
bool ffe_is_f2c_ = FFETARGET_defaultIS_F2C;
bool ffe_is_f2c_library_ = FFETARGET_defaultIS_F2C_LIBRARY;
bool ffe_is_ffedebug_ = FALSE;
bool ffe_is_flatten_arrays_ = FALSE;
bool ffe_is_free_form_ = FFETARGET_defaultIS_FREE_FORM;
bool ffe_is_globals_ = TRUE;
bool ffe_is_init_local_zero_ = FFETARGET_defaultIS_INIT_LOCAL_ZERO;
@ -216,6 +217,10 @@ ffe_decode_option (argc, argv)
ffe_set_is_f2c_library (TRUE);
else if (strcmp (&opt[2], "no-f2c-library") == 0)
ffe_set_is_f2c_library (FALSE);
else if (strcmp (&opt[2], "flatten-arrays") == 0)
ffe_set_is_flatten_arrays (TRUE);
else if (strcmp (&opt[2], "no-flatten-arrays") == 0)
ffe_set_is_flatten_arrays (FALSE);
else if (strcmp (&opt[2], "free-form") == 0)
ffe_set_is_free_form (TRUE);
else if (strcmp (&opt[2], "no-free-form") == 0)

3
gcc/f/top.h
View File

@ -90,6 +90,7 @@ extern bool ffe_is_dollar_ok_;
extern bool ffe_is_f2c_;
extern bool ffe_is_f2c_library_;
extern bool ffe_is_ffedebug_;
extern bool ffe_is_flatten_arrays_;
extern bool ffe_is_free_form_;
extern bool ffe_is_globals_;
extern bool ffe_is_init_local_zero_;
@ -178,6 +179,7 @@ void ffe_terminate_4 (void);
#define ffe_is_f2c() ffe_is_f2c_
#define ffe_is_f2c_library() ffe_is_f2c_library_
#define ffe_is_ffedebug() ffe_is_ffedebug_
#define ffe_is_flatten_arrays() ffe_is_flatten_arrays_
#define ffe_is_free_form() ffe_is_free_form_
#define ffe_is_globals() ffe_is_globals_
#define ffe_is_init_local_zero() ffe_is_init_local_zero_
@ -230,6 +232,7 @@ void ffe_terminate_4 (void);
#define ffe_set_is_f2c(f) (ffe_is_f2c_ = (f))
#define ffe_set_is_f2c_library(f) (ffe_is_f2c_library_ = (f))
#define ffe_set_is_ffedebug(f) (ffe_is_ffedebug_ = (f))
#define ffe_set_is_flatten_arrays(f) (ffe_is_flatten_arrays_ = (f))
#define ffe_set_is_free_form(f) (ffe_is_free_form_ = (f))
#define ffe_set_is_globals(f) (ffe_is_globals_ = (f))
#define ffe_set_is_init_local_zero(f) (ffe_is_init_local_zero_ = (f))

2
gcc/f/version.c
View File

@ -1 +1 @@
const char *ffe_version_string = "0.5.24-19990503";
const char *ffe_version_string = "0.5.24-19990513";