diff options
Diffstat (limited to 'contrib/gcc/f/expr.c')
| -rw-r--r-- | contrib/gcc/f/expr.c | 189 |
1 files changed, 155 insertions, 34 deletions
diff --git a/contrib/gcc/f/expr.c b/contrib/gcc/f/expr.c index 7e7bf867..67b3765 100644 --- a/contrib/gcc/f/expr.c +++ b/contrib/gcc/f/expr.c @@ -1,6 +1,6 @@ /* expr.c -- Implementation File (module.c template V1.0) Copyright (C) 1995-1998 Free Software Foundation, Inc. - Contributed by James Craig Burley (burley@gnu.org). + Contributed by James Craig Burley. This file is part of GNU Fortran. @@ -268,7 +268,7 @@ static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar); static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s); static ffeexprExpr_ ffeexpr_expr_new_ (void); static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t); -static bool ffeexpr_isdigits_ (char *p); +static bool ffeexpr_isdigits_ (const char *p); static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t); static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t); static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t); @@ -633,6 +633,10 @@ ffeexpr_collapse_convert (ffebld expr, ffelexToken t) break; } + /* If conversion operation is not implemented, return original expr. */ + if (error == FFEBAD_NOCANDO) + return expr; + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val (ffebld_cu_val_integer1 (u)), expr); @@ -822,6 +826,10 @@ ffeexpr_collapse_convert (ffebld expr, ffelexToken t) break; } + /* If conversion operation is not implemented, return original expr. */ + if (error == FFEBAD_NOCANDO) + return expr; + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val (ffebld_cu_val_integer2 (u)), expr); @@ -1011,6 +1019,10 @@ ffeexpr_collapse_convert (ffebld expr, ffelexToken t) break; } + /* If conversion operation is not implemented, return original expr. */ + if (error == FFEBAD_NOCANDO) + return expr; + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val (ffebld_cu_val_integer3 (u)), expr); @@ -1200,6 +1212,10 @@ ffeexpr_collapse_convert (ffebld expr, ffelexToken t) break; } + /* If conversion operation is not implemented, return original expr. */ + if (error == FFEBAD_NOCANDO) + return expr; + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val (ffebld_cu_val_integer4 (u)), expr); @@ -1317,6 +1333,10 @@ ffeexpr_collapse_convert (ffebld expr, ffelexToken t) break; } + /* If conversion operation is not implemented, return original expr. */ + if (error == FFEBAD_NOCANDO) + return expr; + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val (ffebld_cu_val_logical1 (u)), expr); @@ -1424,6 +1444,10 @@ ffeexpr_collapse_convert (ffebld expr, ffelexToken t) break; } + /* If conversion operation is not implemented, return original expr. */ + if (error == FFEBAD_NOCANDO) + return expr; + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val (ffebld_cu_val_logical2 (u)), expr); @@ -1531,6 +1555,10 @@ ffeexpr_collapse_convert (ffebld expr, ffelexToken t) break; } + /* If conversion operation is not implemented, return original expr. */ + if (error == FFEBAD_NOCANDO) + return expr; + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val (ffebld_cu_val_logical3 (u)), expr); @@ -1638,6 +1666,10 @@ ffeexpr_collapse_convert (ffebld expr, ffelexToken t) break; } + /* If conversion operation is not implemented, return original expr. */ + if (error == FFEBAD_NOCANDO) + return expr; + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val (ffebld_cu_val_logical4 (u)), expr); @@ -1796,6 +1828,10 @@ ffeexpr_collapse_convert (ffebld expr, ffelexToken t) break; } + /* If conversion operation is not implemented, return original expr. */ + if (error == FFEBAD_NOCANDO) + return expr; + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val (ffebld_cu_val_real1 (u)), expr); @@ -1944,6 +1980,10 @@ ffeexpr_collapse_convert (ffebld expr, ffelexToken t) break; } + /* If conversion operation is not implemented, return original expr. */ + if (error == FFEBAD_NOCANDO) + return expr; + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val (ffebld_cu_val_real2 (u)), expr); @@ -2092,6 +2132,10 @@ ffeexpr_collapse_convert (ffebld expr, ffelexToken t) break; } + /* If conversion operation is not implemented, return original expr. */ + if (error == FFEBAD_NOCANDO) + return expr; + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val (ffebld_cu_val_real3 (u)), expr); @@ -2240,6 +2284,10 @@ ffeexpr_collapse_convert (ffebld expr, ffelexToken t) break; } + /* If conversion operation is not implemented, return original expr. */ + if (error == FFEBAD_NOCANDO) + return expr; + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val (ffebld_cu_val_real4 (u)), expr); @@ -2398,6 +2446,10 @@ ffeexpr_collapse_convert (ffebld expr, ffelexToken t) break; } + /* If conversion operation is not implemented, return original expr. */ + if (error == FFEBAD_NOCANDO) + return expr; + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val (ffebld_cu_val_complex1 (u)), expr); @@ -2546,6 +2598,10 @@ ffeexpr_collapse_convert (ffebld expr, ffelexToken t) break; } + /* If conversion operation is not implemented, return original expr. */ + if (error == FFEBAD_NOCANDO) + return expr; + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val (ffebld_cu_val_complex2 (u)), expr); @@ -2694,6 +2750,10 @@ ffeexpr_collapse_convert (ffebld expr, ffelexToken t) break; } + /* If conversion operation is not implemented, return original expr. */ + if (error == FFEBAD_NOCANDO) + return expr; + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val (ffebld_cu_val_complex3 (u)), expr); @@ -2842,6 +2902,10 @@ ffeexpr_collapse_convert (ffebld expr, ffelexToken t) break; } + /* If conversion operation is not implemented, return original expr. */ + if (error == FFEBAD_NOCANDO) + return expr; + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val (ffebld_cu_val_complex4 (u)), expr); @@ -8520,7 +8584,7 @@ ffeexpr_context_outer_ (ffeexprStack_ s) static ffeexprPercent_ ffeexpr_percent_ (ffelexToken t) { - char *p; + const char *p; switch (ffelex_token_length (t)) { @@ -9473,7 +9537,7 @@ ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t) /* Check whether rest of string is all decimal digits. */ static bool -ffeexpr_isdigits_ (char *p) +ffeexpr_isdigits_ (const char *p) { for (; *p != '\0'; ++p) if (! ISDIGIT (*p)) @@ -10314,7 +10378,7 @@ ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, if ((lkd != FFEINFO_kindANY) && ffebad_start (FFEBAD_CONCAT_ARG_KIND)) { - char *what; + const char *what; if (lrk != 0) what = "an array"; @@ -10330,7 +10394,7 @@ ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, { if (ffebad_start (FFEBAD_CONCAT_ARG_KIND)) { - char *what; + const char *what; if (rrk != 0) what = "an array"; @@ -11602,7 +11666,7 @@ static ffelexHandler ffeexpr_nil_real_ (ffelexToken t) { char d; - char *p; + const char *p; if (((ffelex_token_type (t) != FFELEX_typeNAME) && (ffelex_token_type (t) != FFELEX_typeNAMES)) @@ -11640,7 +11704,7 @@ static ffelexHandler ffeexpr_nil_number_ (ffelexToken t) { char d; - char *p; + const char *p; if (ffeexpr_hollerith_count_ > 0) ffelex_set_expecting_hollerith (0, '\0', @@ -11715,7 +11779,7 @@ ffeexpr_nil_number_period_ (ffelexToken t) { ffelexHandler nexthandler; char d; - char *p; + const char *p; switch (ffelex_token_type (t)) { @@ -11772,7 +11836,7 @@ static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t) { char d; - char *p; + const char *p; if (((ffelex_token_type (t) != FFELEX_typeNAME) && (ffelex_token_type (t) != FFELEX_typeNAMES)) @@ -12203,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 @@ -12226,7 +12289,6 @@ again: /* :::::::::::::::::::: */ break; } /* Fall through. */ - case FFEINFO_basictypeINTEGER: case FFEINFO_basictypeHOLLERITH: case FFEINFO_basictypeTYPELESS: error = FALSE; @@ -12235,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; @@ -12242,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; @@ -12616,11 +12721,12 @@ again: /* :::::::::::::::::::: */ switch (ffeinfo_basictype (info)) { case FFEINFO_basictypeLOGICAL: - error = error && !ffe_is_ugly_logint (); - if (!ffeexpr_stack_->is_rhs) - break; /* Don't convert lhs variable. */ + if (! ffe_is_ugly_logint ()) + error = TRUE; + if (! ffeexpr_stack_->is_rhs) + break; expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - ffeinfo_kindtype (ffebld_info (expr)), 0, + ffeinfo_kindtype (info), 0, FFETARGET_charactersizeNONE, FFEEXPR_contextLET); break; @@ -12664,18 +12770,21 @@ again: /* :::::::::::::::::::: */ switch (ffeinfo_basictype (info)) { case FFEINFO_basictypeLOGICAL: - error = error - && (ffeinfo_kindtype (info) != FFEINFO_kindtypeLOGICALDEFAULT); - if (!ffeexpr_stack_->is_rhs) - break; /* Don't convert lhs variable. */ + if (! ffeexpr_stack_->is_rhs) + break; expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, - FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + ffeinfo_kindtype (info), 0, + FFETARGET_charactersizeNONE, FFEEXPR_contextLET); - break; - + /* Fall through. */ case FFEINFO_basictypeINTEGER: - error = error && - (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT); + if (ffeexpr_stack_->is_rhs + && (ffeinfo_kindtype (ffebld_info (expr)) + != FFEINFO_kindtypeINTEGERDEFAULT)) + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); break; case FFEINFO_basictypeHOLLERITH: @@ -12853,7 +12962,11 @@ again: /* :::::::::::::::::::: */ : ffeinfo_basictype (info)) { case FFEINFO_basictypeINTEGER: - error = FALSE; + /* Maybe this should be supported someday, but, right now, + g77 can't generate a call to libf2c to write to an + integer other than the default size. */ + error = ((! ffeexpr_stack_->is_rhs) + && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT); break; default: @@ -13584,7 +13697,7 @@ static ffelexHandler ffeexpr_token_real_ (ffelexToken t) { char d; - char *p; + const char *p; if (((ffelex_token_type (t) != FFELEX_typeNAME) && (ffelex_token_type (t) != FFELEX_typeNAMES)) @@ -13741,7 +13854,7 @@ ffeexpr_token_number_ (ffelexToken t) ffeexprExpr_ e; ffeinfo ni; char d; - char *p; + const char *p; if (ffeexpr_hollerith_count_ > 0) ffelex_set_expecting_hollerith (0, '\0', @@ -13897,7 +14010,7 @@ ffeexpr_token_number_period_ (ffelexToken t) { ffeexprExpr_ e; ffelexHandler nexthandler; - char *p; + const char *p; char d; switch (ffelex_token_type (t)) @@ -14015,7 +14128,7 @@ static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t) { char d; - char *p; + const char *p; if (((ffelex_token_type (t) != FFELEX_typeNAME) && (ffelex_token_type (t) != FFELEX_typeNAMES)) @@ -18530,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)); @@ -18841,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; |
