/* expr.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995-1997 Free Software Foundation, Inc.
- Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
+ 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 files. */
#include "proj.h"
-#include <ctype.h>
#include "expr.h"
#include "bad.h"
#include "bld.h"
#include "src.h"
#include "st.h"
#include "symbol.h"
+#include "str.h"
#include "target.h"
#include "where.h"
+#include "real.h"
/* Externals defined here. */
/* Simple definitions and enumerations. */
-typedef enum
- {
- FFEEXPR_dotdotNONE_,
- FFEEXPR_dotdotTRUE_,
- FFEEXPR_dotdotFALSE_,
- FFEEXPR_dotdotNOT_,
- FFEEXPR_dotdotAND_,
- FFEEXPR_dotdotOR_,
- FFEEXPR_dotdotXOR_,
- FFEEXPR_dotdotEQV_,
- FFEEXPR_dotdotNEQV_,
- FFEEXPR_dotdotLT_,
- FFEEXPR_dotdotLE_,
- FFEEXPR_dotdotEQ_,
- FFEEXPR_dotdotNE_,
- FFEEXPR_dotdotGT_,
- FFEEXPR_dotdotGE_,
- FFEEXPR_dotdot
- } ffeexprDotdot_;
-
typedef enum
{
FFEEXPR_exprtypeUNKNOWN_,
static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */
static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */
-static ffeexprDotdot_ ffeexpr_current_dotdot_; /* Current .FOO. keyword. */
+static ffestrOther ffeexpr_current_dotdot_; /* Current .FOO. keyword. */
static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */
static int ffeexpr_level_; /* Level of DATA implied-DO construct. */
static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */
static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
-static ffeexprDotdot_ ffeexpr_dotdot_ (ffelexToken t);
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);
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;
}
+ /* 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);
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;
}
+ /* 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);
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;
}
+ /* 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);
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;
}
+ /* 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);
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);
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);
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);
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);
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;
}
+ /* 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);
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;
}
+ /* 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);
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;
}
+ /* 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);
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;
- }
-
- 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;
}
+ /* 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);
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;
}
+ /* 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);
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;
}
+ /* 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);
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;
- }
-
- 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;
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);
- break;
-#endif
-
default:
assert ("bad complex kind type" == NULL);
break;
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;
#endif
#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- error = ffetarget_gt_real3 (&val,
- ffebld_constant_real3 (ffebld_conter (l)),
- ffebld_constant_real3 (ffebld_conter (r)));
- expr = ffebld_new_conter_with_orig
- (ffebld_constant_new_logicaldefault (val), expr);
- 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)));
+ case FFEINFO_kindtypeREAL3:
+ error = ffetarget_gt_real3 (&val,
+ ffebld_constant_real3 (ffebld_conter (l)),
+ ffebld_constant_real3 (ffebld_conter (r)));
expr = ffebld_new_conter_with_orig
(ffebld_constant_new_logicaldefault (val), expr);
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))
}
}
-/* ffeexpr_dotdot_ -- Look up name in list of .FOO. possibilities
-
- ffeexprDotdot_ d;
- ffelexToken t;
- d = ffeexpr_dotdot_(t);
-
- Returns the identifier for the name, or the NONE identifier. */
-
-static ffeexprDotdot_
-ffeexpr_dotdot_ (ffelexToken t)
-{
- char *p;
-
- switch (ffelex_token_length (t))
- {
- case 2:
- switch (*(p = ffelex_token_text (t)))
- {
- case FFESRC_CASE_MATCH_INIT ('E', 'e', match_2e, no_match_2):
- if (ffesrc_char_match_noninit (*++p, 'Q', 'q'))
- return FFEEXPR_dotdotEQ_;
- return FFEEXPR_dotdotNONE_;
-
- case FFESRC_CASE_MATCH_INIT ('G', 'g', match_2g, no_match_2):
- if (ffesrc_char_match_noninit (*++p, 'E', 'e'))
- return FFEEXPR_dotdotGE_;
- if (ffesrc_char_match_noninit (*p, 'T', 't'))
- return FFEEXPR_dotdotGT_;
- return FFEEXPR_dotdotNONE_;
-
- case FFESRC_CASE_MATCH_INIT ('L', 'l', match_2l, no_match_2):
- if (ffesrc_char_match_noninit (*++p, 'E', 'e'))
- return FFEEXPR_dotdotLE_;
- if (ffesrc_char_match_noninit (*p, 'T', 't'))
- return FFEEXPR_dotdotLT_;
- return FFEEXPR_dotdotNONE_;
-
- case FFESRC_CASE_MATCH_INIT ('N', 'n', match_2n, no_match_2):
- if (ffesrc_char_match_noninit (*++p, 'E', 'e'))
- return FFEEXPR_dotdotNE_;
- return FFEEXPR_dotdotNONE_;
-
- case FFESRC_CASE_MATCH_INIT ('O', 'o', match_2o, no_match_2):
- if (ffesrc_char_match_noninit (*++p, 'R', 'r'))
- return FFEEXPR_dotdotOR_;
- return FFEEXPR_dotdotNONE_;
-
- default:
- no_match_2: /* :::::::::::::::::::: */
- return FFEEXPR_dotdotNONE_;
- }
-
- case 3:
- switch (*(p = ffelex_token_text (t)))
- {
- case FFESRC_CASE_MATCH_INIT ('A', 'a', match_3a, no_match_3):
- if ((ffesrc_char_match_noninit (*++p, 'N', 'n'))
- && (ffesrc_char_match_noninit (*++p, 'D', 'd')))
- return FFEEXPR_dotdotAND_;
- return FFEEXPR_dotdotNONE_;
-
- case FFESRC_CASE_MATCH_INIT ('E', 'e', match_3e, no_match_3):
- if ((ffesrc_char_match_noninit (*++p, 'Q', 'q'))
- && (ffesrc_char_match_noninit (*++p, 'V', 'v')))
- return FFEEXPR_dotdotEQV_;
- return FFEEXPR_dotdotNONE_;
-
- case FFESRC_CASE_MATCH_INIT ('N', 'n', match_3n, no_match_3):
- if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
- && (ffesrc_char_match_noninit (*++p, 'T', 't')))
- return FFEEXPR_dotdotNOT_;
- return FFEEXPR_dotdotNONE_;
-
- case FFESRC_CASE_MATCH_INIT ('X', 'x', match_3x, no_match_3):
- if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
- && (ffesrc_char_match_noninit (*++p, 'R', 'r')))
- return FFEEXPR_dotdotXOR_;
- return FFEEXPR_dotdotNONE_;
-
- default:
- no_match_3: /* :::::::::::::::::::: */
- return FFEEXPR_dotdotNONE_;
- }
-
- case 4:
- switch (*(p = ffelex_token_text (t)))
- {
- case FFESRC_CASE_MATCH_INIT ('N', 'n', match_4n, no_match_4):
- if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
- && (ffesrc_char_match_noninit (*++p, 'Q', 'q'))
- && (ffesrc_char_match_noninit (*++p, 'V', 'v')))
- return FFEEXPR_dotdotNEQV_;
- return FFEEXPR_dotdotNONE_;
-
- case FFESRC_CASE_MATCH_INIT ('T', 't', match_4t, no_match_4):
- if ((ffesrc_char_match_noninit (*++p, 'R', 'r'))
- && (ffesrc_char_match_noninit (*++p, 'U', 'u'))
- && (ffesrc_char_match_noninit (*++p, 'E', 'e')))
- return FFEEXPR_dotdotTRUE_;
- return FFEEXPR_dotdotNONE_;
-
- default:
- no_match_4: /* :::::::::::::::::::: */
- return FFEEXPR_dotdotNONE_;
- }
-
- case 5:
- if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "FALSE",
- "false", "False")
- == 0)
- return FFEEXPR_dotdotFALSE_;
- return FFEEXPR_dotdotNONE_;
-
- default:
- return FFEEXPR_dotdotNONE_;
- }
-}
-
/* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
ffeexprPercent_ p;
static ffeexprPercent_
ffeexpr_percent_ (ffelexToken t)
{
- char *p;
+ const char *p;
switch (ffelex_token_length (t))
{
#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;
as = FFEGLOBAL_argsummaryALTRTN;
break;
+#if 0
+ /* No, %LOC(foo) is just like any INTEGER(KIND=7)
+ expression, so don't treat it specially. */
case FFEBLD_opPERCENT_LOC:
as = FFEGLOBAL_argsummaryPTR;
break;
+#endif
case FFEBLD_opPERCENT_VAL:
as = FFEGLOBAL_argsummaryVAL;
break;
case FFEBLD_opFUNCREF:
+#if 0
+ /* No, LOC(foo) is just like any INTEGER(KIND=7)
+ expression, so don't treat it specially. */
if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER)
&& (ffesymbol_specific (ffebld_symter (ffebld_left (item)))
== FFEINTRIN_specLOC))
as = FFEGLOBAL_argsummaryPTR;
break;
}
+#endif
/* Fall through. */
default:
if (ffebld_op (item) == FFEBLD_opSYMTER)
/* 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))
+ if (! ISDIGIT (*p))
return FALSE;
return TRUE;
}
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 ((lkd != FFEINFO_kindANY)
&& ffebad_start (FFEBAD_CONCAT_ARG_KIND))
{
- char *what;
+ const char *what;
if (lrk != 0)
what = "an array";
{
if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
{
- char *what;
+ const char *what;
if (rrk != 0)
what = "an array";
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 FFELEX_typeNAME:
case FFELEX_typeNAMES:
- ffeexpr_current_dotdot_ = ffeexpr_dotdot_ (t);
+ ffeexpr_current_dotdot_ = ffestr_other (t);
switch (ffeexpr_current_dotdot_)
{
- case FFEEXPR_dotdotNONE_:
+ case FFESTR_otherNone:
return (ffelexHandler) ffeexpr_nil_rhs_ (t);
- case FFEEXPR_dotdotTRUE_:
- case FFEEXPR_dotdotFALSE_:
- case FFEEXPR_dotdotNOT_:
+ case FFESTR_otherTRUE:
+ case FFESTR_otherFALSE:
+ case FFESTR_otherNOT:
return (ffelexHandler) ffeexpr_nil_end_period_;
default:
{
switch (ffeexpr_current_dotdot_)
{
- case FFEEXPR_dotdotNOT_:
+ case FFESTR_otherNOT:
if (ffelex_token_type (t) != FFELEX_typePERIOD)
return (ffelexHandler) ffeexpr_nil_rhs_ (t);
return (ffelexHandler) ffeexpr_nil_rhs_;
- case FFEEXPR_dotdotTRUE_:
- case FFEEXPR_dotdotFALSE_:
+ case FFESTR_otherTRUE:
+ case FFESTR_otherFALSE:
if (ffelex_token_type (t) != FFELEX_typePERIOD)
return (ffelexHandler) ffeexpr_nil_binary_ (t);
return (ffelexHandler) ffeexpr_nil_binary_;
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))
ffeexpr_nil_number_ (ffelexToken t)
{
char d;
- char *p;
+ const char *p;
if (ffeexpr_hollerith_count_ > 0)
ffelex_set_expecting_hollerith (0, '\0',
{
ffelexHandler nexthandler;
char d;
- char *p;
+ const char *p;
switch (ffelex_token_type (t))
{
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))
{
case FFELEX_typeNAME:
case FFELEX_typeNAMES:
- ffeexpr_current_dotdot_ = ffeexpr_dotdot_ (t);
+ ffeexpr_current_dotdot_ = ffestr_other (t);
switch (ffeexpr_current_dotdot_)
{
- case FFEEXPR_dotdotTRUE_:
- case FFEEXPR_dotdotFALSE_:
- case FFEEXPR_dotdotNOT_:
+ case FFESTR_otherTRUE:
+ case FFESTR_otherFALSE:
+ case FFESTR_otherNOT:
return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
default:
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:
: 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:
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;
{
case FFELEX_typeNAME:
case FFELEX_typeNAMES:
- ffeexpr_current_dotdot_ = ffeexpr_dotdot_ (t);
+ ffeexpr_current_dotdot_ = ffestr_other (t);
switch (ffeexpr_current_dotdot_)
{
- case FFEEXPR_dotdotNONE_:
+ case FFESTR_otherNone:
if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
{
ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
ffelex_token_kill (ffeexpr_tokens_[0]);
return (ffelexHandler) ffeexpr_token_rhs_ (t);
- case FFEEXPR_dotdotTRUE_:
- case FFEEXPR_dotdotFALSE_:
- case FFEEXPR_dotdotNOT_:
+ case FFESTR_otherTRUE:
+ case FFESTR_otherFALSE:
+ case FFESTR_otherNOT:
ffeexpr_tokens_[1] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_end_period_;
switch (ffeexpr_current_dotdot_)
{
- case FFEEXPR_dotdotNOT_:
+ case FFESTR_otherNOT:
e->type = FFEEXPR_exprtypeUNARY_;
e->u.operator.op = FFEEXPR_operatorNOT_;
e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
return (ffelexHandler) ffeexpr_token_rhs_ (t);
return (ffelexHandler) ffeexpr_token_rhs_;
- case FFEEXPR_dotdotTRUE_:
+ case FFESTR_otherTRUE:
e->type = FFEEXPR_exprtypeOPERAND_;
e->u.operand
= ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
return (ffelexHandler) ffeexpr_token_binary_ (t);
return (ffelexHandler) ffeexpr_token_binary_;
- case FFEEXPR_dotdotFALSE_:
+ case FFESTR_otherFALSE:
e->type = FFEEXPR_exprtypeOPERAND_;
e->u.operand
= ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
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))
ffeexprExpr_ e;
ffeinfo ni;
char d;
- char *p;
+ const char *p;
if (ffeexpr_hollerith_count_ > 0)
ffelex_set_expecting_hollerith (0, '\0',
/* Nothing specific we were looking for, so make an integer and pass the
current token to the binary state. */
- e = ffeexpr_expr_new_ ();
- e->type = FFEEXPR_exprtypeOPERAND_;
- e->token = ffeexpr_tokens_[0];
- e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
- (ffeexpr_tokens_[0]));
- ffebld_set_info (e->u.operand,
- ffeinfo_new (FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT, 0,
- FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
- FFETARGET_charactersizeNONE));
- ffeexpr_exprstack_push_operand_ (e);
+ ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
+ NULL, NULL, NULL);
return (ffelexHandler) ffeexpr_token_binary_ (t);
}
{
ffeexprExpr_ e;
ffelexHandler nexthandler;
- char *p;
+ const char *p;
char d;
switch (ffelex_token_type (t))
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))
{
case FFELEX_typeNAME:
case FFELEX_typeNAMES:
- ffeexpr_current_dotdot_ = ffeexpr_dotdot_ (t);
+ ffeexpr_current_dotdot_ = ffestr_other (t);
switch (ffeexpr_current_dotdot_)
{
- case FFEEXPR_dotdotTRUE_:
- case FFEEXPR_dotdotFALSE_:
- case FFEEXPR_dotdotNOT_:
+ case FFESTR_otherTRUE:
+ case FFESTR_otherFALSE:
+ case FFESTR_otherNOT:
if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
{
operand = ffeexpr_stack_->exprstack;
ffelex_token_kill (ffeexpr_tokens_[0]);
return (ffelexHandler) ffeexpr_token_binary_sw_per_;
- case FFEEXPR_dotdotNONE_:
- if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
- {
- ffebad_string (ffelex_token_text (t));
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
- ffelex_token_where_column (ffeexpr_tokens_[0]));
- ffebad_finish ();
- }
- ffeexpr_current_dotdot_ = FFEEXPR_dotdotEQ_;
- /* Fall through here, pretending we got a .EQ. operator. */
default:
ffeexpr_tokens_[1] = ffelex_token_use (t);
return (ffelexHandler) ffeexpr_token_binary_end_per_;
{
ffeexprExpr_ e;
- if (ffelex_token_type (t) != FFELEX_typePERIOD)
- {
- if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
- {
- ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
- ffelex_token_where_column (ffeexpr_tokens_[0]));
- ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
- ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
- ffebad_finish ();
- }
- }
-
- ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
-
e = ffeexpr_expr_new_ ();
e->type = FFEEXPR_exprtypeBINARY_;
e->token = ffeexpr_tokens_[0];
switch (ffeexpr_current_dotdot_)
{
- case FFEEXPR_dotdotAND_:
+ case FFESTR_otherAND:
e->u.operator.op = FFEEXPR_operatorAND_;
e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
e->u.operator.as = FFEEXPR_operatorassociativityAND_;
break;
- case FFEEXPR_dotdotOR_:
+ case FFESTR_otherOR:
e->u.operator.op = FFEEXPR_operatorOR_;
e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
e->u.operator.as = FFEEXPR_operatorassociativityOR_;
break;
- case FFEEXPR_dotdotXOR_:
+ case FFESTR_otherXOR:
e->u.operator.op = FFEEXPR_operatorXOR_;
e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
break;
- case FFEEXPR_dotdotEQV_:
+ case FFESTR_otherEQV:
e->u.operator.op = FFEEXPR_operatorEQV_;
e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
break;
- case FFEEXPR_dotdotNEQV_:
+ case FFESTR_otherNEQV:
e->u.operator.op = FFEEXPR_operatorNEQV_;
e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
break;
- case FFEEXPR_dotdotLT_:
+ case FFESTR_otherLT:
e->u.operator.op = FFEEXPR_operatorLT_;
e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
e->u.operator.as = FFEEXPR_operatorassociativityLT_;
break;
- case FFEEXPR_dotdotLE_:
+ case FFESTR_otherLE:
e->u.operator.op = FFEEXPR_operatorLE_;
e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
e->u.operator.as = FFEEXPR_operatorassociativityLE_;
break;
- case FFEEXPR_dotdotEQ_:
+ case FFESTR_otherEQ:
e->u.operator.op = FFEEXPR_operatorEQ_;
e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
break;
- case FFEEXPR_dotdotNE_:
+ case FFESTR_otherNE:
e->u.operator.op = FFEEXPR_operatorNE_;
e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
e->u.operator.as = FFEEXPR_operatorassociativityNE_;
break;
- case FFEEXPR_dotdotGT_:
+ case FFESTR_otherGT:
e->u.operator.op = FFEEXPR_operatorGT_;
e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
e->u.operator.as = FFEEXPR_operatorassociativityGT_;
break;
- case FFEEXPR_dotdotGE_:
+ case FFESTR_otherGE:
e->u.operator.op = FFEEXPR_operatorGE_;
e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
e->u.operator.as = FFEEXPR_operatorassociativityGE_;
break;
default:
- assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
+ if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
+ {
+ ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
+ ffelex_token_where_column (ffeexpr_tokens_[0]));
+ ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
+ ffebad_finish ();
+ }
+ e->u.operator.op = FFEEXPR_operatorEQ_;
+ e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
+ e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
+ break;
}
ffeexpr_exprstack_push_binary_ (e);
if (ffelex_token_type (t) != FFELEX_typePERIOD)
- return (ffelexHandler) ffeexpr_token_rhs_ (t);
+ {
+ if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
+ {
+ ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
+ ffelex_token_where_column (ffeexpr_tokens_[0]));
+ ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
+ ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
+ ffebad_finish ();
+ }
+ ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
+ return (ffelexHandler) ffeexpr_token_rhs_ (t);
+ }
+
+ ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
return (ffelexHandler) ffeexpr_token_rhs_;
}
break;
#endif
+ case 'I': /* Make an integer. */
+ e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
+ (ffeexpr_tokens_[0]));
+ ffebld_set_info (e->u.operand,
+ ffeinfo_new (FFEINFO_basictypeINTEGER,
+ FFEINFO_kindtypeINTEGERDEFAULT, 0,
+ FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
+ FFETARGET_charactersizeNONE));
+ break;
+
default:
no_match: /* :::::::::::::::::::: */
assert ("Lost the exponent letter!" == NULL);
version. */
if (!ffeimplic_establish_symbol (sp))
ffesymbol_error (sp, t);
- ffesymbol_set_info (sp,
- ffeinfo_new (ffesymbol_basictype (sp),
- ffesymbol_kindtype (sp),
- ffesymbol_rank (sp),
- kind,
- where,
- ffesymbol_size (sp)));
- ffesymbol_set_attrs (sp, na);
- ffesymbol_set_state (sp, ns);
- ffesymbol_resolve_intrin (sp);
- if (!ffesymbol_state_is_specable (ns))
- sp = ffecom_sym_learned (sp);
- ffesymbol_signal_unreported (sp); /* For debugging purposes. */
+ else
+ {
+ ffesymbol_set_info (sp,
+ ffeinfo_new (ffesymbol_basictype (sp),
+ ffesymbol_kindtype (sp),
+ ffesymbol_rank (sp),
+ kind,
+ where,
+ ffesymbol_size (sp)));
+ ffesymbol_set_attrs (sp, na);
+ ffesymbol_set_state (sp, ns);
+ ffesymbol_resolve_intrin (sp);
+ if (!ffesymbol_state_is_specable (ns))
+ sp = ffecom_sym_learned (sp);
+ ffesymbol_signal_unreported (sp); /* For debugging purposes. */
+ }
}
}
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