From: Craig Burley Date: Sat, 15 May 1999 15:46:16 +0000 (+0000) Subject: fix INTEGER*8 subscripts, add -fflatten-arrays X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=ff852b44545f35144c7f30d9f1216df05cb39b55;p=gcc.git fix INTEGER*8 subscripts, add -fflatten-arrays From-SVN: r26948 --- diff --git a/gcc/f/ChangeLog b/gcc/f/ChangeLog index 265a565ddc4..21c9a360866 100644 --- a/gcc/f/ChangeLog +++ b/gcc/f/ChangeLog @@ -1,3 +1,31 @@ +Thu May 13 12:23:20 1999 Craig Burley + + 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 * com.c (lang_init_options): Disable back end's maintenance diff --git a/gcc/f/com.c b/gcc/f/com.c index 5af35225d2d..a3e0eb1b3a0 100644 --- a/gcc/f/com.c +++ b/gcc/f/com.c @@ -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: diff --git a/gcc/f/expr.c b/gcc/f/expr.c index 83838c7dda0..67b3765bd2a 100644 --- a/gcc/f/expr.c +++ b/gcc/f/expr.c @@ -12267,7 +12267,6 @@ again: /* :::::::::::::::::::: */ case FFEEXPR_contextINDEX_: case FFEEXPR_contextSFUNCDEFINDEX_: - case FFEEXPR_contextRETURN: if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) break; switch ((expr == NULL) ? FFEINFO_basictypeNONE @@ -12290,7 +12289,6 @@ again: /* :::::::::::::::::::: */ break; } /* Fall through. */ - case FFEINFO_basictypeINTEGER: case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: error = FALSE; @@ -12299,6 +12297,11 @@ again: /* :::::::::::::::::::: */ 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; @@ -12306,6 +12309,44 @@ again: /* :::::::::::::::::::: */ break; /* expr==NULL ok for substring; element case caught by callback. */ + case FFEEXPR_contextRETURN: + 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_basictypeINTEGER: + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + error = FALSE; + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + default: + error = TRUE; + break; + } + break; + case FFEEXPR_contextDO: if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) break; @@ -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; diff --git a/gcc/f/g77.texi b/gcc/f/g77.texi index 36aa3eccf5a..25070dbd5f8 100644 --- a/gcc/f/g77.texi +++ b/gcc/f/g77.texi @@ -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 diff --git a/gcc/f/lang-options.h b/gcc/f/lang-options.h index 4e98a309b0c..417159cd4b4 100644 --- a/gcc/f/lang-options.h +++ b/gcc/f/lang-options.h @@ -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", "" ) diff --git a/gcc/f/news.texi b/gcc/f/news.texi index 9b293181db5..0a4b8e4e137 100644 --- a/gcc/f/news.texi +++ b/gcc/f/news.texi @@ -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 diff --git a/gcc/f/top.c b/gcc/f/top.c index 8603f011ea0..0d6fb35e214 100644 --- a/gcc/f/top.c +++ b/gcc/f/top.c @@ -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) diff --git a/gcc/f/top.h b/gcc/f/top.h index c03e1d65400..c5deea8a700 100644 --- a/gcc/f/top.h +++ b/gcc/f/top.h @@ -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)) diff --git a/gcc/f/version.c b/gcc/f/version.c index 95242141ceb..6705384221d 100644 --- a/gcc/f/version.c +++ b/gcc/f/version.c @@ -1 +1 @@ -const char *ffe_version_string = "0.5.24-19990503"; +const char *ffe_version_string = "0.5.24-19990513";