1/* expr.c -- Implementation File (module.c template V1.0) 2 Copyright (C) 1995-1998 Free Software Foundation, Inc. 3 Contributed by James Craig Burley. 4 5This file is part of GNU Fortran. 6 7GNU Fortran is free software; you can redistribute it and/or modify 8it under the terms of the GNU General Public License as published by 9the Free Software Foundation; either version 2, or (at your option) 10any later version. 11 12GNU Fortran is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17You should have received a copy of the GNU General Public License 18along with GNU Fortran; see the file COPYING. If not, write to 19the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA 2002111-1307, USA. 21 22 Related Modules: 23 None. 24 25 Description: 26 Handles syntactic and semantic analysis of Fortran expressions. 27 28 Modifications: 29*/ 30 31/* Include files. */ 32 33#include "proj.h" 34#include "expr.h" 35#include "bad.h" 36#include "bld.h" 37#include "com.h" 38#include "global.h" 39#include "implic.h" 40#include "intrin.h" 41#include "info.h" 42#include "lex.h" 43#include "malloc.h" 44#include "src.h" 45#include "st.h" 46#include "symbol.h" 47#include "str.h" 48#include "target.h" 49#include "where.h" 50 51/* Externals defined here. */ 52 53 54/* Simple definitions and enumerations. */ 55 56typedef enum 57 { 58 FFEEXPR_exprtypeUNKNOWN_, 59 FFEEXPR_exprtypeOPERAND_, 60 FFEEXPR_exprtypeUNARY_, 61 FFEEXPR_exprtypeBINARY_, 62 FFEEXPR_exprtype_ 63 } ffeexprExprtype_; 64 65typedef enum 66 { 67 FFEEXPR_operatorPOWER_, 68 FFEEXPR_operatorMULTIPLY_, 69 FFEEXPR_operatorDIVIDE_, 70 FFEEXPR_operatorADD_, 71 FFEEXPR_operatorSUBTRACT_, 72 FFEEXPR_operatorCONCATENATE_, 73 FFEEXPR_operatorLT_, 74 FFEEXPR_operatorLE_, 75 FFEEXPR_operatorEQ_, 76 FFEEXPR_operatorNE_, 77 FFEEXPR_operatorGT_, 78 FFEEXPR_operatorGE_, 79 FFEEXPR_operatorNOT_, 80 FFEEXPR_operatorAND_, 81 FFEEXPR_operatorOR_, 82 FFEEXPR_operatorXOR_, 83 FFEEXPR_operatorEQV_, 84 FFEEXPR_operatorNEQV_, 85 FFEEXPR_operator_ 86 } ffeexprOperator_; 87 88typedef enum 89 { 90 FFEEXPR_operatorprecedenceHIGHEST_ = 1, 91 FFEEXPR_operatorprecedencePOWER_ = 1, 92 FFEEXPR_operatorprecedenceMULTIPLY_ = 2, 93 FFEEXPR_operatorprecedenceDIVIDE_ = 2, 94 FFEEXPR_operatorprecedenceADD_ = 3, 95 FFEEXPR_operatorprecedenceSUBTRACT_ = 3, 96 FFEEXPR_operatorprecedenceLOWARITH_ = 3, 97 FFEEXPR_operatorprecedenceCONCATENATE_ = 3, 98 FFEEXPR_operatorprecedenceLT_ = 4, 99 FFEEXPR_operatorprecedenceLE_ = 4, 100 FFEEXPR_operatorprecedenceEQ_ = 4, 101 FFEEXPR_operatorprecedenceNE_ = 4, 102 FFEEXPR_operatorprecedenceGT_ = 4, 103 FFEEXPR_operatorprecedenceGE_ = 4, 104 FFEEXPR_operatorprecedenceNOT_ = 5, 105 FFEEXPR_operatorprecedenceAND_ = 6, 106 FFEEXPR_operatorprecedenceOR_ = 7, 107 FFEEXPR_operatorprecedenceXOR_ = 8, 108 FFEEXPR_operatorprecedenceEQV_ = 8, 109 FFEEXPR_operatorprecedenceNEQV_ = 8, 110 FFEEXPR_operatorprecedenceLOWEST_ = 8, 111 FFEEXPR_operatorprecedence_ 112 } ffeexprOperatorPrecedence_; 113 114#define FFEEXPR_operatorassociativityL2R_ TRUE 115#define FFEEXPR_operatorassociativityR2L_ FALSE 116#define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_ 117#define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_ 118#define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_ 119#define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_ 120#define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_ 121#define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_ 122#define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_ 123#define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_ 124#define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_ 125#define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_ 126#define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_ 127#define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_ 128#define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_ 129#define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_ 130#define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_ 131#define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_ 132#define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_ 133#define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_ 134 135typedef enum 136 { 137 FFEEXPR_parentypeFUNCTION_, 138 FFEEXPR_parentypeSUBROUTINE_, 139 FFEEXPR_parentypeARRAY_, 140 FFEEXPR_parentypeSUBSTRING_, 141 FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */ 142 FFEEXPR_parentypeEQUIVALENCE_, /* Ambig: ARRAY_ or SUBSTRING_. */ 143 FFEEXPR_parentypeANY_, /* Allow basically anything. */ 144 FFEEXPR_parentype_ 145 } ffeexprParenType_; 146 147typedef enum 148 { 149 FFEEXPR_percentNONE_, 150 FFEEXPR_percentLOC_, 151 FFEEXPR_percentVAL_, 152 FFEEXPR_percentREF_, 153 FFEEXPR_percentDESCR_, 154 FFEEXPR_percent_ 155 } ffeexprPercent_; 156 157/* Internal typedefs. */ 158 159typedef struct _ffeexpr_expr_ *ffeexprExpr_; 160typedef bool ffeexprOperatorAssociativity_; 161typedef struct _ffeexpr_stack_ *ffeexprStack_; 162 163/* Private include files. */ 164 165 166/* Internal structure definitions. */ 167 168struct _ffeexpr_expr_ 169 { 170 ffeexprExpr_ previous; 171 ffelexToken token; 172 ffeexprExprtype_ type; 173 union 174 { 175 struct 176 { 177 ffeexprOperator_ op; 178 ffeexprOperatorPrecedence_ prec; 179 ffeexprOperatorAssociativity_ as; 180 } 181 operator; 182 ffebld operand; 183 } 184 u; 185 }; 186 187struct _ffeexpr_stack_ 188 { 189 ffeexprStack_ previous; 190 mallocPool pool; 191 ffeexprContext context; 192 ffeexprCallback callback; 193 ffelexToken first_token; 194 ffeexprExpr_ exprstack; 195 ffelexToken tokens[10]; /* Used in certain cases, like (unary) 196 open-paren. */ 197 ffebld expr; /* For first of 198 complex/implied-do/substring/array-elements 199 / actual-args expression. */ 200 ffebld bound_list; /* For tracking dimension bounds list of 201 array. */ 202 ffebldListBottom bottom; /* For building lists. */ 203 ffeinfoRank rank; /* For elements in an array reference. */ 204 bool constant; /* TRUE while elements seen so far are 205 constants. */ 206 bool immediate; /* TRUE while elements seen so far are 207 immediate/constants. */ 208 ffebld next_dummy; /* Next SFUNC dummy arg in arg list. */ 209 ffebldListLength num_args; /* Number of dummy args expected in arg list. */ 210 bool is_rhs; /* TRUE if rhs context, FALSE otherwise. */ 211 ffeexprPercent_ percent; /* Current %FOO keyword. */ 212 }; 213 214struct _ffeexpr_find_ 215 { 216 ffelexToken t; 217 ffelexHandler after; 218 int level; 219 }; 220 221/* Static objects accessed by functions in this module. */ 222 223static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */ 224static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */ 225static ffestrOther ffeexpr_current_dotdot_; /* Current .FOO. keyword. */ 226static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */ 227static int ffeexpr_level_; /* Level of DATA implied-DO construct. */ 228static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */ 229static struct _ffeexpr_find_ ffeexpr_find_; 230 231/* Static functions (internal). */ 232 233static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, 234 ffelexToken t); 235static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, 236 ffebld expr, 237 ffelexToken t); 238static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t); 239static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft, 240 ffebld expr, ffelexToken t); 241static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, 242 ffelexToken t); 243static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft, 244 ffebld expr, ffelexToken t); 245static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, 246 ffelexToken t); 247static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, 248 ffelexToken t); 249static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, 250 ffelexToken t); 251static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr, 252 ffelexToken t); 253static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr, 254 ffelexToken t); 255static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr, 256 ffelexToken t); 257static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t); 258static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr, 259 ffelexToken t); 260static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, 261 ffelexToken t); 262static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t); 263static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s); 264static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t, 265 ffebld dovar, ffelexToken dovar_t); 266static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar); 267static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar); 268static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s); 269static ffeexprExpr_ ffeexpr_expr_new_ (void); 270static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t); 271static bool ffeexpr_isdigits_ (const char *p); 272static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t); 273static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t); 274static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t); 275static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t); 276static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t); 277static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t); 278static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t); 279static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t); 280static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t); 281static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t); 282static void ffeexpr_expr_kill_ (ffeexprExpr_ e); 283static void ffeexpr_exprstack_push_ (ffeexprExpr_ e); 284static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e); 285static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e); 286static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e); 287static void ffeexpr_reduce_ (void); 288static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, 289 ffeexprExpr_ r); 290static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, 291 ffeexprExpr_ op, ffeexprExpr_ r); 292static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, 293 ffeexprExpr_ op, ffeexprExpr_ r); 294static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, 295 ffeexprExpr_ op, ffeexprExpr_ r); 296static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, 297 ffeexprExpr_ r); 298static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, 299 ffeexprExpr_ op, ffeexprExpr_ r); 300static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, 301 ffeexprExpr_ op, ffeexprExpr_ r); 302static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, 303 ffeexprExpr_ op, ffeexprExpr_ r); 304static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r); 305static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, 306 ffeexprExpr_ r); 307static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, 308 ffeexprExpr_ op, ffeexprExpr_ r); 309static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, 310 ffeexprExpr_ op, ffeexprExpr_ r); 311static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t, 312 ffelexHandler after); 313static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t); 314static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t); 315static ffelexHandler ffeexpr_nil_period_ (ffelexToken t); 316static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t); 317static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t); 318static ffelexHandler ffeexpr_nil_real_ (ffelexToken t); 319static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t); 320static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t); 321static ffelexHandler ffeexpr_nil_number_ (ffelexToken t); 322static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t); 323static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t); 324static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t); 325static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t); 326static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t); 327static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t); 328static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t); 329static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t); 330static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t); 331static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t); 332static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t); 333static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t); 334static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t); 335static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t); 336static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t); 337static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t); 338static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t); 339static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t); 340static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t); 341static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t); 342static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t); 343static ffelexHandler ffeexpr_finished_ (ffelexToken t); 344static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr); 345static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t); 346static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t); 347static ffelexHandler ffeexpr_token_binary_ (ffelexToken t); 348static ffelexHandler ffeexpr_token_period_ (ffelexToken t); 349static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t); 350static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t); 351static ffelexHandler ffeexpr_token_real_ (ffelexToken t); 352static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t); 353static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t); 354static ffelexHandler ffeexpr_token_number_ (ffelexToken t); 355static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t); 356static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t); 357static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t); 358static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t); 359static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t); 360static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t); 361static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t); 362static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t); 363static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t); 364static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t); 365static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t); 366static ffelexHandler ffeexpr_token_quote_ (ffelexToken t); 367static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t); 368static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t); 369static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t); 370static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t); 371static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t); 372static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t); 373static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t); 374static ffelexHandler ffeexpr_token_percent_ (ffelexToken t); 375static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t); 376static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, 377 ffelexToken t); 378static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, 379 ffelexToken t); 380static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, 381 ffelexToken t); 382static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, 383 ffelexToken t); 384static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr, 385 ffelexToken t); 386static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t); 387static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t); 388static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, 389 ffelexToken t); 390static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr, 391 ffelexToken t); 392static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer, 393 ffelexToken decimal, ffelexToken fraction, ffelexToken exponent, 394 ffelexToken exponent_sign, ffelexToken exponent_digits); 395static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin); 396static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t); 397static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t); 398static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t); 399static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t); 400static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t); 401static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t); 402static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t); 403static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t); 404static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t); 405static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t); 406static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t, 407 bool maybe_intrin, 408 ffeexprParenType_ *paren_type); 409static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t); 410 411/* Internal macros. */ 412 413#define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t) 414#define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t) 415 416/* ffeexpr_collapse_convert -- Collapse convert expr 417 418 ffebld expr; 419 ffelexToken token; 420 expr = ffeexpr_collapse_convert(expr,token); 421 422 If the result of the expr is a constant, replaces the expr with the 423 computed constant. */ 424 425ffebld 426ffeexpr_collapse_convert (ffebld expr, ffelexToken t) 427{ 428 ffebad error = FFEBAD; 429 ffebld l; 430 ffebldConstantUnion u; 431 ffeinfoBasictype bt; 432 ffeinfoKindtype kt; 433 ffetargetCharacterSize sz; 434 ffetargetCharacterSize sz2; 435 436 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 437 return expr; 438 439 l = ffebld_left (expr); 440 441 if (ffebld_op (l) != FFEBLD_opCONTER) 442 return expr; 443 444 switch (bt = ffeinfo_basictype (ffebld_info (expr))) 445 { 446 case FFEINFO_basictypeANY: 447 return expr; 448 449 case FFEINFO_basictypeINTEGER: 450 sz = FFETARGET_charactersizeNONE; 451 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 452 { 453#if FFETARGET_okINTEGER1 454 case FFEINFO_kindtypeINTEGER1: 455 switch (ffeinfo_basictype (ffebld_info (l))) 456 { 457 case FFEINFO_basictypeINTEGER: 458 switch (ffeinfo_kindtype (ffebld_info (l))) 459 { 460#if FFETARGET_okINTEGER2 461 case FFEINFO_kindtypeINTEGER2: 462 error = ffetarget_convert_integer1_integer2 463 (ffebld_cu_ptr_integer1 (u), 464 ffebld_constant_integer2 (ffebld_conter (l))); 465 break; 466#endif 467 468#if FFETARGET_okINTEGER3 469 case FFEINFO_kindtypeINTEGER3: 470 error = ffetarget_convert_integer1_integer3 471 (ffebld_cu_ptr_integer1 (u), 472 ffebld_constant_integer3 (ffebld_conter (l))); 473 break; 474#endif 475 476#if FFETARGET_okINTEGER4 477 case FFEINFO_kindtypeINTEGER4: 478 error = ffetarget_convert_integer1_integer4 479 (ffebld_cu_ptr_integer1 (u), 480 ffebld_constant_integer4 (ffebld_conter (l))); 481 break; 482#endif 483 484 default: 485 assert ("INTEGER1/INTEGER bad source kind type" == NULL); 486 break; 487 } 488 break; 489 490 case FFEINFO_basictypeREAL: 491 switch (ffeinfo_kindtype (ffebld_info (l))) 492 { 493#if FFETARGET_okREAL1 494 case FFEINFO_kindtypeREAL1: 495 error = ffetarget_convert_integer1_real1 496 (ffebld_cu_ptr_integer1 (u), 497 ffebld_constant_real1 (ffebld_conter (l))); 498 break; 499#endif 500 501#if FFETARGET_okREAL2 502 case FFEINFO_kindtypeREAL2: 503 error = ffetarget_convert_integer1_real2 504 (ffebld_cu_ptr_integer1 (u), 505 ffebld_constant_real2 (ffebld_conter (l))); 506 break; 507#endif 508 509#if FFETARGET_okREAL3 510 case FFEINFO_kindtypeREAL3: 511 error = ffetarget_convert_integer1_real3 512 (ffebld_cu_ptr_integer1 (u), 513 ffebld_constant_real3 (ffebld_conter (l))); 514 break; 515#endif 516 517#if FFETARGET_okREAL4 518 case FFEINFO_kindtypeREAL4: 519 error = ffetarget_convert_integer1_real4 520 (ffebld_cu_ptr_integer1 (u), 521 ffebld_constant_real4 (ffebld_conter (l))); 522 break; 523#endif 524 525 default: 526 assert ("INTEGER1/REAL bad source kind type" == NULL); 527 break; 528 } 529 break; 530 531 case FFEINFO_basictypeCOMPLEX: 532 switch (ffeinfo_kindtype (ffebld_info (l))) 533 { 534#if FFETARGET_okCOMPLEX1 535 case FFEINFO_kindtypeREAL1: 536 error = ffetarget_convert_integer1_complex1 537 (ffebld_cu_ptr_integer1 (u), 538 ffebld_constant_complex1 (ffebld_conter (l))); 539 break; 540#endif 541 542#if FFETARGET_okCOMPLEX2 543 case FFEINFO_kindtypeREAL2: 544 error = ffetarget_convert_integer1_complex2 545 (ffebld_cu_ptr_integer1 (u), 546 ffebld_constant_complex2 (ffebld_conter (l))); 547 break; 548#endif 549 550#if FFETARGET_okCOMPLEX3 551 case FFEINFO_kindtypeREAL3: 552 error = ffetarget_convert_integer1_complex3 553 (ffebld_cu_ptr_integer1 (u), 554 ffebld_constant_complex3 (ffebld_conter (l))); 555 break; 556#endif 557 558#if FFETARGET_okCOMPLEX4 559 case FFEINFO_kindtypeREAL4: 560 error = ffetarget_convert_integer1_complex4 561 (ffebld_cu_ptr_integer1 (u), 562 ffebld_constant_complex4 (ffebld_conter (l))); 563 break; 564#endif 565 566 default: 567 assert ("INTEGER1/COMPLEX bad source kind type" == NULL); 568 break; 569 } 570 break; 571 572 case FFEINFO_basictypeLOGICAL: 573 switch (ffeinfo_kindtype (ffebld_info (l))) 574 { 575#if FFETARGET_okLOGICAL1 576 case FFEINFO_kindtypeLOGICAL1: 577 error = ffetarget_convert_integer1_logical1 578 (ffebld_cu_ptr_integer1 (u), 579 ffebld_constant_logical1 (ffebld_conter (l))); 580 break; 581#endif 582 583#if FFETARGET_okLOGICAL2 584 case FFEINFO_kindtypeLOGICAL2: 585 error = ffetarget_convert_integer1_logical2 586 (ffebld_cu_ptr_integer1 (u), 587 ffebld_constant_logical2 (ffebld_conter (l))); 588 break; 589#endif 590 591#if FFETARGET_okLOGICAL3 592 case FFEINFO_kindtypeLOGICAL3: 593 error = ffetarget_convert_integer1_logical3 594 (ffebld_cu_ptr_integer1 (u), 595 ffebld_constant_logical3 (ffebld_conter (l))); 596 break; 597#endif 598 599#if FFETARGET_okLOGICAL4 600 case FFEINFO_kindtypeLOGICAL4: 601 error = ffetarget_convert_integer1_logical4 602 (ffebld_cu_ptr_integer1 (u), 603 ffebld_constant_logical4 (ffebld_conter (l))); 604 break; 605#endif 606 607 default: 608 assert ("INTEGER1/LOGICAL bad source kind type" == NULL); 609 break; 610 } 611 break; 612 613 case FFEINFO_basictypeCHARACTER: 614 error = ffetarget_convert_integer1_character1 615 (ffebld_cu_ptr_integer1 (u), 616 ffebld_constant_character1 (ffebld_conter (l))); 617 break; 618 619 case FFEINFO_basictypeHOLLERITH: 620 error = ffetarget_convert_integer1_hollerith 621 (ffebld_cu_ptr_integer1 (u), 622 ffebld_constant_hollerith (ffebld_conter (l))); 623 break; 624 625 case FFEINFO_basictypeTYPELESS: 626 error = ffetarget_convert_integer1_typeless 627 (ffebld_cu_ptr_integer1 (u), 628 ffebld_constant_typeless (ffebld_conter (l))); 629 break; 630 631 default: 632 assert ("INTEGER1 bad type" == NULL); 633 break; 634 } 635 636 /* If conversion operation is not implemented, return original expr. */ 637 if (error == FFEBAD_NOCANDO) 638 return expr; 639 640 expr = ffebld_new_conter_with_orig 641 (ffebld_constant_new_integer1_val 642 (ffebld_cu_val_integer1 (u)), expr); 643 break; 644#endif 645 646#if FFETARGET_okINTEGER2 647 case FFEINFO_kindtypeINTEGER2: 648 switch (ffeinfo_basictype (ffebld_info (l))) 649 { 650 case FFEINFO_basictypeINTEGER: 651 switch (ffeinfo_kindtype (ffebld_info (l))) 652 { 653#if FFETARGET_okINTEGER1 654 case FFEINFO_kindtypeINTEGER1: 655 error = ffetarget_convert_integer2_integer1 656 (ffebld_cu_ptr_integer2 (u), 657 ffebld_constant_integer1 (ffebld_conter (l))); 658 break; 659#endif 660 661#if FFETARGET_okINTEGER3 662 case FFEINFO_kindtypeINTEGER3: 663 error = ffetarget_convert_integer2_integer3 664 (ffebld_cu_ptr_integer2 (u), 665 ffebld_constant_integer3 (ffebld_conter (l))); 666 break; 667#endif 668 669#if FFETARGET_okINTEGER4 670 case FFEINFO_kindtypeINTEGER4: 671 error = ffetarget_convert_integer2_integer4 672 (ffebld_cu_ptr_integer2 (u), 673 ffebld_constant_integer4 (ffebld_conter (l))); 674 break; 675#endif 676 677 default: 678 assert ("INTEGER2/INTEGER bad source kind type" == NULL); 679 break; 680 } 681 break; 682 683 case FFEINFO_basictypeREAL: 684 switch (ffeinfo_kindtype (ffebld_info (l))) 685 { 686#if FFETARGET_okREAL1 687 case FFEINFO_kindtypeREAL1: 688 error = ffetarget_convert_integer2_real1 689 (ffebld_cu_ptr_integer2 (u), 690 ffebld_constant_real1 (ffebld_conter (l))); 691 break; 692#endif 693 694#if FFETARGET_okREAL2 695 case FFEINFO_kindtypeREAL2: 696 error = ffetarget_convert_integer2_real2 697 (ffebld_cu_ptr_integer2 (u), 698 ffebld_constant_real2 (ffebld_conter (l))); 699 break; 700#endif 701 702#if FFETARGET_okREAL3 703 case FFEINFO_kindtypeREAL3: 704 error = ffetarget_convert_integer2_real3 705 (ffebld_cu_ptr_integer2 (u), 706 ffebld_constant_real3 (ffebld_conter (l))); 707 break; 708#endif 709 710#if FFETARGET_okREAL4 711 case FFEINFO_kindtypeREAL4: 712 error = ffetarget_convert_integer2_real4 713 (ffebld_cu_ptr_integer2 (u), 714 ffebld_constant_real4 (ffebld_conter (l))); 715 break; 716#endif 717 718 default: 719 assert ("INTEGER2/REAL bad source kind type" == NULL); 720 break; 721 } 722 break; 723 724 case FFEINFO_basictypeCOMPLEX: 725 switch (ffeinfo_kindtype (ffebld_info (l))) 726 { 727#if FFETARGET_okCOMPLEX1 728 case FFEINFO_kindtypeREAL1: 729 error = ffetarget_convert_integer2_complex1 730 (ffebld_cu_ptr_integer2 (u), 731 ffebld_constant_complex1 (ffebld_conter (l))); 732 break; 733#endif 734 735#if FFETARGET_okCOMPLEX2 736 case FFEINFO_kindtypeREAL2: 737 error = ffetarget_convert_integer2_complex2 738 (ffebld_cu_ptr_integer2 (u), 739 ffebld_constant_complex2 (ffebld_conter (l))); 740 break; 741#endif 742 743#if FFETARGET_okCOMPLEX3 744 case FFEINFO_kindtypeREAL3: 745 error = ffetarget_convert_integer2_complex3 746 (ffebld_cu_ptr_integer2 (u), 747 ffebld_constant_complex3 (ffebld_conter (l))); 748 break; 749#endif 750 751#if FFETARGET_okCOMPLEX4 752 case FFEINFO_kindtypeREAL4: 753 error = ffetarget_convert_integer2_complex4 754 (ffebld_cu_ptr_integer2 (u), 755 ffebld_constant_complex4 (ffebld_conter (l))); 756 break; 757#endif 758 759 default: 760 assert ("INTEGER2/COMPLEX bad source kind type" == NULL); 761 break; 762 } 763 break; 764 765 case FFEINFO_basictypeLOGICAL: 766 switch (ffeinfo_kindtype (ffebld_info (l))) 767 { 768#if FFETARGET_okLOGICAL1 769 case FFEINFO_kindtypeLOGICAL1: 770 error = ffetarget_convert_integer2_logical1 771 (ffebld_cu_ptr_integer2 (u), 772 ffebld_constant_logical1 (ffebld_conter (l))); 773 break; 774#endif 775 776#if FFETARGET_okLOGICAL2 777 case FFEINFO_kindtypeLOGICAL2: 778 error = ffetarget_convert_integer2_logical2 779 (ffebld_cu_ptr_integer2 (u), 780 ffebld_constant_logical2 (ffebld_conter (l))); 781 break; 782#endif 783 784#if FFETARGET_okLOGICAL3 785 case FFEINFO_kindtypeLOGICAL3: 786 error = ffetarget_convert_integer2_logical3 787 (ffebld_cu_ptr_integer2 (u), 788 ffebld_constant_logical3 (ffebld_conter (l))); 789 break; 790#endif 791 792#if FFETARGET_okLOGICAL4 793 case FFEINFO_kindtypeLOGICAL4: 794 error = ffetarget_convert_integer2_logical4 795 (ffebld_cu_ptr_integer2 (u), 796 ffebld_constant_logical4 (ffebld_conter (l))); 797 break; 798#endif 799 800 default: 801 assert ("INTEGER2/LOGICAL bad source kind type" == NULL); 802 break; 803 } 804 break; 805 806 case FFEINFO_basictypeCHARACTER: 807 error = ffetarget_convert_integer2_character1 808 (ffebld_cu_ptr_integer2 (u), 809 ffebld_constant_character1 (ffebld_conter (l))); 810 break; 811 812 case FFEINFO_basictypeHOLLERITH: 813 error = ffetarget_convert_integer2_hollerith 814 (ffebld_cu_ptr_integer2 (u), 815 ffebld_constant_hollerith (ffebld_conter (l))); 816 break; 817 818 case FFEINFO_basictypeTYPELESS: 819 error = ffetarget_convert_integer2_typeless 820 (ffebld_cu_ptr_integer2 (u), 821 ffebld_constant_typeless (ffebld_conter (l))); 822 break; 823 824 default: 825 assert ("INTEGER2 bad type" == NULL); 826 break; 827 } 828 829 /* If conversion operation is not implemented, return original expr. */ 830 if (error == FFEBAD_NOCANDO) 831 return expr; 832 833 expr = ffebld_new_conter_with_orig 834 (ffebld_constant_new_integer2_val 835 (ffebld_cu_val_integer2 (u)), expr); 836 break; 837#endif 838 839#if FFETARGET_okINTEGER3 840 case FFEINFO_kindtypeINTEGER3: 841 switch (ffeinfo_basictype (ffebld_info (l))) 842 { 843 case FFEINFO_basictypeINTEGER: 844 switch (ffeinfo_kindtype (ffebld_info (l))) 845 { 846#if FFETARGET_okINTEGER1 847 case FFEINFO_kindtypeINTEGER1: 848 error = ffetarget_convert_integer3_integer1 849 (ffebld_cu_ptr_integer3 (u), 850 ffebld_constant_integer1 (ffebld_conter (l))); 851 break; 852#endif 853 854#if FFETARGET_okINTEGER2 855 case FFEINFO_kindtypeINTEGER2: 856 error = ffetarget_convert_integer3_integer2 857 (ffebld_cu_ptr_integer3 (u), 858 ffebld_constant_integer2 (ffebld_conter (l))); 859 break; 860#endif 861 862#if FFETARGET_okINTEGER4 863 case FFEINFO_kindtypeINTEGER4: 864 error = ffetarget_convert_integer3_integer4 865 (ffebld_cu_ptr_integer3 (u), 866 ffebld_constant_integer4 (ffebld_conter (l))); 867 break; 868#endif 869 870 default: 871 assert ("INTEGER3/INTEGER bad source kind type" == NULL); 872 break; 873 } 874 break; 875 876 case FFEINFO_basictypeREAL: 877 switch (ffeinfo_kindtype (ffebld_info (l))) 878 { 879#if FFETARGET_okREAL1 880 case FFEINFO_kindtypeREAL1: 881 error = ffetarget_convert_integer3_real1 882 (ffebld_cu_ptr_integer3 (u), 883 ffebld_constant_real1 (ffebld_conter (l))); 884 break; 885#endif 886 887#if FFETARGET_okREAL2 888 case FFEINFO_kindtypeREAL2: 889 error = ffetarget_convert_integer3_real2 890 (ffebld_cu_ptr_integer3 (u), 891 ffebld_constant_real2 (ffebld_conter (l))); 892 break; 893#endif 894 895#if FFETARGET_okREAL3 896 case FFEINFO_kindtypeREAL3: 897 error = ffetarget_convert_integer3_real3 898 (ffebld_cu_ptr_integer3 (u), 899 ffebld_constant_real3 (ffebld_conter (l))); 900 break; 901#endif 902 903#if FFETARGET_okREAL4 904 case FFEINFO_kindtypeREAL4: 905 error = ffetarget_convert_integer3_real4 906 (ffebld_cu_ptr_integer3 (u), 907 ffebld_constant_real4 (ffebld_conter (l))); 908 break; 909#endif 910 911 default: 912 assert ("INTEGER3/REAL bad source kind type" == NULL); 913 break; 914 } 915 break; 916 917 case FFEINFO_basictypeCOMPLEX: 918 switch (ffeinfo_kindtype (ffebld_info (l))) 919 { 920#if FFETARGET_okCOMPLEX1 921 case FFEINFO_kindtypeREAL1: 922 error = ffetarget_convert_integer3_complex1 923 (ffebld_cu_ptr_integer3 (u), 924 ffebld_constant_complex1 (ffebld_conter (l))); 925 break; 926#endif 927 928#if FFETARGET_okCOMPLEX2 929 case FFEINFO_kindtypeREAL2: 930 error = ffetarget_convert_integer3_complex2 931 (ffebld_cu_ptr_integer3 (u), 932 ffebld_constant_complex2 (ffebld_conter (l))); 933 break; 934#endif 935 936#if FFETARGET_okCOMPLEX3 937 case FFEINFO_kindtypeREAL3: 938 error = ffetarget_convert_integer3_complex3 939 (ffebld_cu_ptr_integer3 (u), 940 ffebld_constant_complex3 (ffebld_conter (l))); 941 break; 942#endif 943 944#if FFETARGET_okCOMPLEX4 945 case FFEINFO_kindtypeREAL4: 946 error = ffetarget_convert_integer3_complex4 947 (ffebld_cu_ptr_integer3 (u), 948 ffebld_constant_complex4 (ffebld_conter (l))); 949 break; 950#endif 951 952 default: 953 assert ("INTEGER3/COMPLEX bad source kind type" == NULL); 954 break; 955 } 956 break; 957 958 case FFEINFO_basictypeLOGICAL: 959 switch (ffeinfo_kindtype (ffebld_info (l))) 960 { 961#if FFETARGET_okLOGICAL1 962 case FFEINFO_kindtypeLOGICAL1: 963 error = ffetarget_convert_integer3_logical1 964 (ffebld_cu_ptr_integer3 (u), 965 ffebld_constant_logical1 (ffebld_conter (l))); 966 break; 967#endif 968 969#if FFETARGET_okLOGICAL2 970 case FFEINFO_kindtypeLOGICAL2: 971 error = ffetarget_convert_integer3_logical2 972 (ffebld_cu_ptr_integer3 (u), 973 ffebld_constant_logical2 (ffebld_conter (l))); 974 break; 975#endif 976 977#if FFETARGET_okLOGICAL3 978 case FFEINFO_kindtypeLOGICAL3: 979 error = ffetarget_convert_integer3_logical3 980 (ffebld_cu_ptr_integer3 (u), 981 ffebld_constant_logical3 (ffebld_conter (l))); 982 break; 983#endif 984 985#if FFETARGET_okLOGICAL4 986 case FFEINFO_kindtypeLOGICAL4: 987 error = ffetarget_convert_integer3_logical4 988 (ffebld_cu_ptr_integer3 (u), 989 ffebld_constant_logical4 (ffebld_conter (l))); 990 break; 991#endif 992 993 default: 994 assert ("INTEGER3/LOGICAL bad source kind type" == NULL); 995 break; 996 } 997 break; 998 999 case FFEINFO_basictypeCHARACTER: 1000 error = ffetarget_convert_integer3_character1 1001 (ffebld_cu_ptr_integer3 (u), 1002 ffebld_constant_character1 (ffebld_conter (l))); 1003 break; 1004 1005 case FFEINFO_basictypeHOLLERITH: 1006 error = ffetarget_convert_integer3_hollerith 1007 (ffebld_cu_ptr_integer3 (u), 1008 ffebld_constant_hollerith (ffebld_conter (l))); 1009 break; 1010 1011 case FFEINFO_basictypeTYPELESS: 1012 error = ffetarget_convert_integer3_typeless 1013 (ffebld_cu_ptr_integer3 (u), 1014 ffebld_constant_typeless (ffebld_conter (l))); 1015 break; 1016 1017 default: 1018 assert ("INTEGER3 bad type" == NULL); 1019 break; 1020 } 1021 1022 /* If conversion operation is not implemented, return original expr. */ 1023 if (error == FFEBAD_NOCANDO) 1024 return expr; 1025 1026 expr = ffebld_new_conter_with_orig 1027 (ffebld_constant_new_integer3_val 1028 (ffebld_cu_val_integer3 (u)), expr); 1029 break; 1030#endif 1031 1032#if FFETARGET_okINTEGER4 1033 case FFEINFO_kindtypeINTEGER4: 1034 switch (ffeinfo_basictype (ffebld_info (l))) 1035 { 1036 case FFEINFO_basictypeINTEGER: 1037 switch (ffeinfo_kindtype (ffebld_info (l))) 1038 { 1039#if FFETARGET_okINTEGER1 1040 case FFEINFO_kindtypeINTEGER1: 1041 error = ffetarget_convert_integer4_integer1 1042 (ffebld_cu_ptr_integer4 (u), 1043 ffebld_constant_integer1 (ffebld_conter (l))); 1044 break; 1045#endif 1046 1047#if FFETARGET_okINTEGER2 1048 case FFEINFO_kindtypeINTEGER2: 1049 error = ffetarget_convert_integer4_integer2 1050 (ffebld_cu_ptr_integer4 (u), 1051 ffebld_constant_integer2 (ffebld_conter (l))); 1052 break; 1053#endif 1054 1055#if FFETARGET_okINTEGER3 1056 case FFEINFO_kindtypeINTEGER3: 1057 error = ffetarget_convert_integer4_integer3 1058 (ffebld_cu_ptr_integer4 (u), 1059 ffebld_constant_integer3 (ffebld_conter (l))); 1060 break; 1061#endif 1062 1063 default: 1064 assert ("INTEGER4/INTEGER bad source kind type" == NULL); 1065 break; 1066 } 1067 break; 1068 1069 case FFEINFO_basictypeREAL: 1070 switch (ffeinfo_kindtype (ffebld_info (l))) 1071 { 1072#if FFETARGET_okREAL1 1073 case FFEINFO_kindtypeREAL1: 1074 error = ffetarget_convert_integer4_real1 1075 (ffebld_cu_ptr_integer4 (u), 1076 ffebld_constant_real1 (ffebld_conter (l))); 1077 break; 1078#endif 1079 1080#if FFETARGET_okREAL2 1081 case FFEINFO_kindtypeREAL2: 1082 error = ffetarget_convert_integer4_real2 1083 (ffebld_cu_ptr_integer4 (u), 1084 ffebld_constant_real2 (ffebld_conter (l))); 1085 break; 1086#endif 1087 1088#if FFETARGET_okREAL3 1089 case FFEINFO_kindtypeREAL3: 1090 error = ffetarget_convert_integer4_real3 1091 (ffebld_cu_ptr_integer4 (u), 1092 ffebld_constant_real3 (ffebld_conter (l))); 1093 break; 1094#endif 1095 1096#if FFETARGET_okREAL4 1097 case FFEINFO_kindtypeREAL4: 1098 error = ffetarget_convert_integer4_real4 1099 (ffebld_cu_ptr_integer4 (u), 1100 ffebld_constant_real4 (ffebld_conter (l))); 1101 break; 1102#endif 1103 1104 default: 1105 assert ("INTEGER4/REAL bad source kind type" == NULL); 1106 break; 1107 } 1108 break; 1109 1110 case FFEINFO_basictypeCOMPLEX: 1111 switch (ffeinfo_kindtype (ffebld_info (l))) 1112 { 1113#if FFETARGET_okCOMPLEX1 1114 case FFEINFO_kindtypeREAL1: 1115 error = ffetarget_convert_integer4_complex1 1116 (ffebld_cu_ptr_integer4 (u), 1117 ffebld_constant_complex1 (ffebld_conter (l))); 1118 break; 1119#endif 1120 1121#if FFETARGET_okCOMPLEX2 1122 case FFEINFO_kindtypeREAL2: 1123 error = ffetarget_convert_integer4_complex2 1124 (ffebld_cu_ptr_integer4 (u), 1125 ffebld_constant_complex2 (ffebld_conter (l))); 1126 break; 1127#endif 1128 1129#if FFETARGET_okCOMPLEX3 1130 case FFEINFO_kindtypeREAL3: 1131 error = ffetarget_convert_integer4_complex3 1132 (ffebld_cu_ptr_integer4 (u), 1133 ffebld_constant_complex3 (ffebld_conter (l))); 1134 break; 1135#endif 1136 1137#if FFETARGET_okCOMPLEX4 1138 case FFEINFO_kindtypeREAL4: 1139 error = ffetarget_convert_integer4_complex4 1140 (ffebld_cu_ptr_integer4 (u), 1141 ffebld_constant_complex4 (ffebld_conter (l))); 1142 break; 1143#endif 1144 1145 default: 1146 assert ("INTEGER3/COMPLEX bad source kind type" == NULL); 1147 break; 1148 } 1149 break; 1150 1151 case FFEINFO_basictypeLOGICAL: 1152 switch (ffeinfo_kindtype (ffebld_info (l))) 1153 { 1154#if FFETARGET_okLOGICAL1 1155 case FFEINFO_kindtypeLOGICAL1: 1156 error = ffetarget_convert_integer4_logical1 1157 (ffebld_cu_ptr_integer4 (u), 1158 ffebld_constant_logical1 (ffebld_conter (l))); 1159 break; 1160#endif 1161 1162#if FFETARGET_okLOGICAL2 1163 case FFEINFO_kindtypeLOGICAL2: 1164 error = ffetarget_convert_integer4_logical2 1165 (ffebld_cu_ptr_integer4 (u), 1166 ffebld_constant_logical2 (ffebld_conter (l))); 1167 break; 1168#endif 1169 1170#if FFETARGET_okLOGICAL3 1171 case FFEINFO_kindtypeLOGICAL3: 1172 error = ffetarget_convert_integer4_logical3 1173 (ffebld_cu_ptr_integer4 (u), 1174 ffebld_constant_logical3 (ffebld_conter (l))); 1175 break; 1176#endif 1177 1178#if FFETARGET_okLOGICAL4 1179 case FFEINFO_kindtypeLOGICAL4: 1180 error = ffetarget_convert_integer4_logical4 1181 (ffebld_cu_ptr_integer4 (u), 1182 ffebld_constant_logical4 (ffebld_conter (l))); 1183 break; 1184#endif 1185 1186 default: 1187 assert ("INTEGER4/LOGICAL bad source kind type" == NULL); 1188 break; 1189 } 1190 break; 1191 1192 case FFEINFO_basictypeCHARACTER: 1193 error = ffetarget_convert_integer4_character1 1194 (ffebld_cu_ptr_integer4 (u), 1195 ffebld_constant_character1 (ffebld_conter (l))); 1196 break; 1197 1198 case FFEINFO_basictypeHOLLERITH: 1199 error = ffetarget_convert_integer4_hollerith 1200 (ffebld_cu_ptr_integer4 (u), 1201 ffebld_constant_hollerith (ffebld_conter (l))); 1202 break; 1203 1204 case FFEINFO_basictypeTYPELESS: 1205 error = ffetarget_convert_integer4_typeless 1206 (ffebld_cu_ptr_integer4 (u), 1207 ffebld_constant_typeless (ffebld_conter (l))); 1208 break; 1209 1210 default: 1211 assert ("INTEGER4 bad type" == NULL); 1212 break; 1213 } 1214 1215 /* If conversion operation is not implemented, return original expr. */ 1216 if (error == FFEBAD_NOCANDO) 1217 return expr; 1218 1219 expr = ffebld_new_conter_with_orig 1220 (ffebld_constant_new_integer4_val 1221 (ffebld_cu_val_integer4 (u)), expr); 1222 break; 1223#endif 1224 1225 default: 1226 assert ("bad integer kind type" == NULL); 1227 break; 1228 } 1229 break; 1230 1231 case FFEINFO_basictypeLOGICAL: 1232 sz = FFETARGET_charactersizeNONE; 1233 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 1234 { 1235#if FFETARGET_okLOGICAL1 1236 case FFEINFO_kindtypeLOGICAL1: 1237 switch (ffeinfo_basictype (ffebld_info (l))) 1238 { 1239 case FFEINFO_basictypeLOGICAL: 1240 switch (ffeinfo_kindtype (ffebld_info (l))) 1241 { 1242#if FFETARGET_okLOGICAL2 1243 case FFEINFO_kindtypeLOGICAL2: 1244 error = ffetarget_convert_logical1_logical2 1245 (ffebld_cu_ptr_logical1 (u), 1246 ffebld_constant_logical2 (ffebld_conter (l))); 1247 break; 1248#endif 1249 1250#if FFETARGET_okLOGICAL3 1251 case FFEINFO_kindtypeLOGICAL3: 1252 error = ffetarget_convert_logical1_logical3 1253 (ffebld_cu_ptr_logical1 (u), 1254 ffebld_constant_logical3 (ffebld_conter (l))); 1255 break; 1256#endif 1257 1258#if FFETARGET_okLOGICAL4 1259 case FFEINFO_kindtypeLOGICAL4: 1260 error = ffetarget_convert_logical1_logical4 1261 (ffebld_cu_ptr_logical1 (u), 1262 ffebld_constant_logical4 (ffebld_conter (l))); 1263 break; 1264#endif 1265 1266 default: 1267 assert ("LOGICAL1/LOGICAL bad source kind type" == NULL); 1268 break; 1269 } 1270 break; 1271 1272 case FFEINFO_basictypeINTEGER: 1273 switch (ffeinfo_kindtype (ffebld_info (l))) 1274 { 1275#if FFETARGET_okINTEGER1 1276 case FFEINFO_kindtypeINTEGER1: 1277 error = ffetarget_convert_logical1_integer1 1278 (ffebld_cu_ptr_logical1 (u), 1279 ffebld_constant_integer1 (ffebld_conter (l))); 1280 break; 1281#endif 1282 1283#if FFETARGET_okINTEGER2 1284 case FFEINFO_kindtypeINTEGER2: 1285 error = ffetarget_convert_logical1_integer2 1286 (ffebld_cu_ptr_logical1 (u), 1287 ffebld_constant_integer2 (ffebld_conter (l))); 1288 break; 1289#endif 1290 1291#if FFETARGET_okINTEGER3 1292 case FFEINFO_kindtypeINTEGER3: 1293 error = ffetarget_convert_logical1_integer3 1294 (ffebld_cu_ptr_logical1 (u), 1295 ffebld_constant_integer3 (ffebld_conter (l))); 1296 break; 1297#endif 1298 1299#if FFETARGET_okINTEGER4 1300 case FFEINFO_kindtypeINTEGER4: 1301 error = ffetarget_convert_logical1_integer4 1302 (ffebld_cu_ptr_logical1 (u), 1303 ffebld_constant_integer4 (ffebld_conter (l))); 1304 break; 1305#endif 1306 1307 default: 1308 assert ("LOGICAL1/INTEGER bad source kind type" == NULL); 1309 break; 1310 } 1311 break; 1312 1313 case FFEINFO_basictypeCHARACTER: 1314 error = ffetarget_convert_logical1_character1 1315 (ffebld_cu_ptr_logical1 (u), 1316 ffebld_constant_character1 (ffebld_conter (l))); 1317 break; 1318 1319 case FFEINFO_basictypeHOLLERITH: 1320 error = ffetarget_convert_logical1_hollerith 1321 (ffebld_cu_ptr_logical1 (u), 1322 ffebld_constant_hollerith (ffebld_conter (l))); 1323 break; 1324 1325 case FFEINFO_basictypeTYPELESS: 1326 error = ffetarget_convert_logical1_typeless 1327 (ffebld_cu_ptr_logical1 (u), 1328 ffebld_constant_typeless (ffebld_conter (l))); 1329 break; 1330 1331 default: 1332 assert ("LOGICAL1 bad type" == NULL); 1333 break; 1334 } 1335 1336 /* If conversion operation is not implemented, return original expr. */ 1337 if (error == FFEBAD_NOCANDO) 1338 return expr; 1339 1340 expr = ffebld_new_conter_with_orig 1341 (ffebld_constant_new_logical1_val 1342 (ffebld_cu_val_logical1 (u)), expr); 1343 break; 1344#endif 1345 1346#if FFETARGET_okLOGICAL2 1347 case FFEINFO_kindtypeLOGICAL2: 1348 switch (ffeinfo_basictype (ffebld_info (l))) 1349 { 1350 case FFEINFO_basictypeLOGICAL: 1351 switch (ffeinfo_kindtype (ffebld_info (l))) 1352 { 1353#if FFETARGET_okLOGICAL1 1354 case FFEINFO_kindtypeLOGICAL1: 1355 error = ffetarget_convert_logical2_logical1 1356 (ffebld_cu_ptr_logical2 (u), 1357 ffebld_constant_logical1 (ffebld_conter (l))); 1358 break; 1359#endif 1360 1361#if FFETARGET_okLOGICAL3 1362 case FFEINFO_kindtypeLOGICAL3: 1363 error = ffetarget_convert_logical2_logical3 1364 (ffebld_cu_ptr_logical2 (u), 1365 ffebld_constant_logical3 (ffebld_conter (l))); 1366 break; 1367#endif 1368 1369#if FFETARGET_okLOGICAL4 1370 case FFEINFO_kindtypeLOGICAL4: 1371 error = ffetarget_convert_logical2_logical4 1372 (ffebld_cu_ptr_logical2 (u), 1373 ffebld_constant_logical4 (ffebld_conter (l))); 1374 break; 1375#endif 1376 1377 default: 1378 assert ("LOGICAL2/LOGICAL bad source kind type" == NULL); 1379 break; 1380 } 1381 break; 1382 1383 case FFEINFO_basictypeINTEGER: 1384 switch (ffeinfo_kindtype (ffebld_info (l))) 1385 { 1386#if FFETARGET_okINTEGER1 1387 case FFEINFO_kindtypeINTEGER1: 1388 error = ffetarget_convert_logical2_integer1 1389 (ffebld_cu_ptr_logical2 (u), 1390 ffebld_constant_integer1 (ffebld_conter (l))); 1391 break; 1392#endif 1393 1394#if FFETARGET_okINTEGER2 1395 case FFEINFO_kindtypeINTEGER2: 1396 error = ffetarget_convert_logical2_integer2 1397 (ffebld_cu_ptr_logical2 (u), 1398 ffebld_constant_integer2 (ffebld_conter (l))); 1399 break; 1400#endif 1401 1402#if FFETARGET_okINTEGER3 1403 case FFEINFO_kindtypeINTEGER3: 1404 error = ffetarget_convert_logical2_integer3 1405 (ffebld_cu_ptr_logical2 (u), 1406 ffebld_constant_integer3 (ffebld_conter (l))); 1407 break; 1408#endif 1409 1410#if FFETARGET_okINTEGER4 1411 case FFEINFO_kindtypeINTEGER4: 1412 error = ffetarget_convert_logical2_integer4 1413 (ffebld_cu_ptr_logical2 (u), 1414 ffebld_constant_integer4 (ffebld_conter (l))); 1415 break; 1416#endif 1417 1418 default: 1419 assert ("LOGICAL2/INTEGER bad source kind type" == NULL); 1420 break; 1421 } 1422 break; 1423 1424 case FFEINFO_basictypeCHARACTER: 1425 error = ffetarget_convert_logical2_character1 1426 (ffebld_cu_ptr_logical2 (u), 1427 ffebld_constant_character1 (ffebld_conter (l))); 1428 break; 1429 1430 case FFEINFO_basictypeHOLLERITH: 1431 error = ffetarget_convert_logical2_hollerith 1432 (ffebld_cu_ptr_logical2 (u), 1433 ffebld_constant_hollerith (ffebld_conter (l))); 1434 break; 1435 1436 case FFEINFO_basictypeTYPELESS: 1437 error = ffetarget_convert_logical2_typeless 1438 (ffebld_cu_ptr_logical2 (u), 1439 ffebld_constant_typeless (ffebld_conter (l))); 1440 break; 1441 1442 default: 1443 assert ("LOGICAL2 bad type" == NULL); 1444 break; 1445 } 1446 1447 /* If conversion operation is not implemented, return original expr. */ 1448 if (error == FFEBAD_NOCANDO) 1449 return expr; 1450 1451 expr = ffebld_new_conter_with_orig 1452 (ffebld_constant_new_logical2_val 1453 (ffebld_cu_val_logical2 (u)), expr); 1454 break; 1455#endif 1456 1457#if FFETARGET_okLOGICAL3 1458 case FFEINFO_kindtypeLOGICAL3: 1459 switch (ffeinfo_basictype (ffebld_info (l))) 1460 { 1461 case FFEINFO_basictypeLOGICAL: 1462 switch (ffeinfo_kindtype (ffebld_info (l))) 1463 { 1464#if FFETARGET_okLOGICAL1 1465 case FFEINFO_kindtypeLOGICAL1: 1466 error = ffetarget_convert_logical3_logical1 1467 (ffebld_cu_ptr_logical3 (u), 1468 ffebld_constant_logical1 (ffebld_conter (l))); 1469 break; 1470#endif 1471 1472#if FFETARGET_okLOGICAL2 1473 case FFEINFO_kindtypeLOGICAL2: 1474 error = ffetarget_convert_logical3_logical2 1475 (ffebld_cu_ptr_logical3 (u), 1476 ffebld_constant_logical2 (ffebld_conter (l))); 1477 break; 1478#endif 1479 1480#if FFETARGET_okLOGICAL4 1481 case FFEINFO_kindtypeLOGICAL4: 1482 error = ffetarget_convert_logical3_logical4 1483 (ffebld_cu_ptr_logical3 (u), 1484 ffebld_constant_logical4 (ffebld_conter (l))); 1485 break; 1486#endif 1487 1488 default: 1489 assert ("LOGICAL3/LOGICAL bad source kind type" == NULL); 1490 break; 1491 } 1492 break; 1493 1494 case FFEINFO_basictypeINTEGER: 1495 switch (ffeinfo_kindtype (ffebld_info (l))) 1496 { 1497#if FFETARGET_okINTEGER1 1498 case FFEINFO_kindtypeINTEGER1: 1499 error = ffetarget_convert_logical3_integer1 1500 (ffebld_cu_ptr_logical3 (u), 1501 ffebld_constant_integer1 (ffebld_conter (l))); 1502 break; 1503#endif 1504 1505#if FFETARGET_okINTEGER2 1506 case FFEINFO_kindtypeINTEGER2: 1507 error = ffetarget_convert_logical3_integer2 1508 (ffebld_cu_ptr_logical3 (u), 1509 ffebld_constant_integer2 (ffebld_conter (l))); 1510 break; 1511#endif 1512 1513#if FFETARGET_okINTEGER3 1514 case FFEINFO_kindtypeINTEGER3: 1515 error = ffetarget_convert_logical3_integer3 1516 (ffebld_cu_ptr_logical3 (u), 1517 ffebld_constant_integer3 (ffebld_conter (l))); 1518 break; 1519#endif 1520 1521#if FFETARGET_okINTEGER4 1522 case FFEINFO_kindtypeINTEGER4: 1523 error = ffetarget_convert_logical3_integer4 1524 (ffebld_cu_ptr_logical3 (u), 1525 ffebld_constant_integer4 (ffebld_conter (l))); 1526 break; 1527#endif 1528 1529 default: 1530 assert ("LOGICAL3/INTEGER bad source kind type" == NULL); 1531 break; 1532 } 1533 break; 1534 1535 case FFEINFO_basictypeCHARACTER: 1536 error = ffetarget_convert_logical3_character1 1537 (ffebld_cu_ptr_logical3 (u), 1538 ffebld_constant_character1 (ffebld_conter (l))); 1539 break; 1540 1541 case FFEINFO_basictypeHOLLERITH: 1542 error = ffetarget_convert_logical3_hollerith 1543 (ffebld_cu_ptr_logical3 (u), 1544 ffebld_constant_hollerith (ffebld_conter (l))); 1545 break; 1546 1547 case FFEINFO_basictypeTYPELESS: 1548 error = ffetarget_convert_logical3_typeless 1549 (ffebld_cu_ptr_logical3 (u), 1550 ffebld_constant_typeless (ffebld_conter (l))); 1551 break; 1552 1553 default: 1554 assert ("LOGICAL3 bad type" == NULL); 1555 break; 1556 } 1557 1558 /* If conversion operation is not implemented, return original expr. */ 1559 if (error == FFEBAD_NOCANDO) 1560 return expr; 1561 1562 expr = ffebld_new_conter_with_orig 1563 (ffebld_constant_new_logical3_val 1564 (ffebld_cu_val_logical3 (u)), expr); 1565 break; 1566#endif 1567 1568#if FFETARGET_okLOGICAL4 1569 case FFEINFO_kindtypeLOGICAL4: 1570 switch (ffeinfo_basictype (ffebld_info (l))) 1571 { 1572 case FFEINFO_basictypeLOGICAL: 1573 switch (ffeinfo_kindtype (ffebld_info (l))) 1574 { 1575#if FFETARGET_okLOGICAL1 1576 case FFEINFO_kindtypeLOGICAL1: 1577 error = ffetarget_convert_logical4_logical1 1578 (ffebld_cu_ptr_logical4 (u), 1579 ffebld_constant_logical1 (ffebld_conter (l))); 1580 break; 1581#endif 1582 1583#if FFETARGET_okLOGICAL2 1584 case FFEINFO_kindtypeLOGICAL2: 1585 error = ffetarget_convert_logical4_logical2 1586 (ffebld_cu_ptr_logical4 (u), 1587 ffebld_constant_logical2 (ffebld_conter (l))); 1588 break; 1589#endif 1590 1591#if FFETARGET_okLOGICAL3 1592 case FFEINFO_kindtypeLOGICAL3: 1593 error = ffetarget_convert_logical4_logical3 1594 (ffebld_cu_ptr_logical4 (u), 1595 ffebld_constant_logical3 (ffebld_conter (l))); 1596 break; 1597#endif 1598 1599 default: 1600 assert ("LOGICAL4/LOGICAL bad source kind type" == NULL); 1601 break; 1602 } 1603 break; 1604 1605 case FFEINFO_basictypeINTEGER: 1606 switch (ffeinfo_kindtype (ffebld_info (l))) 1607 { 1608#if FFETARGET_okINTEGER1 1609 case FFEINFO_kindtypeINTEGER1: 1610 error = ffetarget_convert_logical4_integer1 1611 (ffebld_cu_ptr_logical4 (u), 1612 ffebld_constant_integer1 (ffebld_conter (l))); 1613 break; 1614#endif 1615 1616#if FFETARGET_okINTEGER2 1617 case FFEINFO_kindtypeINTEGER2: 1618 error = ffetarget_convert_logical4_integer2 1619 (ffebld_cu_ptr_logical4 (u), 1620 ffebld_constant_integer2 (ffebld_conter (l))); 1621 break; 1622#endif 1623 1624#if FFETARGET_okINTEGER3 1625 case FFEINFO_kindtypeINTEGER3: 1626 error = ffetarget_convert_logical4_integer3 1627 (ffebld_cu_ptr_logical4 (u), 1628 ffebld_constant_integer3 (ffebld_conter (l))); 1629 break; 1630#endif 1631 1632#if FFETARGET_okINTEGER4 1633 case FFEINFO_kindtypeINTEGER4: 1634 error = ffetarget_convert_logical4_integer4 1635 (ffebld_cu_ptr_logical4 (u), 1636 ffebld_constant_integer4 (ffebld_conter (l))); 1637 break; 1638#endif 1639 1640 default: 1641 assert ("LOGICAL4/INTEGER bad source kind type" == NULL); 1642 break; 1643 } 1644 break; 1645 1646 case FFEINFO_basictypeCHARACTER: 1647 error = ffetarget_convert_logical4_character1 1648 (ffebld_cu_ptr_logical4 (u), 1649 ffebld_constant_character1 (ffebld_conter (l))); 1650 break; 1651 1652 case FFEINFO_basictypeHOLLERITH: 1653 error = ffetarget_convert_logical4_hollerith 1654 (ffebld_cu_ptr_logical4 (u), 1655 ffebld_constant_hollerith (ffebld_conter (l))); 1656 break; 1657 1658 case FFEINFO_basictypeTYPELESS: 1659 error = ffetarget_convert_logical4_typeless 1660 (ffebld_cu_ptr_logical4 (u), 1661 ffebld_constant_typeless (ffebld_conter (l))); 1662 break; 1663 1664 default: 1665 assert ("LOGICAL4 bad type" == NULL); 1666 break; 1667 } 1668 1669 /* If conversion operation is not implemented, return original expr. */ 1670 if (error == FFEBAD_NOCANDO) 1671 return expr; 1672 1673 expr = ffebld_new_conter_with_orig 1674 (ffebld_constant_new_logical4_val 1675 (ffebld_cu_val_logical4 (u)), expr); 1676 break; 1677#endif 1678 1679 default: 1680 assert ("bad logical kind type" == NULL); 1681 break; 1682 } 1683 break; 1684 1685 case FFEINFO_basictypeREAL: 1686 sz = FFETARGET_charactersizeNONE; 1687 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 1688 { 1689#if FFETARGET_okREAL1 1690 case FFEINFO_kindtypeREAL1: 1691 switch (ffeinfo_basictype (ffebld_info (l))) 1692 { 1693 case FFEINFO_basictypeINTEGER: 1694 switch (ffeinfo_kindtype (ffebld_info (l))) 1695 { 1696#if FFETARGET_okINTEGER1 1697 case FFEINFO_kindtypeINTEGER1: 1698 error = ffetarget_convert_real1_integer1 1699 (ffebld_cu_ptr_real1 (u), 1700 ffebld_constant_integer1 (ffebld_conter (l))); 1701 break; 1702#endif 1703 1704#if FFETARGET_okINTEGER2 1705 case FFEINFO_kindtypeINTEGER2: 1706 error = ffetarget_convert_real1_integer2 1707 (ffebld_cu_ptr_real1 (u), 1708 ffebld_constant_integer2 (ffebld_conter (l))); 1709 break; 1710#endif 1711 1712#if FFETARGET_okINTEGER3 1713 case FFEINFO_kindtypeINTEGER3: 1714 error = ffetarget_convert_real1_integer3 1715 (ffebld_cu_ptr_real1 (u), 1716 ffebld_constant_integer3 (ffebld_conter (l))); 1717 break; 1718#endif 1719 1720#if FFETARGET_okINTEGER4 1721 case FFEINFO_kindtypeINTEGER4: 1722 error = ffetarget_convert_real1_integer4 1723 (ffebld_cu_ptr_real1 (u), 1724 ffebld_constant_integer4 (ffebld_conter (l))); 1725 break; 1726#endif 1727 1728 default: 1729 assert ("REAL1/INTEGER bad source kind type" == NULL); 1730 break; 1731 } 1732 break; 1733 1734 case FFEINFO_basictypeREAL: 1735 switch (ffeinfo_kindtype (ffebld_info (l))) 1736 { 1737#if FFETARGET_okREAL2 1738 case FFEINFO_kindtypeREAL2: 1739 error = ffetarget_convert_real1_real2 1740 (ffebld_cu_ptr_real1 (u), 1741 ffebld_constant_real2 (ffebld_conter (l))); 1742 break; 1743#endif 1744 1745#if FFETARGET_okREAL3 1746 case FFEINFO_kindtypeREAL3: 1747 error = ffetarget_convert_real1_real3 1748 (ffebld_cu_ptr_real1 (u), 1749 ffebld_constant_real3 (ffebld_conter (l))); 1750 break; 1751#endif 1752 1753#if FFETARGET_okREAL4 1754 case FFEINFO_kindtypeREAL4: 1755 error = ffetarget_convert_real1_real4 1756 (ffebld_cu_ptr_real1 (u), 1757 ffebld_constant_real4 (ffebld_conter (l))); 1758 break; 1759#endif 1760 1761 default: 1762 assert ("REAL1/REAL bad source kind type" == NULL); 1763 break; 1764 } 1765 break; 1766 1767 case FFEINFO_basictypeCOMPLEX: 1768 switch (ffeinfo_kindtype (ffebld_info (l))) 1769 { 1770#if FFETARGET_okCOMPLEX1 1771 case FFEINFO_kindtypeREAL1: 1772 error = ffetarget_convert_real1_complex1 1773 (ffebld_cu_ptr_real1 (u), 1774 ffebld_constant_complex1 (ffebld_conter (l))); 1775 break; 1776#endif 1777 1778#if FFETARGET_okCOMPLEX2 1779 case FFEINFO_kindtypeREAL2: 1780 error = ffetarget_convert_real1_complex2 1781 (ffebld_cu_ptr_real1 (u), 1782 ffebld_constant_complex2 (ffebld_conter (l))); 1783 break; 1784#endif 1785 1786#if FFETARGET_okCOMPLEX3 1787 case FFEINFO_kindtypeREAL3: 1788 error = ffetarget_convert_real1_complex3 1789 (ffebld_cu_ptr_real1 (u), 1790 ffebld_constant_complex3 (ffebld_conter (l))); 1791 break; 1792#endif 1793 1794#if FFETARGET_okCOMPLEX4 1795 case FFEINFO_kindtypeREAL4: 1796 error = ffetarget_convert_real1_complex4 1797 (ffebld_cu_ptr_real1 (u), 1798 ffebld_constant_complex4 (ffebld_conter (l))); 1799 break; 1800#endif 1801 1802 default: 1803 assert ("REAL1/COMPLEX bad source kind type" == NULL); 1804 break; 1805 } 1806 break; 1807 1808 case FFEINFO_basictypeCHARACTER: 1809 error = ffetarget_convert_real1_character1 1810 (ffebld_cu_ptr_real1 (u), 1811 ffebld_constant_character1 (ffebld_conter (l))); 1812 break; 1813 1814 case FFEINFO_basictypeHOLLERITH: 1815 error = ffetarget_convert_real1_hollerith 1816 (ffebld_cu_ptr_real1 (u), 1817 ffebld_constant_hollerith (ffebld_conter (l))); 1818 break; 1819 1820 case FFEINFO_basictypeTYPELESS: 1821 error = ffetarget_convert_real1_typeless 1822 (ffebld_cu_ptr_real1 (u), 1823 ffebld_constant_typeless (ffebld_conter (l))); 1824 break; 1825 1826 default: 1827 assert ("REAL1 bad type" == NULL); 1828 break; 1829 } 1830 1831 /* If conversion operation is not implemented, return original expr. */ 1832 if (error == FFEBAD_NOCANDO) 1833 return expr; 1834 1835 expr = ffebld_new_conter_with_orig 1836 (ffebld_constant_new_real1_val 1837 (ffebld_cu_val_real1 (u)), expr); 1838 break; 1839#endif 1840 1841#if FFETARGET_okREAL2 1842 case FFEINFO_kindtypeREAL2: 1843 switch (ffeinfo_basictype (ffebld_info (l))) 1844 { 1845 case FFEINFO_basictypeINTEGER: 1846 switch (ffeinfo_kindtype (ffebld_info (l))) 1847 { 1848#if FFETARGET_okINTEGER1 1849 case FFEINFO_kindtypeINTEGER1: 1850 error = ffetarget_convert_real2_integer1 1851 (ffebld_cu_ptr_real2 (u), 1852 ffebld_constant_integer1 (ffebld_conter (l))); 1853 break; 1854#endif 1855 1856#if FFETARGET_okINTEGER2 1857 case FFEINFO_kindtypeINTEGER2: 1858 error = ffetarget_convert_real2_integer2 1859 (ffebld_cu_ptr_real2 (u), 1860 ffebld_constant_integer2 (ffebld_conter (l))); 1861 break; 1862#endif 1863 1864#if FFETARGET_okINTEGER3 1865 case FFEINFO_kindtypeINTEGER3: 1866 error = ffetarget_convert_real2_integer3 1867 (ffebld_cu_ptr_real2 (u), 1868 ffebld_constant_integer3 (ffebld_conter (l))); 1869 break; 1870#endif 1871 1872#if FFETARGET_okINTEGER4 1873 case FFEINFO_kindtypeINTEGER4: 1874 error = ffetarget_convert_real2_integer4 1875 (ffebld_cu_ptr_real2 (u), 1876 ffebld_constant_integer4 (ffebld_conter (l))); 1877 break; 1878#endif 1879 1880 default: 1881 assert ("REAL2/INTEGER bad source kind type" == NULL); 1882 break; 1883 } 1884 break; 1885 1886 case FFEINFO_basictypeREAL: 1887 switch (ffeinfo_kindtype (ffebld_info (l))) 1888 { 1889#if FFETARGET_okREAL1 1890 case FFEINFO_kindtypeREAL1: 1891 error = ffetarget_convert_real2_real1 1892 (ffebld_cu_ptr_real2 (u), 1893 ffebld_constant_real1 (ffebld_conter (l))); 1894 break; 1895#endif 1896 1897#if FFETARGET_okREAL3 1898 case FFEINFO_kindtypeREAL3: 1899 error = ffetarget_convert_real2_real3 1900 (ffebld_cu_ptr_real2 (u), 1901 ffebld_constant_real3 (ffebld_conter (l))); 1902 break; 1903#endif 1904 1905#if FFETARGET_okREAL4 1906 case FFEINFO_kindtypeREAL4: 1907 error = ffetarget_convert_real2_real4 1908 (ffebld_cu_ptr_real2 (u), 1909 ffebld_constant_real4 (ffebld_conter (l))); 1910 break; 1911#endif 1912 1913 default: 1914 assert ("REAL2/REAL bad source kind type" == NULL); 1915 break; 1916 } 1917 break; 1918 1919 case FFEINFO_basictypeCOMPLEX: 1920 switch (ffeinfo_kindtype (ffebld_info (l))) 1921 { 1922#if FFETARGET_okCOMPLEX1 1923 case FFEINFO_kindtypeREAL1: 1924 error = ffetarget_convert_real2_complex1 1925 (ffebld_cu_ptr_real2 (u), 1926 ffebld_constant_complex1 (ffebld_conter (l))); 1927 break; 1928#endif 1929 1930#if FFETARGET_okCOMPLEX2 1931 case FFEINFO_kindtypeREAL2: 1932 error = ffetarget_convert_real2_complex2 1933 (ffebld_cu_ptr_real2 (u), 1934 ffebld_constant_complex2 (ffebld_conter (l))); 1935 break; 1936#endif 1937 1938#if FFETARGET_okCOMPLEX3 1939 case FFEINFO_kindtypeREAL3: 1940 error = ffetarget_convert_real2_complex3 1941 (ffebld_cu_ptr_real2 (u), 1942 ffebld_constant_complex3 (ffebld_conter (l))); 1943 break; 1944#endif 1945 1946#if FFETARGET_okCOMPLEX4 1947 case FFEINFO_kindtypeREAL4: 1948 error = ffetarget_convert_real2_complex4 1949 (ffebld_cu_ptr_real2 (u), 1950 ffebld_constant_complex4 (ffebld_conter (l))); 1951 break; 1952#endif 1953 1954 default: 1955 assert ("REAL2/COMPLEX bad source kind type" == NULL); 1956 break; 1957 } 1958 break; 1959 1960 case FFEINFO_basictypeCHARACTER: 1961 error = ffetarget_convert_real2_character1 1962 (ffebld_cu_ptr_real2 (u), 1963 ffebld_constant_character1 (ffebld_conter (l))); 1964 break; 1965 1966 case FFEINFO_basictypeHOLLERITH: 1967 error = ffetarget_convert_real2_hollerith 1968 (ffebld_cu_ptr_real2 (u), 1969 ffebld_constant_hollerith (ffebld_conter (l))); 1970 break; 1971 1972 case FFEINFO_basictypeTYPELESS: 1973 error = ffetarget_convert_real2_typeless 1974 (ffebld_cu_ptr_real2 (u), 1975 ffebld_constant_typeless (ffebld_conter (l))); 1976 break; 1977 1978 default: 1979 assert ("REAL2 bad type" == NULL); 1980 break; 1981 } 1982 1983 /* If conversion operation is not implemented, return original expr. */ 1984 if (error == FFEBAD_NOCANDO) 1985 return expr; 1986 1987 expr = ffebld_new_conter_with_orig 1988 (ffebld_constant_new_real2_val 1989 (ffebld_cu_val_real2 (u)), expr); 1990 break; 1991#endif 1992 1993#if FFETARGET_okREAL3 1994 case FFEINFO_kindtypeREAL3: 1995 switch (ffeinfo_basictype (ffebld_info (l))) 1996 { 1997 case FFEINFO_basictypeINTEGER: 1998 switch (ffeinfo_kindtype (ffebld_info (l))) 1999 { 2000#if FFETARGET_okINTEGER1 2001 case FFEINFO_kindtypeINTEGER1: 2002 error = ffetarget_convert_real3_integer1 2003 (ffebld_cu_ptr_real3 (u), 2004 ffebld_constant_integer1 (ffebld_conter (l))); 2005 break; 2006#endif 2007 2008#if FFETARGET_okINTEGER2 2009 case FFEINFO_kindtypeINTEGER2: 2010 error = ffetarget_convert_real3_integer2 2011 (ffebld_cu_ptr_real3 (u), 2012 ffebld_constant_integer2 (ffebld_conter (l))); 2013 break; 2014#endif 2015 2016#if FFETARGET_okINTEGER3 2017 case FFEINFO_kindtypeINTEGER3: 2018 error = ffetarget_convert_real3_integer3 2019 (ffebld_cu_ptr_real3 (u), 2020 ffebld_constant_integer3 (ffebld_conter (l))); 2021 break; 2022#endif 2023 2024#if FFETARGET_okINTEGER4 2025 case FFEINFO_kindtypeINTEGER4: 2026 error = ffetarget_convert_real3_integer4 2027 (ffebld_cu_ptr_real3 (u), 2028 ffebld_constant_integer4 (ffebld_conter (l))); 2029 break; 2030#endif 2031 2032 default: 2033 assert ("REAL3/INTEGER bad source kind type" == NULL); 2034 break; 2035 } 2036 break; 2037 2038 case FFEINFO_basictypeREAL: 2039 switch (ffeinfo_kindtype (ffebld_info (l))) 2040 { 2041#if FFETARGET_okREAL1 2042 case FFEINFO_kindtypeREAL1: 2043 error = ffetarget_convert_real3_real1 2044 (ffebld_cu_ptr_real3 (u), 2045 ffebld_constant_real1 (ffebld_conter (l))); 2046 break; 2047#endif 2048 2049#if FFETARGET_okREAL2 2050 case FFEINFO_kindtypeREAL2: 2051 error = ffetarget_convert_real3_real2 2052 (ffebld_cu_ptr_real3 (u), 2053 ffebld_constant_real2 (ffebld_conter (l))); 2054 break; 2055#endif 2056 2057#if FFETARGET_okREAL4 2058 case FFEINFO_kindtypeREAL4: 2059 error = ffetarget_convert_real3_real4 2060 (ffebld_cu_ptr_real3 (u), 2061 ffebld_constant_real4 (ffebld_conter (l))); 2062 break; 2063#endif 2064 2065 default: 2066 assert ("REAL3/REAL bad source kind type" == NULL); 2067 break; 2068 } 2069 break; 2070 2071 case FFEINFO_basictypeCOMPLEX: 2072 switch (ffeinfo_kindtype (ffebld_info (l))) 2073 { 2074#if FFETARGET_okCOMPLEX1 2075 case FFEINFO_kindtypeREAL1: 2076 error = ffetarget_convert_real3_complex1 2077 (ffebld_cu_ptr_real3 (u), 2078 ffebld_constant_complex1 (ffebld_conter (l))); 2079 break; 2080#endif 2081 2082#if FFETARGET_okCOMPLEX2 2083 case FFEINFO_kindtypeREAL2: 2084 error = ffetarget_convert_real3_complex2 2085 (ffebld_cu_ptr_real3 (u), 2086 ffebld_constant_complex2 (ffebld_conter (l))); 2087 break; 2088#endif 2089 2090#if FFETARGET_okCOMPLEX3 2091 case FFEINFO_kindtypeREAL3: 2092 error = ffetarget_convert_real3_complex3 2093 (ffebld_cu_ptr_real3 (u), 2094 ffebld_constant_complex3 (ffebld_conter (l))); 2095 break; 2096#endif 2097 2098#if FFETARGET_okCOMPLEX4 2099 case FFEINFO_kindtypeREAL4: 2100 error = ffetarget_convert_real3_complex4 2101 (ffebld_cu_ptr_real3 (u), 2102 ffebld_constant_complex4 (ffebld_conter (l))); 2103 break; 2104#endif 2105 2106 default: 2107 assert ("REAL3/COMPLEX bad source kind type" == NULL); 2108 break; 2109 } 2110 break; 2111 2112 case FFEINFO_basictypeCHARACTER: 2113 error = ffetarget_convert_real3_character1 2114 (ffebld_cu_ptr_real3 (u), 2115 ffebld_constant_character1 (ffebld_conter (l))); 2116 break; 2117 2118 case FFEINFO_basictypeHOLLERITH: 2119 error = ffetarget_convert_real3_hollerith 2120 (ffebld_cu_ptr_real3 (u), 2121 ffebld_constant_hollerith (ffebld_conter (l))); 2122 break; 2123 2124 case FFEINFO_basictypeTYPELESS: 2125 error = ffetarget_convert_real3_typeless 2126 (ffebld_cu_ptr_real3 (u), 2127 ffebld_constant_typeless (ffebld_conter (l))); 2128 break; 2129 2130 default: 2131 assert ("REAL3 bad type" == NULL); 2132 break; 2133 } 2134 2135 /* If conversion operation is not implemented, return original expr. */ 2136 if (error == FFEBAD_NOCANDO) 2137 return expr; 2138 2139 expr = ffebld_new_conter_with_orig 2140 (ffebld_constant_new_real3_val 2141 (ffebld_cu_val_real3 (u)), expr); 2142 break; 2143#endif 2144 2145#if FFETARGET_okREAL4 2146 case FFEINFO_kindtypeREAL4: 2147 switch (ffeinfo_basictype (ffebld_info (l))) 2148 { 2149 case FFEINFO_basictypeINTEGER: 2150 switch (ffeinfo_kindtype (ffebld_info (l))) 2151 { 2152#if FFETARGET_okINTEGER1 2153 case FFEINFO_kindtypeINTEGER1: 2154 error = ffetarget_convert_real4_integer1 2155 (ffebld_cu_ptr_real4 (u), 2156 ffebld_constant_integer1 (ffebld_conter (l))); 2157 break; 2158#endif 2159 2160#if FFETARGET_okINTEGER2 2161 case FFEINFO_kindtypeINTEGER2: 2162 error = ffetarget_convert_real4_integer2 2163 (ffebld_cu_ptr_real4 (u), 2164 ffebld_constant_integer2 (ffebld_conter (l))); 2165 break; 2166#endif 2167 2168#if FFETARGET_okINTEGER3 2169 case FFEINFO_kindtypeINTEGER3: 2170 error = ffetarget_convert_real4_integer3 2171 (ffebld_cu_ptr_real4 (u), 2172 ffebld_constant_integer3 (ffebld_conter (l))); 2173 break; 2174#endif 2175 2176#if FFETARGET_okINTEGER4 2177 case FFEINFO_kindtypeINTEGER4: 2178 error = ffetarget_convert_real4_integer4 2179 (ffebld_cu_ptr_real4 (u), 2180 ffebld_constant_integer4 (ffebld_conter (l))); 2181 break; 2182#endif 2183 2184 default: 2185 assert ("REAL4/INTEGER bad source kind type" == NULL); 2186 break; 2187 } 2188 break; 2189 2190 case FFEINFO_basictypeREAL: 2191 switch (ffeinfo_kindtype (ffebld_info (l))) 2192 { 2193#if FFETARGET_okREAL1 2194 case FFEINFO_kindtypeREAL1: 2195 error = ffetarget_convert_real4_real1 2196 (ffebld_cu_ptr_real4 (u), 2197 ffebld_constant_real1 (ffebld_conter (l))); 2198 break; 2199#endif 2200 2201#if FFETARGET_okREAL2 2202 case FFEINFO_kindtypeREAL2: 2203 error = ffetarget_convert_real4_real2 2204 (ffebld_cu_ptr_real4 (u), 2205 ffebld_constant_real2 (ffebld_conter (l))); 2206 break; 2207#endif 2208 2209#if FFETARGET_okREAL3 2210 case FFEINFO_kindtypeREAL3: 2211 error = ffetarget_convert_real4_real3 2212 (ffebld_cu_ptr_real4 (u), 2213 ffebld_constant_real3 (ffebld_conter (l))); 2214 break; 2215#endif 2216 2217 default: 2218 assert ("REAL4/REAL bad source kind type" == NULL); 2219 break; 2220 } 2221 break; 2222 2223 case FFEINFO_basictypeCOMPLEX: 2224 switch (ffeinfo_kindtype (ffebld_info (l))) 2225 { 2226#if FFETARGET_okCOMPLEX1 2227 case FFEINFO_kindtypeREAL1: 2228 error = ffetarget_convert_real4_complex1 2229 (ffebld_cu_ptr_real4 (u), 2230 ffebld_constant_complex1 (ffebld_conter (l))); 2231 break; 2232#endif 2233 2234#if FFETARGET_okCOMPLEX2 2235 case FFEINFO_kindtypeREAL2: 2236 error = ffetarget_convert_real4_complex2 2237 (ffebld_cu_ptr_real4 (u), 2238 ffebld_constant_complex2 (ffebld_conter (l))); 2239 break; 2240#endif 2241 2242#if FFETARGET_okCOMPLEX3 2243 case FFEINFO_kindtypeREAL3: 2244 error = ffetarget_convert_real4_complex3 2245 (ffebld_cu_ptr_real4 (u), 2246 ffebld_constant_complex3 (ffebld_conter (l))); 2247 break; 2248#endif 2249 2250#if FFETARGET_okCOMPLEX4 2251 case FFEINFO_kindtypeREAL4: 2252 error = ffetarget_convert_real4_complex4 2253 (ffebld_cu_ptr_real4 (u), 2254 ffebld_constant_complex4 (ffebld_conter (l))); 2255 break; 2256#endif 2257 2258 default: 2259 assert ("REAL4/COMPLEX bad source kind type" == NULL); 2260 break; 2261 } 2262 break; 2263 2264 case FFEINFO_basictypeCHARACTER: 2265 error = ffetarget_convert_real4_character1 2266 (ffebld_cu_ptr_real4 (u), 2267 ffebld_constant_character1 (ffebld_conter (l))); 2268 break; 2269 2270 case FFEINFO_basictypeHOLLERITH: 2271 error = ffetarget_convert_real4_hollerith 2272 (ffebld_cu_ptr_real4 (u), 2273 ffebld_constant_hollerith (ffebld_conter (l))); 2274 break; 2275 2276 case FFEINFO_basictypeTYPELESS: 2277 error = ffetarget_convert_real4_typeless 2278 (ffebld_cu_ptr_real4 (u), 2279 ffebld_constant_typeless (ffebld_conter (l))); 2280 break; 2281 2282 default: 2283 assert ("REAL4 bad type" == NULL); 2284 break; 2285 } 2286 2287 /* If conversion operation is not implemented, return original expr. */ 2288 if (error == FFEBAD_NOCANDO) 2289 return expr; 2290 2291 expr = ffebld_new_conter_with_orig 2292 (ffebld_constant_new_real4_val 2293 (ffebld_cu_val_real4 (u)), expr); 2294 break; 2295#endif 2296 2297 default: 2298 assert ("bad real kind type" == NULL); 2299 break; 2300 } 2301 break; 2302 2303 case FFEINFO_basictypeCOMPLEX: 2304 sz = FFETARGET_charactersizeNONE; 2305 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 2306 { 2307#if FFETARGET_okCOMPLEX1 2308 case FFEINFO_kindtypeREAL1: 2309 switch (ffeinfo_basictype (ffebld_info (l))) 2310 { 2311 case FFEINFO_basictypeINTEGER: 2312 switch (ffeinfo_kindtype (ffebld_info (l))) 2313 { 2314#if FFETARGET_okINTEGER1 2315 case FFEINFO_kindtypeINTEGER1: 2316 error = ffetarget_convert_complex1_integer1 2317 (ffebld_cu_ptr_complex1 (u), 2318 ffebld_constant_integer1 (ffebld_conter (l))); 2319 break; 2320#endif 2321 2322#if FFETARGET_okINTEGER2 2323 case FFEINFO_kindtypeINTEGER2: 2324 error = ffetarget_convert_complex1_integer2 2325 (ffebld_cu_ptr_complex1 (u), 2326 ffebld_constant_integer2 (ffebld_conter (l))); 2327 break; 2328#endif 2329 2330#if FFETARGET_okINTEGER3 2331 case FFEINFO_kindtypeINTEGER3: 2332 error = ffetarget_convert_complex1_integer3 2333 (ffebld_cu_ptr_complex1 (u), 2334 ffebld_constant_integer3 (ffebld_conter (l))); 2335 break; 2336#endif 2337 2338#if FFETARGET_okINTEGER4 2339 case FFEINFO_kindtypeINTEGER4: 2340 error = ffetarget_convert_complex1_integer4 2341 (ffebld_cu_ptr_complex1 (u), 2342 ffebld_constant_integer4 (ffebld_conter (l))); 2343 break; 2344#endif 2345 2346 default: 2347 assert ("COMPLEX1/INTEGER bad source kind type" == NULL); 2348 break; 2349 } 2350 break; 2351 2352 case FFEINFO_basictypeREAL: 2353 switch (ffeinfo_kindtype (ffebld_info (l))) 2354 { 2355#if FFETARGET_okREAL1 2356 case FFEINFO_kindtypeREAL1: 2357 error = ffetarget_convert_complex1_real1 2358 (ffebld_cu_ptr_complex1 (u), 2359 ffebld_constant_real1 (ffebld_conter (l))); 2360 break; 2361#endif 2362 2363#if FFETARGET_okREAL2 2364 case FFEINFO_kindtypeREAL2: 2365 error = ffetarget_convert_complex1_real2 2366 (ffebld_cu_ptr_complex1 (u), 2367 ffebld_constant_real2 (ffebld_conter (l))); 2368 break; 2369#endif 2370 2371#if FFETARGET_okREAL3 2372 case FFEINFO_kindtypeREAL3: 2373 error = ffetarget_convert_complex1_real3 2374 (ffebld_cu_ptr_complex1 (u), 2375 ffebld_constant_real3 (ffebld_conter (l))); 2376 break; 2377#endif 2378 2379#if FFETARGET_okREAL4 2380 case FFEINFO_kindtypeREAL4: 2381 error = ffetarget_convert_complex1_real4 2382 (ffebld_cu_ptr_complex1 (u), 2383 ffebld_constant_real4 (ffebld_conter (l))); 2384 break; 2385#endif 2386 2387 default: 2388 assert ("COMPLEX1/REAL bad source kind type" == NULL); 2389 break; 2390 } 2391 break; 2392 2393 case FFEINFO_basictypeCOMPLEX: 2394 switch (ffeinfo_kindtype (ffebld_info (l))) 2395 { 2396#if FFETARGET_okCOMPLEX2 2397 case FFEINFO_kindtypeREAL2: 2398 error = ffetarget_convert_complex1_complex2 2399 (ffebld_cu_ptr_complex1 (u), 2400 ffebld_constant_complex2 (ffebld_conter (l))); 2401 break; 2402#endif 2403 2404#if FFETARGET_okCOMPLEX3 2405 case FFEINFO_kindtypeREAL3: 2406 error = ffetarget_convert_complex1_complex3 2407 (ffebld_cu_ptr_complex1 (u), 2408 ffebld_constant_complex3 (ffebld_conter (l))); 2409 break; 2410#endif 2411 2412#if FFETARGET_okCOMPLEX4 2413 case FFEINFO_kindtypeREAL4: 2414 error = ffetarget_convert_complex1_complex4 2415 (ffebld_cu_ptr_complex1 (u), 2416 ffebld_constant_complex4 (ffebld_conter (l))); 2417 break; 2418#endif 2419 2420 default: 2421 assert ("COMPLEX1/COMPLEX bad source kind type" == NULL); 2422 break; 2423 } 2424 break; 2425 2426 case FFEINFO_basictypeCHARACTER: 2427 error = ffetarget_convert_complex1_character1 2428 (ffebld_cu_ptr_complex1 (u), 2429 ffebld_constant_character1 (ffebld_conter (l))); 2430 break; 2431 2432 case FFEINFO_basictypeHOLLERITH: 2433 error = ffetarget_convert_complex1_hollerith 2434 (ffebld_cu_ptr_complex1 (u), 2435 ffebld_constant_hollerith (ffebld_conter (l))); 2436 break; 2437 2438 case FFEINFO_basictypeTYPELESS: 2439 error = ffetarget_convert_complex1_typeless 2440 (ffebld_cu_ptr_complex1 (u), 2441 ffebld_constant_typeless (ffebld_conter (l))); 2442 break; 2443 2444 default: 2445 assert ("COMPLEX1 bad type" == NULL); 2446 break; 2447 } 2448 2449 /* If conversion operation is not implemented, return original expr. */ 2450 if (error == FFEBAD_NOCANDO) 2451 return expr; 2452 2453 expr = ffebld_new_conter_with_orig 2454 (ffebld_constant_new_complex1_val 2455 (ffebld_cu_val_complex1 (u)), expr); 2456 break; 2457#endif 2458 2459#if FFETARGET_okCOMPLEX2 2460 case FFEINFO_kindtypeREAL2: 2461 switch (ffeinfo_basictype (ffebld_info (l))) 2462 { 2463 case FFEINFO_basictypeINTEGER: 2464 switch (ffeinfo_kindtype (ffebld_info (l))) 2465 { 2466#if FFETARGET_okINTEGER1 2467 case FFEINFO_kindtypeINTEGER1: 2468 error = ffetarget_convert_complex2_integer1 2469 (ffebld_cu_ptr_complex2 (u), 2470 ffebld_constant_integer1 (ffebld_conter (l))); 2471 break; 2472#endif 2473 2474#if FFETARGET_okINTEGER2 2475 case FFEINFO_kindtypeINTEGER2: 2476 error = ffetarget_convert_complex2_integer2 2477 (ffebld_cu_ptr_complex2 (u), 2478 ffebld_constant_integer2 (ffebld_conter (l))); 2479 break; 2480#endif 2481 2482#if FFETARGET_okINTEGER3 2483 case FFEINFO_kindtypeINTEGER3: 2484 error = ffetarget_convert_complex2_integer3 2485 (ffebld_cu_ptr_complex2 (u), 2486 ffebld_constant_integer3 (ffebld_conter (l))); 2487 break; 2488#endif 2489 2490#if FFETARGET_okINTEGER4 2491 case FFEINFO_kindtypeINTEGER4: 2492 error = ffetarget_convert_complex2_integer4 2493 (ffebld_cu_ptr_complex2 (u), 2494 ffebld_constant_integer4 (ffebld_conter (l))); 2495 break; 2496#endif 2497 2498 default: 2499 assert ("COMPLEX2/INTEGER bad source kind type" == NULL); 2500 break; 2501 } 2502 break; 2503 2504 case FFEINFO_basictypeREAL: 2505 switch (ffeinfo_kindtype (ffebld_info (l))) 2506 { 2507#if FFETARGET_okREAL1 2508 case FFEINFO_kindtypeREAL1: 2509 error = ffetarget_convert_complex2_real1 2510 (ffebld_cu_ptr_complex2 (u), 2511 ffebld_constant_real1 (ffebld_conter (l))); 2512 break; 2513#endif 2514 2515#if FFETARGET_okREAL2 2516 case FFEINFO_kindtypeREAL2: 2517 error = ffetarget_convert_complex2_real2 2518 (ffebld_cu_ptr_complex2 (u), 2519 ffebld_constant_real2 (ffebld_conter (l))); 2520 break; 2521#endif 2522 2523#if FFETARGET_okREAL3 2524 case FFEINFO_kindtypeREAL3: 2525 error = ffetarget_convert_complex2_real3 2526 (ffebld_cu_ptr_complex2 (u), 2527 ffebld_constant_real3 (ffebld_conter (l))); 2528 break; 2529#endif 2530 2531#if FFETARGET_okREAL4 2532 case FFEINFO_kindtypeREAL4: 2533 error = ffetarget_convert_complex2_real4 2534 (ffebld_cu_ptr_complex2 (u), 2535 ffebld_constant_real4 (ffebld_conter (l))); 2536 break; 2537#endif 2538 2539 default: 2540 assert ("COMPLEX2/REAL bad source kind type" == NULL); 2541 break; 2542 } 2543 break; 2544 2545 case FFEINFO_basictypeCOMPLEX: 2546 switch (ffeinfo_kindtype (ffebld_info (l))) 2547 { 2548#if FFETARGET_okCOMPLEX1 2549 case FFEINFO_kindtypeREAL1: 2550 error = ffetarget_convert_complex2_complex1 2551 (ffebld_cu_ptr_complex2 (u), 2552 ffebld_constant_complex1 (ffebld_conter (l))); 2553 break; 2554#endif 2555 2556#if FFETARGET_okCOMPLEX3 2557 case FFEINFO_kindtypeREAL3: 2558 error = ffetarget_convert_complex2_complex3 2559 (ffebld_cu_ptr_complex2 (u), 2560 ffebld_constant_complex3 (ffebld_conter (l))); 2561 break; 2562#endif 2563 2564#if FFETARGET_okCOMPLEX4 2565 case FFEINFO_kindtypeREAL4: 2566 error = ffetarget_convert_complex2_complex4 2567 (ffebld_cu_ptr_complex2 (u), 2568 ffebld_constant_complex4 (ffebld_conter (l))); 2569 break; 2570#endif 2571 2572 default: 2573 assert ("COMPLEX2/COMPLEX bad source kind type" == NULL); 2574 break; 2575 } 2576 break; 2577 2578 case FFEINFO_basictypeCHARACTER: 2579 error = ffetarget_convert_complex2_character1 2580 (ffebld_cu_ptr_complex2 (u), 2581 ffebld_constant_character1 (ffebld_conter (l))); 2582 break; 2583 2584 case FFEINFO_basictypeHOLLERITH: 2585 error = ffetarget_convert_complex2_hollerith 2586 (ffebld_cu_ptr_complex2 (u), 2587 ffebld_constant_hollerith (ffebld_conter (l))); 2588 break; 2589 2590 case FFEINFO_basictypeTYPELESS: 2591 error = ffetarget_convert_complex2_typeless 2592 (ffebld_cu_ptr_complex2 (u), 2593 ffebld_constant_typeless (ffebld_conter (l))); 2594 break; 2595 2596 default: 2597 assert ("COMPLEX2 bad type" == NULL); 2598 break; 2599 } 2600 2601 /* If conversion operation is not implemented, return original expr. */ 2602 if (error == FFEBAD_NOCANDO) 2603 return expr; 2604 2605 expr = ffebld_new_conter_with_orig 2606 (ffebld_constant_new_complex2_val 2607 (ffebld_cu_val_complex2 (u)), expr); 2608 break; 2609#endif 2610 2611#if FFETARGET_okCOMPLEX3 2612 case FFEINFO_kindtypeREAL3: 2613 switch (ffeinfo_basictype (ffebld_info (l))) 2614 { 2615 case FFEINFO_basictypeINTEGER: 2616 switch (ffeinfo_kindtype (ffebld_info (l))) 2617 { 2618#if FFETARGET_okINTEGER1 2619 case FFEINFO_kindtypeINTEGER1: 2620 error = ffetarget_convert_complex3_integer1 2621 (ffebld_cu_ptr_complex3 (u), 2622 ffebld_constant_integer1 (ffebld_conter (l))); 2623 break; 2624#endif 2625 2626#if FFETARGET_okINTEGER2 2627 case FFEINFO_kindtypeINTEGER2: 2628 error = ffetarget_convert_complex3_integer2 2629 (ffebld_cu_ptr_complex3 (u), 2630 ffebld_constant_integer2 (ffebld_conter (l))); 2631 break; 2632#endif 2633 2634#if FFETARGET_okINTEGER3 2635 case FFEINFO_kindtypeINTEGER3: 2636 error = ffetarget_convert_complex3_integer3 2637 (ffebld_cu_ptr_complex3 (u), 2638 ffebld_constant_integer3 (ffebld_conter (l))); 2639 break; 2640#endif 2641 2642#if FFETARGET_okINTEGER4 2643 case FFEINFO_kindtypeINTEGER4: 2644 error = ffetarget_convert_complex3_integer4 2645 (ffebld_cu_ptr_complex3 (u), 2646 ffebld_constant_integer4 (ffebld_conter (l))); 2647 break; 2648#endif 2649 2650 default: 2651 assert ("COMPLEX3/INTEGER bad source kind type" == NULL); 2652 break; 2653 } 2654 break; 2655 2656 case FFEINFO_basictypeREAL: 2657 switch (ffeinfo_kindtype (ffebld_info (l))) 2658 { 2659#if FFETARGET_okREAL1 2660 case FFEINFO_kindtypeREAL1: 2661 error = ffetarget_convert_complex3_real1 2662 (ffebld_cu_ptr_complex3 (u), 2663 ffebld_constant_real1 (ffebld_conter (l))); 2664 break; 2665#endif 2666 2667#if FFETARGET_okREAL2 2668 case FFEINFO_kindtypeREAL2: 2669 error = ffetarget_convert_complex3_real2 2670 (ffebld_cu_ptr_complex3 (u), 2671 ffebld_constant_real2 (ffebld_conter (l))); 2672 break; 2673#endif 2674 2675#if FFETARGET_okREAL3 2676 case FFEINFO_kindtypeREAL3: 2677 error = ffetarget_convert_complex3_real3 2678 (ffebld_cu_ptr_complex3 (u), 2679 ffebld_constant_real3 (ffebld_conter (l))); 2680 break; 2681#endif 2682 2683#if FFETARGET_okREAL4 2684 case FFEINFO_kindtypeREAL4: 2685 error = ffetarget_convert_complex3_real4 2686 (ffebld_cu_ptr_complex3 (u), 2687 ffebld_constant_real4 (ffebld_conter (l))); 2688 break; 2689#endif 2690 2691 default: 2692 assert ("COMPLEX3/REAL bad source kind type" == NULL); 2693 break; 2694 } 2695 break; 2696 2697 case FFEINFO_basictypeCOMPLEX: 2698 switch (ffeinfo_kindtype (ffebld_info (l))) 2699 { 2700#if FFETARGET_okCOMPLEX1 2701 case FFEINFO_kindtypeREAL1: 2702 error = ffetarget_convert_complex3_complex1 2703 (ffebld_cu_ptr_complex3 (u), 2704 ffebld_constant_complex1 (ffebld_conter (l))); 2705 break; 2706#endif 2707 2708#if FFETARGET_okCOMPLEX2 2709 case FFEINFO_kindtypeREAL2: 2710 error = ffetarget_convert_complex3_complex2 2711 (ffebld_cu_ptr_complex3 (u), 2712 ffebld_constant_complex2 (ffebld_conter (l))); 2713 break; 2714#endif 2715 2716#if FFETARGET_okCOMPLEX4 2717 case FFEINFO_kindtypeREAL4: 2718 error = ffetarget_convert_complex3_complex4 2719 (ffebld_cu_ptr_complex3 (u), 2720 ffebld_constant_complex4 (ffebld_conter (l))); 2721 break; 2722#endif 2723 2724 default: 2725 assert ("COMPLEX3/COMPLEX bad source kind type" == NULL); 2726 break; 2727 } 2728 break; 2729 2730 case FFEINFO_basictypeCHARACTER: 2731 error = ffetarget_convert_complex3_character1 2732 (ffebld_cu_ptr_complex3 (u), 2733 ffebld_constant_character1 (ffebld_conter (l))); 2734 break; 2735 2736 case FFEINFO_basictypeHOLLERITH: 2737 error = ffetarget_convert_complex3_hollerith 2738 (ffebld_cu_ptr_complex3 (u), 2739 ffebld_constant_hollerith (ffebld_conter (l))); 2740 break; 2741 2742 case FFEINFO_basictypeTYPELESS: 2743 error = ffetarget_convert_complex3_typeless 2744 (ffebld_cu_ptr_complex3 (u), 2745 ffebld_constant_typeless (ffebld_conter (l))); 2746 break; 2747 2748 default: 2749 assert ("COMPLEX3 bad type" == NULL); 2750 break; 2751 } 2752 2753 /* If conversion operation is not implemented, return original expr. */ 2754 if (error == FFEBAD_NOCANDO) 2755 return expr; 2756 2757 expr = ffebld_new_conter_with_orig 2758 (ffebld_constant_new_complex3_val 2759 (ffebld_cu_val_complex3 (u)), expr); 2760 break; 2761#endif 2762 2763#if FFETARGET_okCOMPLEX4 2764 case FFEINFO_kindtypeREAL4: 2765 switch (ffeinfo_basictype (ffebld_info (l))) 2766 { 2767 case FFEINFO_basictypeINTEGER: 2768 switch (ffeinfo_kindtype (ffebld_info (l))) 2769 { 2770#if FFETARGET_okINTEGER1 2771 case FFEINFO_kindtypeINTEGER1: 2772 error = ffetarget_convert_complex4_integer1 2773 (ffebld_cu_ptr_complex4 (u), 2774 ffebld_constant_integer1 (ffebld_conter (l))); 2775 break; 2776#endif 2777 2778#if FFETARGET_okINTEGER2 2779 case FFEINFO_kindtypeINTEGER2: 2780 error = ffetarget_convert_complex4_integer2 2781 (ffebld_cu_ptr_complex4 (u), 2782 ffebld_constant_integer2 (ffebld_conter (l))); 2783 break; 2784#endif 2785 2786#if FFETARGET_okINTEGER3 2787 case FFEINFO_kindtypeINTEGER3: 2788 error = ffetarget_convert_complex4_integer3 2789 (ffebld_cu_ptr_complex4 (u), 2790 ffebld_constant_integer3 (ffebld_conter (l))); 2791 break; 2792#endif 2793 2794#if FFETARGET_okINTEGER4 2795 case FFEINFO_kindtypeINTEGER4: 2796 error = ffetarget_convert_complex4_integer4 2797 (ffebld_cu_ptr_complex4 (u), 2798 ffebld_constant_integer4 (ffebld_conter (l))); 2799 break; 2800#endif 2801 2802 default: 2803 assert ("COMPLEX4/INTEGER bad source kind type" == NULL); 2804 break; 2805 } 2806 break; 2807 2808 case FFEINFO_basictypeREAL: 2809 switch (ffeinfo_kindtype (ffebld_info (l))) 2810 { 2811#if FFETARGET_okREAL1 2812 case FFEINFO_kindtypeREAL1: 2813 error = ffetarget_convert_complex4_real1 2814 (ffebld_cu_ptr_complex4 (u), 2815 ffebld_constant_real1 (ffebld_conter (l))); 2816 break; 2817#endif 2818 2819#if FFETARGET_okREAL2 2820 case FFEINFO_kindtypeREAL2: 2821 error = ffetarget_convert_complex4_real2 2822 (ffebld_cu_ptr_complex4 (u), 2823 ffebld_constant_real2 (ffebld_conter (l))); 2824 break; 2825#endif 2826 2827#if FFETARGET_okREAL3 2828 case FFEINFO_kindtypeREAL3: 2829 error = ffetarget_convert_complex4_real3 2830 (ffebld_cu_ptr_complex4 (u), 2831 ffebld_constant_real3 (ffebld_conter (l))); 2832 break; 2833#endif 2834 2835#if FFETARGET_okREAL4 2836 case FFEINFO_kindtypeREAL4: 2837 error = ffetarget_convert_complex4_real4 2838 (ffebld_cu_ptr_complex4 (u), 2839 ffebld_constant_real4 (ffebld_conter (l))); 2840 break; 2841#endif 2842 2843 default: 2844 assert ("COMPLEX4/REAL bad source kind type" == NULL); 2845 break; 2846 } 2847 break; 2848 2849 case FFEINFO_basictypeCOMPLEX: 2850 switch (ffeinfo_kindtype (ffebld_info (l))) 2851 { 2852#if FFETARGET_okCOMPLEX1 2853 case FFEINFO_kindtypeREAL1: 2854 error = ffetarget_convert_complex4_complex1 2855 (ffebld_cu_ptr_complex4 (u), 2856 ffebld_constant_complex1 (ffebld_conter (l))); 2857 break; 2858#endif 2859 2860#if FFETARGET_okCOMPLEX2 2861 case FFEINFO_kindtypeREAL2: 2862 error = ffetarget_convert_complex4_complex2 2863 (ffebld_cu_ptr_complex4 (u), 2864 ffebld_constant_complex2 (ffebld_conter (l))); 2865 break; 2866#endif 2867 2868#if FFETARGET_okCOMPLEX3 2869 case FFEINFO_kindtypeREAL3: 2870 error = ffetarget_convert_complex4_complex3 2871 (ffebld_cu_ptr_complex4 (u), 2872 ffebld_constant_complex3 (ffebld_conter (l))); 2873 break; 2874#endif 2875 2876 default: 2877 assert ("COMPLEX4/COMPLEX bad source kind type" == NULL); 2878 break; 2879 } 2880 break; 2881 2882 case FFEINFO_basictypeCHARACTER: 2883 error = ffetarget_convert_complex4_character1 2884 (ffebld_cu_ptr_complex4 (u), 2885 ffebld_constant_character1 (ffebld_conter (l))); 2886 break; 2887 2888 case FFEINFO_basictypeHOLLERITH: 2889 error = ffetarget_convert_complex4_hollerith 2890 (ffebld_cu_ptr_complex4 (u), 2891 ffebld_constant_hollerith (ffebld_conter (l))); 2892 break; 2893 2894 case FFEINFO_basictypeTYPELESS: 2895 error = ffetarget_convert_complex4_typeless 2896 (ffebld_cu_ptr_complex4 (u), 2897 ffebld_constant_typeless (ffebld_conter (l))); 2898 break; 2899 2900 default: 2901 assert ("COMPLEX4 bad type" == NULL); 2902 break; 2903 } 2904 2905 /* If conversion operation is not implemented, return original expr. */ 2906 if (error == FFEBAD_NOCANDO) 2907 return expr; 2908 2909 expr = ffebld_new_conter_with_orig 2910 (ffebld_constant_new_complex4_val 2911 (ffebld_cu_val_complex4 (u)), expr); 2912 break; 2913#endif 2914 2915 default: 2916 assert ("bad complex kind type" == NULL); 2917 break; 2918 } 2919 break; 2920 2921 case FFEINFO_basictypeCHARACTER: 2922 if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE) 2923 return expr; 2924 kt = ffeinfo_kindtype (ffebld_info (expr)); 2925 switch (kt) 2926 { 2927#if FFETARGET_okCHARACTER1 2928 case FFEINFO_kindtypeCHARACTER1: 2929 switch (ffeinfo_basictype (ffebld_info (l))) 2930 { 2931 case FFEINFO_basictypeCHARACTER: 2932 if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE) 2933 return expr; 2934 assert (kt == ffeinfo_kindtype (ffebld_info (l))); 2935 assert (sz2 == ffetarget_length_character1 2936 (ffebld_constant_character1 2937 (ffebld_conter (l)))); 2938 error 2939 = ffetarget_convert_character1_character1 2940 (ffebld_cu_ptr_character1 (u), sz, 2941 ffebld_constant_character1 (ffebld_conter (l)), 2942 ffebld_constant_pool ()); 2943 break; 2944 2945 case FFEINFO_basictypeINTEGER: 2946 switch (ffeinfo_kindtype (ffebld_info (l))) 2947 { 2948#if FFETARGET_okINTEGER1 2949 case FFEINFO_kindtypeINTEGER1: 2950 error 2951 = ffetarget_convert_character1_integer1 2952 (ffebld_cu_ptr_character1 (u), 2953 sz, 2954 ffebld_constant_integer1 (ffebld_conter (l)), 2955 ffebld_constant_pool ()); 2956 break; 2957#endif 2958 2959#if FFETARGET_okINTEGER2 2960 case FFEINFO_kindtypeINTEGER2: 2961 error 2962 = ffetarget_convert_character1_integer2 2963 (ffebld_cu_ptr_character1 (u), 2964 sz, 2965 ffebld_constant_integer2 (ffebld_conter (l)), 2966 ffebld_constant_pool ()); 2967 break; 2968#endif 2969 2970#if FFETARGET_okINTEGER3 2971 case FFEINFO_kindtypeINTEGER3: 2972 error 2973 = ffetarget_convert_character1_integer3 2974 (ffebld_cu_ptr_character1 (u), 2975 sz, 2976 ffebld_constant_integer3 (ffebld_conter (l)), 2977 ffebld_constant_pool ()); 2978 break; 2979#endif 2980 2981#if FFETARGET_okINTEGER4 2982 case FFEINFO_kindtypeINTEGER4: 2983 error 2984 = ffetarget_convert_character1_integer4 2985 (ffebld_cu_ptr_character1 (u), 2986 sz, 2987 ffebld_constant_integer4 (ffebld_conter (l)), 2988 ffebld_constant_pool ()); 2989 break; 2990#endif 2991 2992 default: 2993 assert ("CHARACTER1/INTEGER bad source kind type" == NULL); 2994 break; 2995 } 2996 break; 2997 2998 case FFEINFO_basictypeLOGICAL: 2999 switch (ffeinfo_kindtype (ffebld_info (l))) 3000 { 3001#if FFETARGET_okLOGICAL1 3002 case FFEINFO_kindtypeLOGICAL1: 3003 error 3004 = ffetarget_convert_character1_logical1 3005 (ffebld_cu_ptr_character1 (u), 3006 sz, 3007 ffebld_constant_logical1 (ffebld_conter (l)), 3008 ffebld_constant_pool ()); 3009 break; 3010#endif 3011 3012#if FFETARGET_okLOGICAL2 3013 case FFEINFO_kindtypeLOGICAL2: 3014 error 3015 = ffetarget_convert_character1_logical2 3016 (ffebld_cu_ptr_character1 (u), 3017 sz, 3018 ffebld_constant_logical2 (ffebld_conter (l)), 3019 ffebld_constant_pool ()); 3020 break; 3021#endif 3022 3023#if FFETARGET_okLOGICAL3 3024 case FFEINFO_kindtypeLOGICAL3: 3025 error 3026 = ffetarget_convert_character1_logical3 3027 (ffebld_cu_ptr_character1 (u), 3028 sz, 3029 ffebld_constant_logical3 (ffebld_conter (l)), 3030 ffebld_constant_pool ()); 3031 break; 3032#endif 3033 3034#if FFETARGET_okLOGICAL4 3035 case FFEINFO_kindtypeLOGICAL4: 3036 error 3037 = ffetarget_convert_character1_logical4 3038 (ffebld_cu_ptr_character1 (u), 3039 sz, 3040 ffebld_constant_logical4 (ffebld_conter (l)), 3041 ffebld_constant_pool ()); 3042 break; 3043#endif 3044 3045 default: 3046 assert ("CHARACTER1/LOGICAL bad source kind type" == NULL); 3047 break; 3048 } 3049 break; 3050 3051 case FFEINFO_basictypeHOLLERITH: 3052 error 3053 = ffetarget_convert_character1_hollerith 3054 (ffebld_cu_ptr_character1 (u), 3055 sz, 3056 ffebld_constant_hollerith (ffebld_conter (l)), 3057 ffebld_constant_pool ()); 3058 break; 3059 3060 case FFEINFO_basictypeTYPELESS: 3061 error 3062 = ffetarget_convert_character1_typeless 3063 (ffebld_cu_ptr_character1 (u), 3064 sz, 3065 ffebld_constant_typeless (ffebld_conter (l)), 3066 ffebld_constant_pool ()); 3067 break; 3068 3069 default: 3070 assert ("CHARACTER1 bad type" == NULL); 3071 } 3072 3073 expr 3074 = ffebld_new_conter_with_orig 3075 (ffebld_constant_new_character1_val 3076 (ffebld_cu_val_character1 (u)), 3077 expr); 3078 break; 3079#endif 3080 3081 default: 3082 assert ("bad character kind type" == NULL); 3083 break; 3084 } 3085 break; 3086 3087 default: 3088 assert ("bad type" == NULL); 3089 return expr; 3090 } 3091 3092 ffebld_set_info (expr, ffeinfo_new 3093 (bt, 3094 kt, 3095 0, 3096 FFEINFO_kindENTITY, 3097 FFEINFO_whereCONSTANT, 3098 sz)); 3099 3100 if ((error != FFEBAD) 3101 && ffebad_start (error)) 3102 { 3103 assert (t != NULL); 3104 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 3105 ffebad_finish (); 3106 } 3107 3108 return expr; 3109} 3110 3111/* ffeexpr_collapse_paren -- Collapse paren expr 3112 3113 ffebld expr; 3114 ffelexToken token; 3115 expr = ffeexpr_collapse_paren(expr,token); 3116 3117 If the result of the expr is a constant, replaces the expr with the 3118 computed constant. */ 3119 3120ffebld 3121ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED) 3122{ 3123 ffebld r; 3124 ffeinfoBasictype bt; 3125 ffeinfoKindtype kt; 3126 ffetargetCharacterSize len; 3127 3128 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 3129 return expr; 3130 3131 r = ffebld_left (expr); 3132 3133 if (ffebld_op (r) != FFEBLD_opCONTER) 3134 return expr; 3135 3136 bt = ffeinfo_basictype (ffebld_info (r)); 3137 kt = ffeinfo_kindtype (ffebld_info (r)); 3138 len = ffebld_size (r); 3139 3140 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)), 3141 expr); 3142 3143 ffebld_set_info (expr, ffeinfo_new 3144 (bt, 3145 kt, 3146 0, 3147 FFEINFO_kindENTITY, 3148 FFEINFO_whereCONSTANT, 3149 len)); 3150 3151 return expr; 3152} 3153 3154/* ffeexpr_collapse_uplus -- Collapse uplus expr 3155 3156 ffebld expr; 3157 ffelexToken token; 3158 expr = ffeexpr_collapse_uplus(expr,token); 3159 3160 If the result of the expr is a constant, replaces the expr with the 3161 computed constant. */ 3162 3163ffebld 3164ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED) 3165{ 3166 ffebld r; 3167 ffeinfoBasictype bt; 3168 ffeinfoKindtype kt; 3169 ffetargetCharacterSize len; 3170 3171 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 3172 return expr; 3173 3174 r = ffebld_left (expr); 3175 3176 if (ffebld_op (r) != FFEBLD_opCONTER) 3177 return expr; 3178 3179 bt = ffeinfo_basictype (ffebld_info (r)); 3180 kt = ffeinfo_kindtype (ffebld_info (r)); 3181 len = ffebld_size (r); 3182 3183 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)), 3184 expr); 3185 3186 ffebld_set_info (expr, ffeinfo_new 3187 (bt, 3188 kt, 3189 0, 3190 FFEINFO_kindENTITY, 3191 FFEINFO_whereCONSTANT, 3192 len)); 3193 3194 return expr; 3195} 3196 3197/* ffeexpr_collapse_uminus -- Collapse uminus expr 3198 3199 ffebld expr; 3200 ffelexToken token; 3201 expr = ffeexpr_collapse_uminus(expr,token); 3202 3203 If the result of the expr is a constant, replaces the expr with the 3204 computed constant. */ 3205 3206ffebld 3207ffeexpr_collapse_uminus (ffebld expr, ffelexToken t) 3208{ 3209 ffebad error = FFEBAD; 3210 ffebld r; 3211 ffebldConstantUnion u; 3212 ffeinfoBasictype bt; 3213 ffeinfoKindtype kt; 3214 3215 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 3216 return expr; 3217 3218 r = ffebld_left (expr); 3219 3220 if (ffebld_op (r) != FFEBLD_opCONTER) 3221 return expr; 3222 3223 switch (bt = ffeinfo_basictype (ffebld_info (expr))) 3224 { 3225 case FFEINFO_basictypeANY: 3226 return expr; 3227 3228 case FFEINFO_basictypeINTEGER: 3229 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 3230 { 3231#if FFETARGET_okINTEGER1 3232 case FFEINFO_kindtypeINTEGER1: 3233 error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u), 3234 ffebld_constant_integer1 (ffebld_conter (r))); 3235 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val 3236 (ffebld_cu_val_integer1 (u)), expr); 3237 break; 3238#endif 3239 3240#if FFETARGET_okINTEGER2 3241 case FFEINFO_kindtypeINTEGER2: 3242 error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u), 3243 ffebld_constant_integer2 (ffebld_conter (r))); 3244 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val 3245 (ffebld_cu_val_integer2 (u)), expr); 3246 break; 3247#endif 3248 3249#if FFETARGET_okINTEGER3 3250 case FFEINFO_kindtypeINTEGER3: 3251 error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u), 3252 ffebld_constant_integer3 (ffebld_conter (r))); 3253 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val 3254 (ffebld_cu_val_integer3 (u)), expr); 3255 break; 3256#endif 3257 3258#if FFETARGET_okINTEGER4 3259 case FFEINFO_kindtypeINTEGER4: 3260 error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u), 3261 ffebld_constant_integer4 (ffebld_conter (r))); 3262 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val 3263 (ffebld_cu_val_integer4 (u)), expr); 3264 break; 3265#endif 3266 3267 default: 3268 assert ("bad integer kind type" == NULL); 3269 break; 3270 } 3271 break; 3272 3273 case FFEINFO_basictypeREAL: 3274 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 3275 { 3276#if FFETARGET_okREAL1 3277 case FFEINFO_kindtypeREAL1: 3278 error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u), 3279 ffebld_constant_real1 (ffebld_conter (r))); 3280 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val 3281 (ffebld_cu_val_real1 (u)), expr); 3282 break; 3283#endif 3284 3285#if FFETARGET_okREAL2 3286 case FFEINFO_kindtypeREAL2: 3287 error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u), 3288 ffebld_constant_real2 (ffebld_conter (r))); 3289 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val 3290 (ffebld_cu_val_real2 (u)), expr); 3291 break; 3292#endif 3293 3294#if FFETARGET_okREAL3 3295 case FFEINFO_kindtypeREAL3: 3296 error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u), 3297 ffebld_constant_real3 (ffebld_conter (r))); 3298 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val 3299 (ffebld_cu_val_real3 (u)), expr); 3300 break; 3301#endif 3302 3303#if FFETARGET_okREAL4 3304 case FFEINFO_kindtypeREAL4: 3305 error = ffetarget_uminus_real4 (ffebld_cu_ptr_real4 (u), 3306 ffebld_constant_real4 (ffebld_conter (r))); 3307 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val 3308 (ffebld_cu_val_real4 (u)), expr); 3309 break; 3310#endif 3311 3312 default: 3313 assert ("bad real kind type" == NULL); 3314 break; 3315 } 3316 break; 3317 3318 case FFEINFO_basictypeCOMPLEX: 3319 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 3320 { 3321#if FFETARGET_okCOMPLEX1 3322 case FFEINFO_kindtypeREAL1: 3323 error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u), 3324 ffebld_constant_complex1 (ffebld_conter (r))); 3325 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val 3326 (ffebld_cu_val_complex1 (u)), expr); 3327 break; 3328#endif 3329 3330#if FFETARGET_okCOMPLEX2 3331 case FFEINFO_kindtypeREAL2: 3332 error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u), 3333 ffebld_constant_complex2 (ffebld_conter (r))); 3334 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val 3335 (ffebld_cu_val_complex2 (u)), expr); 3336 break; 3337#endif 3338 3339#if FFETARGET_okCOMPLEX3 3340 case FFEINFO_kindtypeREAL3: 3341 error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u), 3342 ffebld_constant_complex3 (ffebld_conter (r))); 3343 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val 3344 (ffebld_cu_val_complex3 (u)), expr); 3345 break; 3346#endif 3347 3348#if FFETARGET_okCOMPLEX4 3349 case FFEINFO_kindtypeREAL4: 3350 error = ffetarget_uminus_complex4 (ffebld_cu_ptr_complex4 (u), 3351 ffebld_constant_complex4 (ffebld_conter (r))); 3352 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val 3353 (ffebld_cu_val_complex4 (u)), expr); 3354 break; 3355#endif 3356 3357 default: 3358 assert ("bad complex kind type" == NULL); 3359 break; 3360 } 3361 break; 3362 3363 default: 3364 assert ("bad type" == NULL); 3365 return expr; 3366 } 3367 3368 ffebld_set_info (expr, ffeinfo_new 3369 (bt, 3370 kt, 3371 0, 3372 FFEINFO_kindENTITY, 3373 FFEINFO_whereCONSTANT, 3374 FFETARGET_charactersizeNONE)); 3375 3376 if ((error != FFEBAD) 3377 && ffebad_start (error)) 3378 { 3379 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 3380 ffebad_finish (); 3381 } 3382 3383 return expr; 3384} 3385 3386/* ffeexpr_collapse_not -- Collapse not expr 3387 3388 ffebld expr; 3389 ffelexToken token; 3390 expr = ffeexpr_collapse_not(expr,token); 3391 3392 If the result of the expr is a constant, replaces the expr with the 3393 computed constant. */ 3394 3395ffebld 3396ffeexpr_collapse_not (ffebld expr, ffelexToken t) 3397{ 3398 ffebad error = FFEBAD; 3399 ffebld r; 3400 ffebldConstantUnion u; 3401 ffeinfoBasictype bt; 3402 ffeinfoKindtype kt; 3403 3404 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 3405 return expr; 3406 3407 r = ffebld_left (expr); 3408 3409 if (ffebld_op (r) != FFEBLD_opCONTER) 3410 return expr; 3411 3412 switch (bt = ffeinfo_basictype (ffebld_info (expr))) 3413 { 3414 case FFEINFO_basictypeANY: 3415 return expr; 3416 3417 case FFEINFO_basictypeINTEGER: 3418 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 3419 { 3420#if FFETARGET_okINTEGER1 3421 case FFEINFO_kindtypeINTEGER1: 3422 error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u), 3423 ffebld_constant_integer1 (ffebld_conter (r))); 3424 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val 3425 (ffebld_cu_val_integer1 (u)), expr); 3426 break; 3427#endif 3428 3429#if FFETARGET_okINTEGER2 3430 case FFEINFO_kindtypeINTEGER2: 3431 error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u), 3432 ffebld_constant_integer2 (ffebld_conter (r))); 3433 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val 3434 (ffebld_cu_val_integer2 (u)), expr); 3435 break; 3436#endif 3437 3438#if FFETARGET_okINTEGER3 3439 case FFEINFO_kindtypeINTEGER3: 3440 error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u), 3441 ffebld_constant_integer3 (ffebld_conter (r))); 3442 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val 3443 (ffebld_cu_val_integer3 (u)), expr); 3444 break; 3445#endif 3446 3447#if FFETARGET_okINTEGER4 3448 case FFEINFO_kindtypeINTEGER4: 3449 error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u), 3450 ffebld_constant_integer4 (ffebld_conter (r))); 3451 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val 3452 (ffebld_cu_val_integer4 (u)), expr); 3453 break; 3454#endif 3455 3456 default: 3457 assert ("bad integer kind type" == NULL); 3458 break; 3459 } 3460 break; 3461 3462 case FFEINFO_basictypeLOGICAL: 3463 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 3464 { 3465#if FFETARGET_okLOGICAL1 3466 case FFEINFO_kindtypeLOGICAL1: 3467 error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u), 3468 ffebld_constant_logical1 (ffebld_conter (r))); 3469 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val 3470 (ffebld_cu_val_logical1 (u)), expr); 3471 break; 3472#endif 3473 3474#if FFETARGET_okLOGICAL2 3475 case FFEINFO_kindtypeLOGICAL2: 3476 error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u), 3477 ffebld_constant_logical2 (ffebld_conter (r))); 3478 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val 3479 (ffebld_cu_val_logical2 (u)), expr); 3480 break; 3481#endif 3482 3483#if FFETARGET_okLOGICAL3 3484 case FFEINFO_kindtypeLOGICAL3: 3485 error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u), 3486 ffebld_constant_logical3 (ffebld_conter (r))); 3487 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val 3488 (ffebld_cu_val_logical3 (u)), expr); 3489 break; 3490#endif 3491 3492#if FFETARGET_okLOGICAL4 3493 case FFEINFO_kindtypeLOGICAL4: 3494 error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u), 3495 ffebld_constant_logical4 (ffebld_conter (r))); 3496 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val 3497 (ffebld_cu_val_logical4 (u)), expr); 3498 break; 3499#endif 3500 3501 default: 3502 assert ("bad logical kind type" == NULL); 3503 break; 3504 } 3505 break; 3506 3507 default: 3508 assert ("bad type" == NULL); 3509 return expr; 3510 } 3511 3512 ffebld_set_info (expr, ffeinfo_new 3513 (bt, 3514 kt, 3515 0, 3516 FFEINFO_kindENTITY, 3517 FFEINFO_whereCONSTANT, 3518 FFETARGET_charactersizeNONE)); 3519 3520 if ((error != FFEBAD) 3521 && ffebad_start (error)) 3522 { 3523 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 3524 ffebad_finish (); 3525 } 3526 3527 return expr; 3528} 3529 3530/* ffeexpr_collapse_add -- Collapse add expr 3531 3532 ffebld expr; 3533 ffelexToken token; 3534 expr = ffeexpr_collapse_add(expr,token); 3535 3536 If the result of the expr is a constant, replaces the expr with the 3537 computed constant. */ 3538 3539ffebld 3540ffeexpr_collapse_add (ffebld expr, ffelexToken t) 3541{ 3542 ffebad error = FFEBAD; 3543 ffebld l; 3544 ffebld r; 3545 ffebldConstantUnion u; 3546 ffeinfoBasictype bt; 3547 ffeinfoKindtype kt; 3548 3549 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 3550 return expr; 3551 3552 l = ffebld_left (expr); 3553 r = ffebld_right (expr); 3554 3555 if (ffebld_op (l) != FFEBLD_opCONTER) 3556 return expr; 3557 if (ffebld_op (r) != FFEBLD_opCONTER) 3558 return expr; 3559 3560 switch (bt = ffeinfo_basictype (ffebld_info (expr))) 3561 { 3562 case FFEINFO_basictypeANY: 3563 return expr; 3564 3565 case FFEINFO_basictypeINTEGER: 3566 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 3567 { 3568#if FFETARGET_okINTEGER1 3569 case FFEINFO_kindtypeINTEGER1: 3570 error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u), 3571 ffebld_constant_integer1 (ffebld_conter (l)), 3572 ffebld_constant_integer1 (ffebld_conter (r))); 3573 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val 3574 (ffebld_cu_val_integer1 (u)), expr); 3575 break; 3576#endif 3577 3578#if FFETARGET_okINTEGER2 3579 case FFEINFO_kindtypeINTEGER2: 3580 error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u), 3581 ffebld_constant_integer2 (ffebld_conter (l)), 3582 ffebld_constant_integer2 (ffebld_conter (r))); 3583 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val 3584 (ffebld_cu_val_integer2 (u)), expr); 3585 break; 3586#endif 3587 3588#if FFETARGET_okINTEGER3 3589 case FFEINFO_kindtypeINTEGER3: 3590 error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u), 3591 ffebld_constant_integer3 (ffebld_conter (l)), 3592 ffebld_constant_integer3 (ffebld_conter (r))); 3593 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val 3594 (ffebld_cu_val_integer3 (u)), expr); 3595 break; 3596#endif 3597 3598#if FFETARGET_okINTEGER4 3599 case FFEINFO_kindtypeINTEGER4: 3600 error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u), 3601 ffebld_constant_integer4 (ffebld_conter (l)), 3602 ffebld_constant_integer4 (ffebld_conter (r))); 3603 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val 3604 (ffebld_cu_val_integer4 (u)), expr); 3605 break; 3606#endif 3607 3608 default: 3609 assert ("bad integer kind type" == NULL); 3610 break; 3611 } 3612 break; 3613 3614 case FFEINFO_basictypeREAL: 3615 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 3616 { 3617#if FFETARGET_okREAL1 3618 case FFEINFO_kindtypeREAL1: 3619 error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u), 3620 ffebld_constant_real1 (ffebld_conter (l)), 3621 ffebld_constant_real1 (ffebld_conter (r))); 3622 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val 3623 (ffebld_cu_val_real1 (u)), expr); 3624 break; 3625#endif 3626 3627#if FFETARGET_okREAL2 3628 case FFEINFO_kindtypeREAL2: 3629 error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u), 3630 ffebld_constant_real2 (ffebld_conter (l)), 3631 ffebld_constant_real2 (ffebld_conter (r))); 3632 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val 3633 (ffebld_cu_val_real2 (u)), expr); 3634 break; 3635#endif 3636 3637#if FFETARGET_okREAL3 3638 case FFEINFO_kindtypeREAL3: 3639 error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u), 3640 ffebld_constant_real3 (ffebld_conter (l)), 3641 ffebld_constant_real3 (ffebld_conter (r))); 3642 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val 3643 (ffebld_cu_val_real3 (u)), expr); 3644 break; 3645#endif 3646 3647#if FFETARGET_okREAL4 3648 case FFEINFO_kindtypeREAL4: 3649 error = ffetarget_add_real4 (ffebld_cu_ptr_real4 (u), 3650 ffebld_constant_real4 (ffebld_conter (l)), 3651 ffebld_constant_real4 (ffebld_conter (r))); 3652 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val 3653 (ffebld_cu_val_real4 (u)), expr); 3654 break; 3655#endif 3656 3657 default: 3658 assert ("bad real kind type" == NULL); 3659 break; 3660 } 3661 break; 3662 3663 case FFEINFO_basictypeCOMPLEX: 3664 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 3665 { 3666#if FFETARGET_okCOMPLEX1 3667 case FFEINFO_kindtypeREAL1: 3668 error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u), 3669 ffebld_constant_complex1 (ffebld_conter (l)), 3670 ffebld_constant_complex1 (ffebld_conter (r))); 3671 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val 3672 (ffebld_cu_val_complex1 (u)), expr); 3673 break; 3674#endif 3675 3676#if FFETARGET_okCOMPLEX2 3677 case FFEINFO_kindtypeREAL2: 3678 error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u), 3679 ffebld_constant_complex2 (ffebld_conter (l)), 3680 ffebld_constant_complex2 (ffebld_conter (r))); 3681 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val 3682 (ffebld_cu_val_complex2 (u)), expr); 3683 break; 3684#endif 3685 3686#if FFETARGET_okCOMPLEX3 3687 case FFEINFO_kindtypeREAL3: 3688 error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u), 3689 ffebld_constant_complex3 (ffebld_conter (l)), 3690 ffebld_constant_complex3 (ffebld_conter (r))); 3691 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val 3692 (ffebld_cu_val_complex3 (u)), expr); 3693 break; 3694#endif 3695 3696#if FFETARGET_okCOMPLEX4 3697 case FFEINFO_kindtypeREAL4: 3698 error = ffetarget_add_complex4 (ffebld_cu_ptr_complex4 (u), 3699 ffebld_constant_complex4 (ffebld_conter (l)), 3700 ffebld_constant_complex4 (ffebld_conter (r))); 3701 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val 3702 (ffebld_cu_val_complex4 (u)), expr); 3703 break; 3704#endif 3705 3706 default: 3707 assert ("bad complex kind type" == NULL); 3708 break; 3709 } 3710 break; 3711 3712 default: 3713 assert ("bad type" == NULL); 3714 return expr; 3715 } 3716 3717 ffebld_set_info (expr, ffeinfo_new 3718 (bt, 3719 kt, 3720 0, 3721 FFEINFO_kindENTITY, 3722 FFEINFO_whereCONSTANT, 3723 FFETARGET_charactersizeNONE)); 3724 3725 if ((error != FFEBAD) 3726 && ffebad_start (error)) 3727 { 3728 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 3729 ffebad_finish (); 3730 } 3731 3732 return expr; 3733} 3734 3735/* ffeexpr_collapse_subtract -- Collapse subtract expr 3736 3737 ffebld expr; 3738 ffelexToken token; 3739 expr = ffeexpr_collapse_subtract(expr,token); 3740 3741 If the result of the expr is a constant, replaces the expr with the 3742 computed constant. */ 3743 3744ffebld 3745ffeexpr_collapse_subtract (ffebld expr, ffelexToken t) 3746{ 3747 ffebad error = FFEBAD; 3748 ffebld l; 3749 ffebld r; 3750 ffebldConstantUnion u; 3751 ffeinfoBasictype bt; 3752 ffeinfoKindtype kt; 3753 3754 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 3755 return expr; 3756 3757 l = ffebld_left (expr); 3758 r = ffebld_right (expr); 3759 3760 if (ffebld_op (l) != FFEBLD_opCONTER) 3761 return expr; 3762 if (ffebld_op (r) != FFEBLD_opCONTER) 3763 return expr; 3764 3765 switch (bt = ffeinfo_basictype (ffebld_info (expr))) 3766 { 3767 case FFEINFO_basictypeANY: 3768 return expr; 3769 3770 case FFEINFO_basictypeINTEGER: 3771 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 3772 { 3773#if FFETARGET_okINTEGER1 3774 case FFEINFO_kindtypeINTEGER1: 3775 error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u), 3776 ffebld_constant_integer1 (ffebld_conter (l)), 3777 ffebld_constant_integer1 (ffebld_conter (r))); 3778 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val 3779 (ffebld_cu_val_integer1 (u)), expr); 3780 break; 3781#endif 3782 3783#if FFETARGET_okINTEGER2 3784 case FFEINFO_kindtypeINTEGER2: 3785 error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u), 3786 ffebld_constant_integer2 (ffebld_conter (l)), 3787 ffebld_constant_integer2 (ffebld_conter (r))); 3788 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val 3789 (ffebld_cu_val_integer2 (u)), expr); 3790 break; 3791#endif 3792 3793#if FFETARGET_okINTEGER3 3794 case FFEINFO_kindtypeINTEGER3: 3795 error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u), 3796 ffebld_constant_integer3 (ffebld_conter (l)), 3797 ffebld_constant_integer3 (ffebld_conter (r))); 3798 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val 3799 (ffebld_cu_val_integer3 (u)), expr); 3800 break; 3801#endif 3802 3803#if FFETARGET_okINTEGER4 3804 case FFEINFO_kindtypeINTEGER4: 3805 error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u), 3806 ffebld_constant_integer4 (ffebld_conter (l)), 3807 ffebld_constant_integer4 (ffebld_conter (r))); 3808 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val 3809 (ffebld_cu_val_integer4 (u)), expr); 3810 break; 3811#endif 3812 3813 default: 3814 assert ("bad integer kind type" == NULL); 3815 break; 3816 } 3817 break; 3818 3819 case FFEINFO_basictypeREAL: 3820 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 3821 { 3822#if FFETARGET_okREAL1 3823 case FFEINFO_kindtypeREAL1: 3824 error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u), 3825 ffebld_constant_real1 (ffebld_conter (l)), 3826 ffebld_constant_real1 (ffebld_conter (r))); 3827 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val 3828 (ffebld_cu_val_real1 (u)), expr); 3829 break; 3830#endif 3831 3832#if FFETARGET_okREAL2 3833 case FFEINFO_kindtypeREAL2: 3834 error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u), 3835 ffebld_constant_real2 (ffebld_conter (l)), 3836 ffebld_constant_real2 (ffebld_conter (r))); 3837 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val 3838 (ffebld_cu_val_real2 (u)), expr); 3839 break; 3840#endif 3841 3842#if FFETARGET_okREAL3 3843 case FFEINFO_kindtypeREAL3: 3844 error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u), 3845 ffebld_constant_real3 (ffebld_conter (l)), 3846 ffebld_constant_real3 (ffebld_conter (r))); 3847 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val 3848 (ffebld_cu_val_real3 (u)), expr); 3849 break; 3850#endif 3851 3852#if FFETARGET_okREAL4 3853 case FFEINFO_kindtypeREAL4: 3854 error = ffetarget_subtract_real4 (ffebld_cu_ptr_real4 (u), 3855 ffebld_constant_real4 (ffebld_conter (l)), 3856 ffebld_constant_real4 (ffebld_conter (r))); 3857 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val 3858 (ffebld_cu_val_real4 (u)), expr); 3859 break; 3860#endif 3861 3862 default: 3863 assert ("bad real kind type" == NULL); 3864 break; 3865 } 3866 break; 3867 3868 case FFEINFO_basictypeCOMPLEX: 3869 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 3870 { 3871#if FFETARGET_okCOMPLEX1 3872 case FFEINFO_kindtypeREAL1: 3873 error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u), 3874 ffebld_constant_complex1 (ffebld_conter (l)), 3875 ffebld_constant_complex1 (ffebld_conter (r))); 3876 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val 3877 (ffebld_cu_val_complex1 (u)), expr); 3878 break; 3879#endif 3880 3881#if FFETARGET_okCOMPLEX2 3882 case FFEINFO_kindtypeREAL2: 3883 error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u), 3884 ffebld_constant_complex2 (ffebld_conter (l)), 3885 ffebld_constant_complex2 (ffebld_conter (r))); 3886 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val 3887 (ffebld_cu_val_complex2 (u)), expr); 3888 break; 3889#endif 3890 3891#if FFETARGET_okCOMPLEX3 3892 case FFEINFO_kindtypeREAL3: 3893 error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u), 3894 ffebld_constant_complex3 (ffebld_conter (l)), 3895 ffebld_constant_complex3 (ffebld_conter (r))); 3896 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val 3897 (ffebld_cu_val_complex3 (u)), expr); 3898 break; 3899#endif 3900 3901#if FFETARGET_okCOMPLEX4 3902 case FFEINFO_kindtypeREAL4: 3903 error = ffetarget_subtract_complex4 (ffebld_cu_ptr_complex4 (u), 3904 ffebld_constant_complex4 (ffebld_conter (l)), 3905 ffebld_constant_complex4 (ffebld_conter (r))); 3906 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val 3907 (ffebld_cu_val_complex4 (u)), expr); 3908 break; 3909#endif 3910 3911 default: 3912 assert ("bad complex kind type" == NULL); 3913 break; 3914 } 3915 break; 3916 3917 default: 3918 assert ("bad type" == NULL); 3919 return expr; 3920 } 3921 3922 ffebld_set_info (expr, ffeinfo_new 3923 (bt, 3924 kt, 3925 0, 3926 FFEINFO_kindENTITY, 3927 FFEINFO_whereCONSTANT, 3928 FFETARGET_charactersizeNONE)); 3929 3930 if ((error != FFEBAD) 3931 && ffebad_start (error)) 3932 { 3933 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 3934 ffebad_finish (); 3935 } 3936 3937 return expr; 3938} 3939 3940/* ffeexpr_collapse_multiply -- Collapse multiply expr 3941 3942 ffebld expr; 3943 ffelexToken token; 3944 expr = ffeexpr_collapse_multiply(expr,token); 3945 3946 If the result of the expr is a constant, replaces the expr with the 3947 computed constant. */ 3948 3949ffebld 3950ffeexpr_collapse_multiply (ffebld expr, ffelexToken t) 3951{ 3952 ffebad error = FFEBAD; 3953 ffebld l; 3954 ffebld r; 3955 ffebldConstantUnion u; 3956 ffeinfoBasictype bt; 3957 ffeinfoKindtype kt; 3958 3959 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 3960 return expr; 3961 3962 l = ffebld_left (expr); 3963 r = ffebld_right (expr); 3964 3965 if (ffebld_op (l) != FFEBLD_opCONTER) 3966 return expr; 3967 if (ffebld_op (r) != FFEBLD_opCONTER) 3968 return expr; 3969 3970 switch (bt = ffeinfo_basictype (ffebld_info (expr))) 3971 { 3972 case FFEINFO_basictypeANY: 3973 return expr; 3974 3975 case FFEINFO_basictypeINTEGER: 3976 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 3977 { 3978#if FFETARGET_okINTEGER1 3979 case FFEINFO_kindtypeINTEGER1: 3980 error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u), 3981 ffebld_constant_integer1 (ffebld_conter (l)), 3982 ffebld_constant_integer1 (ffebld_conter (r))); 3983 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val 3984 (ffebld_cu_val_integer1 (u)), expr); 3985 break; 3986#endif 3987 3988#if FFETARGET_okINTEGER2 3989 case FFEINFO_kindtypeINTEGER2: 3990 error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u), 3991 ffebld_constant_integer2 (ffebld_conter (l)), 3992 ffebld_constant_integer2 (ffebld_conter (r))); 3993 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val 3994 (ffebld_cu_val_integer2 (u)), expr); 3995 break; 3996#endif 3997 3998#if FFETARGET_okINTEGER3 3999 case FFEINFO_kindtypeINTEGER3: 4000 error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u), 4001 ffebld_constant_integer3 (ffebld_conter (l)), 4002 ffebld_constant_integer3 (ffebld_conter (r))); 4003 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val 4004 (ffebld_cu_val_integer3 (u)), expr); 4005 break; 4006#endif 4007 4008#if FFETARGET_okINTEGER4 4009 case FFEINFO_kindtypeINTEGER4: 4010 error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u), 4011 ffebld_constant_integer4 (ffebld_conter (l)), 4012 ffebld_constant_integer4 (ffebld_conter (r))); 4013 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val 4014 (ffebld_cu_val_integer4 (u)), expr); 4015 break; 4016#endif 4017 4018 default: 4019 assert ("bad integer kind type" == NULL); 4020 break; 4021 } 4022 break; 4023 4024 case FFEINFO_basictypeREAL: 4025 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 4026 { 4027#if FFETARGET_okREAL1 4028 case FFEINFO_kindtypeREAL1: 4029 error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u), 4030 ffebld_constant_real1 (ffebld_conter (l)), 4031 ffebld_constant_real1 (ffebld_conter (r))); 4032 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val 4033 (ffebld_cu_val_real1 (u)), expr); 4034 break; 4035#endif 4036 4037#if FFETARGET_okREAL2 4038 case FFEINFO_kindtypeREAL2: 4039 error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u), 4040 ffebld_constant_real2 (ffebld_conter (l)), 4041 ffebld_constant_real2 (ffebld_conter (r))); 4042 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val 4043 (ffebld_cu_val_real2 (u)), expr); 4044 break; 4045#endif 4046 4047#if FFETARGET_okREAL3 4048 case FFEINFO_kindtypeREAL3: 4049 error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u), 4050 ffebld_constant_real3 (ffebld_conter (l)), 4051 ffebld_constant_real3 (ffebld_conter (r))); 4052 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val 4053 (ffebld_cu_val_real3 (u)), expr); 4054 break; 4055#endif 4056 4057#if FFETARGET_okREAL4 4058 case FFEINFO_kindtypeREAL4: 4059 error = ffetarget_multiply_real4 (ffebld_cu_ptr_real4 (u), 4060 ffebld_constant_real4 (ffebld_conter (l)), 4061 ffebld_constant_real4 (ffebld_conter (r))); 4062 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val 4063 (ffebld_cu_val_real4 (u)), expr); 4064 break; 4065#endif 4066 4067 default: 4068 assert ("bad real kind type" == NULL); 4069 break; 4070 } 4071 break; 4072 4073 case FFEINFO_basictypeCOMPLEX: 4074 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 4075 { 4076#if FFETARGET_okCOMPLEX1 4077 case FFEINFO_kindtypeREAL1: 4078 error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u), 4079 ffebld_constant_complex1 (ffebld_conter (l)), 4080 ffebld_constant_complex1 (ffebld_conter (r))); 4081 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val 4082 (ffebld_cu_val_complex1 (u)), expr); 4083 break; 4084#endif 4085 4086#if FFETARGET_okCOMPLEX2 4087 case FFEINFO_kindtypeREAL2: 4088 error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u), 4089 ffebld_constant_complex2 (ffebld_conter (l)), 4090 ffebld_constant_complex2 (ffebld_conter (r))); 4091 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val 4092 (ffebld_cu_val_complex2 (u)), expr); 4093 break; 4094#endif 4095 4096#if FFETARGET_okCOMPLEX3 4097 case FFEINFO_kindtypeREAL3: 4098 error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u), 4099 ffebld_constant_complex3 (ffebld_conter (l)), 4100 ffebld_constant_complex3 (ffebld_conter (r))); 4101 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val 4102 (ffebld_cu_val_complex3 (u)), expr); 4103 break; 4104#endif 4105 4106#if FFETARGET_okCOMPLEX4 4107 case FFEINFO_kindtypeREAL4: 4108 error = ffetarget_multiply_complex4 (ffebld_cu_ptr_complex4 (u), 4109 ffebld_constant_complex4 (ffebld_conter (l)), 4110 ffebld_constant_complex4 (ffebld_conter (r))); 4111 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val 4112 (ffebld_cu_val_complex4 (u)), expr); 4113 break; 4114#endif 4115 4116 default: 4117 assert ("bad complex kind type" == NULL); 4118 break; 4119 } 4120 break; 4121 4122 default: 4123 assert ("bad type" == NULL); 4124 return expr; 4125 } 4126 4127 ffebld_set_info (expr, ffeinfo_new 4128 (bt, 4129 kt, 4130 0, 4131 FFEINFO_kindENTITY, 4132 FFEINFO_whereCONSTANT, 4133 FFETARGET_charactersizeNONE)); 4134 4135 if ((error != FFEBAD) 4136 && ffebad_start (error)) 4137 { 4138 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 4139 ffebad_finish (); 4140 } 4141 4142 return expr; 4143} 4144 4145/* ffeexpr_collapse_divide -- Collapse divide expr 4146 4147 ffebld expr; 4148 ffelexToken token; 4149 expr = ffeexpr_collapse_divide(expr,token); 4150 4151 If the result of the expr is a constant, replaces the expr with the 4152 computed constant. */ 4153 4154ffebld 4155ffeexpr_collapse_divide (ffebld expr, ffelexToken t) 4156{ 4157 ffebad error = FFEBAD; 4158 ffebld l; 4159 ffebld r; 4160 ffebldConstantUnion u; 4161 ffeinfoBasictype bt; 4162 ffeinfoKindtype kt; 4163 4164 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 4165 return expr; 4166 4167 l = ffebld_left (expr); 4168 r = ffebld_right (expr); 4169 4170 if (ffebld_op (l) != FFEBLD_opCONTER) 4171 return expr; 4172 if (ffebld_op (r) != FFEBLD_opCONTER) 4173 return expr; 4174 4175 switch (bt = ffeinfo_basictype (ffebld_info (expr))) 4176 { 4177 case FFEINFO_basictypeANY: 4178 return expr; 4179 4180 case FFEINFO_basictypeINTEGER: 4181 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 4182 { 4183#if FFETARGET_okINTEGER1 4184 case FFEINFO_kindtypeINTEGER1: 4185 error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u), 4186 ffebld_constant_integer1 (ffebld_conter (l)), 4187 ffebld_constant_integer1 (ffebld_conter (r))); 4188 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val 4189 (ffebld_cu_val_integer1 (u)), expr); 4190 break; 4191#endif 4192 4193#if FFETARGET_okINTEGER2 4194 case FFEINFO_kindtypeINTEGER2: 4195 error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u), 4196 ffebld_constant_integer2 (ffebld_conter (l)), 4197 ffebld_constant_integer2 (ffebld_conter (r))); 4198 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val 4199 (ffebld_cu_val_integer2 (u)), expr); 4200 break; 4201#endif 4202 4203#if FFETARGET_okINTEGER3 4204 case FFEINFO_kindtypeINTEGER3: 4205 error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u), 4206 ffebld_constant_integer3 (ffebld_conter (l)), 4207 ffebld_constant_integer3 (ffebld_conter (r))); 4208 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val 4209 (ffebld_cu_val_integer3 (u)), expr); 4210 break; 4211#endif 4212 4213#if FFETARGET_okINTEGER4 4214 case FFEINFO_kindtypeINTEGER4: 4215 error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u), 4216 ffebld_constant_integer4 (ffebld_conter (l)), 4217 ffebld_constant_integer4 (ffebld_conter (r))); 4218 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val 4219 (ffebld_cu_val_integer4 (u)), expr); 4220 break; 4221#endif 4222 4223 default: 4224 assert ("bad integer kind type" == NULL); 4225 break; 4226 } 4227 break; 4228 4229 case FFEINFO_basictypeREAL: 4230 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 4231 { 4232#if FFETARGET_okREAL1 4233 case FFEINFO_kindtypeREAL1: 4234 error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u), 4235 ffebld_constant_real1 (ffebld_conter (l)), 4236 ffebld_constant_real1 (ffebld_conter (r))); 4237 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val 4238 (ffebld_cu_val_real1 (u)), expr); 4239 break; 4240#endif 4241 4242#if FFETARGET_okREAL2 4243 case FFEINFO_kindtypeREAL2: 4244 error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u), 4245 ffebld_constant_real2 (ffebld_conter (l)), 4246 ffebld_constant_real2 (ffebld_conter (r))); 4247 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val 4248 (ffebld_cu_val_real2 (u)), expr); 4249 break; 4250#endif 4251 4252#if FFETARGET_okREAL3 4253 case FFEINFO_kindtypeREAL3: 4254 error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u), 4255 ffebld_constant_real3 (ffebld_conter (l)), 4256 ffebld_constant_real3 (ffebld_conter (r))); 4257 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val 4258 (ffebld_cu_val_real3 (u)), expr); 4259 break; 4260#endif 4261 4262#if FFETARGET_okREAL4 4263 case FFEINFO_kindtypeREAL4: 4264 error = ffetarget_divide_real4 (ffebld_cu_ptr_real4 (u), 4265 ffebld_constant_real4 (ffebld_conter (l)), 4266 ffebld_constant_real4 (ffebld_conter (r))); 4267 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val 4268 (ffebld_cu_val_real4 (u)), expr); 4269 break; 4270#endif 4271 4272 default: 4273 assert ("bad real kind type" == NULL); 4274 break; 4275 } 4276 break; 4277 4278 case FFEINFO_basictypeCOMPLEX: 4279 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 4280 { 4281#if FFETARGET_okCOMPLEX1 4282 case FFEINFO_kindtypeREAL1: 4283 error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u), 4284 ffebld_constant_complex1 (ffebld_conter (l)), 4285 ffebld_constant_complex1 (ffebld_conter (r))); 4286 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val 4287 (ffebld_cu_val_complex1 (u)), expr); 4288 break; 4289#endif 4290 4291#if FFETARGET_okCOMPLEX2 4292 case FFEINFO_kindtypeREAL2: 4293 error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u), 4294 ffebld_constant_complex2 (ffebld_conter (l)), 4295 ffebld_constant_complex2 (ffebld_conter (r))); 4296 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val 4297 (ffebld_cu_val_complex2 (u)), expr); 4298 break; 4299#endif 4300 4301#if FFETARGET_okCOMPLEX3 4302 case FFEINFO_kindtypeREAL3: 4303 error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u), 4304 ffebld_constant_complex3 (ffebld_conter (l)), 4305 ffebld_constant_complex3 (ffebld_conter (r))); 4306 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val 4307 (ffebld_cu_val_complex3 (u)), expr); 4308 break; 4309#endif 4310 4311#if FFETARGET_okCOMPLEX4 4312 case FFEINFO_kindtypeREAL4: 4313 error = ffetarget_divide_complex4 (ffebld_cu_ptr_complex4 (u), 4314 ffebld_constant_complex4 (ffebld_conter (l)), 4315 ffebld_constant_complex4 (ffebld_conter (r))); 4316 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val 4317 (ffebld_cu_val_complex4 (u)), expr); 4318 break; 4319#endif 4320 4321 default: 4322 assert ("bad complex kind type" == NULL); 4323 break; 4324 } 4325 break; 4326 4327 default: 4328 assert ("bad type" == NULL); 4329 return expr; 4330 } 4331 4332 ffebld_set_info (expr, ffeinfo_new 4333 (bt, 4334 kt, 4335 0, 4336 FFEINFO_kindENTITY, 4337 FFEINFO_whereCONSTANT, 4338 FFETARGET_charactersizeNONE)); 4339 4340 if ((error != FFEBAD) 4341 && ffebad_start (error)) 4342 { 4343 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 4344 ffebad_finish (); 4345 } 4346 4347 return expr; 4348} 4349 4350/* ffeexpr_collapse_power -- Collapse power expr 4351 4352 ffebld expr; 4353 ffelexToken token; 4354 expr = ffeexpr_collapse_power(expr,token); 4355 4356 If the result of the expr is a constant, replaces the expr with the 4357 computed constant. */ 4358 4359ffebld 4360ffeexpr_collapse_power (ffebld expr, ffelexToken t) 4361{ 4362 ffebad error = FFEBAD; 4363 ffebld l; 4364 ffebld r; 4365 ffebldConstantUnion u; 4366 ffeinfoBasictype bt; 4367 ffeinfoKindtype kt; 4368 4369 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 4370 return expr; 4371 4372 l = ffebld_left (expr); 4373 r = ffebld_right (expr); 4374 4375 if (ffebld_op (l) != FFEBLD_opCONTER) 4376 return expr; 4377 if (ffebld_op (r) != FFEBLD_opCONTER) 4378 return expr; 4379 4380 if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER) 4381 || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT)) 4382 return expr; 4383 4384 switch (bt = ffeinfo_basictype (ffebld_info (expr))) 4385 { 4386 case FFEINFO_basictypeANY: 4387 return expr; 4388 4389 case FFEINFO_basictypeINTEGER: 4390 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 4391 { 4392 case FFEINFO_kindtypeINTEGERDEFAULT: 4393 error = ffetarget_power_integerdefault_integerdefault 4394 (ffebld_cu_ptr_integerdefault (u), 4395 ffebld_constant_integerdefault (ffebld_conter (l)), 4396 ffebld_constant_integerdefault (ffebld_conter (r))); 4397 expr = ffebld_new_conter_with_orig 4398 (ffebld_constant_new_integerdefault_val 4399 (ffebld_cu_val_integerdefault (u)), expr); 4400 break; 4401 4402 default: 4403 assert ("bad integer kind type" == NULL); 4404 break; 4405 } 4406 break; 4407 4408 case FFEINFO_basictypeREAL: 4409 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 4410 { 4411 case FFEINFO_kindtypeREALDEFAULT: 4412 error = ffetarget_power_realdefault_integerdefault 4413 (ffebld_cu_ptr_realdefault (u), 4414 ffebld_constant_realdefault (ffebld_conter (l)), 4415 ffebld_constant_integerdefault (ffebld_conter (r))); 4416 expr = ffebld_new_conter_with_orig 4417 (ffebld_constant_new_realdefault_val 4418 (ffebld_cu_val_realdefault (u)), expr); 4419 break; 4420 4421 case FFEINFO_kindtypeREALDOUBLE: 4422 error = ffetarget_power_realdouble_integerdefault 4423 (ffebld_cu_ptr_realdouble (u), 4424 ffebld_constant_realdouble (ffebld_conter (l)), 4425 ffebld_constant_integerdefault (ffebld_conter (r))); 4426 expr = ffebld_new_conter_with_orig 4427 (ffebld_constant_new_realdouble_val 4428 (ffebld_cu_val_realdouble (u)), expr); 4429 break; 4430 4431#if FFETARGET_okREALQUAD 4432 case FFEINFO_kindtypeREALQUAD: 4433 error = ffetarget_power_realquad_integerdefault 4434 (ffebld_cu_ptr_realquad (u), 4435 ffebld_constant_realquad (ffebld_conter (l)), 4436 ffebld_constant_integerdefault (ffebld_conter (r))); 4437 expr = ffebld_new_conter_with_orig 4438 (ffebld_constant_new_realquad_val 4439 (ffebld_cu_val_realquad (u)), expr); 4440 break; 4441#endif 4442 default: 4443 assert ("bad real kind type" == NULL); 4444 break; 4445 } 4446 break; 4447 4448 case FFEINFO_basictypeCOMPLEX: 4449 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 4450 { 4451 case FFEINFO_kindtypeREALDEFAULT: 4452 error = ffetarget_power_complexdefault_integerdefault 4453 (ffebld_cu_ptr_complexdefault (u), 4454 ffebld_constant_complexdefault (ffebld_conter (l)), 4455 ffebld_constant_integerdefault (ffebld_conter (r))); 4456 expr = ffebld_new_conter_with_orig 4457 (ffebld_constant_new_complexdefault_val 4458 (ffebld_cu_val_complexdefault (u)), expr); 4459 break; 4460 4461#if FFETARGET_okCOMPLEXDOUBLE 4462 case FFEINFO_kindtypeREALDOUBLE: 4463 error = ffetarget_power_complexdouble_integerdefault 4464 (ffebld_cu_ptr_complexdouble (u), 4465 ffebld_constant_complexdouble (ffebld_conter (l)), 4466 ffebld_constant_integerdefault (ffebld_conter (r))); 4467 expr = ffebld_new_conter_with_orig 4468 (ffebld_constant_new_complexdouble_val 4469 (ffebld_cu_val_complexdouble (u)), expr); 4470 break; 4471#endif 4472 4473#if FFETARGET_okCOMPLEXQUAD 4474 case FFEINFO_kindtypeREALQUAD: 4475 error = ffetarget_power_complexquad_integerdefault 4476 (ffebld_cu_ptr_complexquad (u), 4477 ffebld_constant_complexquad (ffebld_conter (l)), 4478 ffebld_constant_integerdefault (ffebld_conter (r))); 4479 expr = ffebld_new_conter_with_orig 4480 (ffebld_constant_new_complexquad_val 4481 (ffebld_cu_val_complexquad (u)), expr); 4482 break; 4483#endif 4484 4485 default: 4486 assert ("bad complex kind type" == NULL); 4487 break; 4488 } 4489 break; 4490 4491 default: 4492 assert ("bad type" == NULL); 4493 return expr; 4494 } 4495 4496 ffebld_set_info (expr, ffeinfo_new 4497 (bt, 4498 kt, 4499 0, 4500 FFEINFO_kindENTITY, 4501 FFEINFO_whereCONSTANT, 4502 FFETARGET_charactersizeNONE)); 4503 4504 if ((error != FFEBAD) 4505 && ffebad_start (error)) 4506 { 4507 ffebad_here (0, ffelex_token_where_line (t), 4508 ffelex_token_where_column (t)); 4509 ffebad_finish (); 4510 } 4511 4512 return expr; 4513} 4514 4515/* ffeexpr_collapse_concatenate -- Collapse concatenate expr 4516 4517 ffebld expr; 4518 ffelexToken token; 4519 expr = ffeexpr_collapse_concatenate(expr,token); 4520 4521 If the result of the expr is a constant, replaces the expr with the 4522 computed constant. */ 4523 4524ffebld 4525ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t) 4526{ 4527 ffebad error = FFEBAD; 4528 ffebld l; 4529 ffebld r; 4530 ffebldConstantUnion u; 4531 ffeinfoKindtype kt; 4532 ffetargetCharacterSize len; 4533 4534 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 4535 return expr; 4536 4537 l = ffebld_left (expr); 4538 r = ffebld_right (expr); 4539 4540 if (ffebld_op (l) != FFEBLD_opCONTER) 4541 return expr; 4542 if (ffebld_op (r) != FFEBLD_opCONTER) 4543 return expr; 4544 4545 switch (ffeinfo_basictype (ffebld_info (expr))) 4546 { 4547 case FFEINFO_basictypeANY: 4548 return expr; 4549 4550 case FFEINFO_basictypeCHARACTER: 4551 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 4552 { 4553#if FFETARGET_okCHARACTER1 4554 case FFEINFO_kindtypeCHARACTER1: 4555 error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u), 4556 ffebld_constant_character1 (ffebld_conter (l)), 4557 ffebld_constant_character1 (ffebld_conter (r)), 4558 ffebld_constant_pool (), &len); 4559 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val 4560 (ffebld_cu_val_character1 (u)), expr); 4561 break; 4562#endif 4563 4564#if FFETARGET_okCHARACTER2 4565 case FFEINFO_kindtypeCHARACTER2: 4566 error = ffetarget_concatenate_character2 (ffebld_cu_ptr_character2 (u), 4567 ffebld_constant_character2 (ffebld_conter (l)), 4568 ffebld_constant_character2 (ffebld_conter (r)), 4569 ffebld_constant_pool (), &len); 4570 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val 4571 (ffebld_cu_val_character2 (u)), expr); 4572 break; 4573#endif 4574 4575#if FFETARGET_okCHARACTER3 4576 case FFEINFO_kindtypeCHARACTER3: 4577 error = ffetarget_concatenate_character3 (ffebld_cu_ptr_character3 (u), 4578 ffebld_constant_character3 (ffebld_conter (l)), 4579 ffebld_constant_character3 (ffebld_conter (r)), 4580 ffebld_constant_pool (), &len); 4581 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val 4582 (ffebld_cu_val_character3 (u)), expr); 4583 break; 4584#endif 4585 4586#if FFETARGET_okCHARACTER4 4587 case FFEINFO_kindtypeCHARACTER4: 4588 error = ffetarget_concatenate_character4 (ffebld_cu_ptr_character4 (u), 4589 ffebld_constant_character4 (ffebld_conter (l)), 4590 ffebld_constant_character4 (ffebld_conter (r)), 4591 ffebld_constant_pool (), &len); 4592 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val 4593 (ffebld_cu_val_character4 (u)), expr); 4594 break; 4595#endif 4596 4597 default: 4598 assert ("bad character kind type" == NULL); 4599 break; 4600 } 4601 break; 4602 4603 default: 4604 assert ("bad type" == NULL); 4605 return expr; 4606 } 4607 4608 ffebld_set_info (expr, ffeinfo_new 4609 (FFEINFO_basictypeCHARACTER, 4610 kt, 4611 0, 4612 FFEINFO_kindENTITY, 4613 FFEINFO_whereCONSTANT, 4614 len)); 4615 4616 if ((error != FFEBAD) 4617 && ffebad_start (error)) 4618 { 4619 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 4620 ffebad_finish (); 4621 } 4622 4623 return expr; 4624} 4625 4626/* ffeexpr_collapse_eq -- Collapse eq expr 4627 4628 ffebld expr; 4629 ffelexToken token; 4630 expr = ffeexpr_collapse_eq(expr,token); 4631 4632 If the result of the expr is a constant, replaces the expr with the 4633 computed constant. */ 4634 4635ffebld 4636ffeexpr_collapse_eq (ffebld expr, ffelexToken t) 4637{ 4638 ffebad error = FFEBAD; 4639 ffebld l; 4640 ffebld r; 4641 bool val; 4642 4643 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 4644 return expr; 4645 4646 l = ffebld_left (expr); 4647 r = ffebld_right (expr); 4648 4649 if (ffebld_op (l) != FFEBLD_opCONTER) 4650 return expr; 4651 if (ffebld_op (r) != FFEBLD_opCONTER) 4652 return expr; 4653 4654 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) 4655 { 4656 case FFEINFO_basictypeANY: 4657 return expr; 4658 4659 case FFEINFO_basictypeINTEGER: 4660 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 4661 { 4662#if FFETARGET_okINTEGER1 4663 case FFEINFO_kindtypeINTEGER1: 4664 error = ffetarget_eq_integer1 (&val, 4665 ffebld_constant_integer1 (ffebld_conter (l)), 4666 ffebld_constant_integer1 (ffebld_conter (r))); 4667 expr = ffebld_new_conter_with_orig 4668 (ffebld_constant_new_logicaldefault (val), expr); 4669 break; 4670#endif 4671 4672#if FFETARGET_okINTEGER2 4673 case FFEINFO_kindtypeINTEGER2: 4674 error = ffetarget_eq_integer2 (&val, 4675 ffebld_constant_integer2 (ffebld_conter (l)), 4676 ffebld_constant_integer2 (ffebld_conter (r))); 4677 expr = ffebld_new_conter_with_orig 4678 (ffebld_constant_new_logicaldefault (val), expr); 4679 break; 4680#endif 4681 4682#if FFETARGET_okINTEGER3 4683 case FFEINFO_kindtypeINTEGER3: 4684 error = ffetarget_eq_integer3 (&val, 4685 ffebld_constant_integer3 (ffebld_conter (l)), 4686 ffebld_constant_integer3 (ffebld_conter (r))); 4687 expr = ffebld_new_conter_with_orig 4688 (ffebld_constant_new_logicaldefault (val), expr); 4689 break; 4690#endif 4691 4692#if FFETARGET_okINTEGER4 4693 case FFEINFO_kindtypeINTEGER4: 4694 error = ffetarget_eq_integer4 (&val, 4695 ffebld_constant_integer4 (ffebld_conter (l)), 4696 ffebld_constant_integer4 (ffebld_conter (r))); 4697 expr = ffebld_new_conter_with_orig 4698 (ffebld_constant_new_logicaldefault (val), expr); 4699 break; 4700#endif 4701 4702 default: 4703 assert ("bad integer kind type" == NULL); 4704 break; 4705 } 4706 break; 4707 4708 case FFEINFO_basictypeREAL: 4709 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 4710 { 4711#if FFETARGET_okREAL1 4712 case FFEINFO_kindtypeREAL1: 4713 error = ffetarget_eq_real1 (&val, 4714 ffebld_constant_real1 (ffebld_conter (l)), 4715 ffebld_constant_real1 (ffebld_conter (r))); 4716 expr = ffebld_new_conter_with_orig 4717 (ffebld_constant_new_logicaldefault (val), expr); 4718 break; 4719#endif 4720 4721#if FFETARGET_okREAL2 4722 case FFEINFO_kindtypeREAL2: 4723 error = ffetarget_eq_real2 (&val, 4724 ffebld_constant_real2 (ffebld_conter (l)), 4725 ffebld_constant_real2 (ffebld_conter (r))); 4726 expr = ffebld_new_conter_with_orig 4727 (ffebld_constant_new_logicaldefault (val), expr); 4728 break; 4729#endif 4730 4731#if FFETARGET_okREAL3 4732 case FFEINFO_kindtypeREAL3: 4733 error = ffetarget_eq_real3 (&val, 4734 ffebld_constant_real3 (ffebld_conter (l)), 4735 ffebld_constant_real3 (ffebld_conter (r))); 4736 expr = ffebld_new_conter_with_orig 4737 (ffebld_constant_new_logicaldefault (val), expr); 4738 break; 4739#endif 4740 4741#if FFETARGET_okREAL4 4742 case FFEINFO_kindtypeREAL4: 4743 error = ffetarget_eq_real4 (&val, 4744 ffebld_constant_real4 (ffebld_conter (l)), 4745 ffebld_constant_real4 (ffebld_conter (r))); 4746 expr = ffebld_new_conter_with_orig 4747 (ffebld_constant_new_logicaldefault (val), expr); 4748 break; 4749#endif 4750 4751 default: 4752 assert ("bad real kind type" == NULL); 4753 break; 4754 } 4755 break; 4756 4757 case FFEINFO_basictypeCOMPLEX: 4758 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 4759 { 4760#if FFETARGET_okCOMPLEX1 4761 case FFEINFO_kindtypeREAL1: 4762 error = ffetarget_eq_complex1 (&val, 4763 ffebld_constant_complex1 (ffebld_conter (l)), 4764 ffebld_constant_complex1 (ffebld_conter (r))); 4765 expr = ffebld_new_conter_with_orig 4766 (ffebld_constant_new_logicaldefault (val), expr); 4767 break; 4768#endif 4769 4770#if FFETARGET_okCOMPLEX2 4771 case FFEINFO_kindtypeREAL2: 4772 error = ffetarget_eq_complex2 (&val, 4773 ffebld_constant_complex2 (ffebld_conter (l)), 4774 ffebld_constant_complex2 (ffebld_conter (r))); 4775 expr = ffebld_new_conter_with_orig 4776 (ffebld_constant_new_logicaldefault (val), expr); 4777 break; 4778#endif 4779 4780#if FFETARGET_okCOMPLEX3 4781 case FFEINFO_kindtypeREAL3: 4782 error = ffetarget_eq_complex3 (&val, 4783 ffebld_constant_complex3 (ffebld_conter (l)), 4784 ffebld_constant_complex3 (ffebld_conter (r))); 4785 expr = ffebld_new_conter_with_orig 4786 (ffebld_constant_new_logicaldefault (val), expr); 4787 break; 4788#endif 4789 4790#if FFETARGET_okCOMPLEX4 4791 case FFEINFO_kindtypeREAL4: 4792 error = ffetarget_eq_complex4 (&val, 4793 ffebld_constant_complex4 (ffebld_conter (l)), 4794 ffebld_constant_complex4 (ffebld_conter (r))); 4795 expr = ffebld_new_conter_with_orig 4796 (ffebld_constant_new_logicaldefault (val), expr); 4797 break; 4798#endif 4799 4800 default: 4801 assert ("bad complex kind type" == NULL); 4802 break; 4803 } 4804 break; 4805 4806 case FFEINFO_basictypeCHARACTER: 4807 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 4808 { 4809#if FFETARGET_okCHARACTER1 4810 case FFEINFO_kindtypeCHARACTER1: 4811 error = ffetarget_eq_character1 (&val, 4812 ffebld_constant_character1 (ffebld_conter (l)), 4813 ffebld_constant_character1 (ffebld_conter (r))); 4814 expr = ffebld_new_conter_with_orig 4815 (ffebld_constant_new_logicaldefault (val), expr); 4816 break; 4817#endif 4818 4819#if FFETARGET_okCHARACTER2 4820 case FFEINFO_kindtypeCHARACTER2: 4821 error = ffetarget_eq_character2 (&val, 4822 ffebld_constant_character2 (ffebld_conter (l)), 4823 ffebld_constant_character2 (ffebld_conter (r))); 4824 expr = ffebld_new_conter_with_orig 4825 (ffebld_constant_new_logicaldefault (val), expr); 4826 break; 4827#endif 4828 4829#if FFETARGET_okCHARACTER3 4830 case FFEINFO_kindtypeCHARACTER3: 4831 error = ffetarget_eq_character3 (&val, 4832 ffebld_constant_character3 (ffebld_conter (l)), 4833 ffebld_constant_character3 (ffebld_conter (r))); 4834 expr = ffebld_new_conter_with_orig 4835 (ffebld_constant_new_logicaldefault (val), expr); 4836 break; 4837#endif 4838 4839#if FFETARGET_okCHARACTER4 4840 case FFEINFO_kindtypeCHARACTER4: 4841 error = ffetarget_eq_character4 (&val, 4842 ffebld_constant_character4 (ffebld_conter (l)), 4843 ffebld_constant_character4 (ffebld_conter (r))); 4844 expr = ffebld_new_conter_with_orig 4845 (ffebld_constant_new_logicaldefault (val), expr); 4846 break; 4847#endif 4848 4849 default: 4850 assert ("bad character kind type" == NULL); 4851 break; 4852 } 4853 break; 4854 4855 default: 4856 assert ("bad type" == NULL); 4857 return expr; 4858 } 4859 4860 ffebld_set_info (expr, ffeinfo_new 4861 (FFEINFO_basictypeLOGICAL, 4862 FFEINFO_kindtypeLOGICALDEFAULT, 4863 0, 4864 FFEINFO_kindENTITY, 4865 FFEINFO_whereCONSTANT, 4866 FFETARGET_charactersizeNONE)); 4867 4868 if ((error != FFEBAD) 4869 && ffebad_start (error)) 4870 { 4871 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 4872 ffebad_finish (); 4873 } 4874 4875 return expr; 4876} 4877 4878/* ffeexpr_collapse_ne -- Collapse ne expr 4879 4880 ffebld expr; 4881 ffelexToken token; 4882 expr = ffeexpr_collapse_ne(expr,token); 4883 4884 If the result of the expr is a constant, replaces the expr with the 4885 computed constant. */ 4886 4887ffebld 4888ffeexpr_collapse_ne (ffebld expr, ffelexToken t) 4889{ 4890 ffebad error = FFEBAD; 4891 ffebld l; 4892 ffebld r; 4893 bool val; 4894 4895 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 4896 return expr; 4897 4898 l = ffebld_left (expr); 4899 r = ffebld_right (expr); 4900 4901 if (ffebld_op (l) != FFEBLD_opCONTER) 4902 return expr; 4903 if (ffebld_op (r) != FFEBLD_opCONTER) 4904 return expr; 4905 4906 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) 4907 { 4908 case FFEINFO_basictypeANY: 4909 return expr; 4910 4911 case FFEINFO_basictypeINTEGER: 4912 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 4913 { 4914#if FFETARGET_okINTEGER1 4915 case FFEINFO_kindtypeINTEGER1: 4916 error = ffetarget_ne_integer1 (&val, 4917 ffebld_constant_integer1 (ffebld_conter (l)), 4918 ffebld_constant_integer1 (ffebld_conter (r))); 4919 expr = ffebld_new_conter_with_orig 4920 (ffebld_constant_new_logicaldefault (val), expr); 4921 break; 4922#endif 4923 4924#if FFETARGET_okINTEGER2 4925 case FFEINFO_kindtypeINTEGER2: 4926 error = ffetarget_ne_integer2 (&val, 4927 ffebld_constant_integer2 (ffebld_conter (l)), 4928 ffebld_constant_integer2 (ffebld_conter (r))); 4929 expr = ffebld_new_conter_with_orig 4930 (ffebld_constant_new_logicaldefault (val), expr); 4931 break; 4932#endif 4933 4934#if FFETARGET_okINTEGER3 4935 case FFEINFO_kindtypeINTEGER3: 4936 error = ffetarget_ne_integer3 (&val, 4937 ffebld_constant_integer3 (ffebld_conter (l)), 4938 ffebld_constant_integer3 (ffebld_conter (r))); 4939 expr = ffebld_new_conter_with_orig 4940 (ffebld_constant_new_logicaldefault (val), expr); 4941 break; 4942#endif 4943 4944#if FFETARGET_okINTEGER4 4945 case FFEINFO_kindtypeINTEGER4: 4946 error = ffetarget_ne_integer4 (&val, 4947 ffebld_constant_integer4 (ffebld_conter (l)), 4948 ffebld_constant_integer4 (ffebld_conter (r))); 4949 expr = ffebld_new_conter_with_orig 4950 (ffebld_constant_new_logicaldefault (val), expr); 4951 break; 4952#endif 4953 4954 default: 4955 assert ("bad integer kind type" == NULL); 4956 break; 4957 } 4958 break; 4959 4960 case FFEINFO_basictypeREAL: 4961 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 4962 { 4963#if FFETARGET_okREAL1 4964 case FFEINFO_kindtypeREAL1: 4965 error = ffetarget_ne_real1 (&val, 4966 ffebld_constant_real1 (ffebld_conter (l)), 4967 ffebld_constant_real1 (ffebld_conter (r))); 4968 expr = ffebld_new_conter_with_orig 4969 (ffebld_constant_new_logicaldefault (val), expr); 4970 break; 4971#endif 4972 4973#if FFETARGET_okREAL2 4974 case FFEINFO_kindtypeREAL2: 4975 error = ffetarget_ne_real2 (&val, 4976 ffebld_constant_real2 (ffebld_conter (l)), 4977 ffebld_constant_real2 (ffebld_conter (r))); 4978 expr = ffebld_new_conter_with_orig 4979 (ffebld_constant_new_logicaldefault (val), expr); 4980 break; 4981#endif 4982 4983#if FFETARGET_okREAL3 4984 case FFEINFO_kindtypeREAL3: 4985 error = ffetarget_ne_real3 (&val, 4986 ffebld_constant_real3 (ffebld_conter (l)), 4987 ffebld_constant_real3 (ffebld_conter (r))); 4988 expr = ffebld_new_conter_with_orig 4989 (ffebld_constant_new_logicaldefault (val), expr); 4990 break; 4991#endif 4992 4993#if FFETARGET_okREAL4 4994 case FFEINFO_kindtypeREAL4: 4995 error = ffetarget_ne_real4 (&val, 4996 ffebld_constant_real4 (ffebld_conter (l)), 4997 ffebld_constant_real4 (ffebld_conter (r))); 4998 expr = ffebld_new_conter_with_orig 4999 (ffebld_constant_new_logicaldefault (val), expr); 5000 break; 5001#endif 5002 5003 default: 5004 assert ("bad real kind type" == NULL); 5005 break; 5006 } 5007 break; 5008 5009 case FFEINFO_basictypeCOMPLEX: 5010 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 5011 { 5012#if FFETARGET_okCOMPLEX1 5013 case FFEINFO_kindtypeREAL1: 5014 error = ffetarget_ne_complex1 (&val, 5015 ffebld_constant_complex1 (ffebld_conter (l)), 5016 ffebld_constant_complex1 (ffebld_conter (r))); 5017 expr = ffebld_new_conter_with_orig 5018 (ffebld_constant_new_logicaldefault (val), expr); 5019 break; 5020#endif 5021 5022#if FFETARGET_okCOMPLEX2 5023 case FFEINFO_kindtypeREAL2: 5024 error = ffetarget_ne_complex2 (&val, 5025 ffebld_constant_complex2 (ffebld_conter (l)), 5026 ffebld_constant_complex2 (ffebld_conter (r))); 5027 expr = ffebld_new_conter_with_orig 5028 (ffebld_constant_new_logicaldefault (val), expr); 5029 break; 5030#endif 5031 5032#if FFETARGET_okCOMPLEX3 5033 case FFEINFO_kindtypeREAL3: 5034 error = ffetarget_ne_complex3 (&val, 5035 ffebld_constant_complex3 (ffebld_conter (l)), 5036 ffebld_constant_complex3 (ffebld_conter (r))); 5037 expr = ffebld_new_conter_with_orig 5038 (ffebld_constant_new_logicaldefault (val), expr); 5039 break; 5040#endif 5041 5042#if FFETARGET_okCOMPLEX4 5043 case FFEINFO_kindtypeREAL4: 5044 error = ffetarget_ne_complex4 (&val, 5045 ffebld_constant_complex4 (ffebld_conter (l)), 5046 ffebld_constant_complex4 (ffebld_conter (r))); 5047 expr = ffebld_new_conter_with_orig 5048 (ffebld_constant_new_logicaldefault (val), expr); 5049 break; 5050#endif 5051 5052 default: 5053 assert ("bad complex kind type" == NULL); 5054 break; 5055 } 5056 break; 5057 5058 case FFEINFO_basictypeCHARACTER: 5059 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 5060 { 5061#if FFETARGET_okCHARACTER1 5062 case FFEINFO_kindtypeCHARACTER1: 5063 error = ffetarget_ne_character1 (&val, 5064 ffebld_constant_character1 (ffebld_conter (l)), 5065 ffebld_constant_character1 (ffebld_conter (r))); 5066 expr = ffebld_new_conter_with_orig 5067 (ffebld_constant_new_logicaldefault (val), expr); 5068 break; 5069#endif 5070 5071#if FFETARGET_okCHARACTER2 5072 case FFEINFO_kindtypeCHARACTER2: 5073 error = ffetarget_ne_character2 (&val, 5074 ffebld_constant_character2 (ffebld_conter (l)), 5075 ffebld_constant_character2 (ffebld_conter (r))); 5076 expr = ffebld_new_conter_with_orig 5077 (ffebld_constant_new_logicaldefault (val), expr); 5078 break; 5079#endif 5080 5081#if FFETARGET_okCHARACTER3 5082 case FFEINFO_kindtypeCHARACTER3: 5083 error = ffetarget_ne_character3 (&val, 5084 ffebld_constant_character3 (ffebld_conter (l)), 5085 ffebld_constant_character3 (ffebld_conter (r))); 5086 expr = ffebld_new_conter_with_orig 5087 (ffebld_constant_new_logicaldefault (val), expr); 5088 break; 5089#endif 5090 5091#if FFETARGET_okCHARACTER4 5092 case FFEINFO_kindtypeCHARACTER4: 5093 error = ffetarget_ne_character4 (&val, 5094 ffebld_constant_character4 (ffebld_conter (l)), 5095 ffebld_constant_character4 (ffebld_conter (r))); 5096 expr = ffebld_new_conter_with_orig 5097 (ffebld_constant_new_logicaldefault (val), expr); 5098 break; 5099#endif 5100 5101 default: 5102 assert ("bad character kind type" == NULL); 5103 break; 5104 } 5105 break; 5106 5107 default: 5108 assert ("bad type" == NULL); 5109 return expr; 5110 } 5111 5112 ffebld_set_info (expr, ffeinfo_new 5113 (FFEINFO_basictypeLOGICAL, 5114 FFEINFO_kindtypeLOGICALDEFAULT, 5115 0, 5116 FFEINFO_kindENTITY, 5117 FFEINFO_whereCONSTANT, 5118 FFETARGET_charactersizeNONE)); 5119 5120 if ((error != FFEBAD) 5121 && ffebad_start (error)) 5122 { 5123 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 5124 ffebad_finish (); 5125 } 5126 5127 return expr; 5128} 5129 5130/* ffeexpr_collapse_ge -- Collapse ge expr 5131 5132 ffebld expr; 5133 ffelexToken token; 5134 expr = ffeexpr_collapse_ge(expr,token); 5135 5136 If the result of the expr is a constant, replaces the expr with the 5137 computed constant. */ 5138 5139ffebld 5140ffeexpr_collapse_ge (ffebld expr, ffelexToken t) 5141{ 5142 ffebad error = FFEBAD; 5143 ffebld l; 5144 ffebld r; 5145 bool val; 5146 5147 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 5148 return expr; 5149 5150 l = ffebld_left (expr); 5151 r = ffebld_right (expr); 5152 5153 if (ffebld_op (l) != FFEBLD_opCONTER) 5154 return expr; 5155 if (ffebld_op (r) != FFEBLD_opCONTER) 5156 return expr; 5157 5158 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) 5159 { 5160 case FFEINFO_basictypeANY: 5161 return expr; 5162 5163 case FFEINFO_basictypeINTEGER: 5164 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 5165 { 5166#if FFETARGET_okINTEGER1 5167 case FFEINFO_kindtypeINTEGER1: 5168 error = ffetarget_ge_integer1 (&val, 5169 ffebld_constant_integer1 (ffebld_conter (l)), 5170 ffebld_constant_integer1 (ffebld_conter (r))); 5171 expr = ffebld_new_conter_with_orig 5172 (ffebld_constant_new_logicaldefault (val), expr); 5173 break; 5174#endif 5175 5176#if FFETARGET_okINTEGER2 5177 case FFEINFO_kindtypeINTEGER2: 5178 error = ffetarget_ge_integer2 (&val, 5179 ffebld_constant_integer2 (ffebld_conter (l)), 5180 ffebld_constant_integer2 (ffebld_conter (r))); 5181 expr = ffebld_new_conter_with_orig 5182 (ffebld_constant_new_logicaldefault (val), expr); 5183 break; 5184#endif 5185 5186#if FFETARGET_okINTEGER3 5187 case FFEINFO_kindtypeINTEGER3: 5188 error = ffetarget_ge_integer3 (&val, 5189 ffebld_constant_integer3 (ffebld_conter (l)), 5190 ffebld_constant_integer3 (ffebld_conter (r))); 5191 expr = ffebld_new_conter_with_orig 5192 (ffebld_constant_new_logicaldefault (val), expr); 5193 break; 5194#endif 5195 5196#if FFETARGET_okINTEGER4 5197 case FFEINFO_kindtypeINTEGER4: 5198 error = ffetarget_ge_integer4 (&val, 5199 ffebld_constant_integer4 (ffebld_conter (l)), 5200 ffebld_constant_integer4 (ffebld_conter (r))); 5201 expr = ffebld_new_conter_with_orig 5202 (ffebld_constant_new_logicaldefault (val), expr); 5203 break; 5204#endif 5205 5206 default: 5207 assert ("bad integer kind type" == NULL); 5208 break; 5209 } 5210 break; 5211 5212 case FFEINFO_basictypeREAL: 5213 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 5214 { 5215#if FFETARGET_okREAL1 5216 case FFEINFO_kindtypeREAL1: 5217 error = ffetarget_ge_real1 (&val, 5218 ffebld_constant_real1 (ffebld_conter (l)), 5219 ffebld_constant_real1 (ffebld_conter (r))); 5220 expr = ffebld_new_conter_with_orig 5221 (ffebld_constant_new_logicaldefault (val), expr); 5222 break; 5223#endif 5224 5225#if FFETARGET_okREAL2 5226 case FFEINFO_kindtypeREAL2: 5227 error = ffetarget_ge_real2 (&val, 5228 ffebld_constant_real2 (ffebld_conter (l)), 5229 ffebld_constant_real2 (ffebld_conter (r))); 5230 expr = ffebld_new_conter_with_orig 5231 (ffebld_constant_new_logicaldefault (val), expr); 5232 break; 5233#endif 5234 5235#if FFETARGET_okREAL3 5236 case FFEINFO_kindtypeREAL3: 5237 error = ffetarget_ge_real3 (&val, 5238 ffebld_constant_real3 (ffebld_conter (l)), 5239 ffebld_constant_real3 (ffebld_conter (r))); 5240 expr = ffebld_new_conter_with_orig 5241 (ffebld_constant_new_logicaldefault (val), expr); 5242 break; 5243#endif 5244 5245#if FFETARGET_okREAL4 5246 case FFEINFO_kindtypeREAL4: 5247 error = ffetarget_ge_real4 (&val, 5248 ffebld_constant_real4 (ffebld_conter (l)), 5249 ffebld_constant_real4 (ffebld_conter (r))); 5250 expr = ffebld_new_conter_with_orig 5251 (ffebld_constant_new_logicaldefault (val), expr); 5252 break; 5253#endif 5254 5255 default: 5256 assert ("bad real kind type" == NULL); 5257 break; 5258 } 5259 break; 5260 5261 case FFEINFO_basictypeCHARACTER: 5262 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 5263 { 5264#if FFETARGET_okCHARACTER1 5265 case FFEINFO_kindtypeCHARACTER1: 5266 error = ffetarget_ge_character1 (&val, 5267 ffebld_constant_character1 (ffebld_conter (l)), 5268 ffebld_constant_character1 (ffebld_conter (r))); 5269 expr = ffebld_new_conter_with_orig 5270 (ffebld_constant_new_logicaldefault (val), expr); 5271 break; 5272#endif 5273 5274#if FFETARGET_okCHARACTER2 5275 case FFEINFO_kindtypeCHARACTER2: 5276 error = ffetarget_ge_character2 (&val, 5277 ffebld_constant_character2 (ffebld_conter (l)), 5278 ffebld_constant_character2 (ffebld_conter (r))); 5279 expr = ffebld_new_conter_with_orig 5280 (ffebld_constant_new_logicaldefault (val), expr); 5281 break; 5282#endif 5283 5284#if FFETARGET_okCHARACTER3 5285 case FFEINFO_kindtypeCHARACTER3: 5286 error = ffetarget_ge_character3 (&val, 5287 ffebld_constant_character3 (ffebld_conter (l)), 5288 ffebld_constant_character3 (ffebld_conter (r))); 5289 expr = ffebld_new_conter_with_orig 5290 (ffebld_constant_new_logicaldefault (val), expr); 5291 break; 5292#endif 5293 5294#if FFETARGET_okCHARACTER4 5295 case FFEINFO_kindtypeCHARACTER4: 5296 error = ffetarget_ge_character4 (&val, 5297 ffebld_constant_character4 (ffebld_conter (l)), 5298 ffebld_constant_character4 (ffebld_conter (r))); 5299 expr = ffebld_new_conter_with_orig 5300 (ffebld_constant_new_logicaldefault (val), expr); 5301 break; 5302#endif 5303 5304 default: 5305 assert ("bad character kind type" == NULL); 5306 break; 5307 } 5308 break; 5309 5310 default: 5311 assert ("bad type" == NULL); 5312 return expr; 5313 } 5314 5315 ffebld_set_info (expr, ffeinfo_new 5316 (FFEINFO_basictypeLOGICAL, 5317 FFEINFO_kindtypeLOGICALDEFAULT, 5318 0, 5319 FFEINFO_kindENTITY, 5320 FFEINFO_whereCONSTANT, 5321 FFETARGET_charactersizeNONE)); 5322 5323 if ((error != FFEBAD) 5324 && ffebad_start (error)) 5325 { 5326 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 5327 ffebad_finish (); 5328 } 5329 5330 return expr; 5331} 5332 5333/* ffeexpr_collapse_gt -- Collapse gt expr 5334 5335 ffebld expr; 5336 ffelexToken token; 5337 expr = ffeexpr_collapse_gt(expr,token); 5338 5339 If the result of the expr is a constant, replaces the expr with the 5340 computed constant. */ 5341 5342ffebld 5343ffeexpr_collapse_gt (ffebld expr, ffelexToken t) 5344{ 5345 ffebad error = FFEBAD; 5346 ffebld l; 5347 ffebld r; 5348 bool val; 5349 5350 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 5351 return expr; 5352 5353 l = ffebld_left (expr); 5354 r = ffebld_right (expr); 5355 5356 if (ffebld_op (l) != FFEBLD_opCONTER) 5357 return expr; 5358 if (ffebld_op (r) != FFEBLD_opCONTER) 5359 return expr; 5360 5361 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) 5362 { 5363 case FFEINFO_basictypeANY: 5364 return expr; 5365 5366 case FFEINFO_basictypeINTEGER: 5367 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 5368 { 5369#if FFETARGET_okINTEGER1 5370 case FFEINFO_kindtypeINTEGER1: 5371 error = ffetarget_gt_integer1 (&val, 5372 ffebld_constant_integer1 (ffebld_conter (l)), 5373 ffebld_constant_integer1 (ffebld_conter (r))); 5374 expr = ffebld_new_conter_with_orig 5375 (ffebld_constant_new_logicaldefault (val), expr); 5376 break; 5377#endif 5378 5379#if FFETARGET_okINTEGER2 5380 case FFEINFO_kindtypeINTEGER2: 5381 error = ffetarget_gt_integer2 (&val, 5382 ffebld_constant_integer2 (ffebld_conter (l)), 5383 ffebld_constant_integer2 (ffebld_conter (r))); 5384 expr = ffebld_new_conter_with_orig 5385 (ffebld_constant_new_logicaldefault (val), expr); 5386 break; 5387#endif 5388 5389#if FFETARGET_okINTEGER3 5390 case FFEINFO_kindtypeINTEGER3: 5391 error = ffetarget_gt_integer3 (&val, 5392 ffebld_constant_integer3 (ffebld_conter (l)), 5393 ffebld_constant_integer3 (ffebld_conter (r))); 5394 expr = ffebld_new_conter_with_orig 5395 (ffebld_constant_new_logicaldefault (val), expr); 5396 break; 5397#endif 5398 5399#if FFETARGET_okINTEGER4 5400 case FFEINFO_kindtypeINTEGER4: 5401 error = ffetarget_gt_integer4 (&val, 5402 ffebld_constant_integer4 (ffebld_conter (l)), 5403 ffebld_constant_integer4 (ffebld_conter (r))); 5404 expr = ffebld_new_conter_with_orig 5405 (ffebld_constant_new_logicaldefault (val), expr); 5406 break; 5407#endif 5408 5409 default: 5410 assert ("bad integer kind type" == NULL); 5411 break; 5412 } 5413 break; 5414 5415 case FFEINFO_basictypeREAL: 5416 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 5417 { 5418#if FFETARGET_okREAL1 5419 case FFEINFO_kindtypeREAL1: 5420 error = ffetarget_gt_real1 (&val, 5421 ffebld_constant_real1 (ffebld_conter (l)), 5422 ffebld_constant_real1 (ffebld_conter (r))); 5423 expr = ffebld_new_conter_with_orig 5424 (ffebld_constant_new_logicaldefault (val), expr); 5425 break; 5426#endif 5427 5428#if FFETARGET_okREAL2 5429 case FFEINFO_kindtypeREAL2: 5430 error = ffetarget_gt_real2 (&val, 5431 ffebld_constant_real2 (ffebld_conter (l)), 5432 ffebld_constant_real2 (ffebld_conter (r))); 5433 expr = ffebld_new_conter_with_orig 5434 (ffebld_constant_new_logicaldefault (val), expr); 5435 break; 5436#endif 5437 5438#if FFETARGET_okREAL3 5439 case FFEINFO_kindtypeREAL3: 5440 error = ffetarget_gt_real3 (&val, 5441 ffebld_constant_real3 (ffebld_conter (l)), 5442 ffebld_constant_real3 (ffebld_conter (r))); 5443 expr = ffebld_new_conter_with_orig 5444 (ffebld_constant_new_logicaldefault (val), expr); 5445 break; 5446#endif 5447 5448#if FFETARGET_okREAL4 5449 case FFEINFO_kindtypeREAL4: 5450 error = ffetarget_gt_real4 (&val, 5451 ffebld_constant_real4 (ffebld_conter (l)), 5452 ffebld_constant_real4 (ffebld_conter (r))); 5453 expr = ffebld_new_conter_with_orig 5454 (ffebld_constant_new_logicaldefault (val), expr); 5455 break; 5456#endif 5457 5458 default: 5459 assert ("bad real kind type" == NULL); 5460 break; 5461 } 5462 break; 5463 5464 case FFEINFO_basictypeCHARACTER: 5465 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 5466 { 5467#if FFETARGET_okCHARACTER1 5468 case FFEINFO_kindtypeCHARACTER1: 5469 error = ffetarget_gt_character1 (&val, 5470 ffebld_constant_character1 (ffebld_conter (l)), 5471 ffebld_constant_character1 (ffebld_conter (r))); 5472 expr = ffebld_new_conter_with_orig 5473 (ffebld_constant_new_logicaldefault (val), expr); 5474 break; 5475#endif 5476 5477#if FFETARGET_okCHARACTER2 5478 case FFEINFO_kindtypeCHARACTER2: 5479 error = ffetarget_gt_character2 (&val, 5480 ffebld_constant_character2 (ffebld_conter (l)), 5481 ffebld_constant_character2 (ffebld_conter (r))); 5482 expr = ffebld_new_conter_with_orig 5483 (ffebld_constant_new_logicaldefault (val), expr); 5484 break; 5485#endif 5486 5487#if FFETARGET_okCHARACTER3 5488 case FFEINFO_kindtypeCHARACTER3: 5489 error = ffetarget_gt_character3 (&val, 5490 ffebld_constant_character3 (ffebld_conter (l)), 5491 ffebld_constant_character3 (ffebld_conter (r))); 5492 expr = ffebld_new_conter_with_orig 5493 (ffebld_constant_new_logicaldefault (val), expr); 5494 break; 5495#endif 5496 5497#if FFETARGET_okCHARACTER4 5498 case FFEINFO_kindtypeCHARACTER4: 5499 error = ffetarget_gt_character4 (&val, 5500 ffebld_constant_character4 (ffebld_conter (l)), 5501 ffebld_constant_character4 (ffebld_conter (r))); 5502 expr = ffebld_new_conter_with_orig 5503 (ffebld_constant_new_logicaldefault (val), expr); 5504 break; 5505#endif 5506 5507 default: 5508 assert ("bad character kind type" == NULL); 5509 break; 5510 } 5511 break; 5512 5513 default: 5514 assert ("bad type" == NULL); 5515 return expr; 5516 } 5517 5518 ffebld_set_info (expr, ffeinfo_new 5519 (FFEINFO_basictypeLOGICAL, 5520 FFEINFO_kindtypeLOGICALDEFAULT, 5521 0, 5522 FFEINFO_kindENTITY, 5523 FFEINFO_whereCONSTANT, 5524 FFETARGET_charactersizeNONE)); 5525 5526 if ((error != FFEBAD) 5527 && ffebad_start (error)) 5528 { 5529 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 5530 ffebad_finish (); 5531 } 5532 5533 return expr; 5534} 5535 5536/* ffeexpr_collapse_le -- Collapse le expr 5537 5538 ffebld expr; 5539 ffelexToken token; 5540 expr = ffeexpr_collapse_le(expr,token); 5541 5542 If the result of the expr is a constant, replaces the expr with the 5543 computed constant. */ 5544 5545ffebld 5546ffeexpr_collapse_le (ffebld expr, ffelexToken t) 5547{ 5548 ffebad error = FFEBAD; 5549 ffebld l; 5550 ffebld r; 5551 bool val; 5552 5553 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 5554 return expr; 5555 5556 l = ffebld_left (expr); 5557 r = ffebld_right (expr); 5558 5559 if (ffebld_op (l) != FFEBLD_opCONTER) 5560 return expr; 5561 if (ffebld_op (r) != FFEBLD_opCONTER) 5562 return expr; 5563 5564 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) 5565 { 5566 case FFEINFO_basictypeANY: 5567 return expr; 5568 5569 case FFEINFO_basictypeINTEGER: 5570 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 5571 { 5572#if FFETARGET_okINTEGER1 5573 case FFEINFO_kindtypeINTEGER1: 5574 error = ffetarget_le_integer1 (&val, 5575 ffebld_constant_integer1 (ffebld_conter (l)), 5576 ffebld_constant_integer1 (ffebld_conter (r))); 5577 expr = ffebld_new_conter_with_orig 5578 (ffebld_constant_new_logicaldefault (val), expr); 5579 break; 5580#endif 5581 5582#if FFETARGET_okINTEGER2 5583 case FFEINFO_kindtypeINTEGER2: 5584 error = ffetarget_le_integer2 (&val, 5585 ffebld_constant_integer2 (ffebld_conter (l)), 5586 ffebld_constant_integer2 (ffebld_conter (r))); 5587 expr = ffebld_new_conter_with_orig 5588 (ffebld_constant_new_logicaldefault (val), expr); 5589 break; 5590#endif 5591 5592#if FFETARGET_okINTEGER3 5593 case FFEINFO_kindtypeINTEGER3: 5594 error = ffetarget_le_integer3 (&val, 5595 ffebld_constant_integer3 (ffebld_conter (l)), 5596 ffebld_constant_integer3 (ffebld_conter (r))); 5597 expr = ffebld_new_conter_with_orig 5598 (ffebld_constant_new_logicaldefault (val), expr); 5599 break; 5600#endif 5601 5602#if FFETARGET_okINTEGER4 5603 case FFEINFO_kindtypeINTEGER4: 5604 error = ffetarget_le_integer4 (&val, 5605 ffebld_constant_integer4 (ffebld_conter (l)), 5606 ffebld_constant_integer4 (ffebld_conter (r))); 5607 expr = ffebld_new_conter_with_orig 5608 (ffebld_constant_new_logicaldefault (val), expr); 5609 break; 5610#endif 5611 5612 default: 5613 assert ("bad integer kind type" == NULL); 5614 break; 5615 } 5616 break; 5617 5618 case FFEINFO_basictypeREAL: 5619 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 5620 { 5621#if FFETARGET_okREAL1 5622 case FFEINFO_kindtypeREAL1: 5623 error = ffetarget_le_real1 (&val, 5624 ffebld_constant_real1 (ffebld_conter (l)), 5625 ffebld_constant_real1 (ffebld_conter (r))); 5626 expr = ffebld_new_conter_with_orig 5627 (ffebld_constant_new_logicaldefault (val), expr); 5628 break; 5629#endif 5630 5631#if FFETARGET_okREAL2 5632 case FFEINFO_kindtypeREAL2: 5633 error = ffetarget_le_real2 (&val, 5634 ffebld_constant_real2 (ffebld_conter (l)), 5635 ffebld_constant_real2 (ffebld_conter (r))); 5636 expr = ffebld_new_conter_with_orig 5637 (ffebld_constant_new_logicaldefault (val), expr); 5638 break; 5639#endif 5640 5641#if FFETARGET_okREAL3 5642 case FFEINFO_kindtypeREAL3: 5643 error = ffetarget_le_real3 (&val, 5644 ffebld_constant_real3 (ffebld_conter (l)), 5645 ffebld_constant_real3 (ffebld_conter (r))); 5646 expr = ffebld_new_conter_with_orig 5647 (ffebld_constant_new_logicaldefault (val), expr); 5648 break; 5649#endif 5650 5651#if FFETARGET_okREAL4 5652 case FFEINFO_kindtypeREAL4: 5653 error = ffetarget_le_real4 (&val, 5654 ffebld_constant_real4 (ffebld_conter (l)), 5655 ffebld_constant_real4 (ffebld_conter (r))); 5656 expr = ffebld_new_conter_with_orig 5657 (ffebld_constant_new_logicaldefault (val), expr); 5658 break; 5659#endif 5660 5661 default: 5662 assert ("bad real kind type" == NULL); 5663 break; 5664 } 5665 break; 5666 5667 case FFEINFO_basictypeCHARACTER: 5668 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 5669 { 5670#if FFETARGET_okCHARACTER1 5671 case FFEINFO_kindtypeCHARACTER1: 5672 error = ffetarget_le_character1 (&val, 5673 ffebld_constant_character1 (ffebld_conter (l)), 5674 ffebld_constant_character1 (ffebld_conter (r))); 5675 expr = ffebld_new_conter_with_orig 5676 (ffebld_constant_new_logicaldefault (val), expr); 5677 break; 5678#endif 5679 5680#if FFETARGET_okCHARACTER2 5681 case FFEINFO_kindtypeCHARACTER2: 5682 error = ffetarget_le_character2 (&val, 5683 ffebld_constant_character2 (ffebld_conter (l)), 5684 ffebld_constant_character2 (ffebld_conter (r))); 5685 expr = ffebld_new_conter_with_orig 5686 (ffebld_constant_new_logicaldefault (val), expr); 5687 break; 5688#endif 5689 5690#if FFETARGET_okCHARACTER3 5691 case FFEINFO_kindtypeCHARACTER3: 5692 error = ffetarget_le_character3 (&val, 5693 ffebld_constant_character3 (ffebld_conter (l)), 5694 ffebld_constant_character3 (ffebld_conter (r))); 5695 expr = ffebld_new_conter_with_orig 5696 (ffebld_constant_new_logicaldefault (val), expr); 5697 break; 5698#endif 5699 5700#if FFETARGET_okCHARACTER4 5701 case FFEINFO_kindtypeCHARACTER4: 5702 error = ffetarget_le_character4 (&val, 5703 ffebld_constant_character4 (ffebld_conter (l)), 5704 ffebld_constant_character4 (ffebld_conter (r))); 5705 expr = ffebld_new_conter_with_orig 5706 (ffebld_constant_new_logicaldefault (val), expr); 5707 break; 5708#endif 5709 5710 default: 5711 assert ("bad character kind type" == NULL); 5712 break; 5713 } 5714 break; 5715 5716 default: 5717 assert ("bad type" == NULL); 5718 return expr; 5719 } 5720 5721 ffebld_set_info (expr, ffeinfo_new 5722 (FFEINFO_basictypeLOGICAL, 5723 FFEINFO_kindtypeLOGICALDEFAULT, 5724 0, 5725 FFEINFO_kindENTITY, 5726 FFEINFO_whereCONSTANT, 5727 FFETARGET_charactersizeNONE)); 5728 5729 if ((error != FFEBAD) 5730 && ffebad_start (error)) 5731 { 5732 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 5733 ffebad_finish (); 5734 } 5735 5736 return expr; 5737} 5738 5739/* ffeexpr_collapse_lt -- Collapse lt expr 5740 5741 ffebld expr; 5742 ffelexToken token; 5743 expr = ffeexpr_collapse_lt(expr,token); 5744 5745 If the result of the expr is a constant, replaces the expr with the 5746 computed constant. */ 5747 5748ffebld 5749ffeexpr_collapse_lt (ffebld expr, ffelexToken t) 5750{ 5751 ffebad error = FFEBAD; 5752 ffebld l; 5753 ffebld r; 5754 bool val; 5755 5756 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 5757 return expr; 5758 5759 l = ffebld_left (expr); 5760 r = ffebld_right (expr); 5761 5762 if (ffebld_op (l) != FFEBLD_opCONTER) 5763 return expr; 5764 if (ffebld_op (r) != FFEBLD_opCONTER) 5765 return expr; 5766 5767 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) 5768 { 5769 case FFEINFO_basictypeANY: 5770 return expr; 5771 5772 case FFEINFO_basictypeINTEGER: 5773 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 5774 { 5775#if FFETARGET_okINTEGER1 5776 case FFEINFO_kindtypeINTEGER1: 5777 error = ffetarget_lt_integer1 (&val, 5778 ffebld_constant_integer1 (ffebld_conter (l)), 5779 ffebld_constant_integer1 (ffebld_conter (r))); 5780 expr = ffebld_new_conter_with_orig 5781 (ffebld_constant_new_logicaldefault (val), expr); 5782 break; 5783#endif 5784 5785#if FFETARGET_okINTEGER2 5786 case FFEINFO_kindtypeINTEGER2: 5787 error = ffetarget_lt_integer2 (&val, 5788 ffebld_constant_integer2 (ffebld_conter (l)), 5789 ffebld_constant_integer2 (ffebld_conter (r))); 5790 expr = ffebld_new_conter_with_orig 5791 (ffebld_constant_new_logicaldefault (val), expr); 5792 break; 5793#endif 5794 5795#if FFETARGET_okINTEGER3 5796 case FFEINFO_kindtypeINTEGER3: 5797 error = ffetarget_lt_integer3 (&val, 5798 ffebld_constant_integer3 (ffebld_conter (l)), 5799 ffebld_constant_integer3 (ffebld_conter (r))); 5800 expr = ffebld_new_conter_with_orig 5801 (ffebld_constant_new_logicaldefault (val), expr); 5802 break; 5803#endif 5804 5805#if FFETARGET_okINTEGER4 5806 case FFEINFO_kindtypeINTEGER4: 5807 error = ffetarget_lt_integer4 (&val, 5808 ffebld_constant_integer4 (ffebld_conter (l)), 5809 ffebld_constant_integer4 (ffebld_conter (r))); 5810 expr = ffebld_new_conter_with_orig 5811 (ffebld_constant_new_logicaldefault (val), expr); 5812 break; 5813#endif 5814 5815 default: 5816 assert ("bad integer kind type" == NULL); 5817 break; 5818 } 5819 break; 5820 5821 case FFEINFO_basictypeREAL: 5822 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 5823 { 5824#if FFETARGET_okREAL1 5825 case FFEINFO_kindtypeREAL1: 5826 error = ffetarget_lt_real1 (&val, 5827 ffebld_constant_real1 (ffebld_conter (l)), 5828 ffebld_constant_real1 (ffebld_conter (r))); 5829 expr = ffebld_new_conter_with_orig 5830 (ffebld_constant_new_logicaldefault (val), expr); 5831 break; 5832#endif 5833 5834#if FFETARGET_okREAL2 5835 case FFEINFO_kindtypeREAL2: 5836 error = ffetarget_lt_real2 (&val, 5837 ffebld_constant_real2 (ffebld_conter (l)), 5838 ffebld_constant_real2 (ffebld_conter (r))); 5839 expr = ffebld_new_conter_with_orig 5840 (ffebld_constant_new_logicaldefault (val), expr); 5841 break; 5842#endif 5843 5844#if FFETARGET_okREAL3 5845 case FFEINFO_kindtypeREAL3: 5846 error = ffetarget_lt_real3 (&val, 5847 ffebld_constant_real3 (ffebld_conter (l)), 5848 ffebld_constant_real3 (ffebld_conter (r))); 5849 expr = ffebld_new_conter_with_orig 5850 (ffebld_constant_new_logicaldefault (val), expr); 5851 break; 5852#endif 5853 5854#if FFETARGET_okREAL4 5855 case FFEINFO_kindtypeREAL4: 5856 error = ffetarget_lt_real4 (&val, 5857 ffebld_constant_real4 (ffebld_conter (l)), 5858 ffebld_constant_real4 (ffebld_conter (r))); 5859 expr = ffebld_new_conter_with_orig 5860 (ffebld_constant_new_logicaldefault (val), expr); 5861 break; 5862#endif 5863 5864 default: 5865 assert ("bad real kind type" == NULL); 5866 break; 5867 } 5868 break; 5869 5870 case FFEINFO_basictypeCHARACTER: 5871 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) 5872 { 5873#if FFETARGET_okCHARACTER1 5874 case FFEINFO_kindtypeCHARACTER1: 5875 error = ffetarget_lt_character1 (&val, 5876 ffebld_constant_character1 (ffebld_conter (l)), 5877 ffebld_constant_character1 (ffebld_conter (r))); 5878 expr = ffebld_new_conter_with_orig 5879 (ffebld_constant_new_logicaldefault (val), expr); 5880 break; 5881#endif 5882 5883#if FFETARGET_okCHARACTER2 5884 case FFEINFO_kindtypeCHARACTER2: 5885 error = ffetarget_lt_character2 (&val, 5886 ffebld_constant_character2 (ffebld_conter (l)), 5887 ffebld_constant_character2 (ffebld_conter (r))); 5888 expr = ffebld_new_conter_with_orig 5889 (ffebld_constant_new_logicaldefault (val), expr); 5890 break; 5891#endif 5892 5893#if FFETARGET_okCHARACTER3 5894 case FFEINFO_kindtypeCHARACTER3: 5895 error = ffetarget_lt_character3 (&val, 5896 ffebld_constant_character3 (ffebld_conter (l)), 5897 ffebld_constant_character3 (ffebld_conter (r))); 5898 expr = ffebld_new_conter_with_orig 5899 (ffebld_constant_new_logicaldefault (val), expr); 5900 break; 5901#endif 5902 5903#if FFETARGET_okCHARACTER4 5904 case FFEINFO_kindtypeCHARACTER4: 5905 error = ffetarget_lt_character4 (&val, 5906 ffebld_constant_character4 (ffebld_conter (l)), 5907 ffebld_constant_character4 (ffebld_conter (r))); 5908 expr = ffebld_new_conter_with_orig 5909 (ffebld_constant_new_logicaldefault (val), expr); 5910 break; 5911#endif 5912 5913 default: 5914 assert ("bad character kind type" == NULL); 5915 break; 5916 } 5917 break; 5918 5919 default: 5920 assert ("bad type" == NULL); 5921 return expr; 5922 } 5923 5924 ffebld_set_info (expr, ffeinfo_new 5925 (FFEINFO_basictypeLOGICAL, 5926 FFEINFO_kindtypeLOGICALDEFAULT, 5927 0, 5928 FFEINFO_kindENTITY, 5929 FFEINFO_whereCONSTANT, 5930 FFETARGET_charactersizeNONE)); 5931 5932 if ((error != FFEBAD) 5933 && ffebad_start (error)) 5934 { 5935 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 5936 ffebad_finish (); 5937 } 5938 5939 return expr; 5940} 5941 5942/* ffeexpr_collapse_and -- Collapse and expr 5943 5944 ffebld expr; 5945 ffelexToken token; 5946 expr = ffeexpr_collapse_and(expr,token); 5947 5948 If the result of the expr is a constant, replaces the expr with the 5949 computed constant. */ 5950 5951ffebld 5952ffeexpr_collapse_and (ffebld expr, ffelexToken t) 5953{ 5954 ffebad error = FFEBAD; 5955 ffebld l; 5956 ffebld r; 5957 ffebldConstantUnion u; 5958 ffeinfoBasictype bt; 5959 ffeinfoKindtype kt; 5960 5961 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 5962 return expr; 5963 5964 l = ffebld_left (expr); 5965 r = ffebld_right (expr); 5966 5967 if (ffebld_op (l) != FFEBLD_opCONTER) 5968 return expr; 5969 if (ffebld_op (r) != FFEBLD_opCONTER) 5970 return expr; 5971 5972 switch (bt = ffeinfo_basictype (ffebld_info (expr))) 5973 { 5974 case FFEINFO_basictypeANY: 5975 return expr; 5976 5977 case FFEINFO_basictypeINTEGER: 5978 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 5979 { 5980#if FFETARGET_okINTEGER1 5981 case FFEINFO_kindtypeINTEGER1: 5982 error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u), 5983 ffebld_constant_integer1 (ffebld_conter (l)), 5984 ffebld_constant_integer1 (ffebld_conter (r))); 5985 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val 5986 (ffebld_cu_val_integer1 (u)), expr); 5987 break; 5988#endif 5989 5990#if FFETARGET_okINTEGER2 5991 case FFEINFO_kindtypeINTEGER2: 5992 error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u), 5993 ffebld_constant_integer2 (ffebld_conter (l)), 5994 ffebld_constant_integer2 (ffebld_conter (r))); 5995 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val 5996 (ffebld_cu_val_integer2 (u)), expr); 5997 break; 5998#endif 5999 6000#if FFETARGET_okINTEGER3 6001 case FFEINFO_kindtypeINTEGER3: 6002 error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u), 6003 ffebld_constant_integer3 (ffebld_conter (l)), 6004 ffebld_constant_integer3 (ffebld_conter (r))); 6005 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val 6006 (ffebld_cu_val_integer3 (u)), expr); 6007 break; 6008#endif 6009 6010#if FFETARGET_okINTEGER4 6011 case FFEINFO_kindtypeINTEGER4: 6012 error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u), 6013 ffebld_constant_integer4 (ffebld_conter (l)), 6014 ffebld_constant_integer4 (ffebld_conter (r))); 6015 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val 6016 (ffebld_cu_val_integer4 (u)), expr); 6017 break; 6018#endif 6019 6020 default: 6021 assert ("bad integer kind type" == NULL); 6022 break; 6023 } 6024 break; 6025 6026 case FFEINFO_basictypeLOGICAL: 6027 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 6028 { 6029#if FFETARGET_okLOGICAL1 6030 case FFEINFO_kindtypeLOGICAL1: 6031 error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u), 6032 ffebld_constant_logical1 (ffebld_conter (l)), 6033 ffebld_constant_logical1 (ffebld_conter (r))); 6034 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val 6035 (ffebld_cu_val_logical1 (u)), expr); 6036 break; 6037#endif 6038 6039#if FFETARGET_okLOGICAL2 6040 case FFEINFO_kindtypeLOGICAL2: 6041 error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u), 6042 ffebld_constant_logical2 (ffebld_conter (l)), 6043 ffebld_constant_logical2 (ffebld_conter (r))); 6044 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val 6045 (ffebld_cu_val_logical2 (u)), expr); 6046 break; 6047#endif 6048 6049#if FFETARGET_okLOGICAL3 6050 case FFEINFO_kindtypeLOGICAL3: 6051 error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u), 6052 ffebld_constant_logical3 (ffebld_conter (l)), 6053 ffebld_constant_logical3 (ffebld_conter (r))); 6054 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val 6055 (ffebld_cu_val_logical3 (u)), expr); 6056 break; 6057#endif 6058 6059#if FFETARGET_okLOGICAL4 6060 case FFEINFO_kindtypeLOGICAL4: 6061 error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u), 6062 ffebld_constant_logical4 (ffebld_conter (l)), 6063 ffebld_constant_logical4 (ffebld_conter (r))); 6064 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val 6065 (ffebld_cu_val_logical4 (u)), expr); 6066 break; 6067#endif 6068 6069 default: 6070 assert ("bad logical kind type" == NULL); 6071 break; 6072 } 6073 break; 6074 6075 default: 6076 assert ("bad type" == NULL); 6077 return expr; 6078 } 6079 6080 ffebld_set_info (expr, ffeinfo_new 6081 (bt, 6082 kt, 6083 0, 6084 FFEINFO_kindENTITY, 6085 FFEINFO_whereCONSTANT, 6086 FFETARGET_charactersizeNONE)); 6087 6088 if ((error != FFEBAD) 6089 && ffebad_start (error)) 6090 { 6091 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 6092 ffebad_finish (); 6093 } 6094 6095 return expr; 6096} 6097 6098/* ffeexpr_collapse_or -- Collapse or expr 6099 6100 ffebld expr; 6101 ffelexToken token; 6102 expr = ffeexpr_collapse_or(expr,token); 6103 6104 If the result of the expr is a constant, replaces the expr with the 6105 computed constant. */ 6106 6107ffebld 6108ffeexpr_collapse_or (ffebld expr, ffelexToken t) 6109{ 6110 ffebad error = FFEBAD; 6111 ffebld l; 6112 ffebld r; 6113 ffebldConstantUnion u; 6114 ffeinfoBasictype bt; 6115 ffeinfoKindtype kt; 6116 6117 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 6118 return expr; 6119 6120 l = ffebld_left (expr); 6121 r = ffebld_right (expr); 6122 6123 if (ffebld_op (l) != FFEBLD_opCONTER) 6124 return expr; 6125 if (ffebld_op (r) != FFEBLD_opCONTER) 6126 return expr; 6127 6128 switch (bt = ffeinfo_basictype (ffebld_info (expr))) 6129 { 6130 case FFEINFO_basictypeANY: 6131 return expr; 6132 6133 case FFEINFO_basictypeINTEGER: 6134 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 6135 { 6136#if FFETARGET_okINTEGER1 6137 case FFEINFO_kindtypeINTEGER1: 6138 error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u), 6139 ffebld_constant_integer1 (ffebld_conter (l)), 6140 ffebld_constant_integer1 (ffebld_conter (r))); 6141 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val 6142 (ffebld_cu_val_integer1 (u)), expr); 6143 break; 6144#endif 6145 6146#if FFETARGET_okINTEGER2 6147 case FFEINFO_kindtypeINTEGER2: 6148 error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u), 6149 ffebld_constant_integer2 (ffebld_conter (l)), 6150 ffebld_constant_integer2 (ffebld_conter (r))); 6151 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val 6152 (ffebld_cu_val_integer2 (u)), expr); 6153 break; 6154#endif 6155 6156#if FFETARGET_okINTEGER3 6157 case FFEINFO_kindtypeINTEGER3: 6158 error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u), 6159 ffebld_constant_integer3 (ffebld_conter (l)), 6160 ffebld_constant_integer3 (ffebld_conter (r))); 6161 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val 6162 (ffebld_cu_val_integer3 (u)), expr); 6163 break; 6164#endif 6165 6166#if FFETARGET_okINTEGER4 6167 case FFEINFO_kindtypeINTEGER4: 6168 error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u), 6169 ffebld_constant_integer4 (ffebld_conter (l)), 6170 ffebld_constant_integer4 (ffebld_conter (r))); 6171 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val 6172 (ffebld_cu_val_integer4 (u)), expr); 6173 break; 6174#endif 6175 6176 default: 6177 assert ("bad integer kind type" == NULL); 6178 break; 6179 } 6180 break; 6181 6182 case FFEINFO_basictypeLOGICAL: 6183 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 6184 { 6185#if FFETARGET_okLOGICAL1 6186 case FFEINFO_kindtypeLOGICAL1: 6187 error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u), 6188 ffebld_constant_logical1 (ffebld_conter (l)), 6189 ffebld_constant_logical1 (ffebld_conter (r))); 6190 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val 6191 (ffebld_cu_val_logical1 (u)), expr); 6192 break; 6193#endif 6194 6195#if FFETARGET_okLOGICAL2 6196 case FFEINFO_kindtypeLOGICAL2: 6197 error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u), 6198 ffebld_constant_logical2 (ffebld_conter (l)), 6199 ffebld_constant_logical2 (ffebld_conter (r))); 6200 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val 6201 (ffebld_cu_val_logical2 (u)), expr); 6202 break; 6203#endif 6204 6205#if FFETARGET_okLOGICAL3 6206 case FFEINFO_kindtypeLOGICAL3: 6207 error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u), 6208 ffebld_constant_logical3 (ffebld_conter (l)), 6209 ffebld_constant_logical3 (ffebld_conter (r))); 6210 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val 6211 (ffebld_cu_val_logical3 (u)), expr); 6212 break; 6213#endif 6214 6215#if FFETARGET_okLOGICAL4 6216 case FFEINFO_kindtypeLOGICAL4: 6217 error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u), 6218 ffebld_constant_logical4 (ffebld_conter (l)), 6219 ffebld_constant_logical4 (ffebld_conter (r))); 6220 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val 6221 (ffebld_cu_val_logical4 (u)), expr); 6222 break; 6223#endif 6224 6225 default: 6226 assert ("bad logical kind type" == NULL); 6227 break; 6228 } 6229 break; 6230 6231 default: 6232 assert ("bad type" == NULL); 6233 return expr; 6234 } 6235 6236 ffebld_set_info (expr, ffeinfo_new 6237 (bt, 6238 kt, 6239 0, 6240 FFEINFO_kindENTITY, 6241 FFEINFO_whereCONSTANT, 6242 FFETARGET_charactersizeNONE)); 6243 6244 if ((error != FFEBAD) 6245 && ffebad_start (error)) 6246 { 6247 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 6248 ffebad_finish (); 6249 } 6250 6251 return expr; 6252} 6253 6254/* ffeexpr_collapse_xor -- Collapse xor expr 6255 6256 ffebld expr; 6257 ffelexToken token; 6258 expr = ffeexpr_collapse_xor(expr,token); 6259 6260 If the result of the expr is a constant, replaces the expr with the 6261 computed constant. */ 6262 6263ffebld 6264ffeexpr_collapse_xor (ffebld expr, ffelexToken t) 6265{ 6266 ffebad error = FFEBAD; 6267 ffebld l; 6268 ffebld r; 6269 ffebldConstantUnion u; 6270 ffeinfoBasictype bt; 6271 ffeinfoKindtype kt; 6272 6273 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 6274 return expr; 6275 6276 l = ffebld_left (expr); 6277 r = ffebld_right (expr); 6278 6279 if (ffebld_op (l) != FFEBLD_opCONTER) 6280 return expr; 6281 if (ffebld_op (r) != FFEBLD_opCONTER) 6282 return expr; 6283 6284 switch (bt = ffeinfo_basictype (ffebld_info (expr))) 6285 { 6286 case FFEINFO_basictypeANY: 6287 return expr; 6288 6289 case FFEINFO_basictypeINTEGER: 6290 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 6291 { 6292#if FFETARGET_okINTEGER1 6293 case FFEINFO_kindtypeINTEGER1: 6294 error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u), 6295 ffebld_constant_integer1 (ffebld_conter (l)), 6296 ffebld_constant_integer1 (ffebld_conter (r))); 6297 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val 6298 (ffebld_cu_val_integer1 (u)), expr); 6299 break; 6300#endif 6301 6302#if FFETARGET_okINTEGER2 6303 case FFEINFO_kindtypeINTEGER2: 6304 error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u), 6305 ffebld_constant_integer2 (ffebld_conter (l)), 6306 ffebld_constant_integer2 (ffebld_conter (r))); 6307 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val 6308 (ffebld_cu_val_integer2 (u)), expr); 6309 break; 6310#endif 6311 6312#if FFETARGET_okINTEGER3 6313 case FFEINFO_kindtypeINTEGER3: 6314 error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u), 6315 ffebld_constant_integer3 (ffebld_conter (l)), 6316 ffebld_constant_integer3 (ffebld_conter (r))); 6317 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val 6318 (ffebld_cu_val_integer3 (u)), expr); 6319 break; 6320#endif 6321 6322#if FFETARGET_okINTEGER4 6323 case FFEINFO_kindtypeINTEGER4: 6324 error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u), 6325 ffebld_constant_integer4 (ffebld_conter (l)), 6326 ffebld_constant_integer4 (ffebld_conter (r))); 6327 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val 6328 (ffebld_cu_val_integer4 (u)), expr); 6329 break; 6330#endif 6331 6332 default: 6333 assert ("bad integer kind type" == NULL); 6334 break; 6335 } 6336 break; 6337 6338 case FFEINFO_basictypeLOGICAL: 6339 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 6340 { 6341#if FFETARGET_okLOGICAL1 6342 case FFEINFO_kindtypeLOGICAL1: 6343 error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u), 6344 ffebld_constant_logical1 (ffebld_conter (l)), 6345 ffebld_constant_logical1 (ffebld_conter (r))); 6346 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val 6347 (ffebld_cu_val_logical1 (u)), expr); 6348 break; 6349#endif 6350 6351#if FFETARGET_okLOGICAL2 6352 case FFEINFO_kindtypeLOGICAL2: 6353 error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u), 6354 ffebld_constant_logical2 (ffebld_conter (l)), 6355 ffebld_constant_logical2 (ffebld_conter (r))); 6356 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val 6357 (ffebld_cu_val_logical2 (u)), expr); 6358 break; 6359#endif 6360 6361#if FFETARGET_okLOGICAL3 6362 case FFEINFO_kindtypeLOGICAL3: 6363 error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u), 6364 ffebld_constant_logical3 (ffebld_conter (l)), 6365 ffebld_constant_logical3 (ffebld_conter (r))); 6366 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val 6367 (ffebld_cu_val_logical3 (u)), expr); 6368 break; 6369#endif 6370 6371#if FFETARGET_okLOGICAL4 6372 case FFEINFO_kindtypeLOGICAL4: 6373 error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u), 6374 ffebld_constant_logical4 (ffebld_conter (l)), 6375 ffebld_constant_logical4 (ffebld_conter (r))); 6376 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val 6377 (ffebld_cu_val_logical4 (u)), expr); 6378 break; 6379#endif 6380 6381 default: 6382 assert ("bad logical kind type" == NULL); 6383 break; 6384 } 6385 break; 6386 6387 default: 6388 assert ("bad type" == NULL); 6389 return expr; 6390 } 6391 6392 ffebld_set_info (expr, ffeinfo_new 6393 (bt, 6394 kt, 6395 0, 6396 FFEINFO_kindENTITY, 6397 FFEINFO_whereCONSTANT, 6398 FFETARGET_charactersizeNONE)); 6399 6400 if ((error != FFEBAD) 6401 && ffebad_start (error)) 6402 { 6403 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 6404 ffebad_finish (); 6405 } 6406 6407 return expr; 6408} 6409 6410/* ffeexpr_collapse_eqv -- Collapse eqv expr 6411 6412 ffebld expr; 6413 ffelexToken token; 6414 expr = ffeexpr_collapse_eqv(expr,token); 6415 6416 If the result of the expr is a constant, replaces the expr with the 6417 computed constant. */ 6418 6419ffebld 6420ffeexpr_collapse_eqv (ffebld expr, ffelexToken t) 6421{ 6422 ffebad error = FFEBAD; 6423 ffebld l; 6424 ffebld r; 6425 ffebldConstantUnion u; 6426 ffeinfoBasictype bt; 6427 ffeinfoKindtype kt; 6428 6429 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 6430 return expr; 6431 6432 l = ffebld_left (expr); 6433 r = ffebld_right (expr); 6434 6435 if (ffebld_op (l) != FFEBLD_opCONTER) 6436 return expr; 6437 if (ffebld_op (r) != FFEBLD_opCONTER) 6438 return expr; 6439 6440 switch (bt = ffeinfo_basictype (ffebld_info (expr))) 6441 { 6442 case FFEINFO_basictypeANY: 6443 return expr; 6444 6445 case FFEINFO_basictypeINTEGER: 6446 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 6447 { 6448#if FFETARGET_okINTEGER1 6449 case FFEINFO_kindtypeINTEGER1: 6450 error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u), 6451 ffebld_constant_integer1 (ffebld_conter (l)), 6452 ffebld_constant_integer1 (ffebld_conter (r))); 6453 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val 6454 (ffebld_cu_val_integer1 (u)), expr); 6455 break; 6456#endif 6457 6458#if FFETARGET_okINTEGER2 6459 case FFEINFO_kindtypeINTEGER2: 6460 error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u), 6461 ffebld_constant_integer2 (ffebld_conter (l)), 6462 ffebld_constant_integer2 (ffebld_conter (r))); 6463 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val 6464 (ffebld_cu_val_integer2 (u)), expr); 6465 break; 6466#endif 6467 6468#if FFETARGET_okINTEGER3 6469 case FFEINFO_kindtypeINTEGER3: 6470 error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u), 6471 ffebld_constant_integer3 (ffebld_conter (l)), 6472 ffebld_constant_integer3 (ffebld_conter (r))); 6473 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val 6474 (ffebld_cu_val_integer3 (u)), expr); 6475 break; 6476#endif 6477 6478#if FFETARGET_okINTEGER4 6479 case FFEINFO_kindtypeINTEGER4: 6480 error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u), 6481 ffebld_constant_integer4 (ffebld_conter (l)), 6482 ffebld_constant_integer4 (ffebld_conter (r))); 6483 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val 6484 (ffebld_cu_val_integer4 (u)), expr); 6485 break; 6486#endif 6487 6488 default: 6489 assert ("bad integer kind type" == NULL); 6490 break; 6491 } 6492 break; 6493 6494 case FFEINFO_basictypeLOGICAL: 6495 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 6496 { 6497#if FFETARGET_okLOGICAL1 6498 case FFEINFO_kindtypeLOGICAL1: 6499 error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u), 6500 ffebld_constant_logical1 (ffebld_conter (l)), 6501 ffebld_constant_logical1 (ffebld_conter (r))); 6502 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val 6503 (ffebld_cu_val_logical1 (u)), expr); 6504 break; 6505#endif 6506 6507#if FFETARGET_okLOGICAL2 6508 case FFEINFO_kindtypeLOGICAL2: 6509 error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u), 6510 ffebld_constant_logical2 (ffebld_conter (l)), 6511 ffebld_constant_logical2 (ffebld_conter (r))); 6512 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val 6513 (ffebld_cu_val_logical2 (u)), expr); 6514 break; 6515#endif 6516 6517#if FFETARGET_okLOGICAL3 6518 case FFEINFO_kindtypeLOGICAL3: 6519 error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u), 6520 ffebld_constant_logical3 (ffebld_conter (l)), 6521 ffebld_constant_logical3 (ffebld_conter (r))); 6522 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val 6523 (ffebld_cu_val_logical3 (u)), expr); 6524 break; 6525#endif 6526 6527#if FFETARGET_okLOGICAL4 6528 case FFEINFO_kindtypeLOGICAL4: 6529 error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u), 6530 ffebld_constant_logical4 (ffebld_conter (l)), 6531 ffebld_constant_logical4 (ffebld_conter (r))); 6532 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val 6533 (ffebld_cu_val_logical4 (u)), expr); 6534 break; 6535#endif 6536 6537 default: 6538 assert ("bad logical kind type" == NULL); 6539 break; 6540 } 6541 break; 6542 6543 default: 6544 assert ("bad type" == NULL); 6545 return expr; 6546 } 6547 6548 ffebld_set_info (expr, ffeinfo_new 6549 (bt, 6550 kt, 6551 0, 6552 FFEINFO_kindENTITY, 6553 FFEINFO_whereCONSTANT, 6554 FFETARGET_charactersizeNONE)); 6555 6556 if ((error != FFEBAD) 6557 && ffebad_start (error)) 6558 { 6559 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 6560 ffebad_finish (); 6561 } 6562 6563 return expr; 6564} 6565 6566/* ffeexpr_collapse_neqv -- Collapse neqv expr 6567 6568 ffebld expr; 6569 ffelexToken token; 6570 expr = ffeexpr_collapse_neqv(expr,token); 6571 6572 If the result of the expr is a constant, replaces the expr with the 6573 computed constant. */ 6574 6575ffebld 6576ffeexpr_collapse_neqv (ffebld expr, ffelexToken t) 6577{ 6578 ffebad error = FFEBAD; 6579 ffebld l; 6580 ffebld r; 6581 ffebldConstantUnion u; 6582 ffeinfoBasictype bt; 6583 ffeinfoKindtype kt; 6584 6585 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 6586 return expr; 6587 6588 l = ffebld_left (expr); 6589 r = ffebld_right (expr); 6590 6591 if (ffebld_op (l) != FFEBLD_opCONTER) 6592 return expr; 6593 if (ffebld_op (r) != FFEBLD_opCONTER) 6594 return expr; 6595 6596 switch (bt = ffeinfo_basictype (ffebld_info (expr))) 6597 { 6598 case FFEINFO_basictypeANY: 6599 return expr; 6600 6601 case FFEINFO_basictypeINTEGER: 6602 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 6603 { 6604#if FFETARGET_okINTEGER1 6605 case FFEINFO_kindtypeINTEGER1: 6606 error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u), 6607 ffebld_constant_integer1 (ffebld_conter (l)), 6608 ffebld_constant_integer1 (ffebld_conter (r))); 6609 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val 6610 (ffebld_cu_val_integer1 (u)), expr); 6611 break; 6612#endif 6613 6614#if FFETARGET_okINTEGER2 6615 case FFEINFO_kindtypeINTEGER2: 6616 error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u), 6617 ffebld_constant_integer2 (ffebld_conter (l)), 6618 ffebld_constant_integer2 (ffebld_conter (r))); 6619 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val 6620 (ffebld_cu_val_integer2 (u)), expr); 6621 break; 6622#endif 6623 6624#if FFETARGET_okINTEGER3 6625 case FFEINFO_kindtypeINTEGER3: 6626 error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u), 6627 ffebld_constant_integer3 (ffebld_conter (l)), 6628 ffebld_constant_integer3 (ffebld_conter (r))); 6629 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val 6630 (ffebld_cu_val_integer3 (u)), expr); 6631 break; 6632#endif 6633 6634#if FFETARGET_okINTEGER4 6635 case FFEINFO_kindtypeINTEGER4: 6636 error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u), 6637 ffebld_constant_integer4 (ffebld_conter (l)), 6638 ffebld_constant_integer4 (ffebld_conter (r))); 6639 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val 6640 (ffebld_cu_val_integer4 (u)), expr); 6641 break; 6642#endif 6643 6644 default: 6645 assert ("bad integer kind type" == NULL); 6646 break; 6647 } 6648 break; 6649 6650 case FFEINFO_basictypeLOGICAL: 6651 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 6652 { 6653#if FFETARGET_okLOGICAL1 6654 case FFEINFO_kindtypeLOGICAL1: 6655 error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u), 6656 ffebld_constant_logical1 (ffebld_conter (l)), 6657 ffebld_constant_logical1 (ffebld_conter (r))); 6658 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val 6659 (ffebld_cu_val_logical1 (u)), expr); 6660 break; 6661#endif 6662 6663#if FFETARGET_okLOGICAL2 6664 case FFEINFO_kindtypeLOGICAL2: 6665 error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u), 6666 ffebld_constant_logical2 (ffebld_conter (l)), 6667 ffebld_constant_logical2 (ffebld_conter (r))); 6668 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val 6669 (ffebld_cu_val_logical2 (u)), expr); 6670 break; 6671#endif 6672 6673#if FFETARGET_okLOGICAL3 6674 case FFEINFO_kindtypeLOGICAL3: 6675 error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u), 6676 ffebld_constant_logical3 (ffebld_conter (l)), 6677 ffebld_constant_logical3 (ffebld_conter (r))); 6678 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val 6679 (ffebld_cu_val_logical3 (u)), expr); 6680 break; 6681#endif 6682 6683#if FFETARGET_okLOGICAL4 6684 case FFEINFO_kindtypeLOGICAL4: 6685 error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u), 6686 ffebld_constant_logical4 (ffebld_conter (l)), 6687 ffebld_constant_logical4 (ffebld_conter (r))); 6688 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val 6689 (ffebld_cu_val_logical4 (u)), expr); 6690 break; 6691#endif 6692 6693 default: 6694 assert ("bad logical kind type" == NULL); 6695 break; 6696 } 6697 break; 6698 6699 default: 6700 assert ("bad type" == NULL); 6701 return expr; 6702 } 6703 6704 ffebld_set_info (expr, ffeinfo_new 6705 (bt, 6706 kt, 6707 0, 6708 FFEINFO_kindENTITY, 6709 FFEINFO_whereCONSTANT, 6710 FFETARGET_charactersizeNONE)); 6711 6712 if ((error != FFEBAD) 6713 && ffebad_start (error)) 6714 { 6715 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 6716 ffebad_finish (); 6717 } 6718 6719 return expr; 6720} 6721 6722/* ffeexpr_collapse_symter -- Collapse symter expr 6723 6724 ffebld expr; 6725 ffelexToken token; 6726 expr = ffeexpr_collapse_symter(expr,token); 6727 6728 If the result of the expr is a constant, replaces the expr with the 6729 computed constant. */ 6730 6731ffebld 6732ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED) 6733{ 6734 ffebld r; 6735 ffeinfoBasictype bt; 6736 ffeinfoKindtype kt; 6737 ffetargetCharacterSize len; 6738 6739 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 6740 return expr; 6741 6742 if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL) 6743 return expr; /* A PARAMETER lhs in progress. */ 6744 6745 switch (ffebld_op (r)) 6746 { 6747 case FFEBLD_opCONTER: 6748 break; 6749 6750 case FFEBLD_opANY: 6751 return r; 6752 6753 default: 6754 return expr; 6755 } 6756 6757 bt = ffeinfo_basictype (ffebld_info (r)); 6758 kt = ffeinfo_kindtype (ffebld_info (r)); 6759 len = ffebld_size (r); 6760 6761 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)), 6762 expr); 6763 6764 ffebld_set_info (expr, ffeinfo_new 6765 (bt, 6766 kt, 6767 0, 6768 FFEINFO_kindENTITY, 6769 FFEINFO_whereCONSTANT, 6770 len)); 6771 6772 return expr; 6773} 6774 6775/* ffeexpr_collapse_funcref -- Collapse funcref expr 6776 6777 ffebld expr; 6778 ffelexToken token; 6779 expr = ffeexpr_collapse_funcref(expr,token); 6780 6781 If the result of the expr is a constant, replaces the expr with the 6782 computed constant. */ 6783 6784ffebld 6785ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED) 6786{ 6787 return expr; /* ~~someday go ahead and collapse these, 6788 though not required */ 6789} 6790 6791/* ffeexpr_collapse_arrayref -- Collapse arrayref expr 6792 6793 ffebld expr; 6794 ffelexToken token; 6795 expr = ffeexpr_collapse_arrayref(expr,token); 6796 6797 If the result of the expr is a constant, replaces the expr with the 6798 computed constant. */ 6799 6800ffebld 6801ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED) 6802{ 6803 return expr; 6804} 6805 6806/* ffeexpr_collapse_substr -- Collapse substr expr 6807 6808 ffebld expr; 6809 ffelexToken token; 6810 expr = ffeexpr_collapse_substr(expr,token); 6811 6812 If the result of the expr is a constant, replaces the expr with the 6813 computed constant. */ 6814 6815ffebld 6816ffeexpr_collapse_substr (ffebld expr, ffelexToken t) 6817{ 6818 ffebad error = FFEBAD; 6819 ffebld l; 6820 ffebld r; 6821 ffebld start; 6822 ffebld stop; 6823 ffebldConstantUnion u; 6824 ffeinfoKindtype kt; 6825 ffetargetCharacterSize len; 6826 ffetargetIntegerDefault first; 6827 ffetargetIntegerDefault last; 6828 6829 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) 6830 return expr; 6831 6832 l = ffebld_left (expr); 6833 r = ffebld_right (expr); /* opITEM. */ 6834 6835 if (ffebld_op (l) != FFEBLD_opCONTER) 6836 return expr; 6837 6838 kt = ffeinfo_kindtype (ffebld_info (l)); 6839 len = ffebld_size (l); 6840 6841 start = ffebld_head (r); 6842 stop = ffebld_head (ffebld_trail (r)); 6843 if (start == NULL) 6844 first = 1; 6845 else 6846 { 6847 if ((ffebld_op (start) != FFEBLD_opCONTER) 6848 || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER) 6849 || (ffeinfo_kindtype (ffebld_info (start)) 6850 != FFEINFO_kindtypeINTEGERDEFAULT)) 6851 return expr; 6852 first = ffebld_constant_integerdefault (ffebld_conter (start)); 6853 } 6854 if (stop == NULL) 6855 last = len; 6856 else 6857 { 6858 if ((ffebld_op (stop) != FFEBLD_opCONTER) 6859 || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER) 6860 || (ffeinfo_kindtype (ffebld_info (stop)) 6861 != FFEINFO_kindtypeINTEGERDEFAULT)) 6862 return expr; 6863 last = ffebld_constant_integerdefault (ffebld_conter (stop)); 6864 } 6865 6866 /* Handle problems that should have already been diagnosed, but 6867 left in the expression tree. */ 6868 6869 if (first <= 0) 6870 first = 1; 6871 if (last < first) 6872 last = first + len - 1; 6873 6874 if ((first == 1) && (last == len)) 6875 { /* Same as original. */ 6876 expr = ffebld_new_conter_with_orig (ffebld_constant_copy 6877 (ffebld_conter (l)), expr); 6878 ffebld_set_info (expr, ffeinfo_new 6879 (FFEINFO_basictypeCHARACTER, 6880 kt, 6881 0, 6882 FFEINFO_kindENTITY, 6883 FFEINFO_whereCONSTANT, 6884 len)); 6885 6886 return expr; 6887 } 6888 6889 switch (ffeinfo_basictype (ffebld_info (expr))) 6890 { 6891 case FFEINFO_basictypeANY: 6892 return expr; 6893 6894 case FFEINFO_basictypeCHARACTER: 6895 switch (kt = ffeinfo_kindtype (ffebld_info (expr))) 6896 { 6897#if FFETARGET_okCHARACTER1 6898 case FFEINFO_kindtypeCHARACTER1: 6899 error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u), 6900 ffebld_constant_character1 (ffebld_conter (l)), first, last, 6901 ffebld_constant_pool (), &len); 6902 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val 6903 (ffebld_cu_val_character1 (u)), expr); 6904 break; 6905#endif 6906 6907#if FFETARGET_okCHARACTER2 6908 case FFEINFO_kindtypeCHARACTER2: 6909 error = ffetarget_substr_character2 (ffebld_cu_ptr_character2 (u), 6910 ffebld_constant_character2 (ffebld_conter (l)), first, last, 6911 ffebld_constant_pool (), &len); 6912 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val 6913 (ffebld_cu_val_character2 (u)), expr); 6914 break; 6915#endif 6916 6917#if FFETARGET_okCHARACTER3 6918 case FFEINFO_kindtypeCHARACTER3: 6919 error = ffetarget_substr_character3 (ffebld_cu_ptr_character3 (u), 6920 ffebld_constant_character3 (ffebld_conter (l)), first, last, 6921 ffebld_constant_pool (), &len); 6922 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val 6923 (ffebld_cu_val_character3 (u)), expr); 6924 break; 6925#endif 6926 6927#if FFETARGET_okCHARACTER4 6928 case FFEINFO_kindtypeCHARACTER4: 6929 error = ffetarget_substr_character4 (ffebld_cu_ptr_character4 (u), 6930 ffebld_constant_character4 (ffebld_conter (l)), first, last, 6931 ffebld_constant_pool (), &len); 6932 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val 6933 (ffebld_cu_val_character4 (u)), expr); 6934 break; 6935#endif 6936 6937 default: 6938 assert ("bad character kind type" == NULL); 6939 break; 6940 } 6941 break; 6942 6943 default: 6944 assert ("bad type" == NULL); 6945 return expr; 6946 } 6947 6948 ffebld_set_info (expr, ffeinfo_new 6949 (FFEINFO_basictypeCHARACTER, 6950 kt, 6951 0, 6952 FFEINFO_kindENTITY, 6953 FFEINFO_whereCONSTANT, 6954 len)); 6955 6956 if ((error != FFEBAD) 6957 && ffebad_start (error)) 6958 { 6959 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 6960 ffebad_finish (); 6961 } 6962 6963 return expr; 6964} 6965 6966/* ffeexpr_convert -- Convert source expression to given type 6967 6968 ffebld source; 6969 ffelexToken source_token; 6970 ffelexToken dest_token; // Any appropriate token for "destination". 6971 ffeinfoBasictype bt; 6972 ffeinfoKindtype kt; 6973 ffetargetCharactersize sz; 6974 ffeexprContext context; // Mainly LET or DATA. 6975 source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context); 6976 6977 If the expression conforms, returns the source expression. Otherwise 6978 returns source wrapped in a convert node doing the conversion, or 6979 ANY wrapped in convert if there is a conversion error (and issues an 6980 error message). Be sensitive to the context for certain aspects of 6981 the conversion. */ 6982 6983ffebld 6984ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token, 6985 ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk, 6986 ffetargetCharacterSize sz, ffeexprContext context) 6987{ 6988 bool bad; 6989 ffeinfo info; 6990 ffeinfoWhere wh; 6991 6992 info = ffebld_info (source); 6993 if ((bt != ffeinfo_basictype (info)) 6994 || (kt != ffeinfo_kindtype (info)) 6995 || (rk != 0) /* Can't convert from or to arrays yet. */ 6996 || (ffeinfo_rank (info) != 0) 6997 || (sz != ffebld_size_known (source))) 6998#if 0 /* Nobody seems to need this spurious CONVERT node. */ 6999 || ((context != FFEEXPR_contextLET) 7000 && (bt == FFEINFO_basictypeCHARACTER) 7001 && (sz == FFETARGET_charactersizeNONE))) 7002#endif 7003 { 7004 switch (ffeinfo_basictype (info)) 7005 { 7006 case FFEINFO_basictypeLOGICAL: 7007 switch (bt) 7008 { 7009 case FFEINFO_basictypeLOGICAL: 7010 bad = FALSE; 7011 break; 7012 7013 case FFEINFO_basictypeINTEGER: 7014 bad = !ffe_is_ugly_logint (); 7015 break; 7016 7017 case FFEINFO_basictypeCHARACTER: 7018 bad = ffe_is_pedantic () 7019 || !(ffe_is_ugly_init () 7020 && (context == FFEEXPR_contextDATA)); 7021 break; 7022 7023 default: 7024 bad = TRUE; 7025 break; 7026 } 7027 break; 7028 7029 case FFEINFO_basictypeINTEGER: 7030 switch (bt) 7031 { 7032 case FFEINFO_basictypeINTEGER: 7033 case FFEINFO_basictypeREAL: 7034 case FFEINFO_basictypeCOMPLEX: 7035 bad = FALSE; 7036 break; 7037 7038 case FFEINFO_basictypeLOGICAL: 7039 bad = !ffe_is_ugly_logint (); 7040 break; 7041 7042 case FFEINFO_basictypeCHARACTER: 7043 bad = ffe_is_pedantic () 7044 || !(ffe_is_ugly_init () 7045 && (context == FFEEXPR_contextDATA)); 7046 break; 7047 7048 default: 7049 bad = TRUE; 7050 break; 7051 } 7052 break; 7053 7054 case FFEINFO_basictypeREAL: 7055 case FFEINFO_basictypeCOMPLEX: 7056 switch (bt) 7057 { 7058 case FFEINFO_basictypeINTEGER: 7059 case FFEINFO_basictypeREAL: 7060 case FFEINFO_basictypeCOMPLEX: 7061 bad = FALSE; 7062 break; 7063 7064 case FFEINFO_basictypeCHARACTER: 7065 bad = TRUE; 7066 break; 7067 7068 default: 7069 bad = TRUE; 7070 break; 7071 } 7072 break; 7073 7074 case FFEINFO_basictypeCHARACTER: 7075 bad = (bt != FFEINFO_basictypeCHARACTER) 7076 && (ffe_is_pedantic () 7077 || (bt != FFEINFO_basictypeINTEGER) 7078 || !(ffe_is_ugly_init () 7079 && (context == FFEEXPR_contextDATA))); 7080 break; 7081 7082 case FFEINFO_basictypeTYPELESS: 7083 case FFEINFO_basictypeHOLLERITH: 7084 bad = ffe_is_pedantic () 7085 || !(ffe_is_ugly_init () 7086 && ((context == FFEEXPR_contextDATA) 7087 || (context == FFEEXPR_contextLET))); 7088 break; 7089 7090 default: 7091 bad = TRUE; 7092 break; 7093 } 7094 7095 if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0))) 7096 bad = TRUE; 7097 7098 if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY) 7099 && (ffeinfo_basictype (info) != FFEINFO_basictypeANY) 7100 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY) 7101 && (ffeinfo_where (info) != FFEINFO_whereANY)) 7102 { 7103 if (ffebad_start (FFEBAD_BAD_TYPES)) 7104 { 7105 if (dest_token == NULL) 7106 ffebad_here (0, ffewhere_line_unknown (), 7107 ffewhere_column_unknown ()); 7108 else 7109 ffebad_here (0, ffelex_token_where_line (dest_token), 7110 ffelex_token_where_column (dest_token)); 7111 assert (source_token != NULL); 7112 ffebad_here (1, ffelex_token_where_line (source_token), 7113 ffelex_token_where_column (source_token)); 7114 ffebad_finish (); 7115 } 7116 7117 source = ffebld_new_any (); 7118 ffebld_set_info (source, ffeinfo_new_any ()); 7119 } 7120 else 7121 { 7122 switch (ffeinfo_where (info)) 7123 { 7124 case FFEINFO_whereCONSTANT: 7125 wh = FFEINFO_whereCONSTANT; 7126 break; 7127 7128 case FFEINFO_whereIMMEDIATE: 7129 wh = FFEINFO_whereIMMEDIATE; 7130 break; 7131 7132 default: 7133 wh = FFEINFO_whereFLEETING; 7134 break; 7135 } 7136 source = ffebld_new_convert (source); 7137 ffebld_set_info (source, ffeinfo_new 7138 (bt, 7139 kt, 7140 0, 7141 FFEINFO_kindENTITY, 7142 wh, 7143 sz)); 7144 source = ffeexpr_collapse_convert (source, source_token); 7145 } 7146 } 7147 7148 return source; 7149} 7150 7151/* ffeexpr_convert_expr -- Convert source expr to conform to dest expr 7152 7153 ffebld source; 7154 ffebld dest; 7155 ffelexToken source_token; 7156 ffelexToken dest_token; 7157 ffeexprContext context; 7158 source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context); 7159 7160 If the expressions conform, returns the source expression. Otherwise 7161 returns source wrapped in a convert node doing the conversion, or 7162 ANY wrapped in convert if there is a conversion error (and issues an 7163 error message). Be sensitive to the context, such as LET or DATA. */ 7164 7165ffebld 7166ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest, 7167 ffelexToken dest_token, ffeexprContext context) 7168{ 7169 ffeinfo info; 7170 7171 info = ffebld_info (dest); 7172 return ffeexpr_convert (source, source_token, dest_token, 7173 ffeinfo_basictype (info), 7174 ffeinfo_kindtype (info), 7175 ffeinfo_rank (info), 7176 ffebld_size_known (dest), 7177 context); 7178} 7179 7180/* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol 7181 7182 ffebld source; 7183 ffesymbol dest; 7184 ffelexToken source_token; 7185 ffelexToken dest_token; 7186 source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token); 7187 7188 If the expressions conform, returns the source expression. Otherwise 7189 returns source wrapped in a convert node doing the conversion, or 7190 ANY wrapped in convert if there is a conversion error (and issues an 7191 error message). */ 7192 7193ffebld 7194ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token, 7195 ffesymbol dest, ffelexToken dest_token) 7196{ 7197 return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest), 7198 ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest), 7199 FFEEXPR_contextLET); 7200} 7201 7202/* Initializes the module. */ 7203 7204void 7205ffeexpr_init_2 () 7206{ 7207 ffeexpr_stack_ = NULL; 7208 ffeexpr_level_ = 0; 7209} 7210 7211/* ffeexpr_lhs -- Begin processing left-hand-side-context expression 7212 7213 Prepares cluster for delivery of lexer tokens representing an expression 7214 in a left-hand-side context (A in A=B, for example). ffebld is used 7215 to build expressions in the given pool. The appropriate lexer-token 7216 handling routine within ffeexpr is returned. When the end of the 7217 expression is detected, mycallbackroutine is called with the resulting 7218 single ffebld object specifying the entire expression and the first 7219 lexer token that is not considered part of the expression. This caller- 7220 supplied routine itself returns a lexer-token handling routine. Thus, 7221 if necessary, ffeexpr can return several tokens as end-of-expression 7222 tokens if it needs to scan forward more than one in any instance. */ 7223 7224ffelexHandler 7225ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback) 7226{ 7227 ffeexprStack_ s; 7228 7229 ffebld_pool_push (pool); 7230 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s)); 7231 s->previous = ffeexpr_stack_; 7232 s->pool = pool; 7233 s->context = context; 7234 s->callback = callback; 7235 s->first_token = NULL; 7236 s->exprstack = NULL; 7237 s->is_rhs = FALSE; 7238 ffeexpr_stack_ = s; 7239 return (ffelexHandler) ffeexpr_token_first_lhs_; 7240} 7241 7242/* ffeexpr_rhs -- Begin processing right-hand-side-context expression 7243 7244 return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine); // to lexer. 7245 7246 Prepares cluster for delivery of lexer tokens representing an expression 7247 in a right-hand-side context (B in A=B, for example). ffebld is used 7248 to build expressions in the given pool. The appropriate lexer-token 7249 handling routine within ffeexpr is returned. When the end of the 7250 expression is detected, mycallbackroutine is called with the resulting 7251 single ffebld object specifying the entire expression and the first 7252 lexer token that is not considered part of the expression. This caller- 7253 supplied routine itself returns a lexer-token handling routine. Thus, 7254 if necessary, ffeexpr can return several tokens as end-of-expression 7255 tokens if it needs to scan forward more than one in any instance. */ 7256 7257ffelexHandler 7258ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback) 7259{ 7260 ffeexprStack_ s; 7261 7262 ffebld_pool_push (pool); 7263 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s)); 7264 s->previous = ffeexpr_stack_; 7265 s->pool = pool; 7266 s->context = context; 7267 s->callback = callback; 7268 s->first_token = NULL; 7269 s->exprstack = NULL; 7270 s->is_rhs = TRUE; 7271 ffeexpr_stack_ = s; 7272 return (ffelexHandler) ffeexpr_token_first_rhs_; 7273} 7274 7275/* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr 7276 7277 Pass it to ffeexpr_rhs as the callback routine. 7278 7279 Makes sure the end token is close-paren and swallows it, else issues 7280 an error message and doesn't swallow the token (passing it along instead). 7281 In either case wraps up subexpression construction by enclosing the 7282 ffebld expression in a paren. */ 7283 7284static ffelexHandler 7285ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t) 7286{ 7287 ffeexprExpr_ e; 7288 7289 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) 7290 { 7291 /* Oops, naughty user didn't specify the close paren! */ 7292 7293 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN)) 7294 { 7295 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 7296 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), 7297 ffelex_token_where_column (ffeexpr_stack_->tokens[0])); 7298 ffebad_finish (); 7299 } 7300 7301 e = ffeexpr_expr_new_ (); 7302 e->type = FFEEXPR_exprtypeOPERAND_; 7303 e->u.operand = ffebld_new_any (); 7304 ffebld_set_info (e->u.operand, ffeinfo_new_any ()); 7305 ffeexpr_exprstack_push_operand_ (e); 7306 7307 return 7308 (ffelexHandler) ffeexpr_find_close_paren_ (t, 7309 (ffelexHandler) 7310 ffeexpr_token_binary_); 7311 } 7312 7313 if (expr->op == FFEBLD_opIMPDO) 7314 { 7315 if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN)) 7316 { 7317 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), 7318 ffelex_token_where_column (ffeexpr_stack_->tokens[0])); 7319 ffebad_finish (); 7320 } 7321 } 7322 else 7323 { 7324 expr = ffebld_new_paren (expr); 7325 ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr)))); 7326 } 7327 7328 /* Now push the (parenthesized) expression as an operand onto the 7329 expression stack. */ 7330 7331 e = ffeexpr_expr_new_ (); 7332 e->type = FFEEXPR_exprtypeOPERAND_; 7333 e->u.operand = expr; 7334 e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft); 7335 e->token = ffeexpr_stack_->tokens[0]; 7336 ffeexpr_exprstack_push_operand_ (e); 7337 7338 return (ffelexHandler) ffeexpr_token_binary_; 7339} 7340 7341/* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr 7342 7343 Pass it to ffeexpr_rhs as the callback routine. 7344 7345 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)" 7346 with the next token in t. If the next token is possibly a binary 7347 operator, continue processing the outer expression. If the next 7348 token is COMMA, then the expression is a unit specifier, and 7349 parentheses should not be added to it because it surrounds the 7350 I/O control list that starts with the unit specifier (and continues 7351 on from here -- we haven't seen the CLOSE_PAREN that matches the 7352 OPEN_PAREN, it is up to the callback function to expect to see it 7353 at some point). In this case, we notify the callback function that 7354 the COMMA is inside, not outside, the parens by wrapping the expression 7355 in an opITEM (with a NULL trail) -- the callback function presumably 7356 unwraps it after seeing this kludgey indicator. 7357 7358 If the next token is CLOSE_PAREN, then we go to the _1_ state to 7359 decide what to do with the token after that. 7360 7361 15-Feb-91 JCB 1.1 7362 Use an extra state for the CLOSE_PAREN case to make READ &co really 7363 work right. */ 7364 7365static ffelexHandler 7366ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t) 7367{ 7368 ffeexprCallback callback; 7369 ffeexprStack_ s; 7370 7371 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) 7372 { /* Need to see the next token before we 7373 decide anything. */ 7374 ffeexpr_stack_->expr = expr; 7375 ffeexpr_tokens_[0] = ffelex_token_use (ft); 7376 ffeexpr_tokens_[1] = ffelex_token_use (t); 7377 return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_; 7378 } 7379 7380 expr = ffeexpr_finished_ambig_ (ft, expr); 7381 7382 /* Let the callback function handle the case where t isn't COMMA. */ 7383 7384 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN 7385 that preceded the expression starts a list of expressions, and the expr 7386 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN 7387 node. The callback function should extract the real expr from the head 7388 of this opITEM node after testing it. */ 7389 7390 expr = ffebld_new_item (expr, NULL); 7391 7392 ffebld_pool_pop (); 7393 callback = ffeexpr_stack_->callback; 7394 ffelex_token_kill (ffeexpr_stack_->first_token); 7395 s = ffeexpr_stack_->previous; 7396 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); 7397 ffeexpr_stack_ = s; 7398 return (ffelexHandler) (*callback) (ft, expr, t); 7399} 7400 7401/* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN 7402 7403 See ffeexpr_cb_close_paren_ambig_. 7404 7405 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)" 7406 with the next token in t. If the next token is possibly a binary 7407 operator, continue processing the outer expression. If the next 7408 token is COMMA, the expression is a parenthesized format specifier. 7409 If the next token is not EOS or SEMICOLON, then because it is not a 7410 binary operator (it is NAME, OPEN_PAREN, &c), the expression is 7411 a unit specifier, and parentheses should not be added to it because 7412 they surround the I/O control list that consists of only the unit 7413 specifier. If the next token is EOS or SEMICOLON, the statement 7414 must be disambiguated by looking at the type of the expression -- a 7415 character expression is a parenthesized format specifier, while a 7416 non-character expression is a unit specifier. 7417 7418 Another issue is how to do the callback so the recipient of the 7419 next token knows how to handle it if it is a COMMA. In all other 7420 cases, disambiguation is straightforward: the same approach as the 7421 above is used. 7422 7423 EXTENSION: in COMMA case, if not pedantic, use same disambiguation 7424 as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]" 7425 and apparently other compilers do, as well, and some code out there 7426 uses this "feature". 7427 7428 19-Feb-91 JCB 1.1 7429 Extend to allow COMMA as nondisambiguating by itself. Remember 7430 to not try and check info field for opSTAR, since that expr doesn't 7431 have a valid info field. */ 7432 7433static ffelexHandler 7434ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t) 7435{ 7436 ffeexprCallback callback; 7437 ffeexprStack_ s; 7438 ffelexHandler next; 7439 ffelexToken orig_ft = ffeexpr_tokens_[0]; /* In case callback clobbers 7440 these. */ 7441 ffelexToken orig_t = ffeexpr_tokens_[1]; 7442 ffebld expr = ffeexpr_stack_->expr; 7443 7444 switch (ffelex_token_type (t)) 7445 { 7446 case FFELEX_typeCOMMA: /* Subexpr is parenthesized format specifier. */ 7447 if (ffe_is_pedantic ()) 7448 goto pedantic_comma; /* :::::::::::::::::::: */ 7449 /* Fall through. */ 7450 case FFELEX_typeEOS: /* Ambiguous; use type of expr to 7451 disambiguate. */ 7452 case FFELEX_typeSEMICOLON: 7453 if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY) 7454 || (ffebld_op (expr) == FFEBLD_opSTAR) 7455 || (ffeinfo_basictype (ffebld_info (expr)) 7456 != FFEINFO_basictypeCHARACTER)) 7457 break; /* Not a valid CHARACTER entity, can't be a 7458 format spec. */ 7459 /* Fall through. */ 7460 default: /* Binary op (we assume; error otherwise); 7461 format specifier. */ 7462 7463 pedantic_comma: /* :::::::::::::::::::: */ 7464 7465 switch (ffeexpr_stack_->context) 7466 { 7467 case FFEEXPR_contextFILENUMAMBIG: 7468 ffeexpr_stack_->context = FFEEXPR_contextFILENUM; 7469 break; 7470 7471 case FFEEXPR_contextFILEUNITAMBIG: 7472 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; 7473 break; 7474 7475 default: 7476 assert ("bad context" == NULL); 7477 break; 7478 } 7479 7480 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token); 7481 next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t); 7482 ffelex_token_kill (orig_ft); 7483 ffelex_token_kill (orig_t); 7484 return (ffelexHandler) (*next) (t); 7485 7486 case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */ 7487 case FFELEX_typeNAME: 7488 break; 7489 } 7490 7491 expr = ffeexpr_finished_ambig_ (orig_ft, expr); 7492 7493 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN 7494 that preceded the expression starts a list of expressions, and the expr 7495 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN 7496 node. The callback function should extract the real expr from the head 7497 of this opITEM node after testing it. */ 7498 7499 expr = ffebld_new_item (expr, NULL); 7500 7501 ffebld_pool_pop (); 7502 callback = ffeexpr_stack_->callback; 7503 ffelex_token_kill (ffeexpr_stack_->first_token); 7504 s = ffeexpr_stack_->previous; 7505 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); 7506 ffeexpr_stack_ = s; 7507 next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t); 7508 ffelex_token_kill (orig_ft); 7509 ffelex_token_kill (orig_t); 7510 return (ffelexHandler) (*next) (t); 7511} 7512 7513/* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex) 7514 7515 Pass it to ffeexpr_rhs as the callback routine. 7516 7517 Makes sure the end token is close-paren and swallows it, or a comma 7518 and handles complex/implied-do possibilities, else issues 7519 an error message and doesn't swallow the token (passing it along instead). */ 7520 7521static ffelexHandler 7522ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t) 7523{ 7524 /* First check to see if this is a possible complex entity. It is if the 7525 token is a comma. */ 7526 7527 if (ffelex_token_type (t) == FFELEX_typeCOMMA) 7528 { 7529 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft); 7530 ffeexpr_stack_->expr = expr; 7531 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 7532 FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_); 7533 } 7534 7535 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t); 7536} 7537 7538/* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr 7539 7540 Pass it to ffeexpr_rhs as the callback routine. 7541 7542 If this token is not a comma, we have a complex constant (or an attempt 7543 at one), so handle it accordingly, displaying error messages if the token 7544 is not a close-paren. */ 7545 7546static ffelexHandler 7547ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t) 7548{ 7549 ffeexprExpr_ e; 7550 ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL) 7551 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr)); 7552 ffeinfoBasictype rty = (expr == NULL) 7553 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr)); 7554 ffeinfoKindtype lkt; 7555 ffeinfoKindtype rkt; 7556 ffeinfoKindtype nkt; 7557 bool ok = TRUE; 7558 ffebld orig; 7559 7560 if ((ffeexpr_stack_->expr == NULL) 7561 || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER) 7562 || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL) 7563 && (((ffebld_op (orig) != FFEBLD_opUMINUS) 7564 && (ffebld_op (orig) != FFEBLD_opUPLUS)) 7565 || (ffebld_conter_orig (ffebld_left (orig)) != NULL))) 7566 || ((lty != FFEINFO_basictypeINTEGER) 7567 && (lty != FFEINFO_basictypeREAL))) 7568 { 7569 if ((lty != FFEINFO_basictypeANY) 7570 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART)) 7571 { 7572 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]), 7573 ffelex_token_where_column (ffeexpr_stack_->tokens[1])); 7574 ffebad_string ("Real"); 7575 ffebad_finish (); 7576 } 7577 ok = FALSE; 7578 } 7579 if ((expr == NULL) 7580 || (ffebld_op (expr) != FFEBLD_opCONTER) 7581 || (((orig = ffebld_conter_orig (expr)) != NULL) 7582 && (((ffebld_op (orig) != FFEBLD_opUMINUS) 7583 && (ffebld_op (orig) != FFEBLD_opUPLUS)) 7584 || (ffebld_conter_orig (ffebld_left (orig)) != NULL))) 7585 || ((rty != FFEINFO_basictypeINTEGER) 7586 && (rty != FFEINFO_basictypeREAL))) 7587 { 7588 if ((rty != FFEINFO_basictypeANY) 7589 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART)) 7590 { 7591 ffebad_here (0, ffelex_token_where_line (ft), 7592 ffelex_token_where_column (ft)); 7593 ffebad_string ("Imaginary"); 7594 ffebad_finish (); 7595 } 7596 ok = FALSE; 7597 } 7598 7599 ffelex_token_kill (ffeexpr_stack_->tokens[1]); 7600 7601 /* Push the (parenthesized) expression as an operand onto the expression 7602 stack. */ 7603 7604 e = ffeexpr_expr_new_ (); 7605 e->type = FFEEXPR_exprtypeOPERAND_; 7606 e->token = ffeexpr_stack_->tokens[0]; 7607 7608 if (ok) 7609 { 7610 if (lty == FFEINFO_basictypeINTEGER) 7611 lkt = FFEINFO_kindtypeREALDEFAULT; 7612 else 7613 lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr)); 7614 if (rty == FFEINFO_basictypeINTEGER) 7615 rkt = FFEINFO_kindtypeREALDEFAULT; 7616 else 7617 rkt = ffeinfo_kindtype (ffebld_info (expr)); 7618 7619 nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt); 7620 ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr, 7621 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0], 7622 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE, 7623 FFEEXPR_contextLET); 7624 expr = ffeexpr_convert (expr, 7625 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0], 7626 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE, 7627 FFEEXPR_contextLET); 7628 } 7629 else 7630 nkt = FFEINFO_kindtypeANY; 7631 7632 switch (nkt) 7633 { 7634#if FFETARGET_okCOMPLEX1 7635 case FFEINFO_kindtypeREAL1: 7636 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1 7637 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr))); 7638 ffebld_set_info (e->u.operand, 7639 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0, 7640 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, 7641 FFETARGET_charactersizeNONE)); 7642 break; 7643#endif 7644 7645#if FFETARGET_okCOMPLEX2 7646 case FFEINFO_kindtypeREAL2: 7647 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2 7648 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr))); 7649 ffebld_set_info (e->u.operand, 7650 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0, 7651 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, 7652 FFETARGET_charactersizeNONE)); 7653 break; 7654#endif 7655 7656#if FFETARGET_okCOMPLEX3 7657 case FFEINFO_kindtypeREAL3: 7658 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3 7659 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr))); 7660 ffebld_set_info (e->u.operand, 7661 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0, 7662 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, 7663 FFETARGET_charactersizeNONE)); 7664 break; 7665#endif 7666 7667#if FFETARGET_okCOMPLEX4 7668 case FFEINFO_kindtypeREAL4: 7669 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex4 7670 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr))); 7671 ffebld_set_info (e->u.operand, 7672 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0, 7673 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, 7674 FFETARGET_charactersizeNONE)); 7675 break; 7676#endif 7677 7678 default: 7679 if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE) 7680 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX)) 7681 { 7682 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), 7683 ffelex_token_where_column (ffeexpr_stack_->tokens[0])); 7684 ffebad_finish (); 7685 } 7686 /* Fall through. */ 7687 case FFEINFO_kindtypeANY: 7688 e->u.operand = ffebld_new_any (); 7689 ffebld_set_info (e->u.operand, ffeinfo_new_any ()); 7690 break; 7691 } 7692 ffeexpr_exprstack_push_operand_ (e); 7693 7694 /* Now, if the token is a close parenthese, we're in great shape so return 7695 the next handler. */ 7696 7697 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) 7698 return (ffelexHandler) ffeexpr_token_binary_; 7699 7700 /* Oops, naughty user didn't specify the close paren! */ 7701 7702 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN)) 7703 { 7704 ffebad_here (0, ffelex_token_where_line (t), 7705 ffelex_token_where_column (t)); 7706 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), 7707 ffelex_token_where_column (ffeexpr_stack_->tokens[0])); 7708 ffebad_finish (); 7709 } 7710 7711 return 7712 (ffelexHandler) ffeexpr_find_close_paren_ (t, 7713 (ffelexHandler) 7714 ffeexpr_token_binary_); 7715} 7716 7717/* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or 7718 implied-DO construct) 7719 7720 Pass it to ffeexpr_rhs as the callback routine. 7721 7722 Makes sure the end token is close-paren and swallows it, or a comma 7723 and handles complex/implied-do possibilities, else issues 7724 an error message and doesn't swallow the token (passing it along instead). */ 7725 7726static ffelexHandler 7727ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t) 7728{ 7729 ffeexprContext ctx; 7730 7731 /* First check to see if this is a possible complex or implied-DO entity. 7732 It is if the token is a comma. */ 7733 7734 if (ffelex_token_type (t) == FFELEX_typeCOMMA) 7735 { 7736 switch (ffeexpr_stack_->context) 7737 { 7738 case FFEEXPR_contextIOLIST: 7739 case FFEEXPR_contextIMPDOITEM_: 7740 ctx = FFEEXPR_contextIMPDOITEM_; 7741 break; 7742 7743 case FFEEXPR_contextIOLISTDF: 7744 case FFEEXPR_contextIMPDOITEMDF_: 7745 ctx = FFEEXPR_contextIMPDOITEMDF_; 7746 break; 7747 7748 default: 7749 assert ("bad context" == NULL); 7750 ctx = FFEEXPR_contextIMPDOITEM_; 7751 break; 7752 } 7753 7754 ffeexpr_stack_->tokens[0] = ffelex_token_use (ft); 7755 ffeexpr_stack_->expr = expr; 7756 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 7757 ctx, ffeexpr_cb_comma_ci_); 7758 } 7759 7760 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token); 7761 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t); 7762} 7763 7764/* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr 7765 7766 Pass it to ffeexpr_rhs as the callback routine. 7767 7768 If this token is not a comma, we have a complex constant (or an attempt 7769 at one), so handle it accordingly, displaying error messages if the token 7770 is not a close-paren. If we have a comma here, it is an attempt at an 7771 implied-DO, so start making a list accordingly. Oh, it might be an 7772 equal sign also, meaning an implied-DO with only one item in its list. */ 7773 7774static ffelexHandler 7775ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t) 7776{ 7777 ffebld fexpr; 7778 7779 /* First check to see if this is a possible complex constant. It is if the 7780 token is not a comma or an equals sign, in which case it should be a 7781 close-paren. */ 7782 7783 if ((ffelex_token_type (t) != FFELEX_typeCOMMA) 7784 && (ffelex_token_type (t) != FFELEX_typeEQUALS)) 7785 { 7786 ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0]; 7787 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token); 7788 return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t); 7789 } 7790 7791 /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO 7792 construct. Make a list and handle accordingly. */ 7793 7794 ffelex_token_kill (ffeexpr_stack_->tokens[0]); 7795 fexpr = ffeexpr_stack_->expr; 7796 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); 7797 ffebld_append_item (&ffeexpr_stack_->bottom, fexpr); 7798 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t); 7799} 7800 7801/* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr 7802 7803 Pass it to ffeexpr_rhs as the callback routine. 7804 7805 Handle first item in an implied-DO construct. */ 7806 7807static ffelexHandler 7808ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t) 7809{ 7810 if (ffelex_token_type (t) != FFELEX_typeCOMMA) 7811 { 7812 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) 7813 { 7814 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 7815 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), 7816 ffelex_token_where_column (ffeexpr_stack_->first_token)); 7817 ffebad_finish (); 7818 } 7819 ffebld_end_list (&ffeexpr_stack_->bottom); 7820 ffeexpr_stack_->expr = ffebld_new_any (); 7821 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); 7822 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) 7823 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); 7824 return (ffelexHandler) ffeexpr_cb_comma_i_5_; 7825 } 7826 7827 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t); 7828} 7829 7830/* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr 7831 7832 Pass it to ffeexpr_rhs as the callback routine. 7833 7834 Handle first item in an implied-DO construct. */ 7835 7836static ffelexHandler 7837ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t) 7838{ 7839 ffeexprContext ctxi; 7840 ffeexprContext ctxc; 7841 7842 switch (ffeexpr_stack_->context) 7843 { 7844 case FFEEXPR_contextDATA: 7845 case FFEEXPR_contextDATAIMPDOITEM_: 7846 ctxi = FFEEXPR_contextDATAIMPDOITEM_; 7847 ctxc = FFEEXPR_contextDATAIMPDOCTRL_; 7848 break; 7849 7850 case FFEEXPR_contextIOLIST: 7851 case FFEEXPR_contextIMPDOITEM_: 7852 ctxi = FFEEXPR_contextIMPDOITEM_; 7853 ctxc = FFEEXPR_contextIMPDOCTRL_; 7854 break; 7855 7856 case FFEEXPR_contextIOLISTDF: 7857 case FFEEXPR_contextIMPDOITEMDF_: 7858 ctxi = FFEEXPR_contextIMPDOITEMDF_; 7859 ctxc = FFEEXPR_contextIMPDOCTRL_; 7860 break; 7861 7862 default: 7863 assert ("bad context" == NULL); 7864 ctxi = FFEEXPR_context; 7865 ctxc = FFEEXPR_context; 7866 break; 7867 } 7868 7869 switch (ffelex_token_type (t)) 7870 { 7871 case FFELEX_typeCOMMA: 7872 ffebld_append_item (&ffeexpr_stack_->bottom, expr); 7873 if (ffeexpr_stack_->is_rhs) 7874 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 7875 ctxi, ffeexpr_cb_comma_i_1_); 7876 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool, 7877 ctxi, ffeexpr_cb_comma_i_1_); 7878 7879 case FFELEX_typeEQUALS: 7880 ffebld_end_list (&ffeexpr_stack_->bottom); 7881 7882 /* Complain if implied-DO variable in list of items to be read. */ 7883 7884 if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs) 7885 ffeexpr_check_impdo_ (ffeexpr_stack_->expr, 7886 ffeexpr_stack_->first_token, expr, ft); 7887 7888 /* Set doiter flag for all appropriate SYMTERs. */ 7889 7890 ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr); 7891 7892 ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL); 7893 ffebld_set_info (ffeexpr_stack_->expr, 7894 ffeinfo_new (FFEINFO_basictypeNONE, 7895 FFEINFO_kindtypeNONE, 7896 0, 7897 FFEINFO_kindNONE, 7898 FFEINFO_whereNONE, 7899 FFETARGET_charactersizeNONE)); 7900 ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)), 7901 &ffeexpr_stack_->bottom); 7902 ffebld_append_item (&ffeexpr_stack_->bottom, expr); 7903 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 7904 ctxc, ffeexpr_cb_comma_i_2_); 7905 7906 default: 7907 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) 7908 { 7909 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 7910 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), 7911 ffelex_token_where_column (ffeexpr_stack_->first_token)); 7912 ffebad_finish (); 7913 } 7914 ffebld_end_list (&ffeexpr_stack_->bottom); 7915 ffeexpr_stack_->expr = ffebld_new_any (); 7916 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); 7917 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) 7918 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); 7919 return (ffelexHandler) ffeexpr_cb_comma_i_5_; 7920 } 7921} 7922 7923/* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr 7924 7925 Pass it to ffeexpr_rhs as the callback routine. 7926 7927 Handle start-value in an implied-DO construct. */ 7928 7929static ffelexHandler 7930ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) 7931{ 7932 ffeexprContext ctx; 7933 7934 switch (ffeexpr_stack_->context) 7935 { 7936 case FFEEXPR_contextDATA: 7937 case FFEEXPR_contextDATAIMPDOITEM_: 7938 ctx = FFEEXPR_contextDATAIMPDOCTRL_; 7939 break; 7940 7941 case FFEEXPR_contextIOLIST: 7942 case FFEEXPR_contextIOLISTDF: 7943 case FFEEXPR_contextIMPDOITEM_: 7944 case FFEEXPR_contextIMPDOITEMDF_: 7945 ctx = FFEEXPR_contextIMPDOCTRL_; 7946 break; 7947 7948 default: 7949 assert ("bad context" == NULL); 7950 ctx = FFEEXPR_context; 7951 break; 7952 } 7953 7954 switch (ffelex_token_type (t)) 7955 { 7956 case FFELEX_typeCOMMA: 7957 ffebld_append_item (&ffeexpr_stack_->bottom, expr); 7958 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 7959 ctx, ffeexpr_cb_comma_i_3_); 7960 break; 7961 7962 default: 7963 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) 7964 { 7965 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 7966 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), 7967 ffelex_token_where_column (ffeexpr_stack_->first_token)); 7968 ffebad_finish (); 7969 } 7970 ffebld_end_list (&ffeexpr_stack_->bottom); 7971 ffeexpr_stack_->expr = ffebld_new_any (); 7972 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); 7973 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) 7974 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); 7975 return (ffelexHandler) ffeexpr_cb_comma_i_5_; 7976 } 7977} 7978 7979/* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr 7980 7981 Pass it to ffeexpr_rhs as the callback routine. 7982 7983 Handle end-value in an implied-DO construct. */ 7984 7985static ffelexHandler 7986ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) 7987{ 7988 ffeexprContext ctx; 7989 7990 switch (ffeexpr_stack_->context) 7991 { 7992 case FFEEXPR_contextDATA: 7993 case FFEEXPR_contextDATAIMPDOITEM_: 7994 ctx = FFEEXPR_contextDATAIMPDOCTRL_; 7995 break; 7996 7997 case FFEEXPR_contextIOLIST: 7998 case FFEEXPR_contextIOLISTDF: 7999 case FFEEXPR_contextIMPDOITEM_: 8000 case FFEEXPR_contextIMPDOITEMDF_: 8001 ctx = FFEEXPR_contextIMPDOCTRL_; 8002 break; 8003 8004 default: 8005 assert ("bad context" == NULL); 8006 ctx = FFEEXPR_context; 8007 break; 8008 } 8009 8010 switch (ffelex_token_type (t)) 8011 { 8012 case FFELEX_typeCOMMA: 8013 ffebld_append_item (&ffeexpr_stack_->bottom, expr); 8014 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 8015 ctx, ffeexpr_cb_comma_i_4_); 8016 break; 8017 8018 case FFELEX_typeCLOSE_PAREN: 8019 ffebld_append_item (&ffeexpr_stack_->bottom, expr); 8020 return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t); 8021 break; 8022 8023 default: 8024 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) 8025 { 8026 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 8027 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), 8028 ffelex_token_where_column (ffeexpr_stack_->first_token)); 8029 ffebad_finish (); 8030 } 8031 ffebld_end_list (&ffeexpr_stack_->bottom); 8032 ffeexpr_stack_->expr = ffebld_new_any (); 8033 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); 8034 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) 8035 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); 8036 return (ffelexHandler) ffeexpr_cb_comma_i_5_; 8037 } 8038} 8039 8040/* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr 8041 [COMMA expr] 8042 8043 Pass it to ffeexpr_rhs as the callback routine. 8044 8045 Handle incr-value in an implied-DO construct. */ 8046 8047static ffelexHandler 8048ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) 8049{ 8050 switch (ffelex_token_type (t)) 8051 { 8052 case FFELEX_typeCLOSE_PAREN: 8053 ffebld_append_item (&ffeexpr_stack_->bottom, expr); 8054 ffebld_end_list (&ffeexpr_stack_->bottom); 8055 { 8056 ffebld item; 8057 8058 for (item = ffebld_left (ffeexpr_stack_->expr); 8059 item != NULL; 8060 item = ffebld_trail (item)) 8061 if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY) 8062 goto replace_with_any; /* :::::::::::::::::::: */ 8063 8064 for (item = ffebld_right (ffeexpr_stack_->expr); 8065 item != NULL; 8066 item = ffebld_trail (item)) 8067 if ((ffebld_head (item) != NULL) /* Increment may be NULL. */ 8068 && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)) 8069 goto replace_with_any; /* :::::::::::::::::::: */ 8070 } 8071 break; 8072 8073 default: 8074 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) 8075 { 8076 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 8077 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), 8078 ffelex_token_where_column (ffeexpr_stack_->first_token)); 8079 ffebad_finish (); 8080 } 8081 ffebld_end_list (&ffeexpr_stack_->bottom); 8082 8083 replace_with_any: /* :::::::::::::::::::: */ 8084 8085 ffeexpr_stack_->expr = ffebld_new_any (); 8086 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); 8087 break; 8088 } 8089 8090 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) 8091 return (ffelexHandler) ffeexpr_cb_comma_i_5_; 8092 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); 8093} 8094 8095/* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr 8096 [COMMA expr] CLOSE_PAREN 8097 8098 Pass it to ffeexpr_rhs as the callback routine. 8099 8100 Collects token following implied-DO construct for callback function. */ 8101 8102static ffelexHandler 8103ffeexpr_cb_comma_i_5_ (ffelexToken t) 8104{ 8105 ffeexprCallback callback; 8106 ffeexprStack_ s; 8107 ffelexHandler next; 8108 ffelexToken ft; 8109 ffebld expr; 8110 bool terminate; 8111 8112 switch (ffeexpr_stack_->context) 8113 { 8114 case FFEEXPR_contextDATA: 8115 case FFEEXPR_contextDATAIMPDOITEM_: 8116 terminate = TRUE; 8117 break; 8118 8119 case FFEEXPR_contextIOLIST: 8120 case FFEEXPR_contextIOLISTDF: 8121 case FFEEXPR_contextIMPDOITEM_: 8122 case FFEEXPR_contextIMPDOITEMDF_: 8123 terminate = FALSE; 8124 break; 8125 8126 default: 8127 assert ("bad context" == NULL); 8128 terminate = FALSE; 8129 break; 8130 } 8131 8132 ffebld_pool_pop (); 8133 callback = ffeexpr_stack_->callback; 8134 ft = ffeexpr_stack_->first_token; 8135 expr = ffeexpr_stack_->expr; 8136 s = ffeexpr_stack_->previous; 8137 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, 8138 sizeof (*ffeexpr_stack_)); 8139 ffeexpr_stack_ = s; 8140 next = (ffelexHandler) (*callback) (ft, expr, t); 8141 ffelex_token_kill (ft); 8142 if (terminate) 8143 { 8144 ffesymbol_drive_sfnames (ffeexpr_check_impctrl_); 8145 --ffeexpr_level_; 8146 if (ffeexpr_level_ == 0) 8147 ffe_terminate_4 (); 8148 } 8149 return (ffelexHandler) next; 8150} 8151 8152/* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression 8153 8154 Makes sure the end token is close-paren and swallows it, else issues 8155 an error message and doesn't swallow the token (passing it along instead). 8156 In either case wraps up subexpression construction by enclosing the 8157 ffebld expression in a %LOC. */ 8158 8159static ffelexHandler 8160ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) 8161{ 8162 ffeexprExpr_ e; 8163 8164 /* First push the (%LOC) expression as an operand onto the expression 8165 stack. */ 8166 8167 e = ffeexpr_expr_new_ (); 8168 e->type = FFEEXPR_exprtypeOPERAND_; 8169 e->token = ffeexpr_stack_->tokens[0]; 8170 e->u.operand = ffebld_new_percent_loc (expr); 8171 ffebld_set_info (e->u.operand, 8172 ffeinfo_new (FFEINFO_basictypeINTEGER, 8173 ffecom_pointer_kind (), 8174 0, 8175 FFEINFO_kindENTITY, 8176 FFEINFO_whereFLEETING, 8177 FFETARGET_charactersizeNONE)); 8178#if 0 /* ~~ */ 8179 e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft); 8180#endif 8181 ffeexpr_exprstack_push_operand_ (e); 8182 8183 /* Now, if the token is a close parenthese, we're in great shape so return 8184 the next handler. */ 8185 8186 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) 8187 { 8188 ffelex_token_kill (ffeexpr_stack_->tokens[1]); 8189 return (ffelexHandler) ffeexpr_token_binary_; 8190 } 8191 8192 /* Oops, naughty user didn't specify the close paren! */ 8193 8194 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN)) 8195 { 8196 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 8197 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]), 8198 ffelex_token_where_column (ffeexpr_stack_->tokens[1])); 8199 ffebad_finish (); 8200 } 8201 8202 ffelex_token_kill (ffeexpr_stack_->tokens[1]); 8203 return 8204 (ffelexHandler) ffeexpr_find_close_paren_ (t, 8205 (ffelexHandler) 8206 ffeexpr_token_binary_); 8207} 8208 8209/* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr 8210 8211 Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR). */ 8212 8213static ffelexHandler 8214ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t) 8215{ 8216 ffeexprExpr_ e; 8217 ffebldOp op; 8218 8219 /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all 8220 such things until the lowest-level expression is reached. */ 8221 8222 op = ffebld_op (expr); 8223 if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF) 8224 || (op == FFEBLD_opPERCENT_DESCR)) 8225 { 8226 if (ffebad_start (FFEBAD_NESTED_PERCENT)) 8227 { 8228 ffebad_here (0, ffelex_token_where_line (ft), 8229 ffelex_token_where_column (ft)); 8230 ffebad_finish (); 8231 } 8232 8233 do 8234 { 8235 expr = ffebld_left (expr); 8236 op = ffebld_op (expr); 8237 } 8238 while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF) 8239 || (op == FFEBLD_opPERCENT_DESCR)); 8240 } 8241 8242 /* Push the expression as an operand onto the expression stack. */ 8243 8244 e = ffeexpr_expr_new_ (); 8245 e->type = FFEEXPR_exprtypeOPERAND_; 8246 e->token = ffeexpr_stack_->tokens[0]; 8247 switch (ffeexpr_stack_->percent) 8248 { 8249 case FFEEXPR_percentVAL_: 8250 e->u.operand = ffebld_new_percent_val (expr); 8251 break; 8252 8253 case FFEEXPR_percentREF_: 8254 e->u.operand = ffebld_new_percent_ref (expr); 8255 break; 8256 8257 case FFEEXPR_percentDESCR_: 8258 e->u.operand = ffebld_new_percent_descr (expr); 8259 break; 8260 8261 default: 8262 assert ("%lossage" == NULL); 8263 e->u.operand = expr; 8264 break; 8265 } 8266 ffebld_set_info (e->u.operand, ffebld_info (expr)); 8267#if 0 /* ~~ */ 8268 e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft); 8269#endif 8270 ffeexpr_exprstack_push_operand_ (e); 8271 8272 /* Now, if the token is a close parenthese, we're in great shape so return 8273 the next handler. */ 8274 8275 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) 8276 return (ffelexHandler) ffeexpr_cb_end_notloc_1_; 8277 8278 /* Oops, naughty user didn't specify the close paren! */ 8279 8280 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN)) 8281 { 8282 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 8283 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]), 8284 ffelex_token_where_column (ffeexpr_stack_->tokens[1])); 8285 ffebad_finish (); 8286 } 8287 8288 ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC); 8289 8290 switch (ffeexpr_stack_->context) 8291 { 8292 case FFEEXPR_contextACTUALARG_: 8293 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; 8294 break; 8295 8296 case FFEEXPR_contextINDEXORACTUALARG_: 8297 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; 8298 break; 8299 8300 case FFEEXPR_contextSFUNCDEFACTUALARG_: 8301 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; 8302 break; 8303 8304 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 8305 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; 8306 break; 8307 8308 default: 8309 assert ("bad context?!?!" == NULL); 8310 break; 8311 } 8312 8313 ffelex_token_kill (ffeexpr_stack_->tokens[1]); 8314 return 8315 (ffelexHandler) ffeexpr_find_close_paren_ (t, 8316 (ffelexHandler) 8317 ffeexpr_cb_end_notloc_1_); 8318} 8319 8320/* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr 8321 CLOSE_PAREN 8322 8323 Should be COMMA or CLOSE_PAREN, else change back to %LOC. */ 8324 8325static ffelexHandler 8326ffeexpr_cb_end_notloc_1_ (ffelexToken t) 8327{ 8328 switch (ffelex_token_type (t)) 8329 { 8330 case FFELEX_typeCOMMA: 8331 case FFELEX_typeCLOSE_PAREN: 8332 switch (ffeexpr_stack_->context) 8333 { 8334 case FFEEXPR_contextACTUALARG_: 8335 case FFEEXPR_contextSFUNCDEFACTUALARG_: 8336 break; 8337 8338 case FFEEXPR_contextINDEXORACTUALARG_: 8339 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_; 8340 break; 8341 8342 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 8343 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_; 8344 break; 8345 8346 default: 8347 assert ("bad context?!?!" == NULL); 8348 break; 8349 } 8350 break; 8351 8352 default: 8353 if (ffebad_start (FFEBAD_INVALID_PERCENT)) 8354 { 8355 ffebad_here (0, 8356 ffelex_token_where_line (ffeexpr_stack_->first_token), 8357 ffelex_token_where_column (ffeexpr_stack_->first_token)); 8358 ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1])); 8359 ffebad_finish (); 8360 } 8361 8362 ffebld_set_op (ffeexpr_stack_->exprstack->u.operand, 8363 FFEBLD_opPERCENT_LOC); 8364 8365 switch (ffeexpr_stack_->context) 8366 { 8367 case FFEEXPR_contextACTUALARG_: 8368 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; 8369 break; 8370 8371 case FFEEXPR_contextINDEXORACTUALARG_: 8372 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; 8373 break; 8374 8375 case FFEEXPR_contextSFUNCDEFACTUALARG_: 8376 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; 8377 break; 8378 8379 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 8380 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; 8381 break; 8382 8383 default: 8384 assert ("bad context?!?!" == NULL); 8385 break; 8386 } 8387 } 8388 8389 ffelex_token_kill (ffeexpr_stack_->tokens[1]); 8390 return 8391 (ffelexHandler) ffeexpr_token_binary_ (t); 8392} 8393 8394/* Process DATA implied-DO iterator variables as this implied-DO level 8395 terminates. At this point, ffeexpr_level_ == 1 when we see the 8396 last right-paren in "DATA (A(I),I=1,10)/.../". */ 8397 8398static ffesymbol 8399ffeexpr_check_impctrl_ (ffesymbol s) 8400{ 8401 assert (s != NULL); 8402 assert (ffesymbol_sfdummyparent (s) != NULL); 8403 8404 switch (ffesymbol_state (s)) 8405 { 8406 case FFESYMBOL_stateNONE: /* Used as iterator already. Now let symbol 8407 be used as iterator at any level at or 8408 innermore than the outermost of the 8409 current level and the symbol's current 8410 level. */ 8411 if (ffeexpr_level_ < ffesymbol_maxentrynum (s)) 8412 { 8413 ffesymbol_signal_change (s); 8414 ffesymbol_set_maxentrynum (s, ffeexpr_level_); 8415 ffesymbol_signal_unreported (s); 8416 } 8417 break; 8418 8419 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO. 8420 Error if at outermost level, else it can 8421 still become an iterator. */ 8422 if ((ffeexpr_level_ == 1) 8423 && ffebad_start (FFEBAD_BAD_IMPDCL)) 8424 { 8425 ffebad_string (ffesymbol_text (s)); 8426 ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s)); 8427 ffebad_finish (); 8428 } 8429 break; 8430 8431 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */ 8432 assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s)); 8433 ffesymbol_signal_change (s); 8434 ffesymbol_set_state (s, FFESYMBOL_stateNONE); 8435 ffesymbol_signal_unreported (s); 8436 break; 8437 8438 case FFESYMBOL_stateUNDERSTOOD: 8439 break; /* ANY. */ 8440 8441 default: 8442 assert ("Sasha Foo!!" == NULL); 8443 break; 8444 } 8445 8446 return s; 8447} 8448 8449/* Issue diagnostic if implied-DO variable appears in list of lhs 8450 expressions (as in "READ *, (I,I=1,10)"). */ 8451 8452static void 8453ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t, 8454 ffebld dovar, ffelexToken dovar_t) 8455{ 8456 ffebld item; 8457 ffesymbol dovar_sym; 8458 int itemnum; 8459 8460 if (ffebld_op (dovar) != FFEBLD_opSYMTER) 8461 return; /* Presumably opANY. */ 8462 8463 dovar_sym = ffebld_symter (dovar); 8464 8465 for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum) 8466 { 8467 if (((item = ffebld_head (list)) != NULL) 8468 && (ffebld_op (item) == FFEBLD_opSYMTER) 8469 && (ffebld_symter (item) == dovar_sym)) 8470 { 8471 char itemno[20]; 8472 8473 sprintf (&itemno[0], "%d", itemnum); 8474 if (ffebad_start (FFEBAD_DOITER_IMPDO)) 8475 { 8476 ffebad_here (0, ffelex_token_where_line (list_t), 8477 ffelex_token_where_column (list_t)); 8478 ffebad_here (1, ffelex_token_where_line (dovar_t), 8479 ffelex_token_where_column (dovar_t)); 8480 ffebad_string (ffesymbol_text (dovar_sym)); 8481 ffebad_string (itemno); 8482 ffebad_finish (); 8483 } 8484 } 8485 } 8486} 8487 8488/* Decorate any SYMTERs referencing the DO variable with the "doiter" 8489 flag. */ 8490 8491static void 8492ffeexpr_update_impdo_ (ffebld list, ffebld dovar) 8493{ 8494 ffesymbol dovar_sym; 8495 8496 if (ffebld_op (dovar) != FFEBLD_opSYMTER) 8497 return; /* Presumably opANY. */ 8498 8499 dovar_sym = ffebld_symter (dovar); 8500 8501 ffeexpr_update_impdo_sym_ (list, dovar_sym); /* Recurse! */ 8502} 8503 8504/* Recursive function to update any expr so SYMTERs have "doiter" flag 8505 if they refer to the given variable. */ 8506 8507static void 8508ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar) 8509{ 8510 tail_recurse: /* :::::::::::::::::::: */ 8511 8512 if (expr == NULL) 8513 return; 8514 8515 switch (ffebld_op (expr)) 8516 { 8517 case FFEBLD_opSYMTER: 8518 if (ffebld_symter (expr) == dovar) 8519 ffebld_symter_set_is_doiter (expr, TRUE); 8520 break; 8521 8522 case FFEBLD_opITEM: 8523 ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar); 8524 expr = ffebld_trail (expr); 8525 goto tail_recurse; /* :::::::::::::::::::: */ 8526 8527 default: 8528 break; 8529 } 8530 8531 switch (ffebld_arity (expr)) 8532 { 8533 case 2: 8534 ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar); 8535 expr = ffebld_right (expr); 8536 goto tail_recurse; /* :::::::::::::::::::: */ 8537 8538 case 1: 8539 expr = ffebld_left (expr); 8540 goto tail_recurse; /* :::::::::::::::::::: */ 8541 8542 default: 8543 break; 8544 } 8545 8546 return; 8547} 8548 8549/* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs 8550 8551 if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF) 8552 // After zero or more PAREN_ contexts, an IF context exists */ 8553 8554static ffeexprContext 8555ffeexpr_context_outer_ (ffeexprStack_ s) 8556{ 8557 assert (s != NULL); 8558 8559 for (;;) 8560 { 8561 switch (s->context) 8562 { 8563 case FFEEXPR_contextPAREN_: 8564 case FFEEXPR_contextPARENFILENUM_: 8565 case FFEEXPR_contextPARENFILEUNIT_: 8566 break; 8567 8568 default: 8569 return s->context; 8570 } 8571 s = s->previous; 8572 assert (s != NULL); 8573 } 8574} 8575 8576/* ffeexpr_percent_ -- Look up name in list of %FOO possibilities 8577 8578 ffeexprPercent_ p; 8579 ffelexToken t; 8580 p = ffeexpr_percent_(t); 8581 8582 Returns the identifier for the name, or the NONE identifier. */ 8583 8584static ffeexprPercent_ 8585ffeexpr_percent_ (ffelexToken t) 8586{ 8587 const char *p; 8588 8589 switch (ffelex_token_length (t)) 8590 { 8591 case 3: 8592 switch (*(p = ffelex_token_text (t))) 8593 { 8594 case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3): 8595 if ((ffesrc_char_match_noninit (*++p, 'O', 'o')) 8596 && (ffesrc_char_match_noninit (*++p, 'C', 'c'))) 8597 return FFEEXPR_percentLOC_; 8598 return FFEEXPR_percentNONE_; 8599 8600 case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3): 8601 if ((ffesrc_char_match_noninit (*++p, 'E', 'e')) 8602 && (ffesrc_char_match_noninit (*++p, 'F', 'f'))) 8603 return FFEEXPR_percentREF_; 8604 return FFEEXPR_percentNONE_; 8605 8606 case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3): 8607 if ((ffesrc_char_match_noninit (*++p, 'A', 'a')) 8608 && (ffesrc_char_match_noninit (*++p, 'L', 'l'))) 8609 return FFEEXPR_percentVAL_; 8610 return FFEEXPR_percentNONE_; 8611 8612 default: 8613 no_match_3: /* :::::::::::::::::::: */ 8614 return FFEEXPR_percentNONE_; 8615 } 8616 8617 case 5: 8618 if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR", 8619 "descr", "Descr") == 0) 8620 return FFEEXPR_percentDESCR_; 8621 return FFEEXPR_percentNONE_; 8622 8623 default: 8624 return FFEEXPR_percentNONE_; 8625 } 8626} 8627 8628/* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX 8629 8630 See prototype. 8631 8632 If combining the two basictype/kindtype pairs produces a COMPLEX with an 8633 unsupported kind type, complain and use the default kind type for 8634 COMPLEX. */ 8635 8636void 8637ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt, 8638 ffeinfoBasictype lbt, ffeinfoKindtype lkt, 8639 ffeinfoBasictype rbt, ffeinfoKindtype rkt, 8640 ffelexToken t) 8641{ 8642 ffeinfoBasictype nbt; 8643 ffeinfoKindtype nkt; 8644 8645 nbt = ffeinfo_basictype_combine (lbt, rbt); 8646 if ((nbt == FFEINFO_basictypeCOMPLEX) 8647 && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL)) 8648 && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL))) 8649 { 8650 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt); 8651 if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE)) 8652 nkt = FFEINFO_kindtypeNONE; /* Force error. */ 8653 switch (nkt) 8654 { 8655#if FFETARGET_okCOMPLEX1 8656 case FFEINFO_kindtypeREAL1: 8657#endif 8658#if FFETARGET_okCOMPLEX2 8659 case FFEINFO_kindtypeREAL2: 8660#endif 8661#if FFETARGET_okCOMPLEX3 8662 case FFEINFO_kindtypeREAL3: 8663#endif 8664#if FFETARGET_okCOMPLEX4 8665 case FFEINFO_kindtypeREAL4: 8666#endif 8667 break; /* Fine and dandy. */ 8668 8669 default: 8670 if (t != NULL) 8671 { 8672 ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE) 8673 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX); 8674 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 8675 ffebad_finish (); 8676 } 8677 nbt = FFEINFO_basictypeNONE; 8678 nkt = FFEINFO_kindtypeNONE; 8679 break; 8680 8681 case FFEINFO_kindtypeANY: 8682 nkt = FFEINFO_kindtypeREALDEFAULT; 8683 break; 8684 } 8685 } 8686 else 8687 { /* The normal stuff. */ 8688 if (nbt == lbt) 8689 { 8690 if (nbt == rbt) 8691 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt); 8692 else 8693 nkt = lkt; 8694 } 8695 else if (nbt == rbt) 8696 nkt = rkt; 8697 else 8698 { /* Let the caller do the complaining. */ 8699 nbt = FFEINFO_basictypeNONE; 8700 nkt = FFEINFO_kindtypeNONE; 8701 } 8702 } 8703 8704 /* Always a good idea to avoid aliasing problems. */ 8705 8706 *xnbt = nbt; 8707 *xnkt = nkt; 8708} 8709 8710/* ffeexpr_token_first_lhs_ -- First state for lhs expression 8711 8712 Return a pointer to this function to the lexer (ffelex), which will 8713 invoke it for the next token. 8714 8715 Record line and column of first token in expression, then invoke the 8716 initial-state lhs handler. */ 8717 8718static ffelexHandler 8719ffeexpr_token_first_lhs_ (ffelexToken t) 8720{ 8721 ffeexpr_stack_->first_token = ffelex_token_use (t); 8722 8723 /* When changing the list of valid initial lhs tokens, check whether to 8724 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the 8725 READ (expr) <token> case -- it assumes it knows which tokens <token> can 8726 be to indicate an lhs (or implied DO), which right now is the set 8727 {NAME,OPEN_PAREN}. 8728 8729 This comment also appears in ffeexpr_token_lhs_. */ 8730 8731 switch (ffelex_token_type (t)) 8732 { 8733 case FFELEX_typeOPEN_PAREN: 8734 switch (ffeexpr_stack_->context) 8735 { 8736 case FFEEXPR_contextDATA: 8737 ffe_init_4 (); 8738 ffeexpr_level_ = 1; /* Level of DATA implied-DO construct. */ 8739 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); 8740 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool, 8741 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_); 8742 8743 case FFEEXPR_contextDATAIMPDOITEM_: 8744 ++ffeexpr_level_; /* Level of DATA implied-DO construct. */ 8745 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); 8746 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool, 8747 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_); 8748 8749 case FFEEXPR_contextIOLIST: 8750 case FFEEXPR_contextIMPDOITEM_: 8751 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); 8752 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool, 8753 FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_); 8754 8755 case FFEEXPR_contextIOLISTDF: 8756 case FFEEXPR_contextIMPDOITEMDF_: 8757 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); 8758 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool, 8759 FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_); 8760 8761 case FFEEXPR_contextFILEEXTFUNC: 8762 assert (ffeexpr_stack_->exprstack == NULL); 8763 return (ffelexHandler) ffeexpr_token_first_lhs_1_; 8764 8765 default: 8766 break; 8767 } 8768 break; 8769 8770 case FFELEX_typeNAME: 8771 switch (ffeexpr_stack_->context) 8772 { 8773 case FFEEXPR_contextFILENAMELIST: 8774 assert (ffeexpr_stack_->exprstack == NULL); 8775 return (ffelexHandler) ffeexpr_token_namelist_; 8776 8777 case FFEEXPR_contextFILEEXTFUNC: 8778 assert (ffeexpr_stack_->exprstack == NULL); 8779 return (ffelexHandler) ffeexpr_token_first_lhs_1_; 8780 8781 default: 8782 break; 8783 } 8784 break; 8785 8786 default: 8787 switch (ffeexpr_stack_->context) 8788 { 8789 case FFEEXPR_contextFILEEXTFUNC: 8790 assert (ffeexpr_stack_->exprstack == NULL); 8791 return (ffelexHandler) ffeexpr_token_first_lhs_1_; 8792 8793 default: 8794 break; 8795 } 8796 break; 8797 } 8798 8799 return (ffelexHandler) ffeexpr_token_lhs_ (t); 8800} 8801 8802/* ffeexpr_token_first_lhs_1_ -- NAME 8803 8804 return ffeexpr_token_first_lhs_1_; // to lexer 8805 8806 Handle NAME as an external function (USEROPEN= VXT extension to OPEN 8807 statement). */ 8808 8809static ffelexHandler 8810ffeexpr_token_first_lhs_1_ (ffelexToken t) 8811{ 8812 ffeexprCallback callback; 8813 ffeexprStack_ s; 8814 ffelexHandler next; 8815 ffelexToken ft; 8816 ffesymbol sy = NULL; 8817 ffebld expr; 8818 8819 ffebld_pool_pop (); 8820 callback = ffeexpr_stack_->callback; 8821 ft = ffeexpr_stack_->first_token; 8822 s = ffeexpr_stack_->previous; 8823 8824 if ((ffelex_token_type (ft) != FFELEX_typeNAME) 8825 || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE)) 8826 & FFESYMBOL_attrANY)) 8827 { 8828 if ((ffelex_token_type (ft) != FFELEX_typeNAME) 8829 || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY)) 8830 { 8831 ffebad_start (FFEBAD_EXPR_WRONG); 8832 ffebad_here (0, ffelex_token_where_line (ft), 8833 ffelex_token_where_column (ft)); 8834 ffebad_finish (); 8835 } 8836 expr = ffebld_new_any (); 8837 ffebld_set_info (expr, ffeinfo_new_any ()); 8838 } 8839 else 8840 { 8841 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE, 8842 FFEINTRIN_impNONE); 8843 ffebld_set_info (expr, ffesymbol_info (sy)); 8844 } 8845 8846 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, 8847 sizeof (*ffeexpr_stack_)); 8848 ffeexpr_stack_ = s; 8849 8850 next = (ffelexHandler) (*callback) (ft, expr, t); 8851 ffelex_token_kill (ft); 8852 return (ffelexHandler) next; 8853} 8854 8855/* ffeexpr_token_first_rhs_ -- First state for rhs expression 8856 8857 Record line and column of first token in expression, then invoke the 8858 initial-state rhs handler. 8859 8860 19-Feb-91 JCB 1.1 8861 Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only 8862 (i.e. only as in READ(*), not READ((*))). */ 8863 8864static ffelexHandler 8865ffeexpr_token_first_rhs_ (ffelexToken t) 8866{ 8867 ffesymbol s; 8868 8869 ffeexpr_stack_->first_token = ffelex_token_use (t); 8870 8871 switch (ffelex_token_type (t)) 8872 { 8873 case FFELEX_typeASTERISK: 8874 switch (ffeexpr_stack_->context) 8875 { 8876 case FFEEXPR_contextFILEFORMATNML: 8877 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; 8878 /* Fall through. */ 8879 case FFEEXPR_contextFILEUNIT: 8880 case FFEEXPR_contextDIMLIST: 8881 case FFEEXPR_contextFILEFORMAT: 8882 case FFEEXPR_contextCHARACTERSIZE: 8883 if (ffeexpr_stack_->previous != NULL) 8884 break; /* Valid only on first level. */ 8885 assert (ffeexpr_stack_->exprstack == NULL); 8886 return (ffelexHandler) ffeexpr_token_first_rhs_1_; 8887 8888 case FFEEXPR_contextPARENFILEUNIT_: 8889 if (ffeexpr_stack_->previous->previous != NULL) 8890 break; /* Valid only on second level. */ 8891 assert (ffeexpr_stack_->exprstack == NULL); 8892 return (ffelexHandler) ffeexpr_token_first_rhs_1_; 8893 8894 case FFEEXPR_contextACTUALARG_: 8895 if (ffeexpr_stack_->previous->context 8896 != FFEEXPR_contextSUBROUTINEREF) 8897 { 8898 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; 8899 break; 8900 } 8901 assert (ffeexpr_stack_->exprstack == NULL); 8902 return (ffelexHandler) ffeexpr_token_first_rhs_3_; 8903 8904 case FFEEXPR_contextINDEXORACTUALARG_: 8905 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; 8906 break; 8907 8908 case FFEEXPR_contextSFUNCDEFACTUALARG_: 8909 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; 8910 break; 8911 8912 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 8913 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; 8914 break; 8915 8916 default: 8917 break; 8918 } 8919 break; 8920 8921 case FFELEX_typeOPEN_PAREN: 8922 switch (ffeexpr_stack_->context) 8923 { 8924 case FFEEXPR_contextFILENUMAMBIG: 8925 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 8926 FFEEXPR_contextPARENFILENUM_, 8927 ffeexpr_cb_close_paren_ambig_); 8928 8929 case FFEEXPR_contextFILEUNITAMBIG: 8930 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 8931 FFEEXPR_contextPARENFILEUNIT_, 8932 ffeexpr_cb_close_paren_ambig_); 8933 8934 case FFEEXPR_contextIOLIST: 8935 case FFEEXPR_contextIMPDOITEM_: 8936 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 8937 FFEEXPR_contextIMPDOITEM_, 8938 ffeexpr_cb_close_paren_ci_); 8939 8940 case FFEEXPR_contextIOLISTDF: 8941 case FFEEXPR_contextIMPDOITEMDF_: 8942 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 8943 FFEEXPR_contextIMPDOITEMDF_, 8944 ffeexpr_cb_close_paren_ci_); 8945 8946 case FFEEXPR_contextFILEFORMATNML: 8947 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; 8948 break; 8949 8950 case FFEEXPR_contextACTUALARG_: 8951 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; 8952 break; 8953 8954 case FFEEXPR_contextINDEXORACTUALARG_: 8955 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; 8956 break; 8957 8958 case FFEEXPR_contextSFUNCDEFACTUALARG_: 8959 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; 8960 break; 8961 8962 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 8963 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; 8964 break; 8965 8966 default: 8967 break; 8968 } 8969 break; 8970 8971 case FFELEX_typeNUMBER: 8972 switch (ffeexpr_stack_->context) 8973 { 8974 case FFEEXPR_contextFILEFORMATNML: 8975 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; 8976 /* Fall through. */ 8977 case FFEEXPR_contextFILEFORMAT: 8978 if (ffeexpr_stack_->previous != NULL) 8979 break; /* Valid only on first level. */ 8980 assert (ffeexpr_stack_->exprstack == NULL); 8981 return (ffelexHandler) ffeexpr_token_first_rhs_2_; 8982 8983 case FFEEXPR_contextACTUALARG_: 8984 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; 8985 break; 8986 8987 case FFEEXPR_contextINDEXORACTUALARG_: 8988 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; 8989 break; 8990 8991 case FFEEXPR_contextSFUNCDEFACTUALARG_: 8992 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; 8993 break; 8994 8995 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 8996 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; 8997 break; 8998 8999 default: 9000 break; 9001 } 9002 break; 9003 9004 case FFELEX_typeNAME: 9005 switch (ffeexpr_stack_->context) 9006 { 9007 case FFEEXPR_contextFILEFORMATNML: 9008 assert (ffeexpr_stack_->exprstack == NULL); 9009 s = ffesymbol_lookup_local (t); 9010 if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST)) 9011 return (ffelexHandler) ffeexpr_token_namelist_; 9012 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; 9013 break; 9014 9015 default: 9016 break; 9017 } 9018 break; 9019 9020 case FFELEX_typePERCENT: 9021 switch (ffeexpr_stack_->context) 9022 { 9023 case FFEEXPR_contextACTUALARG_: 9024 case FFEEXPR_contextINDEXORACTUALARG_: 9025 case FFEEXPR_contextSFUNCDEFACTUALARG_: 9026 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 9027 return (ffelexHandler) ffeexpr_token_first_rhs_5_; 9028 9029 case FFEEXPR_contextFILEFORMATNML: 9030 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; 9031 break; 9032 9033 default: 9034 break; 9035 } 9036 9037 default: 9038 switch (ffeexpr_stack_->context) 9039 { 9040 case FFEEXPR_contextACTUALARG_: 9041 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; 9042 break; 9043 9044 case FFEEXPR_contextINDEXORACTUALARG_: 9045 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; 9046 break; 9047 9048 case FFEEXPR_contextSFUNCDEFACTUALARG_: 9049 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; 9050 break; 9051 9052 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 9053 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; 9054 break; 9055 9056 case FFEEXPR_contextFILEFORMATNML: 9057 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; 9058 break; 9059 9060 default: 9061 break; 9062 } 9063 break; 9064 } 9065 9066 return (ffelexHandler) ffeexpr_token_rhs_ (t); 9067} 9068 9069/* ffeexpr_token_first_rhs_1_ -- ASTERISK 9070 9071 return ffeexpr_token_first_rhs_1_; // to lexer 9072 9073 Return STAR as expression. */ 9074 9075static ffelexHandler 9076ffeexpr_token_first_rhs_1_ (ffelexToken t) 9077{ 9078 ffebld expr; 9079 ffeexprCallback callback; 9080 ffeexprStack_ s; 9081 ffelexHandler next; 9082 ffelexToken ft; 9083 9084 expr = ffebld_new_star (); 9085 ffebld_pool_pop (); 9086 callback = ffeexpr_stack_->callback; 9087 ft = ffeexpr_stack_->first_token; 9088 s = ffeexpr_stack_->previous; 9089 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); 9090 ffeexpr_stack_ = s; 9091 next = (ffelexHandler) (*callback) (ft, expr, t); 9092 ffelex_token_kill (ft); 9093 return (ffelexHandler) next; 9094} 9095 9096/* ffeexpr_token_first_rhs_2_ -- NUMBER 9097 9098 return ffeexpr_token_first_rhs_2_; // to lexer 9099 9100 Return NULL as expression; NUMBER as first (and only) token, unless the 9101 current token is not a terminating token, in which case run normal 9102 expression handling. */ 9103 9104static ffelexHandler 9105ffeexpr_token_first_rhs_2_ (ffelexToken t) 9106{ 9107 ffeexprCallback callback; 9108 ffeexprStack_ s; 9109 ffelexHandler next; 9110 ffelexToken ft; 9111 9112 switch (ffelex_token_type (t)) 9113 { 9114 case FFELEX_typeCLOSE_PAREN: 9115 case FFELEX_typeCOMMA: 9116 case FFELEX_typeEOS: 9117 case FFELEX_typeSEMICOLON: 9118 break; 9119 9120 default: 9121 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token); 9122 return (ffelexHandler) (*next) (t); 9123 } 9124 9125 ffebld_pool_pop (); 9126 callback = ffeexpr_stack_->callback; 9127 ft = ffeexpr_stack_->first_token; 9128 s = ffeexpr_stack_->previous; 9129 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, 9130 sizeof (*ffeexpr_stack_)); 9131 ffeexpr_stack_ = s; 9132 next = (ffelexHandler) (*callback) (ft, NULL, t); 9133 ffelex_token_kill (ft); 9134 return (ffelexHandler) next; 9135} 9136 9137/* ffeexpr_token_first_rhs_3_ -- ASTERISK 9138 9139 return ffeexpr_token_first_rhs_3_; // to lexer 9140 9141 Expect NUMBER, make LABTOK (with copy of token if not inhibited after 9142 confirming, else NULL). */ 9143 9144static ffelexHandler 9145ffeexpr_token_first_rhs_3_ (ffelexToken t) 9146{ 9147 ffelexHandler next; 9148 9149 if (ffelex_token_type (t) != FFELEX_typeNUMBER) 9150 { /* An error, but let normal processing handle 9151 it. */ 9152 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token); 9153 return (ffelexHandler) (*next) (t); 9154 } 9155 9156 /* Special case: when we see "*10" as an argument to a subroutine 9157 reference, we confirm the current statement and, if not inhibited at 9158 this point, put a copy of the token into a LABTOK node. We do this 9159 instead of just resolving the label directly via ffelab and putting it 9160 into a LABTER simply to improve error reporting and consistency in 9161 ffestc. We put NULL in the LABTOK if we're still inhibited, so ffestb 9162 doesn't have to worry about killing off any tokens when retracting. */ 9163 9164 ffest_confirmed (); 9165 if (ffest_is_inhibited ()) 9166 ffeexpr_stack_->expr = ffebld_new_labtok (NULL); 9167 else 9168 ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t)); 9169 ffebld_set_info (ffeexpr_stack_->expr, 9170 ffeinfo_new (FFEINFO_basictypeNONE, 9171 FFEINFO_kindtypeNONE, 9172 0, 9173 FFEINFO_kindNONE, 9174 FFEINFO_whereNONE, 9175 FFETARGET_charactersizeNONE)); 9176 9177 return (ffelexHandler) ffeexpr_token_first_rhs_4_; 9178} 9179 9180/* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER 9181 9182 return ffeexpr_token_first_rhs_4_; // to lexer 9183 9184 Collect/flush appropriate stuff, send token to callback function. */ 9185 9186static ffelexHandler 9187ffeexpr_token_first_rhs_4_ (ffelexToken t) 9188{ 9189 ffebld expr; 9190 ffeexprCallback callback; 9191 ffeexprStack_ s; 9192 ffelexHandler next; 9193 ffelexToken ft; 9194 9195 expr = ffeexpr_stack_->expr; 9196 ffebld_pool_pop (); 9197 callback = ffeexpr_stack_->callback; 9198 ft = ffeexpr_stack_->first_token; 9199 s = ffeexpr_stack_->previous; 9200 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); 9201 ffeexpr_stack_ = s; 9202 next = (ffelexHandler) (*callback) (ft, expr, t); 9203 ffelex_token_kill (ft); 9204 return (ffelexHandler) next; 9205} 9206 9207/* ffeexpr_token_first_rhs_5_ -- PERCENT 9208 9209 Should be NAME, or pass through original mechanism. If NAME is LOC, 9210 pass through original mechanism, otherwise must be VAL, REF, or DESCR, 9211 in which case handle the argument (in parentheses), etc. */ 9212 9213static ffelexHandler 9214ffeexpr_token_first_rhs_5_ (ffelexToken t) 9215{ 9216 ffelexHandler next; 9217 9218 if (ffelex_token_type (t) == FFELEX_typeNAME) 9219 { 9220 ffeexprPercent_ p = ffeexpr_percent_ (t); 9221 9222 switch (p) 9223 { 9224 case FFEEXPR_percentNONE_: 9225 case FFEEXPR_percentLOC_: 9226 break; /* Treat %LOC as any other expression. */ 9227 9228 case FFEEXPR_percentVAL_: 9229 case FFEEXPR_percentREF_: 9230 case FFEEXPR_percentDESCR_: 9231 ffeexpr_stack_->percent = p; 9232 ffeexpr_stack_->tokens[0] = ffelex_token_use (t); 9233 return (ffelexHandler) ffeexpr_token_first_rhs_6_; 9234 9235 default: 9236 assert ("bad percent?!?" == NULL); 9237 break; 9238 } 9239 } 9240 9241 switch (ffeexpr_stack_->context) 9242 { 9243 case FFEEXPR_contextACTUALARG_: 9244 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; 9245 break; 9246 9247 case FFEEXPR_contextINDEXORACTUALARG_: 9248 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; 9249 break; 9250 9251 case FFEEXPR_contextSFUNCDEFACTUALARG_: 9252 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; 9253 break; 9254 9255 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 9256 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; 9257 break; 9258 9259 default: 9260 assert ("bad context?!?!" == NULL); 9261 break; 9262 } 9263 9264 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token); 9265 return (ffelexHandler) (*next) (t); 9266} 9267 9268/* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR) 9269 9270 Should be OPEN_PAREN, or pass through original mechanism. */ 9271 9272static ffelexHandler 9273ffeexpr_token_first_rhs_6_ (ffelexToken t) 9274{ 9275 ffelexHandler next; 9276 ffelexToken ft; 9277 9278 if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN) 9279 { 9280 ffeexpr_stack_->tokens[1] = ffelex_token_use (t); 9281 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 9282 ffeexpr_stack_->context, 9283 ffeexpr_cb_end_notloc_); 9284 } 9285 9286 switch (ffeexpr_stack_->context) 9287 { 9288 case FFEEXPR_contextACTUALARG_: 9289 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; 9290 break; 9291 9292 case FFEEXPR_contextINDEXORACTUALARG_: 9293 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; 9294 break; 9295 9296 case FFEEXPR_contextSFUNCDEFACTUALARG_: 9297 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; 9298 break; 9299 9300 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 9301 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; 9302 break; 9303 9304 default: 9305 assert ("bad context?!?!" == NULL); 9306 break; 9307 } 9308 9309 ft = ffeexpr_stack_->tokens[0]; 9310 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token); 9311 next = (ffelexHandler) (*next) (ft); 9312 ffelex_token_kill (ft); 9313 return (ffelexHandler) (*next) (t); 9314} 9315 9316/* ffeexpr_token_namelist_ -- NAME 9317 9318 return ffeexpr_token_namelist_; // to lexer 9319 9320 Make sure NAME was a valid namelist object, wrap it in a SYMTER and 9321 return. */ 9322 9323static ffelexHandler 9324ffeexpr_token_namelist_ (ffelexToken t) 9325{ 9326 ffeexprCallback callback; 9327 ffeexprStack_ s; 9328 ffelexHandler next; 9329 ffelexToken ft; 9330 ffesymbol sy; 9331 ffebld expr; 9332 9333 ffebld_pool_pop (); 9334 callback = ffeexpr_stack_->callback; 9335 ft = ffeexpr_stack_->first_token; 9336 s = ffeexpr_stack_->previous; 9337 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); 9338 ffeexpr_stack_ = s; 9339 9340 sy = ffesymbol_lookup_local (ft); 9341 if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST)) 9342 { 9343 ffebad_start (FFEBAD_EXPR_WRONG); 9344 ffebad_here (0, ffelex_token_where_line (ft), 9345 ffelex_token_where_column (ft)); 9346 ffebad_finish (); 9347 expr = ffebld_new_any (); 9348 ffebld_set_info (expr, ffeinfo_new_any ()); 9349 } 9350 else 9351 { 9352 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE, 9353 FFEINTRIN_impNONE); 9354 ffebld_set_info (expr, ffesymbol_info (sy)); 9355 } 9356 next = (ffelexHandler) (*callback) (ft, expr, t); 9357 ffelex_token_kill (ft); 9358 return (ffelexHandler) next; 9359} 9360 9361/* ffeexpr_expr_kill_ -- Kill an existing internal expression object 9362 9363 ffeexprExpr_ e; 9364 ffeexpr_expr_kill_(e); 9365 9366 Kills the ffewhere info, if necessary, then kills the object. */ 9367 9368static void 9369ffeexpr_expr_kill_ (ffeexprExpr_ e) 9370{ 9371 if (e->token != NULL) 9372 ffelex_token_kill (e->token); 9373 malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e)); 9374} 9375 9376/* ffeexpr_expr_new_ -- Make a new internal expression object 9377 9378 ffeexprExpr_ e; 9379 e = ffeexpr_expr_new_(); 9380 9381 Allocates and initializes a new expression object, returns it. */ 9382 9383static ffeexprExpr_ 9384ffeexpr_expr_new_ () 9385{ 9386 ffeexprExpr_ e; 9387 9388 e = (ffeexprExpr_) malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr", 9389 sizeof (*e)); 9390 e->previous = NULL; 9391 e->type = FFEEXPR_exprtypeUNKNOWN_; 9392 e->token = NULL; 9393 return e; 9394} 9395 9396/* Verify that call to global is valid, and register whatever 9397 new information about a global might be discoverable by looking 9398 at the call. */ 9399 9400static void 9401ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t) 9402{ 9403 int n_args; 9404 ffebld list; 9405 ffebld item; 9406 ffesymbol s; 9407 9408 assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF) 9409 || (ffebld_op (*expr) == FFEBLD_opFUNCREF)); 9410 9411 if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER) 9412 return; 9413 9414 if (ffesymbol_retractable ()) 9415 return; 9416 9417 s = ffebld_symter (ffebld_left (*expr)); 9418 if (ffesymbol_global (s) == NULL) 9419 return; 9420 9421 for (n_args = 0, list = ffebld_right (*expr); 9422 list != NULL; 9423 list = ffebld_trail (list), ++n_args) 9424 ; 9425 9426 if (ffeglobal_proc_ref_nargs (s, n_args, t)) 9427 { 9428 ffeglobalArgSummary as; 9429 ffeinfoBasictype bt; 9430 ffeinfoKindtype kt; 9431 bool array; 9432 bool fail = FALSE; 9433 9434 for (n_args = 0, list = ffebld_right (*expr); 9435 list != NULL; 9436 list = ffebld_trail (list), ++n_args) 9437 { 9438 item = ffebld_head (list); 9439 if (item != NULL) 9440 { 9441 bt = ffeinfo_basictype (ffebld_info (item)); 9442 kt = ffeinfo_kindtype (ffebld_info (item)); 9443 array = (ffeinfo_rank (ffebld_info (item)) > 0); 9444 switch (ffebld_op (item)) 9445 { 9446 case FFEBLD_opLABTOK: 9447 case FFEBLD_opLABTER: 9448 as = FFEGLOBAL_argsummaryALTRTN; 9449 break; 9450 9451#if 0 9452 /* No, %LOC(foo) is just like any INTEGER(KIND=7) 9453 expression, so don't treat it specially. */ 9454 case FFEBLD_opPERCENT_LOC: 9455 as = FFEGLOBAL_argsummaryPTR; 9456 break; 9457#endif 9458 9459 case FFEBLD_opPERCENT_VAL: 9460 as = FFEGLOBAL_argsummaryVAL; 9461 break; 9462 9463 case FFEBLD_opPERCENT_REF: 9464 as = FFEGLOBAL_argsummaryREF; 9465 break; 9466 9467 case FFEBLD_opPERCENT_DESCR: 9468 as = FFEGLOBAL_argsummaryDESCR; 9469 break; 9470 9471 case FFEBLD_opFUNCREF: 9472#if 0 9473 /* No, LOC(foo) is just like any INTEGER(KIND=7) 9474 expression, so don't treat it specially. */ 9475 if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER) 9476 && (ffesymbol_specific (ffebld_symter (ffebld_left (item))) 9477 == FFEINTRIN_specLOC)) 9478 { 9479 as = FFEGLOBAL_argsummaryPTR; 9480 break; 9481 } 9482#endif 9483 /* Fall through. */ 9484 default: 9485 if (ffebld_op (item) == FFEBLD_opSYMTER) 9486 { 9487 as = FFEGLOBAL_argsummaryNONE; 9488 9489 switch (ffeinfo_kind (ffebld_info (item))) 9490 { 9491 case FFEINFO_kindFUNCTION: 9492 as = FFEGLOBAL_argsummaryFUNC; 9493 break; 9494 9495 case FFEINFO_kindSUBROUTINE: 9496 as = FFEGLOBAL_argsummarySUBR; 9497 break; 9498 9499 case FFEINFO_kindNONE: 9500 as = FFEGLOBAL_argsummaryPROC; 9501 break; 9502 9503 default: 9504 break; 9505 } 9506 9507 if (as != FFEGLOBAL_argsummaryNONE) 9508 break; 9509 } 9510 9511 if (bt == FFEINFO_basictypeCHARACTER) 9512 as = FFEGLOBAL_argsummaryDESCR; 9513 else 9514 as = FFEGLOBAL_argsummaryREF; 9515 break; 9516 } 9517 } 9518 else 9519 { 9520 array = FALSE; 9521 as = FFEGLOBAL_argsummaryNONE; 9522 bt = FFEINFO_basictypeNONE; 9523 kt = FFEINFO_kindtypeNONE; 9524 } 9525 9526 if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t)) 9527 fail = TRUE; 9528 } 9529 if (! fail) 9530 return; 9531 } 9532 9533 *expr = ffebld_new_any (); 9534 ffebld_set_info (*expr, ffeinfo_new_any ()); 9535} 9536 9537/* Check whether rest of string is all decimal digits. */ 9538 9539static bool 9540ffeexpr_isdigits_ (const char *p) 9541{ 9542 for (; *p != '\0'; ++p) 9543 if (! ISDIGIT (*p)) 9544 return FALSE; 9545 return TRUE; 9546} 9547 9548/* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack 9549 9550 ffeexprExpr_ e; 9551 ffeexpr_exprstack_push_(e); 9552 9553 Pushes the expression onto the stack without any analysis of the existing 9554 contents of the stack. */ 9555 9556static void 9557ffeexpr_exprstack_push_ (ffeexprExpr_ e) 9558{ 9559 e->previous = ffeexpr_stack_->exprstack; 9560 ffeexpr_stack_->exprstack = e; 9561} 9562 9563/* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce? 9564 9565 ffeexprExpr_ e; 9566 ffeexpr_exprstack_push_operand_(e); 9567 9568 Pushes the expression already containing an operand (a constant, variable, 9569 or more complicated expression that has already been fully resolved) after 9570 analyzing the stack and checking for possible reduction (which will never 9571 happen here since the highest precedence operator is ** and it has right- 9572 to-left associativity). */ 9573 9574static void 9575ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e) 9576{ 9577 ffeexpr_exprstack_push_ (e); 9578#ifdef WEIRD_NONFORTRAN_RULES 9579 if ((ffeexpr_stack_->exprstack != NULL) 9580 && (ffeexpr_stack_->exprstack->expr->type == FFEEXPR_exprtypeBINARY_) 9581 && (ffeexpr_stack_->exprstack->expr->u.operator.prec 9582 == FFEEXPR_operatorprecedenceHIGHEST_) 9583 && (ffeexpr_stack_->exprstack->expr->u.operator.as 9584 == FFEEXPR_operatorassociativityL2R_)) 9585 ffeexpr_reduce_ (); 9586#endif 9587} 9588 9589/* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack 9590 9591 ffeexprExpr_ e; 9592 ffeexpr_exprstack_push_unary_(e); 9593 9594 Pushes the expression already containing a unary operator. Reduction can 9595 never happen since unary operators are themselves always R-L; that is, the 9596 top of the expression stack is not an operand, in that it is either empty, 9597 has a binary operator at the top, or a unary operator at the top. In any 9598 of these cases, reduction is impossible. */ 9599 9600static void 9601ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e) 9602{ 9603 if ((ffe_is_pedantic () 9604 || ffe_is_warn_surprising ()) 9605 && (ffeexpr_stack_->exprstack != NULL) 9606 && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_) 9607 && (ffeexpr_stack_->exprstack->u.operator.prec 9608 <= FFEEXPR_operatorprecedenceLOWARITH_) 9609 && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_)) 9610 { 9611 ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses", 9612 ffe_is_pedantic () 9613 ? FFEBAD_severityPEDANTIC 9614 : FFEBAD_severityWARNING); 9615 ffebad_here (0, 9616 ffelex_token_where_line (ffeexpr_stack_->exprstack->token), 9617 ffelex_token_where_column (ffeexpr_stack_->exprstack->token)); 9618 ffebad_here (1, 9619 ffelex_token_where_line (e->token), 9620 ffelex_token_where_column (e->token)); 9621 ffebad_finish (); 9622 } 9623 9624 ffeexpr_exprstack_push_ (e); 9625} 9626 9627/* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce? 9628 9629 ffeexprExpr_ e; 9630 ffeexpr_exprstack_push_binary_(e); 9631 9632 Pushes the expression already containing a binary operator after checking 9633 whether reduction is possible. If the stack is not empty, the top of the 9634 stack must be an operand or syntactic analysis has failed somehow. If 9635 the operand is preceded by a unary operator of higher (or equal and L-R 9636 associativity) precedence than the new binary operator, then reduce that 9637 preceding operator and its operand(s) before pushing the new binary 9638 operator. */ 9639 9640static void 9641ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e) 9642{ 9643 ffeexprExpr_ ce; 9644 9645 if (ffe_is_warn_surprising () 9646 /* These next two are always true (see assertions below). */ 9647 && (ffeexpr_stack_->exprstack != NULL) 9648 && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_) 9649 /* If the previous operator is a unary minus, and the binary op 9650 is of higher precedence, might not do what user expects, 9651 e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would 9652 yield "4". */ 9653 && (ffeexpr_stack_->exprstack->previous != NULL) 9654 && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_) 9655 && (ffeexpr_stack_->exprstack->previous->u.operator.op 9656 == FFEEXPR_operatorSUBTRACT_) 9657 && (e->u.operator.prec 9658 < ffeexpr_stack_->exprstack->previous->u.operator.prec)) 9659 { 9660 ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING); 9661 ffebad_here (0, 9662 ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token), 9663 ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token)); 9664 ffebad_here (1, 9665 ffelex_token_where_line (e->token), 9666 ffelex_token_where_column (e->token)); 9667 ffebad_finish (); 9668 } 9669 9670again: 9671 assert (ffeexpr_stack_->exprstack != NULL); 9672 assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_); 9673 if ((ce = ffeexpr_stack_->exprstack->previous) != NULL) 9674 { 9675 assert (ce->type != FFEEXPR_exprtypeOPERAND_); 9676 if ((ce->u.operator.prec < e->u.operator.prec) 9677 || ((ce->u.operator.prec == e->u.operator.prec) 9678 && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_))) 9679 { 9680 ffeexpr_reduce_ (); 9681 goto again; /* :::::::::::::::::::: */ 9682 } 9683 } 9684 9685 ffeexpr_exprstack_push_ (e); 9686} 9687 9688/* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack 9689 9690 ffeexpr_reduce_(); 9691 9692 Converts operand binop operand or unop operand at top of stack to a 9693 single operand having the appropriate ffebld expression, and makes 9694 sure that the expression is proper (like not trying to add two character 9695 variables, not trying to concatenate two numbers). Also does the 9696 requisite type-assignment. */ 9697 9698static void 9699ffeexpr_reduce_ () 9700{ 9701 ffeexprExpr_ operand; /* This is B in -B or A+B. */ 9702 ffeexprExpr_ left_operand; /* When operator is binary, this is A in A+B. */ 9703 ffeexprExpr_ operator; /* This is + in A+B. */ 9704 ffebld reduced; /* This is +(A,B) in A+B or u-(B) in -B. */ 9705 ffebldConstant constnode; /* For checking magical numbers (where mag == 9706 -mag). */ 9707 ffebld expr; 9708 ffebld left_expr; 9709 bool submag = FALSE; 9710 9711 operand = ffeexpr_stack_->exprstack; 9712 assert (operand != NULL); 9713 assert (operand->type == FFEEXPR_exprtypeOPERAND_); 9714 operator = operand->previous; 9715 assert (operator != NULL); 9716 assert (operator->type != FFEEXPR_exprtypeOPERAND_); 9717 if (operator->type == FFEEXPR_exprtypeUNARY_) 9718 { 9719 expr = operand->u.operand; 9720 switch (operator->u.operator.op) 9721 { 9722 case FFEEXPR_operatorADD_: 9723 reduced = ffebld_new_uplus (expr); 9724 if (ffe_is_ugly_logint ()) 9725 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand); 9726 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand); 9727 reduced = ffeexpr_collapse_uplus (reduced, operator->token); 9728 break; 9729 9730 case FFEEXPR_operatorSUBTRACT_: 9731 submag = TRUE; /* Ok to negate a magic number. */ 9732 reduced = ffebld_new_uminus (expr); 9733 if (ffe_is_ugly_logint ()) 9734 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand); 9735 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand); 9736 reduced = ffeexpr_collapse_uminus (reduced, operator->token); 9737 break; 9738 9739 case FFEEXPR_operatorNOT_: 9740 reduced = ffebld_new_not (expr); 9741 if (ffe_is_ugly_logint ()) 9742 reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand); 9743 reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand); 9744 reduced = ffeexpr_collapse_not (reduced, operator->token); 9745 break; 9746 9747 default: 9748 assert ("unexpected unary op" != NULL); 9749 reduced = NULL; 9750 break; 9751 } 9752 if (!submag 9753 && (ffebld_op (expr) == FFEBLD_opCONTER) 9754 && (ffebld_conter_orig (expr) == NULL) 9755 && ffebld_constant_is_magical (constnode = ffebld_conter (expr))) 9756 { 9757 ffetarget_integer_bad_magical (operand->token); 9758 } 9759 ffeexpr_stack_->exprstack = operator->previous; /* Pops unary-op operand 9760 off stack. */ 9761 ffeexpr_expr_kill_ (operand); 9762 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but 9763 save */ 9764 operator->u.operand = reduced; /* the line/column ffewhere info. */ 9765 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on 9766 stack. */ 9767 } 9768 else 9769 { 9770 assert (operator->type == FFEEXPR_exprtypeBINARY_); 9771 left_operand = operator->previous; 9772 assert (left_operand != NULL); 9773 assert (left_operand->type == FFEEXPR_exprtypeOPERAND_); 9774 expr = operand->u.operand; 9775 left_expr = left_operand->u.operand; 9776 switch (operator->u.operator.op) 9777 { 9778 case FFEEXPR_operatorADD_: 9779 reduced = ffebld_new_add (left_expr, expr); 9780 if (ffe_is_ugly_logint ()) 9781 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, 9782 operand); 9783 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator, 9784 operand); 9785 reduced = ffeexpr_collapse_add (reduced, operator->token); 9786 break; 9787 9788 case FFEEXPR_operatorSUBTRACT_: 9789 submag = TRUE; /* Just to pick the right error if magic 9790 number. */ 9791 reduced = ffebld_new_subtract (left_expr, expr); 9792 if (ffe_is_ugly_logint ()) 9793 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, 9794 operand); 9795 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator, 9796 operand); 9797 reduced = ffeexpr_collapse_subtract (reduced, operator->token); 9798 break; 9799 9800 case FFEEXPR_operatorMULTIPLY_: 9801 reduced = ffebld_new_multiply (left_expr, expr); 9802 if (ffe_is_ugly_logint ()) 9803 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, 9804 operand); 9805 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator, 9806 operand); 9807 reduced = ffeexpr_collapse_multiply (reduced, operator->token); 9808 break; 9809 9810 case FFEEXPR_operatorDIVIDE_: 9811 reduced = ffebld_new_divide (left_expr, expr); 9812 if (ffe_is_ugly_logint ()) 9813 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, 9814 operand); 9815 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator, 9816 operand); 9817 reduced = ffeexpr_collapse_divide (reduced, operator->token); 9818 break; 9819 9820 case FFEEXPR_operatorPOWER_: 9821 reduced = ffebld_new_power (left_expr, expr); 9822 if (ffe_is_ugly_logint ()) 9823 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, 9824 operand); 9825 reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator, 9826 operand); 9827 reduced = ffeexpr_collapse_power (reduced, operator->token); 9828 break; 9829 9830 case FFEEXPR_operatorCONCATENATE_: 9831 reduced = ffebld_new_concatenate (left_expr, expr); 9832 reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator, 9833 operand); 9834 reduced = ffeexpr_collapse_concatenate (reduced, operator->token); 9835 break; 9836 9837 case FFEEXPR_operatorLT_: 9838 reduced = ffebld_new_lt (left_expr, expr); 9839 if (ffe_is_ugly_logint ()) 9840 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, 9841 operand); 9842 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator, 9843 operand); 9844 reduced = ffeexpr_collapse_lt (reduced, operator->token); 9845 break; 9846 9847 case FFEEXPR_operatorLE_: 9848 reduced = ffebld_new_le (left_expr, expr); 9849 if (ffe_is_ugly_logint ()) 9850 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, 9851 operand); 9852 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator, 9853 operand); 9854 reduced = ffeexpr_collapse_le (reduced, operator->token); 9855 break; 9856 9857 case FFEEXPR_operatorEQ_: 9858 reduced = ffebld_new_eq (left_expr, expr); 9859 if (ffe_is_ugly_logint ()) 9860 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, 9861 operand); 9862 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator, 9863 operand); 9864 reduced = ffeexpr_collapse_eq (reduced, operator->token); 9865 break; 9866 9867 case FFEEXPR_operatorNE_: 9868 reduced = ffebld_new_ne (left_expr, expr); 9869 if (ffe_is_ugly_logint ()) 9870 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, 9871 operand); 9872 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator, 9873 operand); 9874 reduced = ffeexpr_collapse_ne (reduced, operator->token); 9875 break; 9876 9877 case FFEEXPR_operatorGT_: 9878 reduced = ffebld_new_gt (left_expr, expr); 9879 if (ffe_is_ugly_logint ()) 9880 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, 9881 operand); 9882 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator, 9883 operand); 9884 reduced = ffeexpr_collapse_gt (reduced, operator->token); 9885 break; 9886 9887 case FFEEXPR_operatorGE_: 9888 reduced = ffebld_new_ge (left_expr, expr); 9889 if (ffe_is_ugly_logint ()) 9890 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, 9891 operand); 9892 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator, 9893 operand); 9894 reduced = ffeexpr_collapse_ge (reduced, operator->token); 9895 break; 9896 9897 case FFEEXPR_operatorAND_: 9898 reduced = ffebld_new_and (left_expr, expr); 9899 if (ffe_is_ugly_logint ()) 9900 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator, 9901 operand); 9902 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, 9903 operand); 9904 reduced = ffeexpr_collapse_and (reduced, operator->token); 9905 break; 9906 9907 case FFEEXPR_operatorOR_: 9908 reduced = ffebld_new_or (left_expr, expr); 9909 if (ffe_is_ugly_logint ()) 9910 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator, 9911 operand); 9912 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, 9913 operand); 9914 reduced = ffeexpr_collapse_or (reduced, operator->token); 9915 break; 9916 9917 case FFEEXPR_operatorXOR_: 9918 reduced = ffebld_new_xor (left_expr, expr); 9919 if (ffe_is_ugly_logint ()) 9920 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator, 9921 operand); 9922 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, 9923 operand); 9924 reduced = ffeexpr_collapse_xor (reduced, operator->token); 9925 break; 9926 9927 case FFEEXPR_operatorEQV_: 9928 reduced = ffebld_new_eqv (left_expr, expr); 9929 if (ffe_is_ugly_logint ()) 9930 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator, 9931 operand); 9932 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, 9933 operand); 9934 reduced = ffeexpr_collapse_eqv (reduced, operator->token); 9935 break; 9936 9937 case FFEEXPR_operatorNEQV_: 9938 reduced = ffebld_new_neqv (left_expr, expr); 9939 if (ffe_is_ugly_logint ()) 9940 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator, 9941 operand); 9942 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, 9943 operand); 9944 reduced = ffeexpr_collapse_neqv (reduced, operator->token); 9945 break; 9946 9947 default: 9948 assert ("bad bin op" == NULL); 9949 reduced = expr; 9950 break; 9951 } 9952 if ((ffebld_op (left_expr) == FFEBLD_opCONTER) 9953 && (ffebld_conter_orig (expr) == NULL) 9954 && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr))) 9955 { 9956 if ((left_operand->previous != NULL) 9957 && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_) 9958 && (left_operand->previous->u.operator.op 9959 == FFEEXPR_operatorSUBTRACT_)) 9960 { 9961 if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_) 9962 ffetarget_integer_bad_magical_precedence (left_operand->token, 9963 left_operand->previous->token, 9964 operator->token); 9965 else 9966 ffetarget_integer_bad_magical_precedence_binary 9967 (left_operand->token, 9968 left_operand->previous->token, 9969 operator->token); 9970 } 9971 else 9972 ffetarget_integer_bad_magical (left_operand->token); 9973 } 9974 if ((ffebld_op (expr) == FFEBLD_opCONTER) 9975 && (ffebld_conter_orig (expr) == NULL) 9976 && ffebld_constant_is_magical (constnode = ffebld_conter (expr))) 9977 { 9978 if (submag) 9979 ffetarget_integer_bad_magical_binary (operand->token, 9980 operator->token); 9981 else 9982 ffetarget_integer_bad_magical (operand->token); 9983 } 9984 ffeexpr_stack_->exprstack = left_operand->previous; /* Pops binary-op 9985 operands off stack. */ 9986 ffeexpr_expr_kill_ (left_operand); 9987 ffeexpr_expr_kill_ (operand); 9988 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but 9989 save */ 9990 operator->u.operand = reduced; /* the line/column ffewhere info. */ 9991 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on 9992 stack. */ 9993 } 9994} 9995 9996/* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator 9997 9998 reduced = ffeexpr_reduced_bool1_(reduced,op,r); 9999 10000 Makes sure the argument for reduced has basictype of 10001 LOGICAL or (ugly) INTEGER. If 10002 argument has where of CONSTANT, assign where CONSTANT to 10003 reduced, else assign where FLEETING. 10004 10005 If these requirements cannot be met, generate error message. */ 10006 10007static ffebld 10008ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r) 10009{ 10010 ffeinfo rinfo, ninfo; 10011 ffeinfoBasictype rbt; 10012 ffeinfoKindtype rkt; 10013 ffeinfoRank rrk; 10014 ffeinfoKind rkd; 10015 ffeinfoWhere rwh, nwh; 10016 10017 rinfo = ffebld_info (ffebld_left (reduced)); 10018 rbt = ffeinfo_basictype (rinfo); 10019 rkt = ffeinfo_kindtype (rinfo); 10020 rrk = ffeinfo_rank (rinfo); 10021 rkd = ffeinfo_kind (rinfo); 10022 rwh = ffeinfo_where (rinfo); 10023 10024 if (((rbt == FFEINFO_basictypeLOGICAL) 10025 || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER))) 10026 && (rrk == 0)) 10027 { 10028 switch (rwh) 10029 { 10030 case FFEINFO_whereCONSTANT: 10031 nwh = FFEINFO_whereCONSTANT; 10032 break; 10033 10034 case FFEINFO_whereIMMEDIATE: 10035 nwh = FFEINFO_whereIMMEDIATE; 10036 break; 10037 10038 default: 10039 nwh = FFEINFO_whereFLEETING; 10040 break; 10041 } 10042 10043 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh, 10044 FFETARGET_charactersizeNONE); 10045 ffebld_set_info (reduced, ninfo); 10046 return reduced; 10047 } 10048 10049 if ((rbt != FFEINFO_basictypeLOGICAL) 10050 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER))) 10051 { 10052 if ((rbt != FFEINFO_basictypeANY) 10053 && ffebad_start (FFEBAD_NOT_ARG_TYPE)) 10054 { 10055 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10056 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10057 ffebad_finish (); 10058 } 10059 } 10060 else 10061 { 10062 if ((rkd != FFEINFO_kindANY) 10063 && ffebad_start (FFEBAD_NOT_ARG_KIND)) 10064 { 10065 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10066 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10067 ffebad_string ("an array"); 10068 ffebad_finish (); 10069 } 10070 } 10071 10072 reduced = ffebld_new_any (); 10073 ffebld_set_info (reduced, ffeinfo_new_any ()); 10074 return reduced; 10075} 10076 10077/* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators 10078 10079 reduced = ffeexpr_reduced_bool2_(reduced,l,op,r); 10080 10081 Makes sure the left and right arguments for reduced have basictype of 10082 LOGICAL or (ugly) INTEGER. Determine common basictype and 10083 size for reduction (flag expression for combined hollerith/typeless 10084 situations for later determination of effective basictype). If both left 10085 and right arguments have where of CONSTANT, assign where CONSTANT to 10086 reduced, else assign where FLEETING. Create CONVERT ops for args where 10087 needed. Convert typeless 10088 constants to the desired type/size explicitly. 10089 10090 If these requirements cannot be met, generate error message. */ 10091 10092static ffebld 10093ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, 10094 ffeexprExpr_ r) 10095{ 10096 ffeinfo linfo, rinfo, ninfo; 10097 ffeinfoBasictype lbt, rbt, nbt; 10098 ffeinfoKindtype lkt, rkt, nkt; 10099 ffeinfoRank lrk, rrk; 10100 ffeinfoKind lkd, rkd; 10101 ffeinfoWhere lwh, rwh, nwh; 10102 10103 linfo = ffebld_info (ffebld_left (reduced)); 10104 lbt = ffeinfo_basictype (linfo); 10105 lkt = ffeinfo_kindtype (linfo); 10106 lrk = ffeinfo_rank (linfo); 10107 lkd = ffeinfo_kind (linfo); 10108 lwh = ffeinfo_where (linfo); 10109 10110 rinfo = ffebld_info (ffebld_right (reduced)); 10111 rbt = ffeinfo_basictype (rinfo); 10112 rkt = ffeinfo_kindtype (rinfo); 10113 rrk = ffeinfo_rank (rinfo); 10114 rkd = ffeinfo_kind (rinfo); 10115 rwh = ffeinfo_where (rinfo); 10116 10117 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); 10118 10119 if (((nbt == FFEINFO_basictypeLOGICAL) 10120 || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER))) 10121 && (lrk == 0) && (rrk == 0)) 10122 { 10123 switch (lwh) 10124 { 10125 case FFEINFO_whereCONSTANT: 10126 switch (rwh) 10127 { 10128 case FFEINFO_whereCONSTANT: 10129 nwh = FFEINFO_whereCONSTANT; 10130 break; 10131 10132 case FFEINFO_whereIMMEDIATE: 10133 nwh = FFEINFO_whereIMMEDIATE; 10134 break; 10135 10136 default: 10137 nwh = FFEINFO_whereFLEETING; 10138 break; 10139 } 10140 break; 10141 10142 case FFEINFO_whereIMMEDIATE: 10143 switch (rwh) 10144 { 10145 case FFEINFO_whereCONSTANT: 10146 case FFEINFO_whereIMMEDIATE: 10147 nwh = FFEINFO_whereIMMEDIATE; 10148 break; 10149 10150 default: 10151 nwh = FFEINFO_whereFLEETING; 10152 break; 10153 } 10154 break; 10155 10156 default: 10157 nwh = FFEINFO_whereFLEETING; 10158 break; 10159 } 10160 10161 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh, 10162 FFETARGET_charactersizeNONE); 10163 ffebld_set_info (reduced, ninfo); 10164 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), 10165 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, 10166 FFEEXPR_contextLET)); 10167 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), 10168 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, 10169 FFEEXPR_contextLET)); 10170 return reduced; 10171 } 10172 10173 if ((lbt != FFEINFO_basictypeLOGICAL) 10174 && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER))) 10175 { 10176 if ((rbt != FFEINFO_basictypeLOGICAL) 10177 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER))) 10178 { 10179 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) 10180 && ffebad_start (FFEBAD_BOOL_ARGS_TYPE)) 10181 { 10182 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10183 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 10184 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10185 ffebad_finish (); 10186 } 10187 } 10188 else 10189 { 10190 if ((lbt != FFEINFO_basictypeANY) 10191 && ffebad_start (FFEBAD_BOOL_ARG_TYPE)) 10192 { 10193 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10194 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 10195 ffebad_finish (); 10196 } 10197 } 10198 } 10199 else if ((rbt != FFEINFO_basictypeLOGICAL) 10200 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER))) 10201 { 10202 if ((rbt != FFEINFO_basictypeANY) 10203 && ffebad_start (FFEBAD_BOOL_ARG_TYPE)) 10204 { 10205 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10206 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10207 ffebad_finish (); 10208 } 10209 } 10210 else if (lrk != 0) 10211 { 10212 if ((lkd != FFEINFO_kindANY) 10213 && ffebad_start (FFEBAD_BOOL_ARG_KIND)) 10214 { 10215 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10216 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 10217 ffebad_string ("an array"); 10218 ffebad_finish (); 10219 } 10220 } 10221 else 10222 { 10223 if ((rkd != FFEINFO_kindANY) 10224 && ffebad_start (FFEBAD_BOOL_ARG_KIND)) 10225 { 10226 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10227 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10228 ffebad_string ("an array"); 10229 ffebad_finish (); 10230 } 10231 } 10232 10233 reduced = ffebld_new_any (); 10234 ffebld_set_info (reduced, ffeinfo_new_any ()); 10235 return reduced; 10236} 10237 10238/* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator 10239 10240 reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r); 10241 10242 Makes sure the left and right arguments for reduced have basictype of 10243 CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION. Assign 10244 basictype of CHARACTER and kind of SCALAR to reduced. Calculate effective 10245 size of concatenation and assign that size to reduced. If both left and 10246 right arguments have where of CONSTANT, assign where CONSTANT to reduced, 10247 else assign where FLEETING. 10248 10249 If these requirements cannot be met, generate error message using the 10250 info in l, op, and r arguments and assign basictype, size, kind, and where 10251 of ANY. */ 10252 10253static ffebld 10254ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, 10255 ffeexprExpr_ r) 10256{ 10257 ffeinfo linfo, rinfo, ninfo; 10258 ffeinfoBasictype lbt, rbt, nbt; 10259 ffeinfoKindtype lkt, rkt, nkt; 10260 ffeinfoRank lrk, rrk; 10261 ffeinfoKind lkd, rkd, nkd; 10262 ffeinfoWhere lwh, rwh, nwh; 10263 ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk; 10264 10265 linfo = ffebld_info (ffebld_left (reduced)); 10266 lbt = ffeinfo_basictype (linfo); 10267 lkt = ffeinfo_kindtype (linfo); 10268 lrk = ffeinfo_rank (linfo); 10269 lkd = ffeinfo_kind (linfo); 10270 lwh = ffeinfo_where (linfo); 10271 lszk = ffeinfo_size (linfo); /* Known size. */ 10272 lszm = ffebld_size_max (ffebld_left (reduced)); 10273 10274 rinfo = ffebld_info (ffebld_right (reduced)); 10275 rbt = ffeinfo_basictype (rinfo); 10276 rkt = ffeinfo_kindtype (rinfo); 10277 rrk = ffeinfo_rank (rinfo); 10278 rkd = ffeinfo_kind (rinfo); 10279 rwh = ffeinfo_where (rinfo); 10280 rszk = ffeinfo_size (rinfo); /* Known size. */ 10281 rszm = ffebld_size_max (ffebld_right (reduced)); 10282 10283 if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER) 10284 && (lkt == rkt) && (lrk == 0) && (rrk == 0) 10285 && (((lszm != FFETARGET_charactersizeNONE) 10286 && (rszm != FFETARGET_charactersizeNONE)) 10287 || (ffeexpr_context_outer_ (ffeexpr_stack_) 10288 == FFEEXPR_contextLET) 10289 || (ffeexpr_context_outer_ (ffeexpr_stack_) 10290 == FFEEXPR_contextSFUNCDEF))) 10291 { 10292 nbt = FFEINFO_basictypeCHARACTER; 10293 nkd = FFEINFO_kindENTITY; 10294 if ((lszk == FFETARGET_charactersizeNONE) 10295 || (rszk == FFETARGET_charactersizeNONE)) 10296 nszk = FFETARGET_charactersizeNONE; /* Ok only in rhs of LET 10297 stmt. */ 10298 else 10299 nszk = lszk + rszk; 10300 10301 switch (lwh) 10302 { 10303 case FFEINFO_whereCONSTANT: 10304 switch (rwh) 10305 { 10306 case FFEINFO_whereCONSTANT: 10307 nwh = FFEINFO_whereCONSTANT; 10308 break; 10309 10310 case FFEINFO_whereIMMEDIATE: 10311 nwh = FFEINFO_whereIMMEDIATE; 10312 break; 10313 10314 default: 10315 nwh = FFEINFO_whereFLEETING; 10316 break; 10317 } 10318 break; 10319 10320 case FFEINFO_whereIMMEDIATE: 10321 switch (rwh) 10322 { 10323 case FFEINFO_whereCONSTANT: 10324 case FFEINFO_whereIMMEDIATE: 10325 nwh = FFEINFO_whereIMMEDIATE; 10326 break; 10327 10328 default: 10329 nwh = FFEINFO_whereFLEETING; 10330 break; 10331 } 10332 break; 10333 10334 default: 10335 nwh = FFEINFO_whereFLEETING; 10336 break; 10337 } 10338 10339 nkt = lkt; 10340 ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk); 10341 ffebld_set_info (reduced, ninfo); 10342 return reduced; 10343 } 10344 10345 if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER)) 10346 { 10347 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) 10348 && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE)) 10349 { 10350 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10351 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 10352 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10353 ffebad_finish (); 10354 } 10355 } 10356 else if (lbt != FFEINFO_basictypeCHARACTER) 10357 { 10358 if ((lbt != FFEINFO_basictypeANY) 10359 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE)) 10360 { 10361 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10362 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 10363 ffebad_finish (); 10364 } 10365 } 10366 else if (rbt != FFEINFO_basictypeCHARACTER) 10367 { 10368 if ((rbt != FFEINFO_basictypeANY) 10369 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE)) 10370 { 10371 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10372 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10373 ffebad_finish (); 10374 } 10375 } 10376 else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE)) 10377 { 10378 if ((lkd != FFEINFO_kindANY) 10379 && ffebad_start (FFEBAD_CONCAT_ARG_KIND)) 10380 { 10381 const char *what; 10382 10383 if (lrk != 0) 10384 what = "an array"; 10385 else 10386 what = "of indeterminate length"; 10387 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10388 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 10389 ffebad_string (what); 10390 ffebad_finish (); 10391 } 10392 } 10393 else 10394 { 10395 if (ffebad_start (FFEBAD_CONCAT_ARG_KIND)) 10396 { 10397 const char *what; 10398 10399 if (rrk != 0) 10400 what = "an array"; 10401 else 10402 what = "of indeterminate length"; 10403 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10404 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10405 ffebad_string (what); 10406 ffebad_finish (); 10407 } 10408 } 10409 10410 reduced = ffebld_new_any (); 10411 ffebld_set_info (reduced, ffeinfo_new_any ()); 10412 return reduced; 10413} 10414 10415/* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators 10416 10417 reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r); 10418 10419 Makes sure the left and right arguments for reduced have basictype of 10420 INTEGER, REAL, COMPLEX, or CHARACTER. Determine common basictype and 10421 size for reduction. If both left 10422 and right arguments have where of CONSTANT, assign where CONSTANT to 10423 reduced, else assign where FLEETING. Create CONVERT ops for args where 10424 needed. Convert typeless 10425 constants to the desired type/size explicitly. 10426 10427 If these requirements cannot be met, generate error message. */ 10428 10429static ffebld 10430ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, 10431 ffeexprExpr_ r) 10432{ 10433 ffeinfo linfo, rinfo, ninfo; 10434 ffeinfoBasictype lbt, rbt, nbt; 10435 ffeinfoKindtype lkt, rkt, nkt; 10436 ffeinfoRank lrk, rrk; 10437 ffeinfoKind lkd, rkd; 10438 ffeinfoWhere lwh, rwh, nwh; 10439 ffetargetCharacterSize lsz, rsz; 10440 10441 linfo = ffebld_info (ffebld_left (reduced)); 10442 lbt = ffeinfo_basictype (linfo); 10443 lkt = ffeinfo_kindtype (linfo); 10444 lrk = ffeinfo_rank (linfo); 10445 lkd = ffeinfo_kind (linfo); 10446 lwh = ffeinfo_where (linfo); 10447 lsz = ffebld_size_known (ffebld_left (reduced)); 10448 10449 rinfo = ffebld_info (ffebld_right (reduced)); 10450 rbt = ffeinfo_basictype (rinfo); 10451 rkt = ffeinfo_kindtype (rinfo); 10452 rrk = ffeinfo_rank (rinfo); 10453 rkd = ffeinfo_kind (rinfo); 10454 rwh = ffeinfo_where (rinfo); 10455 rsz = ffebld_size_known (ffebld_right (reduced)); 10456 10457 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); 10458 10459 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL) 10460 || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER)) 10461 && (lrk == 0) && (rrk == 0)) 10462 { 10463 switch (lwh) 10464 { 10465 case FFEINFO_whereCONSTANT: 10466 switch (rwh) 10467 { 10468 case FFEINFO_whereCONSTANT: 10469 nwh = FFEINFO_whereCONSTANT; 10470 break; 10471 10472 case FFEINFO_whereIMMEDIATE: 10473 nwh = FFEINFO_whereIMMEDIATE; 10474 break; 10475 10476 default: 10477 nwh = FFEINFO_whereFLEETING; 10478 break; 10479 } 10480 break; 10481 10482 case FFEINFO_whereIMMEDIATE: 10483 switch (rwh) 10484 { 10485 case FFEINFO_whereCONSTANT: 10486 case FFEINFO_whereIMMEDIATE: 10487 nwh = FFEINFO_whereIMMEDIATE; 10488 break; 10489 10490 default: 10491 nwh = FFEINFO_whereFLEETING; 10492 break; 10493 } 10494 break; 10495 10496 default: 10497 nwh = FFEINFO_whereFLEETING; 10498 break; 10499 } 10500 10501 if ((lsz != FFETARGET_charactersizeNONE) 10502 && (rsz != FFETARGET_charactersizeNONE)) 10503 lsz = rsz = (lsz > rsz) ? lsz : rsz; 10504 10505 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 10506 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE); 10507 ffebld_set_info (reduced, ninfo); 10508 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), 10509 l->token, op->token, nbt, nkt, 0, lsz, 10510 FFEEXPR_contextLET)); 10511 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), 10512 r->token, op->token, nbt, nkt, 0, rsz, 10513 FFEEXPR_contextLET)); 10514 return reduced; 10515 } 10516 10517 if ((lbt == FFEINFO_basictypeLOGICAL) 10518 && (rbt == FFEINFO_basictypeLOGICAL)) 10519 { 10520 if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2", 10521 FFEBAD_severityFATAL)) 10522 { 10523 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10524 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 10525 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10526 ffebad_finish (); 10527 } 10528 } 10529 else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL) 10530 && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER)) 10531 { 10532 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) 10533 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER)) 10534 { 10535 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) 10536 && ffebad_start (FFEBAD_EQOP_ARGS_TYPE)) 10537 { 10538 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10539 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 10540 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10541 ffebad_finish (); 10542 } 10543 } 10544 else 10545 { 10546 if ((lbt != FFEINFO_basictypeANY) 10547 && ffebad_start (FFEBAD_EQOP_ARG_TYPE)) 10548 { 10549 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10550 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 10551 ffebad_finish (); 10552 } 10553 } 10554 } 10555 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) 10556 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER)) 10557 { 10558 if ((rbt != FFEINFO_basictypeANY) 10559 && ffebad_start (FFEBAD_EQOP_ARG_TYPE)) 10560 { 10561 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10562 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10563 ffebad_finish (); 10564 } 10565 } 10566 else if (lrk != 0) 10567 { 10568 if ((lkd != FFEINFO_kindANY) 10569 && ffebad_start (FFEBAD_EQOP_ARG_KIND)) 10570 { 10571 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10572 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 10573 ffebad_string ("an array"); 10574 ffebad_finish (); 10575 } 10576 } 10577 else 10578 { 10579 if ((rkd != FFEINFO_kindANY) 10580 && ffebad_start (FFEBAD_EQOP_ARG_KIND)) 10581 { 10582 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10583 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10584 ffebad_string ("an array"); 10585 ffebad_finish (); 10586 } 10587 } 10588 10589 reduced = ffebld_new_any (); 10590 ffebld_set_info (reduced, ffeinfo_new_any ()); 10591 return reduced; 10592} 10593 10594/* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators 10595 10596 reduced = ffeexpr_reduced_math1_(reduced,op,r); 10597 10598 Makes sure the argument for reduced has basictype of 10599 INTEGER, REAL, or COMPLEX. If the argument has where of CONSTANT, 10600 assign where CONSTANT to 10601 reduced, else assign where FLEETING. 10602 10603 If these requirements cannot be met, generate error message. */ 10604 10605static ffebld 10606ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r) 10607{ 10608 ffeinfo rinfo, ninfo; 10609 ffeinfoBasictype rbt; 10610 ffeinfoKindtype rkt; 10611 ffeinfoRank rrk; 10612 ffeinfoKind rkd; 10613 ffeinfoWhere rwh, nwh; 10614 10615 rinfo = ffebld_info (ffebld_left (reduced)); 10616 rbt = ffeinfo_basictype (rinfo); 10617 rkt = ffeinfo_kindtype (rinfo); 10618 rrk = ffeinfo_rank (rinfo); 10619 rkd = ffeinfo_kind (rinfo); 10620 rwh = ffeinfo_where (rinfo); 10621 10622 if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL) 10623 || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0)) 10624 { 10625 switch (rwh) 10626 { 10627 case FFEINFO_whereCONSTANT: 10628 nwh = FFEINFO_whereCONSTANT; 10629 break; 10630 10631 case FFEINFO_whereIMMEDIATE: 10632 nwh = FFEINFO_whereIMMEDIATE; 10633 break; 10634 10635 default: 10636 nwh = FFEINFO_whereFLEETING; 10637 break; 10638 } 10639 10640 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh, 10641 FFETARGET_charactersizeNONE); 10642 ffebld_set_info (reduced, ninfo); 10643 return reduced; 10644 } 10645 10646 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) 10647 && (rbt != FFEINFO_basictypeCOMPLEX)) 10648 { 10649 if ((rbt != FFEINFO_basictypeANY) 10650 && ffebad_start (FFEBAD_MATH_ARG_TYPE)) 10651 { 10652 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10653 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10654 ffebad_finish (); 10655 } 10656 } 10657 else 10658 { 10659 if ((rkd != FFEINFO_kindANY) 10660 && ffebad_start (FFEBAD_MATH_ARG_KIND)) 10661 { 10662 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10663 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10664 ffebad_string ("an array"); 10665 ffebad_finish (); 10666 } 10667 } 10668 10669 reduced = ffebld_new_any (); 10670 ffebld_set_info (reduced, ffeinfo_new_any ()); 10671 return reduced; 10672} 10673 10674/* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators 10675 10676 reduced = ffeexpr_reduced_math2_(reduced,l,op,r); 10677 10678 Makes sure the left and right arguments for reduced have basictype of 10679 INTEGER, REAL, or COMPLEX. Determine common basictype and 10680 size for reduction (flag expression for combined hollerith/typeless 10681 situations for later determination of effective basictype). If both left 10682 and right arguments have where of CONSTANT, assign where CONSTANT to 10683 reduced, else assign where FLEETING. Create CONVERT ops for args where 10684 needed. Convert typeless 10685 constants to the desired type/size explicitly. 10686 10687 If these requirements cannot be met, generate error message. */ 10688 10689static ffebld 10690ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, 10691 ffeexprExpr_ r) 10692{ 10693 ffeinfo linfo, rinfo, ninfo; 10694 ffeinfoBasictype lbt, rbt, nbt; 10695 ffeinfoKindtype lkt, rkt, nkt; 10696 ffeinfoRank lrk, rrk; 10697 ffeinfoKind lkd, rkd; 10698 ffeinfoWhere lwh, rwh, nwh; 10699 10700 linfo = ffebld_info (ffebld_left (reduced)); 10701 lbt = ffeinfo_basictype (linfo); 10702 lkt = ffeinfo_kindtype (linfo); 10703 lrk = ffeinfo_rank (linfo); 10704 lkd = ffeinfo_kind (linfo); 10705 lwh = ffeinfo_where (linfo); 10706 10707 rinfo = ffebld_info (ffebld_right (reduced)); 10708 rbt = ffeinfo_basictype (rinfo); 10709 rkt = ffeinfo_kindtype (rinfo); 10710 rrk = ffeinfo_rank (rinfo); 10711 rkd = ffeinfo_kind (rinfo); 10712 rwh = ffeinfo_where (rinfo); 10713 10714 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); 10715 10716 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL) 10717 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0)) 10718 { 10719 switch (lwh) 10720 { 10721 case FFEINFO_whereCONSTANT: 10722 switch (rwh) 10723 { 10724 case FFEINFO_whereCONSTANT: 10725 nwh = FFEINFO_whereCONSTANT; 10726 break; 10727 10728 case FFEINFO_whereIMMEDIATE: 10729 nwh = FFEINFO_whereIMMEDIATE; 10730 break; 10731 10732 default: 10733 nwh = FFEINFO_whereFLEETING; 10734 break; 10735 } 10736 break; 10737 10738 case FFEINFO_whereIMMEDIATE: 10739 switch (rwh) 10740 { 10741 case FFEINFO_whereCONSTANT: 10742 case FFEINFO_whereIMMEDIATE: 10743 nwh = FFEINFO_whereIMMEDIATE; 10744 break; 10745 10746 default: 10747 nwh = FFEINFO_whereFLEETING; 10748 break; 10749 } 10750 break; 10751 10752 default: 10753 nwh = FFEINFO_whereFLEETING; 10754 break; 10755 } 10756 10757 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh, 10758 FFETARGET_charactersizeNONE); 10759 ffebld_set_info (reduced, ninfo); 10760 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), 10761 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, 10762 FFEEXPR_contextLET)); 10763 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), 10764 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, 10765 FFEEXPR_contextLET)); 10766 return reduced; 10767 } 10768 10769 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL) 10770 && (lbt != FFEINFO_basictypeCOMPLEX)) 10771 { 10772 if ((rbt != FFEINFO_basictypeINTEGER) 10773 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX)) 10774 { 10775 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) 10776 && ffebad_start (FFEBAD_MATH_ARGS_TYPE)) 10777 { 10778 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10779 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 10780 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10781 ffebad_finish (); 10782 } 10783 } 10784 else 10785 { 10786 if ((lbt != FFEINFO_basictypeANY) 10787 && ffebad_start (FFEBAD_MATH_ARG_TYPE)) 10788 { 10789 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10790 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 10791 ffebad_finish (); 10792 } 10793 } 10794 } 10795 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) 10796 && (rbt != FFEINFO_basictypeCOMPLEX)) 10797 { 10798 if ((rbt != FFEINFO_basictypeANY) 10799 && ffebad_start (FFEBAD_MATH_ARG_TYPE)) 10800 { 10801 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10802 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10803 ffebad_finish (); 10804 } 10805 } 10806 else if (lrk != 0) 10807 { 10808 if ((lkd != FFEINFO_kindANY) 10809 && ffebad_start (FFEBAD_MATH_ARG_KIND)) 10810 { 10811 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10812 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 10813 ffebad_string ("an array"); 10814 ffebad_finish (); 10815 } 10816 } 10817 else 10818 { 10819 if ((rkd != FFEINFO_kindANY) 10820 && ffebad_start (FFEBAD_MATH_ARG_KIND)) 10821 { 10822 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10823 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10824 ffebad_string ("an array"); 10825 ffebad_finish (); 10826 } 10827 } 10828 10829 reduced = ffebld_new_any (); 10830 ffebld_set_info (reduced, ffeinfo_new_any ()); 10831 return reduced; 10832} 10833 10834/* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator 10835 10836 reduced = ffeexpr_reduced_power_(reduced,l,op,r); 10837 10838 Makes sure the left and right arguments for reduced have basictype of 10839 INTEGER, REAL, or COMPLEX. Determine common basictype and 10840 size for reduction (flag expression for combined hollerith/typeless 10841 situations for later determination of effective basictype). If both left 10842 and right arguments have where of CONSTANT, assign where CONSTANT to 10843 reduced, else assign where FLEETING. Create CONVERT ops for args where 10844 needed. Note that real**int or complex**int 10845 comes out as int = real**int etc with no conversions. 10846 10847 If these requirements cannot be met, generate error message using the 10848 info in l, op, and r arguments and assign basictype, size, kind, and where 10849 of ANY. */ 10850 10851static ffebld 10852ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, 10853 ffeexprExpr_ r) 10854{ 10855 ffeinfo linfo, rinfo, ninfo; 10856 ffeinfoBasictype lbt, rbt, nbt; 10857 ffeinfoKindtype lkt, rkt, nkt; 10858 ffeinfoRank lrk, rrk; 10859 ffeinfoKind lkd, rkd; 10860 ffeinfoWhere lwh, rwh, nwh; 10861 10862 linfo = ffebld_info (ffebld_left (reduced)); 10863 lbt = ffeinfo_basictype (linfo); 10864 lkt = ffeinfo_kindtype (linfo); 10865 lrk = ffeinfo_rank (linfo); 10866 lkd = ffeinfo_kind (linfo); 10867 lwh = ffeinfo_where (linfo); 10868 10869 rinfo = ffebld_info (ffebld_right (reduced)); 10870 rbt = ffeinfo_basictype (rinfo); 10871 rkt = ffeinfo_kindtype (rinfo); 10872 rrk = ffeinfo_rank (rinfo); 10873 rkd = ffeinfo_kind (rinfo); 10874 rwh = ffeinfo_where (rinfo); 10875 10876 if ((rbt == FFEINFO_basictypeINTEGER) 10877 && ((lbt == FFEINFO_basictypeREAL) 10878 || (lbt == FFEINFO_basictypeCOMPLEX))) 10879 { 10880 nbt = lbt; 10881 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT); 10882 if (nkt != FFEINFO_kindtypeREALDEFAULT) 10883 { 10884 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE); 10885 if (nkt != FFEINFO_kindtypeREALDOUBLE) 10886 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */ 10887 } 10888 if (rkt == FFEINFO_kindtypeINTEGER4) 10889 { 10890 ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER", 10891 FFEBAD_severityWARNING); 10892 ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10893 ffebad_finish (); 10894 } 10895 if (rkt != FFEINFO_kindtypeINTEGERDEFAULT) 10896 { 10897 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), 10898 r->token, op->token, 10899 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, 10900 FFETARGET_charactersizeNONE, 10901 FFEEXPR_contextLET)); 10902 rkt = FFEINFO_kindtypeINTEGERDEFAULT; 10903 } 10904 } 10905 else 10906 { 10907 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); 10908 10909#if 0 /* INTEGER4**INTEGER4 works now. */ 10910 if ((nbt == FFEINFO_basictypeINTEGER) 10911 && (nkt != FFEINFO_kindtypeINTEGERDEFAULT)) 10912 nkt = FFEINFO_kindtypeINTEGERDEFAULT; /* Highest kt we can power! */ 10913#endif 10914 if (((nbt == FFEINFO_basictypeREAL) 10915 || (nbt == FFEINFO_basictypeCOMPLEX)) 10916 && (nkt != FFEINFO_kindtypeREALDEFAULT)) 10917 { 10918 nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE); 10919 if (nkt != FFEINFO_kindtypeREALDOUBLE) 10920 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */ 10921 } 10922 /* else Gonna turn into an error below. */ 10923 } 10924 10925 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL) 10926 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0)) 10927 { 10928 switch (lwh) 10929 { 10930 case FFEINFO_whereCONSTANT: 10931 switch (rwh) 10932 { 10933 case FFEINFO_whereCONSTANT: 10934 nwh = FFEINFO_whereCONSTANT; 10935 break; 10936 10937 case FFEINFO_whereIMMEDIATE: 10938 nwh = FFEINFO_whereIMMEDIATE; 10939 break; 10940 10941 default: 10942 nwh = FFEINFO_whereFLEETING; 10943 break; 10944 } 10945 break; 10946 10947 case FFEINFO_whereIMMEDIATE: 10948 switch (rwh) 10949 { 10950 case FFEINFO_whereCONSTANT: 10951 case FFEINFO_whereIMMEDIATE: 10952 nwh = FFEINFO_whereIMMEDIATE; 10953 break; 10954 10955 default: 10956 nwh = FFEINFO_whereFLEETING; 10957 break; 10958 } 10959 break; 10960 10961 default: 10962 nwh = FFEINFO_whereFLEETING; 10963 break; 10964 } 10965 10966 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh, 10967 FFETARGET_charactersizeNONE); 10968 ffebld_set_info (reduced, ninfo); 10969 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), 10970 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, 10971 FFEEXPR_contextLET)); 10972 if (rbt != FFEINFO_basictypeINTEGER) 10973 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), 10974 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, 10975 FFEEXPR_contextLET)); 10976 return reduced; 10977 } 10978 10979 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL) 10980 && (lbt != FFEINFO_basictypeCOMPLEX)) 10981 { 10982 if ((rbt != FFEINFO_basictypeINTEGER) 10983 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX)) 10984 { 10985 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) 10986 && ffebad_start (FFEBAD_MATH_ARGS_TYPE)) 10987 { 10988 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 10989 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 10990 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 10991 ffebad_finish (); 10992 } 10993 } 10994 else 10995 { 10996 if ((lbt != FFEINFO_basictypeANY) 10997 && ffebad_start (FFEBAD_MATH_ARG_TYPE)) 10998 { 10999 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 11000 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 11001 ffebad_finish (); 11002 } 11003 } 11004 } 11005 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) 11006 && (rbt != FFEINFO_basictypeCOMPLEX)) 11007 { 11008 if ((rbt != FFEINFO_basictypeANY) 11009 && ffebad_start (FFEBAD_MATH_ARG_TYPE)) 11010 { 11011 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 11012 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 11013 ffebad_finish (); 11014 } 11015 } 11016 else if (lrk != 0) 11017 { 11018 if ((lkd != FFEINFO_kindANY) 11019 && ffebad_start (FFEBAD_MATH_ARG_KIND)) 11020 { 11021 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 11022 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 11023 ffebad_string ("an array"); 11024 ffebad_finish (); 11025 } 11026 } 11027 else 11028 { 11029 if ((rkd != FFEINFO_kindANY) 11030 && ffebad_start (FFEBAD_MATH_ARG_KIND)) 11031 { 11032 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 11033 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 11034 ffebad_string ("an array"); 11035 ffebad_finish (); 11036 } 11037 } 11038 11039 reduced = ffebld_new_any (); 11040 ffebld_set_info (reduced, ffeinfo_new_any ()); 11041 return reduced; 11042} 11043 11044/* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators 11045 11046 reduced = ffeexpr_reduced_relop2_(reduced,l,op,r); 11047 11048 Makes sure the left and right arguments for reduced have basictype of 11049 INTEGER, REAL, or CHARACTER. Determine common basictype and 11050 size for reduction. If both left 11051 and right arguments have where of CONSTANT, assign where CONSTANT to 11052 reduced, else assign where FLEETING. Create CONVERT ops for args where 11053 needed. Convert typeless 11054 constants to the desired type/size explicitly. 11055 11056 If these requirements cannot be met, generate error message. */ 11057 11058static ffebld 11059ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, 11060 ffeexprExpr_ r) 11061{ 11062 ffeinfo linfo, rinfo, ninfo; 11063 ffeinfoBasictype lbt, rbt, nbt; 11064 ffeinfoKindtype lkt, rkt, nkt; 11065 ffeinfoRank lrk, rrk; 11066 ffeinfoKind lkd, rkd; 11067 ffeinfoWhere lwh, rwh, nwh; 11068 ffetargetCharacterSize lsz, rsz; 11069 11070 linfo = ffebld_info (ffebld_left (reduced)); 11071 lbt = ffeinfo_basictype (linfo); 11072 lkt = ffeinfo_kindtype (linfo); 11073 lrk = ffeinfo_rank (linfo); 11074 lkd = ffeinfo_kind (linfo); 11075 lwh = ffeinfo_where (linfo); 11076 lsz = ffebld_size_known (ffebld_left (reduced)); 11077 11078 rinfo = ffebld_info (ffebld_right (reduced)); 11079 rbt = ffeinfo_basictype (rinfo); 11080 rkt = ffeinfo_kindtype (rinfo); 11081 rrk = ffeinfo_rank (rinfo); 11082 rkd = ffeinfo_kind (rinfo); 11083 rwh = ffeinfo_where (rinfo); 11084 rsz = ffebld_size_known (ffebld_right (reduced)); 11085 11086 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); 11087 11088 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL) 11089 || (nbt == FFEINFO_basictypeCHARACTER)) 11090 && (lrk == 0) && (rrk == 0)) 11091 { 11092 switch (lwh) 11093 { 11094 case FFEINFO_whereCONSTANT: 11095 switch (rwh) 11096 { 11097 case FFEINFO_whereCONSTANT: 11098 nwh = FFEINFO_whereCONSTANT; 11099 break; 11100 11101 case FFEINFO_whereIMMEDIATE: 11102 nwh = FFEINFO_whereIMMEDIATE; 11103 break; 11104 11105 default: 11106 nwh = FFEINFO_whereFLEETING; 11107 break; 11108 } 11109 break; 11110 11111 case FFEINFO_whereIMMEDIATE: 11112 switch (rwh) 11113 { 11114 case FFEINFO_whereCONSTANT: 11115 case FFEINFO_whereIMMEDIATE: 11116 nwh = FFEINFO_whereIMMEDIATE; 11117 break; 11118 11119 default: 11120 nwh = FFEINFO_whereFLEETING; 11121 break; 11122 } 11123 break; 11124 11125 default: 11126 nwh = FFEINFO_whereFLEETING; 11127 break; 11128 } 11129 11130 if ((lsz != FFETARGET_charactersizeNONE) 11131 && (rsz != FFETARGET_charactersizeNONE)) 11132 lsz = rsz = (lsz > rsz) ? lsz : rsz; 11133 11134 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 11135 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE); 11136 ffebld_set_info (reduced, ninfo); 11137 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), 11138 l->token, op->token, nbt, nkt, 0, lsz, 11139 FFEEXPR_contextLET)); 11140 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), 11141 r->token, op->token, nbt, nkt, 0, rsz, 11142 FFEEXPR_contextLET)); 11143 return reduced; 11144 } 11145 11146 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL) 11147 && (lbt != FFEINFO_basictypeCHARACTER)) 11148 { 11149 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) 11150 && (rbt != FFEINFO_basictypeCHARACTER)) 11151 { 11152 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) 11153 && ffebad_start (FFEBAD_RELOP_ARGS_TYPE)) 11154 { 11155 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 11156 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 11157 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 11158 ffebad_finish (); 11159 } 11160 } 11161 else 11162 { 11163 if ((lbt != FFEINFO_basictypeANY) 11164 && ffebad_start (FFEBAD_RELOP_ARG_TYPE)) 11165 { 11166 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 11167 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 11168 ffebad_finish (); 11169 } 11170 } 11171 } 11172 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) 11173 && (rbt != FFEINFO_basictypeCHARACTER)) 11174 { 11175 if ((rbt != FFEINFO_basictypeANY) 11176 && ffebad_start (FFEBAD_RELOP_ARG_TYPE)) 11177 { 11178 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 11179 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 11180 ffebad_finish (); 11181 } 11182 } 11183 else if (lrk != 0) 11184 { 11185 if ((lkd != FFEINFO_kindANY) 11186 && ffebad_start (FFEBAD_RELOP_ARG_KIND)) 11187 { 11188 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 11189 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); 11190 ffebad_string ("an array"); 11191 ffebad_finish (); 11192 } 11193 } 11194 else 11195 { 11196 if ((rkd != FFEINFO_kindANY) 11197 && ffebad_start (FFEBAD_RELOP_ARG_KIND)) 11198 { 11199 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); 11200 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); 11201 ffebad_string ("an array"); 11202 ffebad_finish (); 11203 } 11204 } 11205 11206 reduced = ffebld_new_any (); 11207 ffebld_set_info (reduced, ffeinfo_new_any ()); 11208 return reduced; 11209} 11210 11211/* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL 11212 11213 reduced = ffeexpr_reduced_ugly1_(reduced,op,r); 11214 11215 Sigh. */ 11216 11217static ffebld 11218ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r) 11219{ 11220 ffeinfo rinfo; 11221 ffeinfoBasictype rbt; 11222 ffeinfoKindtype rkt; 11223 ffeinfoRank rrk; 11224 ffeinfoKind rkd; 11225 ffeinfoWhere rwh; 11226 11227 rinfo = ffebld_info (ffebld_left (reduced)); 11228 rbt = ffeinfo_basictype (rinfo); 11229 rkt = ffeinfo_kindtype (rinfo); 11230 rrk = ffeinfo_rank (rinfo); 11231 rkd = ffeinfo_kind (rinfo); 11232 rwh = ffeinfo_where (rinfo); 11233 11234 if ((rbt == FFEINFO_basictypeTYPELESS) 11235 || (rbt == FFEINFO_basictypeHOLLERITH)) 11236 { 11237 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), 11238 r->token, op->token, FFEINFO_basictypeINTEGER, 11239 FFEINFO_kindtypeINTEGERDEFAULT, 0, 11240 FFETARGET_charactersizeNONE, 11241 FFEEXPR_contextLET)); 11242 rinfo = ffebld_info (ffebld_left (reduced)); 11243 rbt = FFEINFO_basictypeINTEGER; 11244 rkt = FFEINFO_kindtypeINTEGERDEFAULT; 11245 rrk = 0; 11246 rkd = FFEINFO_kindENTITY; 11247 rwh = ffeinfo_where (rinfo); 11248 } 11249 11250 if (rbt == FFEINFO_basictypeLOGICAL) 11251 { 11252 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), 11253 r->token, op->token, FFEINFO_basictypeINTEGER, 11254 FFEINFO_kindtypeINTEGERDEFAULT, 0, 11255 FFETARGET_charactersizeNONE, 11256 FFEEXPR_contextLET)); 11257 } 11258 11259 return reduced; 11260} 11261 11262/* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH 11263 11264 reduced = ffeexpr_reduced_ugly1log_(reduced,op,r); 11265 11266 Sigh. */ 11267 11268static ffebld 11269ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r) 11270{ 11271 ffeinfo rinfo; 11272 ffeinfoBasictype rbt; 11273 ffeinfoKindtype rkt; 11274 ffeinfoRank rrk; 11275 ffeinfoKind rkd; 11276 ffeinfoWhere rwh; 11277 11278 rinfo = ffebld_info (ffebld_left (reduced)); 11279 rbt = ffeinfo_basictype (rinfo); 11280 rkt = ffeinfo_kindtype (rinfo); 11281 rrk = ffeinfo_rank (rinfo); 11282 rkd = ffeinfo_kind (rinfo); 11283 rwh = ffeinfo_where (rinfo); 11284 11285 if ((rbt == FFEINFO_basictypeTYPELESS) 11286 || (rbt == FFEINFO_basictypeHOLLERITH)) 11287 { 11288 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), 11289 r->token, op->token, FFEINFO_basictypeLOGICAL, 0, 11290 FFEINFO_kindtypeLOGICALDEFAULT, 11291 FFETARGET_charactersizeNONE, 11292 FFEEXPR_contextLET)); 11293 rinfo = ffebld_info (ffebld_left (reduced)); 11294 rbt = FFEINFO_basictypeLOGICAL; 11295 rkt = FFEINFO_kindtypeLOGICALDEFAULT; 11296 rrk = 0; 11297 rkd = FFEINFO_kindENTITY; 11298 rwh = ffeinfo_where (rinfo); 11299 } 11300 11301 return reduced; 11302} 11303 11304/* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL 11305 11306 reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r); 11307 11308 Sigh. */ 11309 11310static ffebld 11311ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, 11312 ffeexprExpr_ r) 11313{ 11314 ffeinfo linfo, rinfo; 11315 ffeinfoBasictype lbt, rbt; 11316 ffeinfoKindtype lkt, rkt; 11317 ffeinfoRank lrk, rrk; 11318 ffeinfoKind lkd, rkd; 11319 ffeinfoWhere lwh, rwh; 11320 11321 linfo = ffebld_info (ffebld_left (reduced)); 11322 lbt = ffeinfo_basictype (linfo); 11323 lkt = ffeinfo_kindtype (linfo); 11324 lrk = ffeinfo_rank (linfo); 11325 lkd = ffeinfo_kind (linfo); 11326 lwh = ffeinfo_where (linfo); 11327 11328 rinfo = ffebld_info (ffebld_right (reduced)); 11329 rbt = ffeinfo_basictype (rinfo); 11330 rkt = ffeinfo_kindtype (rinfo); 11331 rrk = ffeinfo_rank (rinfo); 11332 rkd = ffeinfo_kind (rinfo); 11333 rwh = ffeinfo_where (rinfo); 11334 11335 if ((lbt == FFEINFO_basictypeTYPELESS) 11336 || (lbt == FFEINFO_basictypeHOLLERITH)) 11337 { 11338 if ((rbt == FFEINFO_basictypeTYPELESS) 11339 || (rbt == FFEINFO_basictypeHOLLERITH)) 11340 { 11341 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), 11342 l->token, op->token, FFEINFO_basictypeINTEGER, 11343 FFEINFO_kindtypeINTEGERDEFAULT, 0, 11344 FFETARGET_charactersizeNONE, 11345 FFEEXPR_contextLET)); 11346 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), 11347 r->token, op->token, FFEINFO_basictypeINTEGER, 0, 11348 FFEINFO_kindtypeINTEGERDEFAULT, 11349 FFETARGET_charactersizeNONE, 11350 FFEEXPR_contextLET)); 11351 linfo = ffebld_info (ffebld_left (reduced)); 11352 rinfo = ffebld_info (ffebld_right (reduced)); 11353 lbt = rbt = FFEINFO_basictypeINTEGER; 11354 lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT; 11355 lrk = rrk = 0; 11356 lkd = rkd = FFEINFO_kindENTITY; 11357 lwh = ffeinfo_where (linfo); 11358 rwh = ffeinfo_where (rinfo); 11359 } 11360 else 11361 { 11362 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced), 11363 l->token, ffebld_right (reduced), r->token, 11364 FFEEXPR_contextLET)); 11365 linfo = ffebld_info (ffebld_left (reduced)); 11366 lbt = ffeinfo_basictype (linfo); 11367 lkt = ffeinfo_kindtype (linfo); 11368 lrk = ffeinfo_rank (linfo); 11369 lkd = ffeinfo_kind (linfo); 11370 lwh = ffeinfo_where (linfo); 11371 } 11372 } 11373 else 11374 { 11375 if ((rbt == FFEINFO_basictypeTYPELESS) 11376 || (rbt == FFEINFO_basictypeHOLLERITH)) 11377 { 11378 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced), 11379 r->token, ffebld_left (reduced), l->token, 11380 FFEEXPR_contextLET)); 11381 rinfo = ffebld_info (ffebld_right (reduced)); 11382 rbt = ffeinfo_basictype (rinfo); 11383 rkt = ffeinfo_kindtype (rinfo); 11384 rrk = ffeinfo_rank (rinfo); 11385 rkd = ffeinfo_kind (rinfo); 11386 rwh = ffeinfo_where (rinfo); 11387 } 11388 /* else Leave it alone. */ 11389 } 11390 11391 if (lbt == FFEINFO_basictypeLOGICAL) 11392 { 11393 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), 11394 l->token, op->token, FFEINFO_basictypeINTEGER, 11395 FFEINFO_kindtypeINTEGERDEFAULT, 0, 11396 FFETARGET_charactersizeNONE, 11397 FFEEXPR_contextLET)); 11398 } 11399 11400 if (rbt == FFEINFO_basictypeLOGICAL) 11401 { 11402 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), 11403 r->token, op->token, FFEINFO_basictypeINTEGER, 11404 FFEINFO_kindtypeINTEGERDEFAULT, 0, 11405 FFETARGET_charactersizeNONE, 11406 FFEEXPR_contextLET)); 11407 } 11408 11409 return reduced; 11410} 11411 11412/* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH 11413 11414 reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r); 11415 11416 Sigh. */ 11417 11418static ffebld 11419ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, 11420 ffeexprExpr_ r) 11421{ 11422 ffeinfo linfo, rinfo; 11423 ffeinfoBasictype lbt, rbt; 11424 ffeinfoKindtype lkt, rkt; 11425 ffeinfoRank lrk, rrk; 11426 ffeinfoKind lkd, rkd; 11427 ffeinfoWhere lwh, rwh; 11428 11429 linfo = ffebld_info (ffebld_left (reduced)); 11430 lbt = ffeinfo_basictype (linfo); 11431 lkt = ffeinfo_kindtype (linfo); 11432 lrk = ffeinfo_rank (linfo); 11433 lkd = ffeinfo_kind (linfo); 11434 lwh = ffeinfo_where (linfo); 11435 11436 rinfo = ffebld_info (ffebld_right (reduced)); 11437 rbt = ffeinfo_basictype (rinfo); 11438 rkt = ffeinfo_kindtype (rinfo); 11439 rrk = ffeinfo_rank (rinfo); 11440 rkd = ffeinfo_kind (rinfo); 11441 rwh = ffeinfo_where (rinfo); 11442 11443 if ((lbt == FFEINFO_basictypeTYPELESS) 11444 || (lbt == FFEINFO_basictypeHOLLERITH)) 11445 { 11446 if ((rbt == FFEINFO_basictypeTYPELESS) 11447 || (rbt == FFEINFO_basictypeHOLLERITH)) 11448 { 11449 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), 11450 l->token, op->token, FFEINFO_basictypeLOGICAL, 11451 FFEINFO_kindtypeLOGICALDEFAULT, 0, 11452 FFETARGET_charactersizeNONE, 11453 FFEEXPR_contextLET)); 11454 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), 11455 r->token, op->token, FFEINFO_basictypeLOGICAL, 11456 FFEINFO_kindtypeLOGICALDEFAULT, 0, 11457 FFETARGET_charactersizeNONE, 11458 FFEEXPR_contextLET)); 11459 linfo = ffebld_info (ffebld_left (reduced)); 11460 rinfo = ffebld_info (ffebld_right (reduced)); 11461 lbt = rbt = FFEINFO_basictypeLOGICAL; 11462 lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT; 11463 lrk = rrk = 0; 11464 lkd = rkd = FFEINFO_kindENTITY; 11465 lwh = ffeinfo_where (linfo); 11466 rwh = ffeinfo_where (rinfo); 11467 } 11468 else 11469 { 11470 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced), 11471 l->token, ffebld_right (reduced), r->token, 11472 FFEEXPR_contextLET)); 11473 linfo = ffebld_info (ffebld_left (reduced)); 11474 lbt = ffeinfo_basictype (linfo); 11475 lkt = ffeinfo_kindtype (linfo); 11476 lrk = ffeinfo_rank (linfo); 11477 lkd = ffeinfo_kind (linfo); 11478 lwh = ffeinfo_where (linfo); 11479 } 11480 } 11481 else 11482 { 11483 if ((rbt == FFEINFO_basictypeTYPELESS) 11484 || (rbt == FFEINFO_basictypeHOLLERITH)) 11485 { 11486 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced), 11487 r->token, ffebld_left (reduced), l->token, 11488 FFEEXPR_contextLET)); 11489 rinfo = ffebld_info (ffebld_right (reduced)); 11490 rbt = ffeinfo_basictype (rinfo); 11491 rkt = ffeinfo_kindtype (rinfo); 11492 rrk = ffeinfo_rank (rinfo); 11493 rkd = ffeinfo_kind (rinfo); 11494 rwh = ffeinfo_where (rinfo); 11495 } 11496 /* else Leave it alone. */ 11497 } 11498 11499 return reduced; 11500} 11501 11502/* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON 11503 is found. 11504 11505 The idea is to process the tokens as they would be done by normal 11506 expression processing, with the key things being telling the lexer 11507 when hollerith/character constants are about to happen, until the 11508 true closing token is found. */ 11509 11510static ffelexHandler 11511ffeexpr_find_close_paren_ (ffelexToken t, 11512 ffelexHandler after) 11513{ 11514 ffeexpr_find_.after = after; 11515 ffeexpr_find_.level = 1; 11516 return (ffelexHandler) ffeexpr_nil_rhs_ (t); 11517} 11518 11519static ffelexHandler 11520ffeexpr_nil_finished_ (ffelexToken t) 11521{ 11522 switch (ffelex_token_type (t)) 11523 { 11524 case FFELEX_typeCLOSE_PAREN: 11525 if (--ffeexpr_find_.level == 0) 11526 return (ffelexHandler) ffeexpr_find_.after; 11527 return (ffelexHandler) ffeexpr_nil_binary_; 11528 11529 case FFELEX_typeCOMMA: 11530 case FFELEX_typeCOLON: 11531 case FFELEX_typeEQUALS: 11532 case FFELEX_typePOINTS: 11533 return (ffelexHandler) ffeexpr_nil_rhs_; 11534 11535 default: 11536 if (--ffeexpr_find_.level == 0) 11537 return (ffelexHandler) ffeexpr_find_.after (t); 11538 return (ffelexHandler) ffeexpr_nil_rhs_ (t); 11539 } 11540} 11541 11542static ffelexHandler 11543ffeexpr_nil_rhs_ (ffelexToken t) 11544{ 11545 switch (ffelex_token_type (t)) 11546 { 11547 case FFELEX_typeQUOTE: 11548 if (ffe_is_vxt ()) 11549 return (ffelexHandler) ffeexpr_nil_quote_; 11550 ffelex_set_expecting_hollerith (-1, '\"', 11551 ffelex_token_where_line (t), 11552 ffelex_token_where_column (t)); 11553 return (ffelexHandler) ffeexpr_nil_apostrophe_; 11554 11555 case FFELEX_typeAPOSTROPHE: 11556 ffelex_set_expecting_hollerith (-1, '\'', 11557 ffelex_token_where_line (t), 11558 ffelex_token_where_column (t)); 11559 return (ffelexHandler) ffeexpr_nil_apostrophe_; 11560 11561 case FFELEX_typePERCENT: 11562 return (ffelexHandler) ffeexpr_nil_percent_; 11563 11564 case FFELEX_typeOPEN_PAREN: 11565 ++ffeexpr_find_.level; 11566 return (ffelexHandler) ffeexpr_nil_rhs_; 11567 11568 case FFELEX_typePLUS: 11569 case FFELEX_typeMINUS: 11570 return (ffelexHandler) ffeexpr_nil_rhs_; 11571 11572 case FFELEX_typePERIOD: 11573 return (ffelexHandler) ffeexpr_nil_period_; 11574 11575 case FFELEX_typeNUMBER: 11576 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t)); 11577 if (ffeexpr_hollerith_count_ > 0) 11578 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_, 11579 '\0', 11580 ffelex_token_where_line (t), 11581 ffelex_token_where_column (t)); 11582 return (ffelexHandler) ffeexpr_nil_number_; 11583 11584 case FFELEX_typeNAME: 11585 case FFELEX_typeNAMES: 11586 return (ffelexHandler) ffeexpr_nil_name_rhs_; 11587 11588 case FFELEX_typeASTERISK: 11589 case FFELEX_typeSLASH: 11590 case FFELEX_typePOWER: 11591 case FFELEX_typeCONCAT: 11592 case FFELEX_typeREL_EQ: 11593 case FFELEX_typeREL_NE: 11594 case FFELEX_typeREL_LE: 11595 case FFELEX_typeREL_GE: 11596 return (ffelexHandler) ffeexpr_nil_rhs_; 11597 11598 default: 11599 return (ffelexHandler) ffeexpr_nil_finished_ (t); 11600 } 11601} 11602 11603static ffelexHandler 11604ffeexpr_nil_period_ (ffelexToken t) 11605{ 11606 switch (ffelex_token_type (t)) 11607 { 11608 case FFELEX_typeNAME: 11609 case FFELEX_typeNAMES: 11610 ffeexpr_current_dotdot_ = ffestr_other (t); 11611 switch (ffeexpr_current_dotdot_) 11612 { 11613 case FFESTR_otherNone: 11614 return (ffelexHandler) ffeexpr_nil_rhs_ (t); 11615 11616 case FFESTR_otherTRUE: 11617 case FFESTR_otherFALSE: 11618 case FFESTR_otherNOT: 11619 return (ffelexHandler) ffeexpr_nil_end_period_; 11620 11621 default: 11622 return (ffelexHandler) ffeexpr_nil_swallow_period_; 11623 } 11624 break; /* Nothing really reaches here. */ 11625 11626 case FFELEX_typeNUMBER: 11627 return (ffelexHandler) ffeexpr_nil_real_; 11628 11629 default: 11630 return (ffelexHandler) ffeexpr_nil_rhs_ (t); 11631 } 11632} 11633 11634static ffelexHandler 11635ffeexpr_nil_end_period_ (ffelexToken t) 11636{ 11637 switch (ffeexpr_current_dotdot_) 11638 { 11639 case FFESTR_otherNOT: 11640 if (ffelex_token_type (t) != FFELEX_typePERIOD) 11641 return (ffelexHandler) ffeexpr_nil_rhs_ (t); 11642 return (ffelexHandler) ffeexpr_nil_rhs_; 11643 11644 case FFESTR_otherTRUE: 11645 case FFESTR_otherFALSE: 11646 if (ffelex_token_type (t) != FFELEX_typePERIOD) 11647 return (ffelexHandler) ffeexpr_nil_binary_ (t); 11648 return (ffelexHandler) ffeexpr_nil_binary_; 11649 11650 default: 11651 assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL); 11652 exit (0); 11653 return NULL; 11654 } 11655} 11656 11657static ffelexHandler 11658ffeexpr_nil_swallow_period_ (ffelexToken t) 11659{ 11660 if (ffelex_token_type (t) != FFELEX_typePERIOD) 11661 return (ffelexHandler) ffeexpr_nil_rhs_ (t); 11662 return (ffelexHandler) ffeexpr_nil_rhs_; 11663} 11664 11665static ffelexHandler 11666ffeexpr_nil_real_ (ffelexToken t) 11667{ 11668 char d; 11669 const char *p; 11670 11671 if (((ffelex_token_type (t) != FFELEX_typeNAME) 11672 && (ffelex_token_type (t) != FFELEX_typeNAMES)) 11673 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), 11674 'D', 'd') 11675 || ffesrc_char_match_init (d, 'E', 'e') 11676 || ffesrc_char_match_init (d, 'Q', 'q'))) 11677 && ffeexpr_isdigits_ (++p))) 11678 return (ffelexHandler) ffeexpr_nil_binary_ (t); 11679 11680 if (*p == '\0') 11681 return (ffelexHandler) ffeexpr_nil_real_exponent_; 11682 return (ffelexHandler) ffeexpr_nil_binary_; 11683} 11684 11685static ffelexHandler 11686ffeexpr_nil_real_exponent_ (ffelexToken t) 11687{ 11688 if ((ffelex_token_type (t) != FFELEX_typePLUS) 11689 && (ffelex_token_type (t) != FFELEX_typeMINUS)) 11690 return (ffelexHandler) ffeexpr_nil_binary_ (t); 11691 11692 return (ffelexHandler) ffeexpr_nil_real_exp_sign_; 11693} 11694 11695static ffelexHandler 11696ffeexpr_nil_real_exp_sign_ (ffelexToken t) 11697{ 11698 if (ffelex_token_type (t) != FFELEX_typeNUMBER) 11699 return (ffelexHandler) ffeexpr_nil_binary_ (t); 11700 return (ffelexHandler) ffeexpr_nil_binary_; 11701} 11702 11703static ffelexHandler 11704ffeexpr_nil_number_ (ffelexToken t) 11705{ 11706 char d; 11707 const char *p; 11708 11709 if (ffeexpr_hollerith_count_ > 0) 11710 ffelex_set_expecting_hollerith (0, '\0', 11711 ffewhere_line_unknown (), 11712 ffewhere_column_unknown ()); 11713 11714 switch (ffelex_token_type (t)) 11715 { 11716 case FFELEX_typeNAME: 11717 case FFELEX_typeNAMES: 11718 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), 11719 'D', 'd') 11720 || ffesrc_char_match_init (d, 'E', 'e') 11721 || ffesrc_char_match_init (d, 'Q', 'q')) 11722 && ffeexpr_isdigits_ (++p)) 11723 { 11724 if (*p == '\0') 11725 { 11726 ffeexpr_find_.t = ffelex_token_use (t); 11727 return (ffelexHandler) ffeexpr_nil_number_exponent_; 11728 } 11729 return (ffelexHandler) ffeexpr_nil_binary_; 11730 } 11731 break; 11732 11733 case FFELEX_typePERIOD: 11734 ffeexpr_find_.t = ffelex_token_use (t); 11735 return (ffelexHandler) ffeexpr_nil_number_period_; 11736 11737 case FFELEX_typeHOLLERITH: 11738 return (ffelexHandler) ffeexpr_nil_binary_; 11739 11740 default: 11741 break; 11742 } 11743 return (ffelexHandler) ffeexpr_nil_binary_ (t); 11744} 11745 11746/* Expects ffeexpr_find_.t. */ 11747 11748static ffelexHandler 11749ffeexpr_nil_number_exponent_ (ffelexToken t) 11750{ 11751 ffelexHandler nexthandler; 11752 11753 if ((ffelex_token_type (t) != FFELEX_typePLUS) 11754 && (ffelex_token_type (t) != FFELEX_typeMINUS)) 11755 { 11756 nexthandler 11757 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t); 11758 ffelex_token_kill (ffeexpr_find_.t); 11759 return (ffelexHandler) (*nexthandler) (t); 11760 } 11761 11762 ffelex_token_kill (ffeexpr_find_.t); 11763 return (ffelexHandler) ffeexpr_nil_number_exp_sign_; 11764} 11765 11766static ffelexHandler 11767ffeexpr_nil_number_exp_sign_ (ffelexToken t) 11768{ 11769 if (ffelex_token_type (t) != FFELEX_typeNUMBER) 11770 return (ffelexHandler) ffeexpr_nil_binary_ (t); 11771 11772 return (ffelexHandler) ffeexpr_nil_binary_; 11773} 11774 11775/* Expects ffeexpr_find_.t. */ 11776 11777static ffelexHandler 11778ffeexpr_nil_number_period_ (ffelexToken t) 11779{ 11780 ffelexHandler nexthandler; 11781 char d; 11782 const char *p; 11783 11784 switch (ffelex_token_type (t)) 11785 { 11786 case FFELEX_typeNAME: 11787 case FFELEX_typeNAMES: 11788 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), 11789 'D', 'd') 11790 || ffesrc_char_match_init (d, 'E', 'e') 11791 || ffesrc_char_match_init (d, 'Q', 'q')) 11792 && ffeexpr_isdigits_ (++p)) 11793 { 11794 if (*p == '\0') 11795 return (ffelexHandler) ffeexpr_nil_number_per_exp_; 11796 ffelex_token_kill (ffeexpr_find_.t); 11797 return (ffelexHandler) ffeexpr_nil_binary_; 11798 } 11799 nexthandler 11800 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t); 11801 ffelex_token_kill (ffeexpr_find_.t); 11802 return (ffelexHandler) (*nexthandler) (t); 11803 11804 case FFELEX_typeNUMBER: 11805 ffelex_token_kill (ffeexpr_find_.t); 11806 return (ffelexHandler) ffeexpr_nil_number_real_; 11807 11808 default: 11809 break; 11810 } 11811 ffelex_token_kill (ffeexpr_find_.t); 11812 return (ffelexHandler) ffeexpr_nil_binary_ (t); 11813} 11814 11815/* Expects ffeexpr_find_.t. */ 11816 11817static ffelexHandler 11818ffeexpr_nil_number_per_exp_ (ffelexToken t) 11819{ 11820 if ((ffelex_token_type (t) != FFELEX_typePLUS) 11821 && (ffelex_token_type (t) != FFELEX_typeMINUS)) 11822 { 11823 ffelexHandler nexthandler; 11824 11825 nexthandler 11826 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t); 11827 ffelex_token_kill (ffeexpr_find_.t); 11828 return (ffelexHandler) (*nexthandler) (t); 11829 } 11830 11831 ffelex_token_kill (ffeexpr_find_.t); 11832 return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_; 11833} 11834 11835static ffelexHandler 11836ffeexpr_nil_number_real_ (ffelexToken t) 11837{ 11838 char d; 11839 const char *p; 11840 11841 if (((ffelex_token_type (t) != FFELEX_typeNAME) 11842 && (ffelex_token_type (t) != FFELEX_typeNAMES)) 11843 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), 11844 'D', 'd') 11845 || ffesrc_char_match_init (d, 'E', 'e') 11846 || ffesrc_char_match_init (d, 'Q', 'q'))) 11847 && ffeexpr_isdigits_ (++p))) 11848 return (ffelexHandler) ffeexpr_nil_binary_ (t); 11849 11850 if (*p == '\0') 11851 return (ffelexHandler) ffeexpr_nil_number_real_exp_; 11852 11853 return (ffelexHandler) ffeexpr_nil_binary_; 11854} 11855 11856static ffelexHandler 11857ffeexpr_nil_num_per_exp_sign_ (ffelexToken t) 11858{ 11859 if (ffelex_token_type (t) != FFELEX_typeNUMBER) 11860 return (ffelexHandler) ffeexpr_nil_binary_ (t); 11861 return (ffelexHandler) ffeexpr_nil_binary_; 11862} 11863 11864static ffelexHandler 11865ffeexpr_nil_number_real_exp_ (ffelexToken t) 11866{ 11867 if ((ffelex_token_type (t) != FFELEX_typePLUS) 11868 && (ffelex_token_type (t) != FFELEX_typeMINUS)) 11869 return (ffelexHandler) ffeexpr_nil_binary_ (t); 11870 return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_; 11871} 11872 11873static ffelexHandler 11874ffeexpr_nil_num_real_exp_sn_ (ffelexToken t) 11875{ 11876 if (ffelex_token_type (t) != FFELEX_typeNUMBER) 11877 return (ffelexHandler) ffeexpr_nil_binary_ (t); 11878 return (ffelexHandler) ffeexpr_nil_binary_; 11879} 11880 11881static ffelexHandler 11882ffeexpr_nil_binary_ (ffelexToken t) 11883{ 11884 switch (ffelex_token_type (t)) 11885 { 11886 case FFELEX_typePLUS: 11887 case FFELEX_typeMINUS: 11888 case FFELEX_typeASTERISK: 11889 case FFELEX_typeSLASH: 11890 case FFELEX_typePOWER: 11891 case FFELEX_typeCONCAT: 11892 case FFELEX_typeOPEN_ANGLE: 11893 case FFELEX_typeCLOSE_ANGLE: 11894 case FFELEX_typeREL_EQ: 11895 case FFELEX_typeREL_NE: 11896 case FFELEX_typeREL_GE: 11897 case FFELEX_typeREL_LE: 11898 return (ffelexHandler) ffeexpr_nil_rhs_; 11899 11900 case FFELEX_typePERIOD: 11901 return (ffelexHandler) ffeexpr_nil_binary_period_; 11902 11903 default: 11904 return (ffelexHandler) ffeexpr_nil_finished_ (t); 11905 } 11906} 11907 11908static ffelexHandler 11909ffeexpr_nil_binary_period_ (ffelexToken t) 11910{ 11911 switch (ffelex_token_type (t)) 11912 { 11913 case FFELEX_typeNAME: 11914 case FFELEX_typeNAMES: 11915 ffeexpr_current_dotdot_ = ffestr_other (t); 11916 switch (ffeexpr_current_dotdot_) 11917 { 11918 case FFESTR_otherTRUE: 11919 case FFESTR_otherFALSE: 11920 case FFESTR_otherNOT: 11921 return (ffelexHandler) ffeexpr_nil_binary_sw_per_; 11922 11923 default: 11924 return (ffelexHandler) ffeexpr_nil_binary_end_per_; 11925 } 11926 break; /* Nothing really reaches here. */ 11927 11928 default: 11929 return (ffelexHandler) ffeexpr_nil_binary_ (t); 11930 } 11931} 11932 11933static ffelexHandler 11934ffeexpr_nil_binary_end_per_ (ffelexToken t) 11935{ 11936 if (ffelex_token_type (t) != FFELEX_typePERIOD) 11937 return (ffelexHandler) ffeexpr_nil_rhs_ (t); 11938 return (ffelexHandler) ffeexpr_nil_rhs_; 11939} 11940 11941static ffelexHandler 11942ffeexpr_nil_binary_sw_per_ (ffelexToken t) 11943{ 11944 if (ffelex_token_type (t) != FFELEX_typePERIOD) 11945 return (ffelexHandler) ffeexpr_nil_binary_ (t); 11946 return (ffelexHandler) ffeexpr_nil_binary_; 11947} 11948 11949static ffelexHandler 11950ffeexpr_nil_quote_ (ffelexToken t) 11951{ 11952 if (ffelex_token_type (t) != FFELEX_typeNUMBER) 11953 return (ffelexHandler) ffeexpr_nil_rhs_ (t); 11954 return (ffelexHandler) ffeexpr_nil_binary_; 11955} 11956 11957static ffelexHandler 11958ffeexpr_nil_apostrophe_ (ffelexToken t) 11959{ 11960 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER); 11961 return (ffelexHandler) ffeexpr_nil_apos_char_; 11962} 11963 11964static ffelexHandler 11965ffeexpr_nil_apos_char_ (ffelexToken t) 11966{ 11967 char c; 11968 11969 if ((ffelex_token_type (t) == FFELEX_typeNAME) 11970 || (ffelex_token_type (t) == FFELEX_typeNAMES)) 11971 { 11972 if ((ffelex_token_length (t) == 1) 11973 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 11974 'B', 'b') 11975 || ffesrc_char_match_init (c, 'O', 'o') 11976 || ffesrc_char_match_init (c, 'X', 'x') 11977 || ffesrc_char_match_init (c, 'Z', 'z'))) 11978 return (ffelexHandler) ffeexpr_nil_binary_; 11979 } 11980 if ((ffelex_token_type (t) == FFELEX_typeNAME) 11981 || (ffelex_token_type (t) == FFELEX_typeNAMES)) 11982 return (ffelexHandler) ffeexpr_nil_rhs_ (t); 11983 return (ffelexHandler) ffeexpr_nil_substrp_ (t); 11984} 11985 11986static ffelexHandler 11987ffeexpr_nil_name_rhs_ (ffelexToken t) 11988{ 11989 switch (ffelex_token_type (t)) 11990 { 11991 case FFELEX_typeQUOTE: 11992 case FFELEX_typeAPOSTROPHE: 11993 ffelex_set_hexnum (TRUE); 11994 return (ffelexHandler) ffeexpr_nil_name_apos_; 11995 11996 case FFELEX_typeOPEN_PAREN: 11997 ++ffeexpr_find_.level; 11998 return (ffelexHandler) ffeexpr_nil_rhs_; 11999 12000 default: 12001 return (ffelexHandler) ffeexpr_nil_binary_ (t); 12002 } 12003} 12004 12005static ffelexHandler 12006ffeexpr_nil_name_apos_ (ffelexToken t) 12007{ 12008 if (ffelex_token_type (t) == FFELEX_typeNAME) 12009 return (ffelexHandler) ffeexpr_nil_name_apos_name_; 12010 return (ffelexHandler) ffeexpr_nil_binary_ (t); 12011} 12012 12013static ffelexHandler 12014ffeexpr_nil_name_apos_name_ (ffelexToken t) 12015{ 12016 switch (ffelex_token_type (t)) 12017 { 12018 case FFELEX_typeAPOSTROPHE: 12019 case FFELEX_typeQUOTE: 12020 return (ffelexHandler) ffeexpr_nil_finished_; 12021 12022 default: 12023 return (ffelexHandler) ffeexpr_nil_finished_ (t); 12024 } 12025} 12026 12027static ffelexHandler 12028ffeexpr_nil_percent_ (ffelexToken t) 12029{ 12030 switch (ffelex_token_type (t)) 12031 { 12032 case FFELEX_typeNAME: 12033 case FFELEX_typeNAMES: 12034 ffeexpr_stack_->percent = ffeexpr_percent_ (t); 12035 ffeexpr_find_.t = ffelex_token_use (t); 12036 return (ffelexHandler) ffeexpr_nil_percent_name_; 12037 12038 default: 12039 return (ffelexHandler) ffeexpr_nil_rhs_ (t); 12040 } 12041} 12042 12043/* Expects ffeexpr_find_.t. */ 12044 12045static ffelexHandler 12046ffeexpr_nil_percent_name_ (ffelexToken t) 12047{ 12048 ffelexHandler nexthandler; 12049 12050 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN) 12051 { 12052 nexthandler 12053 = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t); 12054 ffelex_token_kill (ffeexpr_find_.t); 12055 return (ffelexHandler) (*nexthandler) (t); 12056 } 12057 12058 ffelex_token_kill (ffeexpr_find_.t); 12059 ++ffeexpr_find_.level; 12060 return (ffelexHandler) ffeexpr_nil_rhs_; 12061} 12062 12063static ffelexHandler 12064ffeexpr_nil_substrp_ (ffelexToken t) 12065{ 12066 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN) 12067 return (ffelexHandler) ffeexpr_nil_binary_ (t); 12068 12069 ++ffeexpr_find_.level; 12070 return (ffelexHandler) ffeexpr_nil_rhs_; 12071} 12072 12073/* ffeexpr_finished_ -- Reduce expression stack to one expr, finish 12074 12075 ffelexToken t; 12076 return ffeexpr_finished_(t); 12077 12078 Reduces expression stack to one (or zero) elements by repeatedly reducing 12079 the top operator on the stack (or, if the top element on the stack is 12080 itself an operator, issuing an error message and discarding it). Calls 12081 finishing routine with the expression, returning the ffelexHandler it 12082 returns to the caller. */ 12083 12084static ffelexHandler 12085ffeexpr_finished_ (ffelexToken t) 12086{ 12087 ffeexprExpr_ operand; /* This is B in -B or A+B. */ 12088 ffebld expr; 12089 ffeexprCallback callback; 12090 ffeexprStack_ s; 12091 ffebldConstant constnode; /* For detecting magical number. */ 12092 ffelexToken ft; /* Temporary copy of first token in 12093 expression. */ 12094 ffelexHandler next; 12095 ffeinfo info; 12096 bool error = FALSE; 12097 12098 while (((operand = ffeexpr_stack_->exprstack) != NULL) 12099 && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_))) 12100 { 12101 if (operand->type == FFEEXPR_exprtypeOPERAND_) 12102 ffeexpr_reduce_ (); 12103 else 12104 { 12105 if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR)) 12106 { 12107 ffebad_here (0, ffelex_token_where_line (t), 12108 ffelex_token_where_column (t)); 12109 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token), 12110 ffelex_token_where_column (ffeexpr_stack_->exprstack->token)); 12111 ffebad_finish (); 12112 } 12113 ffeexpr_stack_->exprstack = operand->previous; /* Pop the useless 12114 operator. */ 12115 ffeexpr_expr_kill_ (operand); 12116 } 12117 } 12118 12119 assert ((operand == NULL) || (operand->previous == NULL)); 12120 12121 ffebld_pool_pop (); 12122 if (operand == NULL) 12123 expr = NULL; 12124 else 12125 { 12126 expr = operand->u.operand; 12127 info = ffebld_info (expr); 12128 if ((ffebld_op (expr) == FFEBLD_opCONTER) 12129 && (ffebld_conter_orig (expr) == NULL) 12130 && ffebld_constant_is_magical (constnode = ffebld_conter (expr))) 12131 { 12132 ffetarget_integer_bad_magical (operand->token); 12133 } 12134 ffeexpr_expr_kill_ (operand); 12135 ffeexpr_stack_->exprstack = NULL; 12136 } 12137 12138 ft = ffeexpr_stack_->first_token; 12139 12140again: /* :::::::::::::::::::: */ 12141 switch (ffeexpr_stack_->context) 12142 { 12143 case FFEEXPR_contextLET: 12144 case FFEEXPR_contextSFUNCDEF: 12145 error = (expr == NULL) 12146 || (ffeinfo_rank (info) != 0); 12147 break; 12148 12149 case FFEEXPR_contextPAREN_: 12150 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) 12151 break; 12152 switch (ffeinfo_basictype (info)) 12153 { 12154 case FFEINFO_basictypeHOLLERITH: 12155 case FFEINFO_basictypeTYPELESS: 12156 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12157 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 12158 FFEEXPR_contextLET); 12159 break; 12160 12161 default: 12162 break; 12163 } 12164 break; 12165 12166 case FFEEXPR_contextPARENFILENUM_: 12167 if (ffelex_token_type (t) != FFELEX_typeCOMMA) 12168 ffeexpr_stack_->context = FFEEXPR_contextPAREN_; 12169 else 12170 ffeexpr_stack_->context = FFEEXPR_contextFILENUM; 12171 goto again; /* :::::::::::::::::::: */ 12172 12173 case FFEEXPR_contextPARENFILEUNIT_: 12174 if (ffelex_token_type (t) != FFELEX_typeCOMMA) 12175 ffeexpr_stack_->context = FFEEXPR_contextPAREN_; 12176 else 12177 ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT; 12178 goto again; /* :::::::::::::::::::: */ 12179 12180 case FFEEXPR_contextACTUALARGEXPR_: 12181 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: 12182 switch ((expr == NULL) ? FFEINFO_basictypeNONE 12183 : ffeinfo_basictype (info)) 12184 { 12185 case FFEINFO_basictypeHOLLERITH: 12186 case FFEINFO_basictypeTYPELESS: 12187 if (!ffe_is_ugly_args () 12188 && ffebad_start (FFEBAD_ACTUALARG)) 12189 { 12190 ffebad_here (0, ffelex_token_where_line (ft), 12191 ffelex_token_where_column (ft)); 12192 ffebad_finish (); 12193 } 12194 break; 12195 12196 default: 12197 break; 12198 } 12199 error = (expr != NULL) && (ffeinfo_rank (info) != 0); 12200 break; 12201 12202 case FFEEXPR_contextACTUALARG_: 12203 case FFEEXPR_contextSFUNCDEFACTUALARG_: 12204 switch ((expr == NULL) ? FFEINFO_basictypeNONE 12205 : ffeinfo_basictype (info)) 12206 { 12207 case FFEINFO_basictypeHOLLERITH: 12208 case FFEINFO_basictypeTYPELESS: 12209#if 0 /* Should never get here. */ 12210 expr = ffeexpr_convert (expr, ft, ft, 12211 FFEINFO_basictypeINTEGER, 12212 FFEINFO_kindtypeINTEGERDEFAULT, 12213 0, 12214 FFETARGET_charactersizeNONE, 12215 FFEEXPR_contextLET); 12216#else 12217 assert ("why hollerith/typeless in actualarg_?" == NULL); 12218#endif 12219 break; 12220 12221 default: 12222 break; 12223 } 12224 switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr)) 12225 { 12226 case FFEBLD_opSYMTER: 12227 case FFEBLD_opPERCENT_LOC: 12228 case FFEBLD_opPERCENT_VAL: 12229 case FFEBLD_opPERCENT_REF: 12230 case FFEBLD_opPERCENT_DESCR: 12231 error = FALSE; 12232 break; 12233 12234 default: 12235 error = (expr != NULL) && (ffeinfo_rank (info) != 0); 12236 break; 12237 } 12238 { 12239 ffesymbol s; 12240 ffeinfoWhere where; 12241 ffeinfoKind kind; 12242 12243 if (!error 12244 && (expr != NULL) 12245 && (ffebld_op (expr) == FFEBLD_opSYMTER) 12246 && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)), 12247 (where == FFEINFO_whereINTRINSIC) 12248 || (where == FFEINFO_whereGLOBAL) 12249 || ((where == FFEINFO_whereDUMMY) 12250 && ((kind = ffesymbol_kind (s)), 12251 (kind == FFEINFO_kindFUNCTION) 12252 || (kind == FFEINFO_kindSUBROUTINE)))) 12253 && !ffesymbol_explicitwhere (s)) 12254 { 12255 ffebad_start (where == FFEINFO_whereINTRINSIC 12256 ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL); 12257 ffebad_here (0, ffelex_token_where_line (ft), 12258 ffelex_token_where_column (ft)); 12259 ffebad_string (ffesymbol_text (s)); 12260 ffebad_finish (); 12261 ffesymbol_signal_change (s); 12262 ffesymbol_set_explicitwhere (s, TRUE); 12263 ffesymbol_signal_unreported (s); 12264 } 12265 } 12266 break; 12267 12268 case FFEEXPR_contextINDEX_: 12269 case FFEEXPR_contextSFUNCDEFINDEX_: 12270 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) 12271 break; 12272 switch ((expr == NULL) ? FFEINFO_basictypeNONE 12273 : ffeinfo_basictype (info)) 12274 { 12275 case FFEINFO_basictypeNONE: 12276 error = FALSE; 12277 break; 12278 12279 case FFEINFO_basictypeLOGICAL: 12280 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, 12281 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, 12282 FFEEXPR_contextLET); 12283 /* Fall through. */ 12284 case FFEINFO_basictypeREAL: 12285 case FFEINFO_basictypeCOMPLEX: 12286 if (ffe_is_pedantic ()) 12287 { 12288 error = TRUE; 12289 break; 12290 } 12291 /* Fall through. */ 12292 case FFEINFO_basictypeHOLLERITH: 12293 case FFEINFO_basictypeTYPELESS: 12294 error = FALSE; 12295 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12296 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 12297 FFEEXPR_contextLET); 12298 break; 12299 12300 case FFEINFO_basictypeINTEGER: 12301 /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through 12302 unmolested. Leave it to downstream to handle kinds. */ 12303 break; 12304 12305 default: 12306 error = TRUE; 12307 break; 12308 } 12309 break; /* expr==NULL ok for substring; element case 12310 caught by callback. */ 12311 12312 case FFEEXPR_contextRETURN: 12313 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) 12314 break; 12315 switch ((expr == NULL) ? FFEINFO_basictypeNONE 12316 : ffeinfo_basictype (info)) 12317 { 12318 case FFEINFO_basictypeNONE: 12319 error = FALSE; 12320 break; 12321 12322 case FFEINFO_basictypeLOGICAL: 12323 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, 12324 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, 12325 FFEEXPR_contextLET); 12326 /* Fall through. */ 12327 case FFEINFO_basictypeREAL: 12328 case FFEINFO_basictypeCOMPLEX: 12329 if (ffe_is_pedantic ()) 12330 { 12331 error = TRUE; 12332 break; 12333 } 12334 /* Fall through. */ 12335 case FFEINFO_basictypeINTEGER: 12336 case FFEINFO_basictypeHOLLERITH: 12337 case FFEINFO_basictypeTYPELESS: 12338 error = FALSE; 12339 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12340 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 12341 FFEEXPR_contextLET); 12342 break; 12343 12344 default: 12345 error = TRUE; 12346 break; 12347 } 12348 break; 12349 12350 case FFEEXPR_contextDO: 12351 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) 12352 break; 12353 switch (ffeinfo_basictype (info)) 12354 { 12355 case FFEINFO_basictypeLOGICAL: 12356 error = !ffe_is_ugly_logint (); 12357 if (!ffeexpr_stack_->is_rhs) 12358 break; /* Don't convert lhs variable. */ 12359 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12360 ffeinfo_kindtype (ffebld_info (expr)), 0, 12361 FFETARGET_charactersizeNONE, 12362 FFEEXPR_contextLET); 12363 break; 12364 12365 case FFEINFO_basictypeHOLLERITH: 12366 case FFEINFO_basictypeTYPELESS: 12367 if (!ffeexpr_stack_->is_rhs) 12368 { 12369 error = TRUE; 12370 break; /* Don't convert lhs variable. */ 12371 } 12372 break; 12373 12374 case FFEINFO_basictypeINTEGER: 12375 case FFEINFO_basictypeREAL: 12376 break; 12377 12378 default: 12379 error = TRUE; 12380 break; 12381 } 12382 if (!ffeexpr_stack_->is_rhs 12383 && (ffebld_op (expr) != FFEBLD_opSYMTER)) 12384 error = TRUE; 12385 break; 12386 12387 case FFEEXPR_contextDOWHILE: 12388 case FFEEXPR_contextIF: 12389 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) 12390 break; 12391 switch (ffeinfo_basictype (info)) 12392 { 12393 case FFEINFO_basictypeINTEGER: 12394 error = FALSE; 12395 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12396 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 12397 FFEEXPR_contextLET); 12398 /* Fall through. */ 12399 case FFEINFO_basictypeLOGICAL: 12400 case FFEINFO_basictypeHOLLERITH: 12401 case FFEINFO_basictypeTYPELESS: 12402 error = FALSE; 12403 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, 12404 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, 12405 FFEEXPR_contextLET); 12406 break; 12407 12408 default: 12409 error = TRUE; 12410 break; 12411 } 12412 break; 12413 12414 case FFEEXPR_contextASSIGN: 12415 case FFEEXPR_contextAGOTO: 12416 switch ((expr == NULL) ? FFEINFO_basictypeNONE 12417 : ffeinfo_basictype (info)) 12418 { 12419 case FFEINFO_basictypeINTEGER: 12420 error = (ffeinfo_kindtype (info) != ffecom_label_kind ()); 12421 break; 12422 12423 case FFEINFO_basictypeLOGICAL: 12424 error = !ffe_is_ugly_logint () 12425 || (ffeinfo_kindtype (info) != ffecom_label_kind ()); 12426 break; 12427 12428 default: 12429 error = TRUE; 12430 break; 12431 } 12432 if ((expr == NULL) || (ffeinfo_rank (info) != 0) 12433 || (ffebld_op (expr) != FFEBLD_opSYMTER)) 12434 error = TRUE; 12435 break; 12436 12437 case FFEEXPR_contextCGOTO: 12438 case FFEEXPR_contextFORMAT: 12439 case FFEEXPR_contextDIMLIST: 12440 case FFEEXPR_contextFILENUM: /* See equiv code in _ambig_. */ 12441 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) 12442 break; 12443 switch (ffeinfo_basictype (info)) 12444 { 12445 case FFEINFO_basictypeLOGICAL: 12446 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, 12447 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, 12448 FFEEXPR_contextLET); 12449 /* Fall through. */ 12450 case FFEINFO_basictypeREAL: 12451 case FFEINFO_basictypeCOMPLEX: 12452 if (ffe_is_pedantic ()) 12453 { 12454 error = TRUE; 12455 break; 12456 } 12457 /* Fall through. */ 12458 case FFEINFO_basictypeINTEGER: 12459 case FFEINFO_basictypeHOLLERITH: 12460 case FFEINFO_basictypeTYPELESS: 12461 error = FALSE; 12462 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12463 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 12464 FFEEXPR_contextLET); 12465 break; 12466 12467 default: 12468 error = TRUE; 12469 break; 12470 } 12471 break; 12472 12473 case FFEEXPR_contextARITHIF: 12474 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) 12475 break; 12476 switch (ffeinfo_basictype (info)) 12477 { 12478 case FFEINFO_basictypeLOGICAL: 12479 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, 12480 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, 12481 FFEEXPR_contextLET); 12482 if (ffe_is_pedantic ()) 12483 { 12484 error = TRUE; 12485 break; 12486 } 12487 /* Fall through. */ 12488 case FFEINFO_basictypeHOLLERITH: 12489 case FFEINFO_basictypeTYPELESS: 12490 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12491 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 12492 FFEEXPR_contextLET); 12493 /* Fall through. */ 12494 case FFEINFO_basictypeINTEGER: 12495 case FFEINFO_basictypeREAL: 12496 error = FALSE; 12497 break; 12498 12499 default: 12500 error = TRUE; 12501 break; 12502 } 12503 break; 12504 12505 case FFEEXPR_contextSTOP: 12506 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) 12507 break; 12508 switch ((expr == NULL) ? FFEINFO_basictypeNONE 12509 : ffeinfo_basictype (info)) 12510 { 12511 case FFEINFO_basictypeINTEGER: 12512 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT); 12513 break; 12514 12515 case FFEINFO_basictypeCHARACTER: 12516 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT); 12517 break; 12518 12519 case FFEINFO_basictypeHOLLERITH: 12520 case FFEINFO_basictypeTYPELESS: 12521 error = FALSE; 12522 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12523 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 12524 FFEEXPR_contextLET); 12525 break; 12526 12527 case FFEINFO_basictypeNONE: 12528 error = FALSE; 12529 break; 12530 12531 default: 12532 error = TRUE; 12533 break; 12534 } 12535 if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER) 12536 || (ffebld_conter_orig (expr) != NULL))) 12537 error = TRUE; 12538 break; 12539 12540 case FFEEXPR_contextINCLUDE: 12541 error = (expr == NULL) || (ffeinfo_rank (info) != 0) 12542 || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER) 12543 || (ffebld_op (expr) != FFEBLD_opCONTER) 12544 || (ffebld_conter_orig (expr) != NULL); 12545 break; 12546 12547 case FFEEXPR_contextSELECTCASE: 12548 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) 12549 break; 12550 switch (ffeinfo_basictype (info)) 12551 { 12552 case FFEINFO_basictypeINTEGER: 12553 case FFEINFO_basictypeCHARACTER: 12554 case FFEINFO_basictypeLOGICAL: 12555 error = FALSE; 12556 break; 12557 12558 case FFEINFO_basictypeHOLLERITH: 12559 case FFEINFO_basictypeTYPELESS: 12560 error = FALSE; 12561 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12562 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 12563 FFEEXPR_contextLET); 12564 break; 12565 12566 default: 12567 error = TRUE; 12568 break; 12569 } 12570 break; 12571 12572 case FFEEXPR_contextCASE: 12573 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) 12574 break; 12575 switch ((expr == NULL) ? FFEINFO_basictypeINTEGER 12576 : ffeinfo_basictype (info)) 12577 { 12578 case FFEINFO_basictypeINTEGER: 12579 case FFEINFO_basictypeCHARACTER: 12580 case FFEINFO_basictypeLOGICAL: 12581 error = FALSE; 12582 break; 12583 12584 case FFEINFO_basictypeHOLLERITH: 12585 case FFEINFO_basictypeTYPELESS: 12586 error = FALSE; 12587 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12588 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 12589 FFEEXPR_contextLET); 12590 break; 12591 12592 default: 12593 error = TRUE; 12594 break; 12595 } 12596 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER)) 12597 error = TRUE; 12598 break; 12599 12600 case FFEEXPR_contextCHARACTERSIZE: 12601 case FFEEXPR_contextKINDTYPE: 12602 case FFEEXPR_contextDIMLISTCOMMON: 12603 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) 12604 break; 12605 switch ((expr == NULL) ? FFEINFO_basictypeNONE 12606 : ffeinfo_basictype (info)) 12607 { 12608 case FFEINFO_basictypeLOGICAL: 12609 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, 12610 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, 12611 FFEEXPR_contextLET); 12612 /* Fall through. */ 12613 case FFEINFO_basictypeREAL: 12614 case FFEINFO_basictypeCOMPLEX: 12615 if (ffe_is_pedantic ()) 12616 { 12617 error = TRUE; 12618 break; 12619 } 12620 /* Fall through. */ 12621 case FFEINFO_basictypeINTEGER: 12622 case FFEINFO_basictypeHOLLERITH: 12623 case FFEINFO_basictypeTYPELESS: 12624 error = FALSE; 12625 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12626 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 12627 FFEEXPR_contextLET); 12628 break; 12629 12630 default: 12631 error = TRUE; 12632 break; 12633 } 12634 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER)) 12635 error = TRUE; 12636 break; 12637 12638 case FFEEXPR_contextEQVINDEX_: 12639 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) 12640 break; 12641 switch ((expr == NULL) ? FFEINFO_basictypeNONE 12642 : ffeinfo_basictype (info)) 12643 { 12644 case FFEINFO_basictypeNONE: 12645 error = FALSE; 12646 break; 12647 12648 case FFEINFO_basictypeLOGICAL: 12649 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, 12650 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, 12651 FFEEXPR_contextLET); 12652 /* Fall through. */ 12653 case FFEINFO_basictypeREAL: 12654 case FFEINFO_basictypeCOMPLEX: 12655 if (ffe_is_pedantic ()) 12656 { 12657 error = TRUE; 12658 break; 12659 } 12660 /* Fall through. */ 12661 case FFEINFO_basictypeINTEGER: 12662 case FFEINFO_basictypeHOLLERITH: 12663 case FFEINFO_basictypeTYPELESS: 12664 error = FALSE; 12665 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12666 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 12667 FFEEXPR_contextLET); 12668 break; 12669 12670 default: 12671 error = TRUE; 12672 break; 12673 } 12674 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER)) 12675 error = TRUE; 12676 break; 12677 12678 case FFEEXPR_contextPARAMETER: 12679 if (ffeexpr_stack_->is_rhs) 12680 error = (expr == NULL) || (ffeinfo_rank (info) != 0) 12681 || (ffebld_op (expr) != FFEBLD_opCONTER); 12682 else 12683 error = (expr == NULL) || (ffeinfo_rank (info) != 0) 12684 || (ffebld_op (expr) != FFEBLD_opSYMTER); 12685 break; 12686 12687 case FFEEXPR_contextINDEXORACTUALARG_: 12688 if (ffelex_token_type (t) == FFELEX_typeCOLON) 12689 ffeexpr_stack_->context = FFEEXPR_contextINDEX_; 12690 else 12691 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_; 12692 goto again; /* :::::::::::::::::::: */ 12693 12694 case FFEEXPR_contextINDEXORACTUALARGEXPR_: 12695 if (ffelex_token_type (t) == FFELEX_typeCOLON) 12696 ffeexpr_stack_->context = FFEEXPR_contextINDEX_; 12697 else 12698 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; 12699 goto again; /* :::::::::::::::::::: */ 12700 12701 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 12702 if (ffelex_token_type (t) == FFELEX_typeCOLON) 12703 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_; 12704 else 12705 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_; 12706 goto again; /* :::::::::::::::::::: */ 12707 12708 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: 12709 if (ffelex_token_type (t) == FFELEX_typeCOLON) 12710 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_; 12711 else 12712 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; 12713 goto again; /* :::::::::::::::::::: */ 12714 12715 case FFEEXPR_contextIMPDOCTRL_: 12716 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) 12717 break; 12718 if (!ffeexpr_stack_->is_rhs 12719 && (ffebld_op (expr) != FFEBLD_opSYMTER)) 12720 error = TRUE; 12721 switch (ffeinfo_basictype (info)) 12722 { 12723 case FFEINFO_basictypeLOGICAL: 12724 if (! ffe_is_ugly_logint ()) 12725 error = TRUE; 12726 if (! ffeexpr_stack_->is_rhs) 12727 break; 12728 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12729 ffeinfo_kindtype (info), 0, 12730 FFETARGET_charactersizeNONE, 12731 FFEEXPR_contextLET); 12732 break; 12733 12734 case FFEINFO_basictypeINTEGER: 12735 case FFEINFO_basictypeHOLLERITH: 12736 case FFEINFO_basictypeTYPELESS: 12737 break; 12738 12739 case FFEINFO_basictypeREAL: 12740 if (!ffeexpr_stack_->is_rhs 12741 && ffe_is_warn_surprising () 12742 && !error) 12743 { 12744 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */ 12745 ffebad_here (0, ffelex_token_where_line (ft), 12746 ffelex_token_where_column (ft)); 12747 ffebad_string (ffelex_token_text (ft)); 12748 ffebad_finish (); 12749 } 12750 break; 12751 12752 default: 12753 error = TRUE; 12754 break; 12755 } 12756 break; 12757 12758 case FFEEXPR_contextDATAIMPDOCTRL_: 12759 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) 12760 break; 12761 if (ffeexpr_stack_->is_rhs) 12762 { 12763 if ((ffebld_op (expr) != FFEBLD_opCONTER) 12764 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE)) 12765 error = TRUE; 12766 } 12767 else if ((ffebld_op (expr) != FFEBLD_opSYMTER) 12768 || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE)) 12769 error = TRUE; 12770 switch (ffeinfo_basictype (info)) 12771 { 12772 case FFEINFO_basictypeLOGICAL: 12773 if (! ffeexpr_stack_->is_rhs) 12774 break; 12775 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12776 ffeinfo_kindtype (info), 0, 12777 FFETARGET_charactersizeNONE, 12778 FFEEXPR_contextLET); 12779 /* Fall through. */ 12780 case FFEINFO_basictypeINTEGER: 12781 if (ffeexpr_stack_->is_rhs 12782 && (ffeinfo_kindtype (ffebld_info (expr)) 12783 != FFEINFO_kindtypeINTEGERDEFAULT)) 12784 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12785 FFEINFO_kindtypeINTEGERDEFAULT, 0, 12786 FFETARGET_charactersizeNONE, 12787 FFEEXPR_contextLET); 12788 break; 12789 12790 case FFEINFO_basictypeHOLLERITH: 12791 case FFEINFO_basictypeTYPELESS: 12792 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12793 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 12794 FFEEXPR_contextLET); 12795 break; 12796 12797 case FFEINFO_basictypeREAL: 12798 if (!ffeexpr_stack_->is_rhs 12799 && ffe_is_warn_surprising () 12800 && !error) 12801 { 12802 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */ 12803 ffebad_here (0, ffelex_token_where_line (ft), 12804 ffelex_token_where_column (ft)); 12805 ffebad_string (ffelex_token_text (ft)); 12806 ffebad_finish (); 12807 } 12808 break; 12809 12810 default: 12811 error = TRUE; 12812 break; 12813 } 12814 break; 12815 12816 case FFEEXPR_contextIMPDOITEM_: 12817 if (ffelex_token_type (t) == FFELEX_typeEQUALS) 12818 { 12819 ffeexpr_stack_->is_rhs = FALSE; 12820 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_; 12821 goto again; /* :::::::::::::::::::: */ 12822 } 12823 /* Fall through. */ 12824 case FFEEXPR_contextIOLIST: 12825 case FFEEXPR_contextFILEVXTCODE: 12826 switch ((expr == NULL) ? FFEINFO_basictypeNONE 12827 : ffeinfo_basictype (info)) 12828 { 12829 case FFEINFO_basictypeHOLLERITH: 12830 case FFEINFO_basictypeTYPELESS: 12831 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12832 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 12833 FFEEXPR_contextLET); 12834 break; 12835 12836 default: 12837 break; 12838 } 12839 error = (expr == NULL) 12840 || ((ffeinfo_rank (info) != 0) 12841 && ((ffebld_op (expr) != FFEBLD_opSYMTER) 12842 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL) 12843 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr))) 12844 == FFEBLD_opSTAR))); /* Bad if null expr, or if 12845 array that is not a SYMTER 12846 (can't happen yet, I 12847 think) or has a NULL or 12848 STAR (assumed) array 12849 size. */ 12850 break; 12851 12852 case FFEEXPR_contextIMPDOITEMDF_: 12853 if (ffelex_token_type (t) == FFELEX_typeEQUALS) 12854 { 12855 ffeexpr_stack_->is_rhs = FALSE; 12856 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_; 12857 goto again; /* :::::::::::::::::::: */ 12858 } 12859 /* Fall through. */ 12860 case FFEEXPR_contextIOLISTDF: 12861 switch ((expr == NULL) ? FFEINFO_basictypeNONE 12862 : ffeinfo_basictype (info)) 12863 { 12864 case FFEINFO_basictypeHOLLERITH: 12865 case FFEINFO_basictypeTYPELESS: 12866 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12867 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 12868 FFEEXPR_contextLET); 12869 break; 12870 12871 default: 12872 break; 12873 } 12874 error 12875 = (expr == NULL) 12876 || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER) 12877 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)) 12878 || ((ffeinfo_rank (info) != 0) 12879 && ((ffebld_op (expr) != FFEBLD_opSYMTER) 12880 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL) 12881 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr))) 12882 == FFEBLD_opSTAR))); /* Bad if null expr, 12883 non-default-kindtype 12884 character expr, or if 12885 array that is not a SYMTER 12886 (can't happen yet, I 12887 think) or has a NULL or 12888 STAR (assumed) array 12889 size. */ 12890 break; 12891 12892 case FFEEXPR_contextDATAIMPDOITEM_: 12893 error = (expr == NULL) 12894 || (ffebld_op (expr) != FFEBLD_opARRAYREF) 12895 || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR) 12896 && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR)); 12897 break; 12898 12899 case FFEEXPR_contextDATAIMPDOINDEX_: 12900 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) 12901 break; 12902 switch (ffeinfo_basictype (info)) 12903 { 12904 case FFEINFO_basictypeLOGICAL: 12905 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, 12906 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, 12907 FFEEXPR_contextLET); 12908 /* Fall through. */ 12909 case FFEINFO_basictypeREAL: 12910 case FFEINFO_basictypeCOMPLEX: 12911 if (ffe_is_pedantic ()) 12912 { 12913 error = TRUE; 12914 break; 12915 } 12916 /* Fall through. */ 12917 case FFEINFO_basictypeINTEGER: 12918 case FFEINFO_basictypeHOLLERITH: 12919 case FFEINFO_basictypeTYPELESS: 12920 error = FALSE; 12921 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 12922 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 12923 FFEEXPR_contextLET); 12924 break; 12925 12926 default: 12927 error = TRUE; 12928 break; 12929 } 12930 if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT) 12931 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE)) 12932 error = TRUE; 12933 break; 12934 12935 case FFEEXPR_contextDATA: 12936 if (expr == NULL) 12937 error = TRUE; 12938 else if (ffeexpr_stack_->is_rhs) 12939 error = (ffebld_op (expr) != FFEBLD_opCONTER); 12940 else if (ffebld_op (expr) == FFEBLD_opSYMTER) 12941 error = FALSE; 12942 else 12943 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR); 12944 break; 12945 12946 case FFEEXPR_contextINITVAL: 12947 error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER); 12948 break; 12949 12950 case FFEEXPR_contextEQUIVALENCE: 12951 if (expr == NULL) 12952 error = TRUE; 12953 else if (ffebld_op (expr) == FFEBLD_opSYMTER) 12954 error = FALSE; 12955 else 12956 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR); 12957 break; 12958 12959 case FFEEXPR_contextFILEASSOC: 12960 case FFEEXPR_contextFILEINT: 12961 switch ((expr == NULL) ? FFEINFO_basictypeNONE 12962 : ffeinfo_basictype (info)) 12963 { 12964 case FFEINFO_basictypeINTEGER: 12965 /* Maybe this should be supported someday, but, right now, 12966 g77 can't generate a call to libf2c to write to an 12967 integer other than the default size. */ 12968 error = ((! ffeexpr_stack_->is_rhs) 12969 && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT); 12970 break; 12971 12972 default: 12973 error = TRUE; 12974 break; 12975 } 12976 if ((expr == NULL) || (ffeinfo_rank (info) != 0)) 12977 error = TRUE; 12978 break; 12979 12980 case FFEEXPR_contextFILEDFINT: 12981 switch ((expr == NULL) ? FFEINFO_basictypeNONE 12982 : ffeinfo_basictype (info)) 12983 { 12984 case FFEINFO_basictypeINTEGER: 12985 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT); 12986 break; 12987 12988 default: 12989 error = TRUE; 12990 break; 12991 } 12992 if ((expr == NULL) || (ffeinfo_rank (info) != 0)) 12993 error = TRUE; 12994 break; 12995 12996 case FFEEXPR_contextFILELOG: 12997 switch ((expr == NULL) ? FFEINFO_basictypeNONE 12998 : ffeinfo_basictype (info)) 12999 { 13000 case FFEINFO_basictypeLOGICAL: 13001 error = FALSE; 13002 break; 13003 13004 default: 13005 error = TRUE; 13006 break; 13007 } 13008 if ((expr == NULL) || (ffeinfo_rank (info) != 0)) 13009 error = TRUE; 13010 break; 13011 13012 case FFEEXPR_contextFILECHAR: 13013 switch ((expr == NULL) ? FFEINFO_basictypeNONE 13014 : ffeinfo_basictype (info)) 13015 { 13016 case FFEINFO_basictypeCHARACTER: 13017 error = FALSE; 13018 break; 13019 13020 default: 13021 error = TRUE; 13022 break; 13023 } 13024 if ((expr == NULL) || (ffeinfo_rank (info) != 0)) 13025 error = TRUE; 13026 break; 13027 13028 case FFEEXPR_contextFILENUMCHAR: 13029 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) 13030 break; 13031 switch (ffeinfo_basictype (info)) 13032 { 13033 case FFEINFO_basictypeLOGICAL: 13034 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, 13035 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, 13036 FFEEXPR_contextLET); 13037 /* Fall through. */ 13038 case FFEINFO_basictypeREAL: 13039 case FFEINFO_basictypeCOMPLEX: 13040 if (ffe_is_pedantic ()) 13041 { 13042 error = TRUE; 13043 break; 13044 } 13045 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 13046 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 13047 FFEEXPR_contextLET); 13048 break; 13049 13050 case FFEINFO_basictypeINTEGER: 13051 case FFEINFO_basictypeCHARACTER: 13052 error = FALSE; 13053 break; 13054 13055 default: 13056 error = TRUE; 13057 break; 13058 } 13059 break; 13060 13061 case FFEEXPR_contextFILEDFCHAR: 13062 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) 13063 break; 13064 switch (ffeinfo_basictype (info)) 13065 { 13066 case FFEINFO_basictypeCHARACTER: 13067 error 13068 = (ffeinfo_kindtype (info) 13069 != FFEINFO_kindtypeCHARACTERDEFAULT); 13070 break; 13071 13072 default: 13073 error = TRUE; 13074 break; 13075 } 13076 if (!ffeexpr_stack_->is_rhs 13077 && (ffebld_op (expr) == FFEBLD_opSUBSTR)) 13078 error = TRUE; 13079 break; 13080 13081 case FFEEXPR_contextFILEUNIT: /* See equiv code in _ambig_. */ 13082 switch ((expr == NULL) ? FFEINFO_basictypeNONE 13083 : ffeinfo_basictype (info)) 13084 { 13085 case FFEINFO_basictypeLOGICAL: 13086 if ((error = (ffeinfo_rank (info) != 0))) 13087 break; 13088 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, 13089 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, 13090 FFEEXPR_contextLET); 13091 /* Fall through. */ 13092 case FFEINFO_basictypeREAL: 13093 case FFEINFO_basictypeCOMPLEX: 13094 if ((error = (ffeinfo_rank (info) != 0))) 13095 break; 13096 if (ffe_is_pedantic ()) 13097 { 13098 error = TRUE; 13099 break; 13100 } 13101 /* Fall through. */ 13102 case FFEINFO_basictypeINTEGER: 13103 case FFEINFO_basictypeHOLLERITH: 13104 case FFEINFO_basictypeTYPELESS: 13105 if ((error = (ffeinfo_rank (info) != 0))) 13106 break; 13107 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 13108 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 13109 FFEEXPR_contextLET); 13110 break; 13111 13112 case FFEINFO_basictypeCHARACTER: 13113 switch (ffebld_op (expr)) 13114 { /* As if _lhs had been called instead of 13115 _rhs. */ 13116 case FFEBLD_opSYMTER: 13117 error 13118 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT); 13119 break; 13120 13121 case FFEBLD_opSUBSTR: 13122 error = (ffeinfo_where (ffebld_info (expr)) 13123 == FFEINFO_whereCONSTANT_SUBOBJECT); 13124 break; 13125 13126 case FFEBLD_opARRAYREF: 13127 error = FALSE; 13128 break; 13129 13130 default: 13131 error = TRUE; 13132 break; 13133 } 13134 if (!error 13135 && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT) 13136 || ((ffeinfo_rank (info) != 0) 13137 && ((ffebld_op (expr) != FFEBLD_opSYMTER) 13138 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL) 13139 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr))) 13140 == FFEBLD_opSTAR))))) /* Bad if 13141 non-default-kindtype 13142 character expr, or if 13143 array that is not a SYMTER 13144 (can't happen yet, I 13145 think), or has a NULL or 13146 STAR (assumed) array 13147 size. */ 13148 error = TRUE; 13149 break; 13150 13151 default: 13152 error = TRUE; 13153 break; 13154 } 13155 break; 13156 13157 case FFEEXPR_contextFILEFORMAT: 13158 switch ((expr == NULL) ? FFEINFO_basictypeNONE 13159 : ffeinfo_basictype (info)) 13160 { 13161 case FFEINFO_basictypeINTEGER: 13162 error = (expr == NULL) 13163 || ((ffeinfo_rank (info) != 0) ? 13164 ffe_is_pedantic () /* F77 C5. */ 13165 : (ffeinfo_kindtype (info) != ffecom_label_kind ())) 13166 || (ffebld_op (expr) != FFEBLD_opSYMTER); 13167 break; 13168 13169 case FFEINFO_basictypeLOGICAL: 13170 case FFEINFO_basictypeREAL: 13171 case FFEINFO_basictypeCOMPLEX: 13172 /* F77 C5 -- must be an array of hollerith. */ 13173 error 13174 = ffe_is_pedantic () 13175 || (ffeinfo_rank (info) == 0); 13176 break; 13177 13178 case FFEINFO_basictypeCHARACTER: 13179 if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT) 13180 || ((ffeinfo_rank (info) != 0) 13181 && ((ffebld_op (expr) != FFEBLD_opSYMTER) 13182 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL) 13183 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr))) 13184 == FFEBLD_opSTAR)))) /* Bad if 13185 non-default-kindtype 13186 character expr, or if 13187 array that is not a SYMTER 13188 (can't happen yet, I 13189 think), or has a NULL or 13190 STAR (assumed) array 13191 size. */ 13192 error = TRUE; 13193 else 13194 error = FALSE; 13195 break; 13196 13197 default: 13198 error = TRUE; 13199 break; 13200 } 13201 break; 13202 13203 case FFEEXPR_contextLOC_: 13204 /* See also ffeintrin_check_loc_. */ 13205 if ((expr == NULL) 13206 || (ffeinfo_kind (info) != FFEINFO_kindENTITY) 13207 || ((ffebld_op (expr) != FFEBLD_opSYMTER) 13208 && (ffebld_op (expr) != FFEBLD_opSUBSTR) 13209 && (ffebld_op (expr) != FFEBLD_opARRAYREF))) 13210 error = TRUE; 13211 break; 13212 13213 default: 13214 error = FALSE; 13215 break; 13216 } 13217 13218 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY))) 13219 { 13220 ffebad_start (FFEBAD_EXPR_WRONG); 13221 ffebad_here (0, ffelex_token_where_line (ft), 13222 ffelex_token_where_column (ft)); 13223 ffebad_finish (); 13224 expr = ffebld_new_any (); 13225 ffebld_set_info (expr, ffeinfo_new_any ()); 13226 } 13227 13228 callback = ffeexpr_stack_->callback; 13229 s = ffeexpr_stack_->previous; 13230 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, 13231 sizeof (*ffeexpr_stack_)); 13232 ffeexpr_stack_ = s; 13233 next = (ffelexHandler) (*callback) (ft, expr, t); 13234 ffelex_token_kill (ft); 13235 return (ffelexHandler) next; 13236} 13237 13238/* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec 13239 13240 ffebld expr; 13241 expr = ffeexpr_finished_ambig_(expr); 13242 13243 Replicates a bit of ffeexpr_finished_'s task when in a context 13244 of UNIT or FORMAT. */ 13245 13246static ffebld 13247ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr) 13248{ 13249 ffeinfo info = ffebld_info (expr); 13250 bool error; 13251 13252 switch (ffeexpr_stack_->context) 13253 { 13254 case FFEEXPR_contextFILENUMAMBIG: /* Same as FILENUM in _finished_. */ 13255 switch ((expr == NULL) ? FFEINFO_basictypeNONE 13256 : ffeinfo_basictype (info)) 13257 { 13258 case FFEINFO_basictypeLOGICAL: 13259 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, 13260 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, 13261 FFEEXPR_contextLET); 13262 /* Fall through. */ 13263 case FFEINFO_basictypeREAL: 13264 case FFEINFO_basictypeCOMPLEX: 13265 if (ffe_is_pedantic ()) 13266 { 13267 error = TRUE; 13268 break; 13269 } 13270 /* Fall through. */ 13271 case FFEINFO_basictypeINTEGER: 13272 case FFEINFO_basictypeHOLLERITH: 13273 case FFEINFO_basictypeTYPELESS: 13274 error = FALSE; 13275 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 13276 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 13277 FFEEXPR_contextLET); 13278 break; 13279 13280 default: 13281 error = TRUE; 13282 break; 13283 } 13284 if ((expr == NULL) || (ffeinfo_rank (info) != 0)) 13285 error = TRUE; 13286 break; 13287 13288 case FFEEXPR_contextFILEUNITAMBIG: /* Same as FILEUNIT in _finished_. */ 13289 if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR)) 13290 { 13291 error = FALSE; 13292 break; 13293 } 13294 switch ((expr == NULL) ? FFEINFO_basictypeNONE 13295 : ffeinfo_basictype (info)) 13296 { 13297 case FFEINFO_basictypeLOGICAL: 13298 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, 13299 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, 13300 FFEEXPR_contextLET); 13301 /* Fall through. */ 13302 case FFEINFO_basictypeREAL: 13303 case FFEINFO_basictypeCOMPLEX: 13304 if (ffe_is_pedantic ()) 13305 { 13306 error = TRUE; 13307 break; 13308 } 13309 /* Fall through. */ 13310 case FFEINFO_basictypeINTEGER: 13311 case FFEINFO_basictypeHOLLERITH: 13312 case FFEINFO_basictypeTYPELESS: 13313 error = (ffeinfo_rank (info) != 0); 13314 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, 13315 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, 13316 FFEEXPR_contextLET); 13317 break; 13318 13319 case FFEINFO_basictypeCHARACTER: 13320 switch (ffebld_op (expr)) 13321 { /* As if _lhs had been called instead of 13322 _rhs. */ 13323 case FFEBLD_opSYMTER: 13324 error 13325 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT); 13326 break; 13327 13328 case FFEBLD_opSUBSTR: 13329 error = (ffeinfo_where (ffebld_info (expr)) 13330 == FFEINFO_whereCONSTANT_SUBOBJECT); 13331 break; 13332 13333 case FFEBLD_opARRAYREF: 13334 error = FALSE; 13335 break; 13336 13337 default: 13338 error = TRUE; 13339 break; 13340 } 13341 break; 13342 13343 default: 13344 error = TRUE; 13345 break; 13346 } 13347 break; 13348 13349 default: 13350 assert ("bad context" == NULL); 13351 error = TRUE; 13352 break; 13353 } 13354 13355 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY))) 13356 { 13357 ffebad_start (FFEBAD_EXPR_WRONG); 13358 ffebad_here (0, ffelex_token_where_line (ft), 13359 ffelex_token_where_column (ft)); 13360 ffebad_finish (); 13361 expr = ffebld_new_any (); 13362 ffebld_set_info (expr, ffeinfo_new_any ()); 13363 } 13364 13365 return expr; 13366} 13367 13368/* ffeexpr_token_lhs_ -- Initial state for lhs expression 13369 13370 Return a pointer to this function to the lexer (ffelex), which will 13371 invoke it for the next token. 13372 13373 Basically a smaller version of _rhs_; keep them both in sync, of course. */ 13374 13375static ffelexHandler 13376ffeexpr_token_lhs_ (ffelexToken t) 13377{ 13378 13379 /* When changing the list of valid initial lhs tokens, check whether to 13380 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the 13381 READ (expr) <token> case -- it assumes it knows which tokens <token> can 13382 be to indicate an lhs (or implied DO), which right now is the set 13383 {NAME,OPEN_PAREN}. 13384 13385 This comment also appears in ffeexpr_token_first_lhs_. */ 13386 13387 switch (ffelex_token_type (t)) 13388 { 13389 case FFELEX_typeNAME: 13390 case FFELEX_typeNAMES: 13391 ffeexpr_tokens_[0] = ffelex_token_use (t); 13392 return (ffelexHandler) ffeexpr_token_name_lhs_; 13393 13394 default: 13395 return (ffelexHandler) ffeexpr_finished_ (t); 13396 } 13397} 13398 13399/* ffeexpr_token_rhs_ -- Initial state for rhs expression 13400 13401 Return a pointer to this function to the lexer (ffelex), which will 13402 invoke it for the next token. 13403 13404 The initial state and the post-binary-operator state are the same and 13405 both handled here, with the expression stack used to distinguish 13406 between them. Binary operators are invalid here; unary operators, 13407 constants, subexpressions, and name references are valid. */ 13408 13409static ffelexHandler 13410ffeexpr_token_rhs_ (ffelexToken t) 13411{ 13412 ffeexprExpr_ e; 13413 13414 switch (ffelex_token_type (t)) 13415 { 13416 case FFELEX_typeQUOTE: 13417 if (ffe_is_vxt ()) 13418 { 13419 ffeexpr_tokens_[0] = ffelex_token_use (t); 13420 return (ffelexHandler) ffeexpr_token_quote_; 13421 } 13422 ffeexpr_tokens_[0] = ffelex_token_use (t); 13423 ffelex_set_expecting_hollerith (-1, '\"', 13424 ffelex_token_where_line (t), 13425 ffelex_token_where_column (t)); 13426 /* Don't have to unset this one. */ 13427 return (ffelexHandler) ffeexpr_token_apostrophe_; 13428 13429 case FFELEX_typeAPOSTROPHE: 13430 ffeexpr_tokens_[0] = ffelex_token_use (t); 13431 ffelex_set_expecting_hollerith (-1, '\'', 13432 ffelex_token_where_line (t), 13433 ffelex_token_where_column (t)); 13434 /* Don't have to unset this one. */ 13435 return (ffelexHandler) ffeexpr_token_apostrophe_; 13436 13437 case FFELEX_typePERCENT: 13438 ffeexpr_tokens_[0] = ffelex_token_use (t); 13439 return (ffelexHandler) ffeexpr_token_percent_; 13440 13441 case FFELEX_typeOPEN_PAREN: 13442 ffeexpr_stack_->tokens[0] = ffelex_token_use (t); 13443 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 13444 FFEEXPR_contextPAREN_, 13445 ffeexpr_cb_close_paren_c_); 13446 13447 case FFELEX_typePLUS: 13448 e = ffeexpr_expr_new_ (); 13449 e->type = FFEEXPR_exprtypeUNARY_; 13450 e->token = ffelex_token_use (t); 13451 e->u.operator.op = FFEEXPR_operatorADD_; 13452 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_; 13453 e->u.operator.as = FFEEXPR_operatorassociativityADD_; 13454 ffeexpr_exprstack_push_unary_ (e); 13455 return (ffelexHandler) ffeexpr_token_rhs_; 13456 13457 case FFELEX_typeMINUS: 13458 e = ffeexpr_expr_new_ (); 13459 e->type = FFEEXPR_exprtypeUNARY_; 13460 e->token = ffelex_token_use (t); 13461 e->u.operator.op = FFEEXPR_operatorSUBTRACT_; 13462 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_; 13463 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_; 13464 ffeexpr_exprstack_push_unary_ (e); 13465 return (ffelexHandler) ffeexpr_token_rhs_; 13466 13467 case FFELEX_typePERIOD: 13468 ffeexpr_tokens_[0] = ffelex_token_use (t); 13469 return (ffelexHandler) ffeexpr_token_period_; 13470 13471 case FFELEX_typeNUMBER: 13472 ffeexpr_tokens_[0] = ffelex_token_use (t); 13473 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t)); 13474 if (ffeexpr_hollerith_count_ > 0) 13475 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_, 13476 '\0', 13477 ffelex_token_where_line (t), 13478 ffelex_token_where_column (t)); 13479 return (ffelexHandler) ffeexpr_token_number_; 13480 13481 case FFELEX_typeNAME: 13482 case FFELEX_typeNAMES: 13483 ffeexpr_tokens_[0] = ffelex_token_use (t); 13484 switch (ffeexpr_stack_->context) 13485 { 13486 case FFEEXPR_contextACTUALARG_: 13487 case FFEEXPR_contextINDEXORACTUALARG_: 13488 case FFEEXPR_contextSFUNCDEFACTUALARG_: 13489 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 13490 return (ffelexHandler) ffeexpr_token_name_arg_; 13491 13492 default: 13493 return (ffelexHandler) ffeexpr_token_name_rhs_; 13494 } 13495 13496 case FFELEX_typeASTERISK: 13497 case FFELEX_typeSLASH: 13498 case FFELEX_typePOWER: 13499 case FFELEX_typeCONCAT: 13500 case FFELEX_typeREL_EQ: 13501 case FFELEX_typeREL_NE: 13502 case FFELEX_typeREL_LE: 13503 case FFELEX_typeREL_GE: 13504 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND)) 13505 { 13506 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 13507 ffebad_finish (); 13508 } 13509 return (ffelexHandler) ffeexpr_token_rhs_; 13510 13511#if 0 13512 case FFELEX_typeEQUALS: 13513 case FFELEX_typePOINTS: 13514 case FFELEX_typeCLOSE_ANGLE: 13515 case FFELEX_typeCLOSE_PAREN: 13516 case FFELEX_typeCOMMA: 13517 case FFELEX_typeCOLON: 13518 case FFELEX_typeEOS: 13519 case FFELEX_typeSEMICOLON: 13520#endif 13521 default: 13522 return (ffelexHandler) ffeexpr_finished_ (t); 13523 } 13524} 13525 13526/* ffeexpr_token_period_ -- Rhs PERIOD 13527 13528 Return a pointer to this function to the lexer (ffelex), which will 13529 invoke it for the next token. 13530 13531 Handle a period detected at rhs (expecting unary op or operand) state. 13532 Must begin a floating-point value (as in .12) or a dot-dot name, of 13533 which only .NOT., .TRUE., and .FALSE. are truly valid. Other sort-of- 13534 valid names represent binary operators, which are invalid here because 13535 there isn't an operand at the top of the stack. */ 13536 13537static ffelexHandler 13538ffeexpr_token_period_ (ffelexToken t) 13539{ 13540 switch (ffelex_token_type (t)) 13541 { 13542 case FFELEX_typeNAME: 13543 case FFELEX_typeNAMES: 13544 ffeexpr_current_dotdot_ = ffestr_other (t); 13545 switch (ffeexpr_current_dotdot_) 13546 { 13547 case FFESTR_otherNone: 13548 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD)) 13549 { 13550 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), 13551 ffelex_token_where_column (ffeexpr_tokens_[0])); 13552 ffebad_finish (); 13553 } 13554 ffelex_token_kill (ffeexpr_tokens_[0]); 13555 return (ffelexHandler) ffeexpr_token_rhs_ (t); 13556 13557 case FFESTR_otherTRUE: 13558 case FFESTR_otherFALSE: 13559 case FFESTR_otherNOT: 13560 ffeexpr_tokens_[1] = ffelex_token_use (t); 13561 return (ffelexHandler) ffeexpr_token_end_period_; 13562 13563 default: 13564 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND)) 13565 { 13566 ffebad_here (0, ffelex_token_where_line (t), 13567 ffelex_token_where_column (t)); 13568 ffebad_finish (); 13569 } 13570 ffelex_token_kill (ffeexpr_tokens_[0]); 13571 return (ffelexHandler) ffeexpr_token_swallow_period_; 13572 } 13573 break; /* Nothing really reaches here. */ 13574 13575 case FFELEX_typeNUMBER: 13576 ffeexpr_tokens_[1] = ffelex_token_use (t); 13577 return (ffelexHandler) ffeexpr_token_real_; 13578 13579 default: 13580 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD)) 13581 { 13582 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), 13583 ffelex_token_where_column (ffeexpr_tokens_[0])); 13584 ffebad_finish (); 13585 } 13586 ffelex_token_kill (ffeexpr_tokens_[0]); 13587 return (ffelexHandler) ffeexpr_token_rhs_ (t); 13588 } 13589} 13590 13591/* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE) 13592 13593 Return a pointer to this function to the lexer (ffelex), which will 13594 invoke it for the next token. 13595 13596 Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op 13597 or operator) state. If period isn't found, issue a diagnostic but 13598 pretend we saw one. ffeexpr_current_dotdot_ must already contained the 13599 dotdot representation of the name in between the two PERIOD tokens. */ 13600 13601static ffelexHandler 13602ffeexpr_token_end_period_ (ffelexToken t) 13603{ 13604 ffeexprExpr_ e; 13605 13606 if (ffelex_token_type (t) != FFELEX_typePERIOD) 13607 { 13608 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD)) 13609 { 13610 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), 13611 ffelex_token_where_column (ffeexpr_tokens_[0])); 13612 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); 13613 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1])); 13614 ffebad_finish (); 13615 } 13616 } 13617 13618 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill "NOT"/"TRUE"/"FALSE" 13619 token. */ 13620 13621 e = ffeexpr_expr_new_ (); 13622 e->token = ffeexpr_tokens_[0]; 13623 13624 switch (ffeexpr_current_dotdot_) 13625 { 13626 case FFESTR_otherNOT: 13627 e->type = FFEEXPR_exprtypeUNARY_; 13628 e->u.operator.op = FFEEXPR_operatorNOT_; 13629 e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_; 13630 e->u.operator.as = FFEEXPR_operatorassociativityNOT_; 13631 ffeexpr_exprstack_push_unary_ (e); 13632 if (ffelex_token_type (t) != FFELEX_typePERIOD) 13633 return (ffelexHandler) ffeexpr_token_rhs_ (t); 13634 return (ffelexHandler) ffeexpr_token_rhs_; 13635 13636 case FFESTR_otherTRUE: 13637 e->type = FFEEXPR_exprtypeOPERAND_; 13638 e->u.operand 13639 = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE)); 13640 ffebld_set_info (e->u.operand, 13641 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 13642 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); 13643 ffeexpr_exprstack_push_operand_ (e); 13644 if (ffelex_token_type (t) != FFELEX_typePERIOD) 13645 return (ffelexHandler) ffeexpr_token_binary_ (t); 13646 return (ffelexHandler) ffeexpr_token_binary_; 13647 13648 case FFESTR_otherFALSE: 13649 e->type = FFEEXPR_exprtypeOPERAND_; 13650 e->u.operand 13651 = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE)); 13652 ffebld_set_info (e->u.operand, 13653 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, 13654 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); 13655 ffeexpr_exprstack_push_operand_ (e); 13656 if (ffelex_token_type (t) != FFELEX_typePERIOD) 13657 return (ffelexHandler) ffeexpr_token_binary_ (t); 13658 return (ffelexHandler) ffeexpr_token_binary_; 13659 13660 default: 13661 assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL); 13662 exit (0); 13663 return NULL; 13664 } 13665} 13666 13667/* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE) 13668 13669 Return a pointer to this function to the lexer (ffelex), which will 13670 invoke it for the next token. 13671 13672 A diagnostic has already been issued; just swallow a period if there is 13673 one, then continue with ffeexpr_token_rhs_. */ 13674 13675static ffelexHandler 13676ffeexpr_token_swallow_period_ (ffelexToken t) 13677{ 13678 if (ffelex_token_type (t) != FFELEX_typePERIOD) 13679 return (ffelexHandler) ffeexpr_token_rhs_ (t); 13680 13681 return (ffelexHandler) ffeexpr_token_rhs_; 13682} 13683 13684/* ffeexpr_token_real_ -- Rhs PERIOD NUMBER 13685 13686 Return a pointer to this function to the lexer (ffelex), which will 13687 invoke it for the next token. 13688 13689 After a period and a string of digits, check next token for possible 13690 exponent designation (D, E, or Q as first/only character) and continue 13691 real-number handling accordingly. Else form basic real constant, push 13692 onto expression stack, and enter binary state using current token (which, 13693 if it is a name not beginning with D, E, or Q, will certainly result 13694 in an error, but that's not for this routine to deal with). */ 13695 13696static ffelexHandler 13697ffeexpr_token_real_ (ffelexToken t) 13698{ 13699 char d; 13700 const char *p; 13701 13702 if (((ffelex_token_type (t) != FFELEX_typeNAME) 13703 && (ffelex_token_type (t) != FFELEX_typeNAMES)) 13704 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), 13705 'D', 'd') 13706 || ffesrc_char_match_init (d, 'E', 'e') 13707 || ffesrc_char_match_init (d, 'Q', 'q'))) 13708 && ffeexpr_isdigits_ (++p))) 13709 { 13710#if 0 13711 /* This code has been removed because it seems inconsistent to 13712 produce a diagnostic in this case, but not all of the other 13713 ones that look for an exponent and cannot recognize one. */ 13714 if (((ffelex_token_type (t) == FFELEX_typeNAME) 13715 || (ffelex_token_type (t) == FFELEX_typeNAMES)) 13716 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT)) 13717 { 13718 char bad[2]; 13719 13720 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 13721 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]), 13722 ffelex_token_where_column (ffeexpr_tokens_[0])); 13723 bad[0] = *(p - 1); 13724 bad[1] = '\0'; 13725 ffebad_string (bad); 13726 ffebad_finish (); 13727 } 13728#endif 13729 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL, 13730 ffeexpr_tokens_[0], ffeexpr_tokens_[1], 13731 NULL, NULL, NULL); 13732 13733 ffelex_token_kill (ffeexpr_tokens_[0]); 13734 ffelex_token_kill (ffeexpr_tokens_[1]); 13735 return (ffelexHandler) ffeexpr_token_binary_ (t); 13736 } 13737 13738 /* Just exponent character by itself? In which case, PLUS or MINUS must 13739 surely be next, followed by a NUMBER token. */ 13740 13741 if (*p == '\0') 13742 { 13743 ffeexpr_tokens_[2] = ffelex_token_use (t); 13744 return (ffelexHandler) ffeexpr_token_real_exponent_; 13745 } 13746 13747 ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1], 13748 t, NULL, NULL); 13749 13750 ffelex_token_kill (ffeexpr_tokens_[0]); 13751 ffelex_token_kill (ffeexpr_tokens_[1]); 13752 return (ffelexHandler) ffeexpr_token_binary_; 13753} 13754 13755/* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q) 13756 13757 Return a pointer to this function to the lexer (ffelex), which will 13758 invoke it for the next token. 13759 13760 Ensures this token is PLUS or MINUS, preserves it, goes to final state 13761 for real number (exponent digits). Else issues diagnostic, assumes a 13762 zero exponent field for number, passes token on to binary state as if 13763 previous token had been "E0" instead of "E", for example. */ 13764 13765static ffelexHandler 13766ffeexpr_token_real_exponent_ (ffelexToken t) 13767{ 13768 if ((ffelex_token_type (t) != FFELEX_typePLUS) 13769 && (ffelex_token_type (t) != FFELEX_typeMINUS)) 13770 { 13771 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) 13772 { 13773 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]), 13774 ffelex_token_where_column (ffeexpr_tokens_[2])); 13775 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); 13776 ffebad_finish (); 13777 } 13778 13779 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL, 13780 ffeexpr_tokens_[0], ffeexpr_tokens_[1], 13781 NULL, NULL, NULL); 13782 13783 ffelex_token_kill (ffeexpr_tokens_[0]); 13784 ffelex_token_kill (ffeexpr_tokens_[1]); 13785 ffelex_token_kill (ffeexpr_tokens_[2]); 13786 return (ffelexHandler) ffeexpr_token_binary_ (t); 13787 } 13788 13789 ffeexpr_tokens_[3] = ffelex_token_use (t); 13790 return (ffelexHandler) ffeexpr_token_real_exp_sign_; 13791} 13792 13793/* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS 13794 13795 Return a pointer to this function to the lexer (ffelex), which will 13796 invoke it for the next token. 13797 13798 Make sure token is a NUMBER, make a real constant out of all we have and 13799 push it onto the expression stack. Else issue diagnostic and pretend 13800 exponent field was a zero. */ 13801 13802static ffelexHandler 13803ffeexpr_token_real_exp_sign_ (ffelexToken t) 13804{ 13805 if (ffelex_token_type (t) != FFELEX_typeNUMBER) 13806 { 13807 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) 13808 { 13809 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]), 13810 ffelex_token_where_column (ffeexpr_tokens_[2])); 13811 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); 13812 ffebad_finish (); 13813 } 13814 13815 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL, 13816 ffeexpr_tokens_[0], ffeexpr_tokens_[1], 13817 NULL, NULL, NULL); 13818 13819 ffelex_token_kill (ffeexpr_tokens_[0]); 13820 ffelex_token_kill (ffeexpr_tokens_[1]); 13821 ffelex_token_kill (ffeexpr_tokens_[2]); 13822 ffelex_token_kill (ffeexpr_tokens_[3]); 13823 return (ffelexHandler) ffeexpr_token_binary_ (t); 13824 } 13825 13826 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL, 13827 ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2], 13828 ffeexpr_tokens_[3], t); 13829 13830 ffelex_token_kill (ffeexpr_tokens_[0]); 13831 ffelex_token_kill (ffeexpr_tokens_[1]); 13832 ffelex_token_kill (ffeexpr_tokens_[2]); 13833 ffelex_token_kill (ffeexpr_tokens_[3]); 13834 return (ffelexHandler) ffeexpr_token_binary_; 13835} 13836 13837/* ffeexpr_token_number_ -- Rhs NUMBER 13838 13839 Return a pointer to this function to the lexer (ffelex), which will 13840 invoke it for the next token. 13841 13842 If the token is a period, we may have a floating-point number, or an 13843 integer followed by a dotdot binary operator. If the token is a name 13844 beginning with D, E, or Q, we definitely have a floating-point number. 13845 If the token is a hollerith constant, that's what we've got, so push 13846 it onto the expression stack and continue with the binary state. 13847 13848 Otherwise, we have an integer followed by something the binary state 13849 should be able to swallow. */ 13850 13851static ffelexHandler 13852ffeexpr_token_number_ (ffelexToken t) 13853{ 13854 ffeexprExpr_ e; 13855 ffeinfo ni; 13856 char d; 13857 const char *p; 13858 13859 if (ffeexpr_hollerith_count_ > 0) 13860 ffelex_set_expecting_hollerith (0, '\0', 13861 ffewhere_line_unknown (), 13862 ffewhere_column_unknown ()); 13863 13864 /* See if we've got a floating-point number here. */ 13865 13866 switch (ffelex_token_type (t)) 13867 { 13868 case FFELEX_typeNAME: 13869 case FFELEX_typeNAMES: 13870 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), 13871 'D', 'd') 13872 || ffesrc_char_match_init (d, 'E', 'e') 13873 || ffesrc_char_match_init (d, 'Q', 'q')) 13874 && ffeexpr_isdigits_ (++p)) 13875 { 13876 13877 /* Just exponent character by itself? In which case, PLUS or MINUS 13878 must surely be next, followed by a NUMBER token. */ 13879 13880 if (*p == '\0') 13881 { 13882 ffeexpr_tokens_[1] = ffelex_token_use (t); 13883 return (ffelexHandler) ffeexpr_token_number_exponent_; 13884 } 13885 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t, 13886 NULL, NULL); 13887 13888 ffelex_token_kill (ffeexpr_tokens_[0]); 13889 return (ffelexHandler) ffeexpr_token_binary_; 13890 } 13891 break; 13892 13893 case FFELEX_typePERIOD: 13894 ffeexpr_tokens_[1] = ffelex_token_use (t); 13895 return (ffelexHandler) ffeexpr_token_number_period_; 13896 13897 case FFELEX_typeHOLLERITH: 13898 e = ffeexpr_expr_new_ (); 13899 e->type = FFEEXPR_exprtypeOPERAND_; 13900 e->token = ffeexpr_tokens_[0]; 13901 e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t)); 13902 ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE, 13903 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, 13904 ffelex_token_length (t)); 13905 ffebld_set_info (e->u.operand, ni); 13906 ffeexpr_exprstack_push_operand_ (e); 13907 return (ffelexHandler) ffeexpr_token_binary_; 13908 13909 default: 13910 break; 13911 } 13912 13913 /* Nothing specific we were looking for, so make an integer and pass the 13914 current token to the binary state. */ 13915 13916 ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL, 13917 NULL, NULL, NULL); 13918 return (ffelexHandler) ffeexpr_token_binary_ (t); 13919} 13920 13921/* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q) 13922 13923 Return a pointer to this function to the lexer (ffelex), which will 13924 invoke it for the next token. 13925 13926 Ensures this token is PLUS or MINUS, preserves it, goes to final state 13927 for real number (exponent digits). Else treats number as integer, passes 13928 name to binary, passes current token to subsequent handler. */ 13929 13930static ffelexHandler 13931ffeexpr_token_number_exponent_ (ffelexToken t) 13932{ 13933 if ((ffelex_token_type (t) != FFELEX_typePLUS) 13934 && (ffelex_token_type (t) != FFELEX_typeMINUS)) 13935 { 13936 ffeexprExpr_ e; 13937 ffelexHandler nexthandler; 13938 13939 e = ffeexpr_expr_new_ (); 13940 e->type = FFEEXPR_exprtypeOPERAND_; 13941 e->token = ffeexpr_tokens_[0]; 13942 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault 13943 (ffeexpr_tokens_[0])); 13944 ffebld_set_info (e->u.operand, 13945 ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 13946 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); 13947 ffeexpr_exprstack_push_operand_ (e); 13948 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]); 13949 ffelex_token_kill (ffeexpr_tokens_[1]); 13950 return (ffelexHandler) (*nexthandler) (t); 13951 } 13952 13953 ffeexpr_tokens_[2] = ffelex_token_use (t); 13954 return (ffelexHandler) ffeexpr_token_number_exp_sign_; 13955} 13956 13957/* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS 13958 13959 Return a pointer to this function to the lexer (ffelex), which will 13960 invoke it for the next token. 13961 13962 Make sure token is a NUMBER, make a real constant out of all we have and 13963 push it onto the expression stack. Else issue diagnostic and pretend 13964 exponent field was a zero. */ 13965 13966static ffelexHandler 13967ffeexpr_token_number_exp_sign_ (ffelexToken t) 13968{ 13969 if (ffelex_token_type (t) != FFELEX_typeNUMBER) 13970 { 13971 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) 13972 { 13973 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]), 13974 ffelex_token_where_column (ffeexpr_tokens_[1])); 13975 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); 13976 ffebad_finish (); 13977 } 13978 13979 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0], 13980 ffeexpr_tokens_[0], NULL, NULL, 13981 ffeexpr_tokens_[1], ffeexpr_tokens_[2], 13982 NULL); 13983 13984 ffelex_token_kill (ffeexpr_tokens_[0]); 13985 ffelex_token_kill (ffeexpr_tokens_[1]); 13986 ffelex_token_kill (ffeexpr_tokens_[2]); 13987 return (ffelexHandler) ffeexpr_token_binary_ (t); 13988 } 13989 13990 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0], 13991 ffeexpr_tokens_[0], NULL, NULL, 13992 ffeexpr_tokens_[1], ffeexpr_tokens_[2], t); 13993 13994 ffelex_token_kill (ffeexpr_tokens_[0]); 13995 ffelex_token_kill (ffeexpr_tokens_[1]); 13996 ffelex_token_kill (ffeexpr_tokens_[2]); 13997 return (ffelexHandler) ffeexpr_token_binary_; 13998} 13999 14000/* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD 14001 14002 Return a pointer to this function to the lexer (ffelex), which will 14003 invoke it for the next token. 14004 14005 Handle a period detected following a number at rhs state. Must begin a 14006 floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name. */ 14007 14008static ffelexHandler 14009ffeexpr_token_number_period_ (ffelexToken t) 14010{ 14011 ffeexprExpr_ e; 14012 ffelexHandler nexthandler; 14013 const char *p; 14014 char d; 14015 14016 switch (ffelex_token_type (t)) 14017 { 14018 case FFELEX_typeNAME: 14019 case FFELEX_typeNAMES: 14020 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), 14021 'D', 'd') 14022 || ffesrc_char_match_init (d, 'E', 'e') 14023 || ffesrc_char_match_init (d, 'Q', 'q')) 14024 && ffeexpr_isdigits_ (++p)) 14025 { 14026 14027 /* Just exponent character by itself? In which case, PLUS or MINUS 14028 must surely be next, followed by a NUMBER token. */ 14029 14030 if (*p == '\0') 14031 { 14032 ffeexpr_tokens_[2] = ffelex_token_use (t); 14033 return (ffelexHandler) ffeexpr_token_number_per_exp_; 14034 } 14035 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], 14036 ffeexpr_tokens_[1], NULL, t, NULL, 14037 NULL); 14038 14039 ffelex_token_kill (ffeexpr_tokens_[0]); 14040 ffelex_token_kill (ffeexpr_tokens_[1]); 14041 return (ffelexHandler) ffeexpr_token_binary_; 14042 } 14043 /* A name not representing an exponent, so assume it will be something 14044 like EQ, make an integer from the number, pass the period to binary 14045 state and the current token to the resulting state. */ 14046 14047 e = ffeexpr_expr_new_ (); 14048 e->type = FFEEXPR_exprtypeOPERAND_; 14049 e->token = ffeexpr_tokens_[0]; 14050 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault 14051 (ffeexpr_tokens_[0])); 14052 ffebld_set_info (e->u.operand, 14053 ffeinfo_new (FFEINFO_basictypeINTEGER, 14054 FFEINFO_kindtypeINTEGERDEFAULT, 0, 14055 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, 14056 FFETARGET_charactersizeNONE)); 14057 ffeexpr_exprstack_push_operand_ (e); 14058 nexthandler = (ffelexHandler) ffeexpr_token_binary_ 14059 (ffeexpr_tokens_[1]); 14060 ffelex_token_kill (ffeexpr_tokens_[1]); 14061 return (ffelexHandler) (*nexthandler) (t); 14062 14063 case FFELEX_typeNUMBER: 14064 ffeexpr_tokens_[2] = ffelex_token_use (t); 14065 return (ffelexHandler) ffeexpr_token_number_real_; 14066 14067 default: 14068 break; 14069 } 14070 14071 /* Nothing specific we were looking for, so make a real number and pass the 14072 period and then the current token to the binary state. */ 14073 14074 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), 14075 ffeexpr_tokens_[0], ffeexpr_tokens_[1], 14076 NULL, NULL, NULL, NULL); 14077 14078 ffelex_token_kill (ffeexpr_tokens_[0]); 14079 ffelex_token_kill (ffeexpr_tokens_[1]); 14080 return (ffelexHandler) ffeexpr_token_binary_ (t); 14081} 14082 14083/* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q) 14084 14085 Return a pointer to this function to the lexer (ffelex), which will 14086 invoke it for the next token. 14087 14088 Ensures this token is PLUS or MINUS, preserves it, goes to final state 14089 for real number (exponent digits). Else treats number as real, passes 14090 name to binary, passes current token to subsequent handler. */ 14091 14092static ffelexHandler 14093ffeexpr_token_number_per_exp_ (ffelexToken t) 14094{ 14095 if ((ffelex_token_type (t) != FFELEX_typePLUS) 14096 && (ffelex_token_type (t) != FFELEX_typeMINUS)) 14097 { 14098 ffelexHandler nexthandler; 14099 14100 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), 14101 ffeexpr_tokens_[0], ffeexpr_tokens_[1], 14102 NULL, NULL, NULL, NULL); 14103 14104 ffelex_token_kill (ffeexpr_tokens_[0]); 14105 ffelex_token_kill (ffeexpr_tokens_[1]); 14106 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]); 14107 ffelex_token_kill (ffeexpr_tokens_[2]); 14108 return (ffelexHandler) (*nexthandler) (t); 14109 } 14110 14111 ffeexpr_tokens_[3] = ffelex_token_use (t); 14112 return (ffelexHandler) ffeexpr_token_num_per_exp_sign_; 14113} 14114 14115/* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER 14116 14117 Return a pointer to this function to the lexer (ffelex), which will 14118 invoke it for the next token. 14119 14120 After a number, period, and number, check next token for possible 14121 exponent designation (D, E, or Q as first/only character) and continue 14122 real-number handling accordingly. Else form basic real constant, push 14123 onto expression stack, and enter binary state using current token (which, 14124 if it is a name not beginning with D, E, or Q, will certainly result 14125 in an error, but that's not for this routine to deal with). */ 14126 14127static ffelexHandler 14128ffeexpr_token_number_real_ (ffelexToken t) 14129{ 14130 char d; 14131 const char *p; 14132 14133 if (((ffelex_token_type (t) != FFELEX_typeNAME) 14134 && (ffelex_token_type (t) != FFELEX_typeNAMES)) 14135 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), 14136 'D', 'd') 14137 || ffesrc_char_match_init (d, 'E', 'e') 14138 || ffesrc_char_match_init (d, 'Q', 'q'))) 14139 && ffeexpr_isdigits_ (++p))) 14140 { 14141#if 0 14142 /* This code has been removed because it seems inconsistent to 14143 produce a diagnostic in this case, but not all of the other 14144 ones that look for an exponent and cannot recognize one. */ 14145 if (((ffelex_token_type (t) == FFELEX_typeNAME) 14146 || (ffelex_token_type (t) == FFELEX_typeNAMES)) 14147 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT)) 14148 { 14149 char bad[2]; 14150 14151 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 14152 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]), 14153 ffelex_token_where_column (ffeexpr_tokens_[0])); 14154 bad[0] = *(p - 1); 14155 bad[1] = '\0'; 14156 ffebad_string (bad); 14157 ffebad_finish (); 14158 } 14159#endif 14160 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), 14161 ffeexpr_tokens_[0], ffeexpr_tokens_[1], 14162 ffeexpr_tokens_[2], NULL, NULL, NULL); 14163 14164 ffelex_token_kill (ffeexpr_tokens_[0]); 14165 ffelex_token_kill (ffeexpr_tokens_[1]); 14166 ffelex_token_kill (ffeexpr_tokens_[2]); 14167 return (ffelexHandler) ffeexpr_token_binary_ (t); 14168 } 14169 14170 /* Just exponent character by itself? In which case, PLUS or MINUS must 14171 surely be next, followed by a NUMBER token. */ 14172 14173 if (*p == '\0') 14174 { 14175 ffeexpr_tokens_[3] = ffelex_token_use (t); 14176 return (ffelexHandler) ffeexpr_token_number_real_exp_; 14177 } 14178 14179 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1], 14180 ffeexpr_tokens_[2], t, NULL, NULL); 14181 14182 ffelex_token_kill (ffeexpr_tokens_[0]); 14183 ffelex_token_kill (ffeexpr_tokens_[1]); 14184 ffelex_token_kill (ffeexpr_tokens_[2]); 14185 return (ffelexHandler) ffeexpr_token_binary_; 14186} 14187 14188/* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS 14189 14190 Return a pointer to this function to the lexer (ffelex), which will 14191 invoke it for the next token. 14192 14193 Make sure token is a NUMBER, make a real constant out of all we have and 14194 push it onto the expression stack. Else issue diagnostic and pretend 14195 exponent field was a zero. */ 14196 14197static ffelexHandler 14198ffeexpr_token_num_per_exp_sign_ (ffelexToken t) 14199{ 14200 if (ffelex_token_type (t) != FFELEX_typeNUMBER) 14201 { 14202 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) 14203 { 14204 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]), 14205 ffelex_token_where_column (ffeexpr_tokens_[2])); 14206 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); 14207 ffebad_finish (); 14208 } 14209 14210 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), 14211 ffeexpr_tokens_[0], ffeexpr_tokens_[1], 14212 NULL, NULL, NULL, NULL); 14213 14214 ffelex_token_kill (ffeexpr_tokens_[0]); 14215 ffelex_token_kill (ffeexpr_tokens_[1]); 14216 ffelex_token_kill (ffeexpr_tokens_[2]); 14217 ffelex_token_kill (ffeexpr_tokens_[3]); 14218 return (ffelexHandler) ffeexpr_token_binary_ (t); 14219 } 14220 14221 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], 14222 ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL, 14223 ffeexpr_tokens_[2], ffeexpr_tokens_[3], t); 14224 14225 ffelex_token_kill (ffeexpr_tokens_[0]); 14226 ffelex_token_kill (ffeexpr_tokens_[1]); 14227 ffelex_token_kill (ffeexpr_tokens_[2]); 14228 ffelex_token_kill (ffeexpr_tokens_[3]); 14229 return (ffelexHandler) ffeexpr_token_binary_; 14230} 14231 14232/* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q) 14233 14234 Return a pointer to this function to the lexer (ffelex), which will 14235 invoke it for the next token. 14236 14237 Ensures this token is PLUS or MINUS, preserves it, goes to final state 14238 for real number (exponent digits). Else issues diagnostic, assumes a 14239 zero exponent field for number, passes token on to binary state as if 14240 previous token had been "E0" instead of "E", for example. */ 14241 14242static ffelexHandler 14243ffeexpr_token_number_real_exp_ (ffelexToken t) 14244{ 14245 if ((ffelex_token_type (t) != FFELEX_typePLUS) 14246 && (ffelex_token_type (t) != FFELEX_typeMINUS)) 14247 { 14248 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) 14249 { 14250 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]), 14251 ffelex_token_where_column (ffeexpr_tokens_[3])); 14252 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); 14253 ffebad_finish (); 14254 } 14255 14256 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), 14257 ffeexpr_tokens_[0], ffeexpr_tokens_[1], 14258 ffeexpr_tokens_[2], NULL, NULL, NULL); 14259 14260 ffelex_token_kill (ffeexpr_tokens_[0]); 14261 ffelex_token_kill (ffeexpr_tokens_[1]); 14262 ffelex_token_kill (ffeexpr_tokens_[2]); 14263 ffelex_token_kill (ffeexpr_tokens_[3]); 14264 return (ffelexHandler) ffeexpr_token_binary_ (t); 14265 } 14266 14267 ffeexpr_tokens_[4] = ffelex_token_use (t); 14268 return (ffelexHandler) ffeexpr_token_num_real_exp_sn_; 14269} 14270 14271/* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q) 14272 PLUS/MINUS 14273 14274 Return a pointer to this function to the lexer (ffelex), which will 14275 invoke it for the next token. 14276 14277 Make sure token is a NUMBER, make a real constant out of all we have and 14278 push it onto the expression stack. Else issue diagnostic and pretend 14279 exponent field was a zero. */ 14280 14281static ffelexHandler 14282ffeexpr_token_num_real_exp_sn_ (ffelexToken t) 14283{ 14284 if (ffelex_token_type (t) != FFELEX_typeNUMBER) 14285 { 14286 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) 14287 { 14288 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]), 14289 ffelex_token_where_column (ffeexpr_tokens_[3])); 14290 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); 14291 ffebad_finish (); 14292 } 14293 14294 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), 14295 ffeexpr_tokens_[0], ffeexpr_tokens_[1], 14296 ffeexpr_tokens_[2], NULL, NULL, NULL); 14297 14298 ffelex_token_kill (ffeexpr_tokens_[0]); 14299 ffelex_token_kill (ffeexpr_tokens_[1]); 14300 ffelex_token_kill (ffeexpr_tokens_[2]); 14301 ffelex_token_kill (ffeexpr_tokens_[3]); 14302 ffelex_token_kill (ffeexpr_tokens_[4]); 14303 return (ffelexHandler) ffeexpr_token_binary_ (t); 14304 } 14305 14306 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0], 14307 ffeexpr_tokens_[0], ffeexpr_tokens_[1], 14308 ffeexpr_tokens_[2], ffeexpr_tokens_[3], 14309 ffeexpr_tokens_[4], t); 14310 14311 ffelex_token_kill (ffeexpr_tokens_[0]); 14312 ffelex_token_kill (ffeexpr_tokens_[1]); 14313 ffelex_token_kill (ffeexpr_tokens_[2]); 14314 ffelex_token_kill (ffeexpr_tokens_[3]); 14315 ffelex_token_kill (ffeexpr_tokens_[4]); 14316 return (ffelexHandler) ffeexpr_token_binary_; 14317} 14318 14319/* ffeexpr_token_binary_ -- Handle binary operator possibility 14320 14321 Return a pointer to this function to the lexer (ffelex), which will 14322 invoke it for the next token. 14323 14324 The possibility of a binary operator is handled here, meaning the previous 14325 token was an operand. */ 14326 14327static ffelexHandler 14328ffeexpr_token_binary_ (ffelexToken t) 14329{ 14330 ffeexprExpr_ e; 14331 14332 if (!ffeexpr_stack_->is_rhs) 14333 return (ffelexHandler) ffeexpr_finished_ (t); /* For now. */ 14334 14335 switch (ffelex_token_type (t)) 14336 { 14337 case FFELEX_typePLUS: 14338 e = ffeexpr_expr_new_ (); 14339 e->type = FFEEXPR_exprtypeBINARY_; 14340 e->token = ffelex_token_use (t); 14341 e->u.operator.op = FFEEXPR_operatorADD_; 14342 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_; 14343 e->u.operator.as = FFEEXPR_operatorassociativityADD_; 14344 ffeexpr_exprstack_push_binary_ (e); 14345 return (ffelexHandler) ffeexpr_token_rhs_; 14346 14347 case FFELEX_typeMINUS: 14348 e = ffeexpr_expr_new_ (); 14349 e->type = FFEEXPR_exprtypeBINARY_; 14350 e->token = ffelex_token_use (t); 14351 e->u.operator.op = FFEEXPR_operatorSUBTRACT_; 14352 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_; 14353 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_; 14354 ffeexpr_exprstack_push_binary_ (e); 14355 return (ffelexHandler) ffeexpr_token_rhs_; 14356 14357 case FFELEX_typeASTERISK: 14358 switch (ffeexpr_stack_->context) 14359 { 14360 case FFEEXPR_contextDATA: 14361 return (ffelexHandler) ffeexpr_finished_ (t); 14362 14363 default: 14364 break; 14365 } 14366 e = ffeexpr_expr_new_ (); 14367 e->type = FFEEXPR_exprtypeBINARY_; 14368 e->token = ffelex_token_use (t); 14369 e->u.operator.op = FFEEXPR_operatorMULTIPLY_; 14370 e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_; 14371 e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_; 14372 ffeexpr_exprstack_push_binary_ (e); 14373 return (ffelexHandler) ffeexpr_token_rhs_; 14374 14375 case FFELEX_typeSLASH: 14376 switch (ffeexpr_stack_->context) 14377 { 14378 case FFEEXPR_contextDATA: 14379 return (ffelexHandler) ffeexpr_finished_ (t); 14380 14381 default: 14382 break; 14383 } 14384 e = ffeexpr_expr_new_ (); 14385 e->type = FFEEXPR_exprtypeBINARY_; 14386 e->token = ffelex_token_use (t); 14387 e->u.operator.op = FFEEXPR_operatorDIVIDE_; 14388 e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_; 14389 e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_; 14390 ffeexpr_exprstack_push_binary_ (e); 14391 return (ffelexHandler) ffeexpr_token_rhs_; 14392 14393 case FFELEX_typePOWER: 14394 e = ffeexpr_expr_new_ (); 14395 e->type = FFEEXPR_exprtypeBINARY_; 14396 e->token = ffelex_token_use (t); 14397 e->u.operator.op = FFEEXPR_operatorPOWER_; 14398 e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_; 14399 e->u.operator.as = FFEEXPR_operatorassociativityPOWER_; 14400 ffeexpr_exprstack_push_binary_ (e); 14401 return (ffelexHandler) ffeexpr_token_rhs_; 14402 14403 case FFELEX_typeCONCAT: 14404 e = ffeexpr_expr_new_ (); 14405 e->type = FFEEXPR_exprtypeBINARY_; 14406 e->token = ffelex_token_use (t); 14407 e->u.operator.op = FFEEXPR_operatorCONCATENATE_; 14408 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_; 14409 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_; 14410 ffeexpr_exprstack_push_binary_ (e); 14411 return (ffelexHandler) ffeexpr_token_rhs_; 14412 14413 case FFELEX_typeOPEN_ANGLE: 14414 switch (ffeexpr_stack_->context) 14415 { 14416 case FFEEXPR_contextFORMAT: 14417 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); 14418 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 14419 ffebad_finish (); 14420 break; 14421 14422 default: 14423 break; 14424 } 14425 e = ffeexpr_expr_new_ (); 14426 e->type = FFEEXPR_exprtypeBINARY_; 14427 e->token = ffelex_token_use (t); 14428 e->u.operator.op = FFEEXPR_operatorLT_; 14429 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_; 14430 e->u.operator.as = FFEEXPR_operatorassociativityLT_; 14431 ffeexpr_exprstack_push_binary_ (e); 14432 return (ffelexHandler) ffeexpr_token_rhs_; 14433 14434 case FFELEX_typeCLOSE_ANGLE: 14435 switch (ffeexpr_stack_->context) 14436 { 14437 case FFEEXPR_contextFORMAT: 14438 return ffeexpr_finished_ (t); 14439 14440 default: 14441 break; 14442 } 14443 e = ffeexpr_expr_new_ (); 14444 e->type = FFEEXPR_exprtypeBINARY_; 14445 e->token = ffelex_token_use (t); 14446 e->u.operator.op = FFEEXPR_operatorGT_; 14447 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_; 14448 e->u.operator.as = FFEEXPR_operatorassociativityGT_; 14449 ffeexpr_exprstack_push_binary_ (e); 14450 return (ffelexHandler) ffeexpr_token_rhs_; 14451 14452 case FFELEX_typeREL_EQ: 14453 switch (ffeexpr_stack_->context) 14454 { 14455 case FFEEXPR_contextFORMAT: 14456 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); 14457 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 14458 ffebad_finish (); 14459 break; 14460 14461 default: 14462 break; 14463 } 14464 e = ffeexpr_expr_new_ (); 14465 e->type = FFEEXPR_exprtypeBINARY_; 14466 e->token = ffelex_token_use (t); 14467 e->u.operator.op = FFEEXPR_operatorEQ_; 14468 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_; 14469 e->u.operator.as = FFEEXPR_operatorassociativityEQ_; 14470 ffeexpr_exprstack_push_binary_ (e); 14471 return (ffelexHandler) ffeexpr_token_rhs_; 14472 14473 case FFELEX_typeREL_NE: 14474 switch (ffeexpr_stack_->context) 14475 { 14476 case FFEEXPR_contextFORMAT: 14477 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); 14478 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 14479 ffebad_finish (); 14480 break; 14481 14482 default: 14483 break; 14484 } 14485 e = ffeexpr_expr_new_ (); 14486 e->type = FFEEXPR_exprtypeBINARY_; 14487 e->token = ffelex_token_use (t); 14488 e->u.operator.op = FFEEXPR_operatorNE_; 14489 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_; 14490 e->u.operator.as = FFEEXPR_operatorassociativityNE_; 14491 ffeexpr_exprstack_push_binary_ (e); 14492 return (ffelexHandler) ffeexpr_token_rhs_; 14493 14494 case FFELEX_typeREL_LE: 14495 switch (ffeexpr_stack_->context) 14496 { 14497 case FFEEXPR_contextFORMAT: 14498 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); 14499 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 14500 ffebad_finish (); 14501 break; 14502 14503 default: 14504 break; 14505 } 14506 e = ffeexpr_expr_new_ (); 14507 e->type = FFEEXPR_exprtypeBINARY_; 14508 e->token = ffelex_token_use (t); 14509 e->u.operator.op = FFEEXPR_operatorLE_; 14510 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_; 14511 e->u.operator.as = FFEEXPR_operatorassociativityLE_; 14512 ffeexpr_exprstack_push_binary_ (e); 14513 return (ffelexHandler) ffeexpr_token_rhs_; 14514 14515 case FFELEX_typeREL_GE: 14516 switch (ffeexpr_stack_->context) 14517 { 14518 case FFEEXPR_contextFORMAT: 14519 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); 14520 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 14521 ffebad_finish (); 14522 break; 14523 14524 default: 14525 break; 14526 } 14527 e = ffeexpr_expr_new_ (); 14528 e->type = FFEEXPR_exprtypeBINARY_; 14529 e->token = ffelex_token_use (t); 14530 e->u.operator.op = FFEEXPR_operatorGE_; 14531 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_; 14532 e->u.operator.as = FFEEXPR_operatorassociativityGE_; 14533 ffeexpr_exprstack_push_binary_ (e); 14534 return (ffelexHandler) ffeexpr_token_rhs_; 14535 14536 case FFELEX_typePERIOD: 14537 ffeexpr_tokens_[0] = ffelex_token_use (t); 14538 return (ffelexHandler) ffeexpr_token_binary_period_; 14539 14540#if 0 14541 case FFELEX_typeOPEN_PAREN: 14542 case FFELEX_typeCLOSE_PAREN: 14543 case FFELEX_typeEQUALS: 14544 case FFELEX_typePOINTS: 14545 case FFELEX_typeCOMMA: 14546 case FFELEX_typeCOLON: 14547 case FFELEX_typeEOS: 14548 case FFELEX_typeSEMICOLON: 14549 case FFELEX_typeNAME: 14550 case FFELEX_typeNAMES: 14551#endif 14552 default: 14553 return (ffelexHandler) ffeexpr_finished_ (t); 14554 } 14555} 14556 14557/* ffeexpr_token_binary_period_ -- Binary PERIOD 14558 14559 Return a pointer to this function to the lexer (ffelex), which will 14560 invoke it for the next token. 14561 14562 Handle a period detected at binary (expecting binary op or end) state. 14563 Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not 14564 valid. */ 14565 14566static ffelexHandler 14567ffeexpr_token_binary_period_ (ffelexToken t) 14568{ 14569 ffeexprExpr_ operand; 14570 14571 switch (ffelex_token_type (t)) 14572 { 14573 case FFELEX_typeNAME: 14574 case FFELEX_typeNAMES: 14575 ffeexpr_current_dotdot_ = ffestr_other (t); 14576 switch (ffeexpr_current_dotdot_) 14577 { 14578 case FFESTR_otherTRUE: 14579 case FFESTR_otherFALSE: 14580 case FFESTR_otherNOT: 14581 if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR)) 14582 { 14583 operand = ffeexpr_stack_->exprstack; 14584 assert (operand != NULL); 14585 assert (operand->type == FFEEXPR_exprtypeOPERAND_); 14586 ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token)); 14587 ffebad_here (1, ffelex_token_where_line (t), 14588 ffelex_token_where_column (t)); 14589 ffebad_finish (); 14590 } 14591 ffelex_token_kill (ffeexpr_tokens_[0]); 14592 return (ffelexHandler) ffeexpr_token_binary_sw_per_; 14593 14594 default: 14595 ffeexpr_tokens_[1] = ffelex_token_use (t); 14596 return (ffelexHandler) ffeexpr_token_binary_end_per_; 14597 } 14598 break; /* Nothing really reaches here. */ 14599 14600 default: 14601 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD)) 14602 { 14603 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), 14604 ffelex_token_where_column (ffeexpr_tokens_[0])); 14605 ffebad_finish (); 14606 } 14607 ffelex_token_kill (ffeexpr_tokens_[0]); 14608 return (ffelexHandler) ffeexpr_token_binary_ (t); 14609 } 14610} 14611 14612/* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE) 14613 14614 Return a pointer to this function to the lexer (ffelex), which will 14615 invoke it for the next token. 14616 14617 Expecting a period to close a dot-dot at binary (binary op 14618 or operator) state. If period isn't found, issue a diagnostic but 14619 pretend we saw one. ffeexpr_current_dotdot_ must already contained the 14620 dotdot representation of the name in between the two PERIOD tokens. */ 14621 14622static ffelexHandler 14623ffeexpr_token_binary_end_per_ (ffelexToken t) 14624{ 14625 ffeexprExpr_ e; 14626 14627 e = ffeexpr_expr_new_ (); 14628 e->type = FFEEXPR_exprtypeBINARY_; 14629 e->token = ffeexpr_tokens_[0]; 14630 14631 switch (ffeexpr_current_dotdot_) 14632 { 14633 case FFESTR_otherAND: 14634 e->u.operator.op = FFEEXPR_operatorAND_; 14635 e->u.operator.prec = FFEEXPR_operatorprecedenceAND_; 14636 e->u.operator.as = FFEEXPR_operatorassociativityAND_; 14637 break; 14638 14639 case FFESTR_otherOR: 14640 e->u.operator.op = FFEEXPR_operatorOR_; 14641 e->u.operator.prec = FFEEXPR_operatorprecedenceOR_; 14642 e->u.operator.as = FFEEXPR_operatorassociativityOR_; 14643 break; 14644 14645 case FFESTR_otherXOR: 14646 e->u.operator.op = FFEEXPR_operatorXOR_; 14647 e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_; 14648 e->u.operator.as = FFEEXPR_operatorassociativityXOR_; 14649 break; 14650 14651 case FFESTR_otherEQV: 14652 e->u.operator.op = FFEEXPR_operatorEQV_; 14653 e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_; 14654 e->u.operator.as = FFEEXPR_operatorassociativityEQV_; 14655 break; 14656 14657 case FFESTR_otherNEQV: 14658 e->u.operator.op = FFEEXPR_operatorNEQV_; 14659 e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_; 14660 e->u.operator.as = FFEEXPR_operatorassociativityNEQV_; 14661 break; 14662 14663 case FFESTR_otherLT: 14664 e->u.operator.op = FFEEXPR_operatorLT_; 14665 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_; 14666 e->u.operator.as = FFEEXPR_operatorassociativityLT_; 14667 break; 14668 14669 case FFESTR_otherLE: 14670 e->u.operator.op = FFEEXPR_operatorLE_; 14671 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_; 14672 e->u.operator.as = FFEEXPR_operatorassociativityLE_; 14673 break; 14674 14675 case FFESTR_otherEQ: 14676 e->u.operator.op = FFEEXPR_operatorEQ_; 14677 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_; 14678 e->u.operator.as = FFEEXPR_operatorassociativityEQ_; 14679 break; 14680 14681 case FFESTR_otherNE: 14682 e->u.operator.op = FFEEXPR_operatorNE_; 14683 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_; 14684 e->u.operator.as = FFEEXPR_operatorassociativityNE_; 14685 break; 14686 14687 case FFESTR_otherGT: 14688 e->u.operator.op = FFEEXPR_operatorGT_; 14689 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_; 14690 e->u.operator.as = FFEEXPR_operatorassociativityGT_; 14691 break; 14692 14693 case FFESTR_otherGE: 14694 e->u.operator.op = FFEEXPR_operatorGE_; 14695 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_; 14696 e->u.operator.as = FFEEXPR_operatorassociativityGE_; 14697 break; 14698 14699 default: 14700 if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT)) 14701 { 14702 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), 14703 ffelex_token_where_column (ffeexpr_tokens_[0])); 14704 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1])); 14705 ffebad_finish (); 14706 } 14707 e->u.operator.op = FFEEXPR_operatorEQ_; 14708 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_; 14709 e->u.operator.as = FFEEXPR_operatorassociativityEQ_; 14710 break; 14711 } 14712 14713 ffeexpr_exprstack_push_binary_ (e); 14714 14715 if (ffelex_token_type (t) != FFELEX_typePERIOD) 14716 { 14717 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD)) 14718 { 14719 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), 14720 ffelex_token_where_column (ffeexpr_tokens_[0])); 14721 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); 14722 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1])); 14723 ffebad_finish (); 14724 } 14725 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */ 14726 return (ffelexHandler) ffeexpr_token_rhs_ (t); 14727 } 14728 14729 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */ 14730 return (ffelexHandler) ffeexpr_token_rhs_; 14731} 14732 14733/* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE) 14734 14735 Return a pointer to this function to the lexer (ffelex), which will 14736 invoke it for the next token. 14737 14738 A diagnostic has already been issued; just swallow a period if there is 14739 one, then continue with ffeexpr_token_binary_. */ 14740 14741static ffelexHandler 14742ffeexpr_token_binary_sw_per_ (ffelexToken t) 14743{ 14744 if (ffelex_token_type (t) != FFELEX_typePERIOD) 14745 return (ffelexHandler) ffeexpr_token_binary_ (t); 14746 14747 return (ffelexHandler) ffeexpr_token_binary_; 14748} 14749 14750/* ffeexpr_token_quote_ -- Rhs QUOTE 14751 14752 Return a pointer to this function to the lexer (ffelex), which will 14753 invoke it for the next token. 14754 14755 Expecting a NUMBER that we'll treat as an octal integer. */ 14756 14757static ffelexHandler 14758ffeexpr_token_quote_ (ffelexToken t) 14759{ 14760 ffeexprExpr_ e; 14761 ffebld anyexpr; 14762 14763 if (ffelex_token_type (t) != FFELEX_typeNUMBER) 14764 { 14765 if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS)) 14766 { 14767 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), 14768 ffelex_token_where_column (ffeexpr_tokens_[0])); 14769 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); 14770 ffebad_finish (); 14771 } 14772 ffelex_token_kill (ffeexpr_tokens_[0]); 14773 return (ffelexHandler) ffeexpr_token_rhs_ (t); 14774 } 14775 14776 /* This is kind of a kludge to prevent any whining about magical numbers 14777 that start out as these octal integers, so "20000000000 (on a 32-bit 14778 2's-complement machine) by itself won't produce an error. */ 14779 14780 anyexpr = ffebld_new_any (); 14781 ffebld_set_info (anyexpr, ffeinfo_new_any ()); 14782 14783 e = ffeexpr_expr_new_ (); 14784 e->type = FFEEXPR_exprtypeOPERAND_; 14785 e->token = ffeexpr_tokens_[0]; 14786 e->u.operand = ffebld_new_conter_with_orig 14787 (ffebld_constant_new_integeroctal (t), anyexpr); 14788 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER, 14789 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY, 14790 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); 14791 ffeexpr_exprstack_push_operand_ (e); 14792 return (ffelexHandler) ffeexpr_token_binary_; 14793} 14794 14795/* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE 14796 14797 Return a pointer to this function to the lexer (ffelex), which will 14798 invoke it for the next token. 14799 14800 Handle an open-apostrophe, which begins either a character ('char-const'), 14801 typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or 14802 'hex-const'X) constant. */ 14803 14804static ffelexHandler 14805ffeexpr_token_apostrophe_ (ffelexToken t) 14806{ 14807 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER); 14808 if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0)) 14809 { 14810 ffebad_start (FFEBAD_NULL_CHAR_CONST); 14811 ffebad_here (0, ffelex_token_where_line (t), 14812 ffelex_token_where_column (t)); 14813 ffebad_finish (); 14814 } 14815 ffeexpr_tokens_[1] = ffelex_token_use (t); 14816 return (ffelexHandler) ffeexpr_token_apos_char_; 14817} 14818 14819/* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER 14820 14821 Return a pointer to this function to the lexer (ffelex), which will 14822 invoke it for the next token. 14823 14824 Close-apostrophe is implicit; if this token is NAME, it is a possible 14825 typeless-constant radix specifier. */ 14826 14827static ffelexHandler 14828ffeexpr_token_apos_char_ (ffelexToken t) 14829{ 14830 ffeexprExpr_ e; 14831 ffeinfo ni; 14832 char c; 14833 ffetargetCharacterSize size; 14834 14835 if ((ffelex_token_type (t) == FFELEX_typeNAME) 14836 || (ffelex_token_type (t) == FFELEX_typeNAMES)) 14837 { 14838 if ((ffelex_token_length (t) == 1) 14839 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B', 14840 'b') 14841 || ffesrc_char_match_init (c, 'O', 'o') 14842 || ffesrc_char_match_init (c, 'X', 'x') 14843 || ffesrc_char_match_init (c, 'Z', 'z'))) 14844 { 14845 e = ffeexpr_expr_new_ (); 14846 e->type = FFEEXPR_exprtypeOPERAND_; 14847 e->token = ffeexpr_tokens_[0]; 14848 switch (c) 14849 { 14850 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match): 14851 e->u.operand = ffebld_new_conter 14852 (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1])); 14853 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]); 14854 break; 14855 14856 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match): 14857 e->u.operand = ffebld_new_conter 14858 (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1])); 14859 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]); 14860 break; 14861 14862 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match): 14863 e->u.operand = ffebld_new_conter 14864 (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1])); 14865 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]); 14866 break; 14867 14868 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match): 14869 e->u.operand = ffebld_new_conter 14870 (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1])); 14871 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]); 14872 break; 14873 14874 default: 14875 no_match: /* :::::::::::::::::::: */ 14876 assert ("not BOXZ!" == NULL); 14877 size = 0; 14878 break; 14879 } 14880 ffebld_set_info (e->u.operand, 14881 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE, 14882 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size)); 14883 ffeexpr_exprstack_push_operand_ (e); 14884 ffelex_token_kill (ffeexpr_tokens_[1]); 14885 return (ffelexHandler) ffeexpr_token_binary_; 14886 } 14887 } 14888 e = ffeexpr_expr_new_ (); 14889 e->type = FFEEXPR_exprtypeOPERAND_; 14890 e->token = ffeexpr_tokens_[0]; 14891 e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault 14892 (ffeexpr_tokens_[1])); 14893 ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT, 14894 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, 14895 ffelex_token_length (ffeexpr_tokens_[1])); 14896 ffebld_set_info (e->u.operand, ni); 14897 ffelex_token_kill (ffeexpr_tokens_[1]); 14898 ffeexpr_exprstack_push_operand_ (e); 14899 if ((ffelex_token_type (t) == FFELEX_typeNAME) 14900 || (ffelex_token_type (t) == FFELEX_typeNAMES)) 14901 { 14902 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER)) 14903 { 14904 ffebad_string (ffelex_token_text (t)); 14905 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); 14906 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]), 14907 ffelex_token_where_column (ffeexpr_tokens_[0])); 14908 ffebad_finish (); 14909 } 14910 e = ffeexpr_expr_new_ (); 14911 e->type = FFEEXPR_exprtypeBINARY_; 14912 e->token = ffelex_token_use (t); 14913 e->u.operator.op = FFEEXPR_operatorCONCATENATE_; 14914 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_; 14915 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_; 14916 ffeexpr_exprstack_push_binary_ (e); 14917 return (ffelexHandler) ffeexpr_token_rhs_ (t); 14918 } 14919 ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 (); /* Allow "'hello'(3:5)". */ 14920 return (ffelexHandler) ffeexpr_token_substrp_ (t); 14921} 14922 14923/* ffeexpr_token_name_lhs_ -- Lhs NAME 14924 14925 Return a pointer to this function to the lexer (ffelex), which will 14926 invoke it for the next token. 14927 14928 Handle a name followed by open-paren, period (RECORD.MEMBER), percent 14929 (RECORD%MEMBER), or nothing at all. */ 14930 14931static ffelexHandler 14932ffeexpr_token_name_lhs_ (ffelexToken t) 14933{ 14934 ffeexprExpr_ e; 14935 ffeexprParenType_ paren_type; 14936 ffesymbol s; 14937 ffebld expr; 14938 ffeinfo info; 14939 14940 switch (ffelex_token_type (t)) 14941 { 14942 case FFELEX_typeOPEN_PAREN: 14943 switch (ffeexpr_stack_->context) 14944 { 14945 case FFEEXPR_contextASSIGN: 14946 case FFEEXPR_contextAGOTO: 14947 case FFEEXPR_contextFILEUNIT_DF: 14948 goto just_name; /* :::::::::::::::::::: */ 14949 14950 default: 14951 break; 14952 } 14953 e = ffeexpr_expr_new_ (); 14954 e->type = FFEEXPR_exprtypeOPERAND_; 14955 e->token = ffelex_token_use (ffeexpr_tokens_[0]); 14956 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE, 14957 &paren_type); 14958 14959 switch (ffesymbol_where (s)) 14960 { 14961 case FFEINFO_whereLOCAL: 14962 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF) 14963 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recursion. */ 14964 break; 14965 14966 case FFEINFO_whereINTRINSIC: 14967 case FFEINFO_whereGLOBAL: 14968 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF) 14969 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */ 14970 break; 14971 14972 case FFEINFO_whereCOMMON: 14973 case FFEINFO_whereDUMMY: 14974 case FFEINFO_whereRESULT: 14975 break; 14976 14977 case FFEINFO_whereNONE: 14978 case FFEINFO_whereANY: 14979 break; 14980 14981 default: 14982 ffesymbol_error (s, ffeexpr_tokens_[0]); 14983 break; 14984 } 14985 14986 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY) 14987 { 14988 e->u.operand = ffebld_new_any (); 14989 ffebld_set_info (e->u.operand, ffeinfo_new_any ()); 14990 } 14991 else 14992 { 14993 e->u.operand = ffebld_new_symter (s, 14994 ffesymbol_generic (s), 14995 ffesymbol_specific (s), 14996 ffesymbol_implementation (s)); 14997 ffebld_set_info (e->u.operand, ffesymbol_info (s)); 14998 } 14999 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */ 15000 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0]; 15001 switch (paren_type) 15002 { 15003 case FFEEXPR_parentypeSUBROUTINE_: 15004 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); 15005 return 15006 (ffelexHandler) 15007 ffeexpr_rhs (ffeexpr_stack_->pool, 15008 FFEEXPR_contextACTUALARG_, 15009 ffeexpr_token_arguments_); 15010 15011 case FFEEXPR_parentypeARRAY_: 15012 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); 15013 ffeexpr_stack_->bound_list = ffesymbol_dims (s); 15014 ffeexpr_stack_->rank = 0; 15015 ffeexpr_stack_->constant = TRUE; 15016 ffeexpr_stack_->immediate = TRUE; 15017 switch (ffeexpr_stack_->context) 15018 { 15019 case FFEEXPR_contextDATAIMPDOITEM_: 15020 return 15021 (ffelexHandler) 15022 ffeexpr_rhs (ffeexpr_stack_->pool, 15023 FFEEXPR_contextDATAIMPDOINDEX_, 15024 ffeexpr_token_elements_); 15025 15026 case FFEEXPR_contextEQUIVALENCE: 15027 return 15028 (ffelexHandler) 15029 ffeexpr_rhs (ffeexpr_stack_->pool, 15030 FFEEXPR_contextEQVINDEX_, 15031 ffeexpr_token_elements_); 15032 15033 default: 15034 return 15035 (ffelexHandler) 15036 ffeexpr_rhs (ffeexpr_stack_->pool, 15037 FFEEXPR_contextINDEX_, 15038 ffeexpr_token_elements_); 15039 } 15040 15041 case FFEEXPR_parentypeSUBSTRING_: 15042 e->u.operand = ffeexpr_collapse_symter (e->u.operand, 15043 ffeexpr_tokens_[0]); 15044 return 15045 (ffelexHandler) 15046 ffeexpr_rhs (ffeexpr_stack_->pool, 15047 FFEEXPR_contextINDEX_, 15048 ffeexpr_token_substring_); 15049 15050 case FFEEXPR_parentypeEQUIVALENCE_: 15051 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); 15052 ffeexpr_stack_->bound_list = ffesymbol_dims (s); 15053 ffeexpr_stack_->rank = 0; 15054 ffeexpr_stack_->constant = TRUE; 15055 ffeexpr_stack_->immediate = TRUE; 15056 return 15057 (ffelexHandler) 15058 ffeexpr_rhs (ffeexpr_stack_->pool, 15059 FFEEXPR_contextEQVINDEX_, 15060 ffeexpr_token_equivalence_); 15061 15062 case FFEEXPR_parentypeFUNCTION_: /* Invalid case. */ 15063 case FFEEXPR_parentypeFUNSUBSTR_: /* Invalid case. */ 15064 ffesymbol_error (s, ffeexpr_tokens_[0]); 15065 /* Fall through. */ 15066 case FFEEXPR_parentypeANY_: 15067 e->u.operand = ffebld_new_any (); 15068 ffebld_set_info (e->u.operand, ffeinfo_new_any ()); 15069 return 15070 (ffelexHandler) 15071 ffeexpr_rhs (ffeexpr_stack_->pool, 15072 FFEEXPR_contextACTUALARG_, 15073 ffeexpr_token_anything_); 15074 15075 default: 15076 assert ("bad paren type" == NULL); 15077 break; 15078 } 15079 15080 case FFELEX_typeEQUALS: /* As in "VAR=". */ 15081 switch (ffeexpr_stack_->context) 15082 { 15083 case FFEEXPR_contextIMPDOITEM_: /* within 15084 "(,VAR=start,end[,incr])". */ 15085 case FFEEXPR_contextIMPDOITEMDF_: 15086 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_; 15087 break; 15088 15089 case FFEEXPR_contextDATAIMPDOITEM_: 15090 ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_; 15091 break; 15092 15093 default: 15094 break; 15095 } 15096 break; 15097 15098#if 0 15099 case FFELEX_typePERIOD: 15100 case FFELEX_typePERCENT: 15101 assert ("FOO%, FOO. not yet supported!~~" == NULL); 15102 break; 15103#endif 15104 15105 default: 15106 break; 15107 } 15108 15109just_name: /* :::::::::::::::::::: */ 15110 e = ffeexpr_expr_new_ (); 15111 e->type = FFEEXPR_exprtypeOPERAND_; 15112 e->token = ffeexpr_tokens_[0]; 15113 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], 15114 (ffeexpr_stack_->context 15115 == FFEEXPR_contextSUBROUTINEREF)); 15116 15117 switch (ffesymbol_where (s)) 15118 { 15119 case FFEINFO_whereCONSTANT: 15120 if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER) 15121 || (ffesymbol_kind (s) != FFEINFO_kindENTITY)) 15122 ffesymbol_error (s, ffeexpr_tokens_[0]); 15123 break; 15124 15125 case FFEINFO_whereIMMEDIATE: 15126 if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_) 15127 && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_)) 15128 ffesymbol_error (s, ffeexpr_tokens_[0]); 15129 break; 15130 15131 case FFEINFO_whereLOCAL: 15132 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF) 15133 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recurse!. */ 15134 break; 15135 15136 case FFEINFO_whereINTRINSIC: 15137 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF) 15138 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */ 15139 break; 15140 15141 default: 15142 break; 15143 } 15144 15145 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY) 15146 { 15147 expr = ffebld_new_any (); 15148 info = ffeinfo_new_any (); 15149 ffebld_set_info (expr, info); 15150 } 15151 else 15152 { 15153 expr = ffebld_new_symter (s, 15154 ffesymbol_generic (s), 15155 ffesymbol_specific (s), 15156 ffesymbol_implementation (s)); 15157 info = ffesymbol_info (s); 15158 ffebld_set_info (expr, info); 15159 if (ffesymbol_is_doiter (s)) 15160 { 15161 ffebad_start (FFEBAD_DOITER); 15162 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), 15163 ffelex_token_where_column (ffeexpr_tokens_[0])); 15164 ffest_ffebad_here_doiter (1, s); 15165 ffebad_string (ffesymbol_text (s)); 15166 ffebad_finish (); 15167 } 15168 expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]); 15169 } 15170 15171 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF) 15172 { 15173 if (ffebld_op (expr) == FFEBLD_opANY) 15174 { 15175 expr = ffebld_new_any (); 15176 ffebld_set_info (expr, ffeinfo_new_any ()); 15177 } 15178 else 15179 { 15180 expr = ffebld_new_subrref (expr, NULL); /* No argument list. */ 15181 if (ffesymbol_generic (s) != FFEINTRIN_genNONE) 15182 ffeintrin_fulfill_generic (&expr, &info, e->token); 15183 else if (ffesymbol_specific (s) != FFEINTRIN_specNONE) 15184 ffeintrin_fulfill_specific (&expr, &info, NULL, e->token); 15185 else 15186 ffeexpr_fulfill_call_ (&expr, e->token); 15187 15188 if (ffebld_op (expr) != FFEBLD_opANY) 15189 ffebld_set_info (expr, 15190 ffeinfo_new (ffeinfo_basictype (info), 15191 ffeinfo_kindtype (info), 15192 0, 15193 FFEINFO_kindENTITY, 15194 FFEINFO_whereFLEETING, 15195 ffeinfo_size (info))); 15196 else 15197 ffebld_set_info (expr, ffeinfo_new_any ()); 15198 } 15199 } 15200 15201 e->u.operand = expr; 15202 ffeexpr_exprstack_push_operand_ (e); 15203 return (ffelexHandler) ffeexpr_finished_ (t); 15204} 15205 15206/* ffeexpr_token_name_arg_ -- Rhs NAME 15207 15208 Return a pointer to this function to the lexer (ffelex), which will 15209 invoke it for the next token. 15210 15211 Handle first token in an actual-arg (or possible actual-arg) context 15212 being a NAME, and use second token to refine the context. */ 15213 15214static ffelexHandler 15215ffeexpr_token_name_arg_ (ffelexToken t) 15216{ 15217 switch (ffelex_token_type (t)) 15218 { 15219 case FFELEX_typeCLOSE_PAREN: 15220 case FFELEX_typeCOMMA: 15221 switch (ffeexpr_stack_->context) 15222 { 15223 case FFEEXPR_contextINDEXORACTUALARG_: 15224 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_; 15225 break; 15226 15227 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 15228 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_; 15229 break; 15230 15231 default: 15232 break; 15233 } 15234 break; 15235 15236 default: 15237 switch (ffeexpr_stack_->context) 15238 { 15239 case FFEEXPR_contextACTUALARG_: 15240 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; 15241 break; 15242 15243 case FFEEXPR_contextINDEXORACTUALARG_: 15244 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; 15245 break; 15246 15247 case FFEEXPR_contextSFUNCDEFACTUALARG_: 15248 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; 15249 break; 15250 15251 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 15252 ffeexpr_stack_->context 15253 = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; 15254 break; 15255 15256 default: 15257 assert ("bad context in _name_arg_" == NULL); 15258 break; 15259 } 15260 break; 15261 } 15262 15263 return (ffelexHandler) ffeexpr_token_name_rhs_ (t); 15264} 15265 15266/* ffeexpr_token_name_rhs_ -- Rhs NAME 15267 15268 Return a pointer to this function to the lexer (ffelex), which will 15269 invoke it for the next token. 15270 15271 Handle a name followed by open-paren, apostrophe (O'octal-const', 15272 Z'hex-const', or X'hex-const'), period (RECORD.MEMBER). 15273 15274 26-Nov-91 JCB 1.2 15275 When followed by apostrophe or quote, set lex hexnum flag on so 15276 [0-9] as first char of next token seen as starting a potentially 15277 hex number (NAME). 15278 04-Oct-91 JCB 1.1 15279 In case of intrinsic, decorate its SYMTER with the type info for 15280 the specific intrinsic. */ 15281 15282static ffelexHandler 15283ffeexpr_token_name_rhs_ (ffelexToken t) 15284{ 15285 ffeexprExpr_ e; 15286 ffeexprParenType_ paren_type; 15287 ffesymbol s; 15288 bool sfdef; 15289 15290 switch (ffelex_token_type (t)) 15291 { 15292 case FFELEX_typeQUOTE: 15293 case FFELEX_typeAPOSTROPHE: 15294 ffeexpr_tokens_[1] = ffelex_token_use (t); 15295 ffelex_set_hexnum (TRUE); 15296 return (ffelexHandler) ffeexpr_token_name_apos_; 15297 15298 case FFELEX_typeOPEN_PAREN: 15299 e = ffeexpr_expr_new_ (); 15300 e->type = FFEEXPR_exprtypeOPERAND_; 15301 e->token = ffelex_token_use (ffeexpr_tokens_[0]); 15302 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE, 15303 &paren_type); 15304 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY) 15305 e->u.operand = ffebld_new_any (); 15306 else 15307 e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s), 15308 ffesymbol_specific (s), 15309 ffesymbol_implementation (s)); 15310 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */ 15311 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0]; 15312 switch (ffeexpr_context_outer_ (ffeexpr_stack_)) 15313 { 15314 case FFEEXPR_contextSFUNCDEF: 15315 case FFEEXPR_contextSFUNCDEFINDEX_: 15316 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: 15317 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: 15318 sfdef = TRUE; 15319 break; 15320 15321 case FFEEXPR_contextSFUNCDEFACTUALARG_: 15322 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 15323 assert ("weird context!" == NULL); 15324 sfdef = FALSE; 15325 break; 15326 15327 default: 15328 sfdef = FALSE; 15329 break; 15330 } 15331 switch (paren_type) 15332 { 15333 case FFEEXPR_parentypeFUNCTION_: 15334 ffebld_set_info (e->u.operand, ffesymbol_info (s)); 15335 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); 15336 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) 15337 { /* A statement function. */ 15338 ffeexpr_stack_->num_args 15339 = ffebld_list_length 15340 (ffeexpr_stack_->next_dummy 15341 = ffesymbol_dummyargs (s)); 15342 ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */ 15343 } 15344 else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC) 15345 && !ffe_is_pedantic_not_90 () 15346 && ((ffesymbol_implementation (s) 15347 == FFEINTRIN_impICHAR) 15348 || (ffesymbol_implementation (s) 15349 == FFEINTRIN_impIACHAR) 15350 || (ffesymbol_implementation (s) 15351 == FFEINTRIN_impLEN))) 15352 { /* Allow arbitrary concatenations. */ 15353 return 15354 (ffelexHandler) 15355 ffeexpr_rhs (ffeexpr_stack_->pool, 15356 sfdef 15357 ? FFEEXPR_contextSFUNCDEF 15358 : FFEEXPR_contextLET, 15359 ffeexpr_token_arguments_); 15360 } 15361 return 15362 (ffelexHandler) 15363 ffeexpr_rhs (ffeexpr_stack_->pool, 15364 sfdef 15365 ? FFEEXPR_contextSFUNCDEFACTUALARG_ 15366 : FFEEXPR_contextACTUALARG_, 15367 ffeexpr_token_arguments_); 15368 15369 case FFEEXPR_parentypeARRAY_: 15370 ffebld_set_info (e->u.operand, 15371 ffesymbol_info (ffebld_symter (e->u.operand))); 15372 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); 15373 ffeexpr_stack_->bound_list = ffesymbol_dims (s); 15374 ffeexpr_stack_->rank = 0; 15375 ffeexpr_stack_->constant = TRUE; 15376 ffeexpr_stack_->immediate = TRUE; 15377 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 15378 sfdef 15379 ? FFEEXPR_contextSFUNCDEFINDEX_ 15380 : FFEEXPR_contextINDEX_, 15381 ffeexpr_token_elements_); 15382 15383 case FFEEXPR_parentypeSUBSTRING_: 15384 ffebld_set_info (e->u.operand, 15385 ffesymbol_info (ffebld_symter (e->u.operand))); 15386 e->u.operand = ffeexpr_collapse_symter (e->u.operand, 15387 ffeexpr_tokens_[0]); 15388 return 15389 (ffelexHandler) 15390 ffeexpr_rhs (ffeexpr_stack_->pool, 15391 sfdef 15392 ? FFEEXPR_contextSFUNCDEFINDEX_ 15393 : FFEEXPR_contextINDEX_, 15394 ffeexpr_token_substring_); 15395 15396 case FFEEXPR_parentypeFUNSUBSTR_: 15397 return 15398 (ffelexHandler) 15399 ffeexpr_rhs (ffeexpr_stack_->pool, 15400 sfdef 15401 ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_ 15402 : FFEEXPR_contextINDEXORACTUALARG_, 15403 ffeexpr_token_funsubstr_); 15404 15405 case FFEEXPR_parentypeANY_: 15406 ffebld_set_info (e->u.operand, ffesymbol_info (s)); 15407 return 15408 (ffelexHandler) 15409 ffeexpr_rhs (ffeexpr_stack_->pool, 15410 sfdef 15411 ? FFEEXPR_contextSFUNCDEFACTUALARG_ 15412 : FFEEXPR_contextACTUALARG_, 15413 ffeexpr_token_anything_); 15414 15415 default: 15416 assert ("bad paren type" == NULL); 15417 break; 15418 } 15419 15420 case FFELEX_typeEQUALS: /* As in "VAR=". */ 15421 switch (ffeexpr_stack_->context) 15422 { 15423 case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */ 15424 case FFEEXPR_contextIMPDOITEMDF_: 15425 ffeexpr_stack_->is_rhs = FALSE; /* Really an lhs construct. */ 15426 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_; 15427 break; 15428 15429 default: 15430 break; 15431 } 15432 break; 15433 15434#if 0 15435 case FFELEX_typePERIOD: 15436 case FFELEX_typePERCENT: 15437 ~~Support these two someday, though not required 15438 assert ("FOO%, FOO. not yet supported!~~" == NULL); 15439 break; 15440#endif 15441 15442 default: 15443 break; 15444 } 15445 15446 switch (ffeexpr_stack_->context) 15447 { 15448 case FFEEXPR_contextINDEXORACTUALARG_: 15449 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 15450 assert ("strange context" == NULL); 15451 break; 15452 15453 default: 15454 break; 15455 } 15456 15457 e = ffeexpr_expr_new_ (); 15458 e->type = FFEEXPR_exprtypeOPERAND_; 15459 e->token = ffeexpr_tokens_[0]; 15460 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE); 15461 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY) 15462 { 15463 e->u.operand = ffebld_new_any (); 15464 ffebld_set_info (e->u.operand, ffeinfo_new_any ()); 15465 } 15466 else 15467 { 15468 e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE, 15469 ffesymbol_specific (s), 15470 ffesymbol_implementation (s)); 15471 if (ffesymbol_specific (s) == FFEINTRIN_specNONE) 15472 ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s))); 15473 else 15474 { /* Decorate the SYMTER with the actual type 15475 of the intrinsic. */ 15476 ffebld_set_info (e->u.operand, ffeinfo_new 15477 (ffeintrin_basictype (ffesymbol_specific (s)), 15478 ffeintrin_kindtype (ffesymbol_specific (s)), 15479 0, 15480 ffesymbol_kind (s), 15481 ffesymbol_where (s), 15482 FFETARGET_charactersizeNONE)); 15483 } 15484 if (ffesymbol_is_doiter (s)) 15485 ffebld_symter_set_is_doiter (e->u.operand, TRUE); 15486 e->u.operand = ffeexpr_collapse_symter (e->u.operand, 15487 ffeexpr_tokens_[0]); 15488 } 15489 ffeexpr_exprstack_push_operand_ (e); 15490 return (ffelexHandler) ffeexpr_token_binary_ (t); 15491} 15492 15493/* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE 15494 15495 Return a pointer to this function to the lexer (ffelex), which will 15496 invoke it for the next token. 15497 15498 Expecting a NAME token, analyze the previous NAME token to see what kind, 15499 if any, typeless constant we've got. 15500 15501 01-Sep-90 JCB 1.1 15502 Expect a NAME instead of CHARACTER in this situation. */ 15503 15504static ffelexHandler 15505ffeexpr_token_name_apos_ (ffelexToken t) 15506{ 15507 ffeexprExpr_ e; 15508 15509 ffelex_set_hexnum (FALSE); 15510 15511 switch (ffelex_token_type (t)) 15512 { 15513 case FFELEX_typeNAME: 15514 ffeexpr_tokens_[2] = ffelex_token_use (t); 15515 return (ffelexHandler) ffeexpr_token_name_apos_name_; 15516 15517 default: 15518 break; 15519 } 15520 15521 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER)) 15522 { 15523 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0])); 15524 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), 15525 ffelex_token_where_column (ffeexpr_tokens_[0])); 15526 ffebad_here (1, ffelex_token_where_line (t), 15527 ffelex_token_where_column (t)); 15528 ffebad_finish (); 15529 } 15530 15531 ffelex_token_kill (ffeexpr_tokens_[1]); 15532 15533 e = ffeexpr_expr_new_ (); 15534 e->type = FFEEXPR_exprtypeOPERAND_; 15535 e->u.operand = ffebld_new_any (); 15536 ffebld_set_info (e->u.operand, ffeinfo_new_any ()); 15537 e->token = ffeexpr_tokens_[0]; 15538 ffeexpr_exprstack_push_operand_ (e); 15539 15540 return (ffelexHandler) ffeexpr_token_binary_ (t); 15541} 15542 15543/* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME 15544 15545 Return a pointer to this function to the lexer (ffelex), which will 15546 invoke it for the next token. 15547 15548 Expecting an APOSTROPHE token, analyze the previous NAME token to see 15549 what kind, if any, typeless constant we've got. */ 15550 15551static ffelexHandler 15552ffeexpr_token_name_apos_name_ (ffelexToken t) 15553{ 15554 ffeexprExpr_ e; 15555 char c; 15556 15557 e = ffeexpr_expr_new_ (); 15558 e->type = FFEEXPR_exprtypeOPERAND_; 15559 e->token = ffeexpr_tokens_[0]; 15560 15561 if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1])) 15562 && (ffelex_token_length (ffeexpr_tokens_[0]) == 1) 15563 && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]), 15564 'B', 'b') 15565 || ffesrc_char_match_init (c, 'O', 'o') 15566 || ffesrc_char_match_init (c, 'X', 'x') 15567 || ffesrc_char_match_init (c, 'Z', 'z'))) 15568 { 15569 ffetargetCharacterSize size; 15570 15571 if (!ffe_is_typeless_boz ()) { 15572 15573 switch (c) 15574 { 15575 case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch): 15576 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary 15577 (ffeexpr_tokens_[2])); 15578 break; 15579 15580 case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch): 15581 e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal 15582 (ffeexpr_tokens_[2])); 15583 break; 15584 15585 case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch): 15586 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex 15587 (ffeexpr_tokens_[2])); 15588 break; 15589 15590 case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch): 15591 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex 15592 (ffeexpr_tokens_[2])); 15593 break; 15594 15595 default: 15596 no_imatch: /* :::::::::::::::::::: */ 15597 assert ("not BOXZ!" == NULL); 15598 abort (); 15599 } 15600 15601 ffebld_set_info (e->u.operand, 15602 ffeinfo_new (FFEINFO_basictypeINTEGER, 15603 FFEINFO_kindtypeINTEGERDEFAULT, 0, 15604 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, 15605 FFETARGET_charactersizeNONE)); 15606 ffeexpr_exprstack_push_operand_ (e); 15607 ffelex_token_kill (ffeexpr_tokens_[1]); 15608 ffelex_token_kill (ffeexpr_tokens_[2]); 15609 return (ffelexHandler) ffeexpr_token_binary_; 15610 } 15611 15612 switch (c) 15613 { 15614 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match): 15615 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm 15616 (ffeexpr_tokens_[2])); 15617 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]); 15618 break; 15619 15620 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match): 15621 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om 15622 (ffeexpr_tokens_[2])); 15623 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]); 15624 break; 15625 15626 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match): 15627 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm 15628 (ffeexpr_tokens_[2])); 15629 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]); 15630 break; 15631 15632 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match): 15633 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm 15634 (ffeexpr_tokens_[2])); 15635 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]); 15636 break; 15637 15638 default: 15639 no_match: /* :::::::::::::::::::: */ 15640 assert ("not BOXZ!" == NULL); 15641 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm 15642 (ffeexpr_tokens_[2])); 15643 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]); 15644 break; 15645 } 15646 ffebld_set_info (e->u.operand, 15647 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE, 15648 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size)); 15649 ffeexpr_exprstack_push_operand_ (e); 15650 ffelex_token_kill (ffeexpr_tokens_[1]); 15651 ffelex_token_kill (ffeexpr_tokens_[2]); 15652 return (ffelexHandler) ffeexpr_token_binary_; 15653 } 15654 15655 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER)) 15656 { 15657 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0])); 15658 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), 15659 ffelex_token_where_column (ffeexpr_tokens_[0])); 15660 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); 15661 ffebad_finish (); 15662 } 15663 15664 ffelex_token_kill (ffeexpr_tokens_[1]); 15665 ffelex_token_kill (ffeexpr_tokens_[2]); 15666 15667 e->type = FFEEXPR_exprtypeOPERAND_; 15668 e->u.operand = ffebld_new_any (); 15669 ffebld_set_info (e->u.operand, ffeinfo_new_any ()); 15670 e->token = ffeexpr_tokens_[0]; 15671 ffeexpr_exprstack_push_operand_ (e); 15672 15673 switch (ffelex_token_type (t)) 15674 { 15675 case FFELEX_typeAPOSTROPHE: 15676 case FFELEX_typeQUOTE: 15677 return (ffelexHandler) ffeexpr_token_binary_; 15678 15679 default: 15680 return (ffelexHandler) ffeexpr_token_binary_ (t); 15681 } 15682} 15683 15684/* ffeexpr_token_percent_ -- Rhs PERCENT 15685 15686 Handle a percent sign possibly followed by "LOC". If followed instead 15687 by "VAL", "REF", or "DESCR", issue an error message and substitute 15688 "LOC". If followed by something else, treat the percent sign as a 15689 spurious incorrect token and reprocess the token via _rhs_. */ 15690 15691static ffelexHandler 15692ffeexpr_token_percent_ (ffelexToken t) 15693{ 15694 switch (ffelex_token_type (t)) 15695 { 15696 case FFELEX_typeNAME: 15697 case FFELEX_typeNAMES: 15698 ffeexpr_stack_->percent = ffeexpr_percent_ (t); 15699 ffeexpr_tokens_[1] = ffelex_token_use (t); 15700 return (ffelexHandler) ffeexpr_token_percent_name_; 15701 15702 default: 15703 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) 15704 { 15705 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), 15706 ffelex_token_where_column (ffeexpr_tokens_[0])); 15707 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), 15708 ffelex_token_where_column (ffeexpr_stack_->first_token)); 15709 ffebad_finish (); 15710 } 15711 ffelex_token_kill (ffeexpr_tokens_[0]); 15712 return (ffelexHandler) ffeexpr_token_rhs_ (t); 15713 } 15714} 15715 15716/* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME 15717 15718 Make sure the token is OPEN_PAREN and prepare for the one-item list of 15719 LHS expressions. Else display an error message. */ 15720 15721static ffelexHandler 15722ffeexpr_token_percent_name_ (ffelexToken t) 15723{ 15724 ffelexHandler nexthandler; 15725 15726 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN) 15727 { 15728 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) 15729 { 15730 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), 15731 ffelex_token_where_column (ffeexpr_tokens_[0])); 15732 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), 15733 ffelex_token_where_column (ffeexpr_stack_->first_token)); 15734 ffebad_finish (); 15735 } 15736 ffelex_token_kill (ffeexpr_tokens_[0]); 15737 nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]); 15738 ffelex_token_kill (ffeexpr_tokens_[1]); 15739 return (ffelexHandler) (*nexthandler) (t); 15740 } 15741 15742 switch (ffeexpr_stack_->percent) 15743 { 15744 default: 15745 if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT)) 15746 { 15747 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), 15748 ffelex_token_where_column (ffeexpr_tokens_[0])); 15749 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1])); 15750 ffebad_finish (); 15751 } 15752 ffeexpr_stack_->percent = FFEEXPR_percentLOC_; 15753 /* Fall through. */ 15754 case FFEEXPR_percentLOC_: 15755 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0]; 15756 ffelex_token_kill (ffeexpr_tokens_[1]); 15757 ffeexpr_stack_->tokens[1] = ffelex_token_use (t); 15758 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 15759 FFEEXPR_contextLOC_, 15760 ffeexpr_cb_end_loc_); 15761 } 15762} 15763 15764/* ffeexpr_make_float_const_ -- Make a floating-point constant 15765 15766 See prototype. 15767 15768 Pass 'E', 'D', or 'Q' for exponent letter. */ 15769 15770static void 15771ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer, 15772 ffelexToken decimal, ffelexToken fraction, 15773 ffelexToken exponent, ffelexToken exponent_sign, 15774 ffelexToken exponent_digits) 15775{ 15776 ffeexprExpr_ e; 15777 15778 e = ffeexpr_expr_new_ (); 15779 e->type = FFEEXPR_exprtypeOPERAND_; 15780 if (integer != NULL) 15781 e->token = ffelex_token_use (integer); 15782 else 15783 { 15784 assert (decimal != NULL); 15785 e->token = ffelex_token_use (decimal); 15786 } 15787 15788 switch (exp_letter) 15789 { 15790#if !FFETARGET_okREALQUAD 15791 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match): 15792 if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED)) 15793 { 15794 ffebad_here (0, ffelex_token_where_line (e->token), 15795 ffelex_token_where_column (e->token)); 15796 ffebad_finish (); 15797 } 15798 goto match_d; /* The FFESRC_CASE_* macros don't 15799 allow fall-through! */ 15800#endif 15801 15802 case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match): 15803 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble 15804 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits)); 15805 ffebld_set_info (e->u.operand, 15806 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE, 15807 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); 15808 break; 15809 15810 case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match): 15811 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault 15812 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits)); 15813 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL, 15814 FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY, 15815 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); 15816 break; 15817 15818#if FFETARGET_okREALQUAD 15819 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match): 15820 e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad 15821 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits)); 15822 ffebld_set_info (e->u.operand, 15823 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD, 15824 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); 15825 break; 15826#endif 15827 15828 case 'I': /* Make an integer. */ 15829 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault 15830 (ffeexpr_tokens_[0])); 15831 ffebld_set_info (e->u.operand, 15832 ffeinfo_new (FFEINFO_basictypeINTEGER, 15833 FFEINFO_kindtypeINTEGERDEFAULT, 0, 15834 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, 15835 FFETARGET_charactersizeNONE)); 15836 break; 15837 15838 default: 15839 no_match: /* :::::::::::::::::::: */ 15840 assert ("Lost the exponent letter!" == NULL); 15841 } 15842 15843 ffeexpr_exprstack_push_operand_ (e); 15844} 15845 15846/* Just like ffesymbol_declare_local, except performs any implicit info 15847 assignment necessary. */ 15848 15849static ffesymbol 15850ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin) 15851{ 15852 ffesymbol s; 15853 ffeinfoKind k; 15854 bool bad; 15855 15856 s = ffesymbol_declare_local (t, maybe_intrin); 15857 15858 switch (ffeexpr_context_outer_ (ffeexpr_stack_)) 15859 /* Special-case these since they can involve a different concept 15860 of "state" (in the stmtfunc name space). */ 15861 { 15862 case FFEEXPR_contextDATAIMPDOINDEX_: 15863 case FFEEXPR_contextDATAIMPDOCTRL_: 15864 if (ffeexpr_context_outer_ (ffeexpr_stack_) 15865 == FFEEXPR_contextDATAIMPDOINDEX_) 15866 s = ffeexpr_sym_impdoitem_ (s, t); 15867 else 15868 if (ffeexpr_stack_->is_rhs) 15869 s = ffeexpr_sym_impdoitem_ (s, t); 15870 else 15871 s = ffeexpr_sym_lhs_impdoctrl_ (s, t); 15872 bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY) 15873 || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT) 15874 && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE)); 15875 if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY)) 15876 ffesymbol_error (s, t); 15877 return s; 15878 15879 default: 15880 break; 15881 } 15882 15883 switch ((ffesymbol_sfdummyparent (s) == NULL) 15884 ? ffesymbol_state (s) 15885 : FFESYMBOL_stateUNDERSTOOD) 15886 { 15887 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr 15888 context. */ 15889 if (!ffest_seen_first_exec ()) 15890 goto seen; /* :::::::::::::::::::: */ 15891 /* Fall through. */ 15892 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */ 15893 switch (ffeexpr_context_outer_ (ffeexpr_stack_)) 15894 { 15895 case FFEEXPR_contextSUBROUTINEREF: 15896 s = ffeexpr_sym_lhs_call_ (s, t); 15897 break; 15898 15899 case FFEEXPR_contextFILEEXTFUNC: 15900 s = ffeexpr_sym_lhs_extfunc_ (s, t); 15901 break; 15902 15903 case FFEEXPR_contextSFUNCDEFACTUALARG_: 15904 s = ffecom_sym_exec_transition (s); 15905 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) 15906 goto understood; /* :::::::::::::::::::: */ 15907 /* Fall through. */ 15908 case FFEEXPR_contextACTUALARG_: 15909 s = ffeexpr_sym_rhs_actualarg_ (s, t); 15910 break; 15911 15912 case FFEEXPR_contextDATA: 15913 if (ffeexpr_stack_->is_rhs) 15914 s = ffeexpr_sym_rhs_let_ (s, t); 15915 else 15916 s = ffeexpr_sym_lhs_data_ (s, t); 15917 break; 15918 15919 case FFEEXPR_contextDATAIMPDOITEM_: 15920 s = ffeexpr_sym_lhs_data_ (s, t); 15921 break; 15922 15923 case FFEEXPR_contextSFUNCDEF: 15924 case FFEEXPR_contextSFUNCDEFINDEX_: 15925 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: 15926 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: 15927 s = ffecom_sym_exec_transition (s); 15928 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) 15929 goto understood; /* :::::::::::::::::::: */ 15930 /* Fall through. */ 15931 case FFEEXPR_contextLET: 15932 case FFEEXPR_contextPAREN_: 15933 case FFEEXPR_contextACTUALARGEXPR_: 15934 case FFEEXPR_contextINDEXORACTUALARGEXPR_: 15935 case FFEEXPR_contextASSIGN: 15936 case FFEEXPR_contextIOLIST: 15937 case FFEEXPR_contextIOLISTDF: 15938 case FFEEXPR_contextDO: 15939 case FFEEXPR_contextDOWHILE: 15940 case FFEEXPR_contextAGOTO: 15941 case FFEEXPR_contextCGOTO: 15942 case FFEEXPR_contextIF: 15943 case FFEEXPR_contextARITHIF: 15944 case FFEEXPR_contextFORMAT: 15945 case FFEEXPR_contextSTOP: 15946 case FFEEXPR_contextRETURN: 15947 case FFEEXPR_contextSELECTCASE: 15948 case FFEEXPR_contextCASE: 15949 case FFEEXPR_contextFILEASSOC: 15950 case FFEEXPR_contextFILEINT: 15951 case FFEEXPR_contextFILEDFINT: 15952 case FFEEXPR_contextFILELOG: 15953 case FFEEXPR_contextFILENUM: 15954 case FFEEXPR_contextFILENUMAMBIG: 15955 case FFEEXPR_contextFILECHAR: 15956 case FFEEXPR_contextFILENUMCHAR: 15957 case FFEEXPR_contextFILEDFCHAR: 15958 case FFEEXPR_contextFILEKEY: 15959 case FFEEXPR_contextFILEUNIT: 15960 case FFEEXPR_contextFILEUNIT_DF: 15961 case FFEEXPR_contextFILEUNITAMBIG: 15962 case FFEEXPR_contextFILEFORMAT: 15963 case FFEEXPR_contextFILENAMELIST: 15964 case FFEEXPR_contextFILEVXTCODE: 15965 case FFEEXPR_contextINDEX_: 15966 case FFEEXPR_contextIMPDOITEM_: 15967 case FFEEXPR_contextIMPDOITEMDF_: 15968 case FFEEXPR_contextIMPDOCTRL_: 15969 case FFEEXPR_contextLOC_: 15970 if (ffeexpr_stack_->is_rhs) 15971 s = ffeexpr_sym_rhs_let_ (s, t); 15972 else 15973 s = ffeexpr_sym_lhs_let_ (s, t); 15974 break; 15975 15976 case FFEEXPR_contextCHARACTERSIZE: 15977 case FFEEXPR_contextEQUIVALENCE: 15978 case FFEEXPR_contextINCLUDE: 15979 case FFEEXPR_contextPARAMETER: 15980 case FFEEXPR_contextDIMLIST: 15981 case FFEEXPR_contextDIMLISTCOMMON: 15982 case FFEEXPR_contextKINDTYPE: 15983 case FFEEXPR_contextINITVAL: 15984 case FFEEXPR_contextEQVINDEX_: 15985 break; /* Will turn into errors below. */ 15986 15987 default: 15988 ffesymbol_error (s, t); 15989 break; 15990 } 15991 /* Fall through. */ 15992 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */ 15993 understood: /* :::::::::::::::::::: */ 15994 k = ffesymbol_kind (s); 15995 switch (ffeexpr_context_outer_ (ffeexpr_stack_)) 15996 { 15997 case FFEEXPR_contextSUBROUTINEREF: 15998 bad = ((k != FFEINFO_kindSUBROUTINE) 15999 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC) 16000 || (k != FFEINFO_kindNONE))); 16001 break; 16002 16003 case FFEEXPR_contextFILEEXTFUNC: 16004 bad = (k != FFEINFO_kindFUNCTION) 16005 || (ffesymbol_where (s) != FFEINFO_whereGLOBAL); 16006 break; 16007 16008 case FFEEXPR_contextSFUNCDEFACTUALARG_: 16009 case FFEEXPR_contextACTUALARG_: 16010 switch (k) 16011 { 16012 case FFEINFO_kindENTITY: 16013 bad = FALSE; 16014 break; 16015 16016 case FFEINFO_kindFUNCTION: 16017 case FFEINFO_kindSUBROUTINE: 16018 bad 16019 = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL) 16020 && (ffesymbol_where (s) != FFEINFO_whereDUMMY) 16021 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC) 16022 || !ffeintrin_is_actualarg (ffesymbol_specific (s)))); 16023 break; 16024 16025 case FFEINFO_kindNONE: 16026 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC) 16027 { 16028 bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s))); 16029 break; 16030 } 16031 16032 /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY, 16033 and in the former case, attrsTYPE is set, so we 16034 see this as an error as we should, since CHAR*(*) 16035 cannot be actually referenced in a main/block data 16036 program unit. */ 16037 16038 if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY 16039 | FFESYMBOL_attrsEXTERNAL 16040 | FFESYMBOL_attrsTYPE)) 16041 == FFESYMBOL_attrsEXTERNAL) 16042 bad = FALSE; 16043 else 16044 bad = TRUE; 16045 break; 16046 16047 default: 16048 bad = TRUE; 16049 break; 16050 } 16051 break; 16052 16053 case FFEEXPR_contextDATA: 16054 if (ffeexpr_stack_->is_rhs) 16055 bad = (k != FFEINFO_kindENTITY) 16056 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT); 16057 else 16058 bad = (k != FFEINFO_kindENTITY) 16059 || ((ffesymbol_where (s) != FFEINFO_whereNONE) 16060 && (ffesymbol_where (s) != FFEINFO_whereLOCAL) 16061 && (ffesymbol_where (s) != FFEINFO_whereCOMMON)); 16062 break; 16063 16064 case FFEEXPR_contextDATAIMPDOITEM_: 16065 bad = TRUE; /* Unadorned item never valid. */ 16066 break; 16067 16068 case FFEEXPR_contextSFUNCDEF: 16069 case FFEEXPR_contextSFUNCDEFINDEX_: 16070 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: 16071 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: 16072 case FFEEXPR_contextLET: 16073 case FFEEXPR_contextPAREN_: 16074 case FFEEXPR_contextACTUALARGEXPR_: 16075 case FFEEXPR_contextINDEXORACTUALARGEXPR_: 16076 case FFEEXPR_contextASSIGN: 16077 case FFEEXPR_contextIOLIST: 16078 case FFEEXPR_contextIOLISTDF: 16079 case FFEEXPR_contextDO: 16080 case FFEEXPR_contextDOWHILE: 16081 case FFEEXPR_contextAGOTO: 16082 case FFEEXPR_contextCGOTO: 16083 case FFEEXPR_contextIF: 16084 case FFEEXPR_contextARITHIF: 16085 case FFEEXPR_contextFORMAT: 16086 case FFEEXPR_contextSTOP: 16087 case FFEEXPR_contextRETURN: 16088 case FFEEXPR_contextSELECTCASE: 16089 case FFEEXPR_contextCASE: 16090 case FFEEXPR_contextFILEASSOC: 16091 case FFEEXPR_contextFILEINT: 16092 case FFEEXPR_contextFILEDFINT: 16093 case FFEEXPR_contextFILELOG: 16094 case FFEEXPR_contextFILENUM: 16095 case FFEEXPR_contextFILENUMAMBIG: 16096 case FFEEXPR_contextFILECHAR: 16097 case FFEEXPR_contextFILENUMCHAR: 16098 case FFEEXPR_contextFILEDFCHAR: 16099 case FFEEXPR_contextFILEKEY: 16100 case FFEEXPR_contextFILEUNIT: 16101 case FFEEXPR_contextFILEUNIT_DF: 16102 case FFEEXPR_contextFILEUNITAMBIG: 16103 case FFEEXPR_contextFILEFORMAT: 16104 case FFEEXPR_contextFILENAMELIST: 16105 case FFEEXPR_contextFILEVXTCODE: 16106 case FFEEXPR_contextINDEX_: 16107 case FFEEXPR_contextIMPDOITEM_: 16108 case FFEEXPR_contextIMPDOITEMDF_: 16109 case FFEEXPR_contextIMPDOCTRL_: 16110 case FFEEXPR_contextLOC_: 16111 bad = (k != FFEINFO_kindENTITY); /* This catches "SUBROUTINE 16112 X(A);EXTERNAL A;CALL 16113 Y(A);B=A", for example. */ 16114 break; 16115 16116 case FFEEXPR_contextCHARACTERSIZE: 16117 case FFEEXPR_contextEQUIVALENCE: 16118 case FFEEXPR_contextPARAMETER: 16119 case FFEEXPR_contextDIMLIST: 16120 case FFEEXPR_contextDIMLISTCOMMON: 16121 case FFEEXPR_contextKINDTYPE: 16122 case FFEEXPR_contextINITVAL: 16123 case FFEEXPR_contextEQVINDEX_: 16124 bad = (k != FFEINFO_kindENTITY) 16125 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT); 16126 break; 16127 16128 case FFEEXPR_contextINCLUDE: 16129 bad = TRUE; 16130 break; 16131 16132 default: 16133 bad = TRUE; 16134 break; 16135 } 16136 if (bad && (k != FFEINFO_kindANY)) 16137 ffesymbol_error (s, t); 16138 return s; 16139 16140 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */ 16141 seen: /* :::::::::::::::::::: */ 16142 switch (ffeexpr_context_outer_ (ffeexpr_stack_)) 16143 { 16144 case FFEEXPR_contextPARAMETER: 16145 if (ffeexpr_stack_->is_rhs) 16146 ffesymbol_error (s, t); 16147 else 16148 s = ffeexpr_sym_lhs_parameter_ (s, t); 16149 break; 16150 16151 case FFEEXPR_contextDATA: 16152 s = ffecom_sym_exec_transition (s); 16153 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) 16154 goto understood; /* :::::::::::::::::::: */ 16155 if (ffeexpr_stack_->is_rhs) 16156 ffesymbol_error (s, t); 16157 else 16158 s = ffeexpr_sym_lhs_data_ (s, t); 16159 goto understood; /* :::::::::::::::::::: */ 16160 16161 case FFEEXPR_contextDATAIMPDOITEM_: 16162 s = ffecom_sym_exec_transition (s); 16163 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) 16164 goto understood; /* :::::::::::::::::::: */ 16165 s = ffeexpr_sym_lhs_data_ (s, t); 16166 goto understood; /* :::::::::::::::::::: */ 16167 16168 case FFEEXPR_contextEQUIVALENCE: 16169 s = ffeexpr_sym_lhs_equivalence_ (s, t); 16170 break; 16171 16172 case FFEEXPR_contextDIMLIST: 16173 s = ffeexpr_sym_rhs_dimlist_ (s, t); 16174 break; 16175 16176 case FFEEXPR_contextCHARACTERSIZE: 16177 case FFEEXPR_contextKINDTYPE: 16178 case FFEEXPR_contextDIMLISTCOMMON: 16179 case FFEEXPR_contextINITVAL: 16180 case FFEEXPR_contextEQVINDEX_: 16181 ffesymbol_error (s, t); 16182 break; 16183 16184 case FFEEXPR_contextINCLUDE: 16185 ffesymbol_error (s, t); 16186 break; 16187 16188 case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */ 16189 case FFEEXPR_contextSFUNCDEFACTUALARG_: 16190 s = ffecom_sym_exec_transition (s); 16191 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) 16192 goto understood; /* :::::::::::::::::::: */ 16193 s = ffeexpr_sym_rhs_actualarg_ (s, t); 16194 goto understood; /* :::::::::::::::::::: */ 16195 16196 case FFEEXPR_contextINDEX_: 16197 case FFEEXPR_contextACTUALARGEXPR_: 16198 case FFEEXPR_contextINDEXORACTUALARGEXPR_: 16199 case FFEEXPR_contextSFUNCDEF: 16200 case FFEEXPR_contextSFUNCDEFINDEX_: 16201 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: 16202 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: 16203 assert (ffeexpr_stack_->is_rhs); 16204 s = ffecom_sym_exec_transition (s); 16205 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) 16206 goto understood; /* :::::::::::::::::::: */ 16207 s = ffeexpr_sym_rhs_let_ (s, t); 16208 goto understood; /* :::::::::::::::::::: */ 16209 16210 default: 16211 ffesymbol_error (s, t); 16212 break; 16213 } 16214 return s; 16215 16216 default: 16217 assert ("bad symbol state" == NULL); 16218 return NULL; 16219 break; 16220 } 16221} 16222 16223/* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH). 16224 Could be found via the "statement-function" name space (in which case 16225 it should become an iterator) or the local name space (in which case 16226 it should be either a named constant, or a variable that will have an 16227 sfunc name space sibling that should become an iterator). */ 16228 16229static ffesymbol 16230ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t) 16231{ 16232 ffesymbol s; 16233 ffesymbolAttrs sa; 16234 ffesymbolAttrs na; 16235 ffesymbolState ss; 16236 ffesymbolState ns; 16237 ffeinfoKind kind; 16238 ffeinfoWhere where; 16239 16240 ss = ffesymbol_state (sp); 16241 16242 if (ffesymbol_sfdummyparent (sp) != NULL) 16243 { /* Have symbol in sfunc name space. */ 16244 switch (ss) 16245 { 16246 case FFESYMBOL_stateNONE: /* Used as iterator already. */ 16247 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp)) 16248 ffesymbol_error (sp, t); /* Can't use dead iterator. */ 16249 else 16250 { /* Can use dead iterator because we're at at 16251 least an innermore (higher-numbered) level 16252 than the iterator's outermost 16253 (lowest-numbered) level. */ 16254 ffesymbol_signal_change (sp); 16255 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN); 16256 ffesymbol_set_maxentrynum (sp, ffeexpr_level_); 16257 ffesymbol_signal_unreported (sp); 16258 } 16259 break; 16260 16261 case FFESYMBOL_stateSEEN: /* Seen already in this or other 16262 implied-DO. Set symbol level 16263 number to outermost value, as that 16264 tells us we can see it as iterator 16265 at that level at the innermost. */ 16266 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp)) 16267 { 16268 ffesymbol_signal_change (sp); 16269 ffesymbol_set_maxentrynum (sp, ffeexpr_level_); 16270 ffesymbol_signal_unreported (sp); 16271 } 16272 break; 16273 16274 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */ 16275 assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp)); 16276 ffesymbol_error (sp, t); /* (,,,I=I,10). */ 16277 break; 16278 16279 case FFESYMBOL_stateUNDERSTOOD: 16280 break; /* ANY. */ 16281 16282 default: 16283 assert ("Foo Bar!!" == NULL); 16284 break; 16285 } 16286 16287 return sp; 16288 } 16289 16290 /* Got symbol in local name space, so we haven't seen it in impdo yet. 16291 First, if it is brand-new and we're in executable statements, set the 16292 attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD. 16293 Second, if it is now a constant (PARAMETER), then just return it, it 16294 can't be an implied-do iterator. If it is understood, complain if it is 16295 not a valid variable, but make the inner name space iterator anyway and 16296 return that. If it is not understood, improve understanding of the 16297 symbol accordingly, complain accordingly, in either case make the inner 16298 name space iterator and return that. */ 16299 16300 sa = ffesymbol_attrs (sp); 16301 16302 if (ffesymbol_state_is_specable (ss) 16303 && ffest_seen_first_exec ()) 16304 { 16305 assert (sa == FFESYMBOL_attrsetNONE); 16306 ffesymbol_signal_change (sp); 16307 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN); 16308 ffesymbol_resolve_intrin (sp); 16309 if (ffeimplic_establish_symbol (sp)) 16310 ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG); 16311 else 16312 ffesymbol_error (sp, t); 16313 16314 /* After the exec transition, the state will either be UNCERTAIN (could 16315 be a dummy or local var) or UNDERSTOOD (local var, because this is a 16316 PROGRAM/BLOCKDATA program unit). */ 16317 16318 sp = ffecom_sym_exec_transition (sp); 16319 sa = ffesymbol_attrs (sp); 16320 ss = ffesymbol_state (sp); 16321 } 16322 16323 ns = ss; 16324 kind = ffesymbol_kind (sp); 16325 where = ffesymbol_where (sp); 16326 16327 if (ss == FFESYMBOL_stateUNDERSTOOD) 16328 { 16329 if (kind != FFEINFO_kindENTITY) 16330 ffesymbol_error (sp, t); 16331 if (where == FFEINFO_whereCONSTANT) 16332 return sp; 16333 } 16334 else 16335 { 16336 /* Enhance understanding of local symbol. This used to imply exec 16337 transition, but that doesn't seem necessary, since the local symbol 16338 doesn't actually get put into an ffebld tree here -- we just learn 16339 more about it, just like when we see a local symbol's name in the 16340 dummy-arg list of a statement function. */ 16341 16342 if (ss != FFESYMBOL_stateUNCERTAIN) 16343 { 16344 /* Figure out what kind of object we've got based on previous 16345 declarations of or references to the object. */ 16346 16347 ns = FFESYMBOL_stateSEEN; 16348 16349 if (sa & FFESYMBOL_attrsANY) 16350 na = sa; 16351 else if (!(sa & ~(FFESYMBOL_attrsADJUSTS 16352 | FFESYMBOL_attrsANY 16353 | FFESYMBOL_attrsCOMMON 16354 | FFESYMBOL_attrsDUMMY 16355 | FFESYMBOL_attrsEQUIV 16356 | FFESYMBOL_attrsINIT 16357 | FFESYMBOL_attrsNAMELIST 16358 | FFESYMBOL_attrsRESULT 16359 | FFESYMBOL_attrsSAVE 16360 | FFESYMBOL_attrsSFARG 16361 | FFESYMBOL_attrsTYPE))) 16362 na = sa | FFESYMBOL_attrsSFARG; 16363 else 16364 na = FFESYMBOL_attrsetNONE; 16365 } 16366 else 16367 { /* stateUNCERTAIN. */ 16368 na = sa | FFESYMBOL_attrsSFARG; 16369 ns = FFESYMBOL_stateUNDERSTOOD; 16370 16371 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG 16372 | FFESYMBOL_attrsADJUSTABLE 16373 | FFESYMBOL_attrsANYLEN 16374 | FFESYMBOL_attrsARRAY 16375 | FFESYMBOL_attrsDUMMY 16376 | FFESYMBOL_attrsEXTERNAL 16377 | FFESYMBOL_attrsSFARG 16378 | FFESYMBOL_attrsTYPE))); 16379 16380 if (sa & FFESYMBOL_attrsEXTERNAL) 16381 { 16382 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG 16383 | FFESYMBOL_attrsDUMMY 16384 | FFESYMBOL_attrsEXTERNAL 16385 | FFESYMBOL_attrsTYPE))); 16386 16387 na = FFESYMBOL_attrsetNONE; 16388 } 16389 else if (sa & FFESYMBOL_attrsDUMMY) 16390 { 16391 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ 16392 assert (!(sa & ~(FFESYMBOL_attrsDUMMY 16393 | FFESYMBOL_attrsEXTERNAL 16394 | FFESYMBOL_attrsTYPE))); 16395 16396 kind = FFEINFO_kindENTITY; 16397 } 16398 else if (sa & FFESYMBOL_attrsARRAY) 16399 { 16400 assert (!(sa & ~(FFESYMBOL_attrsARRAY 16401 | FFESYMBOL_attrsADJUSTABLE 16402 | FFESYMBOL_attrsTYPE))); 16403 16404 na = FFESYMBOL_attrsetNONE; 16405 } 16406 else if (sa & FFESYMBOL_attrsSFARG) 16407 { 16408 assert (!(sa & ~(FFESYMBOL_attrsSFARG 16409 | FFESYMBOL_attrsTYPE))); 16410 16411 ns = FFESYMBOL_stateUNCERTAIN; 16412 } 16413 else if (sa & FFESYMBOL_attrsTYPE) 16414 { 16415 assert (!(sa & (FFESYMBOL_attrsARRAY 16416 | FFESYMBOL_attrsDUMMY 16417 | FFESYMBOL_attrsEXTERNAL 16418 | FFESYMBOL_attrsSFARG))); /* Handled above. */ 16419 assert (!(sa & ~(FFESYMBOL_attrsTYPE 16420 | FFESYMBOL_attrsADJUSTABLE 16421 | FFESYMBOL_attrsANYLEN 16422 | FFESYMBOL_attrsARRAY 16423 | FFESYMBOL_attrsDUMMY 16424 | FFESYMBOL_attrsEXTERNAL 16425 | FFESYMBOL_attrsSFARG))); 16426 16427 kind = FFEINFO_kindENTITY; 16428 16429 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN)) 16430 na = FFESYMBOL_attrsetNONE; 16431 else if (ffest_is_entry_valid ()) 16432 ns = FFESYMBOL_stateUNCERTAIN; /* Could be DUMMY or LOCAL. */ 16433 else 16434 where = FFEINFO_whereLOCAL; 16435 } 16436 else 16437 na = FFESYMBOL_attrsetNONE; /* Error. */ 16438 } 16439 16440 /* Now see what we've got for a new object: NONE means a new error 16441 cropped up; ANY means an old error to be ignored; otherwise, 16442 everything's ok, update the object (symbol) and continue on. */ 16443 16444 if (na == FFESYMBOL_attrsetNONE) 16445 ffesymbol_error (sp, t); 16446 else if (!(na & FFESYMBOL_attrsANY)) 16447 { 16448 ffesymbol_signal_change (sp); /* May need to back up to previous 16449 version. */ 16450 if (!ffeimplic_establish_symbol (sp)) 16451 ffesymbol_error (sp, t); 16452 else 16453 { 16454 ffesymbol_set_info (sp, 16455 ffeinfo_new (ffesymbol_basictype (sp), 16456 ffesymbol_kindtype (sp), 16457 ffesymbol_rank (sp), 16458 kind, 16459 where, 16460 ffesymbol_size (sp))); 16461 ffesymbol_set_attrs (sp, na); 16462 ffesymbol_set_state (sp, ns); 16463 ffesymbol_resolve_intrin (sp); 16464 if (!ffesymbol_state_is_specable (ns)) 16465 sp = ffecom_sym_learned (sp); 16466 ffesymbol_signal_unreported (sp); /* For debugging purposes. */ 16467 } 16468 } 16469 } 16470 16471 /* Here we create the sfunc-name-space symbol representing what should 16472 become an iterator in this name space at this or an outermore (lower- 16473 numbered) expression level, else the implied-DO construct is in error. */ 16474 16475 s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj; 16476 also sets sfa_dummy_parent to 16477 parent symbol. */ 16478 assert (sp == ffesymbol_sfdummyparent (s)); 16479 16480 ffesymbol_signal_change (s); 16481 ffesymbol_set_state (s, FFESYMBOL_stateSEEN); 16482 ffesymbol_set_maxentrynum (s, ffeexpr_level_); 16483 ffesymbol_set_info (s, 16484 ffeinfo_new (FFEINFO_basictypeINTEGER, 16485 FFEINFO_kindtypeINTEGERDEFAULT, 16486 0, 16487 FFEINFO_kindENTITY, 16488 FFEINFO_whereIMMEDIATE, 16489 FFETARGET_charactersizeNONE)); 16490 ffesymbol_signal_unreported (s); 16491 16492 if (((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER) 16493 && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY)) 16494 || ((ffesymbol_kindtype (sp) != FFEINFO_kindtypeINTEGERDEFAULT) 16495 && (ffesymbol_kindtype (sp) != FFEINFO_kindtypeANY))) 16496 ffesymbol_error (s, t); 16497 16498 return s; 16499} 16500 16501/* Have FOO in CALL FOO. Local name space, executable context only. */ 16502 16503static ffesymbol 16504ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t) 16505{ 16506 ffesymbolAttrs sa; 16507 ffesymbolAttrs na; 16508 ffeinfoKind kind; 16509 ffeinfoWhere where; 16510 ffeintrinGen gen; 16511 ffeintrinSpec spec; 16512 ffeintrinImp imp; 16513 bool error = FALSE; 16514 16515 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) 16516 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); 16517 16518 na = sa = ffesymbol_attrs (s); 16519 16520 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG 16521 | FFESYMBOL_attrsADJUSTABLE 16522 | FFESYMBOL_attrsANYLEN 16523 | FFESYMBOL_attrsARRAY 16524 | FFESYMBOL_attrsDUMMY 16525 | FFESYMBOL_attrsEXTERNAL 16526 | FFESYMBOL_attrsSFARG 16527 | FFESYMBOL_attrsTYPE))); 16528 16529 kind = ffesymbol_kind (s); 16530 where = ffesymbol_where (s); 16531 16532 /* Figure out what kind of object we've got based on previous declarations 16533 of or references to the object. */ 16534 16535 if (sa & FFESYMBOL_attrsEXTERNAL) 16536 { 16537 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG 16538 | FFESYMBOL_attrsDUMMY 16539 | FFESYMBOL_attrsEXTERNAL 16540 | FFESYMBOL_attrsTYPE))); 16541 16542 if (sa & FFESYMBOL_attrsTYPE) 16543 error = TRUE; 16544 else 16545 /* Not TYPE. */ 16546 { 16547 kind = FFEINFO_kindSUBROUTINE; 16548 16549 if (sa & FFESYMBOL_attrsDUMMY) 16550 ; /* Not TYPE. */ 16551 else if (sa & FFESYMBOL_attrsACTUALARG) 16552 ; /* Not DUMMY or TYPE. */ 16553 else /* Not ACTUALARG, DUMMY, or TYPE. */ 16554 where = FFEINFO_whereGLOBAL; 16555 } 16556 } 16557 else if (sa & FFESYMBOL_attrsDUMMY) 16558 { 16559 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ 16560 assert (!(sa & ~(FFESYMBOL_attrsDUMMY 16561 | FFESYMBOL_attrsEXTERNAL 16562 | FFESYMBOL_attrsTYPE))); 16563 16564 if (sa & FFESYMBOL_attrsTYPE) 16565 error = TRUE; 16566 else 16567 kind = FFEINFO_kindSUBROUTINE; 16568 } 16569 else if (sa & FFESYMBOL_attrsARRAY) 16570 { 16571 assert (!(sa & ~(FFESYMBOL_attrsARRAY 16572 | FFESYMBOL_attrsADJUSTABLE 16573 | FFESYMBOL_attrsTYPE))); 16574 16575 error = TRUE; 16576 } 16577 else if (sa & FFESYMBOL_attrsSFARG) 16578 { 16579 assert (!(sa & ~(FFESYMBOL_attrsSFARG 16580 | FFESYMBOL_attrsTYPE))); 16581 16582 error = TRUE; 16583 } 16584 else if (sa & FFESYMBOL_attrsTYPE) 16585 { 16586 assert (!(sa & (FFESYMBOL_attrsARRAY 16587 | FFESYMBOL_attrsDUMMY 16588 | FFESYMBOL_attrsEXTERNAL 16589 | FFESYMBOL_attrsSFARG))); /* Handled above. */ 16590 assert (!(sa & ~(FFESYMBOL_attrsTYPE 16591 | FFESYMBOL_attrsADJUSTABLE 16592 | FFESYMBOL_attrsANYLEN 16593 | FFESYMBOL_attrsARRAY 16594 | FFESYMBOL_attrsDUMMY 16595 | FFESYMBOL_attrsEXTERNAL 16596 | FFESYMBOL_attrsSFARG))); 16597 16598 error = TRUE; 16599 } 16600 else if (sa == FFESYMBOL_attrsetNONE) 16601 { 16602 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); 16603 16604 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE, 16605 &gen, &spec, &imp)) 16606 { 16607 ffesymbol_signal_change (s); /* May need to back up to previous 16608 version. */ 16609 ffesymbol_set_generic (s, gen); 16610 ffesymbol_set_specific (s, spec); 16611 ffesymbol_set_implementation (s, imp); 16612 ffesymbol_set_info (s, 16613 ffeinfo_new (FFEINFO_basictypeNONE, 16614 FFEINFO_kindtypeNONE, 16615 0, 16616 FFEINFO_kindSUBROUTINE, 16617 FFEINFO_whereINTRINSIC, 16618 FFETARGET_charactersizeNONE)); 16619 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 16620 ffesymbol_resolve_intrin (s); 16621 ffesymbol_reference (s, t, FALSE); 16622 s = ffecom_sym_learned (s); 16623 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 16624 16625 return s; 16626 } 16627 16628 kind = FFEINFO_kindSUBROUTINE; 16629 where = FFEINFO_whereGLOBAL; 16630 } 16631 else 16632 error = TRUE; 16633 16634 /* Now see what we've got for a new object: NONE means a new error cropped 16635 up; ANY means an old error to be ignored; otherwise, everything's ok, 16636 update the object (symbol) and continue on. */ 16637 16638 if (error) 16639 ffesymbol_error (s, t); 16640 else if (!(na & FFESYMBOL_attrsANY)) 16641 { 16642 ffesymbol_signal_change (s); /* May need to back up to previous 16643 version. */ 16644 ffesymbol_set_info (s, 16645 ffeinfo_new (ffesymbol_basictype (s), 16646 ffesymbol_kindtype (s), 16647 ffesymbol_rank (s), 16648 kind, /* SUBROUTINE. */ 16649 where, /* GLOBAL or DUMMY. */ 16650 ffesymbol_size (s))); 16651 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 16652 ffesymbol_resolve_intrin (s); 16653 ffesymbol_reference (s, t, FALSE); 16654 s = ffecom_sym_learned (s); 16655 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 16656 } 16657 16658 return s; 16659} 16660 16661/* Have FOO in DATA FOO/.../. Local name space and executable context 16662 only. (This will change in the future when DATA FOO may be followed 16663 by COMMON FOO or even INTEGER FOO(10), etc.) */ 16664 16665static ffesymbol 16666ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t) 16667{ 16668 ffesymbolAttrs sa; 16669 ffesymbolAttrs na; 16670 ffeinfoKind kind; 16671 ffeinfoWhere where; 16672 bool error = FALSE; 16673 16674 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) 16675 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); 16676 16677 na = sa = ffesymbol_attrs (s); 16678 16679 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG 16680 | FFESYMBOL_attrsADJUSTABLE 16681 | FFESYMBOL_attrsANYLEN 16682 | FFESYMBOL_attrsARRAY 16683 | FFESYMBOL_attrsDUMMY 16684 | FFESYMBOL_attrsEXTERNAL 16685 | FFESYMBOL_attrsSFARG 16686 | FFESYMBOL_attrsTYPE))); 16687 16688 kind = ffesymbol_kind (s); 16689 where = ffesymbol_where (s); 16690 16691 /* Figure out what kind of object we've got based on previous declarations 16692 of or references to the object. */ 16693 16694 if (sa & FFESYMBOL_attrsEXTERNAL) 16695 { 16696 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG 16697 | FFESYMBOL_attrsDUMMY 16698 | FFESYMBOL_attrsEXTERNAL 16699 | FFESYMBOL_attrsTYPE))); 16700 16701 error = TRUE; 16702 } 16703 else if (sa & FFESYMBOL_attrsDUMMY) 16704 { 16705 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ 16706 assert (!(sa & ~(FFESYMBOL_attrsDUMMY 16707 | FFESYMBOL_attrsEXTERNAL 16708 | FFESYMBOL_attrsTYPE))); 16709 16710 error = TRUE; 16711 } 16712 else if (sa & FFESYMBOL_attrsARRAY) 16713 { 16714 assert (!(sa & ~(FFESYMBOL_attrsARRAY 16715 | FFESYMBOL_attrsADJUSTABLE 16716 | FFESYMBOL_attrsTYPE))); 16717 16718 if (sa & FFESYMBOL_attrsADJUSTABLE) 16719 error = TRUE; 16720 where = FFEINFO_whereLOCAL; 16721 } 16722 else if (sa & FFESYMBOL_attrsSFARG) 16723 { 16724 assert (!(sa & ~(FFESYMBOL_attrsSFARG 16725 | FFESYMBOL_attrsTYPE))); 16726 16727 where = FFEINFO_whereLOCAL; 16728 } 16729 else if (sa & FFESYMBOL_attrsTYPE) 16730 { 16731 assert (!(sa & (FFESYMBOL_attrsARRAY 16732 | FFESYMBOL_attrsDUMMY 16733 | FFESYMBOL_attrsEXTERNAL 16734 | FFESYMBOL_attrsSFARG))); /* Handled above. */ 16735 assert (!(sa & ~(FFESYMBOL_attrsTYPE 16736 | FFESYMBOL_attrsADJUSTABLE 16737 | FFESYMBOL_attrsANYLEN 16738 | FFESYMBOL_attrsARRAY 16739 | FFESYMBOL_attrsDUMMY 16740 | FFESYMBOL_attrsEXTERNAL 16741 | FFESYMBOL_attrsSFARG))); 16742 16743 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN)) 16744 error = TRUE; 16745 else 16746 { 16747 kind = FFEINFO_kindENTITY; 16748 where = FFEINFO_whereLOCAL; 16749 } 16750 } 16751 else if (sa == FFESYMBOL_attrsetNONE) 16752 { 16753 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); 16754 kind = FFEINFO_kindENTITY; 16755 where = FFEINFO_whereLOCAL; 16756 } 16757 else 16758 error = TRUE; 16759 16760 /* Now see what we've got for a new object: NONE means a new error cropped 16761 up; ANY means an old error to be ignored; otherwise, everything's ok, 16762 update the object (symbol) and continue on. */ 16763 16764 if (error) 16765 ffesymbol_error (s, t); 16766 else if (!(na & FFESYMBOL_attrsANY)) 16767 { 16768 ffesymbol_signal_change (s); /* May need to back up to previous 16769 version. */ 16770 if (!ffeimplic_establish_symbol (s)) 16771 { 16772 ffesymbol_error (s, t); 16773 return s; 16774 } 16775 ffesymbol_set_info (s, 16776 ffeinfo_new (ffesymbol_basictype (s), 16777 ffesymbol_kindtype (s), 16778 ffesymbol_rank (s), 16779 kind, /* ENTITY. */ 16780 where, /* LOCAL. */ 16781 ffesymbol_size (s))); 16782 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 16783 ffesymbol_resolve_intrin (s); 16784 s = ffecom_sym_learned (s); 16785 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 16786 } 16787 16788 return s; 16789} 16790 16791/* Have FOO in EQUIVALENCE (...,FOO,...). Does not include 16792 EQUIVALENCE (...,BAR(FOO),...). */ 16793 16794static ffesymbol 16795ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t) 16796{ 16797 ffesymbolAttrs sa; 16798 ffesymbolAttrs na; 16799 ffeinfoKind kind; 16800 ffeinfoWhere where; 16801 16802 na = sa = ffesymbol_attrs (s); 16803 kind = FFEINFO_kindENTITY; 16804 where = ffesymbol_where (s); 16805 16806 /* Figure out what kind of object we've got based on previous declarations 16807 of or references to the object. */ 16808 16809 if (!(sa & ~(FFESYMBOL_attrsADJUSTS 16810 | FFESYMBOL_attrsARRAY 16811 | FFESYMBOL_attrsCOMMON 16812 | FFESYMBOL_attrsEQUIV 16813 | FFESYMBOL_attrsINIT 16814 | FFESYMBOL_attrsNAMELIST 16815 | FFESYMBOL_attrsSAVE 16816 | FFESYMBOL_attrsSFARG 16817 | FFESYMBOL_attrsTYPE))) 16818 na = sa | FFESYMBOL_attrsEQUIV; 16819 else 16820 na = FFESYMBOL_attrsetNONE; 16821 16822 /* Don't know why we're bothering to set kind and where in this code, but 16823 added the following to make it complete, in case it's really important. 16824 Generally this is left up to symbol exec transition. */ 16825 16826 if (where == FFEINFO_whereNONE) 16827 { 16828 if (na & (FFESYMBOL_attrsADJUSTS 16829 | FFESYMBOL_attrsCOMMON)) 16830 where = FFEINFO_whereCOMMON; 16831 else if (na & FFESYMBOL_attrsSAVE) 16832 where = FFEINFO_whereLOCAL; 16833 } 16834 16835 /* Now see what we've got for a new object: NONE means a new error cropped 16836 up; ANY means an old error to be ignored; otherwise, everything's ok, 16837 update the object (symbol) and continue on. */ 16838 16839 if (na == FFESYMBOL_attrsetNONE) 16840 ffesymbol_error (s, t); 16841 else if (!(na & FFESYMBOL_attrsANY)) 16842 { 16843 ffesymbol_signal_change (s); /* May need to back up to previous 16844 version. */ 16845 ffesymbol_set_info (s, 16846 ffeinfo_new (ffesymbol_basictype (s), 16847 ffesymbol_kindtype (s), 16848 ffesymbol_rank (s), 16849 kind, /* Always ENTITY. */ 16850 where, /* NONE, COMMON, or LOCAL. */ 16851 ffesymbol_size (s))); 16852 ffesymbol_set_attrs (s, na); 16853 ffesymbol_set_state (s, FFESYMBOL_stateSEEN); 16854 ffesymbol_resolve_intrin (s); 16855 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 16856 } 16857 16858 return s; 16859} 16860 16861/* Have FOO in OPEN(...,USEROPEN=FOO,...). Executable context only. 16862 16863 Note that I think this should be considered semantically similar to 16864 doing CALL XYZ(FOO), in that it should be considered like an 16865 ACTUALARG context. In particular, without EXTERNAL being specified, 16866 it should not be allowed. */ 16867 16868static ffesymbol 16869ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t) 16870{ 16871 ffesymbolAttrs sa; 16872 ffesymbolAttrs na; 16873 ffeinfoKind kind; 16874 ffeinfoWhere where; 16875 bool needs_type = FALSE; 16876 bool error = FALSE; 16877 16878 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) 16879 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); 16880 16881 na = sa = ffesymbol_attrs (s); 16882 16883 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG 16884 | FFESYMBOL_attrsADJUSTABLE 16885 | FFESYMBOL_attrsANYLEN 16886 | FFESYMBOL_attrsARRAY 16887 | FFESYMBOL_attrsDUMMY 16888 | FFESYMBOL_attrsEXTERNAL 16889 | FFESYMBOL_attrsSFARG 16890 | FFESYMBOL_attrsTYPE))); 16891 16892 kind = ffesymbol_kind (s); 16893 where = ffesymbol_where (s); 16894 16895 /* Figure out what kind of object we've got based on previous declarations 16896 of or references to the object. */ 16897 16898 if (sa & FFESYMBOL_attrsEXTERNAL) 16899 { 16900 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG 16901 | FFESYMBOL_attrsDUMMY 16902 | FFESYMBOL_attrsEXTERNAL 16903 | FFESYMBOL_attrsTYPE))); 16904 16905 if (sa & FFESYMBOL_attrsTYPE) 16906 where = FFEINFO_whereGLOBAL; 16907 else 16908 /* Not TYPE. */ 16909 { 16910 kind = FFEINFO_kindFUNCTION; 16911 needs_type = TRUE; 16912 16913 if (sa & FFESYMBOL_attrsDUMMY) 16914 ; /* Not TYPE. */ 16915 else if (sa & FFESYMBOL_attrsACTUALARG) 16916 ; /* Not DUMMY or TYPE. */ 16917 else /* Not ACTUALARG, DUMMY, or TYPE. */ 16918 where = FFEINFO_whereGLOBAL; 16919 } 16920 } 16921 else if (sa & FFESYMBOL_attrsDUMMY) 16922 { 16923 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ 16924 assert (!(sa & ~(FFESYMBOL_attrsDUMMY 16925 | FFESYMBOL_attrsEXTERNAL 16926 | FFESYMBOL_attrsTYPE))); 16927 16928 kind = FFEINFO_kindFUNCTION; 16929 if (!(sa & FFESYMBOL_attrsTYPE)) 16930 needs_type = TRUE; 16931 } 16932 else if (sa & FFESYMBOL_attrsARRAY) 16933 { 16934 assert (!(sa & ~(FFESYMBOL_attrsARRAY 16935 | FFESYMBOL_attrsADJUSTABLE 16936 | FFESYMBOL_attrsTYPE))); 16937 16938 error = TRUE; 16939 } 16940 else if (sa & FFESYMBOL_attrsSFARG) 16941 { 16942 assert (!(sa & ~(FFESYMBOL_attrsSFARG 16943 | FFESYMBOL_attrsTYPE))); 16944 16945 error = TRUE; 16946 } 16947 else if (sa & FFESYMBOL_attrsTYPE) 16948 { 16949 assert (!(sa & (FFESYMBOL_attrsARRAY 16950 | FFESYMBOL_attrsDUMMY 16951 | FFESYMBOL_attrsEXTERNAL 16952 | FFESYMBOL_attrsSFARG))); /* Handled above. */ 16953 assert (!(sa & ~(FFESYMBOL_attrsTYPE 16954 | FFESYMBOL_attrsADJUSTABLE 16955 | FFESYMBOL_attrsANYLEN 16956 | FFESYMBOL_attrsARRAY 16957 | FFESYMBOL_attrsDUMMY 16958 | FFESYMBOL_attrsEXTERNAL 16959 | FFESYMBOL_attrsSFARG))); 16960 16961 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN)) 16962 error = TRUE; 16963 else 16964 { 16965 kind = FFEINFO_kindFUNCTION; 16966 where = FFEINFO_whereGLOBAL; 16967 } 16968 } 16969 else if (sa == FFESYMBOL_attrsetNONE) 16970 { 16971 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); 16972 kind = FFEINFO_kindFUNCTION; 16973 where = FFEINFO_whereGLOBAL; 16974 needs_type = TRUE; 16975 } 16976 else 16977 error = TRUE; 16978 16979 /* Now see what we've got for a new object: NONE means a new error cropped 16980 up; ANY means an old error to be ignored; otherwise, everything's ok, 16981 update the object (symbol) and continue on. */ 16982 16983 if (error) 16984 ffesymbol_error (s, t); 16985 else if (!(na & FFESYMBOL_attrsANY)) 16986 { 16987 ffesymbol_signal_change (s); /* May need to back up to previous 16988 version. */ 16989 if (needs_type && !ffeimplic_establish_symbol (s)) 16990 { 16991 ffesymbol_error (s, t); 16992 return s; 16993 } 16994 if (!ffesymbol_explicitwhere (s)) 16995 { 16996 ffebad_start (FFEBAD_NEED_EXTERNAL); 16997 ffebad_here (0, ffelex_token_where_line (t), 16998 ffelex_token_where_column (t)); 16999 ffebad_string (ffesymbol_text (s)); 17000 ffebad_finish (); 17001 ffesymbol_set_explicitwhere (s, TRUE); 17002 } 17003 ffesymbol_set_info (s, 17004 ffeinfo_new (ffesymbol_basictype (s), 17005 ffesymbol_kindtype (s), 17006 ffesymbol_rank (s), 17007 kind, /* FUNCTION. */ 17008 where, /* GLOBAL or DUMMY. */ 17009 ffesymbol_size (s))); 17010 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 17011 ffesymbol_resolve_intrin (s); 17012 ffesymbol_reference (s, t, FALSE); 17013 s = ffecom_sym_learned (s); 17014 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 17015 } 17016 17017 return s; 17018} 17019 17020/* Have FOO in DATA (stuff,FOO=1,10)/.../. */ 17021 17022static ffesymbol 17023ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t) 17024{ 17025 ffesymbolState ss; 17026 17027 /* If the symbol isn't in the sfunc name space, pretend as though we saw a 17028 reference to it already within the imp-DO construct at this level, so as 17029 to get a symbol that is in the sfunc name space. But this is an 17030 erroneous construct, and should be caught elsewhere. */ 17031 17032 if (ffesymbol_sfdummyparent (s) == NULL) 17033 { 17034 s = ffeexpr_sym_impdoitem_ (s, t); 17035 if (ffesymbol_sfdummyparent (s) == NULL) 17036 { /* PARAMETER FOO...DATA (A(I),FOO=...). */ 17037 ffesymbol_error (s, t); 17038 return s; 17039 } 17040 } 17041 17042 ss = ffesymbol_state (s); 17043 17044 switch (ss) 17045 { 17046 case FFESYMBOL_stateNONE: /* Used as iterator already. */ 17047 if (ffeexpr_level_ < ffesymbol_maxentrynum (s)) 17048 ffesymbol_error (s, t); /* Can't reuse dead iterator. F90 disallows 17049 this; F77 allows it but it is a stupid 17050 feature. */ 17051 else 17052 { /* Can use dead iterator because we're at at 17053 least a innermore (higher-numbered) level 17054 than the iterator's outermost 17055 (lowest-numbered) level. This should be 17056 diagnosed later, because it means an item 17057 in this list didn't reference this 17058 iterator. */ 17059#if 1 17060 ffesymbol_error (s, t); /* For now, complain. */ 17061#else /* Someday will detect all cases where initializer doesn't reference 17062 all applicable iterators, in which case reenable this code. */ 17063 ffesymbol_signal_change (s); 17064 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN); 17065 ffesymbol_set_maxentrynum (s, ffeexpr_level_); 17066 ffesymbol_signal_unreported (s); 17067#endif 17068 } 17069 break; 17070 17071 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO. 17072 If seen in outermore level, can't be an 17073 iterator here, so complain. If not seen 17074 at current level, complain for now, 17075 because that indicates something F90 17076 rejects (though we currently don't detect 17077 all such cases for now). */ 17078 if (ffeexpr_level_ <= ffesymbol_maxentrynum (s)) 17079 { 17080 ffesymbol_signal_change (s); 17081 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN); 17082 ffesymbol_signal_unreported (s); 17083 } 17084 else 17085 ffesymbol_error (s, t); 17086 break; 17087 17088 case FFESYMBOL_stateUNCERTAIN: /* Already iterator! */ 17089 assert ("DATA implied-DO control var seen twice!!" == NULL); 17090 ffesymbol_error (s, t); 17091 break; 17092 17093 case FFESYMBOL_stateUNDERSTOOD: 17094 break; /* ANY. */ 17095 17096 default: 17097 assert ("Foo Bletch!!" == NULL); 17098 break; 17099 } 17100 17101 return s; 17102} 17103 17104/* Have FOO in PARAMETER (FOO=...). */ 17105 17106static ffesymbol 17107ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t) 17108{ 17109 ffesymbolAttrs sa; 17110 17111 sa = ffesymbol_attrs (s); 17112 17113 /* Figure out what kind of object we've got based on previous declarations 17114 of or references to the object. */ 17115 17116 if (sa & ~(FFESYMBOL_attrsANYLEN 17117 | FFESYMBOL_attrsTYPE)) 17118 { 17119 if (!(sa & FFESYMBOL_attrsANY)) 17120 ffesymbol_error (s, t); 17121 } 17122 else 17123 { 17124 ffesymbol_signal_change (s); /* May need to back up to previous 17125 version. */ 17126 if (!ffeimplic_establish_symbol (s)) 17127 { 17128 ffesymbol_error (s, t); 17129 return s; 17130 } 17131 ffesymbol_set_info (s, 17132 ffeinfo_new (ffesymbol_basictype (s), 17133 ffesymbol_kindtype (s), 17134 ffesymbol_rank (s), 17135 FFEINFO_kindENTITY, 17136 FFEINFO_whereCONSTANT, 17137 ffesymbol_size (s))); 17138 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 17139 ffesymbol_resolve_intrin (s); 17140 s = ffecom_sym_learned (s); 17141 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 17142 } 17143 17144 return s; 17145} 17146 17147/* Have FOO in CALL XYZ(...,FOO,...). Does not include any other 17148 embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1). */ 17149 17150static ffesymbol 17151ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t) 17152{ 17153 ffesymbolAttrs sa; 17154 ffesymbolAttrs na; 17155 ffeinfoKind kind; 17156 ffeinfoWhere where; 17157 ffesymbolState ns; 17158 bool needs_type = FALSE; 17159 17160 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) 17161 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); 17162 17163 na = sa = ffesymbol_attrs (s); 17164 17165 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG 17166 | FFESYMBOL_attrsADJUSTABLE 17167 | FFESYMBOL_attrsANYLEN 17168 | FFESYMBOL_attrsARRAY 17169 | FFESYMBOL_attrsDUMMY 17170 | FFESYMBOL_attrsEXTERNAL 17171 | FFESYMBOL_attrsSFARG 17172 | FFESYMBOL_attrsTYPE))); 17173 17174 kind = ffesymbol_kind (s); 17175 where = ffesymbol_where (s); 17176 17177 /* Figure out what kind of object we've got based on previous declarations 17178 of or references to the object. */ 17179 17180 ns = FFESYMBOL_stateUNDERSTOOD; 17181 17182 if (sa & FFESYMBOL_attrsEXTERNAL) 17183 { 17184 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG 17185 | FFESYMBOL_attrsDUMMY 17186 | FFESYMBOL_attrsEXTERNAL 17187 | FFESYMBOL_attrsTYPE))); 17188 17189 if (sa & FFESYMBOL_attrsTYPE) 17190 where = FFEINFO_whereGLOBAL; 17191 else 17192 /* Not TYPE. */ 17193 { 17194 ns = FFESYMBOL_stateUNCERTAIN; 17195 17196 if (sa & FFESYMBOL_attrsDUMMY) 17197 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */ 17198 else if (sa & FFESYMBOL_attrsACTUALARG) 17199 ; /* Not DUMMY or TYPE. */ 17200 else 17201 /* Not ACTUALARG, DUMMY, or TYPE. */ 17202 { 17203 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */ 17204 na |= FFESYMBOL_attrsACTUALARG; 17205 where = FFEINFO_whereGLOBAL; 17206 } 17207 } 17208 } 17209 else if (sa & FFESYMBOL_attrsDUMMY) 17210 { 17211 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ 17212 assert (!(sa & ~(FFESYMBOL_attrsDUMMY 17213 | FFESYMBOL_attrsEXTERNAL 17214 | FFESYMBOL_attrsTYPE))); 17215 17216 kind = FFEINFO_kindENTITY; 17217 if (!(sa & FFESYMBOL_attrsTYPE)) 17218 needs_type = TRUE; 17219 } 17220 else if (sa & FFESYMBOL_attrsARRAY) 17221 { 17222 assert (!(sa & ~(FFESYMBOL_attrsARRAY 17223 | FFESYMBOL_attrsADJUSTABLE 17224 | FFESYMBOL_attrsTYPE))); 17225 17226 where = FFEINFO_whereLOCAL; 17227 } 17228 else if (sa & FFESYMBOL_attrsSFARG) 17229 { 17230 assert (!(sa & ~(FFESYMBOL_attrsSFARG 17231 | FFESYMBOL_attrsTYPE))); 17232 17233 where = FFEINFO_whereLOCAL; 17234 } 17235 else if (sa & FFESYMBOL_attrsTYPE) 17236 { 17237 assert (!(sa & (FFESYMBOL_attrsARRAY 17238 | FFESYMBOL_attrsDUMMY 17239 | FFESYMBOL_attrsEXTERNAL 17240 | FFESYMBOL_attrsSFARG))); /* Handled above. */ 17241 assert (!(sa & ~(FFESYMBOL_attrsTYPE 17242 | FFESYMBOL_attrsADJUSTABLE 17243 | FFESYMBOL_attrsANYLEN 17244 | FFESYMBOL_attrsARRAY 17245 | FFESYMBOL_attrsDUMMY 17246 | FFESYMBOL_attrsEXTERNAL 17247 | FFESYMBOL_attrsSFARG))); 17248 17249 if (sa & FFESYMBOL_attrsANYLEN) 17250 ns = FFESYMBOL_stateNONE; 17251 else 17252 { 17253 kind = FFEINFO_kindENTITY; 17254 where = FFEINFO_whereLOCAL; 17255 } 17256 } 17257 else if (sa == FFESYMBOL_attrsetNONE) 17258 { 17259 /* New state is left empty because there isn't any state flag to 17260 set for this case, and it's UNDERSTOOD after all. */ 17261 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); 17262 kind = FFEINFO_kindENTITY; 17263 where = FFEINFO_whereLOCAL; 17264 needs_type = TRUE; 17265 } 17266 else 17267 ns = FFESYMBOL_stateNONE; /* Error. */ 17268 17269 /* Now see what we've got for a new object: NONE means a new error cropped 17270 up; ANY means an old error to be ignored; otherwise, everything's ok, 17271 update the object (symbol) and continue on. */ 17272 17273 if (ns == FFESYMBOL_stateNONE) 17274 ffesymbol_error (s, t); 17275 else if (!(na & FFESYMBOL_attrsANY)) 17276 { 17277 ffesymbol_signal_change (s); /* May need to back up to previous 17278 version. */ 17279 if (needs_type && !ffeimplic_establish_symbol (s)) 17280 { 17281 ffesymbol_error (s, t); 17282 return s; 17283 } 17284 ffesymbol_set_info (s, 17285 ffeinfo_new (ffesymbol_basictype (s), 17286 ffesymbol_kindtype (s), 17287 ffesymbol_rank (s), 17288 kind, 17289 where, 17290 ffesymbol_size (s))); 17291 ffesymbol_set_attrs (s, na); 17292 ffesymbol_set_state (s, ns); 17293 s = ffecom_sym_learned (s); 17294 ffesymbol_reference (s, t, FALSE); 17295 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 17296 } 17297 17298 return s; 17299} 17300 17301/* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing 17302 a reference to FOO. */ 17303 17304static ffesymbol 17305ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t) 17306{ 17307 ffesymbolAttrs sa; 17308 ffesymbolAttrs na; 17309 ffeinfoKind kind; 17310 ffeinfoWhere where; 17311 17312 na = sa = ffesymbol_attrs (s); 17313 kind = FFEINFO_kindENTITY; 17314 where = ffesymbol_where (s); 17315 17316 /* Figure out what kind of object we've got based on previous declarations 17317 of or references to the object. */ 17318 17319 if (!(sa & ~(FFESYMBOL_attrsADJUSTS 17320 | FFESYMBOL_attrsCOMMON 17321 | FFESYMBOL_attrsDUMMY 17322 | FFESYMBOL_attrsEQUIV 17323 | FFESYMBOL_attrsINIT 17324 | FFESYMBOL_attrsNAMELIST 17325 | FFESYMBOL_attrsSFARG 17326 | FFESYMBOL_attrsTYPE))) 17327 na = sa | FFESYMBOL_attrsADJUSTS; 17328 else 17329 na = FFESYMBOL_attrsetNONE; 17330 17331 /* Since this symbol definitely is going into an expression (the 17332 dimension-list for some dummy array, presumably), figure out WHERE if 17333 possible. */ 17334 17335 if (where == FFEINFO_whereNONE) 17336 { 17337 if (na & (FFESYMBOL_attrsCOMMON 17338 | FFESYMBOL_attrsEQUIV 17339 | FFESYMBOL_attrsINIT 17340 | FFESYMBOL_attrsNAMELIST)) 17341 where = FFEINFO_whereCOMMON; 17342 else if (na & FFESYMBOL_attrsDUMMY) 17343 where = FFEINFO_whereDUMMY; 17344 } 17345 17346 /* Now see what we've got for a new object: NONE means a new error cropped 17347 up; ANY means an old error to be ignored; otherwise, everything's ok, 17348 update the object (symbol) and continue on. */ 17349 17350 if (na == FFESYMBOL_attrsetNONE) 17351 ffesymbol_error (s, t); 17352 else if (!(na & FFESYMBOL_attrsANY)) 17353 { 17354 ffesymbol_signal_change (s); /* May need to back up to previous 17355 version. */ 17356 if (!ffeimplic_establish_symbol (s)) 17357 { 17358 ffesymbol_error (s, t); 17359 return s; 17360 } 17361 ffesymbol_set_info (s, 17362 ffeinfo_new (ffesymbol_basictype (s), 17363 ffesymbol_kindtype (s), 17364 ffesymbol_rank (s), 17365 kind, /* Always ENTITY. */ 17366 where, /* NONE, COMMON, or DUMMY. */ 17367 ffesymbol_size (s))); 17368 ffesymbol_set_attrs (s, na); 17369 ffesymbol_set_state (s, FFESYMBOL_stateSEEN); 17370 ffesymbol_resolve_intrin (s); 17371 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 17372 } 17373 17374 return s; 17375} 17376 17377/* Have FOO in XYZ = ...FOO.... Does not include cases like FOO in 17378 XYZ = BAR(FOO), as such cases are handled elsewhere. */ 17379 17380static ffesymbol 17381ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t) 17382{ 17383 ffesymbolAttrs sa; 17384 ffesymbolAttrs na; 17385 ffeinfoKind kind; 17386 ffeinfoWhere where; 17387 bool error = FALSE; 17388 17389 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) 17390 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); 17391 17392 na = sa = ffesymbol_attrs (s); 17393 17394 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG 17395 | FFESYMBOL_attrsADJUSTABLE 17396 | FFESYMBOL_attrsANYLEN 17397 | FFESYMBOL_attrsARRAY 17398 | FFESYMBOL_attrsDUMMY 17399 | FFESYMBOL_attrsEXTERNAL 17400 | FFESYMBOL_attrsSFARG 17401 | FFESYMBOL_attrsTYPE))); 17402 17403 kind = ffesymbol_kind (s); 17404 where = ffesymbol_where (s); 17405 17406 /* Figure out what kind of object we've got based on previous declarations 17407 of or references to the object. */ 17408 17409 if (sa & FFESYMBOL_attrsEXTERNAL) 17410 { 17411 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG 17412 | FFESYMBOL_attrsDUMMY 17413 | FFESYMBOL_attrsEXTERNAL 17414 | FFESYMBOL_attrsTYPE))); 17415 17416 error = TRUE; 17417 } 17418 else if (sa & FFESYMBOL_attrsDUMMY) 17419 { 17420 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ 17421 assert (!(sa & ~(FFESYMBOL_attrsDUMMY 17422 | FFESYMBOL_attrsEXTERNAL 17423 | FFESYMBOL_attrsTYPE))); 17424 17425 kind = FFEINFO_kindENTITY; 17426 } 17427 else if (sa & FFESYMBOL_attrsARRAY) 17428 { 17429 assert (!(sa & ~(FFESYMBOL_attrsARRAY 17430 | FFESYMBOL_attrsADJUSTABLE 17431 | FFESYMBOL_attrsTYPE))); 17432 17433 where = FFEINFO_whereLOCAL; 17434 } 17435 else if (sa & FFESYMBOL_attrsSFARG) 17436 { 17437 assert (!(sa & ~(FFESYMBOL_attrsSFARG 17438 | FFESYMBOL_attrsTYPE))); 17439 17440 where = FFEINFO_whereLOCAL; 17441 } 17442 else if (sa & FFESYMBOL_attrsTYPE) 17443 { 17444 assert (!(sa & (FFESYMBOL_attrsARRAY 17445 | FFESYMBOL_attrsDUMMY 17446 | FFESYMBOL_attrsEXTERNAL 17447 | FFESYMBOL_attrsSFARG))); /* Handled above. */ 17448 assert (!(sa & ~(FFESYMBOL_attrsTYPE 17449 | FFESYMBOL_attrsADJUSTABLE 17450 | FFESYMBOL_attrsANYLEN 17451 | FFESYMBOL_attrsARRAY 17452 | FFESYMBOL_attrsDUMMY 17453 | FFESYMBOL_attrsEXTERNAL 17454 | FFESYMBOL_attrsSFARG))); 17455 17456 if (sa & FFESYMBOL_attrsANYLEN) 17457 error = TRUE; 17458 else 17459 { 17460 kind = FFEINFO_kindENTITY; 17461 where = FFEINFO_whereLOCAL; 17462 } 17463 } 17464 else if (sa == FFESYMBOL_attrsetNONE) 17465 { 17466 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); 17467 kind = FFEINFO_kindENTITY; 17468 where = FFEINFO_whereLOCAL; 17469 } 17470 else 17471 error = TRUE; 17472 17473 /* Now see what we've got for a new object: NONE means a new error cropped 17474 up; ANY means an old error to be ignored; otherwise, everything's ok, 17475 update the object (symbol) and continue on. */ 17476 17477 if (error) 17478 ffesymbol_error (s, t); 17479 else if (!(na & FFESYMBOL_attrsANY)) 17480 { 17481 ffesymbol_signal_change (s); /* May need to back up to previous 17482 version. */ 17483 if (!ffeimplic_establish_symbol (s)) 17484 { 17485 ffesymbol_error (s, t); 17486 return s; 17487 } 17488 ffesymbol_set_info (s, 17489 ffeinfo_new (ffesymbol_basictype (s), 17490 ffesymbol_kindtype (s), 17491 ffesymbol_rank (s), 17492 kind, /* ENTITY. */ 17493 where, /* LOCAL. */ 17494 ffesymbol_size (s))); 17495 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 17496 ffesymbol_resolve_intrin (s); 17497 s = ffecom_sym_learned (s); 17498 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 17499 } 17500 17501 return s; 17502} 17503 17504/* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand 17505 17506 ffelexToken t; 17507 bool maybe_intrin; 17508 ffeexprParenType_ paren_type; 17509 ffesymbol s; 17510 s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type); 17511 17512 Just like ffesymbol_declare_local, except performs any implicit info 17513 assignment necessary, and it returns the type of the parenthesized list 17514 (list of function args, list of array args, or substring spec). */ 17515 17516static ffesymbol 17517ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin, 17518 ffeexprParenType_ *paren_type) 17519{ 17520 ffesymbol s; 17521 ffesymbolState st; /* Effective state. */ 17522 ffeinfoKind k; 17523 bool bad; 17524 17525 if (maybe_intrin && ffesrc_check_symbol ()) 17526 { /* Knock off some easy cases. */ 17527 switch (ffeexpr_stack_->context) 17528 { 17529 case FFEEXPR_contextSUBROUTINEREF: 17530 case FFEEXPR_contextDATA: 17531 case FFEEXPR_contextDATAIMPDOINDEX_: 17532 case FFEEXPR_contextSFUNCDEF: 17533 case FFEEXPR_contextSFUNCDEFINDEX_: 17534 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: 17535 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: 17536 case FFEEXPR_contextLET: 17537 case FFEEXPR_contextPAREN_: 17538 case FFEEXPR_contextACTUALARGEXPR_: 17539 case FFEEXPR_contextINDEXORACTUALARGEXPR_: 17540 case FFEEXPR_contextIOLIST: 17541 case FFEEXPR_contextIOLISTDF: 17542 case FFEEXPR_contextDO: 17543 case FFEEXPR_contextDOWHILE: 17544 case FFEEXPR_contextACTUALARG_: 17545 case FFEEXPR_contextCGOTO: 17546 case FFEEXPR_contextIF: 17547 case FFEEXPR_contextARITHIF: 17548 case FFEEXPR_contextFORMAT: 17549 case FFEEXPR_contextSTOP: 17550 case FFEEXPR_contextRETURN: 17551 case FFEEXPR_contextSELECTCASE: 17552 case FFEEXPR_contextCASE: 17553 case FFEEXPR_contextFILEASSOC: 17554 case FFEEXPR_contextFILEINT: 17555 case FFEEXPR_contextFILEDFINT: 17556 case FFEEXPR_contextFILELOG: 17557 case FFEEXPR_contextFILENUM: 17558 case FFEEXPR_contextFILENUMAMBIG: 17559 case FFEEXPR_contextFILECHAR: 17560 case FFEEXPR_contextFILENUMCHAR: 17561 case FFEEXPR_contextFILEDFCHAR: 17562 case FFEEXPR_contextFILEKEY: 17563 case FFEEXPR_contextFILEUNIT: 17564 case FFEEXPR_contextFILEUNIT_DF: 17565 case FFEEXPR_contextFILEUNITAMBIG: 17566 case FFEEXPR_contextFILEFORMAT: 17567 case FFEEXPR_contextFILENAMELIST: 17568 case FFEEXPR_contextFILEVXTCODE: 17569 case FFEEXPR_contextINDEX_: 17570 case FFEEXPR_contextIMPDOITEM_: 17571 case FFEEXPR_contextIMPDOITEMDF_: 17572 case FFEEXPR_contextIMPDOCTRL_: 17573 case FFEEXPR_contextDATAIMPDOCTRL_: 17574 case FFEEXPR_contextCHARACTERSIZE: 17575 case FFEEXPR_contextPARAMETER: 17576 case FFEEXPR_contextDIMLIST: 17577 case FFEEXPR_contextDIMLISTCOMMON: 17578 case FFEEXPR_contextKINDTYPE: 17579 case FFEEXPR_contextINITVAL: 17580 case FFEEXPR_contextEQVINDEX_: 17581 break; /* These could be intrinsic invocations. */ 17582 17583 case FFEEXPR_contextAGOTO: 17584 case FFEEXPR_contextFILEFORMATNML: 17585 case FFEEXPR_contextALLOCATE: 17586 case FFEEXPR_contextDEALLOCATE: 17587 case FFEEXPR_contextHEAPSTAT: 17588 case FFEEXPR_contextNULLIFY: 17589 case FFEEXPR_contextINCLUDE: 17590 case FFEEXPR_contextDATAIMPDOITEM_: 17591 case FFEEXPR_contextLOC_: 17592 case FFEEXPR_contextINDEXORACTUALARG_: 17593 case FFEEXPR_contextSFUNCDEFACTUALARG_: 17594 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 17595 case FFEEXPR_contextPARENFILENUM_: 17596 case FFEEXPR_contextPARENFILEUNIT_: 17597 maybe_intrin = FALSE; 17598 break; /* Can't be intrinsic invocation. */ 17599 17600 default: 17601 assert ("blah! blah! waaauuggh!" == NULL); 17602 break; 17603 } 17604 } 17605 17606 s = ffesymbol_declare_local (t, maybe_intrin); 17607 17608 switch (ffeexpr_context_outer_ (ffeexpr_stack_)) 17609 /* Special-case these since they can involve a different concept 17610 of "state" (in the stmtfunc name space). */ 17611 { 17612 case FFEEXPR_contextDATAIMPDOINDEX_: 17613 case FFEEXPR_contextDATAIMPDOCTRL_: 17614 if (ffeexpr_context_outer_ (ffeexpr_stack_) 17615 == FFEEXPR_contextDATAIMPDOINDEX_) 17616 s = ffeexpr_sym_impdoitem_ (s, t); 17617 else 17618 if (ffeexpr_stack_->is_rhs) 17619 s = ffeexpr_sym_impdoitem_ (s, t); 17620 else 17621 s = ffeexpr_sym_lhs_impdoctrl_ (s, t); 17622 if (ffesymbol_kind (s) != FFEINFO_kindANY) 17623 ffesymbol_error (s, t); 17624 return s; 17625 17626 default: 17627 break; 17628 } 17629 17630 switch ((ffesymbol_sfdummyparent (s) == NULL) 17631 ? ffesymbol_state (s) 17632 : FFESYMBOL_stateUNDERSTOOD) 17633 { 17634 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr 17635 context. */ 17636 if (!ffest_seen_first_exec ()) 17637 goto seen; /* :::::::::::::::::::: */ 17638 /* Fall through. */ 17639 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */ 17640 switch (ffeexpr_context_outer_ (ffeexpr_stack_)) 17641 { 17642 case FFEEXPR_contextSUBROUTINEREF: 17643 s = ffeexpr_sym_lhs_call_ (s, t); /* "CALL FOO"=="CALL 17644 FOO(...)". */ 17645 break; 17646 17647 case FFEEXPR_contextDATA: 17648 if (ffeexpr_stack_->is_rhs) 17649 s = ffeexpr_sym_rhs_let_ (s, t); 17650 else 17651 s = ffeexpr_sym_lhs_data_ (s, t); 17652 break; 17653 17654 case FFEEXPR_contextDATAIMPDOITEM_: 17655 s = ffeexpr_sym_lhs_data_ (s, t); 17656 break; 17657 17658 case FFEEXPR_contextSFUNCDEF: 17659 case FFEEXPR_contextSFUNCDEFINDEX_: 17660 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: 17661 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: 17662 s = ffecom_sym_exec_transition (s); 17663 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) 17664 goto understood; /* :::::::::::::::::::: */ 17665 /* Fall through. */ 17666 case FFEEXPR_contextLET: 17667 case FFEEXPR_contextPAREN_: 17668 case FFEEXPR_contextACTUALARGEXPR_: 17669 case FFEEXPR_contextINDEXORACTUALARGEXPR_: 17670 case FFEEXPR_contextIOLIST: 17671 case FFEEXPR_contextIOLISTDF: 17672 case FFEEXPR_contextDO: 17673 case FFEEXPR_contextDOWHILE: 17674 case FFEEXPR_contextACTUALARG_: 17675 case FFEEXPR_contextCGOTO: 17676 case FFEEXPR_contextIF: 17677 case FFEEXPR_contextARITHIF: 17678 case FFEEXPR_contextFORMAT: 17679 case FFEEXPR_contextSTOP: 17680 case FFEEXPR_contextRETURN: 17681 case FFEEXPR_contextSELECTCASE: 17682 case FFEEXPR_contextCASE: 17683 case FFEEXPR_contextFILEASSOC: 17684 case FFEEXPR_contextFILEINT: 17685 case FFEEXPR_contextFILEDFINT: 17686 case FFEEXPR_contextFILELOG: 17687 case FFEEXPR_contextFILENUM: 17688 case FFEEXPR_contextFILENUMAMBIG: 17689 case FFEEXPR_contextFILECHAR: 17690 case FFEEXPR_contextFILENUMCHAR: 17691 case FFEEXPR_contextFILEDFCHAR: 17692 case FFEEXPR_contextFILEKEY: 17693 case FFEEXPR_contextFILEUNIT: 17694 case FFEEXPR_contextFILEUNIT_DF: 17695 case FFEEXPR_contextFILEUNITAMBIG: 17696 case FFEEXPR_contextFILEFORMAT: 17697 case FFEEXPR_contextFILENAMELIST: 17698 case FFEEXPR_contextFILEVXTCODE: 17699 case FFEEXPR_contextINDEX_: 17700 case FFEEXPR_contextIMPDOITEM_: 17701 case FFEEXPR_contextIMPDOITEMDF_: 17702 case FFEEXPR_contextIMPDOCTRL_: 17703 case FFEEXPR_contextLOC_: 17704 if (ffeexpr_stack_->is_rhs) 17705 s = ffeexpr_paren_rhs_let_ (s, t); 17706 else 17707 s = ffeexpr_paren_lhs_let_ (s, t); 17708 break; 17709 17710 case FFEEXPR_contextASSIGN: 17711 case FFEEXPR_contextAGOTO: 17712 case FFEEXPR_contextCHARACTERSIZE: 17713 case FFEEXPR_contextEQUIVALENCE: 17714 case FFEEXPR_contextINCLUDE: 17715 case FFEEXPR_contextPARAMETER: 17716 case FFEEXPR_contextDIMLIST: 17717 case FFEEXPR_contextDIMLISTCOMMON: 17718 case FFEEXPR_contextKINDTYPE: 17719 case FFEEXPR_contextINITVAL: 17720 case FFEEXPR_contextEQVINDEX_: 17721 break; /* Will turn into errors below. */ 17722 17723 default: 17724 ffesymbol_error (s, t); 17725 break; 17726 } 17727 /* Fall through. */ 17728 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */ 17729 understood: /* :::::::::::::::::::: */ 17730 17731 /* State might have changed, update it. */ 17732 st = ((ffesymbol_sfdummyparent (s) == NULL) 17733 ? ffesymbol_state (s) 17734 : FFESYMBOL_stateUNDERSTOOD); 17735 17736 k = ffesymbol_kind (s); 17737 switch (ffeexpr_context_outer_ (ffeexpr_stack_)) 17738 { 17739 case FFEEXPR_contextSUBROUTINEREF: 17740 bad = ((k != FFEINFO_kindSUBROUTINE) 17741 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC) 17742 || (k != FFEINFO_kindNONE))); 17743 break; 17744 17745 case FFEEXPR_contextDATA: 17746 if (ffeexpr_stack_->is_rhs) 17747 bad = (k != FFEINFO_kindENTITY) 17748 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT); 17749 else 17750 bad = (k != FFEINFO_kindENTITY) 17751 || ((ffesymbol_where (s) != FFEINFO_whereNONE) 17752 && (ffesymbol_where (s) != FFEINFO_whereLOCAL) 17753 && (ffesymbol_where (s) != FFEINFO_whereCOMMON)); 17754 break; 17755 17756 case FFEEXPR_contextDATAIMPDOITEM_: 17757 bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0) 17758 || ((ffesymbol_where (s) != FFEINFO_whereNONE) 17759 && (ffesymbol_where (s) != FFEINFO_whereLOCAL) 17760 && (ffesymbol_where (s) != FFEINFO_whereCOMMON)); 17761 break; 17762 17763 case FFEEXPR_contextSFUNCDEF: 17764 case FFEEXPR_contextSFUNCDEFINDEX_: 17765 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: 17766 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: 17767 case FFEEXPR_contextLET: 17768 case FFEEXPR_contextPAREN_: 17769 case FFEEXPR_contextACTUALARGEXPR_: 17770 case FFEEXPR_contextINDEXORACTUALARGEXPR_: 17771 case FFEEXPR_contextIOLIST: 17772 case FFEEXPR_contextIOLISTDF: 17773 case FFEEXPR_contextDO: 17774 case FFEEXPR_contextDOWHILE: 17775 case FFEEXPR_contextACTUALARG_: 17776 case FFEEXPR_contextCGOTO: 17777 case FFEEXPR_contextIF: 17778 case FFEEXPR_contextARITHIF: 17779 case FFEEXPR_contextFORMAT: 17780 case FFEEXPR_contextSTOP: 17781 case FFEEXPR_contextRETURN: 17782 case FFEEXPR_contextSELECTCASE: 17783 case FFEEXPR_contextCASE: 17784 case FFEEXPR_contextFILEASSOC: 17785 case FFEEXPR_contextFILEINT: 17786 case FFEEXPR_contextFILEDFINT: 17787 case FFEEXPR_contextFILELOG: 17788 case FFEEXPR_contextFILENUM: 17789 case FFEEXPR_contextFILENUMAMBIG: 17790 case FFEEXPR_contextFILECHAR: 17791 case FFEEXPR_contextFILENUMCHAR: 17792 case FFEEXPR_contextFILEDFCHAR: 17793 case FFEEXPR_contextFILEKEY: 17794 case FFEEXPR_contextFILEUNIT: 17795 case FFEEXPR_contextFILEUNIT_DF: 17796 case FFEEXPR_contextFILEUNITAMBIG: 17797 case FFEEXPR_contextFILEFORMAT: 17798 case FFEEXPR_contextFILENAMELIST: 17799 case FFEEXPR_contextFILEVXTCODE: 17800 case FFEEXPR_contextINDEX_: 17801 case FFEEXPR_contextIMPDOITEM_: 17802 case FFEEXPR_contextIMPDOITEMDF_: 17803 case FFEEXPR_contextIMPDOCTRL_: 17804 case FFEEXPR_contextLOC_: 17805 bad = FALSE; /* Let paren-switch handle the cases. */ 17806 break; 17807 17808 case FFEEXPR_contextASSIGN: 17809 case FFEEXPR_contextAGOTO: 17810 case FFEEXPR_contextCHARACTERSIZE: 17811 case FFEEXPR_contextEQUIVALENCE: 17812 case FFEEXPR_contextPARAMETER: 17813 case FFEEXPR_contextDIMLIST: 17814 case FFEEXPR_contextDIMLISTCOMMON: 17815 case FFEEXPR_contextKINDTYPE: 17816 case FFEEXPR_contextINITVAL: 17817 case FFEEXPR_contextEQVINDEX_: 17818 bad = (k != FFEINFO_kindENTITY) 17819 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT); 17820 break; 17821 17822 case FFEEXPR_contextINCLUDE: 17823 bad = TRUE; 17824 break; 17825 17826 default: 17827 bad = TRUE; 17828 break; 17829 } 17830 17831 switch (bad ? FFEINFO_kindANY : k) 17832 { 17833 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */ 17834 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC) 17835 { 17836 if (ffeexpr_context_outer_ (ffeexpr_stack_) 17837 == FFEEXPR_contextSUBROUTINEREF) 17838 *paren_type = FFEEXPR_parentypeSUBROUTINE_; 17839 else 17840 *paren_type = FFEEXPR_parentypeFUNCTION_; 17841 break; 17842 } 17843 if (st == FFESYMBOL_stateUNDERSTOOD) 17844 { 17845 bad = TRUE; 17846 *paren_type = FFEEXPR_parentypeANY_; 17847 } 17848 else 17849 *paren_type = FFEEXPR_parentypeFUNSUBSTR_; 17850 break; 17851 17852 case FFEINFO_kindFUNCTION: 17853 *paren_type = FFEEXPR_parentypeFUNCTION_; 17854 switch (ffesymbol_where (s)) 17855 { 17856 case FFEINFO_whereLOCAL: 17857 bad = TRUE; /* Attempt to recurse! */ 17858 break; 17859 17860 case FFEINFO_whereCONSTANT: 17861 bad = ((ffesymbol_sfexpr (s) == NULL) 17862 || (ffebld_op (ffesymbol_sfexpr (s)) 17863 == FFEBLD_opANY)); /* Attempt to recurse! */ 17864 break; 17865 17866 default: 17867 break; 17868 } 17869 break; 17870 17871 case FFEINFO_kindSUBROUTINE: 17872 if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF) 17873 || (ffeexpr_stack_->previous != NULL)) 17874 { 17875 bad = TRUE; 17876 *paren_type = FFEEXPR_parentypeANY_; 17877 break; 17878 } 17879 17880 *paren_type = FFEEXPR_parentypeSUBROUTINE_; 17881 switch (ffesymbol_where (s)) 17882 { 17883 case FFEINFO_whereLOCAL: 17884 case FFEINFO_whereCONSTANT: 17885 bad = TRUE; /* Attempt to recurse! */ 17886 break; 17887 17888 default: 17889 break; 17890 } 17891 break; 17892 17893 case FFEINFO_kindENTITY: 17894 if (ffesymbol_rank (s) == 0) 17895 { 17896 if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER) 17897 *paren_type = FFEEXPR_parentypeSUBSTRING_; 17898 else 17899 { 17900 bad = TRUE; 17901 *paren_type = FFEEXPR_parentypeANY_; 17902 } 17903 } 17904 else 17905 *paren_type = FFEEXPR_parentypeARRAY_; 17906 break; 17907 17908 default: 17909 case FFEINFO_kindANY: 17910 bad = TRUE; 17911 *paren_type = FFEEXPR_parentypeANY_; 17912 break; 17913 } 17914 17915 if (bad) 17916 { 17917 if (k == FFEINFO_kindANY) 17918 ffest_shutdown (); 17919 else 17920 ffesymbol_error (s, t); 17921 } 17922 17923 return s; 17924 17925 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */ 17926 seen: /* :::::::::::::::::::: */ 17927 bad = TRUE; 17928 switch (ffeexpr_context_outer_ (ffeexpr_stack_)) 17929 { 17930 case FFEEXPR_contextPARAMETER: 17931 if (ffeexpr_stack_->is_rhs) 17932 ffesymbol_error (s, t); 17933 else 17934 s = ffeexpr_sym_lhs_parameter_ (s, t); 17935 break; 17936 17937 case FFEEXPR_contextDATA: 17938 s = ffecom_sym_exec_transition (s); 17939 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) 17940 goto understood; /* :::::::::::::::::::: */ 17941 if (ffeexpr_stack_->is_rhs) 17942 ffesymbol_error (s, t); 17943 else 17944 s = ffeexpr_sym_lhs_data_ (s, t); 17945 goto understood; /* :::::::::::::::::::: */ 17946 17947 case FFEEXPR_contextDATAIMPDOITEM_: 17948 s = ffecom_sym_exec_transition (s); 17949 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) 17950 goto understood; /* :::::::::::::::::::: */ 17951 s = ffeexpr_sym_lhs_data_ (s, t); 17952 goto understood; /* :::::::::::::::::::: */ 17953 17954 case FFEEXPR_contextEQUIVALENCE: 17955 s = ffeexpr_sym_lhs_equivalence_ (s, t); 17956 bad = FALSE; 17957 break; 17958 17959 case FFEEXPR_contextDIMLIST: 17960 s = ffeexpr_sym_rhs_dimlist_ (s, t); 17961 break; 17962 17963 case FFEEXPR_contextCHARACTERSIZE: 17964 case FFEEXPR_contextKINDTYPE: 17965 case FFEEXPR_contextDIMLISTCOMMON: 17966 case FFEEXPR_contextINITVAL: 17967 case FFEEXPR_contextEQVINDEX_: 17968 break; 17969 17970 case FFEEXPR_contextINCLUDE: 17971 break; 17972 17973 case FFEEXPR_contextINDEX_: 17974 case FFEEXPR_contextACTUALARGEXPR_: 17975 case FFEEXPR_contextINDEXORACTUALARGEXPR_: 17976 case FFEEXPR_contextSFUNCDEF: 17977 case FFEEXPR_contextSFUNCDEFINDEX_: 17978 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: 17979 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: 17980 assert (ffeexpr_stack_->is_rhs); 17981 s = ffecom_sym_exec_transition (s); 17982 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) 17983 goto understood; /* :::::::::::::::::::: */ 17984 s = ffeexpr_paren_rhs_let_ (s, t); 17985 goto understood; /* :::::::::::::::::::: */ 17986 17987 default: 17988 break; 17989 } 17990 k = ffesymbol_kind (s); 17991 switch (bad ? FFEINFO_kindANY : k) 17992 { 17993 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */ 17994 *paren_type = FFEEXPR_parentypeFUNSUBSTR_; 17995 break; 17996 17997 case FFEINFO_kindFUNCTION: 17998 *paren_type = FFEEXPR_parentypeFUNCTION_; 17999 switch (ffesymbol_where (s)) 18000 { 18001 case FFEINFO_whereLOCAL: 18002 bad = TRUE; /* Attempt to recurse! */ 18003 break; 18004 18005 case FFEINFO_whereCONSTANT: 18006 bad = ((ffesymbol_sfexpr (s) == NULL) 18007 || (ffebld_op (ffesymbol_sfexpr (s)) 18008 == FFEBLD_opANY)); /* Attempt to recurse! */ 18009 break; 18010 18011 default: 18012 break; 18013 } 18014 break; 18015 18016 case FFEINFO_kindSUBROUTINE: 18017 *paren_type = FFEEXPR_parentypeANY_; 18018 bad = TRUE; /* Cannot possibly be in 18019 contextSUBROUTINEREF. */ 18020 break; 18021 18022 case FFEINFO_kindENTITY: 18023 if (ffesymbol_rank (s) == 0) 18024 { 18025 if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE) 18026 *paren_type = FFEEXPR_parentypeEQUIVALENCE_; 18027 else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER) 18028 *paren_type = FFEEXPR_parentypeSUBSTRING_; 18029 else 18030 { 18031 bad = TRUE; 18032 *paren_type = FFEEXPR_parentypeANY_; 18033 } 18034 } 18035 else 18036 *paren_type = FFEEXPR_parentypeARRAY_; 18037 break; 18038 18039 default: 18040 case FFEINFO_kindANY: 18041 bad = TRUE; 18042 *paren_type = FFEEXPR_parentypeANY_; 18043 break; 18044 } 18045 18046 if (bad) 18047 { 18048 if (k == FFEINFO_kindANY) 18049 ffest_shutdown (); 18050 else 18051 ffesymbol_error (s, t); 18052 } 18053 18054 return s; 18055 18056 default: 18057 assert ("bad symbol state" == NULL); 18058 return NULL; 18059 } 18060} 18061 18062/* Have FOO in XYZ = ...FOO(...).... Executable context only. */ 18063 18064static ffesymbol 18065ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t) 18066{ 18067 ffesymbolAttrs sa; 18068 ffesymbolAttrs na; 18069 ffeinfoKind kind; 18070 ffeinfoWhere where; 18071 ffeintrinGen gen; 18072 ffeintrinSpec spec; 18073 ffeintrinImp imp; 18074 bool maybe_ambig = FALSE; 18075 bool error = FALSE; 18076 18077 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) 18078 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); 18079 18080 na = sa = ffesymbol_attrs (s); 18081 18082 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG 18083 | FFESYMBOL_attrsADJUSTABLE 18084 | FFESYMBOL_attrsANYLEN 18085 | FFESYMBOL_attrsARRAY 18086 | FFESYMBOL_attrsDUMMY 18087 | FFESYMBOL_attrsEXTERNAL 18088 | FFESYMBOL_attrsSFARG 18089 | FFESYMBOL_attrsTYPE))); 18090 18091 kind = ffesymbol_kind (s); 18092 where = ffesymbol_where (s); 18093 18094 /* Figure out what kind of object we've got based on previous declarations 18095 of or references to the object. */ 18096 18097 if (sa & FFESYMBOL_attrsEXTERNAL) 18098 { 18099 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG 18100 | FFESYMBOL_attrsDUMMY 18101 | FFESYMBOL_attrsEXTERNAL 18102 | FFESYMBOL_attrsTYPE))); 18103 18104 if (sa & FFESYMBOL_attrsTYPE) 18105 where = FFEINFO_whereGLOBAL; 18106 else 18107 /* Not TYPE. */ 18108 { 18109 kind = FFEINFO_kindFUNCTION; 18110 18111 if (sa & FFESYMBOL_attrsDUMMY) 18112 ; /* Not TYPE. */ 18113 else if (sa & FFESYMBOL_attrsACTUALARG) 18114 ; /* Not DUMMY or TYPE. */ 18115 else /* Not ACTUALARG, DUMMY, or TYPE. */ 18116 where = FFEINFO_whereGLOBAL; 18117 } 18118 } 18119 else if (sa & FFESYMBOL_attrsDUMMY) 18120 { 18121 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ 18122 assert (!(sa & ~(FFESYMBOL_attrsDUMMY 18123 | FFESYMBOL_attrsEXTERNAL 18124 | FFESYMBOL_attrsTYPE))); 18125 18126 kind = FFEINFO_kindFUNCTION; 18127 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; kind 18128 could be ENTITY w/substring ref. */ 18129 } 18130 else if (sa & FFESYMBOL_attrsARRAY) 18131 { 18132 assert (!(sa & ~(FFESYMBOL_attrsARRAY 18133 | FFESYMBOL_attrsADJUSTABLE 18134 | FFESYMBOL_attrsTYPE))); 18135 18136 where = FFEINFO_whereLOCAL; 18137 } 18138 else if (sa & FFESYMBOL_attrsSFARG) 18139 { 18140 assert (!(sa & ~(FFESYMBOL_attrsSFARG 18141 | FFESYMBOL_attrsTYPE))); 18142 18143 where = FFEINFO_whereLOCAL; /* Actually an error, but at least we 18144 know it's a local var. */ 18145 } 18146 else if (sa & FFESYMBOL_attrsTYPE) 18147 { 18148 assert (!(sa & (FFESYMBOL_attrsARRAY 18149 | FFESYMBOL_attrsDUMMY 18150 | FFESYMBOL_attrsEXTERNAL 18151 | FFESYMBOL_attrsSFARG))); /* Handled above. */ 18152 assert (!(sa & ~(FFESYMBOL_attrsTYPE 18153 | FFESYMBOL_attrsADJUSTABLE 18154 | FFESYMBOL_attrsANYLEN 18155 | FFESYMBOL_attrsARRAY 18156 | FFESYMBOL_attrsDUMMY 18157 | FFESYMBOL_attrsEXTERNAL 18158 | FFESYMBOL_attrsSFARG))); 18159 18160 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE, 18161 &gen, &spec, &imp)) 18162 { 18163 if (!(sa & FFESYMBOL_attrsANYLEN) 18164 && (ffeimplic_peek_symbol_type (s, NULL) 18165 == FFEINFO_basictypeCHARACTER)) 18166 return s; /* Haven't learned anything yet. */ 18167 18168 ffesymbol_signal_change (s); /* May need to back up to previous 18169 version. */ 18170 ffesymbol_set_generic (s, gen); 18171 ffesymbol_set_specific (s, spec); 18172 ffesymbol_set_implementation (s, imp); 18173 ffesymbol_set_info (s, 18174 ffeinfo_new (ffesymbol_basictype (s), 18175 ffesymbol_kindtype (s), 18176 0, 18177 FFEINFO_kindFUNCTION, 18178 FFEINFO_whereINTRINSIC, 18179 ffesymbol_size (s))); 18180 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 18181 ffesymbol_resolve_intrin (s); 18182 ffesymbol_reference (s, t, FALSE); 18183 s = ffecom_sym_learned (s); 18184 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 18185 18186 return s; 18187 } 18188 if (sa & FFESYMBOL_attrsANYLEN) 18189 error = TRUE; /* Error, since the only way we can, 18190 given CHARACTER*(*) FOO, accept 18191 FOO(...) is for FOO to be a dummy 18192 arg or constant, but it can't 18193 become either now. */ 18194 else if (sa & FFESYMBOL_attrsADJUSTABLE) 18195 { 18196 kind = FFEINFO_kindENTITY; 18197 where = FFEINFO_whereLOCAL; 18198 } 18199 else 18200 { 18201 kind = FFEINFO_kindFUNCTION; 18202 where = FFEINFO_whereGLOBAL; 18203 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; 18204 could be ENTITY/LOCAL w/substring ref. */ 18205 } 18206 } 18207 else if (sa == FFESYMBOL_attrsetNONE) 18208 { 18209 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); 18210 18211 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE, 18212 &gen, &spec, &imp)) 18213 { 18214 if (ffeimplic_peek_symbol_type (s, NULL) 18215 == FFEINFO_basictypeCHARACTER) 18216 return s; /* Haven't learned anything yet. */ 18217 18218 ffesymbol_signal_change (s); /* May need to back up to previous 18219 version. */ 18220 ffesymbol_set_generic (s, gen); 18221 ffesymbol_set_specific (s, spec); 18222 ffesymbol_set_implementation (s, imp); 18223 ffesymbol_set_info (s, 18224 ffeinfo_new (ffesymbol_basictype (s), 18225 ffesymbol_kindtype (s), 18226 0, 18227 FFEINFO_kindFUNCTION, 18228 FFEINFO_whereINTRINSIC, 18229 ffesymbol_size (s))); 18230 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 18231 ffesymbol_resolve_intrin (s); 18232 s = ffecom_sym_learned (s); 18233 ffesymbol_reference (s, t, FALSE); 18234 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 18235 return s; 18236 } 18237 18238 kind = FFEINFO_kindFUNCTION; 18239 where = FFEINFO_whereGLOBAL; 18240 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; 18241 could be ENTITY/LOCAL w/substring ref. */ 18242 } 18243 else 18244 error = TRUE; 18245 18246 /* Now see what we've got for a new object: NONE means a new error cropped 18247 up; ANY means an old error to be ignored; otherwise, everything's ok, 18248 update the object (symbol) and continue on. */ 18249 18250 if (error) 18251 ffesymbol_error (s, t); 18252 else if (!(na & FFESYMBOL_attrsANY)) 18253 { 18254 ffesymbol_signal_change (s); /* May need to back up to previous 18255 version. */ 18256 if (!ffeimplic_establish_symbol (s)) 18257 { 18258 ffesymbol_error (s, t); 18259 return s; 18260 } 18261 if (maybe_ambig 18262 && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)) 18263 return s; /* Still not sure, let caller deal with it 18264 based on (...). */ 18265 18266 ffesymbol_set_info (s, 18267 ffeinfo_new (ffesymbol_basictype (s), 18268 ffesymbol_kindtype (s), 18269 ffesymbol_rank (s), 18270 kind, 18271 where, 18272 ffesymbol_size (s))); 18273 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 18274 ffesymbol_resolve_intrin (s); 18275 s = ffecom_sym_learned (s); 18276 ffesymbol_reference (s, t, FALSE); 18277 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 18278 } 18279 18280 return s; 18281} 18282 18283/* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr 18284 18285 Return a pointer to this function to the lexer (ffelex), which will 18286 invoke it for the next token. 18287 18288 Handle expression (which might be null) and COMMA or CLOSE_PAREN. */ 18289 18290static ffelexHandler 18291ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t) 18292{ 18293 ffeexprExpr_ procedure; 18294 ffebld reduced; 18295 ffeinfo info; 18296 ffeexprContext ctx; 18297 bool check_intrin = FALSE; /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */ 18298 18299 procedure = ffeexpr_stack_->exprstack; 18300 info = ffebld_info (procedure->u.operand); 18301 18302 /* Is there an expression to add? If the expression is nil, 18303 it might still be an argument. It is if: 18304 18305 - The current token is comma, or 18306 18307 - The -fugly-comma flag was specified *and* the procedure 18308 being invoked is external. 18309 18310 Otherwise, if neither of the above is the case, just 18311 ignore this (nil) expression. */ 18312 18313 if ((expr != NULL) 18314 || (ffelex_token_type (t) == FFELEX_typeCOMMA) 18315 || (ffe_is_ugly_comma () 18316 && (ffeinfo_where (info) == FFEINFO_whereGLOBAL))) 18317 { 18318 /* This expression, even if nil, is apparently intended as an argument. */ 18319 18320 /* Internal procedure (CONTAINS, or statement function)? */ 18321 18322 if (ffeinfo_where (info) == FFEINFO_whereCONSTANT) 18323 { 18324 if ((expr == NULL) 18325 && ffebad_start (FFEBAD_NULL_ARGUMENT)) 18326 { 18327 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), 18328 ffelex_token_where_column (ffeexpr_stack_->tokens[0])); 18329 ffebad_here (1, ffelex_token_where_line (t), 18330 ffelex_token_where_column (t)); 18331 ffebad_finish (); 18332 } 18333 18334 if (expr == NULL) 18335 ; 18336 else 18337 { 18338 if (ffeexpr_stack_->next_dummy == NULL) 18339 { /* Report later which was the first extra argument. */ 18340 if (ffeexpr_stack_->tokens[1] == NULL) 18341 { 18342 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft); 18343 ffeexpr_stack_->num_args = 0; 18344 } 18345 ++ffeexpr_stack_->num_args; /* Count # of extra arguments. */ 18346 } 18347 else 18348 { 18349 if ((ffeinfo_rank (ffebld_info (expr)) != 0) 18350 && ffebad_start (FFEBAD_ARRAY_AS_SFARG)) 18351 { 18352 ffebad_here (0, 18353 ffelex_token_where_line (ffeexpr_stack_->tokens[0]), 18354 ffelex_token_where_column (ffeexpr_stack_->tokens[0])); 18355 ffebad_here (1, ffelex_token_where_line (ft), 18356 ffelex_token_where_column (ft)); 18357 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent 18358 (ffebld_symter (ffebld_head 18359 (ffeexpr_stack_->next_dummy))))); 18360 ffebad_finish (); 18361 } 18362 else 18363 { 18364 expr = ffeexpr_convert_expr (expr, ft, 18365 ffebld_head (ffeexpr_stack_->next_dummy), 18366 ffeexpr_stack_->tokens[0], 18367 FFEEXPR_contextLET); 18368 ffebld_append_item (&ffeexpr_stack_->bottom, expr); 18369 } 18370 --ffeexpr_stack_->num_args; /* Count down # of args. */ 18371 ffeexpr_stack_->next_dummy 18372 = ffebld_trail (ffeexpr_stack_->next_dummy); 18373 } 18374 } 18375 } 18376 else 18377 { 18378 if ((expr == NULL) 18379 && ffe_is_pedantic () 18380 && ffebad_start (FFEBAD_NULL_ARGUMENT_W)) 18381 { 18382 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), 18383 ffelex_token_where_column (ffeexpr_stack_->tokens[0])); 18384 ffebad_here (1, ffelex_token_where_line (t), 18385 ffelex_token_where_column (t)); 18386 ffebad_finish (); 18387 } 18388 ffebld_append_item (&ffeexpr_stack_->bottom, expr); 18389 } 18390 } 18391 18392 switch (ffelex_token_type (t)) 18393 { 18394 case FFELEX_typeCOMMA: 18395 switch (ffeexpr_context_outer_ (ffeexpr_stack_)) 18396 { 18397 case FFEEXPR_contextSFUNCDEF: 18398 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: 18399 case FFEEXPR_contextSFUNCDEFINDEX_: 18400 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: 18401 ctx = FFEEXPR_contextSFUNCDEFACTUALARG_; 18402 break; 18403 18404 case FFEEXPR_contextSFUNCDEFACTUALARG_: 18405 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 18406 assert ("bad context" == NULL); 18407 ctx = FFEEXPR_context; 18408 break; 18409 18410 default: 18411 ctx = FFEEXPR_contextACTUALARG_; 18412 break; 18413 } 18414 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx, 18415 ffeexpr_token_arguments_); 18416 18417 default: 18418 break; 18419 } 18420 18421 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT) 18422 && (ffeexpr_stack_->next_dummy != NULL)) 18423 { /* Too few arguments. */ 18424 if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS)) 18425 { 18426 char num[10]; 18427 18428 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args); 18429 18430 ffebad_here (0, ffelex_token_where_line (t), 18431 ffelex_token_where_column (t)); 18432 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), 18433 ffelex_token_where_column (ffeexpr_stack_->tokens[0])); 18434 ffebad_string (num); 18435 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter 18436 (ffebld_head (ffeexpr_stack_->next_dummy))))); 18437 ffebad_finish (); 18438 } 18439 for (; 18440 ffeexpr_stack_->next_dummy != NULL; 18441 ffeexpr_stack_->next_dummy 18442 = ffebld_trail (ffeexpr_stack_->next_dummy)) 18443 { 18444 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0)); 18445 ffebld_set_info (expr, ffeinfo_new_any ()); 18446 ffebld_append_item (&ffeexpr_stack_->bottom, expr); 18447 } 18448 } 18449 18450 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT) 18451 && (ffeexpr_stack_->tokens[1] != NULL)) 18452 { /* Too many arguments to statement function. */ 18453 if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS)) 18454 { 18455 char num[10]; 18456 18457 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args); 18458 18459 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]), 18460 ffelex_token_where_column (ffeexpr_stack_->tokens[1])); 18461 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), 18462 ffelex_token_where_column (ffeexpr_stack_->tokens[0])); 18463 ffebad_string (num); 18464 ffebad_finish (); 18465 } 18466 ffelex_token_kill (ffeexpr_stack_->tokens[1]); 18467 } 18468 ffebld_end_list (&ffeexpr_stack_->bottom); 18469 18470 if (ffebld_op (procedure->u.operand) == FFEBLD_opANY) 18471 { 18472 reduced = ffebld_new_any (); 18473 ffebld_set_info (reduced, ffeinfo_new_any ()); 18474 } 18475 else 18476 { 18477 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF) 18478 reduced = ffebld_new_funcref (procedure->u.operand, 18479 ffeexpr_stack_->expr); 18480 else 18481 reduced = ffebld_new_subrref (procedure->u.operand, 18482 ffeexpr_stack_->expr); 18483 if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE) 18484 ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]); 18485 else if (ffebld_symter_specific (procedure->u.operand) 18486 != FFEINTRIN_specNONE) 18487 ffeintrin_fulfill_specific (&reduced, &info, &check_intrin, 18488 ffeexpr_stack_->tokens[0]); 18489 else 18490 ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]); 18491 18492 if (ffebld_op (reduced) != FFEBLD_opANY) 18493 ffebld_set_info (reduced, 18494 ffeinfo_new (ffeinfo_basictype (info), 18495 ffeinfo_kindtype (info), 18496 0, 18497 FFEINFO_kindENTITY, 18498 FFEINFO_whereFLEETING, 18499 ffeinfo_size (info))); 18500 else 18501 ffebld_set_info (reduced, ffeinfo_new_any ()); 18502 } 18503 if (ffebld_op (reduced) == FFEBLD_opFUNCREF) 18504 reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]); 18505 ffeexpr_stack_->exprstack = procedure->previous; /* Pops 18506 not-quite-operand off 18507 stack. */ 18508 procedure->u.operand = reduced; /* Save the line/column ffewhere 18509 info. */ 18510 ffeexpr_exprstack_push_operand_ (procedure); /* Push it back on stack. */ 18511 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) 18512 { 18513 ffelex_token_kill (ffeexpr_stack_->tokens[0]); 18514 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FUNC(3)(1:1)".... */ 18515 18516 /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where 18517 Z is DOUBLE COMPLEX), and a command-line option doesn't already 18518 establish interpretation, probably complain. */ 18519 18520 if (check_intrin 18521 && !ffe_is_90 () 18522 && !ffe_is_ugly_complex ()) 18523 { 18524 /* If the outer expression is REAL(me...), issue diagnostic 18525 only if next token isn't the close-paren for REAL(me). */ 18526 18527 if ((ffeexpr_stack_->previous != NULL) 18528 && (ffeexpr_stack_->previous->exprstack != NULL) 18529 && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_) 18530 && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL) 18531 && (ffebld_op (reduced) == FFEBLD_opSYMTER) 18532 && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL)) 18533 return (ffelexHandler) ffeexpr_token_intrincheck_; 18534 18535 /* Diagnose the ambiguity now. */ 18536 18537 if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG)) 18538 { 18539 ffebad_string (ffeintrin_name_implementation 18540 (ffebld_symter_implementation 18541 (ffebld_left 18542 (ffeexpr_stack_->exprstack->u.operand)))); 18543 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token), 18544 ffelex_token_where_column (ffeexpr_stack_->exprstack->token)); 18545 ffebad_finish (); 18546 } 18547 } 18548 return (ffelexHandler) ffeexpr_token_substrp_; 18549 } 18550 18551 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) 18552 { 18553 ffebad_here (0, ffelex_token_where_line (t), 18554 ffelex_token_where_column (t)); 18555 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), 18556 ffelex_token_where_column (ffeexpr_stack_->tokens[0])); 18557 ffebad_finish (); 18558 } 18559 ffelex_token_kill (ffeexpr_stack_->tokens[0]); 18560 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */ 18561 return 18562 (ffelexHandler) ffeexpr_find_close_paren_ (t, 18563 (ffelexHandler) 18564 ffeexpr_token_substrp_); 18565} 18566 18567/* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr 18568 18569 Return a pointer to this array to the lexer (ffelex), which will 18570 invoke it for the next token. 18571 18572 Handle expression and COMMA or CLOSE_PAREN. */ 18573 18574static ffelexHandler 18575ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t) 18576{ 18577 ffeexprExpr_ array; 18578 ffebld reduced; 18579 ffeinfo info; 18580 ffeinfoWhere where; 18581 ffetargetIntegerDefault val; 18582 ffetargetIntegerDefault lval = 0; 18583 ffetargetIntegerDefault uval = 0; 18584 ffebld lbound; 18585 ffebld ubound; 18586 bool lcheck; 18587 bool ucheck; 18588 18589 array = ffeexpr_stack_->exprstack; 18590 info = ffebld_info (array->u.operand); 18591 18592 if ((expr == NULL) /* && ((ffeexpr_stack_->rank != 0) || 18593 (ffelex_token_type(t) == 18594 FFELEX_typeCOMMA)) */ ) 18595 { 18596 if (ffebad_start (FFEBAD_NULL_ELEMENT)) 18597 { 18598 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), 18599 ffelex_token_where_column (ffeexpr_stack_->tokens[0])); 18600 ffebad_here (1, ffelex_token_where_line (t), 18601 ffelex_token_where_column (t)); 18602 ffebad_finish (); 18603 } 18604 if (ffeexpr_stack_->rank < ffeinfo_rank (info)) 18605 { /* Don't bother if we're going to complain 18606 later! */ 18607 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1)); 18608 ffebld_set_info (expr, ffeinfo_new_any ()); 18609 } 18610 } 18611 18612 if (expr == NULL) 18613 ; 18614 else if (ffeinfo_rank (info) == 0) 18615 { /* In EQUIVALENCE context, ffeinfo_rank(info) 18616 may == 0. */ 18617 ++ffeexpr_stack_->rank; /* Track anyway, may need for new VXT 18618 feature. */ 18619 ffebld_append_item (&ffeexpr_stack_->bottom, expr); 18620 } 18621 else 18622 { 18623 ++ffeexpr_stack_->rank; 18624 if (ffeexpr_stack_->rank > ffeinfo_rank (info)) 18625 { /* Report later which was the first extra 18626 element. */ 18627 if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1) 18628 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft); 18629 } 18630 else 18631 { 18632 switch (ffeinfo_where (ffebld_info (expr))) 18633 { 18634 case FFEINFO_whereCONSTANT: 18635 break; 18636 18637 case FFEINFO_whereIMMEDIATE: 18638 ffeexpr_stack_->constant = FALSE; 18639 break; 18640 18641 default: 18642 ffeexpr_stack_->constant = FALSE; 18643 ffeexpr_stack_->immediate = FALSE; 18644 break; 18645 } 18646 if (ffebld_op (expr) == FFEBLD_opCONTER 18647 && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT) 18648 { 18649 val = ffebld_constant_integerdefault (ffebld_conter (expr)); 18650 18651 lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list)); 18652 if (lbound == NULL) 18653 { 18654 lcheck = TRUE; 18655 lval = 1; 18656 } 18657 else if (ffebld_op (lbound) == FFEBLD_opCONTER) 18658 { 18659 lcheck = TRUE; 18660 lval = ffebld_constant_integerdefault (ffebld_conter (lbound)); 18661 } 18662 else 18663 lcheck = FALSE; 18664 18665 ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list)); 18666 assert (ubound != NULL); 18667 if (ffebld_op (ubound) == FFEBLD_opCONTER) 18668 { 18669 ucheck = TRUE; 18670 uval = ffebld_constant_integerdefault (ffebld_conter (ubound)); 18671 } 18672 else 18673 ucheck = FALSE; 18674 18675 if ((lcheck && (val < lval)) || (ucheck && (val > uval))) 18676 { 18677 ffebad_start (FFEBAD_RANGE_ARRAY); 18678 ffebad_here (0, ffelex_token_where_line (ft), 18679 ffelex_token_where_column (ft)); 18680 ffebad_finish (); 18681 } 18682 } 18683 ffebld_append_item (&ffeexpr_stack_->bottom, expr); 18684 ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list); 18685 } 18686 } 18687 18688 switch (ffelex_token_type (t)) 18689 { 18690 case FFELEX_typeCOMMA: 18691 switch (ffeexpr_context_outer_ (ffeexpr_stack_)) 18692 { 18693 case FFEEXPR_contextDATAIMPDOITEM_: 18694 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 18695 FFEEXPR_contextDATAIMPDOINDEX_, 18696 ffeexpr_token_elements_); 18697 18698 case FFEEXPR_contextEQUIVALENCE: 18699 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 18700 FFEEXPR_contextEQVINDEX_, 18701 ffeexpr_token_elements_); 18702 18703 case FFEEXPR_contextSFUNCDEF: 18704 case FFEEXPR_contextSFUNCDEFINDEX_: 18705 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 18706 FFEEXPR_contextSFUNCDEFINDEX_, 18707 ffeexpr_token_elements_); 18708 18709 case FFEEXPR_contextSFUNCDEFACTUALARG_: 18710 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 18711 assert ("bad context" == NULL); 18712 break; 18713 18714 default: 18715 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 18716 FFEEXPR_contextINDEX_, 18717 ffeexpr_token_elements_); 18718 } 18719 18720 default: 18721 break; 18722 } 18723 18724 if ((ffeexpr_stack_->rank != ffeinfo_rank (info)) 18725 && (ffeinfo_rank (info) != 0)) 18726 { 18727 char num[10]; 18728 18729 if (ffeexpr_stack_->rank < ffeinfo_rank (info)) 18730 { 18731 if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS)) 18732 { 18733 sprintf (num, "%d", 18734 (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank)); 18735 18736 ffebad_here (0, ffelex_token_where_line (t), 18737 ffelex_token_where_column (t)); 18738 ffebad_here (1, 18739 ffelex_token_where_line (ffeexpr_stack_->tokens[0]), 18740 ffelex_token_where_column (ffeexpr_stack_->tokens[0])); 18741 ffebad_string (num); 18742 ffebad_finish (); 18743 } 18744 } 18745 else 18746 { 18747 if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS)) 18748 { 18749 sprintf (num, "%d", 18750 (int) (ffeexpr_stack_->rank - ffeinfo_rank (info))); 18751 18752 ffebad_here (0, 18753 ffelex_token_where_line (ffeexpr_stack_->tokens[1]), 18754 ffelex_token_where_column (ffeexpr_stack_->tokens[1])); 18755 ffebad_here (1, 18756 ffelex_token_where_line (ffeexpr_stack_->tokens[0]), 18757 ffelex_token_where_column (ffeexpr_stack_->tokens[0])); 18758 ffebad_string (num); 18759 ffebad_finish (); 18760 } 18761 ffelex_token_kill (ffeexpr_stack_->tokens[1]); 18762 } 18763 while (ffeexpr_stack_->rank++ < ffeinfo_rank (info)) 18764 { 18765 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1)); 18766 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER, 18767 FFEINFO_kindtypeINTEGERDEFAULT, 18768 0, FFEINFO_kindENTITY, 18769 FFEINFO_whereCONSTANT, 18770 FFETARGET_charactersizeNONE)); 18771 ffebld_append_item (&ffeexpr_stack_->bottom, expr); 18772 } 18773 } 18774 ffebld_end_list (&ffeexpr_stack_->bottom); 18775 18776 if (ffebld_op (array->u.operand) == FFEBLD_opANY) 18777 { 18778 reduced = ffebld_new_any (); 18779 ffebld_set_info (reduced, ffeinfo_new_any ()); 18780 } 18781 else 18782 { 18783 reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr); 18784 if (ffeexpr_stack_->constant) 18785 where = FFEINFO_whereFLEETING_CADDR; 18786 else if (ffeexpr_stack_->immediate) 18787 where = FFEINFO_whereFLEETING_IADDR; 18788 else 18789 where = FFEINFO_whereFLEETING; 18790 ffebld_set_info (reduced, 18791 ffeinfo_new (ffeinfo_basictype (info), 18792 ffeinfo_kindtype (info), 18793 0, 18794 FFEINFO_kindENTITY, 18795 where, 18796 ffeinfo_size (info))); 18797 reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]); 18798 } 18799 18800 ffeexpr_stack_->exprstack = array->previous; /* Pops not-quite-operand off 18801 stack. */ 18802 array->u.operand = reduced; /* Save the line/column ffewhere info. */ 18803 ffeexpr_exprstack_push_operand_ (array); /* Push it back on stack. */ 18804 18805 switch (ffeinfo_basictype (info)) 18806 { 18807 case FFEINFO_basictypeCHARACTER: 18808 ffeexpr_is_substr_ok_ = TRUE; /* Everyone likes "FOO(3)(1:1)".... */ 18809 break; 18810 18811 case FFEINFO_basictypeNONE: 18812 ffeexpr_is_substr_ok_ = TRUE; 18813 assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE); 18814 break; 18815 18816 default: 18817 ffeexpr_is_substr_ok_ = FALSE; 18818 break; 18819 } 18820 18821 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) 18822 { 18823 ffelex_token_kill (ffeexpr_stack_->tokens[0]); 18824 return (ffelexHandler) ffeexpr_token_substrp_; 18825 } 18826 18827 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) 18828 { 18829 ffebad_here (0, ffelex_token_where_line (t), 18830 ffelex_token_where_column (t)); 18831 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), 18832 ffelex_token_where_column (ffeexpr_stack_->tokens[0])); 18833 ffebad_finish (); 18834 } 18835 ffelex_token_kill (ffeexpr_stack_->tokens[0]); 18836 return 18837 (ffelexHandler) ffeexpr_find_close_paren_ (t, 18838 (ffelexHandler) 18839 ffeexpr_token_substrp_); 18840} 18841 18842/* ffeexpr_token_equivalence_ -- OPEN_PAREN expr 18843 18844 Return a pointer to this array to the lexer (ffelex), which will 18845 invoke it for the next token. 18846 18847 If token is COLON, pass off to _substr_, else init list and pass off 18848 to _elements_. This handles the case "EQUIVALENCE (FOO(expr?", where 18849 ? marks the token, and where FOO's rank/type has not yet been established, 18850 meaning we could be in a list of indices or in a substring 18851 specification. */ 18852 18853static ffelexHandler 18854ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t) 18855{ 18856 if (ffelex_token_type (t) == FFELEX_typeCOLON) 18857 return ffeexpr_token_substring_ (ft, expr, t); 18858 18859 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); 18860 return ffeexpr_token_elements_ (ft, expr, t); 18861} 18862 18863/* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr 18864 18865 Return a pointer to this function to the lexer (ffelex), which will 18866 invoke it for the next token. 18867 18868 Handle expression (which may be null) and COLON. */ 18869 18870static ffelexHandler 18871ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t) 18872{ 18873 ffeexprExpr_ string; 18874 ffeinfo info; 18875 ffetargetIntegerDefault i; 18876 ffeexprContext ctx; 18877 ffetargetCharacterSize size; 18878 18879 string = ffeexpr_stack_->exprstack; 18880 info = ffebld_info (string->u.operand); 18881 size = ffebld_size_max (string->u.operand); 18882 18883 if (ffelex_token_type (t) == FFELEX_typeCOLON) 18884 { 18885 if ((expr != NULL) 18886 && (ffebld_op (expr) == FFEBLD_opCONTER) 18887 && (((i = ffebld_constant_integerdefault (ffebld_conter (expr))) 18888 < 1) 18889 || ((size != FFETARGET_charactersizeNONE) && (i > size)))) 18890 { 18891 ffebad_start (FFEBAD_RANGE_SUBSTR); 18892 ffebad_here (0, ffelex_token_where_line (ft), 18893 ffelex_token_where_column (ft)); 18894 ffebad_finish (); 18895 } 18896 ffeexpr_stack_->expr = expr; 18897 18898 switch (ffeexpr_stack_->context) 18899 { 18900 case FFEEXPR_contextSFUNCDEF: 18901 case FFEEXPR_contextSFUNCDEFINDEX_: 18902 ctx = FFEEXPR_contextSFUNCDEFINDEX_; 18903 break; 18904 18905 case FFEEXPR_contextSFUNCDEFACTUALARG_: 18906 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 18907 assert ("bad context" == NULL); 18908 ctx = FFEEXPR_context; 18909 break; 18910 18911 default: 18912 ctx = FFEEXPR_contextINDEX_; 18913 break; 18914 } 18915 18916 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx, 18917 ffeexpr_token_substring_1_); 18918 } 18919 18920 if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR)) 18921 { 18922 ffebad_here (0, ffelex_token_where_line (t), 18923 ffelex_token_where_column (t)); 18924 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), 18925 ffelex_token_where_column (ffeexpr_stack_->tokens[0])); 18926 ffebad_finish (); 18927 } 18928 18929 ffeexpr_stack_->expr = NULL; 18930 return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t); 18931} 18932 18933/* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr 18934 18935 Return a pointer to this function to the lexer (ffelex), which will 18936 invoke it for the next token. 18937 18938 Handle expression (which might be null) and CLOSE_PAREN. */ 18939 18940static ffelexHandler 18941ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t) 18942{ 18943 ffeexprExpr_ string; 18944 ffebld reduced; 18945 ffebld substrlist; 18946 ffebld first = ffeexpr_stack_->expr; 18947 ffebld strop; 18948 ffeinfo info; 18949 ffeinfoWhere lwh; 18950 ffeinfoWhere rwh; 18951 ffeinfoWhere where; 18952 ffeinfoKindtype first_kt; 18953 ffeinfoKindtype last_kt; 18954 ffetargetIntegerDefault first_val; 18955 ffetargetIntegerDefault last_val; 18956 ffetargetCharacterSize size; 18957 ffetargetCharacterSize strop_size_max; 18958 bool first_known; 18959 18960 string = ffeexpr_stack_->exprstack; 18961 strop = string->u.operand; 18962 info = ffebld_info (strop); 18963 18964 if (first == NULL 18965 || (ffebld_op (first) == FFEBLD_opCONTER 18966 && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT)) 18967 { /* The starting point is known. */ 18968 first_val = (first == NULL) ? 1 18969 : ffebld_constant_integerdefault (ffebld_conter (first)); 18970 first_known = TRUE; 18971 } 18972 else 18973 { /* Assume start of the entity. */ 18974 first_val = 1; 18975 first_known = FALSE; 18976 } 18977 18978 if (last != NULL 18979 && (ffebld_op (last) == FFEBLD_opCONTER 18980 && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT)) 18981 { /* The ending point is known. */ 18982 last_val = ffebld_constant_integerdefault (ffebld_conter (last)); 18983 18984 if (first_known) 18985 { /* The beginning point is a constant. */ 18986 if (first_val <= last_val) 18987 size = last_val - first_val + 1; 18988 else 18989 { 18990 if (0 && ffe_is_90 ()) 18991 size = 0; 18992 else 18993 { 18994 size = 1; 18995 ffebad_start (FFEBAD_ZERO_SIZE); 18996 ffebad_here (0, ffelex_token_where_line (ft), 18997 ffelex_token_where_column (ft)); 18998 ffebad_finish (); 18999 } 19000 } 19001 } 19002 else 19003 size = FFETARGET_charactersizeNONE; 19004 19005 strop_size_max = ffebld_size_max (strop); 19006 19007 if ((strop_size_max != FFETARGET_charactersizeNONE) 19008 && (last_val > strop_size_max)) 19009 { /* Beyond maximum possible end of string. */ 19010 ffebad_start (FFEBAD_RANGE_SUBSTR); 19011 ffebad_here (0, ffelex_token_where_line (ft), 19012 ffelex_token_where_column (ft)); 19013 ffebad_finish (); 19014 } 19015 } 19016 else 19017 size = FFETARGET_charactersizeNONE; /* The size is not known. */ 19018 19019#if 0 /* Don't do this, or "is size of target 19020 known?" would no longer be easily 19021 answerable. To see if there is a max 19022 size, use ffebld_size_max; to get only the 19023 known size, else NONE, use 19024 ffebld_size_known; use ffebld_size if 19025 values are sure to be the same (not 19026 opSUBSTR or opCONCATENATE or known to have 19027 known length). By getting rid of this 19028 "useful info" stuff, we don't end up 19029 blank-padding the constant in the 19030 assignment "A(I:J)='XYZ'" to the known 19031 length of A. */ 19032 if (size == FFETARGET_charactersizeNONE) 19033 size = strop_size_max; /* Assume we use the entire string. */ 19034#endif 19035 19036 substrlist 19037 = ffebld_new_item 19038 (first, 19039 ffebld_new_item 19040 (last, 19041 NULL 19042 ) 19043 ) 19044 ; 19045 19046 if (first == NULL) 19047 lwh = FFEINFO_whereCONSTANT; 19048 else 19049 lwh = ffeinfo_where (ffebld_info (first)); 19050 if (last == NULL) 19051 rwh = FFEINFO_whereCONSTANT; 19052 else 19053 rwh = ffeinfo_where (ffebld_info (last)); 19054 19055 switch (lwh) 19056 { 19057 case FFEINFO_whereCONSTANT: 19058 switch (rwh) 19059 { 19060 case FFEINFO_whereCONSTANT: 19061 where = FFEINFO_whereCONSTANT; 19062 break; 19063 19064 case FFEINFO_whereIMMEDIATE: 19065 where = FFEINFO_whereIMMEDIATE; 19066 break; 19067 19068 default: 19069 where = FFEINFO_whereFLEETING; 19070 break; 19071 } 19072 break; 19073 19074 case FFEINFO_whereIMMEDIATE: 19075 switch (rwh) 19076 { 19077 case FFEINFO_whereCONSTANT: 19078 case FFEINFO_whereIMMEDIATE: 19079 where = FFEINFO_whereIMMEDIATE; 19080 break; 19081 19082 default: 19083 where = FFEINFO_whereFLEETING; 19084 break; 19085 } 19086 break; 19087 19088 default: 19089 where = FFEINFO_whereFLEETING; 19090 break; 19091 } 19092 19093 if (first == NULL) 19094 first_kt = FFEINFO_kindtypeINTEGERDEFAULT; 19095 else 19096 first_kt = ffeinfo_kindtype (ffebld_info (first)); 19097 if (last == NULL) 19098 last_kt = FFEINFO_kindtypeINTEGERDEFAULT; 19099 else 19100 last_kt = ffeinfo_kindtype (ffebld_info (last)); 19101 19102 switch (where) 19103 { 19104 case FFEINFO_whereCONSTANT: 19105 switch (ffeinfo_where (info)) 19106 { 19107 case FFEINFO_whereCONSTANT: 19108 break; 19109 19110 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */ 19111 where = FFEINFO_whereIMMEDIATE; 19112 break; 19113 19114 default: 19115 where = FFEINFO_whereFLEETING_CADDR; 19116 break; 19117 } 19118 break; 19119 19120 case FFEINFO_whereIMMEDIATE: 19121 switch (ffeinfo_where (info)) 19122 { 19123 case FFEINFO_whereCONSTANT: 19124 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */ 19125 break; 19126 19127 default: 19128 where = FFEINFO_whereFLEETING_IADDR; 19129 break; 19130 } 19131 break; 19132 19133 default: 19134 switch (ffeinfo_where (info)) 19135 { 19136 case FFEINFO_whereCONSTANT: 19137 where = FFEINFO_whereCONSTANT_SUBOBJECT; /* An F90 concept. */ 19138 break; 19139 19140 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */ 19141 default: 19142 where = FFEINFO_whereFLEETING; 19143 break; 19144 } 19145 break; 19146 } 19147 19148 if (ffebld_op (strop) == FFEBLD_opANY) 19149 { 19150 reduced = ffebld_new_any (); 19151 ffebld_set_info (reduced, ffeinfo_new_any ()); 19152 } 19153 else 19154 { 19155 reduced = ffebld_new_substr (strop, substrlist); 19156 ffebld_set_info (reduced, ffeinfo_new 19157 (FFEINFO_basictypeCHARACTER, 19158 ffeinfo_kindtype (info), 19159 0, 19160 FFEINFO_kindENTITY, 19161 where, 19162 size)); 19163 reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]); 19164 } 19165 19166 ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off 19167 stack. */ 19168 string->u.operand = reduced; /* Save the line/column ffewhere info. */ 19169 ffeexpr_exprstack_push_operand_ (string); /* Push it back on stack. */ 19170 19171 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) 19172 { 19173 ffelex_token_kill (ffeexpr_stack_->tokens[0]); 19174 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FOO(3:5)(1:1)".... */ 19175 return (ffelexHandler) ffeexpr_token_substrp_; 19176 } 19177 19178 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) 19179 { 19180 ffebad_here (0, ffelex_token_where_line (t), 19181 ffelex_token_where_column (t)); 19182 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), 19183 ffelex_token_where_column (ffeexpr_stack_->tokens[0])); 19184 ffebad_finish (); 19185 } 19186 19187 ffelex_token_kill (ffeexpr_stack_->tokens[0]); 19188 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */ 19189 return 19190 (ffelexHandler) ffeexpr_find_close_paren_ (t, 19191 (ffelexHandler) 19192 ffeexpr_token_substrp_); 19193} 19194 19195/* ffeexpr_token_substrp_ -- Rhs <character entity> 19196 19197 Return a pointer to this function to the lexer (ffelex), which will 19198 invoke it for the next token. 19199 19200 If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and 19201 issue error message if flag (serves as argument) is set. Else, just 19202 forward token to binary_. */ 19203 19204static ffelexHandler 19205ffeexpr_token_substrp_ (ffelexToken t) 19206{ 19207 ffeexprContext ctx; 19208 19209 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN) 19210 return (ffelexHandler) ffeexpr_token_binary_ (t); 19211 19212 ffeexpr_stack_->tokens[0] = ffelex_token_use (t); 19213 19214 switch (ffeexpr_stack_->context) 19215 { 19216 case FFEEXPR_contextSFUNCDEF: 19217 case FFEEXPR_contextSFUNCDEFINDEX_: 19218 ctx = FFEEXPR_contextSFUNCDEFINDEX_; 19219 break; 19220 19221 case FFEEXPR_contextSFUNCDEFACTUALARG_: 19222 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: 19223 assert ("bad context" == NULL); 19224 ctx = FFEEXPR_context; 19225 break; 19226 19227 default: 19228 ctx = FFEEXPR_contextINDEX_; 19229 break; 19230 } 19231 19232 if (!ffeexpr_is_substr_ok_) 19233 { 19234 if (ffebad_start (FFEBAD_BAD_SUBSTR)) 19235 { 19236 ffebad_here (0, ffelex_token_where_line (t), 19237 ffelex_token_where_column (t)); 19238 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token), 19239 ffelex_token_where_column (ffeexpr_stack_->exprstack->token)); 19240 ffebad_finish (); 19241 } 19242 19243 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx, 19244 ffeexpr_token_anything_); 19245 } 19246 19247 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx, 19248 ffeexpr_token_substring_); 19249} 19250 19251static ffelexHandler 19252ffeexpr_token_intrincheck_ (ffelexToken t) 19253{ 19254 if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) 19255 && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG)) 19256 { 19257 ffebad_string (ffeintrin_name_implementation 19258 (ffebld_symter_implementation 19259 (ffebld_left 19260 (ffeexpr_stack_->exprstack->u.operand)))); 19261 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token), 19262 ffelex_token_where_column (ffeexpr_stack_->exprstack->token)); 19263 ffebad_finish (); 19264 } 19265 19266 return (ffelexHandler) ffeexpr_token_substrp_ (t); 19267} 19268 19269/* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr 19270 19271 Return a pointer to this function to the lexer (ffelex), which will 19272 invoke it for the next token. 19273 19274 If COLON, do everything we would have done since _parenthesized_ if 19275 we had known NAME represented a kindENTITY instead of a kindFUNCTION. 19276 If not COLON, do likewise for kindFUNCTION instead. */ 19277 19278static ffelexHandler 19279ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t) 19280{ 19281 ffeinfoWhere where; 19282 ffesymbol s; 19283 ffesymbolAttrs sa; 19284 ffebld symter = ffeexpr_stack_->exprstack->u.operand; 19285 bool needs_type; 19286 ffeintrinGen gen; 19287 ffeintrinSpec spec; 19288 ffeintrinImp imp; 19289 19290 s = ffebld_symter (symter); 19291 sa = ffesymbol_attrs (s); 19292 where = ffesymbol_where (s); 19293 19294 /* We get here only if we don't already know enough about FOO when seeing a 19295 FOO(stuff) reference, and FOO might turn out to be a CHARACTER type. If 19296 "stuff" is a substring reference, then FOO is a CHARACTER scalar type. 19297 Else FOO is a function, either intrinsic or external. If intrinsic, it 19298 wouldn't necessarily be CHARACTER type, so unless it has already been 19299 declared DUMMY, it hasn't had its type established yet. It can't be 19300 CHAR*(*) in any case, though it can have an explicit CHAR*n type. */ 19301 19302 assert (!(sa & ~(FFESYMBOL_attrsDUMMY 19303 | FFESYMBOL_attrsTYPE))); 19304 19305 needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY); 19306 19307 ffesymbol_signal_change (s); /* Probably already done, but in case.... */ 19308 19309 if (ffelex_token_type (t) == FFELEX_typeCOLON) 19310 { /* Definitely an ENTITY (char substring). */ 19311 if (needs_type && !ffeimplic_establish_symbol (s)) 19312 { 19313 ffesymbol_error (s, ffeexpr_stack_->tokens[0]); 19314 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t); 19315 } 19316 19317 ffesymbol_set_info (s, 19318 ffeinfo_new (ffesymbol_basictype (s), 19319 ffesymbol_kindtype (s), 19320 ffesymbol_rank (s), 19321 FFEINFO_kindENTITY, 19322 (where == FFEINFO_whereNONE) 19323 ? FFEINFO_whereLOCAL 19324 : where, 19325 ffesymbol_size (s))); 19326 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s))); 19327 19328 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 19329 ffesymbol_resolve_intrin (s); 19330 s = ffecom_sym_learned (s); 19331 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 19332 19333 ffeexpr_stack_->exprstack->u.operand 19334 = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]); 19335 19336 return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t); 19337 } 19338 19339 /* The "stuff" isn't a substring notation, so we now know the overall 19340 reference is to a function. */ 19341 19342 if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0], 19343 FALSE, &gen, &spec, &imp)) 19344 { 19345 ffebld_symter_set_generic (symter, gen); 19346 ffebld_symter_set_specific (symter, spec); 19347 ffebld_symter_set_implementation (symter, imp); 19348 ffesymbol_set_generic (s, gen); 19349 ffesymbol_set_specific (s, spec); 19350 ffesymbol_set_implementation (s, imp); 19351 ffesymbol_set_info (s, 19352 ffeinfo_new (ffesymbol_basictype (s), 19353 ffesymbol_kindtype (s), 19354 0, 19355 FFEINFO_kindFUNCTION, 19356 FFEINFO_whereINTRINSIC, 19357 ffesymbol_size (s))); 19358 } 19359 else 19360 { /* Not intrinsic, now needs CHAR type. */ 19361 if (!ffeimplic_establish_symbol (s)) 19362 { 19363 ffesymbol_error (s, ffeexpr_stack_->tokens[0]); 19364 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t); 19365 } 19366 19367 ffesymbol_set_info (s, 19368 ffeinfo_new (ffesymbol_basictype (s), 19369 ffesymbol_kindtype (s), 19370 ffesymbol_rank (s), 19371 FFEINFO_kindFUNCTION, 19372 (where == FFEINFO_whereNONE) 19373 ? FFEINFO_whereGLOBAL 19374 : where, 19375 ffesymbol_size (s))); 19376 } 19377 19378 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s))); 19379 19380 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); 19381 ffesymbol_resolve_intrin (s); 19382 s = ffecom_sym_learned (s); 19383 ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE); 19384 ffesymbol_signal_unreported (s); /* For debugging purposes. */ 19385 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); 19386 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t); 19387} 19388 19389/* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr 19390 19391 Handle basically any expression, looking for CLOSE_PAREN. */ 19392 19393static ffelexHandler 19394ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED, 19395 ffelexToken t) 19396{ 19397 ffeexprExpr_ e = ffeexpr_stack_->exprstack; 19398 19399 switch (ffelex_token_type (t)) 19400 { 19401 case FFELEX_typeCOMMA: 19402 case FFELEX_typeCOLON: 19403 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, 19404 FFEEXPR_contextACTUALARG_, 19405 ffeexpr_token_anything_); 19406 19407 default: 19408 e->u.operand = ffebld_new_any (); 19409 ffebld_set_info (e->u.operand, ffeinfo_new_any ()); 19410 ffelex_token_kill (ffeexpr_stack_->tokens[0]); 19411 ffeexpr_is_substr_ok_ = FALSE; 19412 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) 19413 return (ffelexHandler) ffeexpr_token_substrp_; 19414 return (ffelexHandler) ffeexpr_token_substrp_ (t); 19415 } 19416} 19417 19418/* Terminate module. */ 19419 19420void 19421ffeexpr_terminate_2 () 19422{ 19423 assert (ffeexpr_stack_ == NULL); 19424 assert (ffeexpr_level_ == 0); 19425} 19426