/* expr.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995-1998 Free Software Foundation, Inc.
+ Copyright (C) 1995, 1996, 1997, 1998, 2001, 2002, 2003
+ Free Software Foundation, Inc.
Contributed by James Craig Burley.
This file is part of GNU Fortran.
#include "str.h"
#include "target.h"
#include "where.h"
+#include "real.h"
/* Externals defined here. */
static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
ffeexprExpr_ op, ffeexprExpr_ r);
static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
- ffeexprExpr_ op, ffeexprExpr_ r);
+ ffeexprExpr_ op, ffeexprExpr_ r,
+ bool *);
static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
ffelexHandler after);
static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_integer1_real4
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("INTEGER1/REAL bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_integer1_complex4
- (ffebld_cu_ptr_integer1 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_integer2_real4
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("INTEGER2/REAL bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_integer2_complex4
- (ffebld_cu_ptr_integer2 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_integer3_real4
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("INTEGER3/REAL bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_integer3_complex4
- (ffebld_cu_ptr_integer3 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_integer4_real4
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("INTEGER4/REAL bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_integer4_complex4
- (ffebld_cu_ptr_integer4 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_real1_real4
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("REAL1/REAL bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_real1_complex4
- (ffebld_cu_ptr_real1 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("REAL1/COMPLEX bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_real2_real4
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("REAL2/REAL bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_real2_complex4
- (ffebld_cu_ptr_real2 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("REAL2/COMPLEX bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_real3_real4
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("REAL3/REAL bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_real3_complex4
- (ffebld_cu_ptr_real3 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("REAL3/COMPLEX bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_real4_integer1
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_real4_integer2
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_real4_integer3
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_real4_integer4
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL4/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_real4_real1
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_real4_real2
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_real4_real3
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL4/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_real4_complex1
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_real4_complex2
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_real4_complex3
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_real4_complex4
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("REAL4/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_real4_character1
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_real4_hollerith
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_real4_typeless
- (ffebld_cu_ptr_real4 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("REAL4 bad type" == NULL);
- 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);
- break;
-#endif
-
default:
assert ("bad real kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_complex1_real4
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("COMPLEX1/REAL bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_complex1_complex4
- (ffebld_cu_ptr_complex1 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_complex2_real4
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("COMPLEX2/REAL bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_complex2_complex4
- (ffebld_cu_ptr_complex2 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_complex3_real4
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("COMPLEX3/REAL bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_complex3_complex4
- (ffebld_cu_ptr_complex3 (u),
- ffebld_constant_complex4 (ffebld_conter (l)));
- break;
-#endif
-
default:
assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- switch (ffeinfo_basictype (ffebld_info (l)))
- {
- case FFEINFO_basictypeINTEGER:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- error = ffetarget_convert_complex4_integer1
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_integer1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- error = ffetarget_convert_complex4_integer2
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_integer2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- error = ffetarget_convert_complex4_integer3
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_integer3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- error = ffetarget_convert_complex4_integer4
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_integer4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX4/INTEGER bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_complex4_real1
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_real1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_complex4_real2
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_real2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_complex4_real3
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_real3 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_convert_complex4_real4
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_real4 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX4/REAL bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (ffeinfo_kindtype (ffebld_info (l)))
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- error = ffetarget_convert_complex4_complex1
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_complex1 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- error = ffetarget_convert_complex4_complex2
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_complex2 (ffebld_conter (l)));
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_convert_complex4_complex3
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_complex3 (ffebld_conter (l)));
- break;
-#endif
-
- default:
- assert ("COMPLEX4/COMPLEX bad source kind type" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- error = ffetarget_convert_complex4_character1
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_character1 (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeHOLLERITH:
- error = ffetarget_convert_complex4_hollerith
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_hollerith (ffebld_conter (l)));
- break;
-
- case FFEINFO_basictypeTYPELESS:
- error = ffetarget_convert_complex4_typeless
- (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_typeless (ffebld_conter (l)));
- break;
-
- default:
- assert ("COMPLEX4 bad type" == NULL);
- 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);
- break;
-#endif
-
default:
assert ("bad complex kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_uminus_real4 (ffebld_cu_ptr_real4 (u),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
- (ffebld_cu_val_real4 (u)), expr);
- break;
-#endif
-
default:
assert ("bad real kind type" == NULL);
break;
case FFEINFO_kindtypeREAL3:
error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
ffebld_constant_complex3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
- (ffebld_cu_val_complex3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_uminus_complex4 (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_complex4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
- (ffebld_cu_val_complex4 (u)), expr);
+ expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
+ (ffebld_cu_val_complex3 (u)), expr);
break;
#endif
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_add_real4 (ffebld_cu_ptr_real4 (u),
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
- (ffebld_cu_val_real4 (u)), expr);
- break;
-#endif
-
default:
assert ("bad real kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_add_complex4 (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_complex4 (ffebld_conter (l)),
- ffebld_constant_complex4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
- (ffebld_cu_val_complex4 (u)), expr);
- break;
-#endif
-
default:
assert ("bad complex kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_subtract_real4 (ffebld_cu_ptr_real4 (u),
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
- (ffebld_cu_val_real4 (u)), expr);
- break;
-#endif
-
default:
assert ("bad real kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_subtract_complex4 (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_complex4 (ffebld_conter (l)),
- ffebld_constant_complex4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
- (ffebld_cu_val_complex4 (u)), expr);
- break;
-#endif
-
default:
assert ("bad complex kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_multiply_real4 (ffebld_cu_ptr_real4 (u),
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
- (ffebld_cu_val_real4 (u)), expr);
- break;
-#endif
-
default:
assert ("bad real kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_multiply_complex4 (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_complex4 (ffebld_conter (l)),
- ffebld_constant_complex4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
- (ffebld_cu_val_complex4 (u)), expr);
- break;
-#endif
-
default:
assert ("bad complex kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_divide_real4 (ffebld_cu_ptr_real4 (u),
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
- (ffebld_cu_val_real4 (u)), expr);
- break;
-#endif
-
default:
assert ("bad real kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_divide_complex4 (ffebld_cu_ptr_complex4 (u),
- ffebld_constant_complex4 (ffebld_conter (l)),
- ffebld_constant_complex4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
- (ffebld_cu_val_complex4 (u)), expr);
- break;
-#endif
-
default:
assert ("bad complex kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCHARACTER2
- case FFEINFO_kindtypeCHARACTER2:
- error = ffetarget_concatenate_character2 (ffebld_cu_ptr_character2 (u),
- ffebld_constant_character2 (ffebld_conter (l)),
- ffebld_constant_character2 (ffebld_conter (r)),
- ffebld_constant_pool (), &len);
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
- (ffebld_cu_val_character2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEINFO_kindtypeCHARACTER3:
- error = ffetarget_concatenate_character3 (ffebld_cu_ptr_character3 (u),
- ffebld_constant_character3 (ffebld_conter (l)),
- ffebld_constant_character3 (ffebld_conter (r)),
- ffebld_constant_pool (), &len);
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
- (ffebld_cu_val_character3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEINFO_kindtypeCHARACTER4:
- error = ffetarget_concatenate_character4 (ffebld_cu_ptr_character4 (u),
- ffebld_constant_character4 (ffebld_conter (l)),
- ffebld_constant_character4 (ffebld_conter (r)),
- ffebld_constant_pool (), &len);
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
- (ffebld_cu_val_character4 (u)), expr);
- break;
-#endif
-
default:
assert ("bad character kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_eq_real4 (&val,
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
default:
assert ("bad real kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_eq_complex4 (&val,
- ffebld_constant_complex4 (ffebld_conter (l)),
- ffebld_constant_complex4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
default:
assert ("bad complex kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCHARACTER2
- case FFEINFO_kindtypeCHARACTER2:
- error = ffetarget_eq_character2 (&val,
- ffebld_constant_character2 (ffebld_conter (l)),
- ffebld_constant_character2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEINFO_kindtypeCHARACTER3:
- error = ffetarget_eq_character3 (&val,
- ffebld_constant_character3 (ffebld_conter (l)),
- ffebld_constant_character3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEINFO_kindtypeCHARACTER4:
- error = ffetarget_eq_character4 (&val,
- ffebld_constant_character4 (ffebld_conter (l)),
- ffebld_constant_character4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
default:
assert ("bad character kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_ne_real4 (&val,
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
default:
assert ("bad real kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_ne_complex4 (&val,
- ffebld_constant_complex4 (ffebld_conter (l)),
- ffebld_constant_complex4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
default:
assert ("bad complex kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCHARACTER2
- case FFEINFO_kindtypeCHARACTER2:
- error = ffetarget_ne_character2 (&val,
- ffebld_constant_character2 (ffebld_conter (l)),
- ffebld_constant_character2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEINFO_kindtypeCHARACTER3:
- error = ffetarget_ne_character3 (&val,
- ffebld_constant_character3 (ffebld_conter (l)),
- ffebld_constant_character3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEINFO_kindtypeCHARACTER4:
- error = ffetarget_ne_character4 (&val,
- ffebld_constant_character4 (ffebld_conter (l)),
- ffebld_constant_character4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
default:
assert ("bad character kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_ge_real4 (&val,
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
default:
assert ("bad real kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCHARACTER2
- case FFEINFO_kindtypeCHARACTER2:
- error = ffetarget_ge_character2 (&val,
- ffebld_constant_character2 (ffebld_conter (l)),
- ffebld_constant_character2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEINFO_kindtypeCHARACTER3:
- error = ffetarget_ge_character3 (&val,
- ffebld_constant_character3 (ffebld_conter (l)),
- ffebld_constant_character3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEINFO_kindtypeCHARACTER4:
- error = ffetarget_ge_character4 (&val,
- ffebld_constant_character4 (ffebld_conter (l)),
- ffebld_constant_character4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
default:
assert ("bad character kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_gt_real4 (&val,
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
default:
assert ("bad real kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCHARACTER2
- case FFEINFO_kindtypeCHARACTER2:
- error = ffetarget_gt_character2 (&val,
- ffebld_constant_character2 (ffebld_conter (l)),
- ffebld_constant_character2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEINFO_kindtypeCHARACTER3:
- error = ffetarget_gt_character3 (&val,
- ffebld_constant_character3 (ffebld_conter (l)),
- ffebld_constant_character3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEINFO_kindtypeCHARACTER4:
- error = ffetarget_gt_character4 (&val,
- ffebld_constant_character4 (ffebld_conter (l)),
- ffebld_constant_character4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
default:
assert ("bad character kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_le_real4 (&val,
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
default:
assert ("bad real kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCHARACTER2
- case FFEINFO_kindtypeCHARACTER2:
- error = ffetarget_le_character2 (&val,
- ffebld_constant_character2 (ffebld_conter (l)),
- ffebld_constant_character2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEINFO_kindtypeCHARACTER3:
- error = ffetarget_le_character3 (&val,
- ffebld_constant_character3 (ffebld_conter (l)),
- ffebld_constant_character3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEINFO_kindtypeCHARACTER4:
- error = ffetarget_le_character4 (&val,
- ffebld_constant_character4 (ffebld_conter (l)),
- ffebld_constant_character4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
default:
assert ("bad character kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- error = ffetarget_lt_real4 (&val,
- ffebld_constant_real4 (ffebld_conter (l)),
- ffebld_constant_real4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
default:
assert ("bad real kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCHARACTER2
- case FFEINFO_kindtypeCHARACTER2:
- error = ffetarget_lt_character2 (&val,
- ffebld_constant_character2 (ffebld_conter (l)),
- ffebld_constant_character2 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEINFO_kindtypeCHARACTER3:
- error = ffetarget_lt_character3 (&val,
- ffebld_constant_character3 (ffebld_conter (l)),
- ffebld_constant_character3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEINFO_kindtypeCHARACTER4:
- error = ffetarget_lt_character4 (&val,
- ffebld_constant_character4 (ffebld_conter (l)),
- ffebld_constant_character4 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- break;
-#endif
-
default:
assert ("bad character kind type" == NULL);
break;
break;
#endif
-#if FFETARGET_okCHARACTER2
- case FFEINFO_kindtypeCHARACTER2:
- error = ffetarget_substr_character2 (ffebld_cu_ptr_character2 (u),
- ffebld_constant_character2 (ffebld_conter (l)), first, last,
- ffebld_constant_pool (), &len);
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
- (ffebld_cu_val_character2 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEINFO_kindtypeCHARACTER3:
- error = ffetarget_substr_character3 (ffebld_cu_ptr_character3 (u),
- ffebld_constant_character3 (ffebld_conter (l)), first, last,
- ffebld_constant_pool (), &len);
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
- (ffebld_cu_val_character3 (u)), expr);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEINFO_kindtypeCHARACTER4:
- error = ffetarget_substr_character4 (ffebld_cu_ptr_character4 (u),
- ffebld_constant_character4 (ffebld_conter (l)), first, last,
- ffebld_constant_pool (), &len);
- expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
- (ffebld_cu_val_character4 (u)), expr);
- break;
-#endif
-
default:
assert ("bad character kind type" == NULL);
break;
/* Initializes the module. */
void
-ffeexpr_init_2 ()
+ffeexpr_init_2 (void)
{
ffeexpr_stack_ = NULL;
ffeexpr_level_ = 0;
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- e->u.operand = ffebld_new_conter (ffebld_constant_new_complex4
- (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
- FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
- break;
-#endif
-
default:
if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
#endif
#if FFETARGET_okCOMPLEX3
case FFEINFO_kindtypeREAL3:
-#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
#endif
break; /* Fine and dandy. */
Allocates and initializes a new expression object, returns it. */
static ffeexprExpr_
-ffeexpr_expr_new_ ()
+ffeexpr_expr_new_ (void)
{
ffeexprExpr_ e;
- e = (ffeexprExpr_) malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr",
- sizeof (*e));
+ e = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr", sizeof (*e));
e->previous = NULL;
e->type = FFEEXPR_exprtypeUNKNOWN_;
e->token = NULL;
ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
{
ffeexpr_exprstack_push_ (e);
-#ifdef WEIRD_NONFORTRAN_RULES
- if ((ffeexpr_stack_->exprstack != NULL)
- && (ffeexpr_stack_->exprstack->expr->type == FFEEXPR_exprtypeBINARY_)
- && (ffeexpr_stack_->exprstack->expr->u.operator.prec
- == FFEEXPR_operatorprecedenceHIGHEST_)
- && (ffeexpr_stack_->exprstack->expr->u.operator.as
- == FFEEXPR_operatorassociativityL2R_))
- ffeexpr_reduce_ ();
-#endif
}
/* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
<= FFEEXPR_operatorprecedenceLOWARITH_)
&& (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
{
+ /* xgettext:no-c-format */
ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
ffe_is_pedantic ()
? FFEBAD_severityPEDANTIC
&& (e->u.operator.prec
< ffeexpr_stack_->exprstack->previous->u.operator.prec))
{
+ /* xgettext:no-c-format */
ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
ffebad_here (0,
ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
requisite type-assignment. */
static void
-ffeexpr_reduce_ ()
+ffeexpr_reduce_ (void)
{
ffeexprExpr_ operand; /* This is B in -B or A+B. */
ffeexprExpr_ left_operand; /* When operator is binary, this is A in A+B. */
ffebld expr;
ffebld left_expr;
bool submag = FALSE;
+ bool bothlogical;
operand = ffeexpr_stack_->exprstack;
assert (operand != NULL);
reduced = ffebld_new_and (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
- operand);
+ operand, &bothlogical);
reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_and (reduced, operator->token);
+ if (ffe_is_ugly_logint() && bothlogical)
+ reduced = ffeexpr_convert (reduced, left_operand->token,
+ operator->token,
+ FFEINFO_basictypeLOGICAL,
+ FFEINFO_kindtypeLOGICALDEFAULT, 0,
+ FFETARGET_charactersizeNONE,
+ FFEEXPR_contextLET);
break;
case FFEEXPR_operatorOR_:
reduced = ffebld_new_or (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
- operand);
+ operand, &bothlogical);
reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_or (reduced, operator->token);
+ if (ffe_is_ugly_logint() && bothlogical)
+ reduced = ffeexpr_convert (reduced, left_operand->token,
+ operator->token,
+ FFEINFO_basictypeLOGICAL,
+ FFEINFO_kindtypeLOGICALDEFAULT, 0,
+ FFETARGET_charactersizeNONE,
+ FFEEXPR_contextLET);
break;
case FFEEXPR_operatorXOR_:
reduced = ffebld_new_xor (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
- operand);
+ operand, &bothlogical);
reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_xor (reduced, operator->token);
+ if (ffe_is_ugly_logint() && bothlogical)
+ reduced = ffeexpr_convert (reduced, left_operand->token,
+ operator->token,
+ FFEINFO_basictypeLOGICAL,
+ FFEINFO_kindtypeLOGICALDEFAULT, 0,
+ FFETARGET_charactersizeNONE,
+ FFEEXPR_contextLET);
break;
case FFEEXPR_operatorEQV_:
reduced = ffebld_new_eqv (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
- operand);
+ operand, NULL);
reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_eqv (reduced, operator->token);
reduced = ffebld_new_neqv (left_expr, expr);
if (ffe_is_ugly_logint ())
reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
- operand);
+ operand, NULL);
reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
operand);
reduced = ffeexpr_collapse_neqv (reduced, operator->token);
if ((lbt == FFEINFO_basictypeLOGICAL)
&& (rbt == FFEINFO_basictypeLOGICAL))
{
+ /* xgettext:no-c-format */
if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
FFEBAD_severityFATAL))
{
}
if (rkt == FFEINFO_kindtypeINTEGER4)
{
+ /* xgettext:no-c-format */
ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
FFEBAD_severityWARNING);
ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
static ffebld
ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
- ffeexprExpr_ r)
+ ffeexprExpr_ r, bool *bothlogical)
{
ffeinfo linfo, rinfo;
ffeinfoBasictype lbt, rbt;
/* else Leave it alone. */
}
+ if (lbt == FFEINFO_basictypeLOGICAL)
+ {
+ ffebld_set_left (reduced,
+ ffeexpr_convert (ffebld_left (reduced),
+ l->token, op->token,
+ FFEINFO_basictypeINTEGER,
+ FFEINFO_kindtypeINTEGERDEFAULT, 0,
+ FFETARGET_charactersizeNONE,
+ FFEEXPR_contextLET));
+ }
+
+ if (rbt == FFEINFO_basictypeLOGICAL)
+ {
+ ffebld_set_right (reduced,
+ ffeexpr_convert (ffebld_right (reduced),
+ r->token, op->token,
+ FFEINFO_basictypeINTEGER,
+ FFEINFO_kindtypeINTEGERDEFAULT, 0,
+ FFETARGET_charactersizeNONE,
+ FFEEXPR_contextLET));
+ }
+
+ if (bothlogical != NULL)
+ *bothlogical = (lbt == FFEINFO_basictypeLOGICAL
+ && rbt == FFEINFO_basictypeLOGICAL);
+
return reduced;
}
case FFEEXPR_contextINDEX_:
case FFEEXPR_contextSFUNCDEFINDEX_:
- case FFEEXPR_contextRETURN:
if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
break;
switch ((expr == NULL) ? FFEINFO_basictypeNONE
break;
}
/* Fall through. */
- case FFEINFO_basictypeINTEGER:
case FFEINFO_basictypeHOLLERITH:
case FFEINFO_basictypeTYPELESS:
error = FALSE;
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;
+ 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;
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;
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:
error = (expr == NULL)
|| ((ffeinfo_rank (info) != 0) ?
ffe_is_pedantic () /* F77 C5. */
- : (ffeinfo_kindtype (info) != ffecom_label_kind ()))
+ : (bool) (ffeinfo_kindtype (info) != ffecom_label_kind ()))
|| (ffebld_op (expr) != FFEBLD_opSYMTER);
break;
FFETARGET_charactersizeNONE));
ffesymbol_signal_unreported (s);
- if (((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
+ if ((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
&& (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
- || ((ffesymbol_kindtype (sp) != FFEINFO_kindtypeINTEGERDEFAULT)
- && (ffesymbol_kindtype (sp) != FFEINFO_kindtypeANY)))
ffesymbol_error (s, t);
return s;
| FFESYMBOL_attrsINIT
| FFESYMBOL_attrsNAMELIST
| FFESYMBOL_attrsSFARG
+ | FFESYMBOL_attrsARRAY
| FFESYMBOL_attrsTYPE)))
na = sa | FFESYMBOL_attrsADJUSTS;
else
case FFEEXPR_contextDIMLIST:
s = ffeexpr_sym_rhs_dimlist_ (s, t);
+ bad = FALSE;
break;
case FFEEXPR_contextCHARACTERSIZE:
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));
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;
/* Terminate module. */
void
-ffeexpr_terminate_2 ()
+ffeexpr_terminate_2 (void)
{
assert (ffeexpr_stack_ == NULL);
assert (ffeexpr_level_ == 0);
projects / thirdparty / gcc.git / blobdiff