home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / g77-0.5.15-src.tgz / tar.out / fsf / g77 / f / expr.c < prev    next >
C/C++ Source or Header  |  1996-09-28  |  555KB  |  19,013 lines
  1. /* expr.c -- Implementation File (module.c template V1.0)
  2.    Copyright (C) 1995 Free Software Foundation, Inc.
  3.    Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
  4.  
  5. This file is part of GNU Fortran.
  6.  
  7. GNU Fortran is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2, or (at your option)
  10. any later version.
  11.  
  12. GNU Fortran is distributed in the hope that it will be useful,
  13. but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15. GNU General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with GNU Fortran; see the file COPYING.  If not, write to
  19. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.    Related Modules:
  22.       None.
  23.  
  24.    Description:
  25.       Handles syntactic and semantic analysis of Fortran expressions.
  26.  
  27.    Modifications:
  28. */
  29.  
  30. /* Include files. */
  31.  
  32. #include "proj.h"
  33. #include <ctype.h>
  34. #include "expr.h"
  35. #include "bad.h"
  36. #include "bld.h"
  37. #include "com.h"
  38. #include "implic.h"
  39. #include "info.h"
  40. #include "lex.h"
  41. #include "malloc.h"
  42. #include "src.h"
  43. #include "st.h"
  44. #include "symbol.h"
  45. #include "target.h"
  46. #include "where.h"
  47.  
  48. /* Externals defined here. */
  49.  
  50.  
  51. /* Simple definitions and enumerations. */
  52.  
  53. typedef enum
  54.   {
  55.     FFEEXPR_dotdotNONE_,
  56.     FFEEXPR_dotdotTRUE_,
  57.     FFEEXPR_dotdotFALSE_,
  58.     FFEEXPR_dotdotNOT_,
  59.     FFEEXPR_dotdotAND_,
  60.     FFEEXPR_dotdotOR_,
  61.     FFEEXPR_dotdotXOR_,
  62.     FFEEXPR_dotdotEQV_,
  63.     FFEEXPR_dotdotNEQV_,
  64.     FFEEXPR_dotdotLT_,
  65.     FFEEXPR_dotdotLE_,
  66.     FFEEXPR_dotdotEQ_,
  67.     FFEEXPR_dotdotNE_,
  68.     FFEEXPR_dotdotGT_,
  69.     FFEEXPR_dotdotGE_,
  70.     FFEEXPR_dotdot
  71.   } ffeexprDotdot_;
  72.  
  73. typedef enum
  74.   {
  75.     FFEEXPR_exprtypeUNKNOWN_,
  76.     FFEEXPR_exprtypeOPERAND_,
  77.     FFEEXPR_exprtypeUNARY_,
  78.     FFEEXPR_exprtypeBINARY_,
  79.     FFEEXPR_exprtype_
  80.   } ffeexprExprtype_;
  81.  
  82. typedef enum
  83.   {
  84.     FFEEXPR_operatorPOWER_,
  85.     FFEEXPR_operatorMULTIPLY_,
  86.     FFEEXPR_operatorDIVIDE_,
  87.     FFEEXPR_operatorADD_,
  88.     FFEEXPR_operatorSUBTRACT_,
  89.     FFEEXPR_operatorCONCATENATE_,
  90.     FFEEXPR_operatorLT_,
  91.     FFEEXPR_operatorLE_,
  92.     FFEEXPR_operatorEQ_,
  93.     FFEEXPR_operatorNE_,
  94.     FFEEXPR_operatorGT_,
  95.     FFEEXPR_operatorGE_,
  96.     FFEEXPR_operatorNOT_,
  97.     FFEEXPR_operatorAND_,
  98.     FFEEXPR_operatorOR_,
  99.     FFEEXPR_operatorXOR_,
  100.     FFEEXPR_operatorEQV_,
  101.     FFEEXPR_operatorNEQV_,
  102.     FFEEXPR_operator_
  103.   } ffeexprOperator_;
  104.  
  105. typedef enum
  106.   {
  107.     FFEEXPR_operatorprecedenceHIGHEST_ = 1,
  108.     FFEEXPR_operatorprecedencePOWER_ = 1,
  109.     FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
  110.     FFEEXPR_operatorprecedenceDIVIDE_ = 2,
  111.     FFEEXPR_operatorprecedenceADD_ = 3,
  112.     FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
  113.     FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
  114.     FFEEXPR_operatorprecedenceLT_ = 4,
  115.     FFEEXPR_operatorprecedenceLE_ = 4,
  116.     FFEEXPR_operatorprecedenceEQ_ = 4,
  117.     FFEEXPR_operatorprecedenceNE_ = 4,
  118.     FFEEXPR_operatorprecedenceGT_ = 4,
  119.     FFEEXPR_operatorprecedenceGE_ = 4,
  120.     FFEEXPR_operatorprecedenceNOT_ = 5,
  121.     FFEEXPR_operatorprecedenceAND_ = 6,
  122.     FFEEXPR_operatorprecedenceOR_ = 7,
  123.     FFEEXPR_operatorprecedenceXOR_ = 8,
  124.     FFEEXPR_operatorprecedenceEQV_ = 8,
  125.     FFEEXPR_operatorprecedenceNEQV_ = 8,
  126.     FFEEXPR_operatorprecedenceLOWEST_ = 8,
  127.     FFEEXPR_operatorprecedence_
  128.   } ffeexprOperatorPrecedence_;
  129.  
  130. #define FFEEXPR_operatorassociativityL2R_ TRUE
  131. #define FFEEXPR_operatorassociativityR2L_ FALSE
  132. #define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
  133. #define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
  134. #define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
  135. #define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
  136. #define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
  137. #define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
  138. #define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
  139. #define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
  140. #define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
  141. #define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
  142. #define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
  143. #define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
  144. #define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
  145. #define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
  146. #define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
  147. #define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
  148. #define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
  149. #define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
  150.  
  151. typedef enum
  152.   {
  153.     FFEEXPR_parentypeFUNCTION_,
  154.     FFEEXPR_parentypeSUBROUTINE_,
  155.     FFEEXPR_parentypeARRAY_,
  156.     FFEEXPR_parentypeSUBSTRING_,
  157.     FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
  158.     FFEEXPR_parentypeEQUIVALENCE_,    /* Ambig: ARRAY_ or SUBSTRING_. */
  159.     FFEEXPR_parentypeANY_,    /* Allow basically anything. */
  160.     FFEEXPR_parentype_
  161.   } ffeexprParenType_;
  162.  
  163. typedef enum
  164.   {
  165.     FFEEXPR_percentNONE_,
  166.     FFEEXPR_percentLOC_,
  167.     FFEEXPR_percentVAL_,
  168.     FFEEXPR_percentREF_,
  169.     FFEEXPR_percentDESCR_,
  170.     FFEEXPR_percent_
  171.   } ffeexprPercent_;
  172.  
  173. /* Internal typedefs. */
  174.  
  175. typedef struct _ffeexpr_expr_ *ffeexprExpr_;
  176. typedef bool ffeexprOperatorAssociativity_;
  177. typedef struct _ffeexpr_stack_ *ffeexprStack_;
  178.  
  179. /* Private include files. */
  180.  
  181.  
  182. /* Internal structure definitions. */
  183.  
  184. struct _ffeexpr_expr_
  185.   {
  186.     ffeexprExpr_ previous;
  187.     ffelexToken token;
  188.     ffeexprExprtype_ type;
  189.     union
  190.       {
  191.     struct
  192.       {
  193.         ffeexprOperator_ op;
  194.         ffeexprOperatorPrecedence_ prec;
  195.         ffeexprOperatorAssociativity_ as;
  196.       }
  197.     operator;
  198.     ffebld operand;
  199.       }
  200.     u;
  201.   };
  202.  
  203. struct _ffeexpr_stack_
  204.   {
  205.     ffeexprStack_ previous;
  206.     mallocPool pool;
  207.     ffeexprContext context;
  208.     ffeexprCallback callback;
  209.     ffelexToken first_token;
  210.     ffeexprExpr_ exprstack;
  211.     ffelexToken tokens[10];    /* Used in certain cases, like (unary)
  212.                    open-paren. */
  213.     ffebld expr;        /* For first of
  214.                    complex/implied-do/substring/array-elements
  215.                    / actual-args expression. */
  216.     ffebld bound_list;        /* For tracking dimension bounds list of
  217.                    array. */
  218.     ffebldListBottom bottom;    /* For building lists. */
  219.     ffeinfoRank rank;        /* For elements in an array reference. */
  220.     bool constant;        /* TRUE while elements seen so far are
  221.                    constants. */
  222.     bool immediate;        /* TRUE while elements seen so far are
  223.                    immediate/constants. */
  224.     ffebld next_dummy;        /* Next SFUNC dummy arg in arg list. */
  225.     ffebldListLength num_args;    /* Number of dummy args expected in arg list. */
  226.     bool is_rhs;        /* TRUE if rhs context, FALSE otherwise. */
  227.     ffeexprPercent_ percent;    /* Current %FOO keyword. */
  228.   };
  229.  
  230. struct _ffeexpr_find_
  231.   {
  232.     ffelexToken t;
  233.     ffelexHandler after;
  234.     int level;
  235.   };
  236.  
  237. /* Static objects accessed by functions in this module. */
  238.  
  239. static ffeexprStack_ ffeexpr_stack_;    /* Expression stack for semantic. */
  240. static ffelexToken ffeexpr_tokens_[10];    /* Scratchpad tokens for syntactic. */
  241. static ffeexprDotdot_ ffeexpr_current_dotdot_;    /* Current .FOO. keyword. */
  242. static long ffeexpr_hollerith_count_;    /* ffeexpr_token_number_ and caller. */
  243. static int ffeexpr_level_;    /* Level of DATA implied-DO construct. */
  244. static bool ffeexpr_is_substr_ok_;    /* If OPEN_PAREN as binary "op" ok. */
  245. static struct _ffeexpr_find_ ffeexpr_find_;
  246.  
  247. /* Static functions (internal). */
  248.  
  249. static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
  250.                           ffelexToken t);
  251. static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
  252.                             ffebld expr,
  253.                             ffelexToken t);
  254. static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
  255. static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
  256.                         ffebld expr, ffelexToken t);
  257. static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
  258.                       ffelexToken t);
  259. static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
  260.                          ffebld expr, ffelexToken t);
  261. static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
  262.                        ffelexToken t);
  263. static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
  264.                       ffelexToken t);
  265. static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
  266.                         ffelexToken t);
  267. static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
  268.                         ffelexToken t);
  269. static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
  270.                         ffelexToken t);
  271. static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
  272.                         ffelexToken t);
  273. static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
  274. static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
  275.                       ffelexToken t);
  276. static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
  277.                          ffelexToken t);
  278. static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
  279. static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
  280. static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
  281.                   ffebld dovar, ffelexToken dovar_t);
  282. static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
  283. static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
  284. static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
  285. static ffeexprDotdot_ ffeexpr_dotdot_ (ffelexToken t);
  286. static ffeexprExpr_ ffeexpr_expr_new_ (void);
  287. static bool ffeexpr_isdigits_ (char *p);
  288. static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
  289. static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
  290. static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
  291. static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
  292. static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
  293. static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
  294. static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
  295. static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
  296. static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
  297. static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
  298. static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
  299. static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
  300. static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
  301. static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
  302. static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
  303. static void ffeexpr_reduce_ (void);
  304. static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
  305.                       ffeexprExpr_ r);
  306. static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
  307.                       ffeexprExpr_ op, ffeexprExpr_ r);
  308. static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
  309.                         ffeexprExpr_ op, ffeexprExpr_ r);
  310. static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
  311.                       ffeexprExpr_ op, ffeexprExpr_ r);
  312. static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
  313.                       ffeexprExpr_ r);
  314. static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
  315.                       ffeexprExpr_ op, ffeexprExpr_ r);
  316. static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
  317.                       ffeexprExpr_ op, ffeexprExpr_ r);
  318. static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
  319.                        ffeexprExpr_ op, ffeexprExpr_ r);
  320. static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
  321. static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
  322.                      ffeexprExpr_ r);
  323. static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
  324.                       ffeexprExpr_ op, ffeexprExpr_ r);
  325. static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
  326.                      ffeexprExpr_ op, ffeexprExpr_ r);
  327. static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
  328.                         ffelexHandler after);
  329. static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
  330. static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
  331. static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
  332. static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
  333. static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
  334. static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
  335. static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
  336. static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
  337. static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
  338. static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
  339. static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
  340. static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
  341. static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
  342. static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
  343. static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
  344. static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
  345. static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
  346. static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
  347. static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
  348. static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
  349. static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
  350. static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
  351. static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
  352. static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
  353. static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
  354. static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
  355. static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
  356. static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
  357. static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
  358. static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
  359. static ffelexHandler ffeexpr_finished_ (ffelexToken t);
  360. static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
  361. static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
  362. static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
  363. static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
  364. static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
  365. static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
  366. static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
  367. static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
  368. static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
  369. static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
  370. static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
  371. static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
  372. static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
  373. static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
  374. static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
  375. static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
  376. static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
  377. static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
  378. static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
  379. static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
  380. static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
  381. static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
  382. static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
  383. static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
  384. static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
  385. static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
  386. static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
  387. static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
  388. static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
  389. static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
  390. static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
  391. static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
  392. static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
  393.                            ffelexToken t);
  394. static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
  395.                           ffelexToken t);
  396. static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
  397.                          ffelexToken t);
  398. static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
  399.                            ffelexToken t);
  400. static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
  401.                          ffelexToken t);
  402. static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
  403. static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
  404.                            ffelexToken t);
  405. static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
  406.                           ffelexToken t);
  407. static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
  408.         ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
  409.             ffelexToken exponent_sign, ffelexToken exponent_digits);
  410. static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
  411. static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
  412. static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
  413. static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
  414. static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
  415. static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
  416. static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
  417. static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
  418. static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
  419. static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
  420. static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
  421. static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
  422.                          bool maybe_intrin,
  423.                          ffeexprParenType_ *paren_type);
  424. static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
  425. static void ffeexpr_type_combine_ (ffeinfoBasictype *nbt, ffeinfoKindtype *nkt,
  426.                    ffeinfoBasictype lbt, ffeinfoKindtype lkt,
  427.                    ffeinfoBasictype rbt, ffeinfoKindtype rkt,
  428.                    ffeexprExpr_ op);
  429.  
  430. /* Internal macros. */
  431.  
  432. #define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
  433. #define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
  434.  
  435. /* ffeexpr_collapse_convert -- Collapse convert expr
  436.  
  437.    ffebld expr;
  438.    ffelexToken token;
  439.    expr = ffeexpr_collapse_convert(expr,token);
  440.  
  441.    If the result of the expr is a constant, replaces the expr with the
  442.    computed constant.  */
  443.  
  444. ffebld
  445. ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
  446. {
  447.   ffebad error = FFEBAD;
  448.   ffebld l;
  449.   ffebldConstantUnion u;
  450.   ffeinfoBasictype bt;
  451.   ffeinfoKindtype kt;
  452.   ffetargetCharacterSize sz;
  453.   ffetargetCharacterSize sz2;
  454.  
  455.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  456.     return expr;
  457.  
  458.   l = ffebld_left (expr);
  459.  
  460.   if (ffebld_op (l) != FFEBLD_opCONTER)
  461.     return expr;
  462.  
  463.   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  464.     {
  465.     case FFEINFO_basictypeANY:
  466.       return expr;
  467.  
  468.     case FFEINFO_basictypeINTEGER:
  469.       sz = FFETARGET_charactersizeNONE;
  470.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  471.     {
  472. #if FFETARGET_okINTEGER1
  473.     case FFEINFO_kindtypeINTEGER1:
  474.       switch (ffeinfo_basictype (ffebld_info (l)))
  475.         {
  476.         case FFEINFO_basictypeINTEGER:
  477.           switch (ffeinfo_kindtype (ffebld_info (l)))
  478.         {
  479. #if FFETARGET_okINTEGER2
  480.         case FFEINFO_kindtypeINTEGER2:
  481.           error = ffetarget_convert_integer1_integer2
  482.             (ffebld_cu_ptr_integer1 (u),
  483.              ffebld_constant_integer2 (ffebld_conter (l)));
  484.           break;
  485. #endif
  486.  
  487. #if FFETARGET_okINTEGER3
  488.         case FFEINFO_kindtypeINTEGER3:
  489.           error = ffetarget_convert_integer1_integer3
  490.             (ffebld_cu_ptr_integer1 (u),
  491.              ffebld_constant_integer3 (ffebld_conter (l)));
  492.           break;
  493. #endif
  494.  
  495. #if FFETARGET_okINTEGER4
  496.         case FFEINFO_kindtypeINTEGER4:
  497.           error = ffetarget_convert_integer1_integer4
  498.             (ffebld_cu_ptr_integer1 (u),
  499.              ffebld_constant_integer4 (ffebld_conter (l)));
  500.           break;
  501. #endif
  502.  
  503.         default:
  504.           assert ("INTEGER1/INTEGER bad source kind type" == NULL);
  505.           break;
  506.         }
  507.           break;
  508.  
  509.         case FFEINFO_basictypeREAL:
  510.           switch (ffeinfo_kindtype (ffebld_info (l)))
  511.         {
  512. #if FFETARGET_okREAL1
  513.         case FFEINFO_kindtypeREAL1:
  514.           error = ffetarget_convert_integer1_real1
  515.             (ffebld_cu_ptr_integer1 (u),
  516.              ffebld_constant_real1 (ffebld_conter (l)));
  517.           break;
  518. #endif
  519.  
  520. #if FFETARGET_okREAL2
  521.         case FFEINFO_kindtypeREAL2:
  522.           error = ffetarget_convert_integer1_real2
  523.             (ffebld_cu_ptr_integer1 (u),
  524.              ffebld_constant_real2 (ffebld_conter (l)));
  525.           break;
  526. #endif
  527.  
  528. #if FFETARGET_okREAL3
  529.         case FFEINFO_kindtypeREAL3:
  530.           error = ffetarget_convert_integer1_real3
  531.             (ffebld_cu_ptr_integer1 (u),
  532.              ffebld_constant_real3 (ffebld_conter (l)));
  533.           break;
  534. #endif
  535.  
  536. #if FFETARGET_okREAL4
  537.         case FFEINFO_kindtypeREAL4:
  538.           error = ffetarget_convert_integer1_real4
  539.             (ffebld_cu_ptr_integer1 (u),
  540.              ffebld_constant_real4 (ffebld_conter (l)));
  541.           break;
  542. #endif
  543.  
  544.         default:
  545.           assert ("INTEGER1/REAL bad source kind type" == NULL);
  546.           break;
  547.         }
  548.           break;
  549.  
  550.         case FFEINFO_basictypeCOMPLEX:
  551.           switch (ffeinfo_kindtype (ffebld_info (l)))
  552.         {
  553. #if FFETARGET_okCOMPLEX1
  554.         case FFEINFO_kindtypeREAL1:
  555.           error = ffetarget_convert_integer1_complex1
  556.             (ffebld_cu_ptr_integer1 (u),
  557.              ffebld_constant_complex1 (ffebld_conter (l)));
  558.           break;
  559. #endif
  560.  
  561. #if FFETARGET_okCOMPLEX2
  562.         case FFEINFO_kindtypeREAL2:
  563.           error = ffetarget_convert_integer1_complex2
  564.             (ffebld_cu_ptr_integer1 (u),
  565.              ffebld_constant_complex2 (ffebld_conter (l)));
  566.           break;
  567. #endif
  568.  
  569. #if FFETARGET_okCOMPLEX3
  570.         case FFEINFO_kindtypeREAL3:
  571.           error = ffetarget_convert_integer1_complex3
  572.             (ffebld_cu_ptr_integer1 (u),
  573.              ffebld_constant_complex3 (ffebld_conter (l)));
  574.           break;
  575. #endif
  576.  
  577. #if FFETARGET_okCOMPLEX4
  578.         case FFEINFO_kindtypeREAL4:
  579.           error = ffetarget_convert_integer1_complex4
  580.             (ffebld_cu_ptr_integer1 (u),
  581.              ffebld_constant_complex4 (ffebld_conter (l)));
  582.           break;
  583. #endif
  584.  
  585.         default:
  586.           assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
  587.           break;
  588.         }
  589.           break;
  590.  
  591.         case FFEINFO_basictypeLOGICAL:
  592.           switch (ffeinfo_kindtype (ffebld_info (l)))
  593.         {
  594. #if FFETARGET_okLOGICAL1
  595.         case FFEINFO_kindtypeLOGICAL1:
  596.           error = ffetarget_convert_integer1_logical1
  597.             (ffebld_cu_ptr_integer1 (u),
  598.              ffebld_constant_logical1 (ffebld_conter (l)));
  599.           break;
  600. #endif
  601.  
  602. #if FFETARGET_okLOGICAL2
  603.         case FFEINFO_kindtypeLOGICAL2:
  604.           error = ffetarget_convert_integer1_logical2
  605.             (ffebld_cu_ptr_integer1 (u),
  606.              ffebld_constant_logical2 (ffebld_conter (l)));
  607.           break;
  608. #endif
  609.  
  610. #if FFETARGET_okLOGICAL3
  611.         case FFEINFO_kindtypeLOGICAL3:
  612.           error = ffetarget_convert_integer1_logical3
  613.             (ffebld_cu_ptr_integer1 (u),
  614.              ffebld_constant_logical3 (ffebld_conter (l)));
  615.           break;
  616. #endif
  617.  
  618. #if FFETARGET_okLOGICAL4
  619.         case FFEINFO_kindtypeLOGICAL4:
  620.           error = ffetarget_convert_integer1_logical4
  621.             (ffebld_cu_ptr_integer1 (u),
  622.              ffebld_constant_logical4 (ffebld_conter (l)));
  623.           break;
  624. #endif
  625.  
  626.         default:
  627.           assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
  628.           break;
  629.         }
  630.           break;
  631.  
  632.         case FFEINFO_basictypeCHARACTER:
  633.           error = ffetarget_convert_integer1_character1
  634.         (ffebld_cu_ptr_integer1 (u),
  635.          ffebld_constant_character1 (ffebld_conter (l)));
  636.           break;
  637.  
  638.         case FFEINFO_basictypeHOLLERITH:
  639.           error = ffetarget_convert_integer1_hollerith
  640.         (ffebld_cu_ptr_integer1 (u),
  641.          ffebld_constant_hollerith (ffebld_conter (l)));
  642.           break;
  643.  
  644.         case FFEINFO_basictypeTYPELESS:
  645.           error = ffetarget_convert_integer1_typeless
  646.         (ffebld_cu_ptr_integer1 (u),
  647.          ffebld_constant_typeless (ffebld_conter (l)));
  648.           break;
  649.  
  650.         default:
  651.           assert ("INTEGER1 bad type" == NULL);
  652.           break;
  653.         }
  654.  
  655.       expr = ffebld_new_conter_with_orig
  656.         (ffebld_constant_new_integer1_val
  657.          (ffebld_cu_val_integer1 (u)), expr);
  658.       break;
  659. #endif
  660.  
  661. #if FFETARGET_okINTEGER2
  662.     case FFEINFO_kindtypeINTEGER2:
  663.       switch (ffeinfo_basictype (ffebld_info (l)))
  664.         {
  665.         case FFEINFO_basictypeINTEGER:
  666.           switch (ffeinfo_kindtype (ffebld_info (l)))
  667.         {
  668. #if FFETARGET_okINTEGER1
  669.         case FFEINFO_kindtypeINTEGER1:
  670.           error = ffetarget_convert_integer2_integer1
  671.             (ffebld_cu_ptr_integer2 (u),
  672.              ffebld_constant_integer1 (ffebld_conter (l)));
  673.           break;
  674. #endif
  675.  
  676. #if FFETARGET_okINTEGER3
  677.         case FFEINFO_kindtypeINTEGER3:
  678.           error = ffetarget_convert_integer2_integer3
  679.             (ffebld_cu_ptr_integer2 (u),
  680.              ffebld_constant_integer3 (ffebld_conter (l)));
  681.           break;
  682. #endif
  683.  
  684. #if FFETARGET_okINTEGER4
  685.         case FFEINFO_kindtypeINTEGER4:
  686.           error = ffetarget_convert_integer2_integer4
  687.             (ffebld_cu_ptr_integer2 (u),
  688.              ffebld_constant_integer4 (ffebld_conter (l)));
  689.           break;
  690. #endif
  691.  
  692.         default:
  693.           assert ("INTEGER2/INTEGER bad source kind type" == NULL);
  694.           break;
  695.         }
  696.           break;
  697.  
  698.         case FFEINFO_basictypeREAL:
  699.           switch (ffeinfo_kindtype (ffebld_info (l)))
  700.         {
  701. #if FFETARGET_okREAL1
  702.         case FFEINFO_kindtypeREAL1:
  703.           error = ffetarget_convert_integer2_real1
  704.             (ffebld_cu_ptr_integer2 (u),
  705.              ffebld_constant_real1 (ffebld_conter (l)));
  706.           break;
  707. #endif
  708.  
  709. #if FFETARGET_okREAL2
  710.         case FFEINFO_kindtypeREAL2:
  711.           error = ffetarget_convert_integer2_real2
  712.             (ffebld_cu_ptr_integer2 (u),
  713.              ffebld_constant_real2 (ffebld_conter (l)));
  714.           break;
  715. #endif
  716.  
  717. #if FFETARGET_okREAL3
  718.         case FFEINFO_kindtypeREAL3:
  719.           error = ffetarget_convert_integer2_real3
  720.             (ffebld_cu_ptr_integer2 (u),
  721.              ffebld_constant_real3 (ffebld_conter (l)));
  722.           break;
  723. #endif
  724.  
  725. #if FFETARGET_okREAL4
  726.         case FFEINFO_kindtypeREAL4:
  727.           error = ffetarget_convert_integer2_real4
  728.             (ffebld_cu_ptr_integer2 (u),
  729.              ffebld_constant_real4 (ffebld_conter (l)));
  730.           break;
  731. #endif
  732.  
  733.         default:
  734.           assert ("INTEGER2/REAL bad source kind type" == NULL);
  735.           break;
  736.         }
  737.           break;
  738.  
  739.         case FFEINFO_basictypeCOMPLEX:
  740.           switch (ffeinfo_kindtype (ffebld_info (l)))
  741.         {
  742. #if FFETARGET_okCOMPLEX1
  743.         case FFEINFO_kindtypeREAL1:
  744.           error = ffetarget_convert_integer2_complex1
  745.             (ffebld_cu_ptr_integer2 (u),
  746.              ffebld_constant_complex1 (ffebld_conter (l)));
  747.           break;
  748. #endif
  749.  
  750. #if FFETARGET_okCOMPLEX2
  751.         case FFEINFO_kindtypeREAL2:
  752.           error = ffetarget_convert_integer2_complex2
  753.             (ffebld_cu_ptr_integer2 (u),
  754.              ffebld_constant_complex2 (ffebld_conter (l)));
  755.           break;
  756. #endif
  757.  
  758. #if FFETARGET_okCOMPLEX3
  759.         case FFEINFO_kindtypeREAL3:
  760.           error = ffetarget_convert_integer2_complex3
  761.             (ffebld_cu_ptr_integer2 (u),
  762.              ffebld_constant_complex3 (ffebld_conter (l)));
  763.           break;
  764. #endif
  765.  
  766. #if FFETARGET_okCOMPLEX4
  767.         case FFEINFO_kindtypeREAL4:
  768.           error = ffetarget_convert_integer2_complex4
  769.             (ffebld_cu_ptr_integer2 (u),
  770.              ffebld_constant_complex4 (ffebld_conter (l)));
  771.           break;
  772. #endif
  773.  
  774.         default:
  775.           assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
  776.           break;
  777.         }
  778.           break;
  779.  
  780.         case FFEINFO_basictypeLOGICAL:
  781.           switch (ffeinfo_kindtype (ffebld_info (l)))
  782.         {
  783. #if FFETARGET_okLOGICAL1
  784.         case FFEINFO_kindtypeLOGICAL1:
  785.           error = ffetarget_convert_integer2_logical1
  786.             (ffebld_cu_ptr_integer2 (u),
  787.              ffebld_constant_logical1 (ffebld_conter (l)));
  788.           break;
  789. #endif
  790.  
  791. #if FFETARGET_okLOGICAL2
  792.         case FFEINFO_kindtypeLOGICAL2:
  793.           error = ffetarget_convert_integer2_logical2
  794.             (ffebld_cu_ptr_integer2 (u),
  795.              ffebld_constant_logical2 (ffebld_conter (l)));
  796.           break;
  797. #endif
  798.  
  799. #if FFETARGET_okLOGICAL3
  800.         case FFEINFO_kindtypeLOGICAL3:
  801.           error = ffetarget_convert_integer2_logical3
  802.             (ffebld_cu_ptr_integer2 (u),
  803.              ffebld_constant_logical3 (ffebld_conter (l)));
  804.           break;
  805. #endif
  806.  
  807. #if FFETARGET_okLOGICAL4
  808.         case FFEINFO_kindtypeLOGICAL4:
  809.           error = ffetarget_convert_integer2_logical4
  810.             (ffebld_cu_ptr_integer2 (u),
  811.              ffebld_constant_logical4 (ffebld_conter (l)));
  812.           break;
  813. #endif
  814.  
  815.         default:
  816.           assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
  817.           break;
  818.         }
  819.           break;
  820.  
  821.         case FFEINFO_basictypeCHARACTER:
  822.           error = ffetarget_convert_integer2_character1
  823.         (ffebld_cu_ptr_integer2 (u),
  824.          ffebld_constant_character1 (ffebld_conter (l)));
  825.           break;
  826.  
  827.         case FFEINFO_basictypeHOLLERITH:
  828.           error = ffetarget_convert_integer2_hollerith
  829.         (ffebld_cu_ptr_integer2 (u),
  830.          ffebld_constant_hollerith (ffebld_conter (l)));
  831.           break;
  832.  
  833.         case FFEINFO_basictypeTYPELESS:
  834.           error = ffetarget_convert_integer2_typeless
  835.         (ffebld_cu_ptr_integer2 (u),
  836.          ffebld_constant_typeless (ffebld_conter (l)));
  837.           break;
  838.  
  839.         default:
  840.           assert ("INTEGER2 bad type" == NULL);
  841.           break;
  842.         }
  843.  
  844.       expr = ffebld_new_conter_with_orig
  845.         (ffebld_constant_new_integer2_val
  846.          (ffebld_cu_val_integer2 (u)), expr);
  847.       break;
  848. #endif
  849.  
  850. #if FFETARGET_okINTEGER3
  851.     case FFEINFO_kindtypeINTEGER3:
  852.       switch (ffeinfo_basictype (ffebld_info (l)))
  853.         {
  854.         case FFEINFO_basictypeINTEGER:
  855.           switch (ffeinfo_kindtype (ffebld_info (l)))
  856.         {
  857. #if FFETARGET_okINTEGER1
  858.         case FFEINFO_kindtypeINTEGER1:
  859.           error = ffetarget_convert_integer3_integer1
  860.             (ffebld_cu_ptr_integer3 (u),
  861.              ffebld_constant_integer1 (ffebld_conter (l)));
  862.           break;
  863. #endif
  864.  
  865. #if FFETARGET_okINTEGER2
  866.         case FFEINFO_kindtypeINTEGER2:
  867.           error = ffetarget_convert_integer3_integer2
  868.             (ffebld_cu_ptr_integer3 (u),
  869.              ffebld_constant_integer2 (ffebld_conter (l)));
  870.           break;
  871. #endif
  872.  
  873. #if FFETARGET_okINTEGER4
  874.         case FFEINFO_kindtypeINTEGER4:
  875.           error = ffetarget_convert_integer3_integer4
  876.             (ffebld_cu_ptr_integer3 (u),
  877.              ffebld_constant_integer4 (ffebld_conter (l)));
  878.           break;
  879. #endif
  880.  
  881.         default:
  882.           assert ("INTEGER3/INTEGER bad source kind type" == NULL);
  883.           break;
  884.         }
  885.           break;
  886.  
  887.         case FFEINFO_basictypeREAL:
  888.           switch (ffeinfo_kindtype (ffebld_info (l)))
  889.         {
  890. #if FFETARGET_okREAL1
  891.         case FFEINFO_kindtypeREAL1:
  892.           error = ffetarget_convert_integer3_real1
  893.             (ffebld_cu_ptr_integer3 (u),
  894.              ffebld_constant_real1 (ffebld_conter (l)));
  895.           break;
  896. #endif
  897.  
  898. #if FFETARGET_okREAL2
  899.         case FFEINFO_kindtypeREAL2:
  900.           error = ffetarget_convert_integer3_real2
  901.             (ffebld_cu_ptr_integer3 (u),
  902.              ffebld_constant_real2 (ffebld_conter (l)));
  903.           break;
  904. #endif
  905.  
  906. #if FFETARGET_okREAL3
  907.         case FFEINFO_kindtypeREAL3:
  908.           error = ffetarget_convert_integer3_real3
  909.             (ffebld_cu_ptr_integer3 (u),
  910.              ffebld_constant_real3 (ffebld_conter (l)));
  911.           break;
  912. #endif
  913.  
  914. #if FFETARGET_okREAL4
  915.         case FFEINFO_kindtypeREAL4:
  916.           error = ffetarget_convert_integer3_real4
  917.             (ffebld_cu_ptr_integer3 (u),
  918.              ffebld_constant_real4 (ffebld_conter (l)));
  919.           break;
  920. #endif
  921.  
  922.         default:
  923.           assert ("INTEGER3/REAL bad source kind type" == NULL);
  924.           break;
  925.         }
  926.           break;
  927.  
  928.         case FFEINFO_basictypeCOMPLEX:
  929.           switch (ffeinfo_kindtype (ffebld_info (l)))
  930.         {
  931. #if FFETARGET_okCOMPLEX1
  932.         case FFEINFO_kindtypeREAL1:
  933.           error = ffetarget_convert_integer3_complex1
  934.             (ffebld_cu_ptr_integer3 (u),
  935.              ffebld_constant_complex1 (ffebld_conter (l)));
  936.           break;
  937. #endif
  938.  
  939. #if FFETARGET_okCOMPLEX2
  940.         case FFEINFO_kindtypeREAL2:
  941.           error = ffetarget_convert_integer3_complex2
  942.             (ffebld_cu_ptr_integer3 (u),
  943.              ffebld_constant_complex2 (ffebld_conter (l)));
  944.           break;
  945. #endif
  946.  
  947. #if FFETARGET_okCOMPLEX3
  948.         case FFEINFO_kindtypeREAL3:
  949.           error = ffetarget_convert_integer3_complex3
  950.             (ffebld_cu_ptr_integer3 (u),
  951.              ffebld_constant_complex3 (ffebld_conter (l)));
  952.           break;
  953. #endif
  954.  
  955. #if FFETARGET_okCOMPLEX4
  956.         case FFEINFO_kindtypeREAL4:
  957.           error = ffetarget_convert_integer3_complex4
  958.             (ffebld_cu_ptr_integer3 (u),
  959.              ffebld_constant_complex4 (ffebld_conter (l)));
  960.           break;
  961. #endif
  962.  
  963.         default:
  964.           assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
  965.           break;
  966.         }
  967.           break;
  968.  
  969.         case FFEINFO_basictypeLOGICAL:
  970.           switch (ffeinfo_kindtype (ffebld_info (l)))
  971.         {
  972. #if FFETARGET_okLOGICAL1
  973.         case FFEINFO_kindtypeLOGICAL1:
  974.           error = ffetarget_convert_integer3_logical1
  975.             (ffebld_cu_ptr_integer3 (u),
  976.              ffebld_constant_logical1 (ffebld_conter (l)));
  977.           break;
  978. #endif
  979.  
  980. #if FFETARGET_okLOGICAL2
  981.         case FFEINFO_kindtypeLOGICAL2:
  982.           error = ffetarget_convert_integer3_logical2
  983.             (ffebld_cu_ptr_integer3 (u),
  984.              ffebld_constant_logical2 (ffebld_conter (l)));
  985.           break;
  986. #endif
  987.  
  988. #if FFETARGET_okLOGICAL3
  989.         case FFEINFO_kindtypeLOGICAL3:
  990.           error = ffetarget_convert_integer3_logical3
  991.             (ffebld_cu_ptr_integer3 (u),
  992.              ffebld_constant_logical3 (ffebld_conter (l)));
  993.           break;
  994. #endif
  995.  
  996. #if FFETARGET_okLOGICAL4
  997.         case FFEINFO_kindtypeLOGICAL4:
  998.           error = ffetarget_convert_integer3_logical4
  999.             (ffebld_cu_ptr_integer3 (u),
  1000.              ffebld_constant_logical4 (ffebld_conter (l)));
  1001.           break;
  1002. #endif
  1003.  
  1004.         default:
  1005.           assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
  1006.           break;
  1007.         }
  1008.           break;
  1009.  
  1010.         case FFEINFO_basictypeCHARACTER:
  1011.           error = ffetarget_convert_integer3_character1
  1012.         (ffebld_cu_ptr_integer3 (u),
  1013.          ffebld_constant_character1 (ffebld_conter (l)));
  1014.           break;
  1015.  
  1016.         case FFEINFO_basictypeHOLLERITH:
  1017.           error = ffetarget_convert_integer3_hollerith
  1018.         (ffebld_cu_ptr_integer3 (u),
  1019.          ffebld_constant_hollerith (ffebld_conter (l)));
  1020.           break;
  1021.  
  1022.         case FFEINFO_basictypeTYPELESS:
  1023.           error = ffetarget_convert_integer3_typeless
  1024.         (ffebld_cu_ptr_integer3 (u),
  1025.          ffebld_constant_typeless (ffebld_conter (l)));
  1026.           break;
  1027.  
  1028.         default:
  1029.           assert ("INTEGER3 bad type" == NULL);
  1030.           break;
  1031.         }
  1032.  
  1033.       expr = ffebld_new_conter_with_orig
  1034.         (ffebld_constant_new_integer3_val
  1035.          (ffebld_cu_val_integer3 (u)), expr);
  1036.       break;
  1037. #endif
  1038.  
  1039. #if FFETARGET_okINTEGER4
  1040.     case FFEINFO_kindtypeINTEGER4:
  1041.       switch (ffeinfo_basictype (ffebld_info (l)))
  1042.         {
  1043.         case FFEINFO_basictypeINTEGER:
  1044.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1045.         {
  1046. #if FFETARGET_okINTEGER1
  1047.         case FFEINFO_kindtypeINTEGER1:
  1048.           error = ffetarget_convert_integer4_integer1
  1049.             (ffebld_cu_ptr_integer4 (u),
  1050.              ffebld_constant_integer1 (ffebld_conter (l)));
  1051.           break;
  1052. #endif
  1053.  
  1054. #if FFETARGET_okINTEGER2
  1055.         case FFEINFO_kindtypeINTEGER2:
  1056.           error = ffetarget_convert_integer4_integer2
  1057.             (ffebld_cu_ptr_integer4 (u),
  1058.              ffebld_constant_integer2 (ffebld_conter (l)));
  1059.           break;
  1060. #endif
  1061.  
  1062. #if FFETARGET_okINTEGER3
  1063.         case FFEINFO_kindtypeINTEGER3:
  1064.           error = ffetarget_convert_integer4_integer3
  1065.             (ffebld_cu_ptr_integer4 (u),
  1066.              ffebld_constant_integer3 (ffebld_conter (l)));
  1067.           break;
  1068. #endif
  1069.  
  1070.         default:
  1071.           assert ("INTEGER4/INTEGER bad source kind type" == NULL);
  1072.           break;
  1073.         }
  1074.           break;
  1075.  
  1076.         case FFEINFO_basictypeREAL:
  1077.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1078.         {
  1079. #if FFETARGET_okREAL1
  1080.         case FFEINFO_kindtypeREAL1:
  1081.           error = ffetarget_convert_integer4_real1
  1082.             (ffebld_cu_ptr_integer4 (u),
  1083.              ffebld_constant_real1 (ffebld_conter (l)));
  1084.           break;
  1085. #endif
  1086.  
  1087. #if FFETARGET_okREAL2
  1088.         case FFEINFO_kindtypeREAL2:
  1089.           error = ffetarget_convert_integer4_real2
  1090.             (ffebld_cu_ptr_integer4 (u),
  1091.              ffebld_constant_real2 (ffebld_conter (l)));
  1092.           break;
  1093. #endif
  1094.  
  1095. #if FFETARGET_okREAL3
  1096.         case FFEINFO_kindtypeREAL3:
  1097.           error = ffetarget_convert_integer4_real3
  1098.             (ffebld_cu_ptr_integer4 (u),
  1099.              ffebld_constant_real3 (ffebld_conter (l)));
  1100.           break;
  1101. #endif
  1102.  
  1103. #if FFETARGET_okREAL4
  1104.         case FFEINFO_kindtypeREAL4:
  1105.           error = ffetarget_convert_integer4_real4
  1106.             (ffebld_cu_ptr_integer4 (u),
  1107.              ffebld_constant_real4 (ffebld_conter (l)));
  1108.           break;
  1109. #endif
  1110.  
  1111.         default:
  1112.           assert ("INTEGER4/REAL bad source kind type" == NULL);
  1113.           break;
  1114.         }
  1115.           break;
  1116.  
  1117.         case FFEINFO_basictypeCOMPLEX:
  1118.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1119.         {
  1120. #if FFETARGET_okCOMPLEX1
  1121.         case FFEINFO_kindtypeREAL1:
  1122.           error = ffetarget_convert_integer4_complex1
  1123.             (ffebld_cu_ptr_integer4 (u),
  1124.              ffebld_constant_complex1 (ffebld_conter (l)));
  1125.           break;
  1126. #endif
  1127.  
  1128. #if FFETARGET_okCOMPLEX2
  1129.         case FFEINFO_kindtypeREAL2:
  1130.           error = ffetarget_convert_integer4_complex2
  1131.             (ffebld_cu_ptr_integer4 (u),
  1132.              ffebld_constant_complex2 (ffebld_conter (l)));
  1133.           break;
  1134. #endif
  1135.  
  1136. #if FFETARGET_okCOMPLEX3
  1137.         case FFEINFO_kindtypeREAL3:
  1138.           error = ffetarget_convert_integer4_complex3
  1139.             (ffebld_cu_ptr_integer4 (u),
  1140.              ffebld_constant_complex3 (ffebld_conter (l)));
  1141.           break;
  1142. #endif
  1143.  
  1144. #if FFETARGET_okCOMPLEX4
  1145.         case FFEINFO_kindtypeREAL4:
  1146.           error = ffetarget_convert_integer4_complex4
  1147.             (ffebld_cu_ptr_integer4 (u),
  1148.              ffebld_constant_complex4 (ffebld_conter (l)));
  1149.           break;
  1150. #endif
  1151.  
  1152.         default:
  1153.           assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
  1154.           break;
  1155.         }
  1156.           break;
  1157.  
  1158.         case FFEINFO_basictypeLOGICAL:
  1159.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1160.         {
  1161. #if FFETARGET_okLOGICAL1
  1162.         case FFEINFO_kindtypeLOGICAL1:
  1163.           error = ffetarget_convert_integer4_logical1
  1164.             (ffebld_cu_ptr_integer4 (u),
  1165.              ffebld_constant_logical1 (ffebld_conter (l)));
  1166.           break;
  1167. #endif
  1168.  
  1169. #if FFETARGET_okLOGICAL2
  1170.         case FFEINFO_kindtypeLOGICAL2:
  1171.           error = ffetarget_convert_integer4_logical2
  1172.             (ffebld_cu_ptr_integer4 (u),
  1173.              ffebld_constant_logical2 (ffebld_conter (l)));
  1174.           break;
  1175. #endif
  1176.  
  1177. #if FFETARGET_okLOGICAL3
  1178.         case FFEINFO_kindtypeLOGICAL3:
  1179.           error = ffetarget_convert_integer4_logical3
  1180.             (ffebld_cu_ptr_integer4 (u),
  1181.              ffebld_constant_logical3 (ffebld_conter (l)));
  1182.           break;
  1183. #endif
  1184.  
  1185. #if FFETARGET_okLOGICAL4
  1186.         case FFEINFO_kindtypeLOGICAL4:
  1187.           error = ffetarget_convert_integer4_logical4
  1188.             (ffebld_cu_ptr_integer4 (u),
  1189.              ffebld_constant_logical4 (ffebld_conter (l)));
  1190.           break;
  1191. #endif
  1192.  
  1193.         default:
  1194.           assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
  1195.           break;
  1196.         }
  1197.           break;
  1198.  
  1199.         case FFEINFO_basictypeCHARACTER:
  1200.           error = ffetarget_convert_integer4_character1
  1201.         (ffebld_cu_ptr_integer4 (u),
  1202.          ffebld_constant_character1 (ffebld_conter (l)));
  1203.           break;
  1204.  
  1205.         case FFEINFO_basictypeHOLLERITH:
  1206.           error = ffetarget_convert_integer4_hollerith
  1207.         (ffebld_cu_ptr_integer4 (u),
  1208.          ffebld_constant_hollerith (ffebld_conter (l)));
  1209.           break;
  1210.  
  1211.         case FFEINFO_basictypeTYPELESS:
  1212.           error = ffetarget_convert_integer4_typeless
  1213.         (ffebld_cu_ptr_integer4 (u),
  1214.          ffebld_constant_typeless (ffebld_conter (l)));
  1215.           break;
  1216.  
  1217.         default:
  1218.           assert ("INTEGER4 bad type" == NULL);
  1219.           break;
  1220.         }
  1221.  
  1222.       expr = ffebld_new_conter_with_orig
  1223.         (ffebld_constant_new_integer4_val
  1224.          (ffebld_cu_val_integer4 (u)), expr);
  1225.       break;
  1226. #endif
  1227.  
  1228.     default:
  1229.       assert ("bad integer kind type" == NULL);
  1230.       break;
  1231.     }
  1232.       break;
  1233.  
  1234.     case FFEINFO_basictypeLOGICAL:
  1235.       sz = FFETARGET_charactersizeNONE;
  1236.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  1237.     {
  1238. #if FFETARGET_okLOGICAL1
  1239.     case FFEINFO_kindtypeLOGICAL1:
  1240.       switch (ffeinfo_basictype (ffebld_info (l)))
  1241.         {
  1242.         case FFEINFO_basictypeLOGICAL:
  1243.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1244.         {
  1245. #if FFETARGET_okLOGICAL2
  1246.         case FFEINFO_kindtypeLOGICAL2:
  1247.           error = ffetarget_convert_logical1_logical2
  1248.             (ffebld_cu_ptr_logical1 (u),
  1249.              ffebld_constant_logical2 (ffebld_conter (l)));
  1250.           break;
  1251. #endif
  1252.  
  1253. #if FFETARGET_okLOGICAL3
  1254.         case FFEINFO_kindtypeLOGICAL3:
  1255.           error = ffetarget_convert_logical1_logical3
  1256.             (ffebld_cu_ptr_logical1 (u),
  1257.              ffebld_constant_logical3 (ffebld_conter (l)));
  1258.           break;
  1259. #endif
  1260.  
  1261. #if FFETARGET_okLOGICAL4
  1262.         case FFEINFO_kindtypeLOGICAL4:
  1263.           error = ffetarget_convert_logical1_logical4
  1264.             (ffebld_cu_ptr_logical1 (u),
  1265.              ffebld_constant_logical4 (ffebld_conter (l)));
  1266.           break;
  1267. #endif
  1268.  
  1269.         default:
  1270.           assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
  1271.           break;
  1272.         }
  1273.           break;
  1274.  
  1275.         case FFEINFO_basictypeINTEGER:
  1276.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1277.         {
  1278. #if FFETARGET_okINTEGER1
  1279.         case FFEINFO_kindtypeINTEGER1:
  1280.           error = ffetarget_convert_logical1_integer1
  1281.             (ffebld_cu_ptr_logical1 (u),
  1282.              ffebld_constant_integer1 (ffebld_conter (l)));
  1283.           break;
  1284. #endif
  1285.  
  1286. #if FFETARGET_okINTEGER2
  1287.         case FFEINFO_kindtypeINTEGER2:
  1288.           error = ffetarget_convert_logical1_integer2
  1289.             (ffebld_cu_ptr_logical1 (u),
  1290.              ffebld_constant_integer2 (ffebld_conter (l)));
  1291.           break;
  1292. #endif
  1293.  
  1294. #if FFETARGET_okINTEGER3
  1295.         case FFEINFO_kindtypeINTEGER3:
  1296.           error = ffetarget_convert_logical1_integer3
  1297.             (ffebld_cu_ptr_logical1 (u),
  1298.              ffebld_constant_integer3 (ffebld_conter (l)));
  1299.           break;
  1300. #endif
  1301.  
  1302. #if FFETARGET_okINTEGER4
  1303.         case FFEINFO_kindtypeINTEGER4:
  1304.           error = ffetarget_convert_logical1_integer4
  1305.             (ffebld_cu_ptr_logical1 (u),
  1306.              ffebld_constant_integer4 (ffebld_conter (l)));
  1307.           break;
  1308. #endif
  1309.  
  1310.         default:
  1311.           assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
  1312.           break;
  1313.         }
  1314.           break;
  1315.  
  1316.         case FFEINFO_basictypeCHARACTER:
  1317.           error = ffetarget_convert_logical1_character1
  1318.         (ffebld_cu_ptr_logical1 (u),
  1319.          ffebld_constant_character1 (ffebld_conter (l)));
  1320.           break;
  1321.  
  1322.         case FFEINFO_basictypeHOLLERITH:
  1323.           error = ffetarget_convert_logical1_hollerith
  1324.         (ffebld_cu_ptr_logical1 (u),
  1325.          ffebld_constant_hollerith (ffebld_conter (l)));
  1326.           break;
  1327.  
  1328.         case FFEINFO_basictypeTYPELESS:
  1329.           error = ffetarget_convert_logical1_typeless
  1330.         (ffebld_cu_ptr_logical1 (u),
  1331.          ffebld_constant_typeless (ffebld_conter (l)));
  1332.           break;
  1333.  
  1334.         default:
  1335.           assert ("LOGICAL1 bad type" == NULL);
  1336.           break;
  1337.         }
  1338.  
  1339.       expr = ffebld_new_conter_with_orig
  1340.         (ffebld_constant_new_logical1_val
  1341.          (ffebld_cu_val_logical1 (u)), expr);
  1342.       break;
  1343. #endif
  1344.  
  1345. #if FFETARGET_okLOGICAL2
  1346.     case FFEINFO_kindtypeLOGICAL2:
  1347.       switch (ffeinfo_basictype (ffebld_info (l)))
  1348.         {
  1349.         case FFEINFO_basictypeLOGICAL:
  1350.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1351.         {
  1352. #if FFETARGET_okLOGICAL1
  1353.         case FFEINFO_kindtypeLOGICAL1:
  1354.           error = ffetarget_convert_logical2_logical1
  1355.             (ffebld_cu_ptr_logical2 (u),
  1356.              ffebld_constant_logical1 (ffebld_conter (l)));
  1357.           break;
  1358. #endif
  1359.  
  1360. #if FFETARGET_okLOGICAL3
  1361.         case FFEINFO_kindtypeLOGICAL3:
  1362.           error = ffetarget_convert_logical2_logical3
  1363.             (ffebld_cu_ptr_logical2 (u),
  1364.              ffebld_constant_logical3 (ffebld_conter (l)));
  1365.           break;
  1366. #endif
  1367.  
  1368. #if FFETARGET_okLOGICAL4
  1369.         case FFEINFO_kindtypeLOGICAL4:
  1370.           error = ffetarget_convert_logical2_logical4
  1371.             (ffebld_cu_ptr_logical2 (u),
  1372.              ffebld_constant_logical4 (ffebld_conter (l)));
  1373.           break;
  1374. #endif
  1375.  
  1376.         default:
  1377.           assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
  1378.           break;
  1379.         }
  1380.           break;
  1381.  
  1382.         case FFEINFO_basictypeINTEGER:
  1383.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1384.         {
  1385. #if FFETARGET_okINTEGER1
  1386.         case FFEINFO_kindtypeINTEGER1:
  1387.           error = ffetarget_convert_logical2_integer1
  1388.             (ffebld_cu_ptr_logical2 (u),
  1389.              ffebld_constant_integer1 (ffebld_conter (l)));
  1390.           break;
  1391. #endif
  1392.  
  1393. #if FFETARGET_okINTEGER2
  1394.         case FFEINFO_kindtypeINTEGER2:
  1395.           error = ffetarget_convert_logical2_integer2
  1396.             (ffebld_cu_ptr_logical2 (u),
  1397.              ffebld_constant_integer2 (ffebld_conter (l)));
  1398.           break;
  1399. #endif
  1400.  
  1401. #if FFETARGET_okINTEGER3
  1402.         case FFEINFO_kindtypeINTEGER3:
  1403.           error = ffetarget_convert_logical2_integer3
  1404.             (ffebld_cu_ptr_logical2 (u),
  1405.              ffebld_constant_integer3 (ffebld_conter (l)));
  1406.           break;
  1407. #endif
  1408.  
  1409. #if FFETARGET_okINTEGER4
  1410.         case FFEINFO_kindtypeINTEGER4:
  1411.           error = ffetarget_convert_logical2_integer4
  1412.             (ffebld_cu_ptr_logical2 (u),
  1413.              ffebld_constant_integer4 (ffebld_conter (l)));
  1414.           break;
  1415. #endif
  1416.  
  1417.         default:
  1418.           assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
  1419.           break;
  1420.         }
  1421.           break;
  1422.  
  1423.         case FFEINFO_basictypeCHARACTER:
  1424.           error = ffetarget_convert_logical2_character1
  1425.         (ffebld_cu_ptr_logical2 (u),
  1426.          ffebld_constant_character1 (ffebld_conter (l)));
  1427.           break;
  1428.  
  1429.         case FFEINFO_basictypeHOLLERITH:
  1430.           error = ffetarget_convert_logical2_hollerith
  1431.         (ffebld_cu_ptr_logical2 (u),
  1432.          ffebld_constant_hollerith (ffebld_conter (l)));
  1433.           break;
  1434.  
  1435.         case FFEINFO_basictypeTYPELESS:
  1436.           error = ffetarget_convert_logical2_typeless
  1437.         (ffebld_cu_ptr_logical2 (u),
  1438.          ffebld_constant_typeless (ffebld_conter (l)));
  1439.           break;
  1440.  
  1441.         default:
  1442.           assert ("LOGICAL2 bad type" == NULL);
  1443.           break;
  1444.         }
  1445.  
  1446.       expr = ffebld_new_conter_with_orig
  1447.         (ffebld_constant_new_logical2_val
  1448.          (ffebld_cu_val_logical2 (u)), expr);
  1449.       break;
  1450. #endif
  1451.  
  1452. #if FFETARGET_okLOGICAL3
  1453.     case FFEINFO_kindtypeLOGICAL3:
  1454.       switch (ffeinfo_basictype (ffebld_info (l)))
  1455.         {
  1456.         case FFEINFO_basictypeLOGICAL:
  1457.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1458.         {
  1459. #if FFETARGET_okLOGICAL1
  1460.         case FFEINFO_kindtypeLOGICAL1:
  1461.           error = ffetarget_convert_logical3_logical1
  1462.             (ffebld_cu_ptr_logical3 (u),
  1463.              ffebld_constant_logical1 (ffebld_conter (l)));
  1464.           break;
  1465. #endif
  1466.  
  1467. #if FFETARGET_okLOGICAL2
  1468.         case FFEINFO_kindtypeLOGICAL2:
  1469.           error = ffetarget_convert_logical3_logical2
  1470.             (ffebld_cu_ptr_logical3 (u),
  1471.              ffebld_constant_logical2 (ffebld_conter (l)));
  1472.           break;
  1473. #endif
  1474.  
  1475. #if FFETARGET_okLOGICAL4
  1476.         case FFEINFO_kindtypeLOGICAL4:
  1477.           error = ffetarget_convert_logical3_logical4
  1478.             (ffebld_cu_ptr_logical3 (u),
  1479.              ffebld_constant_logical4 (ffebld_conter (l)));
  1480.           break;
  1481. #endif
  1482.  
  1483.         default:
  1484.           assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
  1485.           break;
  1486.         }
  1487.           break;
  1488.  
  1489.         case FFEINFO_basictypeINTEGER:
  1490.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1491.         {
  1492. #if FFETARGET_okINTEGER1
  1493.         case FFEINFO_kindtypeINTEGER1:
  1494.           error = ffetarget_convert_logical3_integer1
  1495.             (ffebld_cu_ptr_logical3 (u),
  1496.              ffebld_constant_integer1 (ffebld_conter (l)));
  1497.           break;
  1498. #endif
  1499.  
  1500. #if FFETARGET_okINTEGER2
  1501.         case FFEINFO_kindtypeINTEGER2:
  1502.           error = ffetarget_convert_logical3_integer2
  1503.             (ffebld_cu_ptr_logical3 (u),
  1504.              ffebld_constant_integer2 (ffebld_conter (l)));
  1505.           break;
  1506. #endif
  1507.  
  1508. #if FFETARGET_okINTEGER3
  1509.         case FFEINFO_kindtypeINTEGER3:
  1510.           error = ffetarget_convert_logical3_integer3
  1511.             (ffebld_cu_ptr_logical3 (u),
  1512.              ffebld_constant_integer3 (ffebld_conter (l)));
  1513.           break;
  1514. #endif
  1515.  
  1516. #if FFETARGET_okINTEGER4
  1517.         case FFEINFO_kindtypeINTEGER4:
  1518.           error = ffetarget_convert_logical3_integer4
  1519.             (ffebld_cu_ptr_logical3 (u),
  1520.              ffebld_constant_integer4 (ffebld_conter (l)));
  1521.           break;
  1522. #endif
  1523.  
  1524.         default:
  1525.           assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
  1526.           break;
  1527.         }
  1528.           break;
  1529.  
  1530.         case FFEINFO_basictypeCHARACTER:
  1531.           error = ffetarget_convert_logical3_character1
  1532.         (ffebld_cu_ptr_logical3 (u),
  1533.          ffebld_constant_character1 (ffebld_conter (l)));
  1534.           break;
  1535.  
  1536.         case FFEINFO_basictypeHOLLERITH:
  1537.           error = ffetarget_convert_logical3_hollerith
  1538.         (ffebld_cu_ptr_logical3 (u),
  1539.          ffebld_constant_hollerith (ffebld_conter (l)));
  1540.           break;
  1541.  
  1542.         case FFEINFO_basictypeTYPELESS:
  1543.           error = ffetarget_convert_logical3_typeless
  1544.         (ffebld_cu_ptr_logical3 (u),
  1545.          ffebld_constant_typeless (ffebld_conter (l)));
  1546.           break;
  1547.  
  1548.         default:
  1549.           assert ("LOGICAL3 bad type" == NULL);
  1550.           break;
  1551.         }
  1552.  
  1553.       expr = ffebld_new_conter_with_orig
  1554.         (ffebld_constant_new_logical3_val
  1555.          (ffebld_cu_val_logical3 (u)), expr);
  1556.       break;
  1557. #endif
  1558.  
  1559. #if FFETARGET_okLOGICAL4
  1560.     case FFEINFO_kindtypeLOGICAL4:
  1561.       switch (ffeinfo_basictype (ffebld_info (l)))
  1562.         {
  1563.         case FFEINFO_basictypeLOGICAL:
  1564.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1565.         {
  1566. #if FFETARGET_okLOGICAL1
  1567.         case FFEINFO_kindtypeLOGICAL1:
  1568.           error = ffetarget_convert_logical4_logical1
  1569.             (ffebld_cu_ptr_logical4 (u),
  1570.              ffebld_constant_logical1 (ffebld_conter (l)));
  1571.           break;
  1572. #endif
  1573.  
  1574. #if FFETARGET_okLOGICAL2
  1575.         case FFEINFO_kindtypeLOGICAL2:
  1576.           error = ffetarget_convert_logical4_logical2
  1577.             (ffebld_cu_ptr_logical4 (u),
  1578.              ffebld_constant_logical2 (ffebld_conter (l)));
  1579.           break;
  1580. #endif
  1581.  
  1582. #if FFETARGET_okLOGICAL3
  1583.         case FFEINFO_kindtypeLOGICAL3:
  1584.           error = ffetarget_convert_logical4_logical3
  1585.             (ffebld_cu_ptr_logical4 (u),
  1586.              ffebld_constant_logical3 (ffebld_conter (l)));
  1587.           break;
  1588. #endif
  1589.  
  1590.         default:
  1591.           assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
  1592.           break;
  1593.         }
  1594.           break;
  1595.  
  1596.         case FFEINFO_basictypeINTEGER:
  1597.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1598.         {
  1599. #if FFETARGET_okINTEGER1
  1600.         case FFEINFO_kindtypeINTEGER1:
  1601.           error = ffetarget_convert_logical4_integer1
  1602.             (ffebld_cu_ptr_logical4 (u),
  1603.              ffebld_constant_integer1 (ffebld_conter (l)));
  1604.           break;
  1605. #endif
  1606.  
  1607. #if FFETARGET_okINTEGER2
  1608.         case FFEINFO_kindtypeINTEGER2:
  1609.           error = ffetarget_convert_logical4_integer2
  1610.             (ffebld_cu_ptr_logical4 (u),
  1611.              ffebld_constant_integer2 (ffebld_conter (l)));
  1612.           break;
  1613. #endif
  1614.  
  1615. #if FFETARGET_okINTEGER3
  1616.         case FFEINFO_kindtypeINTEGER3:
  1617.           error = ffetarget_convert_logical4_integer3
  1618.             (ffebld_cu_ptr_logical4 (u),
  1619.              ffebld_constant_integer3 (ffebld_conter (l)));
  1620.           break;
  1621. #endif
  1622.  
  1623. #if FFETARGET_okINTEGER4
  1624.         case FFEINFO_kindtypeINTEGER4:
  1625.           error = ffetarget_convert_logical4_integer4
  1626.             (ffebld_cu_ptr_logical4 (u),
  1627.              ffebld_constant_integer4 (ffebld_conter (l)));
  1628.           break;
  1629. #endif
  1630.  
  1631.         default:
  1632.           assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
  1633.           break;
  1634.         }
  1635.           break;
  1636.  
  1637.         case FFEINFO_basictypeCHARACTER:
  1638.           error = ffetarget_convert_logical4_character1
  1639.         (ffebld_cu_ptr_logical4 (u),
  1640.          ffebld_constant_character1 (ffebld_conter (l)));
  1641.           break;
  1642.  
  1643.         case FFEINFO_basictypeHOLLERITH:
  1644.           error = ffetarget_convert_logical4_hollerith
  1645.         (ffebld_cu_ptr_logical4 (u),
  1646.          ffebld_constant_hollerith (ffebld_conter (l)));
  1647.           break;
  1648.  
  1649.         case FFEINFO_basictypeTYPELESS:
  1650.           error = ffetarget_convert_logical4_typeless
  1651.         (ffebld_cu_ptr_logical4 (u),
  1652.          ffebld_constant_typeless (ffebld_conter (l)));
  1653.           break;
  1654.  
  1655.         default:
  1656.           assert ("LOGICAL4 bad type" == NULL);
  1657.           break;
  1658.         }
  1659.  
  1660.       expr = ffebld_new_conter_with_orig
  1661.         (ffebld_constant_new_logical4_val
  1662.          (ffebld_cu_val_logical4 (u)), expr);
  1663.       break;
  1664. #endif
  1665.  
  1666.     default:
  1667.       assert ("bad logical kind type" == NULL);
  1668.       break;
  1669.     }
  1670.       break;
  1671.  
  1672.     case FFEINFO_basictypeREAL:
  1673.       sz = FFETARGET_charactersizeNONE;
  1674.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  1675.     {
  1676. #if FFETARGET_okREAL1
  1677.     case FFEINFO_kindtypeREAL1:
  1678.       switch (ffeinfo_basictype (ffebld_info (l)))
  1679.         {
  1680.         case FFEINFO_basictypeINTEGER:
  1681.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1682.         {
  1683. #if FFETARGET_okINTEGER1
  1684.         case FFEINFO_kindtypeINTEGER1:
  1685.           error = ffetarget_convert_real1_integer1
  1686.             (ffebld_cu_ptr_real1 (u),
  1687.              ffebld_constant_integer1 (ffebld_conter (l)));
  1688.           break;
  1689. #endif
  1690.  
  1691. #if FFETARGET_okINTEGER2
  1692.         case FFEINFO_kindtypeINTEGER2:
  1693.           error = ffetarget_convert_real1_integer2
  1694.             (ffebld_cu_ptr_real1 (u),
  1695.              ffebld_constant_integer2 (ffebld_conter (l)));
  1696.           break;
  1697. #endif
  1698.  
  1699. #if FFETARGET_okINTEGER3
  1700.         case FFEINFO_kindtypeINTEGER3:
  1701.           error = ffetarget_convert_real1_integer3
  1702.             (ffebld_cu_ptr_real1 (u),
  1703.              ffebld_constant_integer3 (ffebld_conter (l)));
  1704.           break;
  1705. #endif
  1706.  
  1707. #if FFETARGET_okINTEGER4
  1708.         case FFEINFO_kindtypeINTEGER4:
  1709.           error = ffetarget_convert_real1_integer4
  1710.             (ffebld_cu_ptr_real1 (u),
  1711.              ffebld_constant_integer4 (ffebld_conter (l)));
  1712.           break;
  1713. #endif
  1714.  
  1715.         default:
  1716.           assert ("REAL1/INTEGER bad source kind type" == NULL);
  1717.           break;
  1718.         }
  1719.           break;
  1720.  
  1721.         case FFEINFO_basictypeREAL:
  1722.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1723.         {
  1724. #if FFETARGET_okREAL2
  1725.         case FFEINFO_kindtypeREAL2:
  1726.           error = ffetarget_convert_real1_real2
  1727.             (ffebld_cu_ptr_real1 (u),
  1728.              ffebld_constant_real2 (ffebld_conter (l)));
  1729.           break;
  1730. #endif
  1731.  
  1732. #if FFETARGET_okREAL3
  1733.         case FFEINFO_kindtypeREAL3:
  1734.           error = ffetarget_convert_real1_real3
  1735.             (ffebld_cu_ptr_real1 (u),
  1736.              ffebld_constant_real3 (ffebld_conter (l)));
  1737.           break;
  1738. #endif
  1739.  
  1740. #if FFETARGET_okREAL4
  1741.         case FFEINFO_kindtypeREAL4:
  1742.           error = ffetarget_convert_real1_real4
  1743.             (ffebld_cu_ptr_real1 (u),
  1744.              ffebld_constant_real4 (ffebld_conter (l)));
  1745.           break;
  1746. #endif
  1747.  
  1748.         default:
  1749.           assert ("REAL1/REAL bad source kind type" == NULL);
  1750.           break;
  1751.         }
  1752.           break;
  1753.  
  1754.         case FFEINFO_basictypeCOMPLEX:
  1755.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1756.         {
  1757. #if FFETARGET_okCOMPLEX1
  1758.         case FFEINFO_kindtypeREAL1:
  1759.           error = ffetarget_convert_real1_complex1
  1760.             (ffebld_cu_ptr_real1 (u),
  1761.              ffebld_constant_complex1 (ffebld_conter (l)));
  1762.           break;
  1763. #endif
  1764.  
  1765. #if FFETARGET_okCOMPLEX2
  1766.         case FFEINFO_kindtypeREAL2:
  1767.           error = ffetarget_convert_real1_complex2
  1768.             (ffebld_cu_ptr_real1 (u),
  1769.              ffebld_constant_complex2 (ffebld_conter (l)));
  1770.           break;
  1771. #endif
  1772.  
  1773. #if FFETARGET_okCOMPLEX3
  1774.         case FFEINFO_kindtypeREAL3:
  1775.           error = ffetarget_convert_real1_complex3
  1776.             (ffebld_cu_ptr_real1 (u),
  1777.              ffebld_constant_complex3 (ffebld_conter (l)));
  1778.           break;
  1779. #endif
  1780.  
  1781. #if FFETARGET_okCOMPLEX4
  1782.         case FFEINFO_kindtypeREAL4:
  1783.           error = ffetarget_convert_real1_complex4
  1784.             (ffebld_cu_ptr_real1 (u),
  1785.              ffebld_constant_complex4 (ffebld_conter (l)));
  1786.           break;
  1787. #endif
  1788.  
  1789.         default:
  1790.           assert ("REAL1/COMPLEX bad source kind type" == NULL);
  1791.           break;
  1792.         }
  1793.           break;
  1794.  
  1795.         case FFEINFO_basictypeCHARACTER:
  1796.           error = ffetarget_convert_real1_character1
  1797.         (ffebld_cu_ptr_real1 (u),
  1798.          ffebld_constant_character1 (ffebld_conter (l)));
  1799.           break;
  1800.  
  1801.         case FFEINFO_basictypeHOLLERITH:
  1802.           error = ffetarget_convert_real1_hollerith
  1803.         (ffebld_cu_ptr_real1 (u),
  1804.          ffebld_constant_hollerith (ffebld_conter (l)));
  1805.           break;
  1806.  
  1807.         case FFEINFO_basictypeTYPELESS:
  1808.           error = ffetarget_convert_real1_typeless
  1809.         (ffebld_cu_ptr_real1 (u),
  1810.          ffebld_constant_typeless (ffebld_conter (l)));
  1811.           break;
  1812.  
  1813.         default:
  1814.           assert ("REAL1 bad type" == NULL);
  1815.           break;
  1816.         }
  1817.  
  1818.       expr = ffebld_new_conter_with_orig
  1819.         (ffebld_constant_new_real1_val
  1820.          (ffebld_cu_val_real1 (u)), expr);
  1821.       break;
  1822. #endif
  1823.  
  1824. #if FFETARGET_okREAL2
  1825.     case FFEINFO_kindtypeREAL2:
  1826.       switch (ffeinfo_basictype (ffebld_info (l)))
  1827.         {
  1828.         case FFEINFO_basictypeINTEGER:
  1829.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1830.         {
  1831. #if FFETARGET_okINTEGER1
  1832.         case FFEINFO_kindtypeINTEGER1:
  1833.           error = ffetarget_convert_real2_integer1
  1834.             (ffebld_cu_ptr_real2 (u),
  1835.              ffebld_constant_integer1 (ffebld_conter (l)));
  1836.           break;
  1837. #endif
  1838.  
  1839. #if FFETARGET_okINTEGER2
  1840.         case FFEINFO_kindtypeINTEGER2:
  1841.           error = ffetarget_convert_real2_integer2
  1842.             (ffebld_cu_ptr_real2 (u),
  1843.              ffebld_constant_integer2 (ffebld_conter (l)));
  1844.           break;
  1845. #endif
  1846.  
  1847. #if FFETARGET_okINTEGER3
  1848.         case FFEINFO_kindtypeINTEGER3:
  1849.           error = ffetarget_convert_real2_integer3
  1850.             (ffebld_cu_ptr_real2 (u),
  1851.              ffebld_constant_integer3 (ffebld_conter (l)));
  1852.           break;
  1853. #endif
  1854.  
  1855. #if FFETARGET_okINTEGER4
  1856.         case FFEINFO_kindtypeINTEGER4:
  1857.           error = ffetarget_convert_real2_integer4
  1858.             (ffebld_cu_ptr_real2 (u),
  1859.              ffebld_constant_integer4 (ffebld_conter (l)));
  1860.           break;
  1861. #endif
  1862.  
  1863.         default:
  1864.           assert ("REAL2/INTEGER bad source kind type" == NULL);
  1865.           break;
  1866.         }
  1867.           break;
  1868.  
  1869.         case FFEINFO_basictypeREAL:
  1870.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1871.         {
  1872. #if FFETARGET_okREAL1
  1873.         case FFEINFO_kindtypeREAL1:
  1874.           error = ffetarget_convert_real2_real1
  1875.             (ffebld_cu_ptr_real2 (u),
  1876.              ffebld_constant_real1 (ffebld_conter (l)));
  1877.           break;
  1878. #endif
  1879.  
  1880. #if FFETARGET_okREAL3
  1881.         case FFEINFO_kindtypeREAL3:
  1882.           error = ffetarget_convert_real2_real3
  1883.             (ffebld_cu_ptr_real2 (u),
  1884.              ffebld_constant_real3 (ffebld_conter (l)));
  1885.           break;
  1886. #endif
  1887.  
  1888. #if FFETARGET_okREAL4
  1889.         case FFEINFO_kindtypeREAL4:
  1890.           error = ffetarget_convert_real2_real4
  1891.             (ffebld_cu_ptr_real2 (u),
  1892.              ffebld_constant_real4 (ffebld_conter (l)));
  1893.           break;
  1894. #endif
  1895.  
  1896.         default:
  1897.           assert ("REAL2/REAL bad source kind type" == NULL);
  1898.           break;
  1899.         }
  1900.           break;
  1901.  
  1902.         case FFEINFO_basictypeCOMPLEX:
  1903.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1904.         {
  1905. #if FFETARGET_okCOMPLEX1
  1906.         case FFEINFO_kindtypeREAL1:
  1907.           error = ffetarget_convert_real2_complex1
  1908.             (ffebld_cu_ptr_real2 (u),
  1909.              ffebld_constant_complex1 (ffebld_conter (l)));
  1910.           break;
  1911. #endif
  1912.  
  1913. #if FFETARGET_okCOMPLEX2
  1914.         case FFEINFO_kindtypeREAL2:
  1915.           error = ffetarget_convert_real2_complex2
  1916.             (ffebld_cu_ptr_real2 (u),
  1917.              ffebld_constant_complex2 (ffebld_conter (l)));
  1918.           break;
  1919. #endif
  1920.  
  1921. #if FFETARGET_okCOMPLEX3
  1922.         case FFEINFO_kindtypeREAL3:
  1923.           error = ffetarget_convert_real2_complex3
  1924.             (ffebld_cu_ptr_real2 (u),
  1925.              ffebld_constant_complex3 (ffebld_conter (l)));
  1926.           break;
  1927. #endif
  1928.  
  1929. #if FFETARGET_okCOMPLEX4
  1930.         case FFEINFO_kindtypeREAL4:
  1931.           error = ffetarget_convert_real2_complex4
  1932.             (ffebld_cu_ptr_real2 (u),
  1933.              ffebld_constant_complex4 (ffebld_conter (l)));
  1934.           break;
  1935. #endif
  1936.  
  1937.         default:
  1938.           assert ("REAL2/COMPLEX bad source kind type" == NULL);
  1939.           break;
  1940.         }
  1941.           break;
  1942.  
  1943.         case FFEINFO_basictypeCHARACTER:
  1944.           error = ffetarget_convert_real2_character1
  1945.         (ffebld_cu_ptr_real2 (u),
  1946.          ffebld_constant_character1 (ffebld_conter (l)));
  1947.           break;
  1948.  
  1949.         case FFEINFO_basictypeHOLLERITH:
  1950.           error = ffetarget_convert_real2_hollerith
  1951.         (ffebld_cu_ptr_real2 (u),
  1952.          ffebld_constant_hollerith (ffebld_conter (l)));
  1953.           break;
  1954.  
  1955.         case FFEINFO_basictypeTYPELESS:
  1956.           error = ffetarget_convert_real2_typeless
  1957.         (ffebld_cu_ptr_real2 (u),
  1958.          ffebld_constant_typeless (ffebld_conter (l)));
  1959.           break;
  1960.  
  1961.         default:
  1962.           assert ("REAL2 bad type" == NULL);
  1963.           break;
  1964.         }
  1965.  
  1966.       expr = ffebld_new_conter_with_orig
  1967.         (ffebld_constant_new_real2_val
  1968.          (ffebld_cu_val_real2 (u)), expr);
  1969.       break;
  1970. #endif
  1971.  
  1972. #if FFETARGET_okREAL3
  1973.     case FFEINFO_kindtypeREAL3:
  1974.       switch (ffeinfo_basictype (ffebld_info (l)))
  1975.         {
  1976.         case FFEINFO_basictypeINTEGER:
  1977.           switch (ffeinfo_kindtype (ffebld_info (l)))
  1978.         {
  1979. #if FFETARGET_okINTEGER1
  1980.         case FFEINFO_kindtypeINTEGER1:
  1981.           error = ffetarget_convert_real3_integer1
  1982.             (ffebld_cu_ptr_real3 (u),
  1983.              ffebld_constant_integer1 (ffebld_conter (l)));
  1984.           break;
  1985. #endif
  1986.  
  1987. #if FFETARGET_okINTEGER2
  1988.         case FFEINFO_kindtypeINTEGER2:
  1989.           error = ffetarget_convert_real3_integer2
  1990.             (ffebld_cu_ptr_real3 (u),
  1991.              ffebld_constant_integer2 (ffebld_conter (l)));
  1992.           break;
  1993. #endif
  1994.  
  1995. #if FFETARGET_okINTEGER3
  1996.         case FFEINFO_kindtypeINTEGER3:
  1997.           error = ffetarget_convert_real3_integer3
  1998.             (ffebld_cu_ptr_real3 (u),
  1999.              ffebld_constant_integer3 (ffebld_conter (l)));
  2000.           break;
  2001. #endif
  2002.  
  2003. #if FFETARGET_okINTEGER4
  2004.         case FFEINFO_kindtypeINTEGER4:
  2005.           error = ffetarget_convert_real3_integer4
  2006.             (ffebld_cu_ptr_real3 (u),
  2007.              ffebld_constant_integer4 (ffebld_conter (l)));
  2008.           break;
  2009. #endif
  2010.  
  2011.         default:
  2012.           assert ("REAL3/INTEGER bad source kind type" == NULL);
  2013.           break;
  2014.         }
  2015.           break;
  2016.  
  2017.         case FFEINFO_basictypeREAL:
  2018.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2019.         {
  2020. #if FFETARGET_okREAL1
  2021.         case FFEINFO_kindtypeREAL1:
  2022.           error = ffetarget_convert_real3_real1
  2023.             (ffebld_cu_ptr_real3 (u),
  2024.              ffebld_constant_real1 (ffebld_conter (l)));
  2025.           break;
  2026. #endif
  2027.  
  2028. #if FFETARGET_okREAL2
  2029.         case FFEINFO_kindtypeREAL2:
  2030.           error = ffetarget_convert_real3_real2
  2031.             (ffebld_cu_ptr_real3 (u),
  2032.              ffebld_constant_real2 (ffebld_conter (l)));
  2033.           break;
  2034. #endif
  2035.  
  2036. #if FFETARGET_okREAL4
  2037.         case FFEINFO_kindtypeREAL4:
  2038.           error = ffetarget_convert_real3_real4
  2039.             (ffebld_cu_ptr_real3 (u),
  2040.              ffebld_constant_real4 (ffebld_conter (l)));
  2041.           break;
  2042. #endif
  2043.  
  2044.         default:
  2045.           assert ("REAL3/REAL bad source kind type" == NULL);
  2046.           break;
  2047.         }
  2048.           break;
  2049.  
  2050.         case FFEINFO_basictypeCOMPLEX:
  2051.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2052.         {
  2053. #if FFETARGET_okCOMPLEX1
  2054.         case FFEINFO_kindtypeREAL1:
  2055.           error = ffetarget_convert_real3_complex1
  2056.             (ffebld_cu_ptr_real3 (u),
  2057.              ffebld_constant_complex1 (ffebld_conter (l)));
  2058.           break;
  2059. #endif
  2060.  
  2061. #if FFETARGET_okCOMPLEX2
  2062.         case FFEINFO_kindtypeREAL2:
  2063.           error = ffetarget_convert_real3_complex2
  2064.             (ffebld_cu_ptr_real3 (u),
  2065.              ffebld_constant_complex2 (ffebld_conter (l)));
  2066.           break;
  2067. #endif
  2068.  
  2069. #if FFETARGET_okCOMPLEX3
  2070.         case FFEINFO_kindtypeREAL3:
  2071.           error = ffetarget_convert_real3_complex3
  2072.             (ffebld_cu_ptr_real3 (u),
  2073.              ffebld_constant_complex3 (ffebld_conter (l)));
  2074.           break;
  2075. #endif
  2076.  
  2077. #if FFETARGET_okCOMPLEX4
  2078.         case FFEINFO_kindtypeREAL4:
  2079.           error = ffetarget_convert_real3_complex4
  2080.             (ffebld_cu_ptr_real3 (u),
  2081.              ffebld_constant_complex4 (ffebld_conter (l)));
  2082.           break;
  2083. #endif
  2084.  
  2085.         default:
  2086.           assert ("REAL3/COMPLEX bad source kind type" == NULL);
  2087.           break;
  2088.         }
  2089.           break;
  2090.  
  2091.         case FFEINFO_basictypeCHARACTER:
  2092.           error = ffetarget_convert_real3_character1
  2093.         (ffebld_cu_ptr_real3 (u),
  2094.          ffebld_constant_character1 (ffebld_conter (l)));
  2095.           break;
  2096.  
  2097.         case FFEINFO_basictypeHOLLERITH:
  2098.           error = ffetarget_convert_real3_hollerith
  2099.         (ffebld_cu_ptr_real3 (u),
  2100.          ffebld_constant_hollerith (ffebld_conter (l)));
  2101.           break;
  2102.  
  2103.         case FFEINFO_basictypeTYPELESS:
  2104.           error = ffetarget_convert_real3_typeless
  2105.         (ffebld_cu_ptr_real3 (u),
  2106.          ffebld_constant_typeless (ffebld_conter (l)));
  2107.           break;
  2108.  
  2109.         default:
  2110.           assert ("REAL3 bad type" == NULL);
  2111.           break;
  2112.         }
  2113.  
  2114.       expr = ffebld_new_conter_with_orig
  2115.         (ffebld_constant_new_real3_val
  2116.          (ffebld_cu_val_real3 (u)), expr);
  2117.       break;
  2118. #endif
  2119.  
  2120. #if FFETARGET_okREAL4
  2121.     case FFEINFO_kindtypeREAL4:
  2122.       switch (ffeinfo_basictype (ffebld_info (l)))
  2123.         {
  2124.         case FFEINFO_basictypeINTEGER:
  2125.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2126.         {
  2127. #if FFETARGET_okINTEGER1
  2128.         case FFEINFO_kindtypeINTEGER1:
  2129.           error = ffetarget_convert_real4_integer1
  2130.             (ffebld_cu_ptr_real4 (u),
  2131.              ffebld_constant_integer1 (ffebld_conter (l)));
  2132.           break;
  2133. #endif
  2134.  
  2135. #if FFETARGET_okINTEGER2
  2136.         case FFEINFO_kindtypeINTEGER2:
  2137.           error = ffetarget_convert_real4_integer2
  2138.             (ffebld_cu_ptr_real4 (u),
  2139.              ffebld_constant_integer2 (ffebld_conter (l)));
  2140.           break;
  2141. #endif
  2142.  
  2143. #if FFETARGET_okINTEGER3
  2144.         case FFEINFO_kindtypeINTEGER3:
  2145.           error = ffetarget_convert_real4_integer3
  2146.             (ffebld_cu_ptr_real4 (u),
  2147.              ffebld_constant_integer3 (ffebld_conter (l)));
  2148.           break;
  2149. #endif
  2150.  
  2151. #if FFETARGET_okINTEGER4
  2152.         case FFEINFO_kindtypeINTEGER4:
  2153.           error = ffetarget_convert_real4_integer4
  2154.             (ffebld_cu_ptr_real4 (u),
  2155.              ffebld_constant_integer4 (ffebld_conter (l)));
  2156.           break;
  2157. #endif
  2158.  
  2159.         default:
  2160.           assert ("REAL4/INTEGER bad source kind type" == NULL);
  2161.           break;
  2162.         }
  2163.           break;
  2164.  
  2165.         case FFEINFO_basictypeREAL:
  2166.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2167.         {
  2168. #if FFETARGET_okREAL1
  2169.         case FFEINFO_kindtypeREAL1:
  2170.           error = ffetarget_convert_real4_real1
  2171.             (ffebld_cu_ptr_real4 (u),
  2172.              ffebld_constant_real1 (ffebld_conter (l)));
  2173.           break;
  2174. #endif
  2175.  
  2176. #if FFETARGET_okREAL2
  2177.         case FFEINFO_kindtypeREAL2:
  2178.           error = ffetarget_convert_real4_real2
  2179.             (ffebld_cu_ptr_real4 (u),
  2180.              ffebld_constant_real2 (ffebld_conter (l)));
  2181.           break;
  2182. #endif
  2183.  
  2184. #if FFETARGET_okREAL3
  2185.         case FFEINFO_kindtypeREAL3:
  2186.           error = ffetarget_convert_real4_real3
  2187.             (ffebld_cu_ptr_real4 (u),
  2188.              ffebld_constant_real3 (ffebld_conter (l)));
  2189.           break;
  2190. #endif
  2191.  
  2192.         default:
  2193.           assert ("REAL4/REAL bad source kind type" == NULL);
  2194.           break;
  2195.         }
  2196.           break;
  2197.  
  2198.         case FFEINFO_basictypeCOMPLEX:
  2199.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2200.         {
  2201. #if FFETARGET_okCOMPLEX1
  2202.         case FFEINFO_kindtypeREAL1:
  2203.           error = ffetarget_convert_real4_complex1
  2204.             (ffebld_cu_ptr_real4 (u),
  2205.              ffebld_constant_complex1 (ffebld_conter (l)));
  2206.           break;
  2207. #endif
  2208.  
  2209. #if FFETARGET_okCOMPLEX2
  2210.         case FFEINFO_kindtypeREAL2:
  2211.           error = ffetarget_convert_real4_complex2
  2212.             (ffebld_cu_ptr_real4 (u),
  2213.              ffebld_constant_complex2 (ffebld_conter (l)));
  2214.           break;
  2215. #endif
  2216.  
  2217. #if FFETARGET_okCOMPLEX3
  2218.         case FFEINFO_kindtypeREAL3:
  2219.           error = ffetarget_convert_real4_complex3
  2220.             (ffebld_cu_ptr_real4 (u),
  2221.              ffebld_constant_complex3 (ffebld_conter (l)));
  2222.           break;
  2223. #endif
  2224.  
  2225. #if FFETARGET_okCOMPLEX4
  2226.         case FFEINFO_kindtypeREAL4:
  2227.           error = ffetarget_convert_real4_complex4
  2228.             (ffebld_cu_ptr_real4 (u),
  2229.              ffebld_constant_complex4 (ffebld_conter (l)));
  2230.           break;
  2231. #endif
  2232.  
  2233.         default:
  2234.           assert ("REAL4/COMPLEX bad source kind type" == NULL);
  2235.           break;
  2236.         }
  2237.           break;
  2238.  
  2239.         case FFEINFO_basictypeCHARACTER:
  2240.           error = ffetarget_convert_real4_character1
  2241.         (ffebld_cu_ptr_real4 (u),
  2242.          ffebld_constant_character1 (ffebld_conter (l)));
  2243.           break;
  2244.  
  2245.         case FFEINFO_basictypeHOLLERITH:
  2246.           error = ffetarget_convert_real4_hollerith
  2247.         (ffebld_cu_ptr_real4 (u),
  2248.          ffebld_constant_hollerith (ffebld_conter (l)));
  2249.           break;
  2250.  
  2251.         case FFEINFO_basictypeTYPELESS:
  2252.           error = ffetarget_convert_real4_typeless
  2253.         (ffebld_cu_ptr_real4 (u),
  2254.          ffebld_constant_typeless (ffebld_conter (l)));
  2255.           break;
  2256.  
  2257.         default:
  2258.           assert ("REAL4 bad type" == NULL);
  2259.           break;
  2260.         }
  2261.  
  2262.       expr = ffebld_new_conter_with_orig
  2263.         (ffebld_constant_new_real4_val
  2264.          (ffebld_cu_val_real4 (u)), expr);
  2265.       break;
  2266. #endif
  2267.  
  2268.     default:
  2269.       assert ("bad real kind type" == NULL);
  2270.       break;
  2271.     }
  2272.       break;
  2273.  
  2274.     case FFEINFO_basictypeCOMPLEX:
  2275.       sz = FFETARGET_charactersizeNONE;
  2276.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  2277.     {
  2278. #if FFETARGET_okCOMPLEX1
  2279.     case FFEINFO_kindtypeREAL1:
  2280.       switch (ffeinfo_basictype (ffebld_info (l)))
  2281.         {
  2282.         case FFEINFO_basictypeINTEGER:
  2283.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2284.         {
  2285. #if FFETARGET_okINTEGER1
  2286.         case FFEINFO_kindtypeINTEGER1:
  2287.           error = ffetarget_convert_complex1_integer1
  2288.             (ffebld_cu_ptr_complex1 (u),
  2289.              ffebld_constant_integer1 (ffebld_conter (l)));
  2290.           break;
  2291. #endif
  2292.  
  2293. #if FFETARGET_okINTEGER2
  2294.         case FFEINFO_kindtypeINTEGER2:
  2295.           error = ffetarget_convert_complex1_integer2
  2296.             (ffebld_cu_ptr_complex1 (u),
  2297.              ffebld_constant_integer2 (ffebld_conter (l)));
  2298.           break;
  2299. #endif
  2300.  
  2301. #if FFETARGET_okINTEGER3
  2302.         case FFEINFO_kindtypeINTEGER3:
  2303.           error = ffetarget_convert_complex1_integer3
  2304.             (ffebld_cu_ptr_complex1 (u),
  2305.              ffebld_constant_integer3 (ffebld_conter (l)));
  2306.           break;
  2307. #endif
  2308.  
  2309. #if FFETARGET_okINTEGER4
  2310.         case FFEINFO_kindtypeINTEGER4:
  2311.           error = ffetarget_convert_complex1_integer4
  2312.             (ffebld_cu_ptr_complex1 (u),
  2313.              ffebld_constant_integer4 (ffebld_conter (l)));
  2314.           break;
  2315. #endif
  2316.  
  2317.         default:
  2318.           assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
  2319.           break;
  2320.         }
  2321.           break;
  2322.  
  2323.         case FFEINFO_basictypeREAL:
  2324.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2325.         {
  2326. #if FFETARGET_okREAL1
  2327.         case FFEINFO_kindtypeREAL1:
  2328.           error = ffetarget_convert_complex1_real1
  2329.             (ffebld_cu_ptr_complex1 (u),
  2330.              ffebld_constant_real1 (ffebld_conter (l)));
  2331.           break;
  2332. #endif
  2333.  
  2334. #if FFETARGET_okREAL2
  2335.         case FFEINFO_kindtypeREAL2:
  2336.           error = ffetarget_convert_complex1_real2
  2337.             (ffebld_cu_ptr_complex1 (u),
  2338.              ffebld_constant_real2 (ffebld_conter (l)));
  2339.           break;
  2340. #endif
  2341.  
  2342. #if FFETARGET_okREAL3
  2343.         case FFEINFO_kindtypeREAL3:
  2344.           error = ffetarget_convert_complex1_real3
  2345.             (ffebld_cu_ptr_complex1 (u),
  2346.              ffebld_constant_real3 (ffebld_conter (l)));
  2347.           break;
  2348. #endif
  2349.  
  2350. #if FFETARGET_okREAL4
  2351.         case FFEINFO_kindtypeREAL4:
  2352.           error = ffetarget_convert_complex1_real4
  2353.             (ffebld_cu_ptr_complex1 (u),
  2354.              ffebld_constant_real4 (ffebld_conter (l)));
  2355.           break;
  2356. #endif
  2357.  
  2358.         default:
  2359.           assert ("COMPLEX1/REAL bad source kind type" == NULL);
  2360.           break;
  2361.         }
  2362.           break;
  2363.  
  2364.         case FFEINFO_basictypeCOMPLEX:
  2365.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2366.         {
  2367. #if FFETARGET_okCOMPLEX2
  2368.         case FFEINFO_kindtypeREAL2:
  2369.           error = ffetarget_convert_complex1_complex2
  2370.             (ffebld_cu_ptr_complex1 (u),
  2371.              ffebld_constant_complex2 (ffebld_conter (l)));
  2372.           break;
  2373. #endif
  2374.  
  2375. #if FFETARGET_okCOMPLEX3
  2376.         case FFEINFO_kindtypeREAL3:
  2377.           error = ffetarget_convert_complex1_complex3
  2378.             (ffebld_cu_ptr_complex1 (u),
  2379.              ffebld_constant_complex3 (ffebld_conter (l)));
  2380.           break;
  2381. #endif
  2382.  
  2383. #if FFETARGET_okCOMPLEX4
  2384.         case FFEINFO_kindtypeREAL4:
  2385.           error = ffetarget_convert_complex1_complex4
  2386.             (ffebld_cu_ptr_complex1 (u),
  2387.              ffebld_constant_complex4 (ffebld_conter (l)));
  2388.           break;
  2389. #endif
  2390.  
  2391.         default:
  2392.           assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
  2393.           break;
  2394.         }
  2395.           break;
  2396.  
  2397.         case FFEINFO_basictypeCHARACTER:
  2398.           error = ffetarget_convert_complex1_character1
  2399.         (ffebld_cu_ptr_complex1 (u),
  2400.          ffebld_constant_character1 (ffebld_conter (l)));
  2401.           break;
  2402.  
  2403.         case FFEINFO_basictypeHOLLERITH:
  2404.           error = ffetarget_convert_complex1_hollerith
  2405.         (ffebld_cu_ptr_complex1 (u),
  2406.          ffebld_constant_hollerith (ffebld_conter (l)));
  2407.           break;
  2408.  
  2409.         case FFEINFO_basictypeTYPELESS:
  2410.           error = ffetarget_convert_complex1_typeless
  2411.         (ffebld_cu_ptr_complex1 (u),
  2412.          ffebld_constant_typeless (ffebld_conter (l)));
  2413.           break;
  2414.  
  2415.         default:
  2416.           assert ("COMPLEX1 bad type" == NULL);
  2417.           break;
  2418.         }
  2419.  
  2420.       expr = ffebld_new_conter_with_orig
  2421.         (ffebld_constant_new_complex1_val
  2422.          (ffebld_cu_val_complex1 (u)), expr);
  2423.       break;
  2424. #endif
  2425.  
  2426. #if FFETARGET_okCOMPLEX2
  2427.     case FFEINFO_kindtypeREAL2:
  2428.       switch (ffeinfo_basictype (ffebld_info (l)))
  2429.         {
  2430.         case FFEINFO_basictypeINTEGER:
  2431.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2432.         {
  2433. #if FFETARGET_okINTEGER1
  2434.         case FFEINFO_kindtypeINTEGER1:
  2435.           error = ffetarget_convert_complex2_integer1
  2436.             (ffebld_cu_ptr_complex2 (u),
  2437.              ffebld_constant_integer1 (ffebld_conter (l)));
  2438.           break;
  2439. #endif
  2440.  
  2441. #if FFETARGET_okINTEGER2
  2442.         case FFEINFO_kindtypeINTEGER2:
  2443.           error = ffetarget_convert_complex2_integer2
  2444.             (ffebld_cu_ptr_complex2 (u),
  2445.              ffebld_constant_integer2 (ffebld_conter (l)));
  2446.           break;
  2447. #endif
  2448.  
  2449. #if FFETARGET_okINTEGER3
  2450.         case FFEINFO_kindtypeINTEGER3:
  2451.           error = ffetarget_convert_complex2_integer3
  2452.             (ffebld_cu_ptr_complex2 (u),
  2453.              ffebld_constant_integer3 (ffebld_conter (l)));
  2454.           break;
  2455. #endif
  2456.  
  2457. #if FFETARGET_okINTEGER4
  2458.         case FFEINFO_kindtypeINTEGER4:
  2459.           error = ffetarget_convert_complex2_integer4
  2460.             (ffebld_cu_ptr_complex2 (u),
  2461.              ffebld_constant_integer4 (ffebld_conter (l)));
  2462.           break;
  2463. #endif
  2464.  
  2465.         default:
  2466.           assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
  2467.           break;
  2468.         }
  2469.           break;
  2470.  
  2471.         case FFEINFO_basictypeREAL:
  2472.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2473.         {
  2474. #if FFETARGET_okREAL1
  2475.         case FFEINFO_kindtypeREAL1:
  2476.           error = ffetarget_convert_complex2_real1
  2477.             (ffebld_cu_ptr_complex2 (u),
  2478.              ffebld_constant_real1 (ffebld_conter (l)));
  2479.           break;
  2480. #endif
  2481.  
  2482. #if FFETARGET_okREAL2
  2483.         case FFEINFO_kindtypeREAL2:
  2484.           error = ffetarget_convert_complex2_real2
  2485.             (ffebld_cu_ptr_complex2 (u),
  2486.              ffebld_constant_real2 (ffebld_conter (l)));
  2487.           break;
  2488. #endif
  2489.  
  2490. #if FFETARGET_okREAL3
  2491.         case FFEINFO_kindtypeREAL3:
  2492.           error = ffetarget_convert_complex2_real3
  2493.             (ffebld_cu_ptr_complex2 (u),
  2494.              ffebld_constant_real3 (ffebld_conter (l)));
  2495.           break;
  2496. #endif
  2497.  
  2498. #if FFETARGET_okREAL4
  2499.         case FFEINFO_kindtypeREAL4:
  2500.           error = ffetarget_convert_complex2_real4
  2501.             (ffebld_cu_ptr_complex2 (u),
  2502.              ffebld_constant_real4 (ffebld_conter (l)));
  2503.           break;
  2504. #endif
  2505.  
  2506.         default:
  2507.           assert ("COMPLEX2/REAL bad source kind type" == NULL);
  2508.           break;
  2509.         }
  2510.           break;
  2511.  
  2512.         case FFEINFO_basictypeCOMPLEX:
  2513.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2514.         {
  2515. #if FFETARGET_okCOMPLEX1
  2516.         case FFEINFO_kindtypeREAL1:
  2517.           error = ffetarget_convert_complex2_complex1
  2518.             (ffebld_cu_ptr_complex2 (u),
  2519.              ffebld_constant_complex1 (ffebld_conter (l)));
  2520.           break;
  2521. #endif
  2522.  
  2523. #if FFETARGET_okCOMPLEX3
  2524.         case FFEINFO_kindtypeREAL3:
  2525.           error = ffetarget_convert_complex2_complex3
  2526.             (ffebld_cu_ptr_complex2 (u),
  2527.              ffebld_constant_complex3 (ffebld_conter (l)));
  2528.           break;
  2529. #endif
  2530.  
  2531. #if FFETARGET_okCOMPLEX4
  2532.         case FFEINFO_kindtypeREAL4:
  2533.           error = ffetarget_convert_complex2_complex4
  2534.             (ffebld_cu_ptr_complex2 (u),
  2535.              ffebld_constant_complex4 (ffebld_conter (l)));
  2536.           break;
  2537. #endif
  2538.  
  2539.         default:
  2540.           assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
  2541.           break;
  2542.         }
  2543.           break;
  2544.  
  2545.         case FFEINFO_basictypeCHARACTER:
  2546.           error = ffetarget_convert_complex2_character1
  2547.         (ffebld_cu_ptr_complex2 (u),
  2548.          ffebld_constant_character1 (ffebld_conter (l)));
  2549.           break;
  2550.  
  2551.         case FFEINFO_basictypeHOLLERITH:
  2552.           error = ffetarget_convert_complex2_hollerith
  2553.         (ffebld_cu_ptr_complex2 (u),
  2554.          ffebld_constant_hollerith (ffebld_conter (l)));
  2555.           break;
  2556.  
  2557.         case FFEINFO_basictypeTYPELESS:
  2558.           error = ffetarget_convert_complex2_typeless
  2559.         (ffebld_cu_ptr_complex2 (u),
  2560.          ffebld_constant_typeless (ffebld_conter (l)));
  2561.           break;
  2562.  
  2563.         default:
  2564.           assert ("COMPLEX2 bad type" == NULL);
  2565.           break;
  2566.         }
  2567.  
  2568.       expr = ffebld_new_conter_with_orig
  2569.         (ffebld_constant_new_complex2_val
  2570.          (ffebld_cu_val_complex2 (u)), expr);
  2571.       break;
  2572. #endif
  2573.  
  2574. #if FFETARGET_okCOMPLEX3
  2575.     case FFEINFO_kindtypeREAL3:
  2576.       switch (ffeinfo_basictype (ffebld_info (l)))
  2577.         {
  2578.         case FFEINFO_basictypeINTEGER:
  2579.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2580.         {
  2581. #if FFETARGET_okINTEGER1
  2582.         case FFEINFO_kindtypeINTEGER1:
  2583.           error = ffetarget_convert_complex3_integer1
  2584.             (ffebld_cu_ptr_complex3 (u),
  2585.              ffebld_constant_integer1 (ffebld_conter (l)));
  2586.           break;
  2587. #endif
  2588.  
  2589. #if FFETARGET_okINTEGER2
  2590.         case FFEINFO_kindtypeINTEGER2:
  2591.           error = ffetarget_convert_complex3_integer2
  2592.             (ffebld_cu_ptr_complex3 (u),
  2593.              ffebld_constant_integer2 (ffebld_conter (l)));
  2594.           break;
  2595. #endif
  2596.  
  2597. #if FFETARGET_okINTEGER3
  2598.         case FFEINFO_kindtypeINTEGER3:
  2599.           error = ffetarget_convert_complex3_integer3
  2600.             (ffebld_cu_ptr_complex3 (u),
  2601.              ffebld_constant_integer3 (ffebld_conter (l)));
  2602.           break;
  2603. #endif
  2604.  
  2605. #if FFETARGET_okINTEGER4
  2606.         case FFEINFO_kindtypeINTEGER4:
  2607.           error = ffetarget_convert_complex3_integer4
  2608.             (ffebld_cu_ptr_complex3 (u),
  2609.              ffebld_constant_integer4 (ffebld_conter (l)));
  2610.           break;
  2611. #endif
  2612.  
  2613.         default:
  2614.           assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
  2615.           break;
  2616.         }
  2617.           break;
  2618.  
  2619.         case FFEINFO_basictypeREAL:
  2620.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2621.         {
  2622. #if FFETARGET_okREAL1
  2623.         case FFEINFO_kindtypeREAL1:
  2624.           error = ffetarget_convert_complex3_real1
  2625.             (ffebld_cu_ptr_complex3 (u),
  2626.              ffebld_constant_real1 (ffebld_conter (l)));
  2627.           break;
  2628. #endif
  2629.  
  2630. #if FFETARGET_okREAL2
  2631.         case FFEINFO_kindtypeREAL2:
  2632.           error = ffetarget_convert_complex3_real2
  2633.             (ffebld_cu_ptr_complex3 (u),
  2634.              ffebld_constant_real2 (ffebld_conter (l)));
  2635.           break;
  2636. #endif
  2637.  
  2638. #if FFETARGET_okREAL3
  2639.         case FFEINFO_kindtypeREAL3:
  2640.           error = ffetarget_convert_complex3_real3
  2641.             (ffebld_cu_ptr_complex3 (u),
  2642.              ffebld_constant_real3 (ffebld_conter (l)));
  2643.           break;
  2644. #endif
  2645.  
  2646. #if FFETARGET_okREAL4
  2647.         case FFEINFO_kindtypeREAL4:
  2648.           error = ffetarget_convert_complex3_real4
  2649.             (ffebld_cu_ptr_complex3 (u),
  2650.              ffebld_constant_real4 (ffebld_conter (l)));
  2651.           break;
  2652. #endif
  2653.  
  2654.         default:
  2655.           assert ("COMPLEX3/REAL bad source kind type" == NULL);
  2656.           break;
  2657.         }
  2658.           break;
  2659.  
  2660.         case FFEINFO_basictypeCOMPLEX:
  2661.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2662.         {
  2663. #if FFETARGET_okCOMPLEX1
  2664.         case FFEINFO_kindtypeREAL1:
  2665.           error = ffetarget_convert_complex3_complex1
  2666.             (ffebld_cu_ptr_complex3 (u),
  2667.              ffebld_constant_complex1 (ffebld_conter (l)));
  2668.           break;
  2669. #endif
  2670.  
  2671. #if FFETARGET_okCOMPLEX2
  2672.         case FFEINFO_kindtypeREAL2:
  2673.           error = ffetarget_convert_complex3_complex2
  2674.             (ffebld_cu_ptr_complex3 (u),
  2675.              ffebld_constant_complex2 (ffebld_conter (l)));
  2676.           break;
  2677. #endif
  2678.  
  2679. #if FFETARGET_okCOMPLEX4
  2680.         case FFEINFO_kindtypeREAL4:
  2681.           error = ffetarget_convert_complex3_complex4
  2682.             (ffebld_cu_ptr_complex3 (u),
  2683.              ffebld_constant_complex4 (ffebld_conter (l)));
  2684.           break;
  2685. #endif
  2686.  
  2687.         default:
  2688.           assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
  2689.           break;
  2690.         }
  2691.           break;
  2692.  
  2693.         case FFEINFO_basictypeCHARACTER:
  2694.           error = ffetarget_convert_complex3_character1
  2695.         (ffebld_cu_ptr_complex3 (u),
  2696.          ffebld_constant_character1 (ffebld_conter (l)));
  2697.           break;
  2698.  
  2699.         case FFEINFO_basictypeHOLLERITH:
  2700.           error = ffetarget_convert_complex3_hollerith
  2701.         (ffebld_cu_ptr_complex3 (u),
  2702.          ffebld_constant_hollerith (ffebld_conter (l)));
  2703.           break;
  2704.  
  2705.         case FFEINFO_basictypeTYPELESS:
  2706.           error = ffetarget_convert_complex3_typeless
  2707.         (ffebld_cu_ptr_complex3 (u),
  2708.          ffebld_constant_typeless (ffebld_conter (l)));
  2709.           break;
  2710.  
  2711.         default:
  2712.           assert ("COMPLEX3 bad type" == NULL);
  2713.           break;
  2714.         }
  2715.  
  2716.       expr = ffebld_new_conter_with_orig
  2717.         (ffebld_constant_new_complex3_val
  2718.          (ffebld_cu_val_complex3 (u)), expr);
  2719.       break;
  2720. #endif
  2721.  
  2722. #if FFETARGET_okCOMPLEX4
  2723.     case FFEINFO_kindtypeREAL4:
  2724.       switch (ffeinfo_basictype (ffebld_info (l)))
  2725.         {
  2726.         case FFEINFO_basictypeINTEGER:
  2727.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2728.         {
  2729. #if FFETARGET_okINTEGER1
  2730.         case FFEINFO_kindtypeINTEGER1:
  2731.           error = ffetarget_convert_complex4_integer1
  2732.             (ffebld_cu_ptr_complex4 (u),
  2733.              ffebld_constant_integer1 (ffebld_conter (l)));
  2734.           break;
  2735. #endif
  2736.  
  2737. #if FFETARGET_okINTEGER2
  2738.         case FFEINFO_kindtypeINTEGER2:
  2739.           error = ffetarget_convert_complex4_integer2
  2740.             (ffebld_cu_ptr_complex4 (u),
  2741.              ffebld_constant_integer2 (ffebld_conter (l)));
  2742.           break;
  2743. #endif
  2744.  
  2745. #if FFETARGET_okINTEGER3
  2746.         case FFEINFO_kindtypeINTEGER3:
  2747.           error = ffetarget_convert_complex4_integer3
  2748.             (ffebld_cu_ptr_complex4 (u),
  2749.              ffebld_constant_integer3 (ffebld_conter (l)));
  2750.           break;
  2751. #endif
  2752.  
  2753. #if FFETARGET_okINTEGER4
  2754.         case FFEINFO_kindtypeINTEGER4:
  2755.           error = ffetarget_convert_complex4_integer4
  2756.             (ffebld_cu_ptr_complex4 (u),
  2757.              ffebld_constant_integer4 (ffebld_conter (l)));
  2758.           break;
  2759. #endif
  2760.  
  2761.         default:
  2762.           assert ("COMPLEX4/INTEGER bad source kind type" == NULL);
  2763.           break;
  2764.         }
  2765.           break;
  2766.  
  2767.         case FFEINFO_basictypeREAL:
  2768.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2769.         {
  2770. #if FFETARGET_okREAL1
  2771.         case FFEINFO_kindtypeREAL1:
  2772.           error = ffetarget_convert_complex4_real1
  2773.             (ffebld_cu_ptr_complex4 (u),
  2774.              ffebld_constant_real1 (ffebld_conter (l)));
  2775.           break;
  2776. #endif
  2777.  
  2778. #if FFETARGET_okREAL2
  2779.         case FFEINFO_kindtypeREAL2:
  2780.           error = ffetarget_convert_complex4_real2
  2781.             (ffebld_cu_ptr_complex4 (u),
  2782.              ffebld_constant_real2 (ffebld_conter (l)));
  2783.           break;
  2784. #endif
  2785.  
  2786. #if FFETARGET_okREAL3
  2787.         case FFEINFO_kindtypeREAL3:
  2788.           error = ffetarget_convert_complex4_real3
  2789.             (ffebld_cu_ptr_complex4 (u),
  2790.              ffebld_constant_real3 (ffebld_conter (l)));
  2791.           break;
  2792. #endif
  2793.  
  2794. #if FFETARGET_okREAL4
  2795.         case FFEINFO_kindtypeREAL4:
  2796.           error = ffetarget_convert_complex4_real4
  2797.             (ffebld_cu_ptr_complex4 (u),
  2798.              ffebld_constant_real4 (ffebld_conter (l)));
  2799.           break;
  2800. #endif
  2801.  
  2802.         default:
  2803.           assert ("COMPLEX4/REAL bad source kind type" == NULL);
  2804.           break;
  2805.         }
  2806.           break;
  2807.  
  2808.         case FFEINFO_basictypeCOMPLEX:
  2809.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2810.         {
  2811. #if FFETARGET_okCOMPLEX1
  2812.         case FFEINFO_kindtypeREAL1:
  2813.           error = ffetarget_convert_complex4_complex1
  2814.             (ffebld_cu_ptr_complex4 (u),
  2815.              ffebld_constant_complex1 (ffebld_conter (l)));
  2816.           break;
  2817. #endif
  2818.  
  2819. #if FFETARGET_okCOMPLEX2
  2820.         case FFEINFO_kindtypeREAL2:
  2821.           error = ffetarget_convert_complex4_complex2
  2822.             (ffebld_cu_ptr_complex4 (u),
  2823.              ffebld_constant_complex2 (ffebld_conter (l)));
  2824.           break;
  2825. #endif
  2826.  
  2827. #if FFETARGET_okCOMPLEX3
  2828.         case FFEINFO_kindtypeREAL3:
  2829.           error = ffetarget_convert_complex4_complex3
  2830.             (ffebld_cu_ptr_complex4 (u),
  2831.              ffebld_constant_complex3 (ffebld_conter (l)));
  2832.           break;
  2833. #endif
  2834.  
  2835.         default:
  2836.           assert ("COMPLEX4/COMPLEX bad source kind type" == NULL);
  2837.           break;
  2838.         }
  2839.           break;
  2840.  
  2841.         case FFEINFO_basictypeCHARACTER:
  2842.           error = ffetarget_convert_complex4_character1
  2843.         (ffebld_cu_ptr_complex4 (u),
  2844.          ffebld_constant_character1 (ffebld_conter (l)));
  2845.           break;
  2846.  
  2847.         case FFEINFO_basictypeHOLLERITH:
  2848.           error = ffetarget_convert_complex4_hollerith
  2849.         (ffebld_cu_ptr_complex4 (u),
  2850.          ffebld_constant_hollerith (ffebld_conter (l)));
  2851.           break;
  2852.  
  2853.         case FFEINFO_basictypeTYPELESS:
  2854.           error = ffetarget_convert_complex4_typeless
  2855.         (ffebld_cu_ptr_complex4 (u),
  2856.          ffebld_constant_typeless (ffebld_conter (l)));
  2857.           break;
  2858.  
  2859.         default:
  2860.           assert ("COMPLEX4 bad type" == NULL);
  2861.           break;
  2862.         }
  2863.  
  2864.       expr = ffebld_new_conter_with_orig
  2865.         (ffebld_constant_new_complex4_val
  2866.          (ffebld_cu_val_complex4 (u)), expr);
  2867.       break;
  2868. #endif
  2869.  
  2870.     default:
  2871.       assert ("bad complex kind type" == NULL);
  2872.       break;
  2873.     }
  2874.       break;
  2875.  
  2876.     case FFEINFO_basictypeCHARACTER:
  2877.       if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
  2878.     return expr;
  2879.       kt = ffeinfo_kindtype (ffebld_info (expr));
  2880.       switch (kt)
  2881.     {
  2882. #if FFETARGET_okCHARACTER1
  2883.     case FFEINFO_kindtypeCHARACTER1:
  2884.       switch (ffeinfo_basictype (ffebld_info (l)))
  2885.         {
  2886.         case FFEINFO_basictypeCHARACTER:
  2887.           if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
  2888.         return expr;
  2889.           assert (kt == ffeinfo_kindtype (ffebld_info (l)));
  2890.           assert (sz2 == ffetarget_length_character1
  2891.               (ffebld_constant_character1
  2892.                (ffebld_conter (l))));
  2893.           error
  2894.         = ffetarget_convert_character1_character1
  2895.         (ffebld_cu_ptr_character1 (u), sz,
  2896.          ffebld_constant_character1 (ffebld_conter (l)),
  2897.          ffebld_constant_character_pool ());
  2898.           break;
  2899.  
  2900.         case FFEINFO_basictypeINTEGER:
  2901.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2902.         {
  2903. #if FFETARGET_okINTEGER1
  2904.         case FFEINFO_kindtypeINTEGER1:
  2905.           error
  2906.             = ffetarget_convert_character1_integer1
  2907.               (ffebld_cu_ptr_character1 (u),
  2908.                sz,
  2909.                ffebld_constant_integer1 (ffebld_conter (l)),
  2910.                ffebld_constant_character_pool ());
  2911.           break;
  2912. #endif
  2913.  
  2914. #if FFETARGET_okINTEGER2
  2915.         case FFEINFO_kindtypeINTEGER2:
  2916.           error
  2917.             = ffetarget_convert_character1_integer2
  2918.               (ffebld_cu_ptr_character1 (u),
  2919.                sz,
  2920.                ffebld_constant_integer2 (ffebld_conter (l)),
  2921.                ffebld_constant_character_pool ());
  2922.           break;
  2923. #endif
  2924.  
  2925. #if FFETARGET_okINTEGER3
  2926.         case FFEINFO_kindtypeINTEGER3:
  2927.           error
  2928.             = ffetarget_convert_character1_integer3
  2929.               (ffebld_cu_ptr_character1 (u),
  2930.                sz,
  2931.                ffebld_constant_integer3 (ffebld_conter (l)),
  2932.                ffebld_constant_character_pool ());
  2933.           break;
  2934. #endif
  2935.  
  2936. #if FFETARGET_okINTEGER4
  2937.         case FFEINFO_kindtypeINTEGER4:
  2938.           error
  2939.             = ffetarget_convert_character1_integer4
  2940.               (ffebld_cu_ptr_character1 (u),
  2941.                sz,
  2942.                ffebld_constant_integer4 (ffebld_conter (l)),
  2943.                ffebld_constant_character_pool ());
  2944.           break;
  2945. #endif
  2946.  
  2947.         default:
  2948.           assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
  2949.           break;
  2950.         }
  2951.           break;
  2952.  
  2953.         case FFEINFO_basictypeLOGICAL:
  2954.           switch (ffeinfo_kindtype (ffebld_info (l)))
  2955.         {
  2956. #if FFETARGET_okLOGICAL1
  2957.         case FFEINFO_kindtypeLOGICAL1:
  2958.           error
  2959.             = ffetarget_convert_character1_logical1
  2960.               (ffebld_cu_ptr_character1 (u),
  2961.                sz,
  2962.                ffebld_constant_logical1 (ffebld_conter (l)),
  2963.                ffebld_constant_character_pool ());
  2964.           break;
  2965. #endif
  2966.  
  2967. #if FFETARGET_okLOGICAL2
  2968.         case FFEINFO_kindtypeLOGICAL2:
  2969.           error
  2970.             = ffetarget_convert_character1_logical2
  2971.               (ffebld_cu_ptr_character1 (u),
  2972.                sz,
  2973.                ffebld_constant_logical2 (ffebld_conter (l)),
  2974.                ffebld_constant_character_pool ());
  2975.           break;
  2976. #endif
  2977.  
  2978. #if FFETARGET_okLOGICAL3
  2979.         case FFEINFO_kindtypeLOGICAL3:
  2980.           error
  2981.             = ffetarget_convert_character1_logical3
  2982.               (ffebld_cu_ptr_character1 (u),
  2983.                sz,
  2984.                ffebld_constant_logical3 (ffebld_conter (l)),
  2985.                ffebld_constant_character_pool ());
  2986.           break;
  2987. #endif
  2988.  
  2989. #if FFETARGET_okLOGICAL4
  2990.         case FFEINFO_kindtypeLOGICAL4:
  2991.           error
  2992.             = ffetarget_convert_character1_logical4
  2993.               (ffebld_cu_ptr_character1 (u),
  2994.                sz,
  2995.                ffebld_constant_logical4 (ffebld_conter (l)),
  2996.                ffebld_constant_character_pool ());
  2997.           break;
  2998. #endif
  2999.  
  3000.         default:
  3001.           assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
  3002.           break;
  3003.         }
  3004.           break;
  3005.  
  3006.         case FFEINFO_basictypeHOLLERITH:
  3007.           error
  3008.         = ffetarget_convert_character1_hollerith
  3009.         (ffebld_cu_ptr_character1 (u),
  3010.          sz,
  3011.          ffebld_constant_hollerith (ffebld_conter (l)),
  3012.          ffebld_constant_character_pool ());
  3013.           break;
  3014.  
  3015.         case FFEINFO_basictypeTYPELESS:
  3016.           error
  3017.         = ffetarget_convert_character1_typeless
  3018.         (ffebld_cu_ptr_character1 (u),
  3019.          sz,
  3020.          ffebld_constant_typeless (ffebld_conter (l)),
  3021.          ffebld_constant_character_pool ());
  3022.           break;
  3023.  
  3024.         default:
  3025.           assert ("CHARACTER1 bad type" == NULL);
  3026.         }
  3027.  
  3028.       expr
  3029.         = ffebld_new_conter_with_orig
  3030.         (ffebld_constant_new_character1_val
  3031.          (ffebld_cu_val_character1 (u)),
  3032.          expr);
  3033.       break;
  3034. #endif
  3035.  
  3036.     default:
  3037.       assert ("bad character kind type" == NULL);
  3038.       break;
  3039.     }
  3040.       break;
  3041.  
  3042.     default:
  3043.       assert ("bad type" == NULL);
  3044.       return expr;
  3045.     }
  3046.  
  3047.   ffebld_set_info (expr, ffeinfo_new
  3048.            (bt,
  3049.             kt,
  3050.             0,
  3051.             FFEINFO_kindENTITY,
  3052.             FFEINFO_whereCONSTANT,
  3053.             sz));
  3054.  
  3055.   if ((error != FFEBAD)
  3056.       && ffebad_start (error))
  3057.     {
  3058.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  3059.       ffebad_finish ();
  3060.     }
  3061.  
  3062.   return expr;
  3063. }
  3064.  
  3065. /* ffeexpr_collapse_paren -- Collapse paren expr
  3066.  
  3067.    ffebld expr;
  3068.    ffelexToken token;
  3069.    expr = ffeexpr_collapse_paren(expr,token);
  3070.  
  3071.    If the result of the expr is a constant, replaces the expr with the
  3072.    computed constant.  */
  3073.  
  3074. ffebld
  3075. ffeexpr_collapse_paren (ffebld expr, ffelexToken t)
  3076. {
  3077.   ffebld r;
  3078.   ffeinfoBasictype bt;
  3079.   ffeinfoKindtype kt;
  3080.   ffetargetCharacterSize len;
  3081.  
  3082.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  3083.     return expr;
  3084.  
  3085.   r = ffebld_left (expr);
  3086.  
  3087.   if (ffebld_op (r) != FFEBLD_opCONTER)
  3088.     return expr;
  3089.  
  3090.   bt = ffeinfo_basictype (ffebld_info (r));
  3091.   kt = ffeinfo_kindtype (ffebld_info (r));
  3092.   len = ffebld_size (r);
  3093.  
  3094.   expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
  3095.                       expr);
  3096.  
  3097.   ffebld_set_info (expr, ffeinfo_new
  3098.            (bt,
  3099.             kt,
  3100.             0,
  3101.             FFEINFO_kindENTITY,
  3102.             FFEINFO_whereCONSTANT,
  3103.             len));
  3104.  
  3105.   return expr;
  3106. }
  3107.  
  3108. /* ffeexpr_collapse_uplus -- Collapse uplus expr
  3109.  
  3110.    ffebld expr;
  3111.    ffelexToken token;
  3112.    expr = ffeexpr_collapse_uplus(expr,token);
  3113.  
  3114.    If the result of the expr is a constant, replaces the expr with the
  3115.    computed constant.  */
  3116.  
  3117. ffebld
  3118. ffeexpr_collapse_uplus (ffebld expr, ffelexToken t)
  3119. {
  3120.   ffebld r;
  3121.   ffeinfoBasictype bt;
  3122.   ffeinfoKindtype kt;
  3123.   ffetargetCharacterSize len;
  3124.  
  3125.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  3126.     return expr;
  3127.  
  3128.   r = ffebld_left (expr);
  3129.  
  3130.   if (ffebld_op (r) != FFEBLD_opCONTER)
  3131.     return expr;
  3132.  
  3133.   bt = ffeinfo_basictype (ffebld_info (r));
  3134.   kt = ffeinfo_kindtype (ffebld_info (r));
  3135.   len = ffebld_size (r);
  3136.  
  3137.   expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
  3138.                       expr);
  3139.  
  3140.   ffebld_set_info (expr, ffeinfo_new
  3141.            (bt,
  3142.             kt,
  3143.             0,
  3144.             FFEINFO_kindENTITY,
  3145.             FFEINFO_whereCONSTANT,
  3146.             len));
  3147.  
  3148.   return expr;
  3149. }
  3150.  
  3151. /* ffeexpr_collapse_uminus -- Collapse uminus expr
  3152.  
  3153.    ffebld expr;
  3154.    ffelexToken token;
  3155.    expr = ffeexpr_collapse_uminus(expr,token);
  3156.  
  3157.    If the result of the expr is a constant, replaces the expr with the
  3158.    computed constant.  */
  3159.  
  3160. ffebld
  3161. ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
  3162. {
  3163.   ffebad error = FFEBAD;
  3164.   ffebld r;
  3165.   ffebldConstantUnion u;
  3166.   ffeinfoBasictype bt;
  3167.   ffeinfoKindtype kt;
  3168.  
  3169.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  3170.     return expr;
  3171.  
  3172.   r = ffebld_left (expr);
  3173.  
  3174.   if (ffebld_op (r) != FFEBLD_opCONTER)
  3175.     return expr;
  3176.  
  3177.   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  3178.     {
  3179.     case FFEINFO_basictypeANY:
  3180.       return expr;
  3181.  
  3182.     case FFEINFO_basictypeINTEGER:
  3183.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3184.     {
  3185. #if FFETARGET_okINTEGER1
  3186.     case FFEINFO_kindtypeINTEGER1:
  3187.       error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
  3188.                   ffebld_constant_integer1 (ffebld_conter (r)));
  3189.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  3190.                     (ffebld_cu_val_integer1 (u)), expr);
  3191.       break;
  3192. #endif
  3193.  
  3194. #if FFETARGET_okINTEGER2
  3195.     case FFEINFO_kindtypeINTEGER2:
  3196.       error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
  3197.                   ffebld_constant_integer2 (ffebld_conter (r)));
  3198.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  3199.                     (ffebld_cu_val_integer2 (u)), expr);
  3200.       break;
  3201. #endif
  3202.  
  3203. #if FFETARGET_okINTEGER3
  3204.     case FFEINFO_kindtypeINTEGER3:
  3205.       error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
  3206.                   ffebld_constant_integer3 (ffebld_conter (r)));
  3207.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  3208.                     (ffebld_cu_val_integer3 (u)), expr);
  3209.       break;
  3210. #endif
  3211.  
  3212. #if FFETARGET_okINTEGER4
  3213.     case FFEINFO_kindtypeINTEGER4:
  3214.       error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
  3215.                   ffebld_constant_integer4 (ffebld_conter (r)));
  3216.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  3217.                     (ffebld_cu_val_integer4 (u)), expr);
  3218.       break;
  3219. #endif
  3220.  
  3221.     default:
  3222.       assert ("bad integer kind type" == NULL);
  3223.       break;
  3224.     }
  3225.       break;
  3226.  
  3227.     case FFEINFO_basictypeREAL:
  3228.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3229.     {
  3230. #if FFETARGET_okREAL1
  3231.     case FFEINFO_kindtypeREAL1:
  3232.       error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
  3233.                  ffebld_constant_real1 (ffebld_conter (r)));
  3234.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
  3235.                        (ffebld_cu_val_real1 (u)), expr);
  3236.       break;
  3237. #endif
  3238.  
  3239. #if FFETARGET_okREAL2
  3240.     case FFEINFO_kindtypeREAL2:
  3241.       error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
  3242.                  ffebld_constant_real2 (ffebld_conter (r)));
  3243.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
  3244.                        (ffebld_cu_val_real2 (u)), expr);
  3245.       break;
  3246. #endif
  3247.  
  3248. #if FFETARGET_okREAL3
  3249.     case FFEINFO_kindtypeREAL3:
  3250.       error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
  3251.                  ffebld_constant_real3 (ffebld_conter (r)));
  3252.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
  3253.                        (ffebld_cu_val_real3 (u)), expr);
  3254.       break;
  3255. #endif
  3256.  
  3257. #if FFETARGET_okREAL4
  3258.     case FFEINFO_kindtypeREAL4:
  3259.       error = ffetarget_uminus_real4 (ffebld_cu_ptr_real4 (u),
  3260.                  ffebld_constant_real4 (ffebld_conter (r)));
  3261.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
  3262.                        (ffebld_cu_val_real4 (u)), expr);
  3263.       break;
  3264. #endif
  3265.  
  3266.     default:
  3267.       assert ("bad real kind type" == NULL);
  3268.       break;
  3269.     }
  3270.       break;
  3271.  
  3272.     case FFEINFO_basictypeCOMPLEX:
  3273.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3274.     {
  3275. #if FFETARGET_okCOMPLEX1
  3276.     case FFEINFO_kindtypeREAL1:
  3277.       error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
  3278.                   ffebld_constant_complex1 (ffebld_conter (r)));
  3279.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
  3280.                     (ffebld_cu_val_complex1 (u)), expr);
  3281.       break;
  3282. #endif
  3283.  
  3284. #if FFETARGET_okCOMPLEX2
  3285.     case FFEINFO_kindtypeREAL2:
  3286.       error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
  3287.                   ffebld_constant_complex2 (ffebld_conter (r)));
  3288.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
  3289.                     (ffebld_cu_val_complex2 (u)), expr);
  3290.       break;
  3291. #endif
  3292.  
  3293. #if FFETARGET_okCOMPLEX3
  3294.     case FFEINFO_kindtypeREAL3:
  3295.       error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
  3296.                   ffebld_constant_complex3 (ffebld_conter (r)));
  3297.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
  3298.                     (ffebld_cu_val_complex3 (u)), expr);
  3299.       break;
  3300. #endif
  3301.  
  3302. #if FFETARGET_okCOMPLEX4
  3303.     case FFEINFO_kindtypeREAL4:
  3304.       error = ffetarget_uminus_complex4 (ffebld_cu_ptr_complex4 (u),
  3305.                   ffebld_constant_complex4 (ffebld_conter (r)));
  3306.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
  3307.                     (ffebld_cu_val_complex4 (u)), expr);
  3308.       break;
  3309. #endif
  3310.  
  3311.     default:
  3312.       assert ("bad complex kind type" == NULL);
  3313.       break;
  3314.     }
  3315.       break;
  3316.  
  3317.     default:
  3318.       assert ("bad type" == NULL);
  3319.       return expr;
  3320.     }
  3321.  
  3322.   ffebld_set_info (expr, ffeinfo_new
  3323.            (bt,
  3324.             kt,
  3325.             0,
  3326.             FFEINFO_kindENTITY,
  3327.             FFEINFO_whereCONSTANT,
  3328.             FFETARGET_charactersizeNONE));
  3329.  
  3330.   if ((error != FFEBAD)
  3331.       && ffebad_start (error))
  3332.     {
  3333.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  3334.       ffebad_finish ();
  3335.     }
  3336.  
  3337.   return expr;
  3338. }
  3339.  
  3340. /* ffeexpr_collapse_not -- Collapse not expr
  3341.  
  3342.    ffebld expr;
  3343.    ffelexToken token;
  3344.    expr = ffeexpr_collapse_not(expr,token);
  3345.  
  3346.    If the result of the expr is a constant, replaces the expr with the
  3347.    computed constant.  */
  3348.  
  3349. ffebld
  3350. ffeexpr_collapse_not (ffebld expr, ffelexToken t)
  3351. {
  3352.   ffebad error = FFEBAD;
  3353.   ffebld r;
  3354.   ffebldConstantUnion u;
  3355.   ffeinfoBasictype bt;
  3356.   ffeinfoKindtype kt;
  3357.  
  3358.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  3359.     return expr;
  3360.  
  3361.   r = ffebld_left (expr);
  3362.  
  3363.   if (ffebld_op (r) != FFEBLD_opCONTER)
  3364.     return expr;
  3365.  
  3366.   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  3367.     {
  3368.     case FFEINFO_basictypeANY:
  3369.       return expr;
  3370.  
  3371.     case FFEINFO_basictypeINTEGER:
  3372.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3373.     {
  3374. #if FFETARGET_okINTEGER1
  3375.     case FFEINFO_kindtypeINTEGER1:
  3376.       error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
  3377.                   ffebld_constant_integer1 (ffebld_conter (r)));
  3378.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  3379.                     (ffebld_cu_val_integer1 (u)), expr);
  3380.       break;
  3381. #endif
  3382.  
  3383. #if FFETARGET_okINTEGER2
  3384.     case FFEINFO_kindtypeINTEGER2:
  3385.       error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
  3386.                   ffebld_constant_integer2 (ffebld_conter (r)));
  3387.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  3388.                     (ffebld_cu_val_integer2 (u)), expr);
  3389.       break;
  3390. #endif
  3391.  
  3392. #if FFETARGET_okINTEGER3
  3393.     case FFEINFO_kindtypeINTEGER3:
  3394.       error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
  3395.                   ffebld_constant_integer3 (ffebld_conter (r)));
  3396.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  3397.                     (ffebld_cu_val_integer3 (u)), expr);
  3398.       break;
  3399. #endif
  3400.  
  3401. #if FFETARGET_okINTEGER4
  3402.     case FFEINFO_kindtypeINTEGER4:
  3403.       error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
  3404.                   ffebld_constant_integer4 (ffebld_conter (r)));
  3405.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  3406.                     (ffebld_cu_val_integer4 (u)), expr);
  3407.       break;
  3408. #endif
  3409.  
  3410.     default:
  3411.       assert ("bad integer kind type" == NULL);
  3412.       break;
  3413.     }
  3414.       break;
  3415.  
  3416.     case FFEINFO_basictypeLOGICAL:
  3417.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3418.     {
  3419. #if FFETARGET_okLOGICAL1
  3420.     case FFEINFO_kindtypeLOGICAL1:
  3421.       error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
  3422.                   ffebld_constant_logical1 (ffebld_conter (r)));
  3423.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
  3424.                     (ffebld_cu_val_logical1 (u)), expr);
  3425.       break;
  3426. #endif
  3427.  
  3428. #if FFETARGET_okLOGICAL2
  3429.     case FFEINFO_kindtypeLOGICAL2:
  3430.       error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
  3431.                   ffebld_constant_logical2 (ffebld_conter (r)));
  3432.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
  3433.                     (ffebld_cu_val_logical2 (u)), expr);
  3434.       break;
  3435. #endif
  3436.  
  3437. #if FFETARGET_okLOGICAL3
  3438.     case FFEINFO_kindtypeLOGICAL3:
  3439.       error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
  3440.                   ffebld_constant_logical3 (ffebld_conter (r)));
  3441.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
  3442.                     (ffebld_cu_val_logical3 (u)), expr);
  3443.       break;
  3444. #endif
  3445.  
  3446. #if FFETARGET_okLOGICAL4
  3447.     case FFEINFO_kindtypeLOGICAL4:
  3448.       error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
  3449.                   ffebld_constant_logical4 (ffebld_conter (r)));
  3450.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
  3451.                     (ffebld_cu_val_logical4 (u)), expr);
  3452.       break;
  3453. #endif
  3454.  
  3455.     default:
  3456.       assert ("bad logical kind type" == NULL);
  3457.       break;
  3458.     }
  3459.       break;
  3460.  
  3461.     default:
  3462.       assert ("bad type" == NULL);
  3463.       return expr;
  3464.     }
  3465.  
  3466.   ffebld_set_info (expr, ffeinfo_new
  3467.            (bt,
  3468.             kt,
  3469.             0,
  3470.             FFEINFO_kindENTITY,
  3471.             FFEINFO_whereCONSTANT,
  3472.             FFETARGET_charactersizeNONE));
  3473.  
  3474.   if ((error != FFEBAD)
  3475.       && ffebad_start (error))
  3476.     {
  3477.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  3478.       ffebad_finish ();
  3479.     }
  3480.  
  3481.   return expr;
  3482. }
  3483.  
  3484. /* ffeexpr_collapse_add -- Collapse add expr
  3485.  
  3486.    ffebld expr;
  3487.    ffelexToken token;
  3488.    expr = ffeexpr_collapse_add(expr,token);
  3489.  
  3490.    If the result of the expr is a constant, replaces the expr with the
  3491.    computed constant.  */
  3492.  
  3493. ffebld
  3494. ffeexpr_collapse_add (ffebld expr, ffelexToken t)
  3495. {
  3496.   ffebad error = FFEBAD;
  3497.   ffebld l;
  3498.   ffebld r;
  3499.   ffebldConstantUnion u;
  3500.   ffeinfoBasictype bt;
  3501.   ffeinfoKindtype kt;
  3502.  
  3503.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  3504.     return expr;
  3505.  
  3506.   l = ffebld_left (expr);
  3507.   r = ffebld_right (expr);
  3508.  
  3509.   if (ffebld_op (l) != FFEBLD_opCONTER)
  3510.     return expr;
  3511.   if (ffebld_op (r) != FFEBLD_opCONTER)
  3512.     return expr;
  3513.  
  3514.   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  3515.     {
  3516.     case FFEINFO_basictypeANY:
  3517.       return expr;
  3518.  
  3519.     case FFEINFO_basictypeINTEGER:
  3520.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3521.     {
  3522. #if FFETARGET_okINTEGER1
  3523.     case FFEINFO_kindtypeINTEGER1:
  3524.       error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
  3525.                    ffebld_constant_integer1 (ffebld_conter (l)),
  3526.                   ffebld_constant_integer1 (ffebld_conter (r)));
  3527.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  3528.                     (ffebld_cu_val_integer1 (u)), expr);
  3529.       break;
  3530. #endif
  3531.  
  3532. #if FFETARGET_okINTEGER2
  3533.     case FFEINFO_kindtypeINTEGER2:
  3534.       error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
  3535.                    ffebld_constant_integer2 (ffebld_conter (l)),
  3536.                   ffebld_constant_integer2 (ffebld_conter (r)));
  3537.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  3538.                     (ffebld_cu_val_integer2 (u)), expr);
  3539.       break;
  3540. #endif
  3541.  
  3542. #if FFETARGET_okINTEGER3
  3543.     case FFEINFO_kindtypeINTEGER3:
  3544.       error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
  3545.                    ffebld_constant_integer3 (ffebld_conter (l)),
  3546.                   ffebld_constant_integer3 (ffebld_conter (r)));
  3547.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  3548.                     (ffebld_cu_val_integer3 (u)), expr);
  3549.       break;
  3550. #endif
  3551.  
  3552. #if FFETARGET_okINTEGER4
  3553.     case FFEINFO_kindtypeINTEGER4:
  3554.       error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
  3555.                    ffebld_constant_integer4 (ffebld_conter (l)),
  3556.                   ffebld_constant_integer4 (ffebld_conter (r)));
  3557.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  3558.                     (ffebld_cu_val_integer4 (u)), expr);
  3559.       break;
  3560. #endif
  3561.  
  3562.     default:
  3563.       assert ("bad integer kind type" == NULL);
  3564.       break;
  3565.     }
  3566.       break;
  3567.  
  3568.     case FFEINFO_basictypeREAL:
  3569.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3570.     {
  3571. #if FFETARGET_okREAL1
  3572.     case FFEINFO_kindtypeREAL1:
  3573.       error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
  3574.                   ffebld_constant_real1 (ffebld_conter (l)),
  3575.                  ffebld_constant_real1 (ffebld_conter (r)));
  3576.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
  3577.                        (ffebld_cu_val_real1 (u)), expr);
  3578.       break;
  3579. #endif
  3580.  
  3581. #if FFETARGET_okREAL2
  3582.     case FFEINFO_kindtypeREAL2:
  3583.       error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
  3584.                   ffebld_constant_real2 (ffebld_conter (l)),
  3585.                  ffebld_constant_real2 (ffebld_conter (r)));
  3586.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
  3587.                        (ffebld_cu_val_real2 (u)), expr);
  3588.       break;
  3589. #endif
  3590.  
  3591. #if FFETARGET_okREAL3
  3592.     case FFEINFO_kindtypeREAL3:
  3593.       error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
  3594.                   ffebld_constant_real3 (ffebld_conter (l)),
  3595.                  ffebld_constant_real3 (ffebld_conter (r)));
  3596.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
  3597.                        (ffebld_cu_val_real3 (u)), expr);
  3598.       break;
  3599. #endif
  3600.  
  3601. #if FFETARGET_okREAL4
  3602.     case FFEINFO_kindtypeREAL4:
  3603.       error = ffetarget_add_real4 (ffebld_cu_ptr_real4 (u),
  3604.                   ffebld_constant_real4 (ffebld_conter (l)),
  3605.                  ffebld_constant_real4 (ffebld_conter (r)));
  3606.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
  3607.                        (ffebld_cu_val_real4 (u)), expr);
  3608.       break;
  3609. #endif
  3610.  
  3611.     default:
  3612.       assert ("bad real kind type" == NULL);
  3613.       break;
  3614.     }
  3615.       break;
  3616.  
  3617.     case FFEINFO_basictypeCOMPLEX:
  3618.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3619.     {
  3620. #if FFETARGET_okCOMPLEX1
  3621.     case FFEINFO_kindtypeREAL1:
  3622.       error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
  3623.                    ffebld_constant_complex1 (ffebld_conter (l)),
  3624.                   ffebld_constant_complex1 (ffebld_conter (r)));
  3625.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
  3626.                     (ffebld_cu_val_complex1 (u)), expr);
  3627.       break;
  3628. #endif
  3629.  
  3630. #if FFETARGET_okCOMPLEX2
  3631.     case FFEINFO_kindtypeREAL2:
  3632.       error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
  3633.                    ffebld_constant_complex2 (ffebld_conter (l)),
  3634.                   ffebld_constant_complex2 (ffebld_conter (r)));
  3635.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
  3636.                     (ffebld_cu_val_complex2 (u)), expr);
  3637.       break;
  3638. #endif
  3639.  
  3640. #if FFETARGET_okCOMPLEX3
  3641.     case FFEINFO_kindtypeREAL3:
  3642.       error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
  3643.                    ffebld_constant_complex3 (ffebld_conter (l)),
  3644.                   ffebld_constant_complex3 (ffebld_conter (r)));
  3645.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
  3646.                     (ffebld_cu_val_complex3 (u)), expr);
  3647.       break;
  3648. #endif
  3649.  
  3650. #if FFETARGET_okCOMPLEX4
  3651.     case FFEINFO_kindtypeREAL4:
  3652.       error = ffetarget_add_complex4 (ffebld_cu_ptr_complex4 (u),
  3653.                    ffebld_constant_complex4 (ffebld_conter (l)),
  3654.                   ffebld_constant_complex4 (ffebld_conter (r)));
  3655.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
  3656.                     (ffebld_cu_val_complex4 (u)), expr);
  3657.       break;
  3658. #endif
  3659.  
  3660.     default:
  3661.       assert ("bad complex kind type" == NULL);
  3662.       break;
  3663.     }
  3664.       break;
  3665.  
  3666.     default:
  3667.       assert ("bad type" == NULL);
  3668.       return expr;
  3669.     }
  3670.  
  3671.   ffebld_set_info (expr, ffeinfo_new
  3672.            (bt,
  3673.             kt,
  3674.             0,
  3675.             FFEINFO_kindENTITY,
  3676.             FFEINFO_whereCONSTANT,
  3677.             FFETARGET_charactersizeNONE));
  3678.  
  3679.   if ((error != FFEBAD)
  3680.       && ffebad_start (error))
  3681.     {
  3682.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  3683.       ffebad_finish ();
  3684.     }
  3685.  
  3686.   return expr;
  3687. }
  3688.  
  3689. /* ffeexpr_collapse_subtract -- Collapse subtract expr
  3690.  
  3691.    ffebld expr;
  3692.    ffelexToken token;
  3693.    expr = ffeexpr_collapse_subtract(expr,token);
  3694.  
  3695.    If the result of the expr is a constant, replaces the expr with the
  3696.    computed constant.  */
  3697.  
  3698. ffebld
  3699. ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
  3700. {
  3701.   ffebad error = FFEBAD;
  3702.   ffebld l;
  3703.   ffebld r;
  3704.   ffebldConstantUnion u;
  3705.   ffeinfoBasictype bt;
  3706.   ffeinfoKindtype kt;
  3707.  
  3708.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  3709.     return expr;
  3710.  
  3711.   l = ffebld_left (expr);
  3712.   r = ffebld_right (expr);
  3713.  
  3714.   if (ffebld_op (l) != FFEBLD_opCONTER)
  3715.     return expr;
  3716.   if (ffebld_op (r) != FFEBLD_opCONTER)
  3717.     return expr;
  3718.  
  3719.   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  3720.     {
  3721.     case FFEINFO_basictypeANY:
  3722.       return expr;
  3723.  
  3724.     case FFEINFO_basictypeINTEGER:
  3725.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3726.     {
  3727. #if FFETARGET_okINTEGER1
  3728.     case FFEINFO_kindtypeINTEGER1:
  3729.       error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
  3730.                    ffebld_constant_integer1 (ffebld_conter (l)),
  3731.                   ffebld_constant_integer1 (ffebld_conter (r)));
  3732.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  3733.                     (ffebld_cu_val_integer1 (u)), expr);
  3734.       break;
  3735. #endif
  3736.  
  3737. #if FFETARGET_okINTEGER2
  3738.     case FFEINFO_kindtypeINTEGER2:
  3739.       error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
  3740.                    ffebld_constant_integer2 (ffebld_conter (l)),
  3741.                   ffebld_constant_integer2 (ffebld_conter (r)));
  3742.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  3743.                     (ffebld_cu_val_integer2 (u)), expr);
  3744.       break;
  3745. #endif
  3746.  
  3747. #if FFETARGET_okINTEGER3
  3748.     case FFEINFO_kindtypeINTEGER3:
  3749.       error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
  3750.                    ffebld_constant_integer3 (ffebld_conter (l)),
  3751.                   ffebld_constant_integer3 (ffebld_conter (r)));
  3752.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  3753.                     (ffebld_cu_val_integer3 (u)), expr);
  3754.       break;
  3755. #endif
  3756.  
  3757. #if FFETARGET_okINTEGER4
  3758.     case FFEINFO_kindtypeINTEGER4:
  3759.       error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
  3760.                    ffebld_constant_integer4 (ffebld_conter (l)),
  3761.                   ffebld_constant_integer4 (ffebld_conter (r)));
  3762.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  3763.                     (ffebld_cu_val_integer4 (u)), expr);
  3764.       break;
  3765. #endif
  3766.  
  3767.     default:
  3768.       assert ("bad integer kind type" == NULL);
  3769.       break;
  3770.     }
  3771.       break;
  3772.  
  3773.     case FFEINFO_basictypeREAL:
  3774.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3775.     {
  3776. #if FFETARGET_okREAL1
  3777.     case FFEINFO_kindtypeREAL1:
  3778.       error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
  3779.                   ffebld_constant_real1 (ffebld_conter (l)),
  3780.                  ffebld_constant_real1 (ffebld_conter (r)));
  3781.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
  3782.                        (ffebld_cu_val_real1 (u)), expr);
  3783.       break;
  3784. #endif
  3785.  
  3786. #if FFETARGET_okREAL2
  3787.     case FFEINFO_kindtypeREAL2:
  3788.       error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
  3789.                   ffebld_constant_real2 (ffebld_conter (l)),
  3790.                  ffebld_constant_real2 (ffebld_conter (r)));
  3791.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
  3792.                        (ffebld_cu_val_real2 (u)), expr);
  3793.       break;
  3794. #endif
  3795.  
  3796. #if FFETARGET_okREAL3
  3797.     case FFEINFO_kindtypeREAL3:
  3798.       error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
  3799.                   ffebld_constant_real3 (ffebld_conter (l)),
  3800.                  ffebld_constant_real3 (ffebld_conter (r)));
  3801.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
  3802.                        (ffebld_cu_val_real3 (u)), expr);
  3803.       break;
  3804. #endif
  3805.  
  3806. #if FFETARGET_okREAL4
  3807.     case FFEINFO_kindtypeREAL4:
  3808.       error = ffetarget_subtract_real4 (ffebld_cu_ptr_real4 (u),
  3809.                   ffebld_constant_real4 (ffebld_conter (l)),
  3810.                  ffebld_constant_real4 (ffebld_conter (r)));
  3811.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
  3812.                        (ffebld_cu_val_real4 (u)), expr);
  3813.       break;
  3814. #endif
  3815.  
  3816.     default:
  3817.       assert ("bad real kind type" == NULL);
  3818.       break;
  3819.     }
  3820.       break;
  3821.  
  3822.     case FFEINFO_basictypeCOMPLEX:
  3823.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3824.     {
  3825. #if FFETARGET_okCOMPLEX1
  3826.     case FFEINFO_kindtypeREAL1:
  3827.       error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
  3828.                    ffebld_constant_complex1 (ffebld_conter (l)),
  3829.                   ffebld_constant_complex1 (ffebld_conter (r)));
  3830.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
  3831.                     (ffebld_cu_val_complex1 (u)), expr);
  3832.       break;
  3833. #endif
  3834.  
  3835. #if FFETARGET_okCOMPLEX2
  3836.     case FFEINFO_kindtypeREAL2:
  3837.       error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
  3838.                    ffebld_constant_complex2 (ffebld_conter (l)),
  3839.                   ffebld_constant_complex2 (ffebld_conter (r)));
  3840.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
  3841.                     (ffebld_cu_val_complex2 (u)), expr);
  3842.       break;
  3843. #endif
  3844.  
  3845. #if FFETARGET_okCOMPLEX3
  3846.     case FFEINFO_kindtypeREAL3:
  3847.       error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
  3848.                    ffebld_constant_complex3 (ffebld_conter (l)),
  3849.                   ffebld_constant_complex3 (ffebld_conter (r)));
  3850.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
  3851.                     (ffebld_cu_val_complex3 (u)), expr);
  3852.       break;
  3853. #endif
  3854.  
  3855. #if FFETARGET_okCOMPLEX4
  3856.     case FFEINFO_kindtypeREAL4:
  3857.       error = ffetarget_subtract_complex4 (ffebld_cu_ptr_complex4 (u),
  3858.                    ffebld_constant_complex4 (ffebld_conter (l)),
  3859.                   ffebld_constant_complex4 (ffebld_conter (r)));
  3860.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
  3861.                     (ffebld_cu_val_complex4 (u)), expr);
  3862.       break;
  3863. #endif
  3864.  
  3865.     default:
  3866.       assert ("bad complex kind type" == NULL);
  3867.       break;
  3868.     }
  3869.       break;
  3870.  
  3871.     default:
  3872.       assert ("bad type" == NULL);
  3873.       return expr;
  3874.     }
  3875.  
  3876.   ffebld_set_info (expr, ffeinfo_new
  3877.            (bt,
  3878.             kt,
  3879.             0,
  3880.             FFEINFO_kindENTITY,
  3881.             FFEINFO_whereCONSTANT,
  3882.             FFETARGET_charactersizeNONE));
  3883.  
  3884.   if ((error != FFEBAD)
  3885.       && ffebad_start (error))
  3886.     {
  3887.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  3888.       ffebad_finish ();
  3889.     }
  3890.  
  3891.   return expr;
  3892. }
  3893.  
  3894. /* ffeexpr_collapse_multiply -- Collapse multiply expr
  3895.  
  3896.    ffebld expr;
  3897.    ffelexToken token;
  3898.    expr = ffeexpr_collapse_multiply(expr,token);
  3899.  
  3900.    If the result of the expr is a constant, replaces the expr with the
  3901.    computed constant.  */
  3902.  
  3903. ffebld
  3904. ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
  3905. {
  3906.   ffebad error = FFEBAD;
  3907.   ffebld l;
  3908.   ffebld r;
  3909.   ffebldConstantUnion u;
  3910.   ffeinfoBasictype bt;
  3911.   ffeinfoKindtype kt;
  3912.  
  3913.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  3914.     return expr;
  3915.  
  3916.   l = ffebld_left (expr);
  3917.   r = ffebld_right (expr);
  3918.  
  3919.   if (ffebld_op (l) != FFEBLD_opCONTER)
  3920.     return expr;
  3921.   if (ffebld_op (r) != FFEBLD_opCONTER)
  3922.     return expr;
  3923.  
  3924.   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  3925.     {
  3926.     case FFEINFO_basictypeANY:
  3927.       return expr;
  3928.  
  3929.     case FFEINFO_basictypeINTEGER:
  3930.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3931.     {
  3932. #if FFETARGET_okINTEGER1
  3933.     case FFEINFO_kindtypeINTEGER1:
  3934.       error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
  3935.                    ffebld_constant_integer1 (ffebld_conter (l)),
  3936.                   ffebld_constant_integer1 (ffebld_conter (r)));
  3937.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  3938.                     (ffebld_cu_val_integer1 (u)), expr);
  3939.       break;
  3940. #endif
  3941.  
  3942. #if FFETARGET_okINTEGER2
  3943.     case FFEINFO_kindtypeINTEGER2:
  3944.       error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
  3945.                    ffebld_constant_integer2 (ffebld_conter (l)),
  3946.                   ffebld_constant_integer2 (ffebld_conter (r)));
  3947.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  3948.                     (ffebld_cu_val_integer2 (u)), expr);
  3949.       break;
  3950. #endif
  3951.  
  3952. #if FFETARGET_okINTEGER3
  3953.     case FFEINFO_kindtypeINTEGER3:
  3954.       error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
  3955.                    ffebld_constant_integer3 (ffebld_conter (l)),
  3956.                   ffebld_constant_integer3 (ffebld_conter (r)));
  3957.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  3958.                     (ffebld_cu_val_integer3 (u)), expr);
  3959.       break;
  3960. #endif
  3961.  
  3962. #if FFETARGET_okINTEGER4
  3963.     case FFEINFO_kindtypeINTEGER4:
  3964.       error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
  3965.                    ffebld_constant_integer4 (ffebld_conter (l)),
  3966.                   ffebld_constant_integer4 (ffebld_conter (r)));
  3967.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  3968.                     (ffebld_cu_val_integer4 (u)), expr);
  3969.       break;
  3970. #endif
  3971.  
  3972.     default:
  3973.       assert ("bad integer kind type" == NULL);
  3974.       break;
  3975.     }
  3976.       break;
  3977.  
  3978.     case FFEINFO_basictypeREAL:
  3979.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3980.     {
  3981. #if FFETARGET_okREAL1
  3982.     case FFEINFO_kindtypeREAL1:
  3983.       error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
  3984.                   ffebld_constant_real1 (ffebld_conter (l)),
  3985.                  ffebld_constant_real1 (ffebld_conter (r)));
  3986.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
  3987.                        (ffebld_cu_val_real1 (u)), expr);
  3988.       break;
  3989. #endif
  3990.  
  3991. #if FFETARGET_okREAL2
  3992.     case FFEINFO_kindtypeREAL2:
  3993.       error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
  3994.                   ffebld_constant_real2 (ffebld_conter (l)),
  3995.                  ffebld_constant_real2 (ffebld_conter (r)));
  3996.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
  3997.                        (ffebld_cu_val_real2 (u)), expr);
  3998.       break;
  3999. #endif
  4000.  
  4001. #if FFETARGET_okREAL3
  4002.     case FFEINFO_kindtypeREAL3:
  4003.       error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
  4004.                   ffebld_constant_real3 (ffebld_conter (l)),
  4005.                  ffebld_constant_real3 (ffebld_conter (r)));
  4006.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
  4007.                        (ffebld_cu_val_real3 (u)), expr);
  4008.       break;
  4009. #endif
  4010.  
  4011. #if FFETARGET_okREAL4
  4012.     case FFEINFO_kindtypeREAL4:
  4013.       error = ffetarget_multiply_real4 (ffebld_cu_ptr_real4 (u),
  4014.                   ffebld_constant_real4 (ffebld_conter (l)),
  4015.                  ffebld_constant_real4 (ffebld_conter (r)));
  4016.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
  4017.                        (ffebld_cu_val_real4 (u)), expr);
  4018.       break;
  4019. #endif
  4020.  
  4021.     default:
  4022.       assert ("bad real kind type" == NULL);
  4023.       break;
  4024.     }
  4025.       break;
  4026.  
  4027.     case FFEINFO_basictypeCOMPLEX:
  4028.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  4029.     {
  4030. #if FFETARGET_okCOMPLEX1
  4031.     case FFEINFO_kindtypeREAL1:
  4032.       error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
  4033.                    ffebld_constant_complex1 (ffebld_conter (l)),
  4034.                   ffebld_constant_complex1 (ffebld_conter (r)));
  4035.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
  4036.                     (ffebld_cu_val_complex1 (u)), expr);
  4037.       break;
  4038. #endif
  4039.  
  4040. #if FFETARGET_okCOMPLEX2
  4041.     case FFEINFO_kindtypeREAL2:
  4042.       error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
  4043.                    ffebld_constant_complex2 (ffebld_conter (l)),
  4044.                   ffebld_constant_complex2 (ffebld_conter (r)));
  4045.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
  4046.                     (ffebld_cu_val_complex2 (u)), expr);
  4047.       break;
  4048. #endif
  4049.  
  4050. #if FFETARGET_okCOMPLEX3
  4051.     case FFEINFO_kindtypeREAL3:
  4052.       error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
  4053.                    ffebld_constant_complex3 (ffebld_conter (l)),
  4054.                   ffebld_constant_complex3 (ffebld_conter (r)));
  4055.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
  4056.                     (ffebld_cu_val_complex3 (u)), expr);
  4057.       break;
  4058. #endif
  4059.  
  4060. #if FFETARGET_okCOMPLEX4
  4061.     case FFEINFO_kindtypeREAL4:
  4062.       error = ffetarget_multiply_complex4 (ffebld_cu_ptr_complex4 (u),
  4063.                    ffebld_constant_complex4 (ffebld_conter (l)),
  4064.                   ffebld_constant_complex4 (ffebld_conter (r)));
  4065.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
  4066.                     (ffebld_cu_val_complex4 (u)), expr);
  4067.       break;
  4068. #endif
  4069.  
  4070.     default:
  4071.       assert ("bad complex kind type" == NULL);
  4072.       break;
  4073.     }
  4074.       break;
  4075.  
  4076.     default:
  4077.       assert ("bad type" == NULL);
  4078.       return expr;
  4079.     }
  4080.  
  4081.   ffebld_set_info (expr, ffeinfo_new
  4082.            (bt,
  4083.             kt,
  4084.             0,
  4085.             FFEINFO_kindENTITY,
  4086.             FFEINFO_whereCONSTANT,
  4087.             FFETARGET_charactersizeNONE));
  4088.  
  4089.   if ((error != FFEBAD)
  4090.       && ffebad_start (error))
  4091.     {
  4092.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  4093.       ffebad_finish ();
  4094.     }
  4095.  
  4096.   return expr;
  4097. }
  4098.  
  4099. /* ffeexpr_collapse_divide -- Collapse divide expr
  4100.  
  4101.    ffebld expr;
  4102.    ffelexToken token;
  4103.    expr = ffeexpr_collapse_divide(expr,token);
  4104.  
  4105.    If the result of the expr is a constant, replaces the expr with the
  4106.    computed constant.  */
  4107.  
  4108. ffebld
  4109. ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
  4110. {
  4111.   ffebad error = FFEBAD;
  4112.   ffebld l;
  4113.   ffebld r;
  4114.   ffebldConstantUnion u;
  4115.   ffeinfoBasictype bt;
  4116.   ffeinfoKindtype kt;
  4117.  
  4118.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  4119.     return expr;
  4120.  
  4121.   l = ffebld_left (expr);
  4122.   r = ffebld_right (expr);
  4123.  
  4124.   if (ffebld_op (l) != FFEBLD_opCONTER)
  4125.     return expr;
  4126.   if (ffebld_op (r) != FFEBLD_opCONTER)
  4127.     return expr;
  4128.  
  4129.   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  4130.     {
  4131.     case FFEINFO_basictypeANY:
  4132.       return expr;
  4133.  
  4134.     case FFEINFO_basictypeINTEGER:
  4135.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  4136.     {
  4137. #if FFETARGET_okINTEGER1
  4138.     case FFEINFO_kindtypeINTEGER1:
  4139.       error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
  4140.                    ffebld_constant_integer1 (ffebld_conter (l)),
  4141.                   ffebld_constant_integer1 (ffebld_conter (r)));
  4142.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  4143.                     (ffebld_cu_val_integer1 (u)), expr);
  4144.       break;
  4145. #endif
  4146.  
  4147. #if FFETARGET_okINTEGER2
  4148.     case FFEINFO_kindtypeINTEGER2:
  4149.       error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
  4150.                    ffebld_constant_integer2 (ffebld_conter (l)),
  4151.                   ffebld_constant_integer2 (ffebld_conter (r)));
  4152.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  4153.                     (ffebld_cu_val_integer2 (u)), expr);
  4154.       break;
  4155. #endif
  4156.  
  4157. #if FFETARGET_okINTEGER3
  4158.     case FFEINFO_kindtypeINTEGER3:
  4159.       error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
  4160.                    ffebld_constant_integer3 (ffebld_conter (l)),
  4161.                   ffebld_constant_integer3 (ffebld_conter (r)));
  4162.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  4163.                     (ffebld_cu_val_integer3 (u)), expr);
  4164.       break;
  4165. #endif
  4166.  
  4167. #if FFETARGET_okINTEGER4
  4168.     case FFEINFO_kindtypeINTEGER4:
  4169.       error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
  4170.                    ffebld_constant_integer4 (ffebld_conter (l)),
  4171.                   ffebld_constant_integer4 (ffebld_conter (r)));
  4172.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  4173.                     (ffebld_cu_val_integer4 (u)), expr);
  4174.       break;
  4175. #endif
  4176.  
  4177.     default:
  4178.       assert ("bad integer kind type" == NULL);
  4179.       break;
  4180.     }
  4181.       break;
  4182.  
  4183.     case FFEINFO_basictypeREAL:
  4184.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  4185.     {
  4186. #if FFETARGET_okREAL1
  4187.     case FFEINFO_kindtypeREAL1:
  4188.       error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
  4189.                   ffebld_constant_real1 (ffebld_conter (l)),
  4190.                  ffebld_constant_real1 (ffebld_conter (r)));
  4191.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
  4192.                        (ffebld_cu_val_real1 (u)), expr);
  4193.       break;
  4194. #endif
  4195.  
  4196. #if FFETARGET_okREAL2
  4197.     case FFEINFO_kindtypeREAL2:
  4198.       error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
  4199.                   ffebld_constant_real2 (ffebld_conter (l)),
  4200.                  ffebld_constant_real2 (ffebld_conter (r)));
  4201.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
  4202.                        (ffebld_cu_val_real2 (u)), expr);
  4203.       break;
  4204. #endif
  4205.  
  4206. #if FFETARGET_okREAL3
  4207.     case FFEINFO_kindtypeREAL3:
  4208.       error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
  4209.                   ffebld_constant_real3 (ffebld_conter (l)),
  4210.                  ffebld_constant_real3 (ffebld_conter (r)));
  4211.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
  4212.                        (ffebld_cu_val_real3 (u)), expr);
  4213.       break;
  4214. #endif
  4215.  
  4216. #if FFETARGET_okREAL4
  4217.     case FFEINFO_kindtypeREAL4:
  4218.       error = ffetarget_divide_real4 (ffebld_cu_ptr_real4 (u),
  4219.                   ffebld_constant_real4 (ffebld_conter (l)),
  4220.                  ffebld_constant_real4 (ffebld_conter (r)));
  4221.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
  4222.                        (ffebld_cu_val_real4 (u)), expr);
  4223.       break;
  4224. #endif
  4225.  
  4226.     default:
  4227.       assert ("bad real kind type" == NULL);
  4228.       break;
  4229.     }
  4230.       break;
  4231.  
  4232.     case FFEINFO_basictypeCOMPLEX:
  4233.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  4234.     {
  4235. #if FFETARGET_okCOMPLEX1
  4236.     case FFEINFO_kindtypeREAL1:
  4237.       error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
  4238.                    ffebld_constant_complex1 (ffebld_conter (l)),
  4239.                   ffebld_constant_complex1 (ffebld_conter (r)));
  4240.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
  4241.                     (ffebld_cu_val_complex1 (u)), expr);
  4242.       break;
  4243. #endif
  4244.  
  4245. #if FFETARGET_okCOMPLEX2
  4246.     case FFEINFO_kindtypeREAL2:
  4247.       error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
  4248.                    ffebld_constant_complex2 (ffebld_conter (l)),
  4249.                   ffebld_constant_complex2 (ffebld_conter (r)));
  4250.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
  4251.                     (ffebld_cu_val_complex2 (u)), expr);
  4252.       break;
  4253. #endif
  4254.  
  4255. #if FFETARGET_okCOMPLEX3
  4256.     case FFEINFO_kindtypeREAL3:
  4257.       error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
  4258.                    ffebld_constant_complex3 (ffebld_conter (l)),
  4259.                   ffebld_constant_complex3 (ffebld_conter (r)));
  4260.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
  4261.                     (ffebld_cu_val_complex3 (u)), expr);
  4262.       break;
  4263. #endif
  4264.  
  4265. #if FFETARGET_okCOMPLEX4
  4266.     case FFEINFO_kindtypeREAL4:
  4267.       error = ffetarget_divide_complex4 (ffebld_cu_ptr_complex4 (u),
  4268.                    ffebld_constant_complex4 (ffebld_conter (l)),
  4269.                   ffebld_constant_complex4 (ffebld_conter (r)));
  4270.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
  4271.                     (ffebld_cu_val_complex4 (u)), expr);
  4272.       break;
  4273. #endif
  4274.  
  4275.     default:
  4276.       assert ("bad complex kind type" == NULL);
  4277.       break;
  4278.     }
  4279.       break;
  4280.  
  4281.     default:
  4282.       assert ("bad type" == NULL);
  4283.       return expr;
  4284.     }
  4285.  
  4286.   ffebld_set_info (expr, ffeinfo_new
  4287.            (bt,
  4288.             kt,
  4289.             0,
  4290.             FFEINFO_kindENTITY,
  4291.             FFEINFO_whereCONSTANT,
  4292.             FFETARGET_charactersizeNONE));
  4293.  
  4294.   if ((error != FFEBAD)
  4295.       && ffebad_start (error))
  4296.     {
  4297.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  4298.       ffebad_finish ();
  4299.     }
  4300.  
  4301.   return expr;
  4302. }
  4303.  
  4304. /* ffeexpr_collapse_power -- Collapse power expr
  4305.  
  4306.    ffebld expr;
  4307.    ffelexToken token;
  4308.    expr = ffeexpr_collapse_power(expr,token);
  4309.  
  4310.    If the result of the expr is a constant, replaces the expr with the
  4311.    computed constant.  */
  4312.  
  4313. ffebld
  4314. ffeexpr_collapse_power (ffebld expr, ffelexToken t)
  4315. {
  4316.   ffebad error = FFEBAD;
  4317.   ffebld l;
  4318.   ffebld r;
  4319.   ffebldConstantUnion u;
  4320.   ffeinfoBasictype bt;
  4321.   ffeinfoKindtype kt;
  4322.  
  4323.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  4324.     return expr;
  4325.  
  4326.   l = ffebld_left (expr);
  4327.   r = ffebld_right (expr);
  4328.  
  4329.   if (ffebld_op (l) != FFEBLD_opCONTER)
  4330.     return expr;
  4331.   if (ffebld_op (r) != FFEBLD_opCONTER)
  4332.     return expr;
  4333.  
  4334.   if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
  4335.   || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
  4336.     return expr;
  4337.  
  4338.   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  4339.     {
  4340.     case FFEINFO_basictypeANY:
  4341.       return expr;
  4342.  
  4343.     case FFEINFO_basictypeINTEGER:
  4344.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  4345.     {
  4346.     case FFEINFO_kindtypeINTEGERDEFAULT:
  4347.       error = ffetarget_power_integerdefault_integerdefault
  4348.         (ffebld_cu_ptr_integerdefault (u),
  4349.          ffebld_constant_integerdefault (ffebld_conter (l)),
  4350.          ffebld_constant_integerdefault (ffebld_conter (r)));
  4351.       expr = ffebld_new_conter_with_orig
  4352.         (ffebld_constant_new_integerdefault_val
  4353.          (ffebld_cu_val_integerdefault (u)), expr);
  4354.       break;
  4355.  
  4356.     default:
  4357.       assert ("bad integer kind type" == NULL);
  4358.       break;
  4359.     }
  4360.       break;
  4361.  
  4362.     case FFEINFO_basictypeREAL:
  4363.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  4364.     {
  4365.     case FFEINFO_kindtypeREALDEFAULT:
  4366.       error = ffetarget_power_realdefault_integerdefault
  4367.         (ffebld_cu_ptr_realdefault (u),
  4368.          ffebld_constant_realdefault (ffebld_conter (l)),
  4369.          ffebld_constant_integerdefault (ffebld_conter (r)));
  4370.       expr = ffebld_new_conter_with_orig
  4371.         (ffebld_constant_new_realdefault_val
  4372.          (ffebld_cu_val_realdefault (u)), expr);
  4373.       break;
  4374.  
  4375.     case FFEINFO_kindtypeREALDOUBLE:
  4376.       error = ffetarget_power_realdouble_integerdefault
  4377.         (ffebld_cu_ptr_realdouble (u),
  4378.          ffebld_constant_realdouble (ffebld_conter (l)),
  4379.          ffebld_constant_integerdefault (ffebld_conter (r)));
  4380.       expr = ffebld_new_conter_with_orig
  4381.         (ffebld_constant_new_realdouble_val
  4382.          (ffebld_cu_val_realdouble (u)), expr);
  4383.       break;
  4384.  
  4385. #if FFETARGET_okREALQUAD
  4386.     case FFEINFO_kindtypeREALQUAD:
  4387.       error = ffetarget_power_realquad_integerdefault
  4388.         (ffebld_cu_ptr_realquad (u),
  4389.          ffebld_constant_realquad (ffebld_conter (l)),
  4390.          ffebld_constant_integerdefault (ffebld_conter (r)));
  4391.       expr = ffebld_new_conter_with_orig
  4392.         (ffebld_constant_new_realquad_val
  4393.          (ffebld_cu_val_realquad (u)), expr);
  4394.       break;
  4395. #endif
  4396.     default:
  4397.       assert ("bad real kind type" == NULL);
  4398.       break;
  4399.     }
  4400.       break;
  4401.  
  4402.     case FFEINFO_basictypeCOMPLEX:
  4403.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  4404.     {
  4405.     case FFEINFO_kindtypeREALDEFAULT:
  4406.       error = ffetarget_power_complexdefault_integerdefault
  4407.         (ffebld_cu_ptr_complexdefault (u),
  4408.          ffebld_constant_complexdefault (ffebld_conter (l)),
  4409.          ffebld_constant_integerdefault (ffebld_conter (r)));
  4410.       expr = ffebld_new_conter_with_orig
  4411.         (ffebld_constant_new_complexdefault_val
  4412.          (ffebld_cu_val_complexdefault (u)), expr);
  4413.       break;
  4414.  
  4415. #if FFETARGET_okCOMPLEXDOUBLE
  4416.     case FFEINFO_kindtypeREALDOUBLE:
  4417.       error = ffetarget_power_complexdouble_integerdefault
  4418.         (ffebld_cu_ptr_complexdouble (u),
  4419.          ffebld_constant_complexdouble (ffebld_conter (l)),
  4420.          ffebld_constant_integerdefault (ffebld_conter (r)));
  4421.       expr = ffebld_new_conter_with_orig
  4422.         (ffebld_constant_new_complexdouble_val
  4423.          (ffebld_cu_val_complexdouble (u)), expr);
  4424.       break;
  4425. #endif
  4426.  
  4427. #if FFETARGET_okCOMPLEXQUAD
  4428.     case FFEINFO_kindtypeREALQUAD:
  4429.       error = ffetarget_power_complexquad_integerdefault
  4430.         (ffebld_cu_ptr_complexquad (u),
  4431.          ffebld_constant_complexquad (ffebld_conter (l)),
  4432.          ffebld_constant_integerdefault (ffebld_conter (r)));
  4433.       expr = ffebld_new_conter_with_orig
  4434.         (ffebld_constant_new_complexquad_val
  4435.          (ffebld_cu_val_complexquad (u)), expr);
  4436.       break;
  4437. #endif
  4438.  
  4439.     default:
  4440.       assert ("bad complex kind type" == NULL);
  4441.       break;
  4442.     }
  4443.       break;
  4444.  
  4445.     default:
  4446.       assert ("bad type" == NULL);
  4447.       return expr;
  4448.     }
  4449.  
  4450.   ffebld_set_info (expr, ffeinfo_new
  4451.            (bt,
  4452.             kt,
  4453.             0,
  4454.             FFEINFO_kindENTITY,
  4455.             FFEINFO_whereCONSTANT,
  4456.             FFETARGET_charactersizeNONE));
  4457.  
  4458.   if ((error != FFEBAD)
  4459.       && ffebad_start (error))
  4460.     {
  4461.       ffebad_here (0, ffelex_token_where_line (t),
  4462.            ffelex_token_where_column (t));
  4463.       ffebad_finish ();
  4464.     }
  4465.  
  4466.   return expr;
  4467. }
  4468.  
  4469. /* ffeexpr_collapse_concatenate -- Collapse concatenate expr
  4470.  
  4471.    ffebld expr;
  4472.    ffelexToken token;
  4473.    expr = ffeexpr_collapse_concatenate(expr,token);
  4474.  
  4475.    If the result of the expr is a constant, replaces the expr with the
  4476.    computed constant.  */
  4477.  
  4478. ffebld
  4479. ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
  4480. {
  4481.   ffebad error = FFEBAD;
  4482.   ffebld l;
  4483.   ffebld r;
  4484.   ffebldConstantUnion u;
  4485.   ffeinfoKindtype kt;
  4486.   ffetargetCharacterSize len;
  4487.  
  4488.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  4489.     return expr;
  4490.  
  4491.   l = ffebld_left (expr);
  4492.   r = ffebld_right (expr);
  4493.  
  4494.   if (ffebld_op (l) != FFEBLD_opCONTER)
  4495.     return expr;
  4496.   if (ffebld_op (r) != FFEBLD_opCONTER)
  4497.     return expr;
  4498.  
  4499.   switch (ffeinfo_basictype (ffebld_info (expr)))
  4500.     {
  4501.     case FFEINFO_basictypeANY:
  4502.       return expr;
  4503.  
  4504.     case FFEINFO_basictypeCHARACTER:
  4505.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  4506.     {
  4507. #if FFETARGET_okCHARACTER1
  4508.     case FFEINFO_kindtypeCHARACTER1:
  4509.       error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
  4510.                  ffebld_constant_character1 (ffebld_conter (l)),
  4511.                  ffebld_constant_character1 (ffebld_conter (r)),
  4512.                    ffebld_constant_character_pool (), &len);
  4513.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
  4514.                       (ffebld_cu_val_character1 (u)), expr);
  4515.       break;
  4516. #endif
  4517.  
  4518. #if FFETARGET_okCHARACTER2
  4519.     case FFEINFO_kindtypeCHARACTER2:
  4520.       error = ffetarget_concatenate_character2 (ffebld_cu_ptr_character2 (u),
  4521.                  ffebld_constant_character2 (ffebld_conter (l)),
  4522.                  ffebld_constant_character2 (ffebld_conter (r)),
  4523.                    ffebld_constant_character_pool (), &len);
  4524.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
  4525.                       (ffebld_cu_val_character2 (u)), expr);
  4526.       break;
  4527. #endif
  4528.  
  4529. #if FFETARGET_okCHARACTER3
  4530.     case FFEINFO_kindtypeCHARACTER3:
  4531.       error = ffetarget_concatenate_character3 (ffebld_cu_ptr_character3 (u),
  4532.                  ffebld_constant_character3 (ffebld_conter (l)),
  4533.                  ffebld_constant_character3 (ffebld_conter (r)),
  4534.                    ffebld_constant_character_pool (), &len);
  4535.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
  4536.                       (ffebld_cu_val_character3 (u)), expr);
  4537.       break;
  4538. #endif
  4539.  
  4540. #if FFETARGET_okCHARACTER4
  4541.     case FFEINFO_kindtypeCHARACTER4:
  4542.       error = ffetarget_concatenate_character4 (ffebld_cu_ptr_character4 (u),
  4543.                  ffebld_constant_character4 (ffebld_conter (l)),
  4544.                  ffebld_constant_character4 (ffebld_conter (r)),
  4545.                    ffebld_constant_character_pool (), &len);
  4546.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
  4547.                       (ffebld_cu_val_character4 (u)), expr);
  4548.       break;
  4549. #endif
  4550.  
  4551.     default:
  4552.       assert ("bad character kind type" == NULL);
  4553.       break;
  4554.     }
  4555.       break;
  4556.  
  4557.     default:
  4558.       assert ("bad type" == NULL);
  4559.       return expr;
  4560.     }
  4561.  
  4562.   ffebld_set_info (expr, ffeinfo_new
  4563.            (FFEINFO_basictypeCHARACTER,
  4564.             kt,
  4565.             0,
  4566.             FFEINFO_kindENTITY,
  4567.             FFEINFO_whereCONSTANT,
  4568.             len));
  4569.  
  4570.   if ((error != FFEBAD)
  4571.       && ffebad_start (error))
  4572.     {
  4573.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  4574.       ffebad_finish ();
  4575.     }
  4576.  
  4577.   return expr;
  4578. }
  4579.  
  4580. /* ffeexpr_collapse_eq -- Collapse eq expr
  4581.  
  4582.    ffebld expr;
  4583.    ffelexToken token;
  4584.    expr = ffeexpr_collapse_eq(expr,token);
  4585.  
  4586.    If the result of the expr is a constant, replaces the expr with the
  4587.    computed constant.  */
  4588.  
  4589. ffebld
  4590. ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
  4591. {
  4592.   ffebad error = FFEBAD;
  4593.   ffebld l;
  4594.   ffebld r;
  4595.   bool val;
  4596.  
  4597.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  4598.     return expr;
  4599.  
  4600.   l = ffebld_left (expr);
  4601.   r = ffebld_right (expr);
  4602.  
  4603.   if (ffebld_op (l) != FFEBLD_opCONTER)
  4604.     return expr;
  4605.   if (ffebld_op (r) != FFEBLD_opCONTER)
  4606.     return expr;
  4607.  
  4608.   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
  4609.     {
  4610.     case FFEINFO_basictypeANY:
  4611.       return expr;
  4612.  
  4613.     case FFEINFO_basictypeINTEGER:
  4614.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4615.     {
  4616. #if FFETARGET_okINTEGER1
  4617.     case FFEINFO_kindtypeINTEGER1:
  4618.       error = ffetarget_eq_integer1 (&val,
  4619.                    ffebld_constant_integer1 (ffebld_conter (l)),
  4620.                   ffebld_constant_integer1 (ffebld_conter (r)));
  4621.       expr = ffebld_new_conter_with_orig
  4622.         (ffebld_constant_new_logicaldefault (val), expr);
  4623.       break;
  4624. #endif
  4625.  
  4626. #if FFETARGET_okINTEGER2
  4627.     case FFEINFO_kindtypeINTEGER2:
  4628.       error = ffetarget_eq_integer2 (&val,
  4629.                    ffebld_constant_integer2 (ffebld_conter (l)),
  4630.                   ffebld_constant_integer2 (ffebld_conter (r)));
  4631.       expr = ffebld_new_conter_with_orig
  4632.         (ffebld_constant_new_logicaldefault (val), expr);
  4633.       break;
  4634. #endif
  4635.  
  4636. #if FFETARGET_okINTEGER3
  4637.     case FFEINFO_kindtypeINTEGER3:
  4638.       error = ffetarget_eq_integer3 (&val,
  4639.                    ffebld_constant_integer3 (ffebld_conter (l)),
  4640.                   ffebld_constant_integer3 (ffebld_conter (r)));
  4641.       expr = ffebld_new_conter_with_orig
  4642.         (ffebld_constant_new_logicaldefault (val), expr);
  4643.       break;
  4644. #endif
  4645.  
  4646. #if FFETARGET_okINTEGER4
  4647.     case FFEINFO_kindtypeINTEGER4:
  4648.       error = ffetarget_eq_integer4 (&val,
  4649.                    ffebld_constant_integer4 (ffebld_conter (l)),
  4650.                   ffebld_constant_integer4 (ffebld_conter (r)));
  4651.       expr = ffebld_new_conter_with_orig
  4652.         (ffebld_constant_new_logicaldefault (val), expr);
  4653.       break;
  4654. #endif
  4655.  
  4656.     default:
  4657.       assert ("bad integer kind type" == NULL);
  4658.       break;
  4659.     }
  4660.       break;
  4661.  
  4662.     case FFEINFO_basictypeREAL:
  4663.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4664.     {
  4665. #if FFETARGET_okREAL1
  4666.     case FFEINFO_kindtypeREAL1:
  4667.       error = ffetarget_eq_real1 (&val,
  4668.                   ffebld_constant_real1 (ffebld_conter (l)),
  4669.                  ffebld_constant_real1 (ffebld_conter (r)));
  4670.       expr = ffebld_new_conter_with_orig
  4671.         (ffebld_constant_new_logicaldefault (val), expr);
  4672.       break;
  4673. #endif
  4674.  
  4675. #if FFETARGET_okREAL2
  4676.     case FFEINFO_kindtypeREAL2:
  4677.       error = ffetarget_eq_real2 (&val,
  4678.                   ffebld_constant_real2 (ffebld_conter (l)),
  4679.                  ffebld_constant_real2 (ffebld_conter (r)));
  4680.       expr = ffebld_new_conter_with_orig
  4681.         (ffebld_constant_new_logicaldefault (val), expr);
  4682.       break;
  4683. #endif
  4684.  
  4685. #if FFETARGET_okREAL3
  4686.     case FFEINFO_kindtypeREAL3:
  4687.       error = ffetarget_eq_real3 (&val,
  4688.                   ffebld_constant_real3 (ffebld_conter (l)),
  4689.                  ffebld_constant_real3 (ffebld_conter (r)));
  4690.       expr = ffebld_new_conter_with_orig
  4691.         (ffebld_constant_new_logicaldefault (val), expr);
  4692.       break;
  4693. #endif
  4694.  
  4695. #if FFETARGET_okREAL4
  4696.     case FFEINFO_kindtypeREAL4:
  4697.       error = ffetarget_eq_real4 (&val,
  4698.                   ffebld_constant_real4 (ffebld_conter (l)),
  4699.                  ffebld_constant_real4 (ffebld_conter (r)));
  4700.       expr = ffebld_new_conter_with_orig
  4701.         (ffebld_constant_new_logicaldefault (val), expr);
  4702.       break;
  4703. #endif
  4704.  
  4705.     default:
  4706.       assert ("bad real kind type" == NULL);
  4707.       break;
  4708.     }
  4709.       break;
  4710.  
  4711.     case FFEINFO_basictypeCOMPLEX:
  4712.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4713.     {
  4714. #if FFETARGET_okCOMPLEX1
  4715.     case FFEINFO_kindtypeREAL1:
  4716.       error = ffetarget_eq_complex1 (&val,
  4717.                    ffebld_constant_complex1 (ffebld_conter (l)),
  4718.                   ffebld_constant_complex1 (ffebld_conter (r)));
  4719.       expr = ffebld_new_conter_with_orig
  4720.         (ffebld_constant_new_logicaldefault (val), expr);
  4721.       break;
  4722. #endif
  4723.  
  4724. #if FFETARGET_okCOMPLEX2
  4725.     case FFEINFO_kindtypeREAL2:
  4726.       error = ffetarget_eq_complex2 (&val,
  4727.                    ffebld_constant_complex2 (ffebld_conter (l)),
  4728.                   ffebld_constant_complex2 (ffebld_conter (r)));
  4729.       expr = ffebld_new_conter_with_orig
  4730.         (ffebld_constant_new_logicaldefault (val), expr);
  4731.       break;
  4732. #endif
  4733.  
  4734. #if FFETARGET_okCOMPLEX3
  4735.     case FFEINFO_kindtypeREAL3:
  4736.       error = ffetarget_eq_complex3 (&val,
  4737.                    ffebld_constant_complex3 (ffebld_conter (l)),
  4738.                   ffebld_constant_complex3 (ffebld_conter (r)));
  4739.       expr = ffebld_new_conter_with_orig
  4740.         (ffebld_constant_new_logicaldefault (val), expr);
  4741.       break;
  4742. #endif
  4743.  
  4744. #if FFETARGET_okCOMPLEX4
  4745.     case FFEINFO_kindtypeREAL4:
  4746.       error = ffetarget_eq_complex4 (&val,
  4747.                    ffebld_constant_complex4 (ffebld_conter (l)),
  4748.                   ffebld_constant_complex4 (ffebld_conter (r)));
  4749.       expr = ffebld_new_conter_with_orig
  4750.         (ffebld_constant_new_logicaldefault (val), expr);
  4751.       break;
  4752. #endif
  4753.  
  4754.     default:
  4755.       assert ("bad complex kind type" == NULL);
  4756.       break;
  4757.     }
  4758.       break;
  4759.  
  4760.     case FFEINFO_basictypeCHARACTER:
  4761.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4762.     {
  4763. #if FFETARGET_okCHARACTER1
  4764.     case FFEINFO_kindtypeCHARACTER1:
  4765.       error = ffetarget_eq_character1 (&val,
  4766.                  ffebld_constant_character1 (ffebld_conter (l)),
  4767.                 ffebld_constant_character1 (ffebld_conter (r)));
  4768.       expr = ffebld_new_conter_with_orig
  4769.         (ffebld_constant_new_logicaldefault (val), expr);
  4770.       break;
  4771. #endif
  4772.  
  4773. #if FFETARGET_okCHARACTER2
  4774.     case FFEINFO_kindtypeCHARACTER2:
  4775.       error = ffetarget_eq_character2 (&val,
  4776.                  ffebld_constant_character2 (ffebld_conter (l)),
  4777.                 ffebld_constant_character2 (ffebld_conter (r)));
  4778.       expr = ffebld_new_conter_with_orig
  4779.         (ffebld_constant_new_logicaldefault (val), expr);
  4780.       break;
  4781. #endif
  4782.  
  4783. #if FFETARGET_okCHARACTER3
  4784.     case FFEINFO_kindtypeCHARACTER3:
  4785.       error = ffetarget_eq_character3 (&val,
  4786.                  ffebld_constant_character3 (ffebld_conter (l)),
  4787.                 ffebld_constant_character3 (ffebld_conter (r)));
  4788.       expr = ffebld_new_conter_with_orig
  4789.         (ffebld_constant_new_logicaldefault (val), expr);
  4790.       break;
  4791. #endif
  4792.  
  4793. #if FFETARGET_okCHARACTER4
  4794.     case FFEINFO_kindtypeCHARACTER4:
  4795.       error = ffetarget_eq_character4 (&val,
  4796.                  ffebld_constant_character4 (ffebld_conter (l)),
  4797.                 ffebld_constant_character4 (ffebld_conter (r)));
  4798.       expr = ffebld_new_conter_with_orig
  4799.         (ffebld_constant_new_logicaldefault (val), expr);
  4800.       break;
  4801. #endif
  4802.  
  4803.     default:
  4804.       assert ("bad character kind type" == NULL);
  4805.       break;
  4806.     }
  4807.       break;
  4808.  
  4809.     default:
  4810.       assert ("bad type" == NULL);
  4811.       return expr;
  4812.     }
  4813.  
  4814.   ffebld_set_info (expr, ffeinfo_new
  4815.            (FFEINFO_basictypeLOGICAL,
  4816.             FFEINFO_kindtypeLOGICALDEFAULT,
  4817.             0,
  4818.             FFEINFO_kindENTITY,
  4819.             FFEINFO_whereCONSTANT,
  4820.             FFETARGET_charactersizeNONE));
  4821.  
  4822.   if ((error != FFEBAD)
  4823.       && ffebad_start (error))
  4824.     {
  4825.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  4826.       ffebad_finish ();
  4827.     }
  4828.  
  4829.   return expr;
  4830. }
  4831.  
  4832. /* ffeexpr_collapse_ne -- Collapse ne expr
  4833.  
  4834.    ffebld expr;
  4835.    ffelexToken token;
  4836.    expr = ffeexpr_collapse_ne(expr,token);
  4837.  
  4838.    If the result of the expr is a constant, replaces the expr with the
  4839.    computed constant.  */
  4840.  
  4841. ffebld
  4842. ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
  4843. {
  4844.   ffebad error = FFEBAD;
  4845.   ffebld l;
  4846.   ffebld r;
  4847.   bool val;
  4848.  
  4849.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  4850.     return expr;
  4851.  
  4852.   l = ffebld_left (expr);
  4853.   r = ffebld_right (expr);
  4854.  
  4855.   if (ffebld_op (l) != FFEBLD_opCONTER)
  4856.     return expr;
  4857.   if (ffebld_op (r) != FFEBLD_opCONTER)
  4858.     return expr;
  4859.  
  4860.   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
  4861.     {
  4862.     case FFEINFO_basictypeANY:
  4863.       return expr;
  4864.  
  4865.     case FFEINFO_basictypeINTEGER:
  4866.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4867.     {
  4868. #if FFETARGET_okINTEGER1
  4869.     case FFEINFO_kindtypeINTEGER1:
  4870.       error = ffetarget_ne_integer1 (&val,
  4871.                    ffebld_constant_integer1 (ffebld_conter (l)),
  4872.                   ffebld_constant_integer1 (ffebld_conter (r)));
  4873.       expr = ffebld_new_conter_with_orig
  4874.         (ffebld_constant_new_logicaldefault (val), expr);
  4875.       break;
  4876. #endif
  4877.  
  4878. #if FFETARGET_okINTEGER2
  4879.     case FFEINFO_kindtypeINTEGER2:
  4880.       error = ffetarget_ne_integer2 (&val,
  4881.                    ffebld_constant_integer2 (ffebld_conter (l)),
  4882.                   ffebld_constant_integer2 (ffebld_conter (r)));
  4883.       expr = ffebld_new_conter_with_orig
  4884.         (ffebld_constant_new_logicaldefault (val), expr);
  4885.       break;
  4886. #endif
  4887.  
  4888. #if FFETARGET_okINTEGER3
  4889.     case FFEINFO_kindtypeINTEGER3:
  4890.       error = ffetarget_ne_integer3 (&val,
  4891.                    ffebld_constant_integer3 (ffebld_conter (l)),
  4892.                   ffebld_constant_integer3 (ffebld_conter (r)));
  4893.       expr = ffebld_new_conter_with_orig
  4894.         (ffebld_constant_new_logicaldefault (val), expr);
  4895.       break;
  4896. #endif
  4897.  
  4898. #if FFETARGET_okINTEGER4
  4899.     case FFEINFO_kindtypeINTEGER4:
  4900.       error = ffetarget_ne_integer4 (&val,
  4901.                    ffebld_constant_integer4 (ffebld_conter (l)),
  4902.                   ffebld_constant_integer4 (ffebld_conter (r)));
  4903.       expr = ffebld_new_conter_with_orig
  4904.         (ffebld_constant_new_logicaldefault (val), expr);
  4905.       break;
  4906. #endif
  4907.  
  4908.     default:
  4909.       assert ("bad integer kind type" == NULL);
  4910.       break;
  4911.     }
  4912.       break;
  4913.  
  4914.     case FFEINFO_basictypeREAL:
  4915.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4916.     {
  4917. #if FFETARGET_okREAL1
  4918.     case FFEINFO_kindtypeREAL1:
  4919.       error = ffetarget_ne_real1 (&val,
  4920.                   ffebld_constant_real1 (ffebld_conter (l)),
  4921.                  ffebld_constant_real1 (ffebld_conter (r)));
  4922.       expr = ffebld_new_conter_with_orig
  4923.         (ffebld_constant_new_logicaldefault (val), expr);
  4924.       break;
  4925. #endif
  4926.  
  4927. #if FFETARGET_okREAL2
  4928.     case FFEINFO_kindtypeREAL2:
  4929.       error = ffetarget_ne_real2 (&val,
  4930.                   ffebld_constant_real2 (ffebld_conter (l)),
  4931.                  ffebld_constant_real2 (ffebld_conter (r)));
  4932.       expr = ffebld_new_conter_with_orig
  4933.         (ffebld_constant_new_logicaldefault (val), expr);
  4934.       break;
  4935. #endif
  4936.  
  4937. #if FFETARGET_okREAL3
  4938.     case FFEINFO_kindtypeREAL3:
  4939.       error = ffetarget_ne_real3 (&val,
  4940.                   ffebld_constant_real3 (ffebld_conter (l)),
  4941.                  ffebld_constant_real3 (ffebld_conter (r)));
  4942.       expr = ffebld_new_conter_with_orig
  4943.         (ffebld_constant_new_logicaldefault (val), expr);
  4944.       break;
  4945. #endif
  4946.  
  4947. #if FFETARGET_okREAL4
  4948.     case FFEINFO_kindtypeREAL4:
  4949.       error = ffetarget_ne_real4 (&val,
  4950.                   ffebld_constant_real4 (ffebld_conter (l)),
  4951.                  ffebld_constant_real4 (ffebld_conter (r)));
  4952.       expr = ffebld_new_conter_with_orig
  4953.         (ffebld_constant_new_logicaldefault (val), expr);
  4954.       break;
  4955. #endif
  4956.  
  4957.     default:
  4958.       assert ("bad real kind type" == NULL);
  4959.       break;
  4960.     }
  4961.       break;
  4962.  
  4963.     case FFEINFO_basictypeCOMPLEX:
  4964.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4965.     {
  4966. #if FFETARGET_okCOMPLEX1
  4967.     case FFEINFO_kindtypeREAL1:
  4968.       error = ffetarget_ne_complex1 (&val,
  4969.                    ffebld_constant_complex1 (ffebld_conter (l)),
  4970.                   ffebld_constant_complex1 (ffebld_conter (r)));
  4971.       expr = ffebld_new_conter_with_orig
  4972.         (ffebld_constant_new_logicaldefault (val), expr);
  4973.       break;
  4974. #endif
  4975.  
  4976. #if FFETARGET_okCOMPLEX2
  4977.     case FFEINFO_kindtypeREAL2:
  4978.       error = ffetarget_ne_complex2 (&val,
  4979.                    ffebld_constant_complex2 (ffebld_conter (l)),
  4980.                   ffebld_constant_complex2 (ffebld_conter (r)));
  4981.       expr = ffebld_new_conter_with_orig
  4982.         (ffebld_constant_new_logicaldefault (val), expr);
  4983.       break;
  4984. #endif
  4985.  
  4986. #if FFETARGET_okCOMPLEX3
  4987.     case FFEINFO_kindtypeREAL3:
  4988.       error = ffetarget_ne_complex3 (&val,
  4989.                    ffebld_constant_complex3 (ffebld_conter (l)),
  4990.                   ffebld_constant_complex3 (ffebld_conter (r)));
  4991.       expr = ffebld_new_conter_with_orig
  4992.         (ffebld_constant_new_logicaldefault (val), expr);
  4993.       break;
  4994. #endif
  4995.  
  4996. #if FFETARGET_okCOMPLEX4
  4997.     case FFEINFO_kindtypeREAL4:
  4998.       error = ffetarget_ne_complex4 (&val,
  4999.                    ffebld_constant_complex4 (ffebld_conter (l)),
  5000.                   ffebld_constant_complex4 (ffebld_conter (r)));
  5001.       expr = ffebld_new_conter_with_orig
  5002.         (ffebld_constant_new_logicaldefault (val), expr);
  5003.       break;
  5004. #endif
  5005.  
  5006.     default:
  5007.       assert ("bad complex kind type" == NULL);
  5008.       break;
  5009.     }
  5010.       break;
  5011.  
  5012.     case FFEINFO_basictypeCHARACTER:
  5013.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  5014.     {
  5015. #if FFETARGET_okCHARACTER1
  5016.     case FFEINFO_kindtypeCHARACTER1:
  5017.       error = ffetarget_ne_character1 (&val,
  5018.                  ffebld_constant_character1 (ffebld_conter (l)),
  5019.                 ffebld_constant_character1 (ffebld_conter (r)));
  5020.       expr = ffebld_new_conter_with_orig
  5021.         (ffebld_constant_new_logicaldefault (val), expr);
  5022.       break;
  5023. #endif
  5024.  
  5025. #if FFETARGET_okCHARACTER2
  5026.     case FFEINFO_kindtypeCHARACTER2:
  5027.       error = ffetarget_ne_character2 (&val,
  5028.                  ffebld_constant_character2 (ffebld_conter (l)),
  5029.                 ffebld_constant_character2 (ffebld_conter (r)));
  5030.       expr = ffebld_new_conter_with_orig
  5031.         (ffebld_constant_new_logicaldefault (val), expr);
  5032.       break;
  5033. #endif
  5034.  
  5035. #if FFETARGET_okCHARACTER3
  5036.     case FFEINFO_kindtypeCHARACTER3:
  5037.       error = ffetarget_ne_character3 (&val,
  5038.                  ffebld_constant_character3 (ffebld_conter (l)),
  5039.                 ffebld_constant_character3 (ffebld_conter (r)));
  5040.       expr = ffebld_new_conter_with_orig
  5041.         (ffebld_constant_new_logicaldefault (val), expr);
  5042.       break;
  5043. #endif
  5044.  
  5045. #if FFETARGET_okCHARACTER4
  5046.     case FFEINFO_kindtypeCHARACTER4:
  5047.       error = ffetarget_ne_character4 (&val,
  5048.                  ffebld_constant_character4 (ffebld_conter (l)),
  5049.                 ffebld_constant_character4 (ffebld_conter (r)));
  5050.       expr = ffebld_new_conter_with_orig
  5051.         (ffebld_constant_new_logicaldefault (val), expr);
  5052.       break;
  5053. #endif
  5054.  
  5055.     default:
  5056.       assert ("bad character kind type" == NULL);
  5057.       break;
  5058.     }
  5059.       break;
  5060.  
  5061.     default:
  5062.       assert ("bad type" == NULL);
  5063.       return expr;
  5064.     }
  5065.  
  5066.   ffebld_set_info (expr, ffeinfo_new
  5067.            (FFEINFO_basictypeLOGICAL,
  5068.             FFEINFO_kindtypeLOGICALDEFAULT,
  5069.             0,
  5070.             FFEINFO_kindENTITY,
  5071.             FFEINFO_whereCONSTANT,
  5072.             FFETARGET_charactersizeNONE));
  5073.  
  5074.   if ((error != FFEBAD)
  5075.       && ffebad_start (error))
  5076.     {
  5077.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  5078.       ffebad_finish ();
  5079.     }
  5080.  
  5081.   return expr;
  5082. }
  5083.  
  5084. /* ffeexpr_collapse_ge -- Collapse ge expr
  5085.  
  5086.    ffebld expr;
  5087.    ffelexToken token;
  5088.    expr = ffeexpr_collapse_ge(expr,token);
  5089.  
  5090.    If the result of the expr is a constant, replaces the expr with the
  5091.    computed constant.  */
  5092.  
  5093. ffebld
  5094. ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
  5095. {
  5096.   ffebad error = FFEBAD;
  5097.   ffebld l;
  5098.   ffebld r;
  5099.   bool val;
  5100.  
  5101.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  5102.     return expr;
  5103.  
  5104.   l = ffebld_left (expr);
  5105.   r = ffebld_right (expr);
  5106.  
  5107.   if (ffebld_op (l) != FFEBLD_opCONTER)
  5108.     return expr;
  5109.   if (ffebld_op (r) != FFEBLD_opCONTER)
  5110.     return expr;
  5111.  
  5112.   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
  5113.     {
  5114.     case FFEINFO_basictypeANY:
  5115.       return expr;
  5116.  
  5117.     case FFEINFO_basictypeINTEGER:
  5118.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  5119.     {
  5120. #if FFETARGET_okINTEGER1
  5121.     case FFEINFO_kindtypeINTEGER1:
  5122.       error = ffetarget_ge_integer1 (&val,
  5123.                    ffebld_constant_integer1 (ffebld_conter (l)),
  5124.                   ffebld_constant_integer1 (ffebld_conter (r)));
  5125.       expr = ffebld_new_conter_with_orig
  5126.         (ffebld_constant_new_logicaldefault (val), expr);
  5127.       break;
  5128. #endif
  5129.  
  5130. #if FFETARGET_okINTEGER2
  5131.     case FFEINFO_kindtypeINTEGER2:
  5132.       error = ffetarget_ge_integer2 (&val,
  5133.                    ffebld_constant_integer2 (ffebld_conter (l)),
  5134.                   ffebld_constant_integer2 (ffebld_conter (r)));
  5135.       expr = ffebld_new_conter_with_orig
  5136.         (ffebld_constant_new_logicaldefault (val), expr);
  5137.       break;
  5138. #endif
  5139.  
  5140. #if FFETARGET_okINTEGER3
  5141.     case FFEINFO_kindtypeINTEGER3:
  5142.       error = ffetarget_ge_integer3 (&val,
  5143.                    ffebld_constant_integer3 (ffebld_conter (l)),
  5144.                   ffebld_constant_integer3 (ffebld_conter (r)));
  5145.       expr = ffebld_new_conter_with_orig
  5146.         (ffebld_constant_new_logicaldefault (val), expr);
  5147.       break;
  5148. #endif
  5149.  
  5150. #if FFETARGET_okINTEGER4
  5151.     case FFEINFO_kindtypeINTEGER4:
  5152.       error = ffetarget_ge_integer4 (&val,
  5153.                    ffebld_constant_integer4 (ffebld_conter (l)),
  5154.                   ffebld_constant_integer4 (ffebld_conter (r)));
  5155.       expr = ffebld_new_conter_with_orig
  5156.         (ffebld_constant_new_logicaldefault (val), expr);
  5157.       break;
  5158. #endif
  5159.  
  5160.     default:
  5161.       assert ("bad integer kind type" == NULL);
  5162.       break;
  5163.     }
  5164.       break;
  5165.  
  5166.     case FFEINFO_basictypeREAL:
  5167.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  5168.     {
  5169. #if FFETARGET_okREAL1
  5170.     case FFEINFO_kindtypeREAL1:
  5171.       error = ffetarget_ge_real1 (&val,
  5172.                   ffebld_constant_real1 (ffebld_conter (l)),
  5173.                  ffebld_constant_real1 (ffebld_conter (r)));
  5174.       expr = ffebld_new_conter_with_orig
  5175.         (ffebld_constant_new_logicaldefault (val), expr);
  5176.       break;
  5177. #endif
  5178.  
  5179. #if FFETARGET_okREAL2
  5180.     case FFEINFO_kindtypeREAL2:
  5181.       error = ffetarget_ge_real2 (&val,
  5182.                   ffebld_constant_real2 (ffebld_conter (l)),
  5183.                  ffebld_constant_real2 (ffebld_conter (r)));
  5184.       expr = ffebld_new_conter_with_orig
  5185.         (ffebld_constant_new_logicaldefault (val), expr);
  5186.       break;
  5187. #endif
  5188.  
  5189. #if FFETARGET_okREAL3
  5190.     case FFEINFO_kindtypeREAL3:
  5191.       error = ffetarget_ge_real3 (&val,
  5192.                   ffebld_constant_real3 (ffebld_conter (l)),
  5193.                  ffebld_constant_real3 (ffebld_conter (r)));
  5194.       expr = ffebld_new_conter_with_orig
  5195.         (ffebld_constant_new_logicaldefault (val), expr);
  5196.       break;
  5197. #endif
  5198.  
  5199. #if FFETARGET_okREAL4
  5200.     case FFEINFO_kindtypeREAL4:
  5201.       error = ffetarget_ge_real4 (&val,
  5202.                   ffebld_constant_real4 (ffebld_conter (l)),
  5203.                  ffebld_constant_real4 (ffebld_conter (r)));
  5204.       expr = ffebld_new_conter_with_orig
  5205.         (ffebld_constant_new_logicaldefault (val), expr);
  5206.       break;
  5207. #endif
  5208.  
  5209.     default:
  5210.       assert ("bad real kind type" == NULL);
  5211.       break;
  5212.     }
  5213.       break;
  5214.  
  5215.     case FFEINFO_basictypeCHARACTER:
  5216.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  5217.     {
  5218. #if FFETARGET_okCHARACTER1
  5219.     case FFEINFO_kindtypeCHARACTER1:
  5220.       error = ffetarget_ge_character1 (&val,
  5221.                  ffebld_constant_character1 (ffebld_conter (l)),
  5222.                 ffebld_constant_character1 (ffebld_conter (r)));
  5223.       expr = ffebld_new_conter_with_orig
  5224.         (ffebld_constant_new_logicaldefault (val), expr);
  5225.       break;
  5226. #endif
  5227.  
  5228. #if FFETARGET_okCHARACTER2
  5229.     case FFEINFO_kindtypeCHARACTER2:
  5230.       error = ffetarget_ge_character2 (&val,
  5231.                  ffebld_constant_character2 (ffebld_conter (l)),
  5232.                 ffebld_constant_character2 (ffebld_conter (r)));
  5233.       expr = ffebld_new_conter_with_orig
  5234.         (ffebld_constant_new_logicaldefault (val), expr);
  5235.       break;
  5236. #endif
  5237.  
  5238. #if FFETARGET_okCHARACTER3
  5239.     case FFEINFO_kindtypeCHARACTER3:
  5240.       error = ffetarget_ge_character3 (&val,
  5241.                  ffebld_constant_character3 (ffebld_conter (l)),
  5242.                 ffebld_constant_character3 (ffebld_conter (r)));
  5243.       expr = ffebld_new_conter_with_orig
  5244.         (ffebld_constant_new_logicaldefault (val), expr);
  5245.       break;
  5246. #endif
  5247.  
  5248. #if FFETARGET_okCHARACTER4
  5249.     case FFEINFO_kindtypeCHARACTER4:
  5250.       error = ffetarget_ge_character4 (&val,
  5251.                  ffebld_constant_character4 (ffebld_conter (l)),
  5252.                 ffebld_constant_character4 (ffebld_conter (r)));
  5253.       expr = ffebld_new_conter_with_orig
  5254.         (ffebld_constant_new_logicaldefault (val), expr);
  5255.       break;
  5256. #endif
  5257.  
  5258.     default:
  5259.       assert ("bad character kind type" == NULL);
  5260.       break;
  5261.     }
  5262.       break;
  5263.  
  5264.     default:
  5265.       assert ("bad type" == NULL);
  5266.       return expr;
  5267.     }
  5268.  
  5269.   ffebld_set_info (expr, ffeinfo_new
  5270.            (FFEINFO_basictypeLOGICAL,
  5271.             FFEINFO_kindtypeLOGICALDEFAULT,
  5272.             0,
  5273.             FFEINFO_kindENTITY,
  5274.             FFEINFO_whereCONSTANT,
  5275.             FFETARGET_charactersizeNONE));
  5276.  
  5277.   if ((error != FFEBAD)
  5278.       && ffebad_start (error))
  5279.     {
  5280.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  5281.       ffebad_finish ();
  5282.     }
  5283.  
  5284.   return expr;
  5285. }
  5286.  
  5287. /* ffeexpr_collapse_gt -- Collapse gt expr
  5288.  
  5289.    ffebld expr;
  5290.    ffelexToken token;
  5291.    expr = ffeexpr_collapse_gt(expr,token);
  5292.  
  5293.    If the result of the expr is a constant, replaces the expr with the
  5294.    computed constant.  */
  5295.  
  5296. ffebld
  5297. ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
  5298. {
  5299.   ffebad error = FFEBAD;
  5300.   ffebld l;
  5301.   ffebld r;
  5302.   bool val;
  5303.  
  5304.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  5305.     return expr;
  5306.  
  5307.   l = ffebld_left (expr);
  5308.   r = ffebld_right (expr);
  5309.  
  5310.   if (ffebld_op (l) != FFEBLD_opCONTER)
  5311.     return expr;
  5312.   if (ffebld_op (r) != FFEBLD_opCONTER)
  5313.     return expr;
  5314.  
  5315.   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
  5316.     {
  5317.     case FFEINFO_basictypeANY:
  5318.       return expr;
  5319.  
  5320.     case FFEINFO_basictypeINTEGER:
  5321.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  5322.     {
  5323. #if FFETARGET_okINTEGER1
  5324.     case FFEINFO_kindtypeINTEGER1:
  5325.       error = ffetarget_gt_integer1 (&val,
  5326.                    ffebld_constant_integer1 (ffebld_conter (l)),
  5327.                   ffebld_constant_integer1 (ffebld_conter (r)));
  5328.       expr = ffebld_new_conter_with_orig
  5329.         (ffebld_constant_new_logicaldefault (val), expr);
  5330.       break;
  5331. #endif
  5332.  
  5333. #if FFETARGET_okINTEGER2
  5334.     case FFEINFO_kindtypeINTEGER2:
  5335.       error = ffetarget_gt_integer2 (&val,
  5336.                    ffebld_constant_integer2 (ffebld_conter (l)),
  5337.                   ffebld_constant_integer2 (ffebld_conter (r)));
  5338.       expr = ffebld_new_conter_with_orig
  5339.         (ffebld_constant_new_logicaldefault (val), expr);
  5340.       break;
  5341. #endif
  5342.  
  5343. #if FFETARGET_okINTEGER3
  5344.     case FFEINFO_kindtypeINTEGER3:
  5345.       error = ffetarget_gt_integer3 (&val,
  5346.                    ffebld_constant_integer3 (ffebld_conter (l)),
  5347.                   ffebld_constant_integer3 (ffebld_conter (r)));
  5348.       expr = ffebld_new_conter_with_orig
  5349.         (ffebld_constant_new_logicaldefault (val), expr);
  5350.       break;
  5351. #endif
  5352.  
  5353. #if FFETARGET_okINTEGER4
  5354.     case FFEINFO_kindtypeINTEGER4:
  5355.       error = ffetarget_gt_integer4 (&val,
  5356.                    ffebld_constant_integer4 (ffebld_conter (l)),
  5357.                   ffebld_constant_integer4 (ffebld_conter (r)));
  5358.       expr = ffebld_new_conter_with_orig
  5359.         (ffebld_constant_new_logicaldefault (val), expr);
  5360.       break;
  5361. #endif
  5362.  
  5363.     default:
  5364.       assert ("bad integer kind type" == NULL);
  5365.       break;
  5366.     }
  5367.       break;
  5368.  
  5369.     case FFEINFO_basictypeREAL:
  5370.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  5371.     {
  5372. #if FFETARGET_okREAL1
  5373.     case FFEINFO_kindtypeREAL1:
  5374.       error = ffetarget_gt_real1 (&val,
  5375.                   ffebld_constant_real1 (ffebld_conter (l)),
  5376.                  ffebld_constant_real1 (ffebld_conter (r)));
  5377.       expr = ffebld_new_conter_with_orig
  5378.         (ffebld_constant_new_logicaldefault (val), expr);
  5379.       break;
  5380. #endif
  5381.  
  5382. #if FFETARGET_okREAL2
  5383.     case FFEINFO_kindtypeREAL2:
  5384.       error = ffetarget_gt_real2 (&val,
  5385.                   ffebld_constant_real2 (ffebld_conter (l)),
  5386.                  ffebld_constant_real2 (ffebld_conter (r)));
  5387.       expr = ffebld_new_conter_with_orig
  5388.         (ffebld_constant_new_logicaldefault (val), expr);
  5389.       break;
  5390. #endif
  5391.  
  5392. #if FFETARGET_okREAL3
  5393.     case FFEINFO_kindtypeREAL3:
  5394.       error = ffetarget_gt_real3 (&val,
  5395.                   ffebld_constant_real3 (ffebld_conter (l)),
  5396.                  ffebld_constant_real3 (ffebld_conter (r)));
  5397.       expr = ffebld_new_conter_with_orig
  5398.         (ffebld_constant_new_logicaldefault (val), expr);
  5399.       break;
  5400. #endif
  5401.  
  5402. #if FFETARGET_okREAL4
  5403.     case FFEINFO_kindtypeREAL4:
  5404.       error = ffetarget_gt_real4 (&val,
  5405.                   ffebld_constant_real4 (ffebld_conter (l)),
  5406.                  ffebld_constant_real4 (ffebld_conter (r)));
  5407.       expr = ffebld_new_conter_with_orig
  5408.         (ffebld_constant_new_logicaldefault (val), expr);
  5409.       break;
  5410. #endif
  5411.  
  5412.     default:
  5413.       assert ("bad real kind type" == NULL);
  5414.       break;
  5415.     }
  5416.       break;
  5417.  
  5418.     case FFEINFO_basictypeCHARACTER:
  5419.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  5420.     {
  5421. #if FFETARGET_okCHARACTER1
  5422.     case FFEINFO_kindtypeCHARACTER1:
  5423.       error = ffetarget_gt_character1 (&val,
  5424.                  ffebld_constant_character1 (ffebld_conter (l)),
  5425.                 ffebld_constant_character1 (ffebld_conter (r)));
  5426.       expr = ffebld_new_conter_with_orig
  5427.         (ffebld_constant_new_logicaldefault (val), expr);
  5428.       break;
  5429. #endif
  5430.  
  5431. #if FFETARGET_okCHARACTER2
  5432.     case FFEINFO_kindtypeCHARACTER2:
  5433.       error = ffetarget_gt_character2 (&val,
  5434.                  ffebld_constant_character2 (ffebld_conter (l)),
  5435.                 ffebld_constant_character2 (ffebld_conter (r)));
  5436.       expr = ffebld_new_conter_with_orig
  5437.         (ffebld_constant_new_logicaldefault (val), expr);
  5438.       break;
  5439. #endif
  5440.  
  5441. #if FFETARGET_okCHARACTER3
  5442.     case FFEINFO_kindtypeCHARACTER3:
  5443.       error = ffetarget_gt_character3 (&val,
  5444.                  ffebld_constant_character3 (ffebld_conter (l)),
  5445.                 ffebld_constant_character3 (ffebld_conter (r)));
  5446.       expr = ffebld_new_conter_with_orig
  5447.         (ffebld_constant_new_logicaldefault (val), expr);
  5448.       break;
  5449. #endif
  5450.  
  5451. #if FFETARGET_okCHARACTER4
  5452.     case FFEINFO_kindtypeCHARACTER4:
  5453.       error = ffetarget_gt_character4 (&val,
  5454.                  ffebld_constant_character4 (ffebld_conter (l)),
  5455.                 ffebld_constant_character4 (ffebld_conter (r)));
  5456.       expr = ffebld_new_conter_with_orig
  5457.         (ffebld_constant_new_logicaldefault (val), expr);
  5458.       break;
  5459. #endif
  5460.  
  5461.     default:
  5462.       assert ("bad character kind type" == NULL);
  5463.       break;
  5464.     }
  5465.       break;
  5466.  
  5467.     default:
  5468.       assert ("bad type" == NULL);
  5469.       return expr;
  5470.     }
  5471.  
  5472.   ffebld_set_info (expr, ffeinfo_new
  5473.            (FFEINFO_basictypeLOGICAL,
  5474.             FFEINFO_kindtypeLOGICALDEFAULT,
  5475.             0,
  5476.             FFEINFO_kindENTITY,
  5477.             FFEINFO_whereCONSTANT,
  5478.             FFETARGET_charactersizeNONE));
  5479.  
  5480.   if ((error != FFEBAD)
  5481.       && ffebad_start (error))
  5482.     {
  5483.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  5484.       ffebad_finish ();
  5485.     }
  5486.  
  5487.   return expr;
  5488. }
  5489.  
  5490. /* ffeexpr_collapse_le -- Collapse le expr
  5491.  
  5492.    ffebld expr;
  5493.    ffelexToken token;
  5494.    expr = ffeexpr_collapse_le(expr,token);
  5495.  
  5496.    If the result of the expr is a constant, replaces the expr with the
  5497.    computed constant.  */
  5498.  
  5499. ffebld
  5500. ffeexpr_collapse_le (ffebld expr, ffelexToken t)
  5501. {
  5502.   ffebad error = FFEBAD;
  5503.   ffebld l;
  5504.   ffebld r;
  5505.   bool val;
  5506.  
  5507.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  5508.     return expr;
  5509.  
  5510.   l = ffebld_left (expr);
  5511.   r = ffebld_right (expr);
  5512.  
  5513.   if (ffebld_op (l) != FFEBLD_opCONTER)
  5514.     return expr;
  5515.   if (ffebld_op (r) != FFEBLD_opCONTER)
  5516.     return expr;
  5517.  
  5518.   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
  5519.     {
  5520.     case FFEINFO_basictypeANY:
  5521.       return expr;
  5522.  
  5523.     case FFEINFO_basictypeINTEGER:
  5524.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  5525.     {
  5526. #if FFETARGET_okINTEGER1
  5527.     case FFEINFO_kindtypeINTEGER1:
  5528.       error = ffetarget_le_integer1 (&val,
  5529.                    ffebld_constant_integer1 (ffebld_conter (l)),
  5530.                   ffebld_constant_integer1 (ffebld_conter (r)));
  5531.       expr = ffebld_new_conter_with_orig
  5532.         (ffebld_constant_new_logicaldefault (val), expr);
  5533.       break;
  5534. #endif
  5535.  
  5536. #if FFETARGET_okINTEGER2
  5537.     case FFEINFO_kindtypeINTEGER2:
  5538.       error = ffetarget_le_integer2 (&val,
  5539.                    ffebld_constant_integer2 (ffebld_conter (l)),
  5540.                   ffebld_constant_integer2 (ffebld_conter (r)));
  5541.       expr = ffebld_new_conter_with_orig
  5542.         (ffebld_constant_new_logicaldefault (val), expr);
  5543.       break;
  5544. #endif
  5545.  
  5546. #if FFETARGET_okINTEGER3
  5547.     case FFEINFO_kindtypeINTEGER3:
  5548.       error = ffetarget_le_integer3 (&val,
  5549.                    ffebld_constant_integer3 (ffebld_conter (l)),
  5550.                   ffebld_constant_integer3 (ffebld_conter (r)));
  5551.       expr = ffebld_new_conter_with_orig
  5552.         (ffebld_constant_new_logicaldefault (val), expr);
  5553.       break;
  5554. #endif
  5555.  
  5556. #if FFETARGET_okINTEGER4
  5557.     case FFEINFO_kindtypeINTEGER4:
  5558.       error = ffetarget_le_integer4 (&val,
  5559.                    ffebld_constant_integer4 (ffebld_conter (l)),
  5560.                   ffebld_constant_integer4 (ffebld_conter (r)));
  5561.       expr = ffebld_new_conter_with_orig
  5562.         (ffebld_constant_new_logicaldefault (val), expr);
  5563.       break;
  5564. #endif
  5565.  
  5566.     default:
  5567.       assert ("bad integer kind type" == NULL);
  5568.       break;
  5569.     }
  5570.       break;
  5571.  
  5572.     case FFEINFO_basictypeREAL:
  5573.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  5574.     {
  5575. #if FFETARGET_okREAL1
  5576.     case FFEINFO_kindtypeREAL1:
  5577.       error = ffetarget_le_real1 (&val,
  5578.                   ffebld_constant_real1 (ffebld_conter (l)),
  5579.                  ffebld_constant_real1 (ffebld_conter (r)));
  5580.       expr = ffebld_new_conter_with_orig
  5581.         (ffebld_constant_new_logicaldefault (val), expr);
  5582.       break;
  5583. #endif
  5584.  
  5585. #if FFETARGET_okREAL2
  5586.     case FFEINFO_kindtypeREAL2:
  5587.       error = ffetarget_le_real2 (&val,
  5588.                   ffebld_constant_real2 (ffebld_conter (l)),
  5589.                  ffebld_constant_real2 (ffebld_conter (r)));
  5590.       expr = ffebld_new_conter_with_orig
  5591.         (ffebld_constant_new_logicaldefault (val), expr);
  5592.       break;
  5593. #endif
  5594.  
  5595. #if FFETARGET_okREAL3
  5596.     case FFEINFO_kindtypeREAL3:
  5597.       error = ffetarget_le_real3 (&val,
  5598.                   ffebld_constant_real3 (ffebld_conter (l)),
  5599.                  ffebld_constant_real3 (ffebld_conter (r)));
  5600.       expr = ffebld_new_conter_with_orig
  5601.         (ffebld_constant_new_logicaldefault (val), expr);
  5602.       break;
  5603. #endif
  5604.  
  5605. #if FFETARGET_okREAL4
  5606.     case FFEINFO_kindtypeREAL4:
  5607.       error = ffetarget_le_real4 (&val,
  5608.                   ffebld_constant_real4 (ffebld_conter (l)),
  5609.                  ffebld_constant_real4 (ffebld_conter (r)));
  5610.       expr = ffebld_new_conter_with_orig
  5611.         (ffebld_constant_new_logicaldefault (val), expr);
  5612.       break;
  5613. #endif
  5614.  
  5615.     default:
  5616.       assert ("bad real kind type" == NULL);
  5617.       break;
  5618.     }
  5619.       break;
  5620.  
  5621.     case FFEINFO_basictypeCHARACTER:
  5622.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  5623.     {
  5624. #if FFETARGET_okCHARACTER1
  5625.     case FFEINFO_kindtypeCHARACTER1:
  5626.       error = ffetarget_le_character1 (&val,
  5627.                  ffebld_constant_character1 (ffebld_conter (l)),
  5628.                 ffebld_constant_character1 (ffebld_conter (r)));
  5629.       expr = ffebld_new_conter_with_orig
  5630.         (ffebld_constant_new_logicaldefault (val), expr);
  5631.       break;
  5632. #endif
  5633.  
  5634. #if FFETARGET_okCHARACTER2
  5635.     case FFEINFO_kindtypeCHARACTER2:
  5636.       error = ffetarget_le_character2 (&val,
  5637.                  ffebld_constant_character2 (ffebld_conter (l)),
  5638.                 ffebld_constant_character2 (ffebld_conter (r)));
  5639.       expr = ffebld_new_conter_with_orig
  5640.         (ffebld_constant_new_logicaldefault (val), expr);
  5641.       break;
  5642. #endif
  5643.  
  5644. #if FFETARGET_okCHARACTER3
  5645.     case FFEINFO_kindtypeCHARACTER3:
  5646.       error = ffetarget_le_character3 (&val,
  5647.                  ffebld_constant_character3 (ffebld_conter (l)),
  5648.                 ffebld_constant_character3 (ffebld_conter (r)));
  5649.       expr = ffebld_new_conter_with_orig
  5650.         (ffebld_constant_new_logicaldefault (val), expr);
  5651.       break;
  5652. #endif
  5653.  
  5654. #if FFETARGET_okCHARACTER4
  5655.     case FFEINFO_kindtypeCHARACTER4:
  5656.       error = ffetarget_le_character4 (&val,
  5657.                  ffebld_constant_character4 (ffebld_conter (l)),
  5658.                 ffebld_constant_character4 (ffebld_conter (r)));
  5659.       expr = ffebld_new_conter_with_orig
  5660.         (ffebld_constant_new_logicaldefault (val), expr);
  5661.       break;
  5662. #endif
  5663.  
  5664.     default:
  5665.       assert ("bad character kind type" == NULL);
  5666.       break;
  5667.     }
  5668.       break;
  5669.  
  5670.     default:
  5671.       assert ("bad type" == NULL);
  5672.       return expr;
  5673.     }
  5674.  
  5675.   ffebld_set_info (expr, ffeinfo_new
  5676.            (FFEINFO_basictypeLOGICAL,
  5677.             FFEINFO_kindtypeLOGICALDEFAULT,
  5678.             0,
  5679.             FFEINFO_kindENTITY,
  5680.             FFEINFO_whereCONSTANT,
  5681.             FFETARGET_charactersizeNONE));
  5682.  
  5683.   if ((error != FFEBAD)
  5684.       && ffebad_start (error))
  5685.     {
  5686.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  5687.       ffebad_finish ();
  5688.     }
  5689.  
  5690.   return expr;
  5691. }
  5692.  
  5693. /* ffeexpr_collapse_lt -- Collapse lt expr
  5694.  
  5695.    ffebld expr;
  5696.    ffelexToken token;
  5697.    expr = ffeexpr_collapse_lt(expr,token);
  5698.  
  5699.    If the result of the expr is a constant, replaces the expr with the
  5700.    computed constant.  */
  5701.  
  5702. ffebld
  5703. ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
  5704. {
  5705.   ffebad error = FFEBAD;
  5706.   ffebld l;
  5707.   ffebld r;
  5708.   bool val;
  5709.  
  5710.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  5711.     return expr;
  5712.  
  5713.   l = ffebld_left (expr);
  5714.   r = ffebld_right (expr);
  5715.  
  5716.   if (ffebld_op (l) != FFEBLD_opCONTER)
  5717.     return expr;
  5718.   if (ffebld_op (r) != FFEBLD_opCONTER)
  5719.     return expr;
  5720.  
  5721.   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
  5722.     {
  5723.     case FFEINFO_basictypeANY:
  5724.       return expr;
  5725.  
  5726.     case FFEINFO_basictypeINTEGER:
  5727.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  5728.     {
  5729. #if FFETARGET_okINTEGER1
  5730.     case FFEINFO_kindtypeINTEGER1:
  5731.       error = ffetarget_lt_integer1 (&val,
  5732.                    ffebld_constant_integer1 (ffebld_conter (l)),
  5733.                   ffebld_constant_integer1 (ffebld_conter (r)));
  5734.       expr = ffebld_new_conter_with_orig
  5735.         (ffebld_constant_new_logicaldefault (val), expr);
  5736.       break;
  5737. #endif
  5738.  
  5739. #if FFETARGET_okINTEGER2
  5740.     case FFEINFO_kindtypeINTEGER2:
  5741.       error = ffetarget_lt_integer2 (&val,
  5742.                    ffebld_constant_integer2 (ffebld_conter (l)),
  5743.                   ffebld_constant_integer2 (ffebld_conter (r)));
  5744.       expr = ffebld_new_conter_with_orig
  5745.         (ffebld_constant_new_logicaldefault (val), expr);
  5746.       break;
  5747. #endif
  5748.  
  5749. #if FFETARGET_okINTEGER3
  5750.     case FFEINFO_kindtypeINTEGER3:
  5751.       error = ffetarget_lt_integer3 (&val,
  5752.                    ffebld_constant_integer3 (ffebld_conter (l)),
  5753.                   ffebld_constant_integer3 (ffebld_conter (r)));
  5754.       expr = ffebld_new_conter_with_orig
  5755.         (ffebld_constant_new_logicaldefault (val), expr);
  5756.       break;
  5757. #endif
  5758.  
  5759. #if FFETARGET_okINTEGER4
  5760.     case FFEINFO_kindtypeINTEGER4:
  5761.       error = ffetarget_lt_integer4 (&val,
  5762.                    ffebld_constant_integer4 (ffebld_conter (l)),
  5763.                   ffebld_constant_integer4 (ffebld_conter (r)));
  5764.       expr = ffebld_new_conter_with_orig
  5765.         (ffebld_constant_new_logicaldefault (val), expr);
  5766.       break;
  5767. #endif
  5768.  
  5769.     default:
  5770.       assert ("bad integer kind type" == NULL);
  5771.       break;
  5772.     }
  5773.       break;
  5774.  
  5775.     case FFEINFO_basictypeREAL:
  5776.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  5777.     {
  5778. #if FFETARGET_okREAL1
  5779.     case FFEINFO_kindtypeREAL1:
  5780.       error = ffetarget_lt_real1 (&val,
  5781.                   ffebld_constant_real1 (ffebld_conter (l)),
  5782.                  ffebld_constant_real1 (ffebld_conter (r)));
  5783.       expr = ffebld_new_conter_with_orig
  5784.         (ffebld_constant_new_logicaldefault (val), expr);
  5785.       break;
  5786. #endif
  5787.  
  5788. #if FFETARGET_okREAL2
  5789.     case FFEINFO_kindtypeREAL2:
  5790.       error = ffetarget_lt_real2 (&val,
  5791.                   ffebld_constant_real2 (ffebld_conter (l)),
  5792.                  ffebld_constant_real2 (ffebld_conter (r)));
  5793.       expr = ffebld_new_conter_with_orig
  5794.         (ffebld_constant_new_logicaldefault (val), expr);
  5795.       break;
  5796. #endif
  5797.  
  5798. #if FFETARGET_okREAL3
  5799.     case FFEINFO_kindtypeREAL3:
  5800.       error = ffetarget_lt_real3 (&val,
  5801.                   ffebld_constant_real3 (ffebld_conter (l)),
  5802.                  ffebld_constant_real3 (ffebld_conter (r)));
  5803.       expr = ffebld_new_conter_with_orig
  5804.         (ffebld_constant_new_logicaldefault (val), expr);
  5805.       break;
  5806. #endif
  5807.  
  5808. #if FFETARGET_okREAL4
  5809.     case FFEINFO_kindtypeREAL4:
  5810.       error = ffetarget_lt_real4 (&val,
  5811.                   ffebld_constant_real4 (ffebld_conter (l)),
  5812.                  ffebld_constant_real4 (ffebld_conter (r)));
  5813.       expr = ffebld_new_conter_with_orig
  5814.         (ffebld_constant_new_logicaldefault (val), expr);
  5815.       break;
  5816. #endif
  5817.  
  5818.     default:
  5819.       assert ("bad real kind type" == NULL);
  5820.       break;
  5821.     }
  5822.       break;
  5823.  
  5824.     case FFEINFO_basictypeCHARACTER:
  5825.       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  5826.     {
  5827. #if FFETARGET_okCHARACTER1
  5828.     case FFEINFO_kindtypeCHARACTER1:
  5829.       error = ffetarget_lt_character1 (&val,
  5830.                  ffebld_constant_character1 (ffebld_conter (l)),
  5831.                 ffebld_constant_character1 (ffebld_conter (r)));
  5832.       expr = ffebld_new_conter_with_orig
  5833.         (ffebld_constant_new_logicaldefault (val), expr);
  5834.       break;
  5835. #endif
  5836.  
  5837. #if FFETARGET_okCHARACTER2
  5838.     case FFEINFO_kindtypeCHARACTER2:
  5839.       error = ffetarget_lt_character2 (&val,
  5840.                  ffebld_constant_character2 (ffebld_conter (l)),
  5841.                 ffebld_constant_character2 (ffebld_conter (r)));
  5842.       expr = ffebld_new_conter_with_orig
  5843.         (ffebld_constant_new_logicaldefault (val), expr);
  5844.       break;
  5845. #endif
  5846.  
  5847. #if FFETARGET_okCHARACTER3
  5848.     case FFEINFO_kindtypeCHARACTER3:
  5849.       error = ffetarget_lt_character3 (&val,
  5850.                  ffebld_constant_character3 (ffebld_conter (l)),
  5851.                 ffebld_constant_character3 (ffebld_conter (r)));
  5852.       expr = ffebld_new_conter_with_orig
  5853.         (ffebld_constant_new_logicaldefault (val), expr);
  5854.       break;
  5855. #endif
  5856.  
  5857. #if FFETARGET_okCHARACTER4
  5858.     case FFEINFO_kindtypeCHARACTER4:
  5859.       error = ffetarget_lt_character4 (&val,
  5860.                  ffebld_constant_character4 (ffebld_conter (l)),
  5861.                 ffebld_constant_character4 (ffebld_conter (r)));
  5862.       expr = ffebld_new_conter_with_orig
  5863.         (ffebld_constant_new_logicaldefault (val), expr);
  5864.       break;
  5865. #endif
  5866.  
  5867.     default:
  5868.       assert ("bad character kind type" == NULL);
  5869.       break;
  5870.     }
  5871.       break;
  5872.  
  5873.     default:
  5874.       assert ("bad type" == NULL);
  5875.       return expr;
  5876.     }
  5877.  
  5878.   ffebld_set_info (expr, ffeinfo_new
  5879.            (FFEINFO_basictypeLOGICAL,
  5880.             FFEINFO_kindtypeLOGICALDEFAULT,
  5881.             0,
  5882.             FFEINFO_kindENTITY,
  5883.             FFEINFO_whereCONSTANT,
  5884.             FFETARGET_charactersizeNONE));
  5885.  
  5886.   if ((error != FFEBAD)
  5887.       && ffebad_start (error))
  5888.     {
  5889.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  5890.       ffebad_finish ();
  5891.     }
  5892.  
  5893.   return expr;
  5894. }
  5895.  
  5896. /* ffeexpr_collapse_and -- Collapse and expr
  5897.  
  5898.    ffebld expr;
  5899.    ffelexToken token;
  5900.    expr = ffeexpr_collapse_and(expr,token);
  5901.  
  5902.    If the result of the expr is a constant, replaces the expr with the
  5903.    computed constant.  */
  5904.  
  5905. ffebld
  5906. ffeexpr_collapse_and (ffebld expr, ffelexToken t)
  5907. {
  5908.   ffebad error = FFEBAD;
  5909.   ffebld l;
  5910.   ffebld r;
  5911.   ffebldConstantUnion u;
  5912.   ffeinfoBasictype bt;
  5913.   ffeinfoKindtype kt;
  5914.  
  5915.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  5916.     return expr;
  5917.  
  5918.   l = ffebld_left (expr);
  5919.   r = ffebld_right (expr);
  5920.  
  5921.   if (ffebld_op (l) != FFEBLD_opCONTER)
  5922.     return expr;
  5923.   if (ffebld_op (r) != FFEBLD_opCONTER)
  5924.     return expr;
  5925.  
  5926.   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  5927.     {
  5928.     case FFEINFO_basictypeANY:
  5929.       return expr;
  5930.  
  5931.     case FFEINFO_basictypeINTEGER:
  5932.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  5933.     {
  5934. #if FFETARGET_okINTEGER1
  5935.     case FFEINFO_kindtypeINTEGER1:
  5936.       error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
  5937.                    ffebld_constant_integer1 (ffebld_conter (l)),
  5938.                   ffebld_constant_integer1 (ffebld_conter (r)));
  5939.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  5940.                     (ffebld_cu_val_integer1 (u)), expr);
  5941.       break;
  5942. #endif
  5943.  
  5944. #if FFETARGET_okINTEGER2
  5945.     case FFEINFO_kindtypeINTEGER2:
  5946.       error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
  5947.                    ffebld_constant_integer2 (ffebld_conter (l)),
  5948.                   ffebld_constant_integer2 (ffebld_conter (r)));
  5949.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  5950.                     (ffebld_cu_val_integer2 (u)), expr);
  5951.       break;
  5952. #endif
  5953.  
  5954. #if FFETARGET_okINTEGER3
  5955.     case FFEINFO_kindtypeINTEGER3:
  5956.       error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
  5957.                    ffebld_constant_integer3 (ffebld_conter (l)),
  5958.                   ffebld_constant_integer3 (ffebld_conter (r)));
  5959.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  5960.                     (ffebld_cu_val_integer3 (u)), expr);
  5961.       break;
  5962. #endif
  5963.  
  5964. #if FFETARGET_okINTEGER4
  5965.     case FFEINFO_kindtypeINTEGER4:
  5966.       error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
  5967.                    ffebld_constant_integer4 (ffebld_conter (l)),
  5968.                   ffebld_constant_integer4 (ffebld_conter (r)));
  5969.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  5970.                     (ffebld_cu_val_integer4 (u)), expr);
  5971.       break;
  5972. #endif
  5973.  
  5974.     default:
  5975.       assert ("bad integer kind type" == NULL);
  5976.       break;
  5977.     }
  5978.       break;
  5979.  
  5980.     case FFEINFO_basictypeLOGICAL:
  5981.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  5982.     {
  5983. #if FFETARGET_okLOGICAL1
  5984.     case FFEINFO_kindtypeLOGICAL1:
  5985.       error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
  5986.                    ffebld_constant_logical1 (ffebld_conter (l)),
  5987.                   ffebld_constant_logical1 (ffebld_conter (r)));
  5988.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
  5989.                     (ffebld_cu_val_logical1 (u)), expr);
  5990.       break;
  5991. #endif
  5992.  
  5993. #if FFETARGET_okLOGICAL2
  5994.     case FFEINFO_kindtypeLOGICAL2:
  5995.       error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
  5996.                    ffebld_constant_logical2 (ffebld_conter (l)),
  5997.                   ffebld_constant_logical2 (ffebld_conter (r)));
  5998.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
  5999.                     (ffebld_cu_val_logical2 (u)), expr);
  6000.       break;
  6001. #endif
  6002.  
  6003. #if FFETARGET_okLOGICAL3
  6004.     case FFEINFO_kindtypeLOGICAL3:
  6005.       error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
  6006.                    ffebld_constant_logical3 (ffebld_conter (l)),
  6007.                   ffebld_constant_logical3 (ffebld_conter (r)));
  6008.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
  6009.                     (ffebld_cu_val_logical3 (u)), expr);
  6010.       break;
  6011. #endif
  6012.  
  6013. #if FFETARGET_okLOGICAL4
  6014.     case FFEINFO_kindtypeLOGICAL4:
  6015.       error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
  6016.                    ffebld_constant_logical4 (ffebld_conter (l)),
  6017.                   ffebld_constant_logical4 (ffebld_conter (r)));
  6018.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
  6019.                     (ffebld_cu_val_logical4 (u)), expr);
  6020.       break;
  6021. #endif
  6022.  
  6023.     default:
  6024.       assert ("bad logical kind type" == NULL);
  6025.       break;
  6026.     }
  6027.       break;
  6028.  
  6029.     default:
  6030.       assert ("bad type" == NULL);
  6031.       return expr;
  6032.     }
  6033.  
  6034.   ffebld_set_info (expr, ffeinfo_new
  6035.            (bt,
  6036.             kt,
  6037.             0,
  6038.             FFEINFO_kindENTITY,
  6039.             FFEINFO_whereCONSTANT,
  6040.             FFETARGET_charactersizeNONE));
  6041.  
  6042.   if ((error != FFEBAD)
  6043.       && ffebad_start (error))
  6044.     {
  6045.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  6046.       ffebad_finish ();
  6047.     }
  6048.  
  6049.   return expr;
  6050. }
  6051.  
  6052. /* ffeexpr_collapse_or -- Collapse or expr
  6053.  
  6054.    ffebld expr;
  6055.    ffelexToken token;
  6056.    expr = ffeexpr_collapse_or(expr,token);
  6057.  
  6058.    If the result of the expr is a constant, replaces the expr with the
  6059.    computed constant.  */
  6060.  
  6061. ffebld
  6062. ffeexpr_collapse_or (ffebld expr, ffelexToken t)
  6063. {
  6064.   ffebad error = FFEBAD;
  6065.   ffebld l;
  6066.   ffebld r;
  6067.   ffebldConstantUnion u;
  6068.   ffeinfoBasictype bt;
  6069.   ffeinfoKindtype kt;
  6070.  
  6071.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  6072.     return expr;
  6073.  
  6074.   l = ffebld_left (expr);
  6075.   r = ffebld_right (expr);
  6076.  
  6077.   if (ffebld_op (l) != FFEBLD_opCONTER)
  6078.     return expr;
  6079.   if (ffebld_op (r) != FFEBLD_opCONTER)
  6080.     return expr;
  6081.  
  6082.   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  6083.     {
  6084.     case FFEINFO_basictypeANY:
  6085.       return expr;
  6086.  
  6087.     case FFEINFO_basictypeINTEGER:
  6088.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  6089.     {
  6090. #if FFETARGET_okINTEGER1
  6091.     case FFEINFO_kindtypeINTEGER1:
  6092.       error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
  6093.                    ffebld_constant_integer1 (ffebld_conter (l)),
  6094.                   ffebld_constant_integer1 (ffebld_conter (r)));
  6095.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  6096.                     (ffebld_cu_val_integer1 (u)), expr);
  6097.       break;
  6098. #endif
  6099.  
  6100. #if FFETARGET_okINTEGER2
  6101.     case FFEINFO_kindtypeINTEGER2:
  6102.       error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
  6103.                    ffebld_constant_integer2 (ffebld_conter (l)),
  6104.                   ffebld_constant_integer2 (ffebld_conter (r)));
  6105.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  6106.                     (ffebld_cu_val_integer2 (u)), expr);
  6107.       break;
  6108. #endif
  6109.  
  6110. #if FFETARGET_okINTEGER3
  6111.     case FFEINFO_kindtypeINTEGER3:
  6112.       error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
  6113.                    ffebld_constant_integer3 (ffebld_conter (l)),
  6114.                   ffebld_constant_integer3 (ffebld_conter (r)));
  6115.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  6116.                     (ffebld_cu_val_integer3 (u)), expr);
  6117.       break;
  6118. #endif
  6119.  
  6120. #if FFETARGET_okINTEGER4
  6121.     case FFEINFO_kindtypeINTEGER4:
  6122.       error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
  6123.                    ffebld_constant_integer4 (ffebld_conter (l)),
  6124.                   ffebld_constant_integer4 (ffebld_conter (r)));
  6125.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  6126.                     (ffebld_cu_val_integer4 (u)), expr);
  6127.       break;
  6128. #endif
  6129.  
  6130.     default:
  6131.       assert ("bad integer kind type" == NULL);
  6132.       break;
  6133.     }
  6134.       break;
  6135.  
  6136.     case FFEINFO_basictypeLOGICAL:
  6137.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  6138.     {
  6139. #if FFETARGET_okLOGICAL1
  6140.     case FFEINFO_kindtypeLOGICAL1:
  6141.       error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
  6142.                    ffebld_constant_logical1 (ffebld_conter (l)),
  6143.                   ffebld_constant_logical1 (ffebld_conter (r)));
  6144.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
  6145.                     (ffebld_cu_val_logical1 (u)), expr);
  6146.       break;
  6147. #endif
  6148.  
  6149. #if FFETARGET_okLOGICAL2
  6150.     case FFEINFO_kindtypeLOGICAL2:
  6151.       error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
  6152.                    ffebld_constant_logical2 (ffebld_conter (l)),
  6153.                   ffebld_constant_logical2 (ffebld_conter (r)));
  6154.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
  6155.                     (ffebld_cu_val_logical2 (u)), expr);
  6156.       break;
  6157. #endif
  6158.  
  6159. #if FFETARGET_okLOGICAL3
  6160.     case FFEINFO_kindtypeLOGICAL3:
  6161.       error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
  6162.                    ffebld_constant_logical3 (ffebld_conter (l)),
  6163.                   ffebld_constant_logical3 (ffebld_conter (r)));
  6164.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
  6165.                     (ffebld_cu_val_logical3 (u)), expr);
  6166.       break;
  6167. #endif
  6168.  
  6169. #if FFETARGET_okLOGICAL4
  6170.     case FFEINFO_kindtypeLOGICAL4:
  6171.       error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
  6172.                    ffebld_constant_logical4 (ffebld_conter (l)),
  6173.                   ffebld_constant_logical4 (ffebld_conter (r)));
  6174.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
  6175.                     (ffebld_cu_val_logical4 (u)), expr);
  6176.       break;
  6177. #endif
  6178.  
  6179.     default:
  6180.       assert ("bad logical kind type" == NULL);
  6181.       break;
  6182.     }
  6183.       break;
  6184.  
  6185.     default:
  6186.       assert ("bad type" == NULL);
  6187.       return expr;
  6188.     }
  6189.  
  6190.   ffebld_set_info (expr, ffeinfo_new
  6191.            (bt,
  6192.             kt,
  6193.             0,
  6194.             FFEINFO_kindENTITY,
  6195.             FFEINFO_whereCONSTANT,
  6196.             FFETARGET_charactersizeNONE));
  6197.  
  6198.   if ((error != FFEBAD)
  6199.       && ffebad_start (error))
  6200.     {
  6201.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  6202.       ffebad_finish ();
  6203.     }
  6204.  
  6205.   return expr;
  6206. }
  6207.  
  6208. /* ffeexpr_collapse_xor -- Collapse xor expr
  6209.  
  6210.    ffebld expr;
  6211.    ffelexToken token;
  6212.    expr = ffeexpr_collapse_xor(expr,token);
  6213.  
  6214.    If the result of the expr is a constant, replaces the expr with the
  6215.    computed constant.  */
  6216.  
  6217. ffebld
  6218. ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
  6219. {
  6220.   ffebad error = FFEBAD;
  6221.   ffebld l;
  6222.   ffebld r;
  6223.   ffebldConstantUnion u;
  6224.   ffeinfoBasictype bt;
  6225.   ffeinfoKindtype kt;
  6226.  
  6227.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  6228.     return expr;
  6229.  
  6230.   l = ffebld_left (expr);
  6231.   r = ffebld_right (expr);
  6232.  
  6233.   if (ffebld_op (l) != FFEBLD_opCONTER)
  6234.     return expr;
  6235.   if (ffebld_op (r) != FFEBLD_opCONTER)
  6236.     return expr;
  6237.  
  6238.   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  6239.     {
  6240.     case FFEINFO_basictypeANY:
  6241.       return expr;
  6242.  
  6243.     case FFEINFO_basictypeINTEGER:
  6244.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  6245.     {
  6246. #if FFETARGET_okINTEGER1
  6247.     case FFEINFO_kindtypeINTEGER1:
  6248.       error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
  6249.                    ffebld_constant_integer1 (ffebld_conter (l)),
  6250.                   ffebld_constant_integer1 (ffebld_conter (r)));
  6251.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  6252.                     (ffebld_cu_val_integer1 (u)), expr);
  6253.       break;
  6254. #endif
  6255.  
  6256. #if FFETARGET_okINTEGER2
  6257.     case FFEINFO_kindtypeINTEGER2:
  6258.       error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
  6259.                    ffebld_constant_integer2 (ffebld_conter (l)),
  6260.                   ffebld_constant_integer2 (ffebld_conter (r)));
  6261.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  6262.                     (ffebld_cu_val_integer2 (u)), expr);
  6263.       break;
  6264. #endif
  6265.  
  6266. #if FFETARGET_okINTEGER3
  6267.     case FFEINFO_kindtypeINTEGER3:
  6268.       error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
  6269.                    ffebld_constant_integer3 (ffebld_conter (l)),
  6270.                   ffebld_constant_integer3 (ffebld_conter (r)));
  6271.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  6272.                     (ffebld_cu_val_integer3 (u)), expr);
  6273.       break;
  6274. #endif
  6275.  
  6276. #if FFETARGET_okINTEGER4
  6277.     case FFEINFO_kindtypeINTEGER4:
  6278.       error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
  6279.                    ffebld_constant_integer4 (ffebld_conter (l)),
  6280.                   ffebld_constant_integer4 (ffebld_conter (r)));
  6281.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  6282.                     (ffebld_cu_val_integer4 (u)), expr);
  6283.       break;
  6284. #endif
  6285.  
  6286.     default:
  6287.       assert ("bad integer kind type" == NULL);
  6288.       break;
  6289.     }
  6290.       break;
  6291.  
  6292.     case FFEINFO_basictypeLOGICAL:
  6293.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  6294.     {
  6295. #if FFETARGET_okLOGICAL1
  6296.     case FFEINFO_kindtypeLOGICAL1:
  6297.       error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
  6298.                    ffebld_constant_logical1 (ffebld_conter (l)),
  6299.                   ffebld_constant_logical1 (ffebld_conter (r)));
  6300.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
  6301.                     (ffebld_cu_val_logical1 (u)), expr);
  6302.       break;
  6303. #endif
  6304.  
  6305. #if FFETARGET_okLOGICAL2
  6306.     case FFEINFO_kindtypeLOGICAL2:
  6307.       error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
  6308.                    ffebld_constant_logical2 (ffebld_conter (l)),
  6309.                   ffebld_constant_logical2 (ffebld_conter (r)));
  6310.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
  6311.                     (ffebld_cu_val_logical2 (u)), expr);
  6312.       break;
  6313. #endif
  6314.  
  6315. #if FFETARGET_okLOGICAL3
  6316.     case FFEINFO_kindtypeLOGICAL3:
  6317.       error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
  6318.                    ffebld_constant_logical3 (ffebld_conter (l)),
  6319.                   ffebld_constant_logical3 (ffebld_conter (r)));
  6320.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
  6321.                     (ffebld_cu_val_logical3 (u)), expr);
  6322.       break;
  6323. #endif
  6324.  
  6325. #if FFETARGET_okLOGICAL4
  6326.     case FFEINFO_kindtypeLOGICAL4:
  6327.       error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
  6328.                    ffebld_constant_logical4 (ffebld_conter (l)),
  6329.                   ffebld_constant_logical4 (ffebld_conter (r)));
  6330.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
  6331.                     (ffebld_cu_val_logical4 (u)), expr);
  6332.       break;
  6333. #endif
  6334.  
  6335.     default:
  6336.       assert ("bad logical kind type" == NULL);
  6337.       break;
  6338.     }
  6339.       break;
  6340.  
  6341.     default:
  6342.       assert ("bad type" == NULL);
  6343.       return expr;
  6344.     }
  6345.  
  6346.   ffebld_set_info (expr, ffeinfo_new
  6347.            (bt,
  6348.             kt,
  6349.             0,
  6350.             FFEINFO_kindENTITY,
  6351.             FFEINFO_whereCONSTANT,
  6352.             FFETARGET_charactersizeNONE));
  6353.  
  6354.   if ((error != FFEBAD)
  6355.       && ffebad_start (error))
  6356.     {
  6357.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  6358.       ffebad_finish ();
  6359.     }
  6360.  
  6361.   return expr;
  6362. }
  6363.  
  6364. /* ffeexpr_collapse_eqv -- Collapse eqv expr
  6365.  
  6366.    ffebld expr;
  6367.    ffelexToken token;
  6368.    expr = ffeexpr_collapse_eqv(expr,token);
  6369.  
  6370.    If the result of the expr is a constant, replaces the expr with the
  6371.    computed constant.  */
  6372.  
  6373. ffebld
  6374. ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
  6375. {
  6376.   ffebad error = FFEBAD;
  6377.   ffebld l;
  6378.   ffebld r;
  6379.   ffebldConstantUnion u;
  6380.   ffeinfoBasictype bt;
  6381.   ffeinfoKindtype kt;
  6382.  
  6383.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  6384.     return expr;
  6385.  
  6386.   l = ffebld_left (expr);
  6387.   r = ffebld_right (expr);
  6388.  
  6389.   if (ffebld_op (l) != FFEBLD_opCONTER)
  6390.     return expr;
  6391.   if (ffebld_op (r) != FFEBLD_opCONTER)
  6392.     return expr;
  6393.  
  6394.   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  6395.     {
  6396.     case FFEINFO_basictypeANY:
  6397.       return expr;
  6398.  
  6399.     case FFEINFO_basictypeINTEGER:
  6400.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  6401.     {
  6402. #if FFETARGET_okINTEGER1
  6403.     case FFEINFO_kindtypeINTEGER1:
  6404.       error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
  6405.                    ffebld_constant_integer1 (ffebld_conter (l)),
  6406.                   ffebld_constant_integer1 (ffebld_conter (r)));
  6407.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  6408.                     (ffebld_cu_val_integer1 (u)), expr);
  6409.       break;
  6410. #endif
  6411.  
  6412. #if FFETARGET_okINTEGER2
  6413.     case FFEINFO_kindtypeINTEGER2:
  6414.       error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
  6415.                    ffebld_constant_integer2 (ffebld_conter (l)),
  6416.                   ffebld_constant_integer2 (ffebld_conter (r)));
  6417.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  6418.                     (ffebld_cu_val_integer2 (u)), expr);
  6419.       break;
  6420. #endif
  6421.  
  6422. #if FFETARGET_okINTEGER3
  6423.     case FFEINFO_kindtypeINTEGER3:
  6424.       error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
  6425.                    ffebld_constant_integer3 (ffebld_conter (l)),
  6426.                   ffebld_constant_integer3 (ffebld_conter (r)));
  6427.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  6428.                     (ffebld_cu_val_integer3 (u)), expr);
  6429.       break;
  6430. #endif
  6431.  
  6432. #if FFETARGET_okINTEGER4
  6433.     case FFEINFO_kindtypeINTEGER4:
  6434.       error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
  6435.                    ffebld_constant_integer4 (ffebld_conter (l)),
  6436.                   ffebld_constant_integer4 (ffebld_conter (r)));
  6437.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  6438.                     (ffebld_cu_val_integer4 (u)), expr);
  6439.       break;
  6440. #endif
  6441.  
  6442.     default:
  6443.       assert ("bad integer kind type" == NULL);
  6444.       break;
  6445.     }
  6446.       break;
  6447.  
  6448.     case FFEINFO_basictypeLOGICAL:
  6449.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  6450.     {
  6451. #if FFETARGET_okLOGICAL1
  6452.     case FFEINFO_kindtypeLOGICAL1:
  6453.       error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
  6454.                    ffebld_constant_logical1 (ffebld_conter (l)),
  6455.                   ffebld_constant_logical1 (ffebld_conter (r)));
  6456.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
  6457.                     (ffebld_cu_val_logical1 (u)), expr);
  6458.       break;
  6459. #endif
  6460.  
  6461. #if FFETARGET_okLOGICAL2
  6462.     case FFEINFO_kindtypeLOGICAL2:
  6463.       error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
  6464.                    ffebld_constant_logical2 (ffebld_conter (l)),
  6465.                   ffebld_constant_logical2 (ffebld_conter (r)));
  6466.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
  6467.                     (ffebld_cu_val_logical2 (u)), expr);
  6468.       break;
  6469. #endif
  6470.  
  6471. #if FFETARGET_okLOGICAL3
  6472.     case FFEINFO_kindtypeLOGICAL3:
  6473.       error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
  6474.                    ffebld_constant_logical3 (ffebld_conter (l)),
  6475.                   ffebld_constant_logical3 (ffebld_conter (r)));
  6476.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
  6477.                     (ffebld_cu_val_logical3 (u)), expr);
  6478.       break;
  6479. #endif
  6480.  
  6481. #if FFETARGET_okLOGICAL4
  6482.     case FFEINFO_kindtypeLOGICAL4:
  6483.       error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
  6484.                    ffebld_constant_logical4 (ffebld_conter (l)),
  6485.                   ffebld_constant_logical4 (ffebld_conter (r)));
  6486.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
  6487.                     (ffebld_cu_val_logical4 (u)), expr);
  6488.       break;
  6489. #endif
  6490.  
  6491.     default:
  6492.       assert ("bad logical kind type" == NULL);
  6493.       break;
  6494.     }
  6495.       break;
  6496.  
  6497.     default:
  6498.       assert ("bad type" == NULL);
  6499.       return expr;
  6500.     }
  6501.  
  6502.   ffebld_set_info (expr, ffeinfo_new
  6503.            (bt,
  6504.             kt,
  6505.             0,
  6506.             FFEINFO_kindENTITY,
  6507.             FFEINFO_whereCONSTANT,
  6508.             FFETARGET_charactersizeNONE));
  6509.  
  6510.   if ((error != FFEBAD)
  6511.       && ffebad_start (error))
  6512.     {
  6513.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  6514.       ffebad_finish ();
  6515.     }
  6516.  
  6517.   return expr;
  6518. }
  6519.  
  6520. /* ffeexpr_collapse_neqv -- Collapse neqv expr
  6521.  
  6522.    ffebld expr;
  6523.    ffelexToken token;
  6524.    expr = ffeexpr_collapse_neqv(expr,token);
  6525.  
  6526.    If the result of the expr is a constant, replaces the expr with the
  6527.    computed constant.  */
  6528.  
  6529. ffebld
  6530. ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
  6531. {
  6532.   ffebad error = FFEBAD;
  6533.   ffebld l;
  6534.   ffebld r;
  6535.   ffebldConstantUnion u;
  6536.   ffeinfoBasictype bt;
  6537.   ffeinfoKindtype kt;
  6538.  
  6539.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  6540.     return expr;
  6541.  
  6542.   l = ffebld_left (expr);
  6543.   r = ffebld_right (expr);
  6544.  
  6545.   if (ffebld_op (l) != FFEBLD_opCONTER)
  6546.     return expr;
  6547.   if (ffebld_op (r) != FFEBLD_opCONTER)
  6548.     return expr;
  6549.  
  6550.   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  6551.     {
  6552.     case FFEINFO_basictypeANY:
  6553.       return expr;
  6554.  
  6555.     case FFEINFO_basictypeINTEGER:
  6556.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  6557.     {
  6558. #if FFETARGET_okINTEGER1
  6559.     case FFEINFO_kindtypeINTEGER1:
  6560.       error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
  6561.                    ffebld_constant_integer1 (ffebld_conter (l)),
  6562.                   ffebld_constant_integer1 (ffebld_conter (r)));
  6563.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  6564.                     (ffebld_cu_val_integer1 (u)), expr);
  6565.       break;
  6566. #endif
  6567.  
  6568. #if FFETARGET_okINTEGER2
  6569.     case FFEINFO_kindtypeINTEGER2:
  6570.       error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
  6571.                    ffebld_constant_integer2 (ffebld_conter (l)),
  6572.                   ffebld_constant_integer2 (ffebld_conter (r)));
  6573.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  6574.                     (ffebld_cu_val_integer2 (u)), expr);
  6575.       break;
  6576. #endif
  6577.  
  6578. #if FFETARGET_okINTEGER3
  6579.     case FFEINFO_kindtypeINTEGER3:
  6580.       error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
  6581.                    ffebld_constant_integer3 (ffebld_conter (l)),
  6582.                   ffebld_constant_integer3 (ffebld_conter (r)));
  6583.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  6584.                     (ffebld_cu_val_integer3 (u)), expr);
  6585.       break;
  6586. #endif
  6587.  
  6588. #if FFETARGET_okINTEGER4
  6589.     case FFEINFO_kindtypeINTEGER4:
  6590.       error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
  6591.                    ffebld_constant_integer4 (ffebld_conter (l)),
  6592.                   ffebld_constant_integer4 (ffebld_conter (r)));
  6593.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  6594.                     (ffebld_cu_val_integer4 (u)), expr);
  6595.       break;
  6596. #endif
  6597.  
  6598.     default:
  6599.       assert ("bad integer kind type" == NULL);
  6600.       break;
  6601.     }
  6602.       break;
  6603.  
  6604.     case FFEINFO_basictypeLOGICAL:
  6605.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  6606.     {
  6607. #if FFETARGET_okLOGICAL1
  6608.     case FFEINFO_kindtypeLOGICAL1:
  6609.       error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
  6610.                    ffebld_constant_logical1 (ffebld_conter (l)),
  6611.                   ffebld_constant_logical1 (ffebld_conter (r)));
  6612.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
  6613.                     (ffebld_cu_val_logical1 (u)), expr);
  6614.       break;
  6615. #endif
  6616.  
  6617. #if FFETARGET_okLOGICAL2
  6618.     case FFEINFO_kindtypeLOGICAL2:
  6619.       error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
  6620.                    ffebld_constant_logical2 (ffebld_conter (l)),
  6621.                   ffebld_constant_logical2 (ffebld_conter (r)));
  6622.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
  6623.                     (ffebld_cu_val_logical2 (u)), expr);
  6624.       break;
  6625. #endif
  6626.  
  6627. #if FFETARGET_okLOGICAL3
  6628.     case FFEINFO_kindtypeLOGICAL3:
  6629.       error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
  6630.                    ffebld_constant_logical3 (ffebld_conter (l)),
  6631.                   ffebld_constant_logical3 (ffebld_conter (r)));
  6632.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
  6633.                     (ffebld_cu_val_logical3 (u)), expr);
  6634.       break;
  6635. #endif
  6636.  
  6637. #if FFETARGET_okLOGICAL4
  6638.     case FFEINFO_kindtypeLOGICAL4:
  6639.       error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
  6640.                    ffebld_constant_logical4 (ffebld_conter (l)),
  6641.                   ffebld_constant_logical4 (ffebld_conter (r)));
  6642.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
  6643.                     (ffebld_cu_val_logical4 (u)), expr);
  6644.       break;
  6645. #endif
  6646.  
  6647.     default:
  6648.       assert ("bad logical kind type" == NULL);
  6649.       break;
  6650.     }
  6651.       break;
  6652.  
  6653.     default:
  6654.       assert ("bad type" == NULL);
  6655.       return expr;
  6656.     }
  6657.  
  6658.   ffebld_set_info (expr, ffeinfo_new
  6659.            (bt,
  6660.             kt,
  6661.             0,
  6662.             FFEINFO_kindENTITY,
  6663.             FFEINFO_whereCONSTANT,
  6664.             FFETARGET_charactersizeNONE));
  6665.  
  6666.   if ((error != FFEBAD)
  6667.       && ffebad_start (error))
  6668.     {
  6669.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  6670.       ffebad_finish ();
  6671.     }
  6672.  
  6673.   return expr;
  6674. }
  6675.  
  6676. /* ffeexpr_collapse_symter -- Collapse symter expr
  6677.  
  6678.    ffebld expr;
  6679.    ffelexToken token;
  6680.    expr = ffeexpr_collapse_symter(expr,token);
  6681.  
  6682.    If the result of the expr is a constant, replaces the expr with the
  6683.    computed constant.  */
  6684.  
  6685. ffebld
  6686. ffeexpr_collapse_symter (ffebld expr, ffelexToken t)
  6687. {
  6688.   ffebld r;
  6689.   ffeinfoBasictype bt;
  6690.   ffeinfoKindtype kt;
  6691.   ffetargetCharacterSize len;
  6692.  
  6693.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  6694.     return expr;
  6695.  
  6696.   if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
  6697.     return expr;        /* A PARAMETER lhs in progress. */
  6698.  
  6699.   switch (ffebld_op (r))
  6700.     {
  6701.     case FFEBLD_opCONTER:
  6702.       break;
  6703.  
  6704.     case FFEBLD_opANY:
  6705.       return r;
  6706.  
  6707.     default:
  6708.       return expr;
  6709.     }
  6710.  
  6711.   bt = ffeinfo_basictype (ffebld_info (r));
  6712.   kt = ffeinfo_kindtype (ffebld_info (r));
  6713.   len = ffebld_size (r);
  6714.  
  6715.   expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
  6716.                       expr);
  6717.  
  6718.   ffebld_set_info (expr, ffeinfo_new
  6719.            (bt,
  6720.             kt,
  6721.             0,
  6722.             FFEINFO_kindENTITY,
  6723.             FFEINFO_whereCONSTANT,
  6724.             len));
  6725.  
  6726.   return expr;
  6727. }
  6728.  
  6729. /* ffeexpr_collapse_funcref -- Collapse funcref expr
  6730.  
  6731.    ffebld expr;
  6732.    ffelexToken token;
  6733.    expr = ffeexpr_collapse_funcref(expr,token);
  6734.  
  6735.    If the result of the expr is a constant, replaces the expr with the
  6736.    computed constant.  */
  6737.  
  6738. ffebld
  6739. ffeexpr_collapse_funcref (ffebld expr, ffelexToken t)
  6740. {
  6741.   return expr;            /* ~~someday go ahead and collapse these,
  6742.                    though not required */
  6743. }
  6744.  
  6745. /* ffeexpr_collapse_arrayref -- Collapse arrayref expr
  6746.  
  6747.    ffebld expr;
  6748.    ffelexToken token;
  6749.    expr = ffeexpr_collapse_arrayref(expr,token);
  6750.  
  6751.    If the result of the expr is a constant, replaces the expr with the
  6752.    computed constant.  */
  6753.  
  6754. ffebld
  6755. ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t)
  6756. {
  6757.   return expr;
  6758. }
  6759.  
  6760. /* ffeexpr_collapse_substr -- Collapse substr expr
  6761.  
  6762.    ffebld expr;
  6763.    ffelexToken token;
  6764.    expr = ffeexpr_collapse_substr(expr,token);
  6765.  
  6766.    If the result of the expr is a constant, replaces the expr with the
  6767.    computed constant.  */
  6768.  
  6769. ffebld
  6770. ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
  6771. {
  6772.   ffebad error = FFEBAD;
  6773.   ffebld l;
  6774.   ffebld r;
  6775.   ffebld start;
  6776.   ffebld stop;
  6777.   ffebldConstantUnion u;
  6778.   ffeinfoKindtype kt;
  6779.   ffetargetCharacterSize len;
  6780.   ffetargetIntegerDefault first;
  6781.   ffetargetIntegerDefault last;
  6782.  
  6783.   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  6784.     return expr;
  6785.  
  6786.   l = ffebld_left (expr);
  6787.   r = ffebld_right (expr);    /* opITEM. */
  6788.  
  6789.   if (ffebld_op (l) != FFEBLD_opCONTER)
  6790.     return expr;
  6791.  
  6792.   kt = ffeinfo_kindtype (ffebld_info (l));
  6793.   len = ffebld_size (l);
  6794.  
  6795.   start = ffebld_head (r);
  6796.   stop = ffebld_head (ffebld_trail (r));
  6797.   if (start == NULL)
  6798.     first = 1;
  6799.   else
  6800.     {
  6801.       if ((ffebld_op (start) != FFEBLD_opCONTER)
  6802.       || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
  6803.       || (ffeinfo_kindtype (ffebld_info (start))
  6804.           != FFEINFO_kindtypeINTEGERDEFAULT))
  6805.     return expr;
  6806.       first = ffebld_constant_integerdefault (ffebld_conter (start));
  6807.     }
  6808.   if (stop == NULL)
  6809.     last = len;
  6810.   else
  6811.     {
  6812.       if ((ffebld_op (stop) != FFEBLD_opCONTER)
  6813.       || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
  6814.       || (ffeinfo_kindtype (ffebld_info (stop))
  6815.           != FFEINFO_kindtypeINTEGERDEFAULT))
  6816.     return expr;
  6817.       last = ffebld_constant_integerdefault (ffebld_conter (stop));
  6818.     }
  6819.  
  6820.   /* Handle problems that should have already been diagnosed, but
  6821.      left in the expression tree.  */
  6822.  
  6823.   if (first <= 0)
  6824.     first = 1;
  6825.   if (last < first)
  6826.     last = first + len - 1;
  6827.  
  6828.   if ((first == 1) && (last == len))
  6829.     {                /* Same as original. */
  6830.       expr = ffebld_new_conter_with_orig (ffebld_constant_copy
  6831.                       (ffebld_conter (l)), expr);
  6832.       ffebld_set_info (expr, ffeinfo_new
  6833.                (FFEINFO_basictypeCHARACTER,
  6834.             kt,
  6835.             0,
  6836.             FFEINFO_kindENTITY,
  6837.             FFEINFO_whereCONSTANT,
  6838.             len));
  6839.  
  6840.       return expr;
  6841.     }
  6842.  
  6843.   switch (ffeinfo_basictype (ffebld_info (expr)))
  6844.     {
  6845.     case FFEINFO_basictypeANY:
  6846.       return expr;
  6847.  
  6848.     case FFEINFO_basictypeCHARACTER:
  6849.       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  6850.     {
  6851. #if FFETARGET_okCHARACTER1
  6852.     case FFEINFO_kindtypeCHARACTER1:
  6853.       error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
  6854.         ffebld_constant_character1 (ffebld_conter (l)), first, last,
  6855.                    ffebld_constant_character_pool (), &len);
  6856.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
  6857.                       (ffebld_cu_val_character1 (u)), expr);
  6858.       break;
  6859. #endif
  6860.  
  6861. #if FFETARGET_okCHARACTER2
  6862.     case FFEINFO_kindtypeCHARACTER2:
  6863.       error = ffetarget_substr_character2 (ffebld_cu_ptr_character2 (u),
  6864.         ffebld_constant_character2 (ffebld_conter (l)), first, last,
  6865.                    ffebld_constant_character_pool (), &len);
  6866.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
  6867.                       (ffebld_cu_val_character2 (u)), expr);
  6868.       break;
  6869. #endif
  6870.  
  6871. #if FFETARGET_okCHARACTER3
  6872.     case FFEINFO_kindtypeCHARACTER3:
  6873.       error = ffetarget_substr_character3 (ffebld_cu_ptr_character3 (u),
  6874.         ffebld_constant_character3 (ffebld_conter (l)), first, last,
  6875.                    ffebld_constant_character_pool (), &len);
  6876.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
  6877.                       (ffebld_cu_val_character3 (u)), expr);
  6878.       break;
  6879. #endif
  6880.  
  6881. #if FFETARGET_okCHARACTER4
  6882.     case FFEINFO_kindtypeCHARACTER4:
  6883.       error = ffetarget_substr_character4 (ffebld_cu_ptr_character4 (u),
  6884.         ffebld_constant_character4 (ffebld_conter (l)), first, last,
  6885.                    ffebld_constant_character_pool (), &len);
  6886.       expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
  6887.                       (ffebld_cu_val_character4 (u)), expr);
  6888.       break;
  6889. #endif
  6890.  
  6891.     default:
  6892.       assert ("bad character kind type" == NULL);
  6893.       break;
  6894.     }
  6895.       break;
  6896.  
  6897.     default:
  6898.       assert ("bad type" == NULL);
  6899.       return expr;
  6900.     }
  6901.  
  6902.   ffebld_set_info (expr, ffeinfo_new
  6903.            (FFEINFO_basictypeCHARACTER,
  6904.             kt,
  6905.             0,
  6906.             FFEINFO_kindENTITY,
  6907.             FFEINFO_whereCONSTANT,
  6908.             len));
  6909.  
  6910.   if ((error != FFEBAD)
  6911.       && ffebad_start (error))
  6912.     {
  6913.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  6914.       ffebad_finish ();
  6915.     }
  6916.  
  6917.   return expr;
  6918. }
  6919.  
  6920. /* ffeexpr_convert -- Convert source expression to given type
  6921.  
  6922.    ffebld source;
  6923.    ffelexToken source_token;
  6924.    ffelexToken dest_token;  // Any appropriate token for "destination".
  6925.    ffeinfoBasictype bt;
  6926.    ffeinfoKindtype kt;
  6927.    ffetargetCharactersize sz;
  6928.    ffeexprContext context;  // Mainly LET or DATA.
  6929.    source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
  6930.  
  6931.    If the expression conforms, returns the source expression.  Otherwise
  6932.    returns source wrapped in a convert node doing the conversion, or
  6933.    ANY wrapped in convert if there is a conversion error (and issues an
  6934.    error message).  Be sensitive to the context for certain aspects of
  6935.    the conversion.  */
  6936.  
  6937. ffebld
  6938. ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
  6939.          ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
  6940.          ffetargetCharacterSize sz, ffeexprContext context)
  6941. {
  6942.   bool bad;
  6943.   ffeinfo info;
  6944.   ffeinfoWhere wh;
  6945.  
  6946.   info = ffebld_info (source);
  6947.   if ((bt != ffeinfo_basictype (info))
  6948.       || (kt != ffeinfo_kindtype (info))
  6949.       || (rk != 0)        /* Can't convert from or to arrays yet. */
  6950.       || (ffeinfo_rank (info) != 0)
  6951.       || (sz != ffebld_size_known (source))
  6952.       || ((bt == FFEINFO_basictypeCHARACTER)
  6953.       && (sz == FFETARGET_charactersizeNONE)))
  6954.     {
  6955.       switch (ffeinfo_basictype (info))
  6956.     {
  6957.     case FFEINFO_basictypeLOGICAL:
  6958.       switch (bt)
  6959.         {
  6960.         case FFEINFO_basictypeLOGICAL:
  6961.           bad = FALSE;
  6962.           break;
  6963.  
  6964.         case FFEINFO_basictypeINTEGER:
  6965.           bad = !ffe_is_ugly ();
  6966.           break;
  6967.  
  6968.         case FFEINFO_basictypeCHARACTER:
  6969.           bad = ffe_is_pedantic ()
  6970.         || !(ffe_is_ugly_init ()
  6971.              && (context == FFEEXPR_contextDATA));
  6972.           break;
  6973.           
  6974.         default:
  6975.           bad = TRUE;
  6976.           break;
  6977.         }
  6978.       break;
  6979.  
  6980.     case FFEINFO_basictypeINTEGER:
  6981.       switch (bt)
  6982.         {
  6983.         case FFEINFO_basictypeINTEGER:
  6984.         case FFEINFO_basictypeREAL:
  6985.         case FFEINFO_basictypeCOMPLEX:
  6986.           bad = FALSE;
  6987.           break;
  6988.  
  6989.         case FFEINFO_basictypeLOGICAL:
  6990.           bad = !ffe_is_ugly ();
  6991.           break;
  6992.  
  6993.         case FFEINFO_basictypeCHARACTER:
  6994.           bad = ffe_is_pedantic ()
  6995.         || !(ffe_is_ugly_init ()
  6996.              && (context == FFEEXPR_contextDATA));
  6997.           break;
  6998.           
  6999.         default:
  7000.           bad = TRUE;
  7001.           break;
  7002.         }
  7003.       break;
  7004.  
  7005.     case FFEINFO_basictypeREAL:
  7006.     case FFEINFO_basictypeCOMPLEX:
  7007.       switch (bt)
  7008.         {
  7009.         case FFEINFO_basictypeINTEGER:
  7010.         case FFEINFO_basictypeREAL:
  7011.         case FFEINFO_basictypeCOMPLEX:
  7012.           bad = FALSE;
  7013.           break;
  7014.  
  7015.         case FFEINFO_basictypeCHARACTER:
  7016.           bad = TRUE;
  7017.           break;
  7018.           
  7019.         default:
  7020.           bad = TRUE;
  7021.           break;
  7022.         }
  7023.       break;
  7024.  
  7025.     case FFEINFO_basictypeCHARACTER:
  7026.       bad = (bt != FFEINFO_basictypeCHARACTER)
  7027.         && (ffe_is_pedantic ()
  7028.         || (bt != FFEINFO_basictypeINTEGER)
  7029.         || !(ffe_is_ugly_init ()
  7030.              && (context == FFEEXPR_contextDATA)));
  7031.       break;
  7032.  
  7033.     case FFEINFO_basictypeTYPELESS:
  7034.     case FFEINFO_basictypeHOLLERITH:
  7035.       bad = ffe_is_pedantic ()
  7036.         || !(ffe_is_ugly_init ()
  7037.          || (context == FFEEXPR_contextDATA));
  7038.       break;
  7039.  
  7040.     default:
  7041.       bad = TRUE;
  7042.       break;
  7043.     }
  7044.  
  7045.       if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
  7046.     bad = TRUE;
  7047.  
  7048.       if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
  7049.       && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
  7050.       && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
  7051.       && (ffeinfo_where (info) != FFEINFO_whereANY))
  7052.     {
  7053.       if (ffebad_start (FFEBAD_BAD_TYPES))
  7054.         {
  7055.           if (dest_token == NULL)
  7056.         ffebad_here (0, ffewhere_line_unknown (),
  7057.                  ffewhere_column_unknown ());
  7058.           else
  7059.         ffebad_here (0, ffelex_token_where_line (dest_token),
  7060.                  ffelex_token_where_column (dest_token));
  7061.           ffebad_here (1, ffelex_token_where_line (source_token),
  7062.                ffelex_token_where_column (source_token));
  7063.           ffebad_finish ();
  7064.         }
  7065.  
  7066.       source = ffebld_new_any ();
  7067.       ffebld_set_info (source, ffeinfo_new_any ());
  7068.     }
  7069.       else
  7070.     {
  7071.       switch (ffeinfo_where (info))
  7072.         {
  7073.         case FFEINFO_whereCONSTANT:
  7074.           wh = FFEINFO_whereCONSTANT;
  7075.           break;
  7076.  
  7077.         case FFEINFO_whereIMMEDIATE:
  7078.           wh = FFEINFO_whereIMMEDIATE;
  7079.           break;
  7080.  
  7081.         default:
  7082.           wh = FFEINFO_whereFLEETING;
  7083.           break;
  7084.         }
  7085.       source = ffebld_new_convert (source);
  7086.       ffebld_set_info (source, ffeinfo_new
  7087.                (bt,
  7088.                 kt,
  7089.                 0,
  7090.                 FFEINFO_kindENTITY,
  7091.                 wh,
  7092.                 sz));
  7093.       source = ffeexpr_collapse_convert (source, source_token);
  7094.     }
  7095.     }
  7096.  
  7097.   return source;
  7098. }
  7099.  
  7100. /* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
  7101.  
  7102.    ffebld source;
  7103.    ffebld dest;
  7104.    ffelexToken source_token;
  7105.    ffelexToken dest_token;
  7106.    ffeexprContext context;
  7107.    source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
  7108.  
  7109.    If the expressions conform, returns the source expression.  Otherwise
  7110.    returns source wrapped in a convert node doing the conversion, or
  7111.    ANY wrapped in convert if there is a conversion error (and issues an
  7112.    error message).  Be sensitive to the context, such as LET or DATA.  */
  7113.  
  7114. ffebld
  7115. ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
  7116.               ffelexToken dest_token, ffeexprContext context)
  7117. {
  7118.   ffeinfo info;
  7119.  
  7120.   info = ffebld_info (dest);
  7121.   return ffeexpr_convert (source, source_token, dest_token,
  7122.               ffeinfo_basictype (info),
  7123.               ffeinfo_kindtype (info),
  7124.               ffeinfo_rank (info),
  7125.               ffebld_size_known (dest),
  7126.               context);
  7127. }
  7128.  
  7129. /* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
  7130.  
  7131.    ffebld source;
  7132.    ffesymbol dest;
  7133.    ffelexToken source_token;
  7134.    ffelexToken dest_token;
  7135.    source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
  7136.  
  7137.    If the expressions conform, returns the source expression.  Otherwise
  7138.    returns source wrapped in a convert node doing the conversion, or
  7139.    ANY wrapped in convert if there is a conversion error (and issues an
  7140.    error message).  */
  7141.  
  7142. ffebld
  7143. ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
  7144.             ffesymbol dest, ffelexToken dest_token)
  7145. {
  7146.   return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
  7147.     ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
  7148.               FFEEXPR_contextLET);
  7149. }
  7150.  
  7151. /* Initializes the module.  */
  7152.  
  7153. void
  7154. ffeexpr_init_2 ()
  7155. {
  7156.   ffeexpr_stack_ = NULL;
  7157.   ffeexpr_level_ = 0;
  7158. }
  7159.  
  7160. /* ffeexpr_lhs -- Begin processing left-hand-side-context expression
  7161.  
  7162.    Prepares cluster for delivery of lexer tokens representing an expression
  7163.    in a left-hand-side context (A in A=B, for example).     ffebld is used
  7164.    to build expressions in the given pool.  The appropriate lexer-token
  7165.    handling routine within ffeexpr is returned.     When the end of the
  7166.    expression is detected, mycallbackroutine is called with the resulting
  7167.    single ffebld object specifying the entire expression and the first
  7168.    lexer token that is not considered part of the expression.  This caller-
  7169.    supplied routine itself returns a lexer-token handling routine.  Thus,
  7170.    if necessary, ffeexpr can return several tokens as end-of-expression
  7171.    tokens if it needs to scan forward more than one in any instance.  */
  7172.  
  7173. ffelexHandler
  7174. ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
  7175. {
  7176.   ffeexprStack_ s;
  7177.  
  7178.   ffebld_pool_push (pool);
  7179.   s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
  7180.   s->previous = ffeexpr_stack_;
  7181.   s->pool = pool;
  7182.   s->context = context;
  7183.   s->callback = callback;
  7184.   s->first_token = NULL;
  7185.   s->exprstack = NULL;
  7186.   s->is_rhs = FALSE;
  7187.   ffeexpr_stack_ = s;
  7188.   return (ffelexHandler) ffeexpr_token_first_lhs_;
  7189. }
  7190.  
  7191. /* ffeexpr_rhs -- Begin processing right-hand-side-context expression
  7192.  
  7193.    return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine);  // to lexer.
  7194.  
  7195.    Prepares cluster for delivery of lexer tokens representing an expression
  7196.    in a right-hand-side context (B in A=B, for example).  ffebld is used
  7197.    to build expressions in the given pool.  The appropriate lexer-token
  7198.    handling routine within ffeexpr is returned.     When the end of the
  7199.    expression is detected, mycallbackroutine is called with the resulting
  7200.    single ffebld object specifying the entire expression and the first
  7201.    lexer token that is not considered part of the expression.  This caller-
  7202.    supplied routine itself returns a lexer-token handling routine.  Thus,
  7203.    if necessary, ffeexpr can return several tokens as end-of-expression
  7204.    tokens if it needs to scan forward more than one in any instance.  */
  7205.  
  7206. ffelexHandler
  7207. ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
  7208. {
  7209.   ffeexprStack_ s;
  7210.  
  7211.   ffebld_pool_push (pool);
  7212.   s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
  7213.   s->previous = ffeexpr_stack_;
  7214.   s->pool = pool;
  7215.   s->context = context;
  7216.   s->callback = callback;
  7217.   s->first_token = NULL;
  7218.   s->exprstack = NULL;
  7219.   s->is_rhs = TRUE;
  7220.   ffeexpr_stack_ = s;
  7221.   return (ffelexHandler) ffeexpr_token_first_rhs_;
  7222. }
  7223.  
  7224. /* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
  7225.  
  7226.    Pass it to ffeexpr_rhs as the callback routine.
  7227.  
  7228.    Makes sure the end token is close-paren and swallows it, else issues
  7229.    an error message and doesn't swallow the token (passing it along instead).
  7230.    In either case wraps up subexpression construction by enclosing the
  7231.    ffebld expression in a paren.  */
  7232.  
  7233. static ffelexHandler
  7234. ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
  7235. {
  7236.   ffeexprExpr_ e;
  7237.  
  7238.   /* First push the (parenthesized) expression as an operand onto the
  7239.      expression stack. */
  7240.  
  7241.   e = ffeexpr_expr_new_ ();
  7242.   e->type = FFEEXPR_exprtypeOPERAND_;
  7243.   e->u.operand = ffebld_new_paren (expr);
  7244.   ffebld_set_info (e->u.operand, ffeinfo_use (ffebld_info (expr)));
  7245.   e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
  7246.   e->token = ffeexpr_stack_->tokens[0];
  7247.   ffeexpr_exprstack_push_operand_ (e);
  7248.  
  7249.   /* Now, if the token is a close parenthese, we're in great shape so return
  7250.      the next handler. */
  7251.  
  7252.   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
  7253.     {
  7254.       return (ffelexHandler) ffeexpr_token_binary_;
  7255.     }
  7256.  
  7257.   /* Oops, naughty user didn't specify the close paren! */
  7258.  
  7259.   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
  7260.     {
  7261.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  7262.       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
  7263.            ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
  7264.       ffebad_finish ();
  7265.     }
  7266.  
  7267.   return
  7268.     (ffelexHandler) ffeexpr_find_close_paren_ (t,
  7269.                            (ffelexHandler)
  7270.                            ffeexpr_token_binary_);
  7271. }
  7272.  
  7273. /* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
  7274.  
  7275.    Pass it to ffeexpr_rhs as the callback routine.
  7276.  
  7277.    We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
  7278.    with the next token in t.  If the next token is possibly a binary
  7279.    operator, continue processing the outer expression.    If the next
  7280.    token is COMMA, then the expression is a unit specifier, and
  7281.    parentheses should not be added to it because it surrounds the
  7282.    I/O control list that starts with the unit specifier (and continues
  7283.    on from here -- we haven't seen the CLOSE_PAREN that matches the
  7284.    OPEN_PAREN, it is up to the callback function to expect to see it
  7285.    at some point).  In this case, we notify the callback function that
  7286.    the COMMA is inside, not outside, the parens by wrapping the expression
  7287.    in an opITEM (with a NULL trail) -- the callback function presumably
  7288.    unwraps it after seeing this kludgey indicator.
  7289.  
  7290.    If the next token is CLOSE_PAREN, then we go to the _1_ state to
  7291.    decide what to do with the token after that.
  7292.  
  7293.    15-Feb-91  JCB  1.1
  7294.       Use an extra state for the CLOSE_PAREN case to make READ &co really
  7295.       work right.  */
  7296.  
  7297. static ffelexHandler
  7298. ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
  7299. {
  7300.   ffeexprCallback callback;
  7301.   ffeexprStack_ s;
  7302.  
  7303.   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
  7304.     {                /* Need to see the next token before we
  7305.                    decide anything. */
  7306.       ffeexpr_stack_->expr = expr;
  7307.       ffeexpr_tokens_[0] = ffelex_token_use (ft);
  7308.       ffeexpr_tokens_[1] = ffelex_token_use (t);
  7309.       return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
  7310.     }
  7311.  
  7312.   expr = ffeexpr_finished_ambig_ (ft, expr);
  7313.  
  7314.   /* Let the callback function handle the case where t isn't COMMA. */
  7315.  
  7316.   /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
  7317.      that preceded the expression starts a list of expressions, and the expr
  7318.      hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
  7319.      node.  The callback function should extract the real expr from the head
  7320.      of this opITEM node after testing it. */
  7321.  
  7322.   expr = ffebld_new_item (expr, NULL);
  7323.  
  7324.   ffebld_pool_pop ();
  7325.   callback = ffeexpr_stack_->callback;
  7326.   ffelex_token_kill (ffeexpr_stack_->first_token);
  7327.   s = ffeexpr_stack_->previous;
  7328.   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
  7329.   ffeexpr_stack_ = s;
  7330.   return (ffelexHandler) (*callback) (ft, expr, t);
  7331. }
  7332.  
  7333. /* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
  7334.  
  7335.    See ffeexpr_cb_close_paren_ambig_.
  7336.  
  7337.    We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
  7338.    with the next token in t.  If the next token is possibly a binary
  7339.    operator, continue processing the outer expression.    If the next
  7340.    token is COMMA, the expression is a parenthesized format specifier.
  7341.    If the next token is not EOS or SEMICOLON, then because it is not a
  7342.    binary operator (it is NAME, OPEN_PAREN, &c), the expression is
  7343.    a unit specifier, and parentheses should not be added to it because
  7344.    they surround the I/O control list that consists of only the unit
  7345.    specifier.  If the next token is EOS or SEMICOLON, the statement
  7346.    must be disambiguated by looking at the type of the expression -- a
  7347.    character expression is a parenthesized format specifier, while a
  7348.    non-character expression is a unit specifier.
  7349.  
  7350.    Another issue is how to do the callback so the recipient of the
  7351.    next token knows how to handle it if it is a COMMA.    In all other
  7352.    cases, disambiguation is straightforward: the same approach as the
  7353.    above is used.
  7354.  
  7355.    EXTENSION: in COMMA case, if not pedantic, use same disambiguation
  7356.    as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
  7357.    and apparently other compilers do, as well, and some code out there
  7358.    uses this "feature".
  7359.  
  7360.    19-Feb-91  JCB  1.1
  7361.       Extend to allow COMMA as nondisambiguating by itself.  Remember
  7362.       to not try and check info field for opSTAR, since that expr doesn't
  7363.       have a valid info field.    */
  7364.  
  7365. static ffelexHandler
  7366. ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
  7367. {
  7368.   ffeexprCallback callback;
  7369.   ffeexprStack_ s;
  7370.   ffelexHandler next;
  7371.   ffelexToken orig_ft = ffeexpr_tokens_[0];    /* In case callback clobbers
  7372.                            these. */
  7373.   ffelexToken orig_t = ffeexpr_tokens_[1];
  7374.   ffebld expr = ffeexpr_stack_->expr;
  7375.  
  7376.   switch (ffelex_token_type (t))
  7377.     {
  7378.     case FFELEX_typeCOMMA:    /* Subexpr is parenthesized format specifier. */
  7379.       if (ffe_is_pedantic ())
  7380.     goto pedantic_comma;    /* :::::::::::::::::::: */
  7381.       /* Fall through. */
  7382.     case FFELEX_typeEOS:    /* Ambiguous; use type of expr to
  7383.                    disambiguate. */
  7384.     case FFELEX_typeSEMICOLON:
  7385.       if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
  7386.       || (ffebld_op (expr) == FFEBLD_opSTAR)
  7387.       || (ffeinfo_basictype (ffebld_info (expr))
  7388.           != FFEINFO_basictypeCHARACTER))
  7389.     break;            /* Not a valid CHARACTER entity, can't be a
  7390.                    format spec. */
  7391.       /* Fall through. */
  7392.     default:            /* Binary op (we assume; error otherwise);
  7393.                    format specifier. */
  7394.  
  7395.     pedantic_comma:        /* :::::::::::::::::::: */
  7396.  
  7397.       switch (ffeexpr_stack_->context)
  7398.     {
  7399.     case FFEEXPR_contextFILENUMAMBIG:
  7400.       ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
  7401.       break;
  7402.  
  7403.     case FFEEXPR_contextFILEUNITAMBIG:
  7404.       ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
  7405.       break;
  7406.  
  7407.     default:
  7408.       assert ("bad context" == NULL);
  7409.       break;
  7410.     }
  7411.  
  7412.       ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
  7413.       next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
  7414.       ffelex_token_kill (orig_ft);
  7415.       ffelex_token_kill (orig_t);
  7416.       return (ffelexHandler) (*next) (t);
  7417.  
  7418.     case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
  7419.     case FFELEX_typeNAME:
  7420.       break;
  7421.     }
  7422.  
  7423.   expr = ffeexpr_finished_ambig_ (orig_ft, expr);
  7424.  
  7425.   /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
  7426.      that preceded the expression starts a list of expressions, and the expr
  7427.      hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
  7428.      node.  The callback function should extract the real expr from the head
  7429.      of this opITEM node after testing it. */
  7430.  
  7431.   expr = ffebld_new_item (expr, NULL);
  7432.  
  7433.   ffebld_pool_pop ();
  7434.   callback = ffeexpr_stack_->callback;
  7435.   ffelex_token_kill (ffeexpr_stack_->first_token);
  7436.   s = ffeexpr_stack_->previous;
  7437.   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
  7438.   ffeexpr_stack_ = s;
  7439.   next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
  7440.   ffelex_token_kill (orig_ft);
  7441.   ffelex_token_kill (orig_t);
  7442.   return (ffelexHandler) (*next) (t);
  7443. }
  7444.  
  7445. /* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
  7446.  
  7447.    Pass it to ffeexpr_rhs as the callback routine.
  7448.  
  7449.    Makes sure the end token is close-paren and swallows it, or a comma
  7450.    and handles complex/implied-do possibilities, else issues
  7451.    an error message and doesn't swallow the token (passing it along instead).  */
  7452.  
  7453. static ffelexHandler
  7454. ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
  7455. {
  7456.   /* First check to see if this is a possible complex entity.  It is if the
  7457.      token is a comma. */
  7458.  
  7459.   if (ffelex_token_type (t) == FFELEX_typeCOMMA)
  7460.     {
  7461.       ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
  7462.       ffeexpr_stack_->expr = expr;
  7463.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  7464.                 FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
  7465.     }
  7466.  
  7467.   return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
  7468. }
  7469.  
  7470. /* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
  7471.  
  7472.    Pass it to ffeexpr_rhs as the callback routine.
  7473.  
  7474.    If this token is not a comma, we have a complex constant (or an attempt
  7475.    at one), so handle it accordingly, displaying error messages if the token
  7476.    is not a close-paren.  */
  7477.  
  7478. static ffelexHandler
  7479. ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
  7480. {
  7481.   ffeexprExpr_ e;
  7482.   ffeinfoBasictype lty = ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
  7483.   ffeinfoBasictype rty = ffeinfo_basictype (ffebld_info (expr));
  7484.   ffeinfoKindtype lkt;
  7485.   ffeinfoKindtype rkt;
  7486.   ffeinfoKindtype nkt;
  7487.   bool ok = TRUE;
  7488.   ffebld orig;
  7489.  
  7490.   if ((expr == NULL)
  7491.       || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
  7492.       || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
  7493.       && (((ffebld_op (orig) != FFEBLD_opUMINUS)
  7494.            && (ffebld_op (orig) != FFEBLD_opUPLUS))
  7495.           || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
  7496.       || ((lty != FFEINFO_basictypeINTEGER)
  7497.       && (lty != FFEINFO_basictypeREAL)))
  7498.     {
  7499.       if ((lty != FFEINFO_basictypeANY)
  7500.       && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
  7501.     {
  7502.       ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
  7503.              ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
  7504.       ffebad_string ("real");
  7505.       ffebad_finish ();
  7506.     }
  7507.       ok = FALSE;
  7508.     }
  7509.   if ((expr == NULL)
  7510.       || (ffebld_op (expr) != FFEBLD_opCONTER)
  7511.       || (((orig = ffebld_conter_orig (expr)) != NULL)
  7512.       && (((ffebld_op (orig) != FFEBLD_opUMINUS)
  7513.            && (ffebld_op (orig) != FFEBLD_opUPLUS))
  7514.           || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
  7515.       || ((rty != FFEINFO_basictypeINTEGER)
  7516.       && (rty != FFEINFO_basictypeREAL)))
  7517.     {
  7518.       if ((rty != FFEINFO_basictypeANY)
  7519.       && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
  7520.     {
  7521.       ffebad_here (0, ffelex_token_where_line (ft),
  7522.                ffelex_token_where_column (ft));
  7523.       ffebad_string ("imaginary");
  7524.       ffebad_finish ();
  7525.     }
  7526.       ok = FALSE;
  7527.     }
  7528.  
  7529.   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
  7530.  
  7531.   /* Push the (parenthesized) expression as an operand onto the expression
  7532.      stack. */
  7533.  
  7534.   e = ffeexpr_expr_new_ ();
  7535.   e->type = FFEEXPR_exprtypeOPERAND_;
  7536.   e->token = ffeexpr_stack_->tokens[0];
  7537.  
  7538.   if (ok)
  7539.     {
  7540.       if (lty == FFEINFO_basictypeINTEGER)
  7541.     lkt = FFEINFO_kindtypeREALDEFAULT;
  7542.       else
  7543.     lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
  7544.       if (rty == FFEINFO_basictypeINTEGER)
  7545.     rkt = FFEINFO_kindtypeREALDEFAULT;
  7546.       else
  7547.     rkt = ffeinfo_kindtype (ffebld_info (expr));
  7548.  
  7549.       nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
  7550.       ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
  7551.                ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
  7552.          FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
  7553.                           FFEEXPR_contextLET);
  7554.       expr = ffeexpr_convert (expr,
  7555.                ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
  7556.          FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
  7557.                   FFEEXPR_contextLET);
  7558.     }
  7559.   else
  7560.     nkt = FFEINFO_kindtypeANY;
  7561.  
  7562.   switch (nkt)
  7563.     {
  7564. #if FFETARGET_okCOMPLEX1
  7565.     case FFEINFO_kindtypeREAL1:
  7566.       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
  7567.           (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
  7568.       ffebld_set_info (e->u.operand,
  7569.                ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
  7570.                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
  7571.                     FFETARGET_charactersizeNONE));
  7572.       break;
  7573. #endif
  7574.  
  7575. #if FFETARGET_okCOMPLEX2
  7576.     case FFEINFO_kindtypeREAL2:
  7577.       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
  7578.           (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
  7579.       ffebld_set_info (e->u.operand,
  7580.                ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
  7581.                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
  7582.                     FFETARGET_charactersizeNONE));
  7583.       break;
  7584. #endif
  7585.  
  7586. #if FFETARGET_okCOMPLEX3
  7587.     case FFEINFO_kindtypeREAL3:
  7588.       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
  7589.           (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
  7590.       ffebld_set_info (e->u.operand,
  7591.                ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
  7592.                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
  7593.                     FFETARGET_charactersizeNONE));
  7594.       break;
  7595. #endif
  7596.  
  7597. #if FFETARGET_okCOMPLEX4
  7598.     case FFEINFO_kindtypeREAL4:
  7599.       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex4
  7600.           (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
  7601.       ffebld_set_info (e->u.operand,
  7602.                ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
  7603.                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
  7604.                     FFETARGET_charactersizeNONE));
  7605.       break;
  7606. #endif
  7607.  
  7608.     default:
  7609.       if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
  7610.             ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
  7611.     {
  7612.       ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
  7613.              ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
  7614.       ffebad_finish ();
  7615.     }
  7616.       /* Fall through. */
  7617.     case FFEINFO_kindtypeANY:
  7618.       e->u.operand = ffebld_new_any ();
  7619.       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
  7620.       break;
  7621.     }
  7622.   ffeexpr_exprstack_push_operand_ (e);
  7623.  
  7624.   /* Now, if the token is a close parenthese, we're in great shape so return
  7625.      the next handler. */
  7626.  
  7627.   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
  7628.     return (ffelexHandler) ffeexpr_token_binary_;
  7629.  
  7630.   /* Oops, naughty user didn't specify the close paren! */
  7631.  
  7632.   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
  7633.     {
  7634.       ffebad_here (0, ffelex_token_where_line (t),
  7635.            ffelex_token_where_column (t));
  7636.       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
  7637.            ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
  7638.       ffebad_finish ();
  7639.     }
  7640.  
  7641.   return
  7642.     (ffelexHandler) ffeexpr_find_close_paren_ (t,
  7643.                            (ffelexHandler)
  7644.                            ffeexpr_token_binary_);
  7645. }
  7646.  
  7647. /* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
  7648.                     implied-DO construct)
  7649.  
  7650.    Pass it to ffeexpr_rhs as the callback routine.
  7651.  
  7652.    Makes sure the end token is close-paren and swallows it, or a comma
  7653.    and handles complex/implied-do possibilities, else issues
  7654.    an error message and doesn't swallow the token (passing it along instead).  */
  7655.  
  7656. static ffelexHandler
  7657. ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
  7658. {
  7659.   ffeexprContext ctx;
  7660.  
  7661.   /* First check to see if this is a possible complex or implied-DO entity.
  7662.      It is if the token is a comma. */
  7663.  
  7664.   if (ffelex_token_type (t) == FFELEX_typeCOMMA)
  7665.     {
  7666.       switch (ffeexpr_stack_->context)
  7667.     {
  7668.     case FFEEXPR_contextIOLIST:
  7669.     case FFEEXPR_contextIMPDOITEM_:
  7670.       ctx = FFEEXPR_contextIMPDOITEM_;
  7671.       break;
  7672.  
  7673.     case FFEEXPR_contextIOLISTDF:
  7674.     case FFEEXPR_contextIMPDOITEMDF_:
  7675.       ctx = FFEEXPR_contextIMPDOITEMDF_;
  7676.       break;
  7677.  
  7678.     default:
  7679.       assert ("bad context" == NULL);
  7680.       ctx = FFEEXPR_contextIMPDOITEM_;
  7681.       break;
  7682.     }
  7683.  
  7684.       ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
  7685.       ffeexpr_stack_->expr = expr;
  7686.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  7687.                       ctx, ffeexpr_cb_comma_ci_);
  7688.     }
  7689.  
  7690.   ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
  7691.   return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
  7692. }
  7693.  
  7694. /* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
  7695.  
  7696.    Pass it to ffeexpr_rhs as the callback routine.
  7697.  
  7698.    If this token is not a comma, we have a complex constant (or an attempt
  7699.    at one), so handle it accordingly, displaying error messages if the token
  7700.    is not a close-paren.  If we have a comma here, it is an attempt at an
  7701.    implied-DO, so start making a list accordingly.  Oh, it might be an
  7702.    equal sign also, meaning an implied-DO with only one item in its list.  */
  7703.  
  7704. static ffelexHandler
  7705. ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
  7706. {
  7707.   ffebld fexpr;
  7708.  
  7709.   /* First check to see if this is a possible complex constant.     It is if the
  7710.      token is not a comma or an equals sign, in which case it should be a
  7711.      close-paren. */
  7712.  
  7713.   if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
  7714.       && (ffelex_token_type (t) != FFELEX_typeEQUALS))
  7715.     {
  7716.       ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
  7717.       ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
  7718.       return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
  7719.     }
  7720.  
  7721.   /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
  7722.      construct.     Make a list and handle accordingly. */
  7723.  
  7724.   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
  7725.   fexpr = ffeexpr_stack_->expr;
  7726.   ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
  7727.   ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
  7728.   return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
  7729. }
  7730.  
  7731. /* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
  7732.  
  7733.    Pass it to ffeexpr_rhs as the callback routine.
  7734.  
  7735.    Handle first item in an implied-DO construct.  */
  7736.  
  7737. static ffelexHandler
  7738. ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
  7739. {
  7740.   if (ffelex_token_type (t) != FFELEX_typeCOMMA)
  7741.     {
  7742.       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
  7743.     {
  7744.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  7745.       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
  7746.            ffelex_token_where_column (ffeexpr_stack_->first_token));
  7747.       ffebad_finish ();
  7748.     }
  7749.       ffebld_end_list (&ffeexpr_stack_->bottom);
  7750.       ffeexpr_stack_->expr = ffebld_new_any ();
  7751.       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
  7752.       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
  7753.     return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
  7754.       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
  7755.     }
  7756.  
  7757.   return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
  7758. }
  7759.  
  7760. /* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
  7761.  
  7762.    Pass it to ffeexpr_rhs as the callback routine.
  7763.  
  7764.    Handle first item in an implied-DO construct.  */
  7765.  
  7766. static ffelexHandler
  7767. ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
  7768. {
  7769.   ffeexprContext ctxi;
  7770.   ffeexprContext ctxc;
  7771.  
  7772.   switch (ffeexpr_stack_->context)
  7773.     {
  7774.     case FFEEXPR_contextDATA:
  7775.     case FFEEXPR_contextDATAIMPDOITEM_:
  7776.       ctxi = FFEEXPR_contextDATAIMPDOITEM_;
  7777.       ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
  7778.       break;
  7779.  
  7780.     case FFEEXPR_contextIOLIST:
  7781.     case FFEEXPR_contextIMPDOITEM_:
  7782.       ctxi = FFEEXPR_contextIMPDOITEM_;
  7783.       ctxc = FFEEXPR_contextIMPDOCTRL_;
  7784.       break;
  7785.  
  7786.     case FFEEXPR_contextIOLISTDF:
  7787.     case FFEEXPR_contextIMPDOITEMDF_:
  7788.       ctxi = FFEEXPR_contextIMPDOITEMDF_;
  7789.       ctxc = FFEEXPR_contextIMPDOCTRL_;
  7790.       break;
  7791.  
  7792.     default:
  7793.       assert ("bad context" == NULL);
  7794.       ctxi = FFEEXPR_context;
  7795.       ctxc = FFEEXPR_context;
  7796.       break;
  7797.     }
  7798.  
  7799.   switch (ffelex_token_type (t))
  7800.     {
  7801.     case FFELEX_typeCOMMA:
  7802.       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
  7803.       if (ffeexpr_stack_->is_rhs)
  7804.     return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  7805.                         ctxi, ffeexpr_cb_comma_i_1_);
  7806.       return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
  7807.                       ctxi, ffeexpr_cb_comma_i_1_);
  7808.  
  7809.     case FFELEX_typeEQUALS:
  7810.       ffebld_end_list (&ffeexpr_stack_->bottom);
  7811.  
  7812.       /* Complain if implied-DO variable in list of items to be read.  */
  7813.  
  7814.       if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
  7815.     ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
  7816.                   ffeexpr_stack_->first_token, expr, ft);
  7817.  
  7818.       /* Set doiter flag for all appropriate SYMTERs.  */
  7819.  
  7820.       ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
  7821.  
  7822.       ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
  7823.       ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
  7824.             &ffeexpr_stack_->bottom);
  7825.       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
  7826.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  7827.                       ctxc, ffeexpr_cb_comma_i_2_);
  7828.  
  7829.     default:
  7830.       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
  7831.     {
  7832.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  7833.       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
  7834.            ffelex_token_where_column (ffeexpr_stack_->first_token));
  7835.       ffebad_finish ();
  7836.     }
  7837.       ffebld_end_list (&ffeexpr_stack_->bottom);
  7838.       ffeexpr_stack_->expr = ffebld_new_any ();
  7839.       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
  7840.       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
  7841.     return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
  7842.       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
  7843.     }
  7844. }
  7845.  
  7846. /* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
  7847.  
  7848.    Pass it to ffeexpr_rhs as the callback routine.
  7849.  
  7850.    Handle start-value in an implied-DO construct.  */
  7851.  
  7852. static ffelexHandler
  7853. ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr, ffelexToken t)
  7854. {
  7855.   ffeexprContext ctx;
  7856.  
  7857.   switch (ffeexpr_stack_->context)
  7858.     {
  7859.     case FFEEXPR_contextDATA:
  7860.     case FFEEXPR_contextDATAIMPDOITEM_:
  7861.       ctx = FFEEXPR_contextDATAIMPDOCTRL_;
  7862.       break;
  7863.  
  7864.     case FFEEXPR_contextIOLIST:
  7865.     case FFEEXPR_contextIOLISTDF:
  7866.     case FFEEXPR_contextIMPDOITEM_:
  7867.     case FFEEXPR_contextIMPDOITEMDF_:
  7868.       ctx = FFEEXPR_contextIMPDOCTRL_;
  7869.       break;
  7870.  
  7871.     default:
  7872.       assert ("bad context" == NULL);
  7873.       ctx = FFEEXPR_context;
  7874.       break;
  7875.     }
  7876.  
  7877.   switch (ffelex_token_type (t))
  7878.     {
  7879.     case FFELEX_typeCOMMA:
  7880.       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
  7881.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  7882.                       ctx, ffeexpr_cb_comma_i_3_);
  7883.       break;
  7884.  
  7885.     default:
  7886.       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
  7887.     {
  7888.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  7889.       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
  7890.            ffelex_token_where_column (ffeexpr_stack_->first_token));
  7891.       ffebad_finish ();
  7892.     }
  7893.       ffebld_end_list (&ffeexpr_stack_->bottom);
  7894.       ffeexpr_stack_->expr = ffebld_new_any ();
  7895.       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
  7896.       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
  7897.     return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
  7898.       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
  7899.     }
  7900. }
  7901.  
  7902. /* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
  7903.  
  7904.    Pass it to ffeexpr_rhs as the callback routine.
  7905.  
  7906.    Handle end-value in an implied-DO construct.     */
  7907.  
  7908. static ffelexHandler
  7909. ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr, ffelexToken t)
  7910. {
  7911.   ffeexprContext ctx;
  7912.  
  7913.   switch (ffeexpr_stack_->context)
  7914.     {
  7915.     case FFEEXPR_contextDATA:
  7916.     case FFEEXPR_contextDATAIMPDOITEM_:
  7917.       ctx = FFEEXPR_contextDATAIMPDOCTRL_;
  7918.       break;
  7919.  
  7920.     case FFEEXPR_contextIOLIST:
  7921.     case FFEEXPR_contextIOLISTDF:
  7922.     case FFEEXPR_contextIMPDOITEM_:
  7923.     case FFEEXPR_contextIMPDOITEMDF_:
  7924.       ctx = FFEEXPR_contextIMPDOCTRL_;
  7925.       break;
  7926.  
  7927.     default:
  7928.       assert ("bad context" == NULL);
  7929.       ctx = FFEEXPR_context;
  7930.       break;
  7931.     }
  7932.  
  7933.   switch (ffelex_token_type (t))
  7934.     {
  7935.     case FFELEX_typeCOMMA:
  7936.       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
  7937.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  7938.                       ctx, ffeexpr_cb_comma_i_4_);
  7939.       break;
  7940.  
  7941.     case FFELEX_typeCLOSE_PAREN:
  7942.       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
  7943.       return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
  7944.       break;
  7945.  
  7946.     default:
  7947.       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
  7948.     {
  7949.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  7950.       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
  7951.            ffelex_token_where_column (ffeexpr_stack_->first_token));
  7952.       ffebad_finish ();
  7953.     }
  7954.       ffebld_end_list (&ffeexpr_stack_->bottom);
  7955.       ffeexpr_stack_->expr = ffebld_new_any ();
  7956.       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
  7957.       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
  7958.     return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
  7959.       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
  7960.     }
  7961. }
  7962.  
  7963. /* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
  7964.                    [COMMA expr]
  7965.  
  7966.    Pass it to ffeexpr_rhs as the callback routine.
  7967.  
  7968.    Handle incr-value in an implied-DO construct.  */
  7969.  
  7970. static ffelexHandler
  7971. ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr, ffelexToken t)
  7972. {
  7973.   switch (ffelex_token_type (t))
  7974.     {
  7975.     case FFELEX_typeCLOSE_PAREN:
  7976.       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
  7977.       ffebld_end_list (&ffeexpr_stack_->bottom);
  7978.       {
  7979.     ffebld item;
  7980.  
  7981.     for (item = ffebld_left (ffeexpr_stack_->expr);
  7982.          item != NULL;
  7983.          item = ffebld_trail (item))
  7984.       if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
  7985.         goto replace_with_any;    /* :::::::::::::::::::: */
  7986.  
  7987.     for (item = ffebld_right (ffeexpr_stack_->expr);
  7988.          item != NULL;
  7989.          item = ffebld_trail (item))
  7990.       if ((ffebld_head (item) != NULL)    /* Increment may be NULL. */
  7991.           && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
  7992.         goto replace_with_any;    /* :::::::::::::::::::: */
  7993.       }
  7994.       break;
  7995.  
  7996.     default:
  7997.       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
  7998.     {
  7999.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  8000.       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
  8001.            ffelex_token_where_column (ffeexpr_stack_->first_token));
  8002.       ffebad_finish ();
  8003.     }
  8004.       ffebld_end_list (&ffeexpr_stack_->bottom);
  8005.  
  8006.     replace_with_any:        /* :::::::::::::::::::: */
  8007.  
  8008.       ffeexpr_stack_->expr = ffebld_new_any ();
  8009.       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
  8010.       break;
  8011.     }
  8012.  
  8013.   return (ffelexHandler) ffeexpr_cb_comma_i_5_;
  8014. }
  8015.  
  8016. /* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
  8017.                    [COMMA expr] CLOSE_PAREN
  8018.  
  8019.    Pass it to ffeexpr_rhs as the callback routine.
  8020.  
  8021.    Collects token following implied-DO construct for callback function.     */
  8022.  
  8023. static ffelexHandler
  8024. ffeexpr_cb_comma_i_5_ (ffelexToken t)
  8025. {
  8026.   ffeexprCallback callback;
  8027.   ffeexprStack_ s;
  8028.   ffelexHandler next;
  8029.   ffelexToken ft;
  8030.   ffebld expr;
  8031.   bool terminate;
  8032.  
  8033.   switch (ffeexpr_stack_->context)
  8034.     {
  8035.     case FFEEXPR_contextDATA:
  8036.     case FFEEXPR_contextDATAIMPDOITEM_:
  8037.       terminate = TRUE;
  8038.       break;
  8039.  
  8040.     case FFEEXPR_contextIOLIST:
  8041.     case FFEEXPR_contextIOLISTDF:
  8042.     case FFEEXPR_contextIMPDOITEM_:
  8043.     case FFEEXPR_contextIMPDOITEMDF_:
  8044.       terminate = FALSE;
  8045.       break;
  8046.  
  8047.     default:
  8048.       assert ("bad context" == NULL);
  8049.       terminate = FALSE;
  8050.       break;
  8051.     }
  8052.  
  8053.   ffebld_pool_pop ();
  8054.   callback = ffeexpr_stack_->callback;
  8055.   ft = ffeexpr_stack_->first_token;
  8056.   expr = ffeexpr_stack_->expr;
  8057.   s = ffeexpr_stack_->previous;
  8058.   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
  8059.           sizeof (*ffeexpr_stack_));
  8060.   ffeexpr_stack_ = s;
  8061.   next = (ffelexHandler) (*callback) (ft, expr, t);
  8062.   ffelex_token_kill (ft);
  8063.   if (terminate)
  8064.     {
  8065.       ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
  8066.       --ffeexpr_level_;
  8067.       if (ffeexpr_level_ == 0)
  8068.     ffe_terminate_4 ();
  8069.     }
  8070.   return (ffelexHandler) next;
  8071. }
  8072.  
  8073. /* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
  8074.  
  8075.    Makes sure the end token is close-paren and swallows it, else issues
  8076.    an error message and doesn't swallow the token (passing it along instead).
  8077.    In either case wraps up subexpression construction by enclosing the
  8078.    ffebld expression in a %LOC.     */
  8079.  
  8080. static ffelexHandler
  8081. ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr, ffelexToken t)
  8082. {
  8083.   ffeexprExpr_ e;
  8084.  
  8085.   /* First push the (%LOC) expression as an operand onto the expression
  8086.      stack. */
  8087.  
  8088.   e = ffeexpr_expr_new_ ();
  8089.   e->type = FFEEXPR_exprtypeOPERAND_;
  8090.   e->token = ffeexpr_stack_->tokens[0];
  8091.   e->u.operand = ffebld_new_percent_loc (expr);
  8092.   ffebld_set_info (e->u.operand,
  8093.            ffeinfo_new (FFEINFO_basictypeINTEGER,
  8094.                 FFEINFO_kindtypeINTEGERDEFAULT,
  8095.                 0,
  8096.                 FFEINFO_kindENTITY,
  8097.                 FFEINFO_whereFLEETING,
  8098.                 FFETARGET_charactersizeNONE));
  8099. #if 0                /* ~~ */
  8100.   e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
  8101. #endif
  8102.   ffeexpr_exprstack_push_operand_ (e);
  8103.  
  8104.   /* Now, if the token is a close parenthese, we're in great shape so return
  8105.      the next handler. */
  8106.  
  8107.   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
  8108.     {
  8109.       ffelex_token_kill (ffeexpr_stack_->tokens[1]);
  8110.       return (ffelexHandler) ffeexpr_token_binary_;
  8111.     }
  8112.  
  8113.   /* Oops, naughty user didn't specify the close paren! */
  8114.  
  8115.   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
  8116.     {
  8117.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  8118.       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
  8119.            ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
  8120.       ffebad_finish ();
  8121.     }
  8122.  
  8123.   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
  8124.   return
  8125.     (ffelexHandler) ffeexpr_find_close_paren_ (t,
  8126.                            (ffelexHandler)
  8127.                            ffeexpr_token_binary_);
  8128. }
  8129.  
  8130. /* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
  8131.  
  8132.    Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR).  */
  8133.  
  8134. static ffelexHandler
  8135. ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
  8136. {
  8137.   ffeexprExpr_ e;
  8138.   ffebldOp op;
  8139.  
  8140.   /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
  8141.      such things until the lowest-level expression is reached.  */
  8142.  
  8143.   op = ffebld_op (expr);
  8144.   if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
  8145.       || (op == FFEBLD_opPERCENT_DESCR))
  8146.     {
  8147.       if (ffebad_start (FFEBAD_NESTED_PERCENT))
  8148.     {
  8149.       ffebad_here (0, ffelex_token_where_line (ft),
  8150.                ffelex_token_where_column (ft));
  8151.       ffebad_finish ();
  8152.     }
  8153.  
  8154.       do
  8155.     {
  8156.       expr = ffebld_left (expr);
  8157.       op = ffebld_op (expr);
  8158.     }
  8159.       while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
  8160.          || (op == FFEBLD_opPERCENT_DESCR));
  8161.     }
  8162.  
  8163.   /* Push the expression as an operand onto the expression stack. */
  8164.  
  8165.   e = ffeexpr_expr_new_ ();
  8166.   e->type = FFEEXPR_exprtypeOPERAND_;
  8167.   e->token = ffeexpr_stack_->tokens[0];
  8168.   switch (ffeexpr_stack_->percent)
  8169.     {
  8170.     case FFEEXPR_percentVAL_:
  8171.       e->u.operand = ffebld_new_percent_val (expr);
  8172.       break;
  8173.  
  8174.     case FFEEXPR_percentREF_:
  8175.       e->u.operand = ffebld_new_percent_ref (expr);
  8176.       break;
  8177.  
  8178.     case FFEEXPR_percentDESCR_:
  8179.       e->u.operand = ffebld_new_percent_descr (expr);
  8180.       break;
  8181.  
  8182.     default:
  8183.       assert ("%lossage" == NULL);
  8184.       e->u.operand = expr;
  8185.       break;
  8186.     }
  8187.   ffebld_set_info (e->u.operand,
  8188.            ffeinfo_new (FFEINFO_basictypeNONE,
  8189.                 FFEINFO_kindtypeNONE,
  8190.                 0,
  8191.                 FFEINFO_kindNONE,
  8192.                 FFEINFO_whereNONE,
  8193.                 FFETARGET_charactersizeNONE));
  8194. #if 0                /* ~~ */
  8195.   e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
  8196. #endif
  8197.   ffeexpr_exprstack_push_operand_ (e);
  8198.  
  8199.   /* Now, if the token is a close parenthese, we're in great shape so return
  8200.      the next handler. */
  8201.  
  8202.   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
  8203.     return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
  8204.  
  8205.   /* Oops, naughty user didn't specify the close paren! */
  8206.  
  8207.   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
  8208.     {
  8209.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  8210.       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
  8211.            ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
  8212.       ffebad_finish ();
  8213.     }
  8214.  
  8215.   ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
  8216.   
  8217.   switch (ffeexpr_stack_->context)
  8218.     {
  8219.     case FFEEXPR_contextACTUALARG_:
  8220.       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
  8221.       break;
  8222.       
  8223.     case FFEEXPR_contextINDEXORACTUALARG_:
  8224.       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
  8225.       break;
  8226.       
  8227.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  8228.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
  8229.       break;
  8230.       
  8231.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  8232.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
  8233.       break;
  8234.       
  8235.     default:
  8236.       assert ("bad context?!?!" == NULL);
  8237.       break;
  8238.     }
  8239.  
  8240.   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
  8241.   return
  8242.     (ffelexHandler) ffeexpr_find_close_paren_ (t,
  8243.                            (ffelexHandler)
  8244.                            ffeexpr_cb_end_notloc_1_);
  8245. }
  8246.  
  8247. /* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
  8248.    CLOSE_PAREN
  8249.  
  8250.    Should be COMMA or CLOSE_PAREN, else change back to %LOC.  */
  8251.  
  8252. static ffelexHandler
  8253. ffeexpr_cb_end_notloc_1_ (ffelexToken t)
  8254. {
  8255.   switch (ffelex_token_type (t))
  8256.     {
  8257.     case FFELEX_typeCOMMA:
  8258.     case FFELEX_typeCLOSE_PAREN:
  8259.       switch (ffeexpr_stack_->context)
  8260.     {
  8261.     case FFEEXPR_contextACTUALARG_:
  8262.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  8263.       break;
  8264.  
  8265.     case FFEEXPR_contextINDEXORACTUALARG_:
  8266.       ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
  8267.       break;
  8268.  
  8269.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  8270.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
  8271.       break;
  8272.  
  8273.     default:
  8274.       assert ("bad context?!?!" == NULL);
  8275.       break;
  8276.     }
  8277.       break;
  8278.  
  8279.     default:
  8280.       if (ffebad_start (FFEBAD_INVALID_PERCENT))
  8281.     {
  8282.       ffebad_here (0,
  8283.                ffelex_token_where_line (ffeexpr_stack_->first_token),
  8284.            ffelex_token_where_column (ffeexpr_stack_->first_token));
  8285.       ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
  8286.       ffebad_finish ();
  8287.     }
  8288.  
  8289.       ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
  8290.              FFEBLD_opPERCENT_LOC);
  8291.  
  8292.       switch (ffeexpr_stack_->context)
  8293.     {
  8294.     case FFEEXPR_contextACTUALARG_:
  8295.       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
  8296.       break;
  8297.  
  8298.     case FFEEXPR_contextINDEXORACTUALARG_:
  8299.       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
  8300.       break;
  8301.  
  8302.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  8303.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
  8304.       break;
  8305.       
  8306.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  8307.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
  8308.       break;
  8309.       
  8310.     default:
  8311.       assert ("bad context?!?!" == NULL);
  8312.       break;
  8313.     }
  8314.     }
  8315.  
  8316.   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
  8317.   return
  8318.     (ffelexHandler) ffeexpr_token_binary_ (t);
  8319. }
  8320.  
  8321. /* Process DATA implied-DO iterator variables as this implied-DO level
  8322.    terminates.  At this point, ffeexpr_level_ == 1 when we see the
  8323.    last right-paren in "DATA (A(I),I=1,10)/.../".  */
  8324.  
  8325. static ffesymbol
  8326. ffeexpr_check_impctrl_ (ffesymbol s)
  8327. {
  8328.   assert (s != NULL);
  8329.   assert (ffesymbol_sfdummyparent (s) != NULL);
  8330.  
  8331.   switch (ffesymbol_state (s))
  8332.     {
  8333.     case FFESYMBOL_stateNONE:    /* Used as iterator already. Now let symbol
  8334.                    be used as iterator at any level at or
  8335.                    innermore than the outermost of the
  8336.                    current level and the symbol's current
  8337.                    level. */
  8338.       if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
  8339.     {
  8340.       ffesymbol_signal_change (s);
  8341.       ffesymbol_set_maxentrynum (s, ffeexpr_level_);
  8342.       ffesymbol_signal_unreported (s);
  8343.     }
  8344.       break;
  8345.  
  8346.     case FFESYMBOL_stateSEEN:    /* Seen already in this or other implied-DO.
  8347.                    Error if at outermost level, else it can
  8348.                    still become an iterator. */
  8349.       if ((ffeexpr_level_ == 1)
  8350.       && ffebad_start (FFEBAD_BAD_IMPDCL))
  8351.     {
  8352.       ffebad_string (ffesymbol_text (s));
  8353.       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
  8354.       ffebad_finish ();
  8355.     }
  8356.       break;
  8357.  
  8358.     case FFESYMBOL_stateUNCERTAIN:    /* Iterator. */
  8359.       assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
  8360.       ffesymbol_signal_change (s);
  8361.       ffesymbol_set_state (s, FFESYMBOL_stateNONE);
  8362.       ffesymbol_signal_unreported (s);
  8363.       break;
  8364.  
  8365.     case FFESYMBOL_stateUNDERSTOOD:
  8366.       break;            /* ANY. */
  8367.  
  8368.     default:
  8369.       assert ("Sasha Foo!!" == NULL);
  8370.       break;
  8371.     }
  8372.  
  8373.   return s;
  8374. }
  8375.  
  8376. /* Issue diagnostic if implied-DO variable appears in list of lhs
  8377.    expressions (as in "READ *, (I,I=1,10)").  */
  8378.  
  8379. static void
  8380. ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
  8381.               ffebld dovar, ffelexToken dovar_t)
  8382. {
  8383.   ffebld item;
  8384.   ffesymbol dovar_sym;
  8385.   int itemnum;
  8386.  
  8387.   if (ffebld_op (dovar) != FFEBLD_opSYMTER)
  8388.     return;            /* Presumably opANY. */
  8389.  
  8390.   dovar_sym = ffebld_symter (dovar);
  8391.  
  8392.   for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
  8393.     {
  8394.       if (((item = ffebld_head (list)) != NULL)
  8395.       && (ffebld_op (item) == FFEBLD_opSYMTER)
  8396.       && (ffebld_symter (item) == dovar_sym))
  8397.     {
  8398.       char itemno[20];
  8399.  
  8400.       sprintf (&itemno[0], "%d", itemnum);
  8401.       if (ffebad_start (FFEBAD_DOITER_IMPDO))
  8402.         {
  8403.           ffebad_here (0, ffelex_token_where_line (list_t),
  8404.                ffelex_token_where_column (list_t));
  8405.           ffebad_here (1, ffelex_token_where_line (dovar_t),
  8406.                ffelex_token_where_column (dovar_t));
  8407.           ffebad_string (ffesymbol_text (dovar_sym));
  8408.           ffebad_string (itemno);
  8409.           ffebad_finish ();
  8410.         }
  8411.     }
  8412.     }
  8413. }
  8414.  
  8415. /* Decorate any SYMTERs referencing the DO variable with the "doiter"
  8416.    flag.  */
  8417.  
  8418. static void
  8419. ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
  8420. {
  8421.   ffesymbol dovar_sym;
  8422.  
  8423.   if (ffebld_op (dovar) != FFEBLD_opSYMTER)
  8424.     return;            /* Presumably opANY. */
  8425.  
  8426.   dovar_sym = ffebld_symter (dovar);
  8427.  
  8428.   ffeexpr_update_impdo_sym_ (list, dovar_sym);    /* Recurse! */
  8429. }
  8430.  
  8431. /* Recursive function to update any expr so SYMTERs have "doiter" flag
  8432.    if they refer to the given variable.     */
  8433.  
  8434. static void
  8435. ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
  8436. {
  8437.   tail_recurse:            /* :::::::::::::::::::: */
  8438.  
  8439.   if (expr == NULL)
  8440.     return;
  8441.  
  8442.   switch (ffebld_op (expr))
  8443.     {
  8444.     case FFEBLD_opSYMTER:
  8445.       if (ffebld_symter (expr) == dovar)
  8446.     ffebld_symter_set_is_doiter (expr, TRUE);
  8447.       break;
  8448.  
  8449.     case FFEBLD_opITEM:
  8450.       ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
  8451.       expr = ffebld_trail (expr);
  8452.       goto tail_recurse;    /* :::::::::::::::::::: */
  8453.  
  8454.     default:
  8455.       break;
  8456.     }
  8457.  
  8458.   switch (ffebld_arity (expr))
  8459.     {
  8460.     case 2:
  8461.       ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
  8462.       expr = ffebld_right (expr);
  8463.       goto tail_recurse;    /* :::::::::::::::::::: */
  8464.  
  8465.     case 1:
  8466.       expr = ffebld_left (expr);
  8467.       goto tail_recurse;    /* :::::::::::::::::::: */
  8468.  
  8469.     default:
  8470.       break;
  8471.     }
  8472.  
  8473.   return;
  8474. }
  8475.  
  8476. /* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
  8477.  
  8478.    if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
  8479.        // After zero or more PAREN_ contexts, an IF context exists  */
  8480.  
  8481. static ffeexprContext
  8482. ffeexpr_context_outer_ (ffeexprStack_ s)
  8483. {
  8484.   assert (s != NULL);
  8485.  
  8486.   for (;;)
  8487.     {
  8488.       switch (s->context)
  8489.     {
  8490.     case FFEEXPR_contextPAREN_:
  8491.     case FFEEXPR_contextPARENFILENUM_:
  8492.     case FFEEXPR_contextPARENFILEUNIT_:
  8493.       break;
  8494.  
  8495.     default:
  8496.       return s->context;
  8497.     }
  8498.       s = s->previous;
  8499.       assert (s != NULL);
  8500.     }
  8501. }
  8502.  
  8503. /* ffeexpr_dotdot_ -- Look up name in list of .FOO. possibilities
  8504.  
  8505.    ffeexprDotdot_ d;
  8506.    ffelexToken t;
  8507.    d = ffeexpr_dotdot_(t);
  8508.  
  8509.    Returns the identifier for the name, or the NONE identifier.     */
  8510.  
  8511. static ffeexprDotdot_
  8512. ffeexpr_dotdot_ (ffelexToken t)
  8513. {
  8514.   char *p;
  8515.  
  8516.   switch (ffelex_token_length (t))
  8517.     {
  8518.     case 2:
  8519.       switch (*(p = ffelex_token_text (t)))
  8520.     {
  8521.     case FFESRC_CASE_MATCH_INIT ('E', 'e', match_2e, no_match_2):
  8522.       if (ffesrc_char_match_noninit (*++p, 'Q', 'q'))
  8523.         return FFEEXPR_dotdotEQ_;
  8524.       return FFEEXPR_dotdotNONE_;
  8525.  
  8526.     case FFESRC_CASE_MATCH_INIT ('G', 'g', match_2g, no_match_2):
  8527.       if (ffesrc_char_match_noninit (*++p, 'E', 'e'))
  8528.         return FFEEXPR_dotdotGE_;
  8529.       if (ffesrc_char_match_noninit (*p, 'T', 't'))
  8530.         return FFEEXPR_dotdotGT_;
  8531.       return FFEEXPR_dotdotNONE_;
  8532.  
  8533.     case FFESRC_CASE_MATCH_INIT ('L', 'l', match_2l, no_match_2):
  8534.       if (ffesrc_char_match_noninit (*++p, 'E', 'e'))
  8535.         return FFEEXPR_dotdotLE_;
  8536.       if (ffesrc_char_match_noninit (*p, 'T', 't'))
  8537.         return FFEEXPR_dotdotLT_;
  8538.       return FFEEXPR_dotdotNONE_;
  8539.  
  8540.     case FFESRC_CASE_MATCH_INIT ('N', 'n', match_2n, no_match_2):
  8541.       if (ffesrc_char_match_noninit (*++p, 'E', 'e'))
  8542.         return FFEEXPR_dotdotNE_;
  8543.       return FFEEXPR_dotdotNONE_;
  8544.  
  8545.     case FFESRC_CASE_MATCH_INIT ('O', 'o', match_2o, no_match_2):
  8546.       if (ffesrc_char_match_noninit (*++p, 'R', 'r'))
  8547.         return FFEEXPR_dotdotOR_;
  8548.       return FFEEXPR_dotdotNONE_;
  8549.  
  8550.     default:
  8551.     no_match_2:        /* :::::::::::::::::::: */
  8552.       return FFEEXPR_dotdotNONE_;
  8553.     }
  8554.  
  8555.     case 3:
  8556.       switch (*(p = ffelex_token_text (t)))
  8557.     {
  8558.     case FFESRC_CASE_MATCH_INIT ('A', 'a', match_3a, no_match_3):
  8559.       if ((ffesrc_char_match_noninit (*++p, 'N', 'n'))
  8560.           && (ffesrc_char_match_noninit (*++p, 'D', 'd')))
  8561.         return FFEEXPR_dotdotAND_;
  8562.       return FFEEXPR_dotdotNONE_;
  8563.  
  8564.     case FFESRC_CASE_MATCH_INIT ('E', 'e', match_3e, no_match_3):
  8565.       if ((ffesrc_char_match_noninit (*++p, 'Q', 'q'))
  8566.           && (ffesrc_char_match_noninit (*++p, 'V', 'v')))
  8567.         return FFEEXPR_dotdotEQV_;
  8568.       return FFEEXPR_dotdotNONE_;
  8569.  
  8570.     case FFESRC_CASE_MATCH_INIT ('N', 'n', match_3n, no_match_3):
  8571.       if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
  8572.           && (ffesrc_char_match_noninit (*++p, 'T', 't')))
  8573.         return FFEEXPR_dotdotNOT_;
  8574.       return FFEEXPR_dotdotNONE_;
  8575.  
  8576.     case FFESRC_CASE_MATCH_INIT ('X', 'x', match_3x, no_match_3):
  8577.       if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
  8578.           && (ffesrc_char_match_noninit (*++p, 'R', 'r')))
  8579.         return FFEEXPR_dotdotXOR_;
  8580.       return FFEEXPR_dotdotNONE_;
  8581.  
  8582.     default:
  8583.     no_match_3:        /* :::::::::::::::::::: */
  8584.       return FFEEXPR_dotdotNONE_;
  8585.     }
  8586.  
  8587.     case 4:
  8588.       switch (*(p = ffelex_token_text (t)))
  8589.     {
  8590.     case FFESRC_CASE_MATCH_INIT ('N', 'n', match_4n, no_match_4):
  8591.       if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
  8592.           && (ffesrc_char_match_noninit (*++p, 'Q', 'q'))
  8593.           && (ffesrc_char_match_noninit (*++p, 'V', 'v')))
  8594.         return FFEEXPR_dotdotNEQV_;
  8595.       return FFEEXPR_dotdotNONE_;
  8596.  
  8597.     case FFESRC_CASE_MATCH_INIT ('T', 't', match_4t, no_match_4):
  8598.       if ((ffesrc_char_match_noninit (*++p, 'R', 'r'))
  8599.           && (ffesrc_char_match_noninit (*++p, 'U', 'u'))
  8600.           && (ffesrc_char_match_noninit (*++p, 'E', 'e')))
  8601.         return FFEEXPR_dotdotTRUE_;
  8602.       return FFEEXPR_dotdotNONE_;
  8603.  
  8604.     default:
  8605.     no_match_4:        /* :::::::::::::::::::: */
  8606.       return FFEEXPR_dotdotNONE_;
  8607.     }
  8608.  
  8609.     case 5:
  8610.       if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "FALSE",
  8611.                 "false", "False")
  8612.       == 0)
  8613.     return FFEEXPR_dotdotFALSE_;
  8614.       return FFEEXPR_dotdotNONE_;
  8615.  
  8616.     default:
  8617.       return FFEEXPR_dotdotNONE_;
  8618.     }
  8619. }
  8620.  
  8621. /* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
  8622.  
  8623.    ffeexprPercent_ p;
  8624.    ffelexToken t;
  8625.    p = ffeexpr_percent_(t);
  8626.  
  8627.    Returns the identifier for the name, or the NONE identifier.     */
  8628.  
  8629. static ffeexprPercent_
  8630. ffeexpr_percent_ (ffelexToken t)
  8631. {
  8632.   char *p;
  8633.  
  8634.   switch (ffelex_token_length (t))
  8635.     {
  8636.     case 3:
  8637.       switch (*(p = ffelex_token_text (t)))
  8638.     {
  8639.     case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
  8640.       if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
  8641.           && (ffesrc_char_match_noninit (*++p, 'C', 'c')))
  8642.         return FFEEXPR_percentLOC_;
  8643.       return FFEEXPR_percentNONE_;
  8644.  
  8645.     case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
  8646.       if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
  8647.           && (ffesrc_char_match_noninit (*++p, 'F', 'f')))
  8648.         return FFEEXPR_percentREF_;
  8649.       return FFEEXPR_percentNONE_;
  8650.  
  8651.     case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
  8652.       if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
  8653.           && (ffesrc_char_match_noninit (*++p, 'L', 'l')))
  8654.         return FFEEXPR_percentVAL_;
  8655.       return FFEEXPR_percentNONE_;
  8656.  
  8657.     default:
  8658.     no_match_3:        /* :::::::::::::::::::: */
  8659.       return FFEEXPR_percentNONE_;
  8660.     }
  8661.  
  8662.     case 5:
  8663.       if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
  8664.                 "descr", "Descr") == 0)
  8665.     return FFEEXPR_percentDESCR_;
  8666.       return FFEEXPR_percentNONE_;
  8667.  
  8668.     default:
  8669.       return FFEEXPR_percentNONE_;
  8670.     }
  8671. }
  8672.  
  8673. /* ffeexpr_type_combine_ -- Binop combine types, check for mythical new COMPLEX
  8674.  
  8675.    See prototype.
  8676.  
  8677.    If combining the two basictype/kindtype pairs produces a COMPLEX with an
  8678.    unsupported kind type, complain and use the default kind type for
  8679.    COMPLEX.  */
  8680.  
  8681. static void
  8682. ffeexpr_type_combine_ (ffeinfoBasictype *nbt, ffeinfoKindtype *nkt,
  8683.         ffeinfoBasictype lbt, ffeinfoKindtype lkt, ffeinfoBasictype rbt,
  8684.                ffeinfoKindtype rkt, ffeexprExpr_ op)
  8685. {
  8686.   *nbt = ffeinfo_basictype_combine (lbt, rbt);
  8687.   if ((*nbt == FFEINFO_basictypeCOMPLEX)
  8688.       && ((lbt == *nbt) || (lbt == FFEINFO_basictypeREAL))
  8689.       && ((rbt == *nbt) || (rbt == FFEINFO_basictypeREAL)))
  8690.     {
  8691.       *nkt = ffeinfo_kindtype_max (*nbt, lkt, rkt);
  8692.       if (ffe_is_pedantic_not_90 () && (*nkt == FFEINFO_kindtypeREALDOUBLE))
  8693.     *nkt = FFEINFO_kindtypeNONE;    /* Force error. */
  8694.       switch (*nkt)
  8695.     {
  8696. #if FFETARGET_okCOMPLEX1
  8697.     case FFEINFO_kindtypeREAL1:
  8698. #endif
  8699. #if FFETARGET_okCOMPLEX2
  8700.     case FFEINFO_kindtypeREAL2:
  8701. #endif
  8702. #if FFETARGET_okCOMPLEX3
  8703.     case FFEINFO_kindtypeREAL3:
  8704. #endif
  8705. #if FFETARGET_okCOMPLEX4
  8706.     case FFEINFO_kindtypeREAL4:
  8707. #endif
  8708.       break;        /* Fine and dandy. */
  8709.  
  8710.     default:
  8711.       ffebad_start ((*nkt == FFEINFO_kindtypeREALDOUBLE)
  8712.             ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
  8713.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  8714.       ffebad_finish ();
  8715.       /* Fall through. */
  8716.     case FFEINFO_kindtypeANY:
  8717.       *nkt = FFEINFO_kindtypeREALDEFAULT;
  8718.       break;
  8719.     }
  8720.     }
  8721.   else
  8722.     {                /* The normal stuff. */
  8723.       if (*nbt == lbt)
  8724.     if (*nbt == rbt)
  8725.       *nkt = ffeinfo_kindtype_max (*nbt, lkt, rkt);
  8726.     else
  8727.       *nkt = lkt;
  8728.       else if (*nbt == rbt)
  8729.     *nkt = rkt;
  8730.       else
  8731.     {            /* Let the caller do the complaining. */
  8732.       *nbt = FFEINFO_basictypeNONE;
  8733.       *nkt = FFEINFO_kindtypeNONE;
  8734.     }
  8735.     }
  8736. }
  8737.  
  8738. /* ffeexpr_token_first_lhs_ -- First state for lhs expression
  8739.  
  8740.    Return a pointer to this function to the lexer (ffelex), which will
  8741.    invoke it for the next token.
  8742.  
  8743.    Record line and column of first token in expression, then invoke the
  8744.    initial-state lhs handler.  */
  8745.  
  8746. static ffelexHandler
  8747. ffeexpr_token_first_lhs_ (ffelexToken t)
  8748. {
  8749.   ffeexpr_stack_->first_token = ffelex_token_use (t);
  8750.  
  8751.   /* When changing the list of valid initial lhs tokens, check whether to
  8752.      update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
  8753.      READ (expr) <token> case -- it assumes it knows which tokens <token> can
  8754.      be to indicate an lhs (or implied DO), which right now is the set
  8755.      {NAME,OPEN_PAREN}.
  8756.  
  8757.      This comment also appears in ffeexpr_token_lhs_. */
  8758.  
  8759.   switch (ffelex_token_type (t))
  8760.     {
  8761.     case FFELEX_typeOPEN_PAREN:
  8762.       switch (ffeexpr_stack_->context)
  8763.     {
  8764.     case FFEEXPR_contextDATA:
  8765.       ffe_init_4 ();
  8766.       ffeexpr_level_ = 1;    /* Level of DATA implied-DO construct. */
  8767.       ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
  8768.       return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
  8769.             FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
  8770.  
  8771.     case FFEEXPR_contextDATAIMPDOITEM_:
  8772.       ++ffeexpr_level_;    /* Level of DATA implied-DO construct. */
  8773.       ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
  8774.       return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
  8775.             FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
  8776.  
  8777.     case FFEEXPR_contextIOLIST:
  8778.     case FFEEXPR_contextIMPDOITEM_:
  8779.       ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
  8780.       return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
  8781.                 FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
  8782.  
  8783.     case FFEEXPR_contextIOLISTDF:
  8784.     case FFEEXPR_contextIMPDOITEMDF_:
  8785.       ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
  8786.       return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
  8787.               FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
  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.     case FFELEX_typeNAME:
  8799.       switch (ffeexpr_stack_->context)
  8800.     {
  8801.     case FFEEXPR_contextFILENAMELIST:
  8802.       assert (ffeexpr_stack_->exprstack == NULL);
  8803.       return (ffelexHandler) ffeexpr_token_namelist_;
  8804.  
  8805.     case FFEEXPR_contextFILEEXTFUNC:
  8806.       assert (ffeexpr_stack_->exprstack == NULL);
  8807.       return (ffelexHandler) ffeexpr_token_first_lhs_1_;
  8808.  
  8809.     default:
  8810.       break;
  8811.     }
  8812.       break;
  8813.  
  8814.     default:
  8815.       switch (ffeexpr_stack_->context)
  8816.     {
  8817.     case FFEEXPR_contextFILEEXTFUNC:
  8818.       assert (ffeexpr_stack_->exprstack == NULL);
  8819.       return (ffelexHandler) ffeexpr_token_first_lhs_1_;
  8820.  
  8821.     default:
  8822.       break;
  8823.     }
  8824.       break;
  8825.     }
  8826.  
  8827.   return (ffelexHandler) ffeexpr_token_lhs_ (t);
  8828. }
  8829.  
  8830. /* ffeexpr_token_first_lhs_1_ -- NAME
  8831.  
  8832.    return ffeexpr_token_first_lhs_1_;  // to lexer
  8833.  
  8834.    Handle NAME as an external function (USEROPEN= VXT extension to OPEN
  8835.    statement).    */
  8836.  
  8837. static ffelexHandler
  8838. ffeexpr_token_first_lhs_1_ (ffelexToken t)
  8839. {
  8840.   ffeexprCallback callback;
  8841.   ffeexprStack_ s;
  8842.   ffelexHandler next;
  8843.   ffelexToken ft;
  8844.   ffesymbol sy = NULL;
  8845.   ffebld expr;
  8846.  
  8847.   ffebld_pool_pop ();
  8848.   callback = ffeexpr_stack_->callback;
  8849.   ft = ffeexpr_stack_->first_token;
  8850.   s = ffeexpr_stack_->previous;
  8851.  
  8852.   if ((ffelex_token_type (ft) != FFELEX_typeNAME)
  8853.       || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
  8854.       & FFESYMBOL_attrANY))
  8855.     {
  8856.       if ((ffelex_token_type (ft) != FFELEX_typeNAME)
  8857.       || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
  8858.     {
  8859.       ffebad_start (FFEBAD_EXPR_WRONG);
  8860.       ffebad_here (0, ffelex_token_where_line (ft),
  8861.                ffelex_token_where_column (ft));
  8862.       ffebad_finish ();
  8863.     }
  8864.       expr = ffebld_new_any ();
  8865.       ffebld_set_info (expr, ffeinfo_new_any ());
  8866.     }
  8867.   else
  8868.     {
  8869.       expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
  8870.                 FFEINTRIN_impNONE);
  8871.       ffebld_set_info (expr, ffesymbol_info (sy));
  8872.     }
  8873.  
  8874.   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
  8875.           sizeof (*ffeexpr_stack_));
  8876.   ffeexpr_stack_ = s;
  8877.  
  8878.   next = (ffelexHandler) (*callback) (ft, expr, t);
  8879.   ffelex_token_kill (ft);
  8880.   return (ffelexHandler) next;
  8881. }
  8882.  
  8883. /* ffeexpr_token_first_rhs_ -- First state for rhs expression
  8884.  
  8885.    Record line and column of first token in expression, then invoke the
  8886.    initial-state rhs handler.
  8887.  
  8888.    19-Feb-91  JCB  1.1
  8889.       Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
  8890.       (i.e. only as in READ(*), not READ((*))).     */
  8891.  
  8892. static ffelexHandler
  8893. ffeexpr_token_first_rhs_ (ffelexToken t)
  8894. {
  8895.   ffesymbol s;
  8896.  
  8897.   ffeexpr_stack_->first_token = ffelex_token_use (t);
  8898.  
  8899.   switch (ffelex_token_type (t))
  8900.     {
  8901.     case FFELEX_typeASTERISK:
  8902.       switch (ffeexpr_stack_->context)
  8903.     {
  8904.     case FFEEXPR_contextFILEFORMATNML:
  8905.       ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
  8906.       /* Fall through.  */
  8907.     case FFEEXPR_contextFILEUNIT:
  8908.     case FFEEXPR_contextDIMLIST:
  8909.     case FFEEXPR_contextFILEFORMAT:
  8910.     case FFEEXPR_contextCHARACTERSIZE:
  8911.       if (ffeexpr_stack_->previous != NULL)
  8912.         break;        /* Valid only on first level. */
  8913.       assert (ffeexpr_stack_->exprstack == NULL);
  8914.       return (ffelexHandler) ffeexpr_token_first_rhs_1_;
  8915.  
  8916.     case FFEEXPR_contextPARENFILEUNIT_:
  8917.       if (ffeexpr_stack_->previous->previous != NULL)
  8918.         break;        /* Valid only on second level. */
  8919.       assert (ffeexpr_stack_->exprstack == NULL);
  8920.       return (ffelexHandler) ffeexpr_token_first_rhs_1_;
  8921.  
  8922.     case FFEEXPR_contextACTUALARG_:
  8923.       if (ffeexpr_stack_->previous->context
  8924.           != FFEEXPR_contextSUBROUTINEREF)
  8925.         {
  8926.           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
  8927.           break;
  8928.         }
  8929.       assert (ffeexpr_stack_->exprstack == NULL);
  8930.       return (ffelexHandler) ffeexpr_token_first_rhs_3_;
  8931.  
  8932.     case FFEEXPR_contextINDEXORACTUALARG_:
  8933.       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
  8934.       break;
  8935.  
  8936.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  8937.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
  8938.       break;
  8939.  
  8940.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  8941.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
  8942.       break;
  8943.  
  8944.     default:
  8945.       break;
  8946.     }
  8947.       break;
  8948.  
  8949.     case FFELEX_typeOPEN_PAREN:
  8950.       switch (ffeexpr_stack_->context)
  8951.     {
  8952.     case FFEEXPR_contextFILENUMAMBIG:
  8953.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  8954.                           FFEEXPR_contextPARENFILENUM_,
  8955.                           ffeexpr_cb_close_paren_ambig_);
  8956.  
  8957.     case FFEEXPR_contextFILEUNITAMBIG:
  8958.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  8959.                           FFEEXPR_contextPARENFILEUNIT_,
  8960.                           ffeexpr_cb_close_paren_ambig_);
  8961.  
  8962.     case FFEEXPR_contextIOLIST:
  8963.     case FFEEXPR_contextIMPDOITEM_:
  8964.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  8965.                           FFEEXPR_contextIMPDOITEM_,
  8966.                           ffeexpr_cb_close_paren_ci_);
  8967.  
  8968.     case FFEEXPR_contextIOLISTDF:
  8969.     case FFEEXPR_contextIMPDOITEMDF_:
  8970.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  8971.                           FFEEXPR_contextIMPDOITEMDF_,
  8972.                           ffeexpr_cb_close_paren_ci_);
  8973.  
  8974.     case FFEEXPR_contextFILEFORMATNML:
  8975.       ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
  8976.       break;
  8977.  
  8978.     case FFEEXPR_contextACTUALARG_:
  8979.       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
  8980.       break;
  8981.  
  8982.     case FFEEXPR_contextINDEXORACTUALARG_:
  8983.       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
  8984.       break;
  8985.  
  8986.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  8987.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
  8988.       break;
  8989.  
  8990.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  8991.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
  8992.       break;
  8993.  
  8994.     default:
  8995.       break;
  8996.     }
  8997.       break;
  8998.  
  8999.     case FFELEX_typeNUMBER:
  9000.       switch (ffeexpr_stack_->context)
  9001.     {
  9002.     case FFEEXPR_contextFILEFORMATNML:
  9003.       ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
  9004.       /* Fall through.  */
  9005.     case FFEEXPR_contextFILEFORMAT:
  9006.       if (ffeexpr_stack_->previous != NULL)
  9007.         break;        /* Valid only on first level. */
  9008.       assert (ffeexpr_stack_->exprstack == NULL);
  9009.       return (ffelexHandler) ffeexpr_token_first_rhs_2_;
  9010.  
  9011.     case FFEEXPR_contextACTUALARG_:
  9012.       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
  9013.       break;
  9014.  
  9015.     case FFEEXPR_contextINDEXORACTUALARG_:
  9016.       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
  9017.       break;
  9018.  
  9019.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  9020.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
  9021.       break;
  9022.  
  9023.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  9024.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
  9025.       break;
  9026.  
  9027.     default:
  9028.       break;
  9029.     }
  9030.       break;
  9031.  
  9032.     case FFELEX_typeNAME:
  9033.       switch (ffeexpr_stack_->context)
  9034.     {
  9035.     case FFEEXPR_contextFILEFORMATNML:
  9036.       assert (ffeexpr_stack_->exprstack == NULL);
  9037.       s = ffesymbol_lookup_local (t);
  9038.       if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
  9039.         return (ffelexHandler) ffeexpr_token_namelist_;
  9040.       ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
  9041.       break;
  9042.  
  9043.     default:
  9044.       break;
  9045.     }
  9046.       break;
  9047.  
  9048.     case FFELEX_typePERCENT:
  9049.       switch (ffeexpr_stack_->context)
  9050.     {
  9051.     case FFEEXPR_contextACTUALARG_:
  9052.     case FFEEXPR_contextINDEXORACTUALARG_:
  9053.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  9054.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  9055.       return (ffelexHandler) ffeexpr_token_first_rhs_5_;
  9056.  
  9057.     case FFEEXPR_contextFILEFORMATNML:
  9058.       ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
  9059.       break;
  9060.  
  9061.     default:
  9062.       break;
  9063.     }
  9064.  
  9065.     default:
  9066.       switch (ffeexpr_stack_->context)
  9067.     {
  9068.     case FFEEXPR_contextACTUALARG_:
  9069.       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
  9070.       break;
  9071.  
  9072.     case FFEEXPR_contextINDEXORACTUALARG_:
  9073.       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
  9074.       break;
  9075.  
  9076.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  9077.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
  9078.       break;
  9079.  
  9080.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  9081.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
  9082.       break;
  9083.  
  9084.     case FFEEXPR_contextFILEFORMATNML:
  9085.       ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
  9086.       break;
  9087.  
  9088.     default:
  9089.       break;
  9090.     }
  9091.       break;
  9092.     }
  9093.  
  9094.   return (ffelexHandler) ffeexpr_token_rhs_ (t);
  9095. }
  9096.  
  9097. /* ffeexpr_token_first_rhs_1_ -- ASTERISK
  9098.  
  9099.    return ffeexpr_token_first_rhs_1_;  // to lexer
  9100.  
  9101.    Return STAR as expression.  */
  9102.  
  9103. static ffelexHandler
  9104. ffeexpr_token_first_rhs_1_ (ffelexToken t)
  9105. {
  9106.   ffebld expr;
  9107.   ffeexprCallback callback;
  9108.   ffeexprStack_ s;
  9109.   ffelexHandler next;
  9110.   ffelexToken ft;
  9111.  
  9112.   expr = ffebld_new_star ();
  9113.   ffebld_pool_pop ();
  9114.   callback = ffeexpr_stack_->callback;
  9115.   ft = ffeexpr_stack_->first_token;
  9116.   s = ffeexpr_stack_->previous;
  9117.   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
  9118.   ffeexpr_stack_ = s;
  9119.   next = (ffelexHandler) (*callback) (ft, expr, t);
  9120.   ffelex_token_kill (ft);
  9121.   return (ffelexHandler) next;
  9122. }
  9123.  
  9124. /* ffeexpr_token_first_rhs_2_ -- NUMBER
  9125.  
  9126.    return ffeexpr_token_first_rhs_2_;  // to lexer
  9127.  
  9128.    Return NULL as expression; NUMBER as first (and only) token, unless the
  9129.    current token is not a terminating token, in which case run normal
  9130.    expression handling.     */
  9131.  
  9132. static ffelexHandler
  9133. ffeexpr_token_first_rhs_2_ (ffelexToken t)
  9134. {
  9135.   ffeexprCallback callback;
  9136.   ffeexprStack_ s;
  9137.   ffelexHandler next;
  9138.   ffelexToken ft;
  9139.  
  9140.   switch (ffelex_token_type (t))
  9141.     {
  9142.     case FFELEX_typeCLOSE_PAREN:
  9143.     case FFELEX_typeCOMMA:
  9144.     case FFELEX_typeEOS:
  9145.     case FFELEX_typeSEMICOLON:
  9146.       break;
  9147.  
  9148.     default:
  9149.       next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
  9150.       return (ffelexHandler) (*next) (t);
  9151.     }
  9152.  
  9153.   ffebld_pool_pop ();
  9154.   callback = ffeexpr_stack_->callback;
  9155.   ft = ffeexpr_stack_->first_token;
  9156.   s = ffeexpr_stack_->previous;
  9157.   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
  9158.           sizeof (*ffeexpr_stack_));
  9159.   ffeexpr_stack_ = s;
  9160.   next = (ffelexHandler) (*callback) (ft, NULL, t);
  9161.   ffelex_token_kill (ft);
  9162.   return (ffelexHandler) next;
  9163. }
  9164.  
  9165. /* ffeexpr_token_first_rhs_3_ -- ASTERISK
  9166.  
  9167.    return ffeexpr_token_first_rhs_3_;  // to lexer
  9168.  
  9169.    Expect NUMBER, make LABTOK (with copy of token if not inhibited after
  9170.    confirming, else NULL).  */
  9171.  
  9172. static ffelexHandler
  9173. ffeexpr_token_first_rhs_3_ (ffelexToken t)
  9174. {
  9175.   ffelexHandler next;
  9176.  
  9177.   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
  9178.     {                /* An error, but let normal processing handle
  9179.                    it. */
  9180.       next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
  9181.       return (ffelexHandler) (*next) (t);
  9182.     }
  9183.  
  9184.   /* Special case: when we see "*10" as an argument to a subroutine
  9185.      reference, we confirm the current statement and, if not inhibited at
  9186.      this point, put a copy of the token into a LABTOK node.  We do this
  9187.      instead of just resolving the label directly via ffelab and putting it
  9188.      into a LABTER simply to improve error reporting and consistency in
  9189.      ffestc.  We put NULL in the LABTOK if we're still inhibited, so ffestb
  9190.      doesn't have to worry about killing off any tokens when retracting. */
  9191.  
  9192.   ffest_confirmed ();
  9193.   if (ffest_is_inhibited ())
  9194.     ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
  9195.   else
  9196.     ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
  9197.  
  9198.   return (ffelexHandler) ffeexpr_token_first_rhs_4_;
  9199. }
  9200.  
  9201. /* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
  9202.  
  9203.    return ffeexpr_token_first_rhs_4_;  // to lexer
  9204.  
  9205.    Collect/flush appropriate stuff, send token to callback function.  */
  9206.  
  9207. static ffelexHandler
  9208. ffeexpr_token_first_rhs_4_ (ffelexToken t)
  9209. {
  9210.   ffebld expr;
  9211.   ffeexprCallback callback;
  9212.   ffeexprStack_ s;
  9213.   ffelexHandler next;
  9214.   ffelexToken ft;
  9215.  
  9216.   expr = ffeexpr_stack_->expr;
  9217.   ffebld_pool_pop ();
  9218.   callback = ffeexpr_stack_->callback;
  9219.   ft = ffeexpr_stack_->first_token;
  9220.   s = ffeexpr_stack_->previous;
  9221.   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
  9222.   ffeexpr_stack_ = s;
  9223.   next = (ffelexHandler) (*callback) (ft, expr, t);
  9224.   ffelex_token_kill (ft);
  9225.   return (ffelexHandler) next;
  9226. }
  9227.  
  9228. /* ffeexpr_token_first_rhs_5_ -- PERCENT
  9229.  
  9230.    Should be NAME, or pass through original mechanism.  If NAME is LOC,
  9231.    pass through original mechanism, otherwise must be VAL, REF, or DESCR,
  9232.    in which case handle the argument (in parentheses), etc.  */
  9233.  
  9234. static ffelexHandler
  9235. ffeexpr_token_first_rhs_5_ (ffelexToken t)
  9236. {
  9237.   ffelexHandler next;
  9238.  
  9239.   if (ffelex_token_type (t) == FFELEX_typeNAME)
  9240.     {
  9241.       ffeexprPercent_ p = ffeexpr_percent_ (t);
  9242.  
  9243.       switch (p)
  9244.     {
  9245.     case FFEEXPR_percentNONE_:
  9246.     case FFEEXPR_percentLOC_:
  9247.       break;        /* Treat %LOC as any other expression. */
  9248.  
  9249.     case FFEEXPR_percentVAL_:
  9250.     case FFEEXPR_percentREF_:
  9251.     case FFEEXPR_percentDESCR_:
  9252.       ffeexpr_stack_->percent = p;
  9253.       ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
  9254.       return (ffelexHandler) ffeexpr_token_first_rhs_6_;
  9255.  
  9256.     default:
  9257.       assert ("bad percent?!?" == NULL);
  9258.       break;
  9259.     }
  9260.     }
  9261.  
  9262.   switch (ffeexpr_stack_->context)
  9263.     {
  9264.     case FFEEXPR_contextACTUALARG_:
  9265.       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
  9266.       break;
  9267.  
  9268.     case FFEEXPR_contextINDEXORACTUALARG_:
  9269.       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
  9270.       break;
  9271.  
  9272.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  9273.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
  9274.       break;
  9275.  
  9276.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  9277.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
  9278.       break;
  9279.  
  9280.     default:
  9281.       assert ("bad context?!?!" == NULL);
  9282.       break;
  9283.     }
  9284.  
  9285.   next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
  9286.   return (ffelexHandler) (*next) (t);
  9287. }
  9288.  
  9289. /* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
  9290.  
  9291.    Should be OPEN_PAREN, or pass through original mechanism.  */
  9292.  
  9293. static ffelexHandler
  9294. ffeexpr_token_first_rhs_6_ (ffelexToken t)
  9295. {
  9296.   ffelexHandler next;
  9297.   ffelexToken ft;
  9298.  
  9299.   if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
  9300.     {
  9301.       ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
  9302.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  9303.                       ffeexpr_stack_->context,
  9304.                       ffeexpr_cb_end_notloc_);
  9305.     }
  9306.  
  9307.   switch (ffeexpr_stack_->context)
  9308.     {
  9309.     case FFEEXPR_contextACTUALARG_:
  9310.       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
  9311.       break;
  9312.  
  9313.     case FFEEXPR_contextINDEXORACTUALARG_:
  9314.       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
  9315.       break;
  9316.  
  9317.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  9318.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
  9319.       break;
  9320.  
  9321.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  9322.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
  9323.       break;
  9324.  
  9325.     default:
  9326.       assert ("bad context?!?!" == NULL);
  9327.       break;
  9328.     }
  9329.  
  9330.   ft = ffeexpr_stack_->tokens[0];
  9331.   next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
  9332.   next = (ffelexHandler) (*next) (ft);
  9333.   ffelex_token_kill (ft);
  9334.   return (ffelexHandler) (*next) (t);
  9335. }
  9336.  
  9337. /* ffeexpr_token_namelist_ -- NAME
  9338.  
  9339.    return ffeexpr_token_namelist_;  // to lexer
  9340.  
  9341.    Make sure NAME was a valid namelist object, wrap it in a SYMTER and
  9342.    return.  */
  9343.  
  9344. static ffelexHandler
  9345. ffeexpr_token_namelist_ (ffelexToken t)
  9346. {
  9347.   ffeexprCallback callback;
  9348.   ffeexprStack_ s;
  9349.   ffelexHandler next;
  9350.   ffelexToken ft;
  9351.   ffesymbol sy;
  9352.   ffebld expr;
  9353.  
  9354.   ffebld_pool_pop ();
  9355.   callback = ffeexpr_stack_->callback;
  9356.   ft = ffeexpr_stack_->first_token;
  9357.   s = ffeexpr_stack_->previous;
  9358.   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
  9359.   ffeexpr_stack_ = s;
  9360.  
  9361.   sy = ffesymbol_lookup_local (ft);
  9362.   if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
  9363.     {
  9364.       ffebad_start (FFEBAD_EXPR_WRONG);
  9365.       ffebad_here (0, ffelex_token_where_line (ft),
  9366.            ffelex_token_where_column (ft));
  9367.       ffebad_finish ();
  9368.       expr = ffebld_new_any ();
  9369.       ffebld_set_info (expr, ffeinfo_new_any ());
  9370.     }
  9371.   else
  9372.     {
  9373.       expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
  9374.                 FFEINTRIN_impNONE);
  9375.       ffebld_set_info (expr, ffesymbol_info (sy));
  9376.     }
  9377.   next = (ffelexHandler) (*callback) (ft, expr, t);
  9378.   ffelex_token_kill (ft);
  9379.   return (ffelexHandler) next;
  9380. }
  9381.  
  9382. /* ffeexpr_expr_kill_ -- Kill an existing internal expression object
  9383.  
  9384.    ffeexprExpr_ e;
  9385.    ffeexpr_expr_kill_(e);
  9386.  
  9387.    Kills the ffewhere info, if necessary, then kills the object.  */
  9388.  
  9389. static void
  9390. ffeexpr_expr_kill_ (ffeexprExpr_ e)
  9391. {
  9392.   if (e->token != NULL)
  9393.     ffelex_token_kill (e->token);
  9394.   malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
  9395. }
  9396.  
  9397. /* ffeexpr_expr_new_ -- Make a new internal expression object
  9398.  
  9399.    ffeexprExpr_ e;
  9400.    e = ffeexpr_expr_new_();
  9401.  
  9402.    Allocates and initializes a new expression object, returns it.  */
  9403.  
  9404. static ffeexprExpr_
  9405. ffeexpr_expr_new_ ()
  9406. {
  9407.   ffeexprExpr_ e;
  9408.  
  9409.   e = (ffeexprExpr_) malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr",
  9410.                     sizeof (*e));
  9411.   e->previous = NULL;
  9412.   e->type = FFEEXPR_exprtypeUNKNOWN_;
  9413.   e->token = NULL;
  9414.   return e;
  9415. }
  9416.  
  9417. /* Check whether rest of string is all decimal digits.  */
  9418.  
  9419. static bool
  9420. ffeexpr_isdigits_ (char *p)
  9421. {
  9422.   for (; *p != '\0'; ++p)
  9423.     if (!isdigit (*p))
  9424.       return FALSE;
  9425.   return TRUE;
  9426. }
  9427.  
  9428. /* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack
  9429.  
  9430.    ffeexprExpr_ e;
  9431.    ffeexpr_exprstack_push_(e);
  9432.  
  9433.    Pushes the expression onto the stack without any analysis of the existing
  9434.    contents of the stack.  */
  9435.  
  9436. static void
  9437. ffeexpr_exprstack_push_ (ffeexprExpr_ e)
  9438. {
  9439.   e->previous = ffeexpr_stack_->exprstack;
  9440.   ffeexpr_stack_->exprstack = e;
  9441. }
  9442.  
  9443. /* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?
  9444.  
  9445.    ffeexprExpr_ e;
  9446.    ffeexpr_exprstack_push_operand_(e);
  9447.  
  9448.    Pushes the expression already containing an operand (a constant, variable,
  9449.    or more complicated expression that has already been fully resolved) after
  9450.    analyzing the stack and checking for possible reduction (which will never
  9451.    happen here since the highest precedence operator is ** and it has right-
  9452.    to-left associativity).  */
  9453.  
  9454. static void
  9455. ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
  9456. {
  9457.   ffeexpr_exprstack_push_ (e);
  9458. #ifdef WEIRD_NONFORTRAN_RULES
  9459.   if ((ffeexpr_stack_->exprstack != NULL)
  9460.       && (ffeexpr_stack_->exprstack->expr->type == FFEEXPR_exprtypeBINARY_)
  9461.       && (ffeexpr_stack_->exprstack->expr->u.operator.prec
  9462.       == FFEEXPR_operatorprecedenceHIGHEST_)
  9463.       && (ffeexpr_stack_->exprstack->expr->u.operator.as
  9464.       == FFEEXPR_operatorassociativityL2R_))
  9465.     ffeexpr_reduce_ ();
  9466. #endif
  9467. }
  9468.  
  9469. /* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
  9470.  
  9471.    ffeexprExpr_ e;
  9472.    ffeexpr_exprstack_push_unary_(e);
  9473.  
  9474.    Pushes the expression already containing a unary operator.  Reduction can
  9475.    never happen since unary operators are themselves always R-L; that is, the
  9476.    top of the expression stack is not an operand, in that it is either empty,
  9477.    has a binary operator at the top, or a unary operator at the top.  In any
  9478.    of these cases, reduction is impossible.  */
  9479.  
  9480. static void
  9481. ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
  9482. {
  9483.   ffeexpr_exprstack_push_ (e);
  9484. }
  9485.  
  9486. /* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?
  9487.  
  9488.    ffeexprExpr_ e;
  9489.    ffeexpr_exprstack_push_binary_(e);
  9490.  
  9491.    Pushes the expression already containing a binary operator after checking
  9492.    whether reduction is possible.  If the stack is not empty, the top of the
  9493.    stack must be an operand or syntactic analysis has failed somehow.  If
  9494.    the operand is preceded by a unary operator of higher (or equal and L-R
  9495.    associativity) precedence than the new binary operator, then reduce that
  9496.    preceding operator and its operand(s) before pushing the new binary
  9497.    operator.  */
  9498.  
  9499. static void
  9500. ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
  9501. {
  9502.   ffeexprExpr_ ce;
  9503.  
  9504. again:
  9505.   assert (ffeexpr_stack_->exprstack != NULL);
  9506.   assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
  9507.   if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
  9508.     {
  9509.       assert (ce->type != FFEEXPR_exprtypeOPERAND_);
  9510.       if ((ce->u.operator.prec < e->u.operator.prec)
  9511.       || ((ce->u.operator.prec == e->u.operator.prec)
  9512.           && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
  9513.     {
  9514.       ffeexpr_reduce_ ();
  9515.       goto again;    /* :::::::::::::::::::: */
  9516.     }
  9517.     }
  9518.  
  9519.   ffeexpr_exprstack_push_ (e);
  9520. }
  9521.  
  9522. /* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack
  9523.  
  9524.    ffeexpr_reduce_();
  9525.  
  9526.    Converts operand binop operand or unop operand at top of stack to a
  9527.    single operand having the appropriate ffebld expression, and makes
  9528.    sure that the expression is proper (like not trying to add two character
  9529.    variables, not trying to concatenate two numbers).  Also does the
  9530.    requisite type-assignment.  */
  9531.  
  9532. static void
  9533. ffeexpr_reduce_ ()
  9534. {
  9535.   ffeexprExpr_ operand;        /* This is B in -B or A+B. */
  9536.   ffeexprExpr_ left_operand;    /* When operator is binary, this is A in A+B. */
  9537.   ffeexprExpr_ operator;    /* This is + in A+B. */
  9538.   ffebld reduced;        /* This is +(A,B) in A+B or u-(B) in -B. */
  9539.   ffebldConstant constnode;    /* For checking magical numbers (where mag ==
  9540.                    -mag). */
  9541.   ffebld expr;
  9542.   ffebld left_expr;
  9543.   bool submag = FALSE;
  9544.  
  9545.   operand = ffeexpr_stack_->exprstack;
  9546.   assert (operand != NULL);
  9547.   assert (operand->type == FFEEXPR_exprtypeOPERAND_);
  9548.   operator = operand->previous;
  9549.   assert (operator != NULL);
  9550.   assert (operator->type != FFEEXPR_exprtypeOPERAND_);
  9551.   if (operator->type == FFEEXPR_exprtypeUNARY_)
  9552.     {
  9553.       expr = operand->u.operand;
  9554.       switch (operator->u.operator.op)
  9555.     {
  9556.     case FFEEXPR_operatorADD_:
  9557.       reduced = ffebld_new_uplus (expr);
  9558.       if (ffe_is_ugly ())
  9559.         reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
  9560.       reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
  9561.       reduced = ffeexpr_collapse_uplus (reduced, operator->token);
  9562.       break;
  9563.  
  9564.     case FFEEXPR_operatorSUBTRACT_:
  9565.       submag = TRUE;    /* Ok to negate a magic number. */
  9566.       reduced = ffebld_new_uminus (expr);
  9567.       if (ffe_is_ugly ())
  9568.         reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
  9569.       reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
  9570.       reduced = ffeexpr_collapse_uminus (reduced, operator->token);
  9571.       break;
  9572.  
  9573.     case FFEEXPR_operatorNOT_:
  9574.       reduced = ffebld_new_not (expr);
  9575.       if (ffe_is_ugly ())
  9576.         reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
  9577.       reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
  9578.       reduced = ffeexpr_collapse_not (reduced, operator->token);
  9579.       break;
  9580.  
  9581.     default:
  9582.       assert ("unexpected unary op" != NULL);
  9583.       reduced = NULL;
  9584.       break;
  9585.     }
  9586.       if (!submag
  9587.       && (ffebld_op (expr) == FFEBLD_opCONTER)
  9588.       && (ffebld_conter_orig (expr) == NULL)
  9589.       && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
  9590.     {
  9591.       ffetarget_integer_bad_magical (operand->token);
  9592.     }
  9593.       ffeexpr_stack_->exprstack = operator->previous;    /* Pops unary-op operand
  9594.                                off stack. */
  9595.       ffeexpr_expr_kill_ (operand);
  9596.       operator->type = FFEEXPR_exprtypeOPERAND_;    /* Convert operator, but
  9597.                                save */
  9598.       operator->u.operand = reduced;    /* the line/column ffewhere info. */
  9599.       ffeexpr_exprstack_push_operand_ (operator);    /* Push it back on
  9600.                                stack. */
  9601.     }
  9602.   else
  9603.     {
  9604.       assert (operator->type == FFEEXPR_exprtypeBINARY_);
  9605.       left_operand = operator->previous;
  9606.       assert (left_operand != NULL);
  9607.       assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
  9608.       expr = operand->u.operand;
  9609.       left_expr = left_operand->u.operand;
  9610.       switch (operator->u.operator.op)
  9611.     {
  9612.     case FFEEXPR_operatorADD_:
  9613.       reduced = ffebld_new_add (left_expr, expr);
  9614.       if (ffe_is_ugly ())
  9615.         reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
  9616.                           operand);
  9617.       reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
  9618.                         operand);
  9619.       reduced = ffeexpr_collapse_add (reduced, operator->token);
  9620.       break;
  9621.  
  9622.     case FFEEXPR_operatorSUBTRACT_:
  9623.       submag = TRUE;    /* Just to pick the right error if magic
  9624.                    number. */
  9625.       reduced = ffebld_new_subtract (left_expr, expr);
  9626.       if (ffe_is_ugly ())
  9627.         reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
  9628.                           operand);
  9629.       reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
  9630.                         operand);
  9631.       reduced = ffeexpr_collapse_subtract (reduced, operator->token);
  9632.       break;
  9633.  
  9634.     case FFEEXPR_operatorMULTIPLY_:
  9635.       reduced = ffebld_new_multiply (left_expr, expr);
  9636.       if (ffe_is_ugly ())
  9637.         reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
  9638.                           operand);
  9639.       reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
  9640.                         operand);
  9641.       reduced = ffeexpr_collapse_multiply (reduced, operator->token);
  9642.       break;
  9643.  
  9644.     case FFEEXPR_operatorDIVIDE_:
  9645.       reduced = ffebld_new_divide (left_expr, expr);
  9646.       if (ffe_is_ugly ())
  9647.         reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
  9648.                           operand);
  9649.       reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
  9650.                         operand);
  9651.       reduced = ffeexpr_collapse_divide (reduced, operator->token);
  9652.       break;
  9653.  
  9654.     case FFEEXPR_operatorPOWER_:
  9655.       reduced = ffebld_new_power (left_expr, expr);
  9656.       if (ffe_is_ugly ())
  9657.         reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
  9658.                           operand);
  9659.       reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
  9660.                         operand);
  9661.       reduced = ffeexpr_collapse_power (reduced, operator->token);
  9662.       break;
  9663.  
  9664.     case FFEEXPR_operatorCONCATENATE_:
  9665.       reduced = ffebld_new_concatenate (left_expr, expr);
  9666.       reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
  9667.                           operand);
  9668.       reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
  9669.       break;
  9670.  
  9671.     case FFEEXPR_operatorLT_:
  9672.       reduced = ffebld_new_lt (left_expr, expr);
  9673.       if (ffe_is_ugly ())
  9674.         reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
  9675.                           operand);
  9676.       reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
  9677.                          operand);
  9678.       reduced = ffeexpr_collapse_lt (reduced, operator->token);
  9679.       break;
  9680.  
  9681.     case FFEEXPR_operatorLE_:
  9682.       reduced = ffebld_new_le (left_expr, expr);
  9683.       if (ffe_is_ugly ())
  9684.         reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
  9685.                           operand);
  9686.       reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
  9687.                          operand);
  9688.       reduced = ffeexpr_collapse_le (reduced, operator->token);
  9689.       break;
  9690.  
  9691.     case FFEEXPR_operatorEQ_:
  9692.       reduced = ffebld_new_eq (left_expr, expr);
  9693.       if (ffe_is_ugly ())
  9694.         reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
  9695.                           operand);
  9696.       reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
  9697.                         operand);
  9698.       reduced = ffeexpr_collapse_eq (reduced, operator->token);
  9699.       break;
  9700.  
  9701.     case FFEEXPR_operatorNE_:
  9702.       reduced = ffebld_new_ne (left_expr, expr);
  9703.       if (ffe_is_ugly ())
  9704.         reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
  9705.                           operand);
  9706.       reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
  9707.                         operand);
  9708.       reduced = ffeexpr_collapse_ne (reduced, operator->token);
  9709.       break;
  9710.  
  9711.     case FFEEXPR_operatorGT_:
  9712.       reduced = ffebld_new_gt (left_expr, expr);
  9713.       if (ffe_is_ugly ())
  9714.         reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
  9715.                           operand);
  9716.       reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
  9717.                          operand);
  9718.       reduced = ffeexpr_collapse_gt (reduced, operator->token);
  9719.       break;
  9720.  
  9721.     case FFEEXPR_operatorGE_:
  9722.       reduced = ffebld_new_ge (left_expr, expr);
  9723.       if (ffe_is_ugly ())
  9724.         reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
  9725.                           operand);
  9726.       reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
  9727.                          operand);
  9728.       reduced = ffeexpr_collapse_ge (reduced, operator->token);
  9729.       break;
  9730.  
  9731.     case FFEEXPR_operatorAND_:
  9732.       reduced = ffebld_new_and (left_expr, expr);
  9733.       if (ffe_is_ugly ())
  9734.         reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
  9735.                          operand);
  9736.       reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
  9737.                         operand);
  9738.       reduced = ffeexpr_collapse_and (reduced, operator->token);
  9739.       break;
  9740.  
  9741.     case FFEEXPR_operatorOR_:
  9742.       reduced = ffebld_new_or (left_expr, expr);
  9743.       if (ffe_is_ugly ())
  9744.         reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
  9745.                          operand);
  9746.       reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
  9747.                         operand);
  9748.       reduced = ffeexpr_collapse_or (reduced, operator->token);
  9749.       break;
  9750.  
  9751.     case FFEEXPR_operatorXOR_:
  9752.       reduced = ffebld_new_xor (left_expr, expr);
  9753.       if (ffe_is_ugly ())
  9754.         reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
  9755.                          operand);
  9756.       reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
  9757.                         operand);
  9758.       reduced = ffeexpr_collapse_xor (reduced, operator->token);
  9759.       break;
  9760.  
  9761.     case FFEEXPR_operatorEQV_:
  9762.       reduced = ffebld_new_eqv (left_expr, expr);
  9763.       if (ffe_is_ugly ())
  9764.         reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
  9765.                          operand);
  9766.       reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
  9767.                         operand);
  9768.       reduced = ffeexpr_collapse_eqv (reduced, operator->token);
  9769.       break;
  9770.  
  9771.     case FFEEXPR_operatorNEQV_:
  9772.       reduced = ffebld_new_neqv (left_expr, expr);
  9773.       if (ffe_is_ugly ())
  9774.         reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
  9775.                          operand);
  9776.       reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
  9777.                         operand);
  9778.       reduced = ffeexpr_collapse_neqv (reduced, operator->token);
  9779.       break;
  9780.  
  9781.     default:
  9782.       assert ("bad bin op" == NULL);
  9783.       reduced = expr;
  9784.       break;
  9785.     }
  9786.       if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
  9787.       && (ffebld_conter_orig (expr) == NULL)
  9788.       && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
  9789.     {
  9790.       if ((left_operand->previous != NULL)
  9791.           && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
  9792.           && (left_operand->previous->u.operator.op
  9793.           == FFEEXPR_operatorSUBTRACT_))
  9794.         if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
  9795.           ffetarget_integer_bad_magical_precedence (left_operand->token,
  9796.                           left_operand->previous->token,
  9797.                             operator->token);
  9798.         else
  9799.           ffetarget_integer_bad_magical_precedence_binary
  9800.         (left_operand->token,
  9801.          left_operand->previous->token,
  9802.          operator->token);
  9803.       else
  9804.         ffetarget_integer_bad_magical (left_operand->token);
  9805.     }
  9806.       if ((ffebld_op (expr) == FFEBLD_opCONTER)
  9807.       && (ffebld_conter_orig (expr) == NULL)
  9808.       && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
  9809.     if (submag)
  9810.       ffetarget_integer_bad_magical_binary (operand->token,
  9811.                         operator->token);
  9812.     else
  9813.       ffetarget_integer_bad_magical (operand->token);
  9814.       ffeexpr_stack_->exprstack = left_operand->previous;    /* Pops binary-op
  9815.                                    operands off stack. */
  9816.       ffeexpr_expr_kill_ (left_operand);
  9817.       ffeexpr_expr_kill_ (operand);
  9818.       operator->type = FFEEXPR_exprtypeOPERAND_;    /* Convert operator, but
  9819.                                save */
  9820.       operator->u.operand = reduced;    /* the line/column ffewhere info. */
  9821.       ffeexpr_exprstack_push_operand_ (operator);    /* Push it back on
  9822.                                stack. */
  9823.     }
  9824. }
  9825.  
  9826. /* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
  9827.  
  9828.    reduced = ffeexpr_reduced_bool1_(reduced,op,r);
  9829.  
  9830.    Makes sure the argument for reduced has basictype of
  9831.    LOGICAL or (ugly) INTEGER.  If
  9832.    argument has where of CONSTANT, assign where CONSTANT to
  9833.    reduced, else assign where FLEETING.
  9834.  
  9835.    If these requirements cannot be met, generate error message.     */
  9836.  
  9837. static ffebld
  9838. ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
  9839. {
  9840.   ffeinfo rinfo, ninfo;
  9841.   ffeinfoBasictype rbt;
  9842.   ffeinfoKindtype rkt;
  9843.   ffeinfoRank rrk;
  9844.   ffeinfoKind rkd;
  9845.   ffeinfoWhere rwh, nwh;
  9846.  
  9847.   rinfo = ffebld_info (ffebld_left (reduced));
  9848.   rbt = ffeinfo_basictype (rinfo);
  9849.   rkt = ffeinfo_kindtype (rinfo);
  9850.   rrk = ffeinfo_rank (rinfo);
  9851.   rkd = ffeinfo_kind (rinfo);
  9852.   rwh = ffeinfo_where (rinfo);
  9853.  
  9854.   if (((rbt == FFEINFO_basictypeLOGICAL)
  9855.        || (ffe_is_ugly () && (rbt == FFEINFO_basictypeINTEGER)))
  9856.       && (rrk == 0))
  9857.     {
  9858.       switch (rwh)
  9859.     {
  9860.     case FFEINFO_whereCONSTANT:
  9861.       nwh = FFEINFO_whereCONSTANT;
  9862.       break;
  9863.  
  9864.     case FFEINFO_whereIMMEDIATE:
  9865.       nwh = FFEINFO_whereIMMEDIATE;
  9866.       break;
  9867.  
  9868.     default:
  9869.       nwh = FFEINFO_whereFLEETING;
  9870.       break;
  9871.     }
  9872.  
  9873.       ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
  9874.                FFETARGET_charactersizeNONE);
  9875.       ffebld_set_info (reduced, ninfo);
  9876.       return reduced;
  9877.     }
  9878.  
  9879.   if ((rbt != FFEINFO_basictypeLOGICAL)
  9880.       && (!ffe_is_ugly () || (rbt != FFEINFO_basictypeINTEGER)))
  9881.     {
  9882.       if ((rbt != FFEINFO_basictypeANY)
  9883.       && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
  9884.     {
  9885.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  9886.       ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  9887.       ffebad_finish ();
  9888.     }
  9889.     }
  9890.   else
  9891.     {
  9892.       if ((rkd != FFEINFO_kindANY)
  9893.       && ffebad_start (FFEBAD_BOOL_ARG_KIND))
  9894.     {
  9895.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  9896.       ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  9897.       ffebad_string ("an array");
  9898.       ffebad_finish ();
  9899.     }
  9900.     }
  9901.  
  9902.   reduced = ffebld_new_any ();
  9903.   ffebld_set_info (reduced, ffeinfo_new_any ());
  9904.   return reduced;
  9905. }
  9906.  
  9907. /* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
  9908.  
  9909.    reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
  9910.  
  9911.    Makes sure the left and right arguments for reduced have basictype of
  9912.    LOGICAL or (ugly) INTEGER.  Determine common basictype and
  9913.    size for reduction (flag expression for combined hollerith/typeless
  9914.    situations for later determination of effective basictype).    If both left
  9915.    and right arguments have where of CONSTANT, assign where CONSTANT to
  9916.    reduced, else assign where FLEETING.     Create CONVERT ops for args where
  9917.    needed.  Convert typeless
  9918.    constants to the desired type/size explicitly.
  9919.  
  9920.    If these requirements cannot be met, generate error message.     */
  9921.  
  9922. static ffebld
  9923. ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
  9924.             ffeexprExpr_ r)
  9925. {
  9926.   ffeinfo linfo, rinfo, ninfo;
  9927.   ffeinfoBasictype lbt, rbt, nbt;
  9928.   ffeinfoKindtype lkt, rkt, nkt;
  9929.   ffeinfoRank lrk, rrk;
  9930.   ffeinfoKind lkd, rkd;
  9931.   ffeinfoWhere lwh, rwh, nwh;
  9932.  
  9933.   linfo = ffebld_info (ffebld_left (reduced));
  9934.   lbt = ffeinfo_basictype (linfo);
  9935.   lkt = ffeinfo_kindtype (linfo);
  9936.   lrk = ffeinfo_rank (linfo);
  9937.   lkd = ffeinfo_kind (linfo);
  9938.   lwh = ffeinfo_where (linfo);
  9939.  
  9940.   rinfo = ffebld_info (ffebld_right (reduced));
  9941.   rbt = ffeinfo_basictype (rinfo);
  9942.   rkt = ffeinfo_kindtype (rinfo);
  9943.   rrk = ffeinfo_rank (rinfo);
  9944.   rkd = ffeinfo_kind (rinfo);
  9945.   rwh = ffeinfo_where (rinfo);
  9946.  
  9947.   ffeexpr_type_combine_ (&nbt, &nkt, lbt, lkt, rbt, rkt, op);
  9948.  
  9949.   if (((nbt == FFEINFO_basictypeLOGICAL)
  9950.        || (ffe_is_ugly () && (nbt == FFEINFO_basictypeINTEGER)))
  9951.       && (lrk == 0) && (rrk == 0))
  9952.     {
  9953.       switch (lwh)
  9954.     {
  9955.     case FFEINFO_whereCONSTANT:
  9956.       switch (rwh)
  9957.         {
  9958.         case FFEINFO_whereCONSTANT:
  9959.           nwh = FFEINFO_whereCONSTANT;
  9960.           break;
  9961.  
  9962.         case FFEINFO_whereIMMEDIATE:
  9963.           nwh = FFEINFO_whereIMMEDIATE;
  9964.           break;
  9965.  
  9966.         default:
  9967.           nwh = FFEINFO_whereFLEETING;
  9968.           break;
  9969.         }
  9970.       break;
  9971.  
  9972.     case FFEINFO_whereIMMEDIATE:
  9973.       switch (rwh)
  9974.         {
  9975.         case FFEINFO_whereCONSTANT:
  9976.         case FFEINFO_whereIMMEDIATE:
  9977.           nwh = FFEINFO_whereIMMEDIATE;
  9978.           break;
  9979.  
  9980.         default:
  9981.           nwh = FFEINFO_whereFLEETING;
  9982.           break;
  9983.         }
  9984.       break;
  9985.  
  9986.     default:
  9987.       nwh = FFEINFO_whereFLEETING;
  9988.       break;
  9989.     }
  9990.  
  9991.       ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
  9992.                FFETARGET_charactersizeNONE);
  9993.       ffebld_set_info (reduced, ninfo);
  9994.       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
  9995.           l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
  9996.                          FFEEXPR_contextLET));
  9997.       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
  9998.           r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
  9999.                           FFEEXPR_contextLET));
  10000.       return reduced;
  10001.     }
  10002.  
  10003.   if ((lbt != FFEINFO_basictypeLOGICAL)
  10004.       && (!ffe_is_ugly () || (lbt != FFEINFO_basictypeINTEGER)))
  10005.     {
  10006.       if ((rbt != FFEINFO_basictypeLOGICAL)
  10007.       && (!ffe_is_ugly () || (rbt != FFEINFO_basictypeINTEGER)))
  10008.     {
  10009.       if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
  10010.           && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
  10011.         {
  10012.           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10013.           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
  10014.           ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10015.           ffebad_finish ();
  10016.         }
  10017.     }
  10018.       else
  10019.     {
  10020.       if ((lbt != FFEINFO_basictypeANY)
  10021.           && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
  10022.         {
  10023.           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10024.           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
  10025.           ffebad_finish ();
  10026.         }
  10027.     }
  10028.     }
  10029.   else if ((rbt != FFEINFO_basictypeLOGICAL)
  10030.        && (!ffe_is_ugly () || (rbt != FFEINFO_basictypeINTEGER)))
  10031.     {
  10032.       if ((rbt != FFEINFO_basictypeANY)
  10033.       && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
  10034.     {
  10035.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10036.       ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10037.       ffebad_finish ();
  10038.     }
  10039.     }
  10040.   else if (lrk != 0)
  10041.     {
  10042.       if ((lkd != FFEINFO_kindANY)
  10043.       && ffebad_start (FFEBAD_BOOL_ARG_KIND))
  10044.     {
  10045.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10046.       ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
  10047.       ffebad_string ("an array");
  10048.       ffebad_finish ();
  10049.     }
  10050.     }
  10051.   else
  10052.     {
  10053.       if ((rkd != FFEINFO_kindANY)
  10054.       && ffebad_start (FFEBAD_BOOL_ARG_KIND))
  10055.     {
  10056.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10057.       ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10058.       ffebad_string ("an array");
  10059.       ffebad_finish ();
  10060.     }
  10061.     }
  10062.  
  10063.   reduced = ffebld_new_any ();
  10064.   ffebld_set_info (reduced, ffeinfo_new_any ());
  10065.   return reduced;
  10066. }
  10067.  
  10068. /* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
  10069.  
  10070.    reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
  10071.  
  10072.    Makes sure the left and right arguments for reduced have basictype of
  10073.    CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION.  Assign
  10074.    basictype of CHARACTER and kind of SCALAR to reduced.  Calculate effective
  10075.    size of concatenation and assign that size to reduced.  If both left and
  10076.    right arguments have where of CONSTANT, assign where CONSTANT to reduced,
  10077.    else assign where FLEETING.
  10078.  
  10079.    If these requirements cannot be met, generate error message using the
  10080.    info in l, op, and r arguments and assign basictype, size, kind, and where
  10081.    of ANY.  */
  10082.  
  10083. static ffebld
  10084. ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
  10085.                   ffeexprExpr_ r)
  10086. {
  10087.   ffeinfo linfo, rinfo, ninfo;
  10088.   ffeinfoBasictype lbt, rbt, nbt;
  10089.   ffeinfoKindtype lkt, rkt, nkt;
  10090.   ffeinfoRank lrk, rrk;
  10091.   ffeinfoKind lkd, rkd, nkd;
  10092.   ffeinfoWhere lwh, rwh, nwh;
  10093.   ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
  10094.  
  10095.   linfo = ffebld_info (ffebld_left (reduced));
  10096.   lbt = ffeinfo_basictype (linfo);
  10097.   lkt = ffeinfo_kindtype (linfo);
  10098.   lrk = ffeinfo_rank (linfo);
  10099.   lkd = ffeinfo_kind (linfo);
  10100.   lwh = ffeinfo_where (linfo);
  10101.   lszk = ffeinfo_size (linfo);    /* Known size. */
  10102.   lszm = ffebld_size_max (ffebld_left (reduced));
  10103.  
  10104.   rinfo = ffebld_info (ffebld_right (reduced));
  10105.   rbt = ffeinfo_basictype (rinfo);
  10106.   rkt = ffeinfo_kindtype (rinfo);
  10107.   rrk = ffeinfo_rank (rinfo);
  10108.   rkd = ffeinfo_kind (rinfo);
  10109.   rwh = ffeinfo_where (rinfo);
  10110.   rszk = ffeinfo_size (rinfo);    /* Known size. */
  10111.   rszm = ffebld_size_max (ffebld_right (reduced));
  10112.  
  10113.   if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
  10114.       && (lkt == rkt) && (lrk == 0) && (rrk == 0)
  10115.       && (((lszm != FFETARGET_charactersizeNONE)
  10116.        && (rszm != FFETARGET_charactersizeNONE))
  10117.       || (ffeexpr_context_outer_ (ffeexpr_stack_)
  10118.           == FFEEXPR_contextLET)
  10119.       || (ffeexpr_context_outer_ (ffeexpr_stack_)
  10120.           == FFEEXPR_contextSFUNCDEF)))
  10121.     {
  10122.       nbt = FFEINFO_basictypeCHARACTER;
  10123.       nkd = FFEINFO_kindENTITY;
  10124.       if ((lszk == FFETARGET_charactersizeNONE)
  10125.       || (rszk == FFETARGET_charactersizeNONE))
  10126.     nszk = FFETARGET_charactersizeNONE;    /* Ok only in rhs of LET
  10127.                            stmt. */
  10128.       else
  10129.     nszk = lszk + rszk;
  10130.  
  10131.       switch (lwh)
  10132.     {
  10133.     case FFEINFO_whereCONSTANT:
  10134.       switch (rwh)
  10135.         {
  10136.         case FFEINFO_whereCONSTANT:
  10137.           nwh = FFEINFO_whereCONSTANT;
  10138.           break;
  10139.  
  10140.         case FFEINFO_whereIMMEDIATE:
  10141.           nwh = FFEINFO_whereIMMEDIATE;
  10142.           break;
  10143.  
  10144.         default:
  10145.           nwh = FFEINFO_whereFLEETING;
  10146.           break;
  10147.         }
  10148.       break;
  10149.  
  10150.     case FFEINFO_whereIMMEDIATE:
  10151.       switch (rwh)
  10152.         {
  10153.         case FFEINFO_whereCONSTANT:
  10154.         case FFEINFO_whereIMMEDIATE:
  10155.           nwh = FFEINFO_whereIMMEDIATE;
  10156.           break;
  10157.  
  10158.         default:
  10159.           nwh = FFEINFO_whereFLEETING;
  10160.           break;
  10161.         }
  10162.       break;
  10163.  
  10164.     default:
  10165.       nwh = FFEINFO_whereFLEETING;
  10166.       break;
  10167.     }
  10168.  
  10169.       nkt = lkt;
  10170.       ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
  10171.       ffebld_set_info (reduced, ninfo);
  10172.       return reduced;
  10173.     }
  10174.  
  10175.   if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
  10176.     {
  10177.       if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
  10178.       && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
  10179.     {
  10180.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10181.       ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
  10182.       ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10183.       ffebad_finish ();
  10184.     }
  10185.     }
  10186.   else if (lbt != FFEINFO_basictypeCHARACTER)
  10187.     {
  10188.       if ((lbt != FFEINFO_basictypeANY)
  10189.       && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
  10190.     {
  10191.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10192.       ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
  10193.       ffebad_finish ();
  10194.     }
  10195.     }
  10196.   else if (rbt != FFEINFO_basictypeCHARACTER)
  10197.     {
  10198.       if ((rbt != FFEINFO_basictypeANY)
  10199.       && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
  10200.     {
  10201.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10202.       ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10203.       ffebad_finish ();
  10204.     }
  10205.     }
  10206.   else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
  10207.     {
  10208.       if ((lkd != FFEINFO_kindANY)
  10209.       && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
  10210.     {
  10211.       char *what;
  10212.  
  10213.       if (lrk != 0)
  10214.         what = "an array";
  10215.       else
  10216.         what = "of indeterminate length";
  10217.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10218.       ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
  10219.       ffebad_string (what);
  10220.       ffebad_finish ();
  10221.     }
  10222.     }
  10223.   else
  10224.     {
  10225.       if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
  10226.     {
  10227.       char *what;
  10228.  
  10229.       if (rrk != 0)
  10230.         what = "an array";
  10231.       else
  10232.         what = "of indeterminate length";
  10233.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10234.       ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10235.       ffebad_string (what);
  10236.       ffebad_finish ();
  10237.     }
  10238.     }
  10239.  
  10240.   reduced = ffebld_new_any ();
  10241.   ffebld_set_info (reduced, ffeinfo_new_any ());
  10242.   return reduced;
  10243. }
  10244.  
  10245. /* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
  10246.  
  10247.    reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
  10248.  
  10249.    Makes sure the left and right arguments for reduced have basictype of
  10250.    INTEGER, REAL, COMPLEX, or CHARACTER.  Determine common basictype and
  10251.    size for reduction.    If both left
  10252.    and right arguments have where of CONSTANT, assign where CONSTANT to
  10253.    reduced, else assign where FLEETING.     Create CONVERT ops for args where
  10254.    needed.  Convert typeless
  10255.    constants to the desired type/size explicitly.
  10256.  
  10257.    If these requirements cannot be met, generate error message.     */
  10258.  
  10259. static ffebld
  10260. ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
  10261.             ffeexprExpr_ r)
  10262. {
  10263.   ffeinfo linfo, rinfo, ninfo;
  10264.   ffeinfoBasictype lbt, rbt, nbt;
  10265.   ffeinfoKindtype lkt, rkt, nkt;
  10266.   ffeinfoRank lrk, rrk;
  10267.   ffeinfoKind lkd, rkd;
  10268.   ffeinfoWhere lwh, rwh, nwh;
  10269.   ffetargetCharacterSize lsz, rsz;
  10270.  
  10271.   linfo = ffebld_info (ffebld_left (reduced));
  10272.   lbt = ffeinfo_basictype (linfo);
  10273.   lkt = ffeinfo_kindtype (linfo);
  10274.   lrk = ffeinfo_rank (linfo);
  10275.   lkd = ffeinfo_kind (linfo);
  10276.   lwh = ffeinfo_where (linfo);
  10277.   lsz = ffebld_size_known (ffebld_left (reduced));
  10278.  
  10279.   rinfo = ffebld_info (ffebld_right (reduced));
  10280.   rbt = ffeinfo_basictype (rinfo);
  10281.   rkt = ffeinfo_kindtype (rinfo);
  10282.   rrk = ffeinfo_rank (rinfo);
  10283.   rkd = ffeinfo_kind (rinfo);
  10284.   rwh = ffeinfo_where (rinfo);
  10285.   rsz = ffebld_size_known (ffebld_right (reduced));
  10286.  
  10287.   ffeexpr_type_combine_ (&nbt, &nkt, lbt, lkt, rbt, rkt, op);
  10288.  
  10289.   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
  10290.        || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
  10291.       && (lrk == 0) && (rrk == 0))
  10292.     {
  10293.       switch (lwh)
  10294.     {
  10295.     case FFEINFO_whereCONSTANT:
  10296.       switch (rwh)
  10297.         {
  10298.         case FFEINFO_whereCONSTANT:
  10299.           nwh = FFEINFO_whereCONSTANT;
  10300.           break;
  10301.  
  10302.         case FFEINFO_whereIMMEDIATE:
  10303.           nwh = FFEINFO_whereIMMEDIATE;
  10304.           break;
  10305.  
  10306.         default:
  10307.           nwh = FFEINFO_whereFLEETING;
  10308.           break;
  10309.         }
  10310.       break;
  10311.  
  10312.     case FFEINFO_whereIMMEDIATE:
  10313.       switch (rwh)
  10314.         {
  10315.         case FFEINFO_whereCONSTANT:
  10316.         case FFEINFO_whereIMMEDIATE:
  10317.           nwh = FFEINFO_whereIMMEDIATE;
  10318.           break;
  10319.  
  10320.         default:
  10321.           nwh = FFEINFO_whereFLEETING;
  10322.           break;
  10323.         }
  10324.       break;
  10325.  
  10326.     default:
  10327.       nwh = FFEINFO_whereFLEETING;
  10328.       break;
  10329.     }
  10330.  
  10331.       if ((lsz != FFETARGET_charactersizeNONE)
  10332.       && (rsz != FFETARGET_charactersizeNONE))
  10333.     lsz = rsz = (lsz > rsz) ? lsz : rsz;
  10334.  
  10335.       ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
  10336.            0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
  10337.       ffebld_set_info (reduced, ninfo);
  10338.       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
  10339.                       l->token, op->token, nbt, nkt, 0, lsz,
  10340.                          FFEEXPR_contextLET));
  10341.       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
  10342.                       r->token, op->token, nbt, nkt, 0, rsz,
  10343.                           FFEEXPR_contextLET));
  10344.       return reduced;
  10345.     }
  10346.  
  10347.   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
  10348.       && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
  10349.     {
  10350.       if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
  10351.       && (rbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
  10352.     {
  10353.       if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
  10354.           && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
  10355.         {
  10356.           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10357.           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
  10358.           ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10359.           ffebad_finish ();
  10360.         }
  10361.     }
  10362.       else
  10363.     {
  10364.       if ((lbt != FFEINFO_basictypeANY)
  10365.           && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
  10366.         {
  10367.           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10368.           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
  10369.           ffebad_finish ();
  10370.         }
  10371.     }
  10372.     }
  10373.   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
  10374.        && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
  10375.     {
  10376.       if ((rbt != FFEINFO_basictypeANY)
  10377.       && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
  10378.     {
  10379.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10380.       ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10381.       ffebad_finish ();
  10382.     }
  10383.     }
  10384.   else if (lrk != 0)
  10385.     {
  10386.       if ((lkd != FFEINFO_kindANY)
  10387.       && ffebad_start (FFEBAD_EQOP_ARG_KIND))
  10388.     {
  10389.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10390.       ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
  10391.       ffebad_string ("an array");
  10392.       ffebad_finish ();
  10393.     }
  10394.     }
  10395.   else
  10396.     {
  10397.       if ((rkd != FFEINFO_kindANY)
  10398.       && ffebad_start (FFEBAD_EQOP_ARG_KIND))
  10399.     {
  10400.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10401.       ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10402.       ffebad_string ("an array");
  10403.       ffebad_finish ();
  10404.     }
  10405.     }
  10406.  
  10407.   reduced = ffebld_new_any ();
  10408.   ffebld_set_info (reduced, ffeinfo_new_any ());
  10409.   return reduced;
  10410. }
  10411.  
  10412. /* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
  10413.  
  10414.    reduced = ffeexpr_reduced_math1_(reduced,op,r);
  10415.  
  10416.    Makes sure the argument for reduced has basictype of
  10417.    INTEGER, REAL, or COMPLEX.  If the argument has where of CONSTANT,
  10418.    assign where CONSTANT to
  10419.    reduced, else assign where FLEETING.
  10420.  
  10421.    If these requirements cannot be met, generate error message.     */
  10422.  
  10423. static ffebld
  10424. ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
  10425. {
  10426.   ffeinfo rinfo, ninfo;
  10427.   ffeinfoBasictype rbt;
  10428.   ffeinfoKindtype rkt;
  10429.   ffeinfoRank rrk;
  10430.   ffeinfoKind rkd;
  10431.   ffeinfoWhere rwh, nwh;
  10432.  
  10433.   rinfo = ffebld_info (ffebld_left (reduced));
  10434.   rbt = ffeinfo_basictype (rinfo);
  10435.   rkt = ffeinfo_kindtype (rinfo);
  10436.   rrk = ffeinfo_rank (rinfo);
  10437.   rkd = ffeinfo_kind (rinfo);
  10438.   rwh = ffeinfo_where (rinfo);
  10439.  
  10440.   if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
  10441.        || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
  10442.     {
  10443.       switch (rwh)
  10444.     {
  10445.     case FFEINFO_whereCONSTANT:
  10446.       nwh = FFEINFO_whereCONSTANT;
  10447.       break;
  10448.  
  10449.     case FFEINFO_whereIMMEDIATE:
  10450.       nwh = FFEINFO_whereIMMEDIATE;
  10451.       break;
  10452.  
  10453.     default:
  10454.       nwh = FFEINFO_whereFLEETING;
  10455.       break;
  10456.     }
  10457.  
  10458.       ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
  10459.                FFETARGET_charactersizeNONE);
  10460.       ffebld_set_info (reduced, ninfo);
  10461.       return reduced;
  10462.     }
  10463.  
  10464.   if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
  10465.       && (rbt != FFEINFO_basictypeCOMPLEX))
  10466.     {
  10467.       if ((rbt != FFEINFO_basictypeANY)
  10468.       && ffebad_start (FFEBAD_MATH_ARG_TYPE))
  10469.     {
  10470.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10471.       ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10472.       ffebad_finish ();
  10473.     }
  10474.     }
  10475.   else
  10476.     {
  10477.       if ((rkd != FFEINFO_kindANY)
  10478.       && ffebad_start (FFEBAD_MATH_ARG_KIND))
  10479.     {
  10480.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10481.       ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10482.       ffebad_string ("an array");
  10483.       ffebad_finish ();
  10484.     }
  10485.     }
  10486.  
  10487.   reduced = ffebld_new_any ();
  10488.   ffebld_set_info (reduced, ffeinfo_new_any ());
  10489.   return reduced;
  10490. }
  10491.  
  10492. /* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
  10493.  
  10494.    reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
  10495.  
  10496.    Makes sure the left and right arguments for reduced have basictype of
  10497.    INTEGER, REAL, or COMPLEX.  Determine common basictype and
  10498.    size for reduction (flag expression for combined hollerith/typeless
  10499.    situations for later determination of effective basictype).    If both left
  10500.    and right arguments have where of CONSTANT, assign where CONSTANT to
  10501.    reduced, else assign where FLEETING.     Create CONVERT ops for args where
  10502.    needed.  Convert typeless
  10503.    constants to the desired type/size explicitly.
  10504.  
  10505.    If these requirements cannot be met, generate error message.     */
  10506.  
  10507. static ffebld
  10508. ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
  10509.             ffeexprExpr_ r)
  10510. {
  10511.   ffeinfo linfo, rinfo, ninfo;
  10512.   ffeinfoBasictype lbt, rbt, nbt;
  10513.   ffeinfoKindtype lkt, rkt, nkt;
  10514.   ffeinfoRank lrk, rrk;
  10515.   ffeinfoKind lkd, rkd;
  10516.   ffeinfoWhere lwh, rwh, nwh;
  10517.  
  10518.   linfo = ffebld_info (ffebld_left (reduced));
  10519.   lbt = ffeinfo_basictype (linfo);
  10520.   lkt = ffeinfo_kindtype (linfo);
  10521.   lrk = ffeinfo_rank (linfo);
  10522.   lkd = ffeinfo_kind (linfo);
  10523.   lwh = ffeinfo_where (linfo);
  10524.  
  10525.   rinfo = ffebld_info (ffebld_right (reduced));
  10526.   rbt = ffeinfo_basictype (rinfo);
  10527.   rkt = ffeinfo_kindtype (rinfo);
  10528.   rrk = ffeinfo_rank (rinfo);
  10529.   rkd = ffeinfo_kind (rinfo);
  10530.   rwh = ffeinfo_where (rinfo);
  10531.  
  10532.   ffeexpr_type_combine_ (&nbt, &nkt, lbt, lkt, rbt, rkt, op);
  10533.  
  10534.   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
  10535.        || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
  10536.     {
  10537.       switch (lwh)
  10538.     {
  10539.     case FFEINFO_whereCONSTANT:
  10540.       switch (rwh)
  10541.         {
  10542.         case FFEINFO_whereCONSTANT:
  10543.           nwh = FFEINFO_whereCONSTANT;
  10544.           break;
  10545.  
  10546.         case FFEINFO_whereIMMEDIATE:
  10547.           nwh = FFEINFO_whereIMMEDIATE;
  10548.           break;
  10549.  
  10550.         default:
  10551.           nwh = FFEINFO_whereFLEETING;
  10552.           break;
  10553.         }
  10554.       break;
  10555.  
  10556.     case FFEINFO_whereIMMEDIATE:
  10557.       switch (rwh)
  10558.         {
  10559.         case FFEINFO_whereCONSTANT:
  10560.         case FFEINFO_whereIMMEDIATE:
  10561.           nwh = FFEINFO_whereIMMEDIATE;
  10562.           break;
  10563.  
  10564.         default:
  10565.           nwh = FFEINFO_whereFLEETING;
  10566.           break;
  10567.         }
  10568.       break;
  10569.  
  10570.     default:
  10571.       nwh = FFEINFO_whereFLEETING;
  10572.       break;
  10573.     }
  10574.  
  10575.       ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
  10576.                FFETARGET_charactersizeNONE);
  10577.       ffebld_set_info (reduced, ninfo);
  10578.       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
  10579.           l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
  10580.                          FFEEXPR_contextLET));
  10581.       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
  10582.           r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
  10583.                           FFEEXPR_contextLET));
  10584.       return reduced;
  10585.     }
  10586.  
  10587.   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
  10588.       && (lbt != FFEINFO_basictypeCOMPLEX))
  10589.     {
  10590.       if ((rbt != FFEINFO_basictypeINTEGER)
  10591.       && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
  10592.     {
  10593.       if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
  10594.           && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
  10595.         {
  10596.           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10597.           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
  10598.           ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10599.           ffebad_finish ();
  10600.         }
  10601.     }
  10602.       else
  10603.     {
  10604.       if ((lbt != FFEINFO_basictypeANY)
  10605.           && ffebad_start (FFEBAD_MATH_ARG_TYPE))
  10606.         {
  10607.           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10608.           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
  10609.           ffebad_finish ();
  10610.         }
  10611.     }
  10612.     }
  10613.   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
  10614.        && (rbt != FFEINFO_basictypeCOMPLEX))
  10615.     {
  10616.       if ((rbt != FFEINFO_basictypeANY)
  10617.       && ffebad_start (FFEBAD_MATH_ARG_TYPE))
  10618.     {
  10619.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10620.       ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10621.       ffebad_finish ();
  10622.     }
  10623.     }
  10624.   else if (lrk != 0)
  10625.     {
  10626.       if ((lkd != FFEINFO_kindANY)
  10627.       && ffebad_start (FFEBAD_MATH_ARG_KIND))
  10628.     {
  10629.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10630.       ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
  10631.       ffebad_string ("an array");
  10632.       ffebad_finish ();
  10633.     }
  10634.     }
  10635.   else
  10636.     {
  10637.       if ((rkd != FFEINFO_kindANY)
  10638.       && ffebad_start (FFEBAD_MATH_ARG_KIND))
  10639.     {
  10640.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10641.       ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10642.       ffebad_string ("an array");
  10643.       ffebad_finish ();
  10644.     }
  10645.     }
  10646.  
  10647.   reduced = ffebld_new_any ();
  10648.   ffebld_set_info (reduced, ffeinfo_new_any ());
  10649.   return reduced;
  10650. }
  10651.  
  10652. /* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
  10653.  
  10654.    reduced = ffeexpr_reduced_power_(reduced,l,op,r);
  10655.  
  10656.    Makes sure the left and right arguments for reduced have basictype of
  10657.    INTEGER, REAL, or COMPLEX.  Determine common basictype and
  10658.    size for reduction (flag expression for combined hollerith/typeless
  10659.    situations for later determination of effective basictype).    If both left
  10660.    and right arguments have where of CONSTANT, assign where CONSTANT to
  10661.    reduced, else assign where FLEETING.     Create CONVERT ops for args where
  10662.    needed.  Note that real**int or complex**int
  10663.    comes out as int = real**int etc with no conversions.
  10664.  
  10665.    If these requirements cannot be met, generate error message using the
  10666.    info in l, op, and r arguments and assign basictype, size, kind, and where
  10667.    of ANY.  */
  10668.  
  10669. static ffebld
  10670. ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
  10671.             ffeexprExpr_ r)
  10672. {
  10673.   ffeinfo linfo, rinfo, ninfo;
  10674.   ffeinfoBasictype lbt, rbt, nbt;
  10675.   ffeinfoKindtype lkt, rkt, nkt;
  10676.   ffeinfoRank lrk, rrk;
  10677.   ffeinfoKind lkd, rkd;
  10678.   ffeinfoWhere lwh, rwh, nwh;
  10679.  
  10680.   linfo = ffebld_info (ffebld_left (reduced));
  10681.   lbt = ffeinfo_basictype (linfo);
  10682.   lkt = ffeinfo_kindtype (linfo);
  10683.   lrk = ffeinfo_rank (linfo);
  10684.   lkd = ffeinfo_kind (linfo);
  10685.   lwh = ffeinfo_where (linfo);
  10686.  
  10687.   rinfo = ffebld_info (ffebld_right (reduced));
  10688.   rbt = ffeinfo_basictype (rinfo);
  10689.   rkt = ffeinfo_kindtype (rinfo);
  10690.   rrk = ffeinfo_rank (rinfo);
  10691.   rkd = ffeinfo_kind (rinfo);
  10692.   rwh = ffeinfo_where (rinfo);
  10693.  
  10694.   if ((rbt == FFEINFO_basictypeINTEGER)
  10695.    && ((lbt == FFEINFO_basictypeREAL) || (lbt == FFEINFO_basictypeCOMPLEX)))
  10696.     {
  10697.       nbt = lbt;
  10698.       nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
  10699.       if (nkt != FFEINFO_kindtypeREALDEFAULT)
  10700.     {
  10701.       nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
  10702.       if (nkt != FFEINFO_kindtypeREALDOUBLE)
  10703.         nkt = FFEINFO_kindtypeREALDOUBLE;    /* Highest kt we can power! */
  10704.     }
  10705.       if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
  10706.     {
  10707.       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
  10708.                               r->token, op->token,
  10709.         FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
  10710.                         FFETARGET_charactersizeNONE,
  10711.                               FFEEXPR_contextLET));
  10712.       rkt = FFEINFO_kindtypeINTEGERDEFAULT;
  10713.     }
  10714.     }
  10715.   else
  10716.     {
  10717.       ffeexpr_type_combine_ (&nbt, &nkt, lbt, lkt, rbt, rkt, op);
  10718.  
  10719.       if ((nbt == FFEINFO_basictypeINTEGER)
  10720.       && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
  10721.     nkt = FFEINFO_kindtypeINTEGERDEFAULT;    /* Highest kt we can power! */
  10722.       else if (((nbt == FFEINFO_basictypeREAL)
  10723.         || (nbt == FFEINFO_basictypeCOMPLEX))
  10724.            && (nkt != FFEINFO_kindtypeREALDEFAULT))
  10725.     {
  10726.       nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
  10727.       if (nkt != FFEINFO_kindtypeREALDOUBLE)
  10728.         nkt = FFEINFO_kindtypeREALDOUBLE;    /* Highest kt we can power! */
  10729.     }
  10730.       /* else Gonna turn into an error below. */
  10731.     }
  10732.  
  10733.   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
  10734.        || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
  10735.     {
  10736.       switch (lwh)
  10737.     {
  10738.     case FFEINFO_whereCONSTANT:
  10739.       switch (rwh)
  10740.         {
  10741.         case FFEINFO_whereCONSTANT:
  10742.           nwh = FFEINFO_whereCONSTANT;
  10743.           break;
  10744.  
  10745.         case FFEINFO_whereIMMEDIATE:
  10746.           nwh = FFEINFO_whereIMMEDIATE;
  10747.           break;
  10748.  
  10749.         default:
  10750.           nwh = FFEINFO_whereFLEETING;
  10751.           break;
  10752.         }
  10753.       break;
  10754.  
  10755.     case FFEINFO_whereIMMEDIATE:
  10756.       switch (rwh)
  10757.         {
  10758.         case FFEINFO_whereCONSTANT:
  10759.         case FFEINFO_whereIMMEDIATE:
  10760.           nwh = FFEINFO_whereIMMEDIATE;
  10761.           break;
  10762.  
  10763.         default:
  10764.           nwh = FFEINFO_whereFLEETING;
  10765.           break;
  10766.         }
  10767.       break;
  10768.  
  10769.     default:
  10770.       nwh = FFEINFO_whereFLEETING;
  10771.       break;
  10772.     }
  10773.  
  10774.       ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
  10775.                FFETARGET_charactersizeNONE);
  10776.       ffebld_set_info (reduced, ninfo);
  10777.       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
  10778.           l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
  10779.                          FFEEXPR_contextLET));
  10780.       if (rbt != FFEINFO_basictypeINTEGER)
  10781.     ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
  10782.           r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
  10783.                             FFEEXPR_contextLET));
  10784.       return reduced;
  10785.     }
  10786.  
  10787.   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
  10788.       && (lbt != FFEINFO_basictypeCOMPLEX))
  10789.     {
  10790.       if ((rbt != FFEINFO_basictypeINTEGER)
  10791.       && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
  10792.     {
  10793.       if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
  10794.           && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
  10795.         {
  10796.           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10797.           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
  10798.           ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10799.           ffebad_finish ();
  10800.         }
  10801.     }
  10802.       else
  10803.     {
  10804.       if ((lbt != FFEINFO_basictypeANY)
  10805.           && ffebad_start (FFEBAD_MATH_ARG_TYPE))
  10806.         {
  10807.           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10808.           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
  10809.           ffebad_finish ();
  10810.         }
  10811.     }
  10812.     }
  10813.   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
  10814.        && (rbt != FFEINFO_basictypeCOMPLEX))
  10815.     {
  10816.       if ((rbt != FFEINFO_basictypeANY)
  10817.       && ffebad_start (FFEBAD_MATH_ARG_TYPE))
  10818.     {
  10819.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10820.       ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10821.       ffebad_finish ();
  10822.     }
  10823.     }
  10824.   else if (lrk != 0)
  10825.     {
  10826.       if ((lkd != FFEINFO_kindANY)
  10827.       && ffebad_start (FFEBAD_MATH_ARG_KIND))
  10828.     {
  10829.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10830.       ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
  10831.       ffebad_string ("an array");
  10832.       ffebad_finish ();
  10833.     }
  10834.     }
  10835.   else
  10836.     {
  10837.       if ((rkd != FFEINFO_kindANY)
  10838.       && ffebad_start (FFEBAD_MATH_ARG_KIND))
  10839.     {
  10840.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10841.       ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10842.       ffebad_string ("an array");
  10843.       ffebad_finish ();
  10844.     }
  10845.     }
  10846.  
  10847.   reduced = ffebld_new_any ();
  10848.   ffebld_set_info (reduced, ffeinfo_new_any ());
  10849.   return reduced;
  10850. }
  10851.  
  10852. /* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
  10853.  
  10854.    reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
  10855.  
  10856.    Makes sure the left and right arguments for reduced have basictype of
  10857.    INTEGER, REAL, or CHARACTER.     Determine common basictype and
  10858.    size for reduction.    If both left
  10859.    and right arguments have where of CONSTANT, assign where CONSTANT to
  10860.    reduced, else assign where FLEETING.     Create CONVERT ops for args where
  10861.    needed.  Convert typeless
  10862.    constants to the desired type/size explicitly.
  10863.  
  10864.    If these requirements cannot be met, generate error message.     */
  10865.  
  10866. static ffebld
  10867. ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
  10868.              ffeexprExpr_ r)
  10869. {
  10870.   ffeinfo linfo, rinfo, ninfo;
  10871.   ffeinfoBasictype lbt, rbt, nbt;
  10872.   ffeinfoKindtype lkt, rkt, nkt;
  10873.   ffeinfoRank lrk, rrk;
  10874.   ffeinfoKind lkd, rkd;
  10875.   ffeinfoWhere lwh, rwh, nwh;
  10876.   ffetargetCharacterSize lsz, rsz;
  10877.  
  10878.   linfo = ffebld_info (ffebld_left (reduced));
  10879.   lbt = ffeinfo_basictype (linfo);
  10880.   lkt = ffeinfo_kindtype (linfo);
  10881.   lrk = ffeinfo_rank (linfo);
  10882.   lkd = ffeinfo_kind (linfo);
  10883.   lwh = ffeinfo_where (linfo);
  10884.   lsz = ffebld_size_known (ffebld_left (reduced));
  10885.  
  10886.   rinfo = ffebld_info (ffebld_right (reduced));
  10887.   rbt = ffeinfo_basictype (rinfo);
  10888.   rkt = ffeinfo_kindtype (rinfo);
  10889.   rrk = ffeinfo_rank (rinfo);
  10890.   rkd = ffeinfo_kind (rinfo);
  10891.   rwh = ffeinfo_where (rinfo);
  10892.   rsz = ffebld_size_known (ffebld_right (reduced));
  10893.  
  10894.   ffeexpr_type_combine_ (&nbt, &nkt, lbt, lkt, rbt, rkt, op);
  10895.  
  10896.   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
  10897.        || (nbt == FFEINFO_basictypeCHARACTER))
  10898.       && (lrk == 0) && (rrk == 0))
  10899.     {
  10900.       switch (lwh)
  10901.     {
  10902.     case FFEINFO_whereCONSTANT:
  10903.       switch (rwh)
  10904.         {
  10905.         case FFEINFO_whereCONSTANT:
  10906.           nwh = FFEINFO_whereCONSTANT;
  10907.           break;
  10908.  
  10909.         case FFEINFO_whereIMMEDIATE:
  10910.           nwh = FFEINFO_whereIMMEDIATE;
  10911.           break;
  10912.  
  10913.         default:
  10914.           nwh = FFEINFO_whereFLEETING;
  10915.           break;
  10916.         }
  10917.       break;
  10918.  
  10919.     case FFEINFO_whereIMMEDIATE:
  10920.       switch (rwh)
  10921.         {
  10922.         case FFEINFO_whereCONSTANT:
  10923.         case FFEINFO_whereIMMEDIATE:
  10924.           nwh = FFEINFO_whereIMMEDIATE;
  10925.           break;
  10926.  
  10927.         default:
  10928.           nwh = FFEINFO_whereFLEETING;
  10929.           break;
  10930.         }
  10931.       break;
  10932.  
  10933.     default:
  10934.       nwh = FFEINFO_whereFLEETING;
  10935.       break;
  10936.     }
  10937.  
  10938.       if ((lsz != FFETARGET_charactersizeNONE)
  10939.       && (rsz != FFETARGET_charactersizeNONE))
  10940.     lsz = rsz = (lsz > rsz) ? lsz : rsz;
  10941.  
  10942.       ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
  10943.            0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
  10944.       ffebld_set_info (reduced, ninfo);
  10945.       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
  10946.                       l->token, op->token, nbt, nkt, 0, lsz,
  10947.                          FFEEXPR_contextLET));
  10948.       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
  10949.                       r->token, op->token, nbt, nkt, 0, rsz,
  10950.                           FFEEXPR_contextLET));
  10951.       return reduced;
  10952.     }
  10953.  
  10954.   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
  10955.       && (lbt != FFEINFO_basictypeCHARACTER))
  10956.     {
  10957.       if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
  10958.       && (lbt != FFEINFO_basictypeCHARACTER))
  10959.     {
  10960.       if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
  10961.           && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
  10962.         {
  10963.           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10964.           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
  10965.           ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10966.           ffebad_finish ();
  10967.         }
  10968.     }
  10969.       else
  10970.     {
  10971.       if ((lbt != FFEINFO_basictypeANY)
  10972.           && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
  10973.         {
  10974.           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10975.           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
  10976.           ffebad_finish ();
  10977.         }
  10978.     }
  10979.     }
  10980.   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
  10981.        && (rbt != FFEINFO_basictypeCHARACTER))
  10982.     {
  10983.       if ((rbt != FFEINFO_basictypeANY)
  10984.       && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
  10985.     {
  10986.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10987.       ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  10988.       ffebad_finish ();
  10989.     }
  10990.     }
  10991.   else if (lrk != 0)
  10992.     {
  10993.       if ((lkd != FFEINFO_kindANY)
  10994.       && ffebad_start (FFEBAD_RELOP_ARG_KIND))
  10995.     {
  10996.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  10997.       ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
  10998.       ffebad_string ("an array");
  10999.       ffebad_finish ();
  11000.     }
  11001.     }
  11002.   else
  11003.     {
  11004.       if ((rkd != FFEINFO_kindANY)
  11005.       && ffebad_start (FFEBAD_RELOP_ARG_KIND))
  11006.     {
  11007.       ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
  11008.       ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
  11009.       ffebad_string ("an array");
  11010.       ffebad_finish ();
  11011.     }
  11012.     }
  11013.  
  11014.   reduced = ffebld_new_any ();
  11015.   ffebld_set_info (reduced, ffeinfo_new_any ());
  11016.   return reduced;
  11017. }
  11018.  
  11019. /* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
  11020.  
  11021.    reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
  11022.  
  11023.    Sigh.  */
  11024.  
  11025. static ffebld
  11026. ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
  11027. {
  11028.   ffeinfo rinfo;
  11029.   ffeinfoBasictype rbt;
  11030.   ffeinfoKindtype rkt;
  11031.   ffeinfoRank rrk;
  11032.   ffeinfoKind rkd;
  11033.   ffeinfoWhere rwh;
  11034.  
  11035.   rinfo = ffebld_info (ffebld_left (reduced));
  11036.   rbt = ffeinfo_basictype (rinfo);
  11037.   rkt = ffeinfo_kindtype (rinfo);
  11038.   rrk = ffeinfo_rank (rinfo);
  11039.   rkd = ffeinfo_kind (rinfo);
  11040.   rwh = ffeinfo_where (rinfo);
  11041.  
  11042.   if ((rbt == FFEINFO_basictypeTYPELESS)
  11043.       || (rbt == FFEINFO_basictypeHOLLERITH))
  11044.     {
  11045.       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
  11046.                   r->token, op->token, FFEINFO_basictypeINTEGER,
  11047.                       FFEINFO_kindtypeINTEGERDEFAULT, 0,
  11048.                          FFETARGET_charactersizeNONE,
  11049.                          FFEEXPR_contextLET));
  11050.       rinfo = ffebld_info (ffebld_left (reduced));
  11051.       rbt = FFEINFO_basictypeINTEGER;
  11052.       rkt = FFEINFO_kindtypeINTEGERDEFAULT;
  11053.       rrk = 0;
  11054.       rkd = FFEINFO_kindENTITY;
  11055.       rwh = ffeinfo_where (rinfo);
  11056.     }
  11057.  
  11058.   if (rbt == FFEINFO_basictypeLOGICAL)
  11059.     {
  11060.       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
  11061.                   r->token, op->token, FFEINFO_basictypeINTEGER,
  11062.                       FFEINFO_kindtypeINTEGERDEFAULT, 0,
  11063.                          FFETARGET_charactersizeNONE,
  11064.                          FFEEXPR_contextLET));
  11065.     }
  11066.  
  11067.   return reduced;
  11068. }
  11069.  
  11070. /* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
  11071.  
  11072.    reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
  11073.  
  11074.    Sigh.  */
  11075.  
  11076. static ffebld
  11077. ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
  11078. {
  11079.   ffeinfo rinfo;
  11080.   ffeinfoBasictype rbt;
  11081.   ffeinfoKindtype rkt;
  11082.   ffeinfoRank rrk;
  11083.   ffeinfoKind rkd;
  11084.   ffeinfoWhere rwh;
  11085.  
  11086.   rinfo = ffebld_info (ffebld_left (reduced));
  11087.   rbt = ffeinfo_basictype (rinfo);
  11088.   rkt = ffeinfo_kindtype (rinfo);
  11089.   rrk = ffeinfo_rank (rinfo);
  11090.   rkd = ffeinfo_kind (rinfo);
  11091.   rwh = ffeinfo_where (rinfo);
  11092.  
  11093.   if ((rbt == FFEINFO_basictypeTYPELESS)
  11094.       || (rbt == FFEINFO_basictypeHOLLERITH))
  11095.     {
  11096.       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
  11097.                r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
  11098.                          FFEINFO_kindtypeLOGICALDEFAULT,
  11099.                          FFETARGET_charactersizeNONE,
  11100.                          FFEEXPR_contextLET));
  11101.       rinfo = ffebld_info (ffebld_left (reduced));
  11102.       rbt = FFEINFO_basictypeLOGICAL;
  11103.       rkt = FFEINFO_kindtypeLOGICALDEFAULT;
  11104.       rrk = 0;
  11105.       rkd = FFEINFO_kindENTITY;
  11106.       rwh = ffeinfo_where (rinfo);
  11107.     }
  11108.  
  11109.   return reduced;
  11110. }
  11111.  
  11112. /* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
  11113.  
  11114.    reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
  11115.  
  11116.    Sigh.  */
  11117.  
  11118. static ffebld
  11119. ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
  11120.             ffeexprExpr_ r)
  11121. {
  11122.   ffeinfo linfo, rinfo;
  11123.   ffeinfoBasictype lbt, rbt;
  11124.   ffeinfoKindtype lkt, rkt;
  11125.   ffeinfoRank lrk, rrk;
  11126.   ffeinfoKind lkd, rkd;
  11127.   ffeinfoWhere lwh, rwh;
  11128.  
  11129.   linfo = ffebld_info (ffebld_left (reduced));
  11130.   lbt = ffeinfo_basictype (linfo);
  11131.   lkt = ffeinfo_kindtype (linfo);
  11132.   lrk = ffeinfo_rank (linfo);
  11133.   lkd = ffeinfo_kind (linfo);
  11134.   lwh = ffeinfo_where (linfo);
  11135.  
  11136.   rinfo = ffebld_info (ffebld_right (reduced));
  11137.   rbt = ffeinfo_basictype (rinfo);
  11138.   rkt = ffeinfo_kindtype (rinfo);
  11139.   rrk = ffeinfo_rank (rinfo);
  11140.   rkd = ffeinfo_kind (rinfo);
  11141.   rwh = ffeinfo_where (rinfo);
  11142.  
  11143.   if ((lbt == FFEINFO_basictypeTYPELESS)
  11144.       || (lbt == FFEINFO_basictypeHOLLERITH))
  11145.     {
  11146.       if ((rbt == FFEINFO_basictypeTYPELESS)
  11147.       || (rbt == FFEINFO_basictypeHOLLERITH))
  11148.     {
  11149.       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
  11150.                   l->token, op->token, FFEINFO_basictypeINTEGER,
  11151.                       FFEINFO_kindtypeINTEGERDEFAULT, 0,
  11152.                         FFETARGET_charactersizeNONE,
  11153.                              FFEEXPR_contextLET));
  11154.       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
  11155.                r->token, op->token, FFEINFO_basictypeINTEGER, 0,
  11156.                          FFEINFO_kindtypeINTEGERDEFAULT,
  11157.                         FFETARGET_charactersizeNONE,
  11158.                               FFEEXPR_contextLET));
  11159.       linfo = ffebld_info (ffebld_left (reduced));
  11160.       rinfo = ffebld_info (ffebld_right (reduced));
  11161.       lbt = rbt = FFEINFO_basictypeINTEGER;
  11162.       lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
  11163.       lrk = rrk = 0;
  11164.       lkd = rkd = FFEINFO_kindENTITY;
  11165.       lwh = ffeinfo_where (linfo);
  11166.       rwh = ffeinfo_where (rinfo);
  11167.     }
  11168.       else
  11169.     {
  11170.       ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
  11171.                  l->token, ffebld_right (reduced), r->token,
  11172.                                FFEEXPR_contextLET));
  11173.       linfo = ffebld_info (ffebld_left (reduced));
  11174.       lbt = ffeinfo_basictype (linfo);
  11175.       lkt = ffeinfo_kindtype (linfo);
  11176.       lrk = ffeinfo_rank (linfo);
  11177.       lkd = ffeinfo_kind (linfo);
  11178.       lwh = ffeinfo_where (linfo);
  11179.     }
  11180.     }
  11181.   else
  11182.     {
  11183.       if ((rbt == FFEINFO_basictypeTYPELESS)
  11184.       || (rbt == FFEINFO_basictypeHOLLERITH))
  11185.     {
  11186.       ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
  11187.                   r->token, ffebld_left (reduced), l->token,
  11188.                                FFEEXPR_contextLET));
  11189.       rinfo = ffebld_info (ffebld_right (reduced));
  11190.       rbt = ffeinfo_basictype (rinfo);
  11191.       rkt = ffeinfo_kindtype (rinfo);
  11192.       rrk = ffeinfo_rank (rinfo);
  11193.       rkd = ffeinfo_kind (rinfo);
  11194.       rwh = ffeinfo_where (rinfo);
  11195.     }
  11196.       /* else Leave it alone. */
  11197.     }
  11198.  
  11199.   if (lbt == FFEINFO_basictypeLOGICAL)
  11200.     {
  11201.       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
  11202.                   l->token, op->token, FFEINFO_basictypeINTEGER,
  11203.                       FFEINFO_kindtypeINTEGERDEFAULT, 0,
  11204.                          FFETARGET_charactersizeNONE,
  11205.                          FFEEXPR_contextLET));
  11206.     }
  11207.  
  11208.   if (rbt == FFEINFO_basictypeLOGICAL)
  11209.     {
  11210.       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
  11211.                   r->token, op->token, FFEINFO_basictypeINTEGER,
  11212.                       FFEINFO_kindtypeINTEGERDEFAULT, 0,
  11213.                         FFETARGET_charactersizeNONE,
  11214.                           FFEEXPR_contextLET));
  11215.     }
  11216.  
  11217.   return reduced;
  11218. }
  11219.  
  11220. /* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
  11221.  
  11222.    reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
  11223.  
  11224.    Sigh.  */
  11225.  
  11226. static ffebld
  11227. ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
  11228.                ffeexprExpr_ r)
  11229. {
  11230.   ffeinfo linfo, rinfo;
  11231.   ffeinfoBasictype lbt, rbt;
  11232.   ffeinfoKindtype lkt, rkt;
  11233.   ffeinfoRank lrk, rrk;
  11234.   ffeinfoKind lkd, rkd;
  11235.   ffeinfoWhere lwh, rwh;
  11236.  
  11237.   linfo = ffebld_info (ffebld_left (reduced));
  11238.   lbt = ffeinfo_basictype (linfo);
  11239.   lkt = ffeinfo_kindtype (linfo);
  11240.   lrk = ffeinfo_rank (linfo);
  11241.   lkd = ffeinfo_kind (linfo);
  11242.   lwh = ffeinfo_where (linfo);
  11243.  
  11244.   rinfo = ffebld_info (ffebld_right (reduced));
  11245.   rbt = ffeinfo_basictype (rinfo);
  11246.   rkt = ffeinfo_kindtype (rinfo);
  11247.   rrk = ffeinfo_rank (rinfo);
  11248.   rkd = ffeinfo_kind (rinfo);
  11249.   rwh = ffeinfo_where (rinfo);
  11250.  
  11251.   if ((lbt == FFEINFO_basictypeTYPELESS)
  11252.       || (lbt == FFEINFO_basictypeHOLLERITH))
  11253.     {
  11254.       if ((rbt == FFEINFO_basictypeTYPELESS)
  11255.       || (rbt == FFEINFO_basictypeHOLLERITH))
  11256.     {
  11257.       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
  11258.                   l->token, op->token, FFEINFO_basictypeLOGICAL,
  11259.                       FFEINFO_kindtypeLOGICALDEFAULT, 0,
  11260.                         FFETARGET_charactersizeNONE,
  11261.                              FFEEXPR_contextLET));
  11262.       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
  11263.                   r->token, op->token, FFEINFO_basictypeLOGICAL,
  11264.                       FFEINFO_kindtypeLOGICALDEFAULT, 0,
  11265.                         FFETARGET_charactersizeNONE,
  11266.                               FFEEXPR_contextLET));
  11267.       linfo = ffebld_info (ffebld_left (reduced));
  11268.       rinfo = ffebld_info (ffebld_right (reduced));
  11269.       lbt = rbt = FFEINFO_basictypeLOGICAL;
  11270.       lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
  11271.       lrk = rrk = 0;
  11272.       lkd = rkd = FFEINFO_kindENTITY;
  11273.       lwh = ffeinfo_where (linfo);
  11274.       rwh = ffeinfo_where (rinfo);
  11275.     }
  11276.       else
  11277.     {
  11278.       ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
  11279.                  l->token, ffebld_right (reduced), r->token,
  11280.                                FFEEXPR_contextLET));
  11281.       linfo = ffebld_info (ffebld_left (reduced));
  11282.       lbt = ffeinfo_basictype (linfo);
  11283.       lkt = ffeinfo_kindtype (linfo);
  11284.       lrk = ffeinfo_rank (linfo);
  11285.       lkd = ffeinfo_kind (linfo);
  11286.       lwh = ffeinfo_where (linfo);
  11287.     }
  11288.     }
  11289.   else
  11290.     {
  11291.       if ((rbt == FFEINFO_basictypeTYPELESS)
  11292.       || (rbt == FFEINFO_basictypeHOLLERITH))
  11293.     {
  11294.       ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
  11295.                   r->token, ffebld_left (reduced), l->token,
  11296.                                FFEEXPR_contextLET));
  11297.       rinfo = ffebld_info (ffebld_right (reduced));
  11298.       rbt = ffeinfo_basictype (rinfo);
  11299.       rkt = ffeinfo_kindtype (rinfo);
  11300.       rrk = ffeinfo_rank (rinfo);
  11301.       rkd = ffeinfo_kind (rinfo);
  11302.       rwh = ffeinfo_where (rinfo);
  11303.     }
  11304.       /* else Leave it alone. */
  11305.     }
  11306.  
  11307.   return reduced;
  11308. }
  11309.  
  11310. /* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
  11311.    is found.
  11312.  
  11313.    The idea is to process the tokens as they would be done by normal
  11314.    expression processing, with the key things being telling the lexer
  11315.    when hollerith/character constants are about to happen, until the
  11316.    true closing token is found.  */
  11317.  
  11318. static ffelexHandler
  11319. ffeexpr_find_close_paren_ (ffelexToken t,
  11320.                ffelexHandler after)
  11321. {
  11322.   ffeexpr_find_.after = after;
  11323.   ffeexpr_find_.level = 1;
  11324.   return (ffelexHandler) ffeexpr_nil_rhs_ (t);
  11325. }
  11326.  
  11327. static ffelexHandler
  11328. ffeexpr_nil_finished_ (ffelexToken t)
  11329. {
  11330.   switch (ffelex_token_type (t))
  11331.     {
  11332.     case FFELEX_typeCLOSE_PAREN:
  11333.       if (--ffeexpr_find_.level == 0)
  11334.     return (ffelexHandler) ffeexpr_find_.after;
  11335.       return (ffelexHandler) ffeexpr_nil_binary_;
  11336.  
  11337.     case FFELEX_typeCOMMA:
  11338.     case FFELEX_typeCOLON:
  11339.     case FFELEX_typeEQUALS:
  11340.     case FFELEX_typePOINTS:
  11341.       return (ffelexHandler) ffeexpr_nil_rhs_;
  11342.  
  11343.     default:
  11344.       if (--ffeexpr_find_.level == 0)
  11345.     return (ffelexHandler) ffeexpr_find_.after (t);
  11346.       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
  11347.     }
  11348. }
  11349.  
  11350. static ffelexHandler
  11351. ffeexpr_nil_rhs_ (ffelexToken t)
  11352. {
  11353.   switch (ffelex_token_type (t))
  11354.     {
  11355.     case FFELEX_typeQUOTE:
  11356.       if (ffe_is_vxt_not_90 ())
  11357.     return (ffelexHandler) ffeexpr_nil_quote_;
  11358.       ffelex_set_expecting_hollerith (-1, '\"',
  11359.                       ffelex_token_where_line (t),
  11360.                       ffelex_token_where_column (t));
  11361.       return (ffelexHandler) ffeexpr_nil_apostrophe_;
  11362.  
  11363.     case FFELEX_typeAPOSTROPHE:
  11364.       ffelex_set_expecting_hollerith (-1, '\'',
  11365.                       ffelex_token_where_line (t),
  11366.                       ffelex_token_where_column (t));
  11367.       return (ffelexHandler) ffeexpr_nil_apostrophe_;
  11368.  
  11369.     case FFELEX_typePERCENT:
  11370.       return (ffelexHandler) ffeexpr_nil_percent_;
  11371.  
  11372.     case FFELEX_typeOPEN_PAREN:
  11373.       ++ffeexpr_find_.level;
  11374.       return (ffelexHandler) ffeexpr_nil_rhs_;
  11375.  
  11376.     case FFELEX_typePLUS:
  11377.     case FFELEX_typeMINUS:
  11378.       return (ffelexHandler) ffeexpr_nil_rhs_;
  11379.  
  11380.     case FFELEX_typePERIOD:
  11381.       return (ffelexHandler) ffeexpr_nil_period_;
  11382.  
  11383.     case FFELEX_typeNUMBER:
  11384.       ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
  11385.       if (ffeexpr_hollerith_count_ > 0)
  11386.     ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
  11387.                     '\0',
  11388.                     ffelex_token_where_line (t),
  11389.                     ffelex_token_where_column (t));
  11390.       return (ffelexHandler) ffeexpr_nil_number_;
  11391.  
  11392.     case FFELEX_typeNAME:
  11393.     case FFELEX_typeNAMES:
  11394.       return (ffelexHandler) ffeexpr_nil_name_rhs_;
  11395.  
  11396.     case FFELEX_typeASTERISK:
  11397.     case FFELEX_typeSLASH:
  11398.     case FFELEX_typePOWER:
  11399.     case FFELEX_typeCONCAT:
  11400.     case FFELEX_typeREL_EQ:
  11401.     case FFELEX_typeREL_NE:
  11402.     case FFELEX_typeREL_LE:
  11403.     case FFELEX_typeREL_GE:
  11404.       return (ffelexHandler) ffeexpr_nil_rhs_;
  11405.  
  11406.     default:
  11407.       return (ffelexHandler) ffeexpr_nil_finished_ (t);
  11408.     }
  11409. }
  11410.  
  11411. static ffelexHandler
  11412. ffeexpr_nil_period_ (ffelexToken t)
  11413. {
  11414.   switch (ffelex_token_type (t))
  11415.     {
  11416.     case FFELEX_typeNAME:
  11417.     case FFELEX_typeNAMES:
  11418.       ffeexpr_current_dotdot_ = ffeexpr_dotdot_ (t);
  11419.       switch (ffeexpr_current_dotdot_)
  11420.     {
  11421.     case FFEEXPR_dotdotNONE_:
  11422.       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
  11423.  
  11424.     case FFEEXPR_dotdotTRUE_:
  11425.     case FFEEXPR_dotdotFALSE_:
  11426.     case FFEEXPR_dotdotNOT_:
  11427.       return (ffelexHandler) ffeexpr_nil_end_period_;
  11428.  
  11429.     default:
  11430.       return (ffelexHandler) ffeexpr_nil_swallow_period_;
  11431.     }
  11432.       break;            /* Nothing really reaches here. */
  11433.  
  11434.     case FFELEX_typeNUMBER:
  11435.       return (ffelexHandler) ffeexpr_nil_real_;
  11436.  
  11437.     default:
  11438.       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
  11439.     }
  11440. }
  11441.  
  11442. static ffelexHandler
  11443. ffeexpr_nil_end_period_ (ffelexToken t)
  11444. {
  11445.   switch (ffeexpr_current_dotdot_)
  11446.     {
  11447.     case FFEEXPR_dotdotNOT_:
  11448.       if (ffelex_token_type (t) != FFELEX_typePERIOD)
  11449.     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
  11450.       return (ffelexHandler) ffeexpr_nil_rhs_;
  11451.  
  11452.     case FFEEXPR_dotdotTRUE_:
  11453.     case FFEEXPR_dotdotFALSE_:
  11454.       if (ffelex_token_type (t) != FFELEX_typePERIOD)
  11455.     return (ffelexHandler) ffeexpr_nil_binary_ (t);
  11456.       return (ffelexHandler) ffeexpr_nil_binary_;
  11457.  
  11458.     default:
  11459.       assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
  11460.       exit (0);
  11461.       return NULL;
  11462.     }
  11463. }
  11464.  
  11465. static ffelexHandler
  11466. ffeexpr_nil_swallow_period_ (ffelexToken t)
  11467. {
  11468.   if (ffelex_token_type (t) != FFELEX_typePERIOD)
  11469.     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
  11470.   return (ffelexHandler) ffeexpr_nil_rhs_;
  11471. }
  11472.  
  11473. static ffelexHandler
  11474. ffeexpr_nil_real_ (ffelexToken t)
  11475. {
  11476.   char d;
  11477.   char *p;
  11478.  
  11479.   if (((ffelex_token_type (t) != FFELEX_typeNAME)
  11480.        && (ffelex_token_type (t) != FFELEX_typeNAMES))
  11481.       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
  11482.                      'D', 'd')
  11483.          || ffesrc_char_match_init (d, 'E', 'e')
  11484.          || ffesrc_char_match_init (d, 'Q', 'q')))
  11485.        && ffeexpr_isdigits_ (++p)))
  11486.     return (ffelexHandler) ffeexpr_nil_binary_ (t);
  11487.  
  11488.   if (*p == '\0')
  11489.     return (ffelexHandler) ffeexpr_nil_real_exponent_;
  11490.   return (ffelexHandler) ffeexpr_nil_binary_;
  11491. }
  11492.  
  11493. static ffelexHandler
  11494. ffeexpr_nil_real_exponent_ (ffelexToken t)
  11495. {
  11496.   if ((ffelex_token_type (t) != FFELEX_typePLUS)
  11497.       && (ffelex_token_type (t) != FFELEX_typeMINUS))
  11498.     return (ffelexHandler) ffeexpr_nil_binary_ (t);
  11499.  
  11500.   return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
  11501. }
  11502.  
  11503. static ffelexHandler
  11504. ffeexpr_nil_real_exp_sign_ (ffelexToken t)
  11505. {
  11506.   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
  11507.     return (ffelexHandler) ffeexpr_nil_binary_ (t);
  11508.   return (ffelexHandler) ffeexpr_nil_binary_;
  11509. }
  11510.  
  11511. static ffelexHandler
  11512. ffeexpr_nil_number_ (ffelexToken t)
  11513. {
  11514.   char d;
  11515.   char *p;
  11516.  
  11517.   if (ffeexpr_hollerith_count_ > 0)
  11518.     ffelex_set_expecting_hollerith (0, '\0',
  11519.                     ffewhere_line_unknown (),
  11520.                     ffewhere_column_unknown ());
  11521.  
  11522.   switch (ffelex_token_type (t))
  11523.     {
  11524.     case FFELEX_typeNAME:
  11525.     case FFELEX_typeNAMES:
  11526.       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
  11527.                    'D', 'd')
  11528.        || ffesrc_char_match_init (d, 'E', 'e')
  11529.        || ffesrc_char_match_init (d, 'Q', 'q'))
  11530.       && ffeexpr_isdigits_ (++p))
  11531.     {
  11532.       if (*p == '\0')
  11533.         {
  11534.           ffeexpr_find_.t = ffelex_token_use (t);
  11535.           return (ffelexHandler) ffeexpr_nil_number_exponent_;
  11536.         }
  11537.       return (ffelexHandler) ffeexpr_nil_binary_;
  11538.     }
  11539.       break;
  11540.  
  11541.     case FFELEX_typePERIOD:
  11542.       ffeexpr_find_.t = ffelex_token_use (t);
  11543.       return (ffelexHandler) ffeexpr_nil_number_period_;
  11544.  
  11545.     case FFELEX_typeHOLLERITH:
  11546.       return (ffelexHandler) ffeexpr_nil_binary_;
  11547.  
  11548.     default:
  11549.       break;
  11550.     }
  11551.   return (ffelexHandler) ffeexpr_nil_binary_ (t);
  11552. }
  11553.  
  11554. /* Expects ffeexpr_find_.t.  */
  11555.  
  11556. static ffelexHandler
  11557. ffeexpr_nil_number_exponent_ (ffelexToken t)
  11558. {
  11559.   ffelexHandler nexthandler;
  11560.  
  11561.   if ((ffelex_token_type (t) != FFELEX_typePLUS)
  11562.       && (ffelex_token_type (t) != FFELEX_typeMINUS))
  11563.     {
  11564.       nexthandler
  11565.     = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
  11566.       ffelex_token_kill (ffeexpr_find_.t);
  11567.       return (ffelexHandler) (*nexthandler) (t);
  11568.     }
  11569.  
  11570.   ffelex_token_kill (ffeexpr_find_.t);
  11571.   return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
  11572. }
  11573.  
  11574. static ffelexHandler
  11575. ffeexpr_nil_number_exp_sign_ (ffelexToken t)
  11576. {
  11577.   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
  11578.     return (ffelexHandler) ffeexpr_nil_binary_ (t);
  11579.  
  11580.   return (ffelexHandler) ffeexpr_nil_binary_;
  11581. }
  11582.  
  11583. /* Expects ffeexpr_find_.t.  */
  11584.  
  11585. static ffelexHandler
  11586. ffeexpr_nil_number_period_ (ffelexToken t)
  11587. {
  11588.   ffelexHandler nexthandler;
  11589.   char d;
  11590.   char *p;
  11591.  
  11592.   switch (ffelex_token_type (t))
  11593.     {
  11594.     case FFELEX_typeNAME:
  11595.     case FFELEX_typeNAMES:
  11596.       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
  11597.                    'D', 'd')
  11598.        || ffesrc_char_match_init (d, 'E', 'e')
  11599.        || ffesrc_char_match_init (d, 'Q', 'q'))
  11600.       && ffeexpr_isdigits_ (++p))
  11601.     {
  11602.       if (*p == '\0')
  11603.         return (ffelexHandler) ffeexpr_nil_number_per_exp_;
  11604.       ffelex_token_kill (ffeexpr_find_.t);
  11605.       return (ffelexHandler) ffeexpr_nil_binary_;
  11606.     }
  11607.       nexthandler
  11608.     = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
  11609.       ffelex_token_kill (ffeexpr_find_.t);
  11610.       return (ffelexHandler) (*nexthandler) (t);
  11611.  
  11612.     case FFELEX_typeNUMBER:
  11613.       ffelex_token_kill (ffeexpr_find_.t);
  11614.       return (ffelexHandler) ffeexpr_nil_number_real_;
  11615.  
  11616.     default:
  11617.       break;
  11618.     }
  11619.   ffelex_token_kill (ffeexpr_find_.t);
  11620.   return (ffelexHandler) ffeexpr_nil_binary_ (t);
  11621. }
  11622.  
  11623. /* Expects ffeexpr_find_.t.  */
  11624.  
  11625. static ffelexHandler
  11626. ffeexpr_nil_number_per_exp_ (ffelexToken t)
  11627. {
  11628.   if ((ffelex_token_type (t) != FFELEX_typePLUS)
  11629.       && (ffelex_token_type (t) != FFELEX_typeMINUS))
  11630.     {
  11631.       ffelexHandler nexthandler;
  11632.  
  11633.       nexthandler
  11634.     = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
  11635.       ffelex_token_kill (ffeexpr_find_.t);
  11636.       return (ffelexHandler) (*nexthandler) (t);
  11637.     }
  11638.  
  11639.   ffelex_token_kill (ffeexpr_find_.t);
  11640.   return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
  11641. }
  11642.  
  11643. static ffelexHandler
  11644. ffeexpr_nil_number_real_ (ffelexToken t)
  11645. {
  11646.   char d;
  11647.   char *p;
  11648.  
  11649.   if (((ffelex_token_type (t) != FFELEX_typeNAME)
  11650.        && (ffelex_token_type (t) != FFELEX_typeNAMES))
  11651.       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
  11652.                      'D', 'd')
  11653.          || ffesrc_char_match_init (d, 'E', 'e')
  11654.          || ffesrc_char_match_init (d, 'Q', 'q')))
  11655.        && ffeexpr_isdigits_ (++p)))
  11656.     return (ffelexHandler) ffeexpr_nil_binary_ (t);
  11657.  
  11658.   if (*p == '\0')
  11659.     return (ffelexHandler) ffeexpr_nil_number_real_exp_;
  11660.  
  11661.   return (ffelexHandler) ffeexpr_nil_binary_;
  11662. }
  11663.  
  11664. static ffelexHandler
  11665. ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
  11666. {
  11667.   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
  11668.     return (ffelexHandler) ffeexpr_nil_binary_ (t);
  11669.   return (ffelexHandler) ffeexpr_nil_binary_;
  11670. }
  11671.  
  11672. static ffelexHandler
  11673. ffeexpr_nil_number_real_exp_ (ffelexToken t)
  11674. {
  11675.   if ((ffelex_token_type (t) != FFELEX_typePLUS)
  11676.       && (ffelex_token_type (t) != FFELEX_typeMINUS))
  11677.     return (ffelexHandler) ffeexpr_nil_binary_ (t);
  11678.   return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
  11679. }
  11680.  
  11681. static ffelexHandler
  11682. ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
  11683. {
  11684.   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
  11685.     return (ffelexHandler) ffeexpr_nil_binary_ (t);
  11686.   return (ffelexHandler) ffeexpr_nil_binary_;
  11687. }
  11688.  
  11689. static ffelexHandler
  11690. ffeexpr_nil_binary_ (ffelexToken t)
  11691. {
  11692.   switch (ffelex_token_type (t))
  11693.     {
  11694.     case FFELEX_typePLUS:
  11695.     case FFELEX_typeMINUS:
  11696.     case FFELEX_typeASTERISK:
  11697.     case FFELEX_typeSLASH:
  11698.     case FFELEX_typePOWER:
  11699.     case FFELEX_typeCONCAT:
  11700.     case FFELEX_typeOPEN_ANGLE:
  11701.     case FFELEX_typeCLOSE_ANGLE:
  11702.     case FFELEX_typeREL_EQ:
  11703.     case FFELEX_typeREL_NE:
  11704.     case FFELEX_typeREL_GE:
  11705.     case FFELEX_typeREL_LE:
  11706.       return (ffelexHandler) ffeexpr_nil_rhs_;
  11707.  
  11708.     case FFELEX_typePERIOD:
  11709.       return (ffelexHandler) ffeexpr_nil_binary_period_;
  11710.  
  11711.     default:
  11712.       return (ffelexHandler) ffeexpr_nil_finished_ (t);
  11713.     }
  11714. }
  11715.  
  11716. static ffelexHandler
  11717. ffeexpr_nil_binary_period_ (ffelexToken t)
  11718. {
  11719.   switch (ffelex_token_type (t))
  11720.     {
  11721.     case FFELEX_typeNAME:
  11722.     case FFELEX_typeNAMES:
  11723.       ffeexpr_current_dotdot_ = ffeexpr_dotdot_ (t);
  11724.       switch (ffeexpr_current_dotdot_)
  11725.     {
  11726.     case FFEEXPR_dotdotTRUE_:
  11727.     case FFEEXPR_dotdotFALSE_:
  11728.     case FFEEXPR_dotdotNOT_:
  11729.       return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
  11730.  
  11731.     default:
  11732.       return (ffelexHandler) ffeexpr_nil_binary_end_per_;
  11733.     }
  11734.       break;            /* Nothing really reaches here. */
  11735.  
  11736.     default:
  11737.       return (ffelexHandler) ffeexpr_nil_binary_ (t);
  11738.     }
  11739. }
  11740.  
  11741. static ffelexHandler
  11742. ffeexpr_nil_binary_end_per_ (ffelexToken t)
  11743. {
  11744.   if (ffelex_token_type (t) != FFELEX_typePERIOD)
  11745.     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
  11746.   return (ffelexHandler) ffeexpr_nil_rhs_;
  11747. }
  11748.  
  11749. static ffelexHandler
  11750. ffeexpr_nil_binary_sw_per_ (ffelexToken t)
  11751. {
  11752.   if (ffelex_token_type (t) != FFELEX_typePERIOD)
  11753.     return (ffelexHandler) ffeexpr_nil_binary_ (t);
  11754.   return (ffelexHandler) ffeexpr_nil_binary_;
  11755. }
  11756.  
  11757. static ffelexHandler
  11758. ffeexpr_nil_quote_ (ffelexToken t)
  11759. {
  11760.   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
  11761.     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
  11762.   return (ffelexHandler) ffeexpr_nil_binary_;
  11763. }
  11764.  
  11765. static ffelexHandler
  11766. ffeexpr_nil_apostrophe_ (ffelexToken t)
  11767. {
  11768.   assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
  11769.   return (ffelexHandler) ffeexpr_nil_apos_char_;
  11770. }
  11771.  
  11772. static ffelexHandler
  11773. ffeexpr_nil_apos_char_ (ffelexToken t)
  11774. {
  11775.   char c;
  11776.  
  11777.   if ((ffelex_token_type (t) == FFELEX_typeNAME)
  11778.       || (ffelex_token_type (t) == FFELEX_typeNAMES))
  11779.     {
  11780.       if ((ffelex_token_length (t) == 1)
  11781.       && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
  11782.                       'B', 'b')
  11783.           || ffesrc_char_match_init (c, 'O', 'o')
  11784.           || ffesrc_char_match_init (c, 'X', 'x')
  11785.           || ffesrc_char_match_init (c, 'Z', 'z')))
  11786.     return (ffelexHandler) ffeexpr_nil_binary_;
  11787.     }
  11788.   if ((ffelex_token_type (t) == FFELEX_typeNAME)
  11789.       || (ffelex_token_type (t) == FFELEX_typeNAMES))
  11790.     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
  11791.   return (ffelexHandler) ffeexpr_nil_substrp_ (t);
  11792. }
  11793.  
  11794. static ffelexHandler
  11795. ffeexpr_nil_name_rhs_ (ffelexToken t)
  11796. {
  11797.   switch (ffelex_token_type (t))
  11798.     {
  11799.     case FFELEX_typeQUOTE:
  11800.     case FFELEX_typeAPOSTROPHE:
  11801.       ffelex_set_hexnum (TRUE);
  11802.       return (ffelexHandler) ffeexpr_nil_name_apos_;
  11803.  
  11804.     case FFELEX_typeOPEN_PAREN:
  11805.       ++ffeexpr_find_.level;
  11806.       return (ffelexHandler) ffeexpr_nil_rhs_;
  11807.  
  11808.     default:
  11809.       return (ffelexHandler) ffeexpr_nil_binary_ (t);
  11810.     }
  11811. }
  11812.  
  11813. static ffelexHandler
  11814. ffeexpr_nil_name_apos_ (ffelexToken t)
  11815. {
  11816.   if (ffelex_token_type (t) == FFELEX_typeNAME)
  11817.     return (ffelexHandler) ffeexpr_nil_name_apos_name_;
  11818.   return (ffelexHandler) ffeexpr_nil_binary_ (t);
  11819. }
  11820.  
  11821. static ffelexHandler
  11822. ffeexpr_nil_name_apos_name_ (ffelexToken t)
  11823. {
  11824.   switch (ffelex_token_type (t))
  11825.     {
  11826.     case FFELEX_typeAPOSTROPHE:
  11827.     case FFELEX_typeQUOTE:
  11828.       return (ffelexHandler) ffeexpr_nil_finished_;
  11829.  
  11830.     default:
  11831.       return (ffelexHandler) ffeexpr_nil_finished_ (t);
  11832.     }
  11833. }
  11834.  
  11835. static ffelexHandler
  11836. ffeexpr_nil_percent_ (ffelexToken t)
  11837. {
  11838.   switch (ffelex_token_type (t))
  11839.     {
  11840.     case FFELEX_typeNAME:
  11841.     case FFELEX_typeNAMES:
  11842.       ffeexpr_stack_->percent = ffeexpr_percent_ (t);
  11843.       ffeexpr_find_.t = ffelex_token_use (t);
  11844.       return (ffelexHandler) ffeexpr_nil_percent_name_;
  11845.  
  11846.     default:
  11847.       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
  11848.     }
  11849. }
  11850.  
  11851. /* Expects ffeexpr_find_.t.  */
  11852.  
  11853. static ffelexHandler
  11854. ffeexpr_nil_percent_name_ (ffelexToken t)
  11855. {
  11856.   ffelexHandler nexthandler;
  11857.  
  11858.   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
  11859.     {
  11860.       nexthandler
  11861.     = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
  11862.       ffelex_token_kill (ffeexpr_find_.t);
  11863.       return (ffelexHandler) (*nexthandler) (t);
  11864.     }
  11865.  
  11866.   ffelex_token_kill (ffeexpr_find_.t);
  11867.   ++ffeexpr_find_.level;
  11868.   return (ffelexHandler) ffeexpr_nil_rhs_;
  11869. }
  11870.  
  11871. static ffelexHandler
  11872. ffeexpr_nil_substrp_ (ffelexToken t)
  11873. {
  11874.   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
  11875.     return (ffelexHandler) ffeexpr_nil_binary_ (t);
  11876.  
  11877.   ++ffeexpr_find_.level;
  11878.   return (ffelexHandler) ffeexpr_nil_rhs_;
  11879. }
  11880.  
  11881. /* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
  11882.  
  11883.    ffelexToken t;
  11884.    return ffeexpr_finished_(t);
  11885.  
  11886.    Reduces expression stack to one (or zero) elements by repeatedly reducing
  11887.    the top operator on the stack (or, if the top element on the stack is
  11888.    itself an operator, issuing an error message and discarding it).  Calls
  11889.    finishing routine with the expression, returning the ffelexHandler it
  11890.    returns to the caller.  */
  11891.  
  11892. static ffelexHandler
  11893. ffeexpr_finished_ (ffelexToken t)
  11894. {
  11895.   ffeexprExpr_ operand;        /* This is B in -B or A+B. */
  11896.   ffebld expr;
  11897.   ffeexprCallback callback;
  11898.   ffeexprStack_ s;
  11899.   ffebldConstant constnode;    /* For detecting magical number. */
  11900.   ffelexToken ft;        /* Temporary copy of first token in
  11901.                    expression. */
  11902.   ffelexHandler next;
  11903.   ffeinfo info;
  11904.   bool error = FALSE;
  11905.  
  11906.   while (((operand = ffeexpr_stack_->exprstack) != NULL)
  11907.      && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
  11908.     {
  11909.       if (operand->type == FFEEXPR_exprtypeOPERAND_)
  11910.     ffeexpr_reduce_ ();
  11911.       else
  11912.     {
  11913.       if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
  11914.         {
  11915.           ffebad_here (0, ffelex_token_where_line (t),
  11916.                ffelex_token_where_column (t));
  11917.           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
  11918.           ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
  11919.           ffebad_finish ();
  11920.         }
  11921.       ffeexpr_stack_->exprstack = operand->previous;    /* Pop the useless
  11922.                                    operator. */
  11923.       ffeexpr_expr_kill_ (operand);
  11924.     }
  11925.     }
  11926.  
  11927.   assert ((operand == NULL) || (operand->previous == NULL));
  11928.  
  11929.   ffebld_pool_pop ();
  11930.   if (operand == NULL)
  11931.     expr = NULL;
  11932.   else
  11933.     {
  11934.       expr = operand->u.operand;
  11935.       info = ffebld_info (expr);
  11936.       if ((ffebld_op (expr) == FFEBLD_opCONTER)
  11937.       && (ffebld_conter_orig (expr) == NULL)
  11938.       && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
  11939.     {
  11940.       ffetarget_integer_bad_magical (operand->token);
  11941.     }
  11942.       ffeexpr_expr_kill_ (operand);
  11943.       ffeexpr_stack_->exprstack = NULL;
  11944.     }
  11945.  
  11946.   ft = ffeexpr_stack_->first_token;
  11947.  
  11948. again:                /* :::::::::::::::::::: */
  11949.   switch (ffeexpr_stack_->context)
  11950.     {
  11951.     case FFEEXPR_contextLET:
  11952.     case FFEEXPR_contextSFUNCDEF:
  11953.       error = (expr == NULL)
  11954.     || (ffeinfo_rank (info) != 0);
  11955.       break;
  11956.  
  11957.     case FFEEXPR_contextPAREN_:
  11958.       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
  11959.     break;
  11960.       switch (ffeinfo_basictype (info))
  11961.     {
  11962.     case FFEINFO_basictypeHOLLERITH:
  11963.     case FFEINFO_basictypeTYPELESS:
  11964.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  11965.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  11966.                   FFEEXPR_contextLET);
  11967.       break;
  11968.  
  11969.     default:
  11970.       break;
  11971.     }
  11972.       break;
  11973.  
  11974.     case FFEEXPR_contextPARENFILENUM_:
  11975.       if (ffelex_token_type (t) != FFELEX_typeCOMMA)
  11976.     ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
  11977.       else
  11978.     ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
  11979.       goto again;        /* :::::::::::::::::::: */
  11980.  
  11981.     case FFEEXPR_contextPARENFILEUNIT_:
  11982.       if (ffelex_token_type (t) != FFELEX_typeCOMMA)
  11983.     ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
  11984.       else
  11985.     ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
  11986.       goto again;        /* :::::::::::::::::::: */
  11987.  
  11988.     case FFEEXPR_contextACTUALARGEXPR_:
  11989.     case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
  11990.       switch ((expr == NULL) ? FFEINFO_basictypeNONE
  11991.           : ffeinfo_basictype (info))
  11992.     {
  11993.     case FFEINFO_basictypeHOLLERITH:
  11994.     case FFEINFO_basictypeTYPELESS:
  11995.       if (!ffe_is_ugly_args ()
  11996.           && ffebad_start (FFEBAD_ACTUALARG))
  11997.         {
  11998.           ffebad_here (0, ffelex_token_where_line (ft),
  11999.                ffelex_token_where_column (ft));
  12000.           ffebad_finish ();
  12001.         }
  12002.       break;
  12003.  
  12004.     default:
  12005.       break;
  12006.     }
  12007.       error = ((expr == NULL) && ffe_is_pedantic ())
  12008.     || ((expr != NULL) && (ffeinfo_rank (info) != 0));
  12009.       break;
  12010.  
  12011.     case FFEEXPR_contextACTUALARG_:
  12012.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  12013.       switch ((expr == NULL) ? FFEINFO_basictypeNONE
  12014.           : ffeinfo_basictype (info))
  12015.     {
  12016.     case FFEINFO_basictypeHOLLERITH:
  12017.     case FFEINFO_basictypeTYPELESS:
  12018. #if 0                /* Should never get here. */
  12019.       expr = ffeexpr_convert (expr, ft, ft,
  12020.                   FFEINFO_basictypeINTEGER,
  12021.                   FFEINFO_kindtypeINTEGERDEFAULT,
  12022.                   0,
  12023.                   FFETARGET_charactersizeNONE,
  12024.                   FFEEXPR_contextLET);
  12025. #else
  12026.       assert ("why hollerith/typeless in actualarg_?" == NULL);
  12027. #endif
  12028.       break;
  12029.  
  12030.     default:
  12031.       break;
  12032.     }
  12033.       switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
  12034.     {
  12035.     case FFEBLD_opSYMTER:
  12036.     case FFEBLD_opPERCENT_LOC:
  12037.     case FFEBLD_opPERCENT_VAL:
  12038.     case FFEBLD_opPERCENT_REF:
  12039.     case FFEBLD_opPERCENT_DESCR:
  12040.       error = FALSE;
  12041.       break;
  12042.  
  12043.     default:
  12044.       error = (expr != NULL) && (ffeinfo_rank (info) != 0);
  12045.       break;
  12046.     }
  12047.       {
  12048.     ffesymbol s;
  12049.     ffeinfoWhere where;
  12050.     ffeinfoKind kind;
  12051.  
  12052.     if (!error
  12053.         && (expr != NULL)
  12054.         && (ffebld_op (expr) == FFEBLD_opSYMTER)
  12055.         && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
  12056.         (where == FFEINFO_whereINTRINSIC)
  12057.         || (where == FFEINFO_whereGLOBAL)
  12058.         || ((where == FFEINFO_whereDUMMY)
  12059.             && ((kind = ffesymbol_kind (s)),
  12060.             (kind == FFEINFO_kindFUNCTION)
  12061.             || (kind == FFEINFO_kindSUBROUTINE))))
  12062.         && !ffesymbol_explicitwhere (s))
  12063.       {
  12064.         ffebad_start (where == FFEINFO_whereINTRINSIC
  12065.               ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
  12066.         ffebad_here (0, ffelex_token_where_line (ft),
  12067.              ffelex_token_where_column (ft));
  12068.         ffebad_string (ffesymbol_text (s));
  12069.         ffebad_finish ();
  12070.         ffesymbol_signal_change (s);
  12071.         ffesymbol_set_explicitwhere (s, TRUE);
  12072.         ffesymbol_signal_unreported (s);
  12073.       }
  12074.       }
  12075.       break;
  12076.  
  12077.     case FFEEXPR_contextINDEX_:
  12078.     case FFEEXPR_contextSFUNCDEFINDEX_:
  12079.     case FFEEXPR_contextRETURN:
  12080.       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
  12081.     break;
  12082.       switch ((expr == NULL) ? FFEINFO_basictypeNONE
  12083.           : ffeinfo_basictype (info))
  12084.     {
  12085.     case FFEINFO_basictypeNONE:
  12086.       error = FALSE;
  12087.       break;
  12088.  
  12089.     case FFEINFO_basictypeLOGICAL:
  12090.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
  12091.          FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
  12092.                   FFEEXPR_contextLET);
  12093.       /* Fall through. */
  12094.     case FFEINFO_basictypeREAL:
  12095.     case FFEINFO_basictypeCOMPLEX:
  12096.       if (ffe_is_pedantic ())
  12097.         {
  12098.           error = TRUE;
  12099.           break;
  12100.         }
  12101.       /* Fall through. */
  12102.     case FFEINFO_basictypeINTEGER:
  12103.     case FFEINFO_basictypeHOLLERITH:
  12104.     case FFEINFO_basictypeTYPELESS:
  12105.       error = FALSE;
  12106.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12107.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12108.                   FFEEXPR_contextLET);
  12109.       break;
  12110.  
  12111.     default:
  12112.       error = TRUE;
  12113.       break;
  12114.     }
  12115.       break;            /* expr==NULL ok for substring; element case
  12116.                    caught by callback. */
  12117.  
  12118.     case FFEEXPR_contextDO:
  12119.       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
  12120.     break;
  12121.       switch (ffeinfo_basictype (info))
  12122.     {
  12123.     case FFEINFO_basictypeLOGICAL:
  12124.       error = FALSE;
  12125.       if (!ffeexpr_stack_->is_rhs)
  12126.         {
  12127.           if (!ffe_is_ugly ())
  12128.         error = TRUE;
  12129.           break;        /* Don't convert lhs variable. */
  12130.         }
  12131.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
  12132.          FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
  12133.                   FFEEXPR_contextLET);
  12134.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12135.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12136.                   FFEEXPR_contextLET);
  12137.       break;
  12138.  
  12139.     case FFEINFO_basictypeHOLLERITH:
  12140.     case FFEINFO_basictypeTYPELESS:
  12141.       error = FALSE;
  12142.       if (!ffeexpr_stack_->is_rhs)
  12143.         {
  12144.           error = TRUE;
  12145.           break;        /* Don't convert lhs variable. */
  12146.         }
  12147.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12148.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12149.                   FFEEXPR_contextLET);
  12150.       break;
  12151.  
  12152.     case FFEINFO_basictypeINTEGER:
  12153.     case FFEINFO_basictypeREAL:
  12154.       break;
  12155.  
  12156.     default:
  12157.       error = TRUE;
  12158.       break;
  12159.     }
  12160.       if (!ffeexpr_stack_->is_rhs
  12161.       && (ffebld_op (expr) != FFEBLD_opSYMTER))
  12162.     error = TRUE;
  12163.       break;
  12164.  
  12165.     case FFEEXPR_contextDOWHILE:
  12166.     case FFEEXPR_contextIF:
  12167.       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
  12168.     break;
  12169.       switch (ffeinfo_basictype (info))
  12170.     {
  12171.     case FFEINFO_basictypeINTEGER:
  12172.       error = FALSE;
  12173.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12174.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12175.                   FFEEXPR_contextLET);
  12176.       /* Fall through. */
  12177.     case FFEINFO_basictypeLOGICAL:
  12178.     case FFEINFO_basictypeHOLLERITH:
  12179.     case FFEINFO_basictypeTYPELESS:
  12180.       error = FALSE;
  12181.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
  12182.          FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
  12183.                   FFEEXPR_contextLET);
  12184.       break;
  12185.  
  12186.     default:
  12187.       error = TRUE;
  12188.       break;
  12189.     }
  12190.       break;
  12191.  
  12192.     case FFEEXPR_contextASSIGN:
  12193.     case FFEEXPR_contextAGOTO:
  12194.       switch ((expr == NULL) ? FFEINFO_basictypeNONE
  12195.           : ffeinfo_basictype (info))
  12196.     {
  12197.     case FFEINFO_basictypeINTEGER:
  12198.       error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
  12199.       break;
  12200.  
  12201.     case FFEINFO_basictypeLOGICAL:
  12202.       error = !ffe_is_ugly ()
  12203.         || (ffeinfo_kindtype (info) != FFEINFO_kindtypeLOGICALDEFAULT);
  12204.       break;
  12205.  
  12206.     default:
  12207.       error = TRUE;
  12208.       break;
  12209.     }
  12210.       if ((expr == NULL) || (ffeinfo_rank (info) != 0)
  12211.       || (ffebld_op (expr) != FFEBLD_opSYMTER))
  12212.     error = TRUE;
  12213.       break;
  12214.  
  12215.     case FFEEXPR_contextCGOTO:
  12216.     case FFEEXPR_contextFORMAT:
  12217.     case FFEEXPR_contextDIMLIST:
  12218.     case FFEEXPR_contextFILENUM:    /* See equiv code in _ambig_. */
  12219.       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
  12220.     break;
  12221.       switch (ffeinfo_basictype (info))
  12222.     {
  12223.     case FFEINFO_basictypeLOGICAL:
  12224.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
  12225.          FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
  12226.                   FFEEXPR_contextLET);
  12227.       /* Fall through. */
  12228.     case FFEINFO_basictypeREAL:
  12229.     case FFEINFO_basictypeCOMPLEX:
  12230.       if (ffe_is_pedantic ())
  12231.         {
  12232.           error = TRUE;
  12233.           break;
  12234.         }
  12235.       /* Fall through. */
  12236.     case FFEINFO_basictypeINTEGER:
  12237.     case FFEINFO_basictypeHOLLERITH:
  12238.     case FFEINFO_basictypeTYPELESS:
  12239.       error = FALSE;
  12240.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12241.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12242.                   FFEEXPR_contextLET);
  12243.       break;
  12244.  
  12245.     default:
  12246.       error = TRUE;
  12247.       break;
  12248.     }
  12249.       break;
  12250.  
  12251.     case FFEEXPR_contextARITHIF:
  12252.       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
  12253.     break;
  12254.       switch (ffeinfo_basictype (info))
  12255.     {
  12256.     case FFEINFO_basictypeLOGICAL:
  12257.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
  12258.          FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
  12259.                   FFEEXPR_contextLET);
  12260.       if (ffe_is_pedantic ())
  12261.         {
  12262.           error = TRUE;
  12263.           break;
  12264.         }
  12265.       /* Fall through. */
  12266.     case FFEINFO_basictypeHOLLERITH:
  12267.     case FFEINFO_basictypeTYPELESS:
  12268.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12269.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12270.                   FFEEXPR_contextLET);
  12271.       /* Fall through. */
  12272.     case FFEINFO_basictypeINTEGER:
  12273.     case FFEINFO_basictypeREAL:
  12274.       error = FALSE;
  12275.       break;
  12276.  
  12277.     default:
  12278.       error = TRUE;
  12279.       break;
  12280.     }
  12281.       break;
  12282.  
  12283.     case FFEEXPR_contextSTOP:
  12284.       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
  12285.     break;
  12286.       switch ((expr == NULL) ? FFEINFO_basictypeNONE
  12287.           : ffeinfo_basictype (info))
  12288.     {
  12289.     case FFEINFO_basictypeINTEGER:
  12290.       error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
  12291.       break;
  12292.  
  12293.     case FFEINFO_basictypeCHARACTER:
  12294.       error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
  12295.       break;
  12296.  
  12297.     case FFEINFO_basictypeHOLLERITH:
  12298.     case FFEINFO_basictypeTYPELESS:
  12299.       error = FALSE;
  12300.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12301.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12302.                   FFEEXPR_contextLET);
  12303.       break;
  12304.  
  12305.     case FFEINFO_basictypeNONE:
  12306.       error = FALSE;
  12307.       break;
  12308.  
  12309.     default:
  12310.       error = TRUE;
  12311.       break;
  12312.     }
  12313.       if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
  12314.                  || (ffebld_conter_orig (expr) != NULL)))
  12315.     error = TRUE;
  12316.       break;
  12317.  
  12318.     case FFEEXPR_contextINCLUDE:
  12319.       error = (expr == NULL) || (ffeinfo_rank (info) != 0)
  12320.     || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
  12321.     || (ffebld_op (expr) != FFEBLD_opCONTER)
  12322.     || (ffebld_conter_orig (expr) != NULL);
  12323.       break;
  12324.  
  12325.     case FFEEXPR_contextSELECTCASE:
  12326.       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
  12327.     break;
  12328.       switch (ffeinfo_basictype (info))
  12329.     {
  12330.     case FFEINFO_basictypeINTEGER:
  12331.     case FFEINFO_basictypeCHARACTER:
  12332.     case FFEINFO_basictypeLOGICAL:
  12333.       error = FALSE;
  12334.       break;
  12335.  
  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_contextCASE:
  12351.       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
  12352.     break;
  12353.       switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
  12354.           : ffeinfo_basictype (info))
  12355.     {
  12356.     case FFEINFO_basictypeINTEGER:
  12357.     case FFEINFO_basictypeCHARACTER:
  12358.     case FFEINFO_basictypeLOGICAL:
  12359.       error = FALSE;
  12360.       break;
  12361.  
  12362.     case FFEINFO_basictypeHOLLERITH:
  12363.     case FFEINFO_basictypeTYPELESS:
  12364.       error = FALSE;
  12365.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12366.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12367.                   FFEEXPR_contextLET);
  12368.       break;
  12369.  
  12370.     default:
  12371.       error = TRUE;
  12372.       break;
  12373.     }
  12374.       if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
  12375.     error = TRUE;
  12376.       break;
  12377.  
  12378.     case FFEEXPR_contextCHARACTERSIZE:
  12379.     case FFEEXPR_contextKINDTYPE:
  12380.     case FFEEXPR_contextDIMLISTCOMMON:
  12381.       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
  12382.     break;
  12383.       switch ((expr == NULL) ? FFEINFO_basictypeNONE
  12384.           : ffeinfo_basictype (info))
  12385.     {
  12386.     case FFEINFO_basictypeLOGICAL:
  12387.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
  12388.          FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
  12389.                   FFEEXPR_contextLET);
  12390.       /* Fall through. */
  12391.     case FFEINFO_basictypeREAL:
  12392.     case FFEINFO_basictypeCOMPLEX:
  12393.       if (ffe_is_pedantic ())
  12394.         {
  12395.           error = TRUE;
  12396.           break;
  12397.         }
  12398.       /* Fall through. */
  12399.     case FFEINFO_basictypeINTEGER:
  12400.     case FFEINFO_basictypeHOLLERITH:
  12401.     case FFEINFO_basictypeTYPELESS:
  12402.       error = FALSE;
  12403.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12404.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12405.                   FFEEXPR_contextLET);
  12406.       break;
  12407.  
  12408.     default:
  12409.       error = TRUE;
  12410.       break;
  12411.     }
  12412.       if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
  12413.     error = TRUE;
  12414.       break;
  12415.  
  12416.     case FFEEXPR_contextEQVINDEX_:
  12417.       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
  12418.     break;
  12419.       switch ((expr == NULL) ? FFEINFO_basictypeNONE
  12420.           : ffeinfo_basictype (info))
  12421.     {
  12422.     case FFEINFO_basictypeNONE:
  12423.       error = FALSE;
  12424.       break;
  12425.  
  12426.     case FFEINFO_basictypeLOGICAL:
  12427.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
  12428.          FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
  12429.                   FFEEXPR_contextLET);
  12430.       /* Fall through. */
  12431.     case FFEINFO_basictypeREAL:
  12432.     case FFEINFO_basictypeCOMPLEX:
  12433.       if (ffe_is_pedantic ())
  12434.         {
  12435.           error = TRUE;
  12436.           break;
  12437.         }
  12438.       /* Fall through. */
  12439.     case FFEINFO_basictypeINTEGER:
  12440.     case FFEINFO_basictypeHOLLERITH:
  12441.     case FFEINFO_basictypeTYPELESS:
  12442.       error = FALSE;
  12443.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12444.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12445.                   FFEEXPR_contextLET);
  12446.       break;
  12447.  
  12448.     default:
  12449.       error = TRUE;
  12450.       break;
  12451.     }
  12452.       if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
  12453.     error = TRUE;
  12454.       break;
  12455.  
  12456.     case FFEEXPR_contextPARAMETER:
  12457.       if (ffeexpr_stack_->is_rhs)
  12458.     error = (expr == NULL) || (ffeinfo_rank (info) != 0)
  12459.       || (ffebld_op (expr) != FFEBLD_opCONTER);
  12460.       else
  12461.     error = (expr == NULL) || (ffeinfo_rank (info) != 0)
  12462.       || (ffebld_op (expr) != FFEBLD_opSYMTER);
  12463.       break;
  12464.  
  12465.     case FFEEXPR_contextINDEXORACTUALARG_:
  12466.       if (ffelex_token_type (t) == FFELEX_typeCOLON)
  12467.     ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
  12468.       else
  12469.     ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
  12470.       goto again;        /* :::::::::::::::::::: */
  12471.  
  12472.     case FFEEXPR_contextINDEXORACTUALARGEXPR_:
  12473.       if (ffelex_token_type (t) == FFELEX_typeCOLON)
  12474.     ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
  12475.       else
  12476.     ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
  12477.       goto again;        /* :::::::::::::::::::: */
  12478.  
  12479.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  12480.       if (ffelex_token_type (t) == FFELEX_typeCOLON)
  12481.     ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
  12482.       else
  12483.     ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
  12484.       goto again;        /* :::::::::::::::::::: */
  12485.  
  12486.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
  12487.       if (ffelex_token_type (t) == FFELEX_typeCOLON)
  12488.     ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
  12489.       else
  12490.     ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
  12491.       goto again;        /* :::::::::::::::::::: */
  12492.  
  12493.     case FFEEXPR_contextIMPDOCTRL_:
  12494.       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
  12495.     break;
  12496.       switch (ffeinfo_basictype (info))
  12497.     {
  12498.     case FFEINFO_basictypeLOGICAL:
  12499.       error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeLOGICALDEFAULT);
  12500.       if (!ffeexpr_stack_->is_rhs)
  12501.         break;        /* Don't convert lhs variable. */
  12502.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12503.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12504.                   FFEEXPR_contextLET);
  12505.       break;
  12506.  
  12507.     case FFEINFO_basictypeINTEGER:
  12508.       error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
  12509.       break;
  12510.  
  12511.     case FFEINFO_basictypeHOLLERITH:
  12512.     case FFEINFO_basictypeTYPELESS:
  12513.       error = FALSE;
  12514.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12515.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12516.                   FFEEXPR_contextLET);
  12517.       break;
  12518.  
  12519.     case FFEINFO_basictypeREAL:
  12520.       error = !ffe_is_pedantic () && !ffe_is_ugly ();
  12521.       /* Only pedantic/ugly ALLOWED to use REAL! */
  12522.       break;
  12523.  
  12524.     default:
  12525.       error = TRUE;
  12526.       break;
  12527.     }
  12528.       if (!ffeexpr_stack_->is_rhs
  12529.       && (ffebld_op (expr) != FFEBLD_opSYMTER))
  12530.     error = TRUE;
  12531.       break;
  12532.  
  12533.     case FFEEXPR_contextDATAIMPDOCTRL_:
  12534.       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
  12535.     break;
  12536.       switch (ffeinfo_basictype (info))
  12537.     {
  12538.     case FFEINFO_basictypeLOGICAL:
  12539.       error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeLOGICALDEFAULT);
  12540.       if (!ffeexpr_stack_->is_rhs)
  12541.         break;        /* Don't convert lhs variable. */
  12542.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12543.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12544.                   FFEEXPR_contextLET);
  12545.       break;
  12546.  
  12547.     case FFEINFO_basictypeINTEGER:
  12548.       error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
  12549.       break;
  12550.  
  12551.     case FFEINFO_basictypeHOLLERITH:
  12552.     case FFEINFO_basictypeTYPELESS:
  12553.       error = FALSE;
  12554.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12555.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12556.                   FFEEXPR_contextLET);
  12557.       break;
  12558.  
  12559.     case FFEINFO_basictypeREAL:
  12560.       error = !ffe_is_pedantic () && !ffe_is_ugly ();
  12561.       /* Only pedantic/ugly ALLOWED to use REAL! */
  12562.       break;
  12563.  
  12564.     default:
  12565.       error = TRUE;
  12566.       break;
  12567.     }
  12568.       if (ffeexpr_stack_->is_rhs)
  12569.     {
  12570.       if ((ffebld_op (expr) != FFEBLD_opCONTER)
  12571.           && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
  12572.         error = TRUE;
  12573.     }
  12574.       else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
  12575.            || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
  12576.     error = TRUE;
  12577.       break;
  12578.  
  12579.     case FFEEXPR_contextIMPDOITEM_:
  12580.       if (ffelex_token_type (t) == FFELEX_typeEQUALS)
  12581.     {
  12582.       ffeexpr_stack_->is_rhs = FALSE;
  12583.       ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
  12584.       goto again;        /* :::::::::::::::::::: */
  12585.     }
  12586.       /* Fall through. */
  12587.     case FFEEXPR_contextIOLIST:
  12588.     case FFEEXPR_contextFILEVXTCODE:
  12589.       switch ((expr == NULL) ? FFEINFO_basictypeNONE
  12590.           : ffeinfo_basictype (info))
  12591.     {
  12592.     case FFEINFO_basictypeHOLLERITH:
  12593.     case FFEINFO_basictypeTYPELESS:
  12594.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12595.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12596.                   FFEEXPR_contextLET);
  12597.       break;
  12598.  
  12599.     default:
  12600.       break;
  12601.     }
  12602.       error = (expr == NULL)
  12603.     || ((ffeinfo_rank (info) != 0)
  12604.         && ((ffebld_op (expr) != FFEBLD_opSYMTER)
  12605.         || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
  12606.         || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
  12607.             == FFEBLD_opSTAR)));    /* Bad if null expr, or if
  12608.                            array that is not a SYMTER
  12609.                            (can't happen yet, I
  12610.                            think) or has a NULL or
  12611.                            STAR (assumed) array
  12612.                            size. */
  12613.       break;
  12614.  
  12615.     case FFEEXPR_contextIMPDOITEMDF_:
  12616.       if (ffelex_token_type (t) == FFELEX_typeEQUALS)
  12617.     {
  12618.       ffeexpr_stack_->is_rhs = FALSE;
  12619.       ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
  12620.       goto again;        /* :::::::::::::::::::: */
  12621.     }
  12622.       /* Fall through. */
  12623.     case FFEEXPR_contextIOLISTDF:
  12624.       switch ((expr == NULL) ? FFEINFO_basictypeNONE
  12625.           : ffeinfo_basictype (info))
  12626.     {
  12627.     case FFEINFO_basictypeHOLLERITH:
  12628.     case FFEINFO_basictypeTYPELESS:
  12629.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12630.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12631.                   FFEEXPR_contextLET);
  12632.       break;
  12633.  
  12634.     default:
  12635.       break;
  12636.     }
  12637.       error
  12638.     = (expr == NULL)
  12639.       || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
  12640.           && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
  12641.         || ((ffeinfo_rank (info) != 0)
  12642.         && ((ffebld_op (expr) != FFEBLD_opSYMTER)
  12643.             || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
  12644.             || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
  12645.             == FFEBLD_opSTAR)));    /* Bad if null expr,
  12646.                            non-default-kindtype
  12647.                            character expr, or if
  12648.                            array that is not a SYMTER
  12649.                            (can't happen yet, I
  12650.                            think) or has a NULL or
  12651.                            STAR (assumed) array
  12652.                            size. */
  12653.       break;
  12654.  
  12655.     case FFEEXPR_contextDATAIMPDOITEM_:
  12656.       error = (expr == NULL)
  12657.     || (ffebld_op (expr) != FFEBLD_opARRAYREF)
  12658.     || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
  12659.         && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
  12660.       break;
  12661.  
  12662.     case FFEEXPR_contextDATAIMPDOINDEX_:
  12663.       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
  12664.     break;
  12665.       switch (ffeinfo_basictype (info))
  12666.     {
  12667.     case FFEINFO_basictypeLOGICAL:
  12668.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
  12669.          FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
  12670.                   FFEEXPR_contextLET);
  12671.       /* Fall through. */
  12672.     case FFEINFO_basictypeREAL:
  12673.     case FFEINFO_basictypeCOMPLEX:
  12674.       if (ffe_is_pedantic ())
  12675.         {
  12676.           error = TRUE;
  12677.           break;
  12678.         }
  12679.       /* Fall through. */
  12680.     case FFEINFO_basictypeINTEGER:
  12681.     case FFEINFO_basictypeHOLLERITH:
  12682.     case FFEINFO_basictypeTYPELESS:
  12683.       error = FALSE;
  12684.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12685.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12686.                   FFEEXPR_contextLET);
  12687.       break;
  12688.  
  12689.     default:
  12690.       error = TRUE;
  12691.       break;
  12692.     }
  12693.       if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
  12694.       && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
  12695.     error = TRUE;
  12696.       break;
  12697.  
  12698.     case FFEEXPR_contextDATA:
  12699.       if (expr == NULL)
  12700.     error = TRUE;
  12701.       else if (ffeexpr_stack_->is_rhs)
  12702.     error = (ffebld_op (expr) != FFEBLD_opCONTER);
  12703.       else if (ffebld_op (expr) == FFEBLD_opSYMTER)
  12704.     error = FALSE;
  12705.       else
  12706.     error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
  12707.       break;
  12708.  
  12709.     case FFEEXPR_contextINITVAL:
  12710.       error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
  12711.       break;
  12712.  
  12713.     case FFEEXPR_contextEQUIVALENCE:
  12714.       if (expr == NULL)
  12715.     error = TRUE;
  12716.       else if (ffebld_op (expr) == FFEBLD_opSYMTER)
  12717.     error = FALSE;
  12718.       else
  12719.     error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
  12720.       break;
  12721.  
  12722.     case FFEEXPR_contextFILEASSOC:
  12723.     case FFEEXPR_contextFILEINT:
  12724.       switch ((expr == NULL) ? FFEINFO_basictypeNONE
  12725.           : ffeinfo_basictype (info))
  12726.     {
  12727.     case FFEINFO_basictypeINTEGER:
  12728.       error = FALSE;
  12729.       break;
  12730.  
  12731.     default:
  12732.       error = TRUE;
  12733.       break;
  12734.     }
  12735.       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
  12736.     error = TRUE;
  12737.       break;
  12738.  
  12739.     case FFEEXPR_contextFILEDFINT:
  12740.       switch ((expr == NULL) ? FFEINFO_basictypeNONE
  12741.           : ffeinfo_basictype (info))
  12742.     {
  12743.     case FFEINFO_basictypeINTEGER:
  12744.       error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
  12745.       break;
  12746.  
  12747.     default:
  12748.       error = TRUE;
  12749.       break;
  12750.     }
  12751.       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
  12752.     error = TRUE;
  12753.       break;
  12754.  
  12755.     case FFEEXPR_contextFILELOG:
  12756.       switch ((expr == NULL) ? FFEINFO_basictypeNONE
  12757.           : ffeinfo_basictype (info))
  12758.     {
  12759.     case FFEINFO_basictypeLOGICAL:
  12760.       error = FALSE;
  12761.       break;
  12762.  
  12763.     default:
  12764.       error = TRUE;
  12765.       break;
  12766.     }
  12767.       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
  12768.     error = TRUE;
  12769.       break;
  12770.  
  12771.     case FFEEXPR_contextFILECHAR:
  12772.       switch ((expr == NULL) ? FFEINFO_basictypeNONE
  12773.           : ffeinfo_basictype (info))
  12774.     {
  12775.     case FFEINFO_basictypeCHARACTER:
  12776.       error = FALSE;
  12777.       break;
  12778.  
  12779.     default:
  12780.       error = TRUE;
  12781.       break;
  12782.     }
  12783.       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
  12784.     error = TRUE;
  12785.       break;
  12786.  
  12787.     case FFEEXPR_contextFILENUMCHAR:
  12788.       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
  12789.     break;
  12790.       switch (ffeinfo_basictype (info))
  12791.     {
  12792.     case FFEINFO_basictypeLOGICAL:
  12793.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
  12794.          FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
  12795.                   FFEEXPR_contextLET);
  12796.       /* Fall through. */
  12797.     case FFEINFO_basictypeREAL:
  12798.     case FFEINFO_basictypeCOMPLEX:
  12799.       if (ffe_is_pedantic ())
  12800.         {
  12801.           error = TRUE;
  12802.           break;
  12803.         }
  12804.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12805.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12806.                   FFEEXPR_contextLET);
  12807.       break;
  12808.  
  12809.     case FFEINFO_basictypeINTEGER:
  12810.     case FFEINFO_basictypeCHARACTER:
  12811.       error = FALSE;
  12812.       break;
  12813.  
  12814.     default:
  12815.       error = TRUE;
  12816.       break;
  12817.     }
  12818.       break;
  12819.  
  12820.     case FFEEXPR_contextFILEDFCHAR:
  12821.       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
  12822.     break;
  12823.       switch (ffeinfo_basictype (info))
  12824.     {
  12825.     case FFEINFO_basictypeCHARACTER:
  12826.       error
  12827.         = (ffeinfo_kindtype (info)
  12828.            != FFEINFO_kindtypeCHARACTERDEFAULT);
  12829.       break;
  12830.  
  12831.     default:
  12832.       error = TRUE;
  12833.       break;
  12834.     }
  12835.       if (!ffeexpr_stack_->is_rhs
  12836.       && (ffebld_op (expr) == FFEBLD_opSUBSTR))
  12837.     error = TRUE;
  12838.       break;
  12839.  
  12840.     case FFEEXPR_contextFILEUNIT:    /* See equiv code in _ambig_. */
  12841.       switch ((expr == NULL) ? FFEINFO_basictypeNONE
  12842.           : ffeinfo_basictype (info))
  12843.     {
  12844.     case FFEINFO_basictypeLOGICAL:
  12845.       if ((error = (ffeinfo_rank (info) != 0)))
  12846.         break;
  12847.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
  12848.          FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
  12849.                   FFEEXPR_contextLET);
  12850.       /* Fall through. */
  12851.     case FFEINFO_basictypeREAL:
  12852.     case FFEINFO_basictypeCOMPLEX:
  12853.       if ((error = (ffeinfo_rank (info) != 0)))
  12854.         break;
  12855.       if (ffe_is_pedantic ())
  12856.         {
  12857.           error = TRUE;
  12858.           break;
  12859.         }
  12860.       /* Fall through. */
  12861.     case FFEINFO_basictypeINTEGER:
  12862.     case FFEINFO_basictypeHOLLERITH:
  12863.     case FFEINFO_basictypeTYPELESS:
  12864.       if ((error = (ffeinfo_rank (info) != 0)))
  12865.         break;
  12866.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  12867.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  12868.                   FFEEXPR_contextLET);
  12869.       break;
  12870.  
  12871.     case FFEINFO_basictypeCHARACTER:
  12872.       switch (ffebld_op (expr))
  12873.         {            /* As if _lhs had been called instead of
  12874.                    _rhs. */
  12875.         case FFEBLD_opSYMTER:
  12876.           error
  12877.         = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
  12878.           break;
  12879.  
  12880.         case FFEBLD_opSUBSTR:
  12881.           error = (ffeinfo_where (ffebld_info (expr))
  12882.                == FFEINFO_whereCONSTANT_SUBOBJECT);
  12883.           break;
  12884.  
  12885.         case FFEBLD_opARRAYREF:
  12886.           error = FALSE;
  12887.           break;
  12888.  
  12889.         default:
  12890.           error = TRUE;
  12891.           break;
  12892.         }
  12893.       if (!error
  12894.        && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
  12895.            || ((ffeinfo_rank (info) != 0)
  12896.            && ((ffebld_op (expr) != FFEBLD_opSYMTER)
  12897.              || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
  12898.           || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
  12899.               == FFEBLD_opSTAR)))))    /* Bad if
  12900.                            non-default-kindtype
  12901.                            character expr, or if
  12902.                            array that is not a SYMTER
  12903.                            (can't happen yet, I
  12904.                            think), or has a NULL or
  12905.                            STAR (assumed) array
  12906.                            size. */
  12907.         error = TRUE;
  12908.       break;
  12909.  
  12910.     default:
  12911.       error = TRUE;
  12912.       break;
  12913.     }
  12914.       break;
  12915.  
  12916.     case FFEEXPR_contextFILEFORMAT:
  12917.       switch ((expr == NULL) ? FFEINFO_basictypeNONE
  12918.           : ffeinfo_basictype (info))
  12919.     {
  12920.     case FFEINFO_basictypeINTEGER:
  12921.       error = (expr == NULL)
  12922.         || ((ffeinfo_rank (info) != 0)
  12923.         && ffe_is_pedantic ())    /* F77 C5. */
  12924.         || (ffebld_op (expr) != FFEBLD_opSYMTER);
  12925.       break;
  12926.  
  12927.     case FFEINFO_basictypeLOGICAL:
  12928.     case FFEINFO_basictypeREAL:
  12929.     case FFEINFO_basictypeCOMPLEX:
  12930.       /* F77 C5 -- must be an array of hollerith.  */
  12931.       error
  12932.         = ffe_is_pedantic ()
  12933.           || (ffeinfo_rank (info) == 0);
  12934.       break;
  12935.  
  12936.     case FFEINFO_basictypeCHARACTER:
  12937.       if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
  12938.           || ((ffeinfo_rank (info) != 0)
  12939.           && ((ffebld_op (expr) != FFEBLD_opSYMTER)
  12940.               || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
  12941.               || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
  12942.               == FFEBLD_opSTAR))))    /* Bad if
  12943.                            non-default-kindtype
  12944.                            character expr, or if
  12945.                            array that is not a SYMTER
  12946.                            (can't happen yet, I
  12947.                            think), or has a NULL or
  12948.                            STAR (assumed) array
  12949.                            size. */
  12950.         error = TRUE;
  12951.       else
  12952.         error = FALSE;
  12953.       break;
  12954.  
  12955.     default:
  12956.       error = TRUE;
  12957.       break;
  12958.     }
  12959.       break;
  12960.  
  12961.     case FFEEXPR_contextLOC_:
  12962.       /* See also ffeintrin_check_loc_.  */
  12963.       if ((expr == NULL)
  12964.       || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
  12965.       || ((ffebld_op (expr) != FFEBLD_opSYMTER)
  12966.           && (ffebld_op (expr) != FFEBLD_opSUBSTR)
  12967.           && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
  12968.     error = TRUE;
  12969.       break;
  12970.  
  12971.     default:
  12972.       error = FALSE;
  12973.       break;
  12974.     }
  12975.  
  12976.   if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
  12977.     {
  12978.       ffebad_start (FFEBAD_EXPR_WRONG);
  12979.       ffebad_here (0, ffelex_token_where_line (ft),
  12980.            ffelex_token_where_column (ft));
  12981.       ffebad_finish ();
  12982.       expr = ffebld_new_any ();
  12983.       ffebld_set_info (expr, ffeinfo_new_any ());
  12984.     }
  12985.  
  12986.   callback = ffeexpr_stack_->callback;
  12987.   s = ffeexpr_stack_->previous;
  12988.   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
  12989.           sizeof (*ffeexpr_stack_));
  12990.   ffeexpr_stack_ = s;
  12991.   next = (ffelexHandler) (*callback) (ft, expr, t);
  12992.   ffelex_token_kill (ft);
  12993.   return (ffelexHandler) next;
  12994. }
  12995.  
  12996. /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
  12997.  
  12998.    ffebld expr;
  12999.    expr = ffeexpr_finished_ambig_(expr);
  13000.  
  13001.    Replicates a bit of ffeexpr_finished_'s task when in a context
  13002.    of UNIT or FORMAT.  */
  13003.  
  13004. static ffebld
  13005. ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
  13006. {
  13007.   ffeinfo info = ffebld_info (expr);
  13008.   bool error;
  13009.  
  13010.   switch (ffeexpr_stack_->context)
  13011.     {
  13012.     case FFEEXPR_contextFILENUMAMBIG:    /* Same as FILENUM in _finished_. */
  13013.       switch ((expr == NULL) ? FFEINFO_basictypeNONE
  13014.           : ffeinfo_basictype (info))
  13015.     {
  13016.     case FFEINFO_basictypeLOGICAL:
  13017.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
  13018.          FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
  13019.                   FFEEXPR_contextLET);
  13020.       /* Fall through. */
  13021.     case FFEINFO_basictypeREAL:
  13022.     case FFEINFO_basictypeCOMPLEX:
  13023.       if (ffe_is_pedantic ())
  13024.         {
  13025.           error = TRUE;
  13026.           break;
  13027.         }
  13028.       /* Fall through. */
  13029.     case FFEINFO_basictypeINTEGER:
  13030.     case FFEINFO_basictypeHOLLERITH:
  13031.     case FFEINFO_basictypeTYPELESS:
  13032.       error = FALSE;
  13033.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  13034.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  13035.                   FFEEXPR_contextLET);
  13036.       break;
  13037.  
  13038.     default:
  13039.       error = TRUE;
  13040.       break;
  13041.     }
  13042.       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
  13043.     error = TRUE;
  13044.       break;
  13045.  
  13046.     case FFEEXPR_contextFILEUNITAMBIG:    /* Same as FILEUNIT in _finished_. */
  13047.       if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
  13048.     {
  13049.       error = FALSE;
  13050.       break;
  13051.     }
  13052.       switch ((expr == NULL) ? FFEINFO_basictypeNONE
  13053.           : ffeinfo_basictype (info))
  13054.     {
  13055.     case FFEINFO_basictypeLOGICAL:
  13056.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
  13057.          FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
  13058.                   FFEEXPR_contextLET);
  13059.       /* Fall through. */
  13060.     case FFEINFO_basictypeREAL:
  13061.     case FFEINFO_basictypeCOMPLEX:
  13062.       if (ffe_is_pedantic ())
  13063.         {
  13064.           error = TRUE;
  13065.           break;
  13066.         }
  13067.       /* Fall through. */
  13068.     case FFEINFO_basictypeINTEGER:
  13069.     case FFEINFO_basictypeHOLLERITH:
  13070.     case FFEINFO_basictypeTYPELESS:
  13071.       error = (ffeinfo_rank (info) != 0);
  13072.       expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
  13073.          FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
  13074.                   FFEEXPR_contextLET);
  13075.       break;
  13076.  
  13077.     case FFEINFO_basictypeCHARACTER:
  13078.       switch (ffebld_op (expr))
  13079.         {            /* As if _lhs had been called instead of
  13080.                    _rhs. */
  13081.         case FFEBLD_opSYMTER:
  13082.           error
  13083.         = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
  13084.           break;
  13085.  
  13086.         case FFEBLD_opSUBSTR:
  13087.           error = (ffeinfo_where (ffebld_info (expr))
  13088.                == FFEINFO_whereCONSTANT_SUBOBJECT);
  13089.           break;
  13090.  
  13091.         case FFEBLD_opARRAYREF:
  13092.           error = FALSE;
  13093.           break;
  13094.  
  13095.         default:
  13096.           error = TRUE;
  13097.           break;
  13098.         }
  13099.       break;
  13100.  
  13101.     default:
  13102.       error = TRUE;
  13103.       break;
  13104.     }
  13105.       break;
  13106.  
  13107.     default:
  13108.       assert ("bad context" == NULL);
  13109.       error = TRUE;
  13110.       break;
  13111.     }
  13112.  
  13113.   if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
  13114.     {
  13115.       ffebad_start (FFEBAD_EXPR_WRONG);
  13116.       ffebad_here (0, ffelex_token_where_line (ft),
  13117.            ffelex_token_where_column (ft));
  13118.       ffebad_finish ();
  13119.       expr = ffebld_new_any ();
  13120.       ffebld_set_info (expr, ffeinfo_new_any ());
  13121.     }
  13122.  
  13123.   return expr;
  13124. }
  13125.  
  13126. /* ffeexpr_token_lhs_ -- Initial state for lhs expression
  13127.  
  13128.    Return a pointer to this function to the lexer (ffelex), which will
  13129.    invoke it for the next token.
  13130.  
  13131.    Basically a smaller version of _rhs_; keep them both in sync, of course.  */
  13132.  
  13133. static ffelexHandler
  13134. ffeexpr_token_lhs_ (ffelexToken t)
  13135. {
  13136.  
  13137.   /* When changing the list of valid initial lhs tokens, check whether to
  13138.      update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
  13139.      READ (expr) <token> case -- it assumes it knows which tokens <token> can
  13140.      be to indicate an lhs (or implied DO), which right now is the set
  13141.      {NAME,OPEN_PAREN}.
  13142.  
  13143.      This comment also appears in ffeexpr_token_first_lhs_. */
  13144.  
  13145.   switch (ffelex_token_type (t))
  13146.     {
  13147.     case FFELEX_typeNAME:
  13148.     case FFELEX_typeNAMES:
  13149.       ffeexpr_tokens_[0] = ffelex_token_use (t);
  13150.       return (ffelexHandler) ffeexpr_token_name_lhs_;
  13151.  
  13152.     default:
  13153.       return (ffelexHandler) ffeexpr_finished_ (t);
  13154.     }
  13155. }
  13156.  
  13157. /* ffeexpr_token_rhs_ -- Initial state for rhs expression
  13158.  
  13159.    Return a pointer to this function to the lexer (ffelex), which will
  13160.    invoke it for the next token.
  13161.  
  13162.    The initial state and the post-binary-operator state are the same and
  13163.    both handled here, with the expression stack used to distinguish
  13164.    between them.  Binary operators are invalid here; unary operators,
  13165.    constants, subexpressions, and name references are valid.  */
  13166.  
  13167. static ffelexHandler
  13168. ffeexpr_token_rhs_ (ffelexToken t)
  13169. {
  13170.   ffeexprExpr_ e;
  13171.  
  13172.   switch (ffelex_token_type (t))
  13173.     {
  13174.     case FFELEX_typeQUOTE:
  13175.       if (ffe_is_vxt_not_90 ())
  13176.     {
  13177.       ffeexpr_tokens_[0] = ffelex_token_use (t);
  13178.       return (ffelexHandler) ffeexpr_token_quote_;
  13179.     }
  13180.       ffeexpr_tokens_[0] = ffelex_token_use (t);
  13181.       ffelex_set_expecting_hollerith (-1, '\"',
  13182.                       ffelex_token_where_line (t),
  13183.                       ffelex_token_where_column (t));
  13184.       /* Don't have to unset this one. */
  13185.       return (ffelexHandler) ffeexpr_token_apostrophe_;
  13186.  
  13187.     case FFELEX_typeAPOSTROPHE:
  13188.       ffeexpr_tokens_[0] = ffelex_token_use (t);
  13189.       ffelex_set_expecting_hollerith (-1, '\'',
  13190.                       ffelex_token_where_line (t),
  13191.                       ffelex_token_where_column (t));
  13192.       /* Don't have to unset this one. */
  13193.       return (ffelexHandler) ffeexpr_token_apostrophe_;
  13194.  
  13195.     case FFELEX_typePERCENT:
  13196.       ffeexpr_tokens_[0] = ffelex_token_use (t);
  13197.       return (ffelexHandler) ffeexpr_token_percent_;
  13198.  
  13199.     case FFELEX_typeOPEN_PAREN:
  13200.       ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
  13201.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  13202.                       FFEEXPR_contextPAREN_,
  13203.                       ffeexpr_cb_close_paren_c_);
  13204.  
  13205.     case FFELEX_typePLUS:
  13206.       e = ffeexpr_expr_new_ ();
  13207.       e->type = FFEEXPR_exprtypeUNARY_;
  13208.       e->token = ffelex_token_use (t);
  13209.       e->u.operator.op = FFEEXPR_operatorADD_;
  13210.       e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
  13211.       e->u.operator.as = FFEEXPR_operatorassociativityADD_;
  13212.       ffeexpr_exprstack_push_unary_ (e);
  13213.       return (ffelexHandler) ffeexpr_token_rhs_;
  13214.  
  13215.     case FFELEX_typeMINUS:
  13216.       e = ffeexpr_expr_new_ ();
  13217.       e->type = FFEEXPR_exprtypeUNARY_;
  13218.       e->token = ffelex_token_use (t);
  13219.       e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
  13220.       e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
  13221.       e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
  13222.       ffeexpr_exprstack_push_unary_ (e);
  13223.       return (ffelexHandler) ffeexpr_token_rhs_;
  13224.  
  13225.     case FFELEX_typePERIOD:
  13226.       ffeexpr_tokens_[0] = ffelex_token_use (t);
  13227.       return (ffelexHandler) ffeexpr_token_period_;
  13228.  
  13229.     case FFELEX_typeNUMBER:
  13230.       ffeexpr_tokens_[0] = ffelex_token_use (t);
  13231.       ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
  13232.       if (ffeexpr_hollerith_count_ > 0)
  13233.     ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
  13234.                     '\0',
  13235.                     ffelex_token_where_line (t),
  13236.                     ffelex_token_where_column (t));
  13237.       return (ffelexHandler) ffeexpr_token_number_;
  13238.  
  13239.     case FFELEX_typeNAME:
  13240.     case FFELEX_typeNAMES:
  13241.       ffeexpr_tokens_[0] = ffelex_token_use (t);
  13242.       switch (ffeexpr_stack_->context)
  13243.     {
  13244.     case FFEEXPR_contextACTUALARG_:
  13245.     case FFEEXPR_contextINDEXORACTUALARG_:
  13246.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  13247.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  13248.       return (ffelexHandler) ffeexpr_token_name_arg_;
  13249.  
  13250.     default:
  13251.       return (ffelexHandler) ffeexpr_token_name_rhs_;
  13252.     }
  13253.  
  13254.     case FFELEX_typeASTERISK:
  13255.     case FFELEX_typeSLASH:
  13256.     case FFELEX_typePOWER:
  13257.     case FFELEX_typeCONCAT:
  13258.     case FFELEX_typeREL_EQ:
  13259.     case FFELEX_typeREL_NE:
  13260.     case FFELEX_typeREL_LE:
  13261.     case FFELEX_typeREL_GE:
  13262.       if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
  13263.     {
  13264.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  13265.       ffebad_finish ();
  13266.     }
  13267.       return (ffelexHandler) ffeexpr_token_rhs_;
  13268.  
  13269. #if 0
  13270.     case FFELEX_typeEQUALS:
  13271.     case FFELEX_typePOINTS:
  13272.     case FFELEX_typeCLOSE_ANGLE:
  13273.     case FFELEX_typeCLOSE_PAREN:
  13274.     case FFELEX_typeCOMMA:
  13275.     case FFELEX_typeCOLON:
  13276.     case FFELEX_typeEOS:
  13277.     case FFELEX_typeSEMICOLON:
  13278. #endif
  13279.     default:
  13280.       return (ffelexHandler) ffeexpr_finished_ (t);
  13281.     }
  13282. }
  13283.  
  13284. /* ffeexpr_token_period_ -- Rhs PERIOD
  13285.  
  13286.    Return a pointer to this function to the lexer (ffelex), which will
  13287.    invoke it for the next token.
  13288.  
  13289.    Handle a period detected at rhs (expecting unary op or operand) state.
  13290.    Must begin a floating-point value (as in .12) or a dot-dot name, of
  13291.    which only .NOT., .TRUE., and .FALSE. are truly valid.  Other sort-of-
  13292.    valid names represent binary operators, which are invalid here because
  13293.    there isn't an operand at the top of the stack.  */
  13294.  
  13295. static ffelexHandler
  13296. ffeexpr_token_period_ (ffelexToken t)
  13297. {
  13298.   switch (ffelex_token_type (t))
  13299.     {
  13300.     case FFELEX_typeNAME:
  13301.     case FFELEX_typeNAMES:
  13302.       ffeexpr_current_dotdot_ = ffeexpr_dotdot_ (t);
  13303.       switch (ffeexpr_current_dotdot_)
  13304.     {
  13305.     case FFEEXPR_dotdotNONE_:
  13306.       if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
  13307.         {
  13308.           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
  13309.                ffelex_token_where_column (ffeexpr_tokens_[0]));
  13310.           ffebad_finish ();
  13311.         }
  13312.       ffelex_token_kill (ffeexpr_tokens_[0]);
  13313.       return (ffelexHandler) ffeexpr_token_rhs_ (t);
  13314.  
  13315.     case FFEEXPR_dotdotTRUE_:
  13316.     case FFEEXPR_dotdotFALSE_:
  13317.     case FFEEXPR_dotdotNOT_:
  13318.       ffeexpr_tokens_[1] = ffelex_token_use (t);
  13319.       return (ffelexHandler) ffeexpr_token_end_period_;
  13320.  
  13321.     default:
  13322.       if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
  13323.         {
  13324.           ffebad_here (0, ffelex_token_where_line (t),
  13325.                ffelex_token_where_column (t));
  13326.           ffebad_finish ();
  13327.         }
  13328.       ffelex_token_kill (ffeexpr_tokens_[0]);
  13329.       return (ffelexHandler) ffeexpr_token_swallow_period_;
  13330.     }
  13331.       break;            /* Nothing really reaches here. */
  13332.  
  13333.     case FFELEX_typeNUMBER:
  13334.       ffeexpr_tokens_[1] = ffelex_token_use (t);
  13335.       return (ffelexHandler) ffeexpr_token_real_;
  13336.  
  13337.     default:
  13338.       if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
  13339.     {
  13340.       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
  13341.                ffelex_token_where_column (ffeexpr_tokens_[0]));
  13342.       ffebad_finish ();
  13343.     }
  13344.       ffelex_token_kill (ffeexpr_tokens_[0]);
  13345.       return (ffelexHandler) ffeexpr_token_rhs_ (t);
  13346.     }
  13347. }
  13348.  
  13349. /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
  13350.  
  13351.    Return a pointer to this function to the lexer (ffelex), which will
  13352.    invoke it for the next token.
  13353.  
  13354.    Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
  13355.    or operator) state.    If period isn't found, issue a diagnostic but
  13356.    pretend we saw one.    ffeexpr_current_dotdot_ must already contained the
  13357.    dotdot representation of the name in between the two PERIOD tokens.    */
  13358.  
  13359. static ffelexHandler
  13360. ffeexpr_token_end_period_ (ffelexToken t)
  13361. {
  13362.   ffeexprExpr_ e;
  13363.  
  13364.   if (ffelex_token_type (t) != FFELEX_typePERIOD)
  13365.     {
  13366.       if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
  13367.     {
  13368.       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
  13369.                ffelex_token_where_column (ffeexpr_tokens_[0]));
  13370.       ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
  13371.       ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
  13372.       ffebad_finish ();
  13373.     }
  13374.     }
  13375.  
  13376.   ffelex_token_kill (ffeexpr_tokens_[1]);    /* Kill "NOT"/"TRUE"/"FALSE"
  13377.                            token. */
  13378.  
  13379.   e = ffeexpr_expr_new_ ();
  13380.   e->token = ffeexpr_tokens_[0];
  13381.  
  13382.   switch (ffeexpr_current_dotdot_)
  13383.     {
  13384.     case FFEEXPR_dotdotNOT_:
  13385.       e->type = FFEEXPR_exprtypeUNARY_;
  13386.       e->u.operator.op = FFEEXPR_operatorNOT_;
  13387.       e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
  13388.       e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
  13389.       ffeexpr_exprstack_push_unary_ (e);
  13390.       if (ffelex_token_type (t) != FFELEX_typePERIOD)
  13391.     return (ffelexHandler) ffeexpr_token_rhs_ (t);
  13392.       return (ffelexHandler) ffeexpr_token_rhs_;
  13393.  
  13394.     case FFEEXPR_dotdotTRUE_:
  13395.       e->type = FFEEXPR_exprtypeOPERAND_;
  13396.       e->u.operand
  13397.     = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
  13398.       ffebld_set_info (e->u.operand,
  13399.       ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
  13400.            0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
  13401.       ffeexpr_exprstack_push_operand_ (e);
  13402.       if (ffelex_token_type (t) != FFELEX_typePERIOD)
  13403.     return (ffelexHandler) ffeexpr_token_binary_ (t);
  13404.       return (ffelexHandler) ffeexpr_token_binary_;
  13405.  
  13406.     case FFEEXPR_dotdotFALSE_:
  13407.       e->type = FFEEXPR_exprtypeOPERAND_;
  13408.       e->u.operand
  13409.     = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
  13410.       ffebld_set_info (e->u.operand,
  13411.       ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
  13412.            0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
  13413.       ffeexpr_exprstack_push_operand_ (e);
  13414.       if (ffelex_token_type (t) != FFELEX_typePERIOD)
  13415.     return (ffelexHandler) ffeexpr_token_binary_ (t);
  13416.       return (ffelexHandler) ffeexpr_token_binary_;
  13417.  
  13418.     default:
  13419.       assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
  13420.       exit (0);
  13421.       return NULL;
  13422.     }
  13423. }
  13424.  
  13425. /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
  13426.  
  13427.    Return a pointer to this function to the lexer (ffelex), which will
  13428.    invoke it for the next token.
  13429.  
  13430.    A diagnostic has already been issued; just swallow a period if there is
  13431.    one, then continue with ffeexpr_token_rhs_.    */
  13432.  
  13433. static ffelexHandler
  13434. ffeexpr_token_swallow_period_ (ffelexToken t)
  13435. {
  13436.   if (ffelex_token_type (t) != FFELEX_typePERIOD)
  13437.     return (ffelexHandler) ffeexpr_token_rhs_ (t);
  13438.  
  13439.   return (ffelexHandler) ffeexpr_token_rhs_;
  13440. }
  13441.  
  13442. /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
  13443.  
  13444.    Return a pointer to this function to the lexer (ffelex), which will
  13445.    invoke it for the next token.
  13446.  
  13447.    After a period and a string of digits, check next token for possible
  13448.    exponent designation (D, E, or Q as first/only character) and continue
  13449.    real-number handling accordingly.  Else form basic real constant, push
  13450.    onto expression stack, and enter binary state using current token (which,
  13451.    if it is a name not beginning with D, E, or Q, will certainly result
  13452.    in an error, but that's not for this routine to deal with).    */
  13453.  
  13454. static ffelexHandler
  13455. ffeexpr_token_real_ (ffelexToken t)
  13456. {
  13457.   char d;
  13458.   char *p;
  13459.  
  13460.   if (((ffelex_token_type (t) != FFELEX_typeNAME)
  13461.        && (ffelex_token_type (t) != FFELEX_typeNAMES))
  13462.       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
  13463.                      'D', 'd')
  13464.          || ffesrc_char_match_init (d, 'E', 'e')
  13465.          || ffesrc_char_match_init (d, 'Q', 'q')))
  13466.        && ffeexpr_isdigits_ (++p)))
  13467.     {
  13468. #if 0
  13469.       /* This code has been removed because it seems inconsistent to
  13470.      produce a diagnostic in this case, but not all of the other
  13471.      ones that look for an exponent and cannot recognize one.  */
  13472.       if (((ffelex_token_type (t) == FFELEX_typeNAME)
  13473.        || (ffelex_token_type (t) == FFELEX_typeNAMES))
  13474.       && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
  13475.     {
  13476.       char bad[2];
  13477.  
  13478.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  13479.       ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
  13480.                ffelex_token_where_column (ffeexpr_tokens_[0]));
  13481.       bad[0] = *(p - 1);
  13482.       bad[1] = '\0';
  13483.       ffebad_string (bad);
  13484.       ffebad_finish ();
  13485.     }
  13486. #endif
  13487.       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
  13488.                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
  13489.                  NULL, NULL, NULL);
  13490.  
  13491.       ffelex_token_kill (ffeexpr_tokens_[0]);
  13492.       ffelex_token_kill (ffeexpr_tokens_[1]);
  13493.       return (ffelexHandler) ffeexpr_token_binary_ (t);
  13494.     }
  13495.  
  13496.   /* Just exponent character by itself?     In which case, PLUS or MINUS must
  13497.      surely be next, followed by a NUMBER token. */
  13498.  
  13499.   if (*p == '\0')
  13500.     {
  13501.       ffeexpr_tokens_[2] = ffelex_token_use (t);
  13502.       return (ffelexHandler) ffeexpr_token_real_exponent_;
  13503.     }
  13504.  
  13505.   ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
  13506.                  t, NULL, NULL);
  13507.  
  13508.   ffelex_token_kill (ffeexpr_tokens_[0]);
  13509.   ffelex_token_kill (ffeexpr_tokens_[1]);
  13510.   return (ffelexHandler) ffeexpr_token_binary_;
  13511. }
  13512.  
  13513. /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
  13514.  
  13515.    Return a pointer to this function to the lexer (ffelex), which will
  13516.    invoke it for the next token.
  13517.  
  13518.    Ensures this token is PLUS or MINUS, preserves it, goes to final state
  13519.    for real number (exponent digits).  Else issues diagnostic, assumes a
  13520.    zero exponent field for number, passes token on to binary state as if
  13521.    previous token had been "E0" instead of "E", for example.  */
  13522.  
  13523. static ffelexHandler
  13524. ffeexpr_token_real_exponent_ (ffelexToken t)
  13525. {
  13526.   if ((ffelex_token_type (t) != FFELEX_typePLUS)
  13527.       && (ffelex_token_type (t) != FFELEX_typeMINUS))
  13528.     {
  13529.       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
  13530.     {
  13531.       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
  13532.                ffelex_token_where_column (ffeexpr_tokens_[2]));
  13533.       ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
  13534.       ffebad_finish ();
  13535.     }
  13536.  
  13537.       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
  13538.                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
  13539.                  NULL, NULL, NULL);
  13540.  
  13541.       ffelex_token_kill (ffeexpr_tokens_[0]);
  13542.       ffelex_token_kill (ffeexpr_tokens_[1]);
  13543.       ffelex_token_kill (ffeexpr_tokens_[2]);
  13544.       return (ffelexHandler) ffeexpr_token_binary_ (t);
  13545.     }
  13546.  
  13547.   ffeexpr_tokens_[3] = ffelex_token_use (t);
  13548.   return (ffelexHandler) ffeexpr_token_real_exp_sign_;
  13549. }
  13550.  
  13551. /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
  13552.  
  13553.    Return a pointer to this function to the lexer (ffelex), which will
  13554.    invoke it for the next token.
  13555.  
  13556.    Make sure token is a NUMBER, make a real constant out of all we have and
  13557.    push it onto the expression stack.  Else issue diagnostic and pretend
  13558.    exponent field was a zero.  */
  13559.  
  13560. static ffelexHandler
  13561. ffeexpr_token_real_exp_sign_ (ffelexToken t)
  13562. {
  13563.   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
  13564.     {
  13565.       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
  13566.     {
  13567.       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
  13568.                ffelex_token_where_column (ffeexpr_tokens_[2]));
  13569.       ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
  13570.       ffebad_finish ();
  13571.     }
  13572.  
  13573.       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
  13574.                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
  13575.                  NULL, NULL, NULL);
  13576.  
  13577.       ffelex_token_kill (ffeexpr_tokens_[0]);
  13578.       ffelex_token_kill (ffeexpr_tokens_[1]);
  13579.       ffelex_token_kill (ffeexpr_tokens_[2]);
  13580.       ffelex_token_kill (ffeexpr_tokens_[3]);
  13581.       return (ffelexHandler) ffeexpr_token_binary_ (t);
  13582.     }
  13583.  
  13584.   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
  13585.          ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
  13586.                  ffeexpr_tokens_[3], t);
  13587.  
  13588.   ffelex_token_kill (ffeexpr_tokens_[0]);
  13589.   ffelex_token_kill (ffeexpr_tokens_[1]);
  13590.   ffelex_token_kill (ffeexpr_tokens_[2]);
  13591.   ffelex_token_kill (ffeexpr_tokens_[3]);
  13592.   return (ffelexHandler) ffeexpr_token_binary_;
  13593. }
  13594.  
  13595. /* ffeexpr_token_number_ -- Rhs NUMBER
  13596.  
  13597.    Return a pointer to this function to the lexer (ffelex), which will
  13598.    invoke it for the next token.
  13599.  
  13600.    If the token is a period, we may have a floating-point number, or an
  13601.    integer followed by a dotdot binary operator.  If the token is a name
  13602.    beginning with D, E, or Q, we definitely have a floating-point number.
  13603.    If the token is a hollerith constant, that's what we've got, so push
  13604.    it onto the expression stack and continue with the binary state.
  13605.  
  13606.    Otherwise, we have an integer followed by something the binary state
  13607.    should be able to swallow.  */
  13608.  
  13609. static ffelexHandler
  13610. ffeexpr_token_number_ (ffelexToken t)
  13611. {
  13612.   ffeexprExpr_ e;
  13613.   ffeinfo ni;
  13614.   char d;
  13615.   char *p;
  13616.  
  13617.   if (ffeexpr_hollerith_count_ > 0)
  13618.     ffelex_set_expecting_hollerith (0, '\0',
  13619.                     ffewhere_line_unknown (),
  13620.                     ffewhere_column_unknown ());
  13621.  
  13622.   /* See if we've got a floating-point number here. */
  13623.  
  13624.   switch (ffelex_token_type (t))
  13625.     {
  13626.     case FFELEX_typeNAME:
  13627.     case FFELEX_typeNAMES:
  13628.       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
  13629.                    'D', 'd')
  13630.        || ffesrc_char_match_init (d, 'E', 'e')
  13631.        || ffesrc_char_match_init (d, 'Q', 'q'))
  13632.       && ffeexpr_isdigits_ (++p))
  13633.     {
  13634.  
  13635.       /* Just exponent character by itself?     In which case, PLUS or MINUS
  13636.          must surely be next, followed by a NUMBER token. */
  13637.  
  13638.       if (*p == '\0')
  13639.         {
  13640.           ffeexpr_tokens_[1] = ffelex_token_use (t);
  13641.           return (ffelexHandler) ffeexpr_token_number_exponent_;
  13642.         }
  13643.       ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
  13644.                      NULL, NULL);
  13645.  
  13646.       ffelex_token_kill (ffeexpr_tokens_[0]);
  13647.       return (ffelexHandler) ffeexpr_token_binary_;
  13648.     }
  13649.       break;
  13650.  
  13651.     case FFELEX_typePERIOD:
  13652.       ffeexpr_tokens_[1] = ffelex_token_use (t);
  13653.       return (ffelexHandler) ffeexpr_token_number_period_;
  13654.  
  13655.     case FFELEX_typeHOLLERITH:
  13656.       e = ffeexpr_expr_new_ ();
  13657.       e->type = FFEEXPR_exprtypeOPERAND_;
  13658.       e->token = ffeexpr_tokens_[0];
  13659.       e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
  13660.       ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
  13661.             0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
  13662.             ffelex_token_length (t));
  13663.       ffebld_set_info (e->u.operand, ni);
  13664.       ffeexpr_exprstack_push_operand_ (e);
  13665.       return (ffelexHandler) ffeexpr_token_binary_;
  13666.  
  13667.     default:
  13668.       break;
  13669.     }
  13670.  
  13671.   /* Nothing specific we were looking for, so make an integer and pass the
  13672.      current token to the binary state. */
  13673.  
  13674.   e = ffeexpr_expr_new_ ();
  13675.   e->type = FFEEXPR_exprtypeOPERAND_;
  13676.   e->token = ffeexpr_tokens_[0];
  13677.   e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
  13678.                     (ffeexpr_tokens_[0]));
  13679.   ffebld_set_info (e->u.operand,
  13680.            ffeinfo_new (FFEINFO_basictypeINTEGER,
  13681.                 FFEINFO_kindtypeINTEGERDEFAULT, 0,
  13682.                 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
  13683.                 FFETARGET_charactersizeNONE));
  13684.   ffeexpr_exprstack_push_operand_ (e);
  13685.   return (ffelexHandler) ffeexpr_token_binary_ (t);
  13686. }
  13687.  
  13688. /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
  13689.  
  13690.    Return a pointer to this function to the lexer (ffelex), which will
  13691.    invoke it for the next token.
  13692.  
  13693.    Ensures this token is PLUS or MINUS, preserves it, goes to final state
  13694.    for real number (exponent digits).  Else treats number as integer, passes
  13695.    name to binary, passes current token to subsequent handler.  */
  13696.  
  13697. static ffelexHandler
  13698. ffeexpr_token_number_exponent_ (ffelexToken t)
  13699. {
  13700.   if ((ffelex_token_type (t) != FFELEX_typePLUS)
  13701.       && (ffelex_token_type (t) != FFELEX_typeMINUS))
  13702.     {
  13703.       ffeexprExpr_ e;
  13704.       ffelexHandler nexthandler;
  13705.  
  13706.       e = ffeexpr_expr_new_ ();
  13707.       e->type = FFEEXPR_exprtypeOPERAND_;
  13708.       e->token = ffeexpr_tokens_[0];
  13709.       e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
  13710.                     (ffeexpr_tokens_[0]));
  13711.       ffebld_set_info (e->u.operand,
  13712.       ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
  13713.            0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
  13714.       ffeexpr_exprstack_push_operand_ (e);
  13715.       nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
  13716.       ffelex_token_kill (ffeexpr_tokens_[1]);
  13717.       return (ffelexHandler) (*nexthandler) (t);
  13718.     }
  13719.  
  13720.   ffeexpr_tokens_[2] = ffelex_token_use (t);
  13721.   return (ffelexHandler) ffeexpr_token_number_exp_sign_;
  13722. }
  13723.  
  13724. /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
  13725.  
  13726.    Return a pointer to this function to the lexer (ffelex), which will
  13727.    invoke it for the next token.
  13728.  
  13729.    Make sure token is a NUMBER, make a real constant out of all we have and
  13730.    push it onto the expression stack.  Else issue diagnostic and pretend
  13731.    exponent field was a zero.  */
  13732.  
  13733. static ffelexHandler
  13734. ffeexpr_token_number_exp_sign_ (ffelexToken t)
  13735. {
  13736.   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
  13737.     {
  13738.       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
  13739.     {
  13740.       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
  13741.                ffelex_token_where_column (ffeexpr_tokens_[1]));
  13742.       ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
  13743.       ffebad_finish ();
  13744.     }
  13745.  
  13746.       ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
  13747.                  ffeexpr_tokens_[0], NULL, NULL,
  13748.                  ffeexpr_tokens_[1], ffeexpr_tokens_[2],
  13749.                  NULL);
  13750.  
  13751.       ffelex_token_kill (ffeexpr_tokens_[0]);
  13752.       ffelex_token_kill (ffeexpr_tokens_[1]);
  13753.       ffelex_token_kill (ffeexpr_tokens_[2]);
  13754.       return (ffelexHandler) ffeexpr_token_binary_ (t);
  13755.     }
  13756.  
  13757.   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
  13758.                  ffeexpr_tokens_[0], NULL, NULL,
  13759.                  ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
  13760.  
  13761.   ffelex_token_kill (ffeexpr_tokens_[0]);
  13762.   ffelex_token_kill (ffeexpr_tokens_[1]);
  13763.   ffelex_token_kill (ffeexpr_tokens_[2]);
  13764.   return (ffelexHandler) ffeexpr_token_binary_;
  13765. }
  13766.  
  13767. /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
  13768.  
  13769.    Return a pointer to this function to the lexer (ffelex), which will
  13770.    invoke it for the next token.
  13771.  
  13772.    Handle a period detected following a number at rhs state.  Must begin a
  13773.    floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name.  */
  13774.  
  13775. static ffelexHandler
  13776. ffeexpr_token_number_period_ (ffelexToken t)
  13777. {
  13778.   ffeexprExpr_ e;
  13779.   ffelexHandler nexthandler;
  13780.   char *p;
  13781.   char d;
  13782.  
  13783.   switch (ffelex_token_type (t))
  13784.     {
  13785.     case FFELEX_typeNAME:
  13786.     case FFELEX_typeNAMES:
  13787.       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
  13788.                    'D', 'd')
  13789.        || ffesrc_char_match_init (d, 'E', 'e')
  13790.        || ffesrc_char_match_init (d, 'Q', 'q'))
  13791.       && ffeexpr_isdigits_ (++p))
  13792.     {
  13793.  
  13794.       /* Just exponent character by itself?     In which case, PLUS or MINUS
  13795.          must surely be next, followed by a NUMBER token. */
  13796.  
  13797.       if (*p == '\0')
  13798.         {
  13799.           ffeexpr_tokens_[2] = ffelex_token_use (t);
  13800.           return (ffelexHandler) ffeexpr_token_number_per_exp_;
  13801.         }
  13802.       ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
  13803.                      ffeexpr_tokens_[1], NULL, t, NULL,
  13804.                      NULL);
  13805.  
  13806.       ffelex_token_kill (ffeexpr_tokens_[0]);
  13807.       ffelex_token_kill (ffeexpr_tokens_[1]);
  13808.       return (ffelexHandler) ffeexpr_token_binary_;
  13809.     }
  13810.       /* A name not representing an exponent, so assume it will be something
  13811.          like EQ, make an integer from the number, pass the period to binary
  13812.          state and the current token to the resulting state. */
  13813.  
  13814.       e = ffeexpr_expr_new_ ();
  13815.       e->type = FFEEXPR_exprtypeOPERAND_;
  13816.       e->token = ffeexpr_tokens_[0];
  13817.       e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
  13818.                     (ffeexpr_tokens_[0]));
  13819.       ffebld_set_info (e->u.operand,
  13820.                ffeinfo_new (FFEINFO_basictypeINTEGER,
  13821.                     FFEINFO_kindtypeINTEGERDEFAULT, 0,
  13822.                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
  13823.                     FFETARGET_charactersizeNONE));
  13824.       ffeexpr_exprstack_push_operand_ (e);
  13825.       nexthandler = (ffelexHandler) ffeexpr_token_binary_
  13826.     (ffeexpr_tokens_[1]);
  13827.       ffelex_token_kill (ffeexpr_tokens_[1]);
  13828.       return (ffelexHandler) (*nexthandler) (t);
  13829.  
  13830.     case FFELEX_typeNUMBER:
  13831.       ffeexpr_tokens_[2] = ffelex_token_use (t);
  13832.       return (ffelexHandler) ffeexpr_token_number_real_;
  13833.  
  13834.     default:
  13835.       break;
  13836.     }
  13837.  
  13838.   /* Nothing specific we were looking for, so make a real number and pass the
  13839.      period and then the current token to the binary state. */
  13840.  
  13841.   ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
  13842.                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
  13843.                  NULL, NULL, NULL, NULL);
  13844.  
  13845.   ffelex_token_kill (ffeexpr_tokens_[0]);
  13846.   ffelex_token_kill (ffeexpr_tokens_[1]);
  13847.   return (ffelexHandler) ffeexpr_token_binary_ (t);
  13848. }
  13849.  
  13850. /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
  13851.  
  13852.    Return a pointer to this function to the lexer (ffelex), which will
  13853.    invoke it for the next token.
  13854.  
  13855.    Ensures this token is PLUS or MINUS, preserves it, goes to final state
  13856.    for real number (exponent digits).  Else treats number as real, passes
  13857.    name to binary, passes current token to subsequent handler.    */
  13858.  
  13859. static ffelexHandler
  13860. ffeexpr_token_number_per_exp_ (ffelexToken t)
  13861. {
  13862.   if ((ffelex_token_type (t) != FFELEX_typePLUS)
  13863.       && (ffelex_token_type (t) != FFELEX_typeMINUS))
  13864.     {
  13865.       ffelexHandler nexthandler;
  13866.  
  13867.       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
  13868.                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
  13869.                  NULL, NULL, NULL, NULL);
  13870.  
  13871.       ffelex_token_kill (ffeexpr_tokens_[0]);
  13872.       ffelex_token_kill (ffeexpr_tokens_[1]);
  13873.       nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
  13874.       ffelex_token_kill (ffeexpr_tokens_[2]);
  13875.       return (ffelexHandler) (*nexthandler) (t);
  13876.     }
  13877.  
  13878.   ffeexpr_tokens_[3] = ffelex_token_use (t);
  13879.   return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
  13880. }
  13881.  
  13882. /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
  13883.  
  13884.    Return a pointer to this function to the lexer (ffelex), which will
  13885.    invoke it for the next token.
  13886.  
  13887.    After a number, period, and number, check next token for possible
  13888.    exponent designation (D, E, or Q as first/only character) and continue
  13889.    real-number handling accordingly.  Else form basic real constant, push
  13890.    onto expression stack, and enter binary state using current token (which,
  13891.    if it is a name not beginning with D, E, or Q, will certainly result
  13892.    in an error, but that's not for this routine to deal with).    */
  13893.  
  13894. static ffelexHandler
  13895. ffeexpr_token_number_real_ (ffelexToken t)
  13896. {
  13897.   char d;
  13898.   char *p;
  13899.  
  13900.   if (((ffelex_token_type (t) != FFELEX_typeNAME)
  13901.        && (ffelex_token_type (t) != FFELEX_typeNAMES))
  13902.       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
  13903.                      'D', 'd')
  13904.          || ffesrc_char_match_init (d, 'E', 'e')
  13905.          || ffesrc_char_match_init (d, 'Q', 'q')))
  13906.        && ffeexpr_isdigits_ (++p)))
  13907.     {
  13908. #if 0
  13909.       /* This code has been removed because it seems inconsistent to
  13910.      produce a diagnostic in this case, but not all of the other
  13911.      ones that look for an exponent and cannot recognize one.  */
  13912.       if (((ffelex_token_type (t) == FFELEX_typeNAME)
  13913.        || (ffelex_token_type (t) == FFELEX_typeNAMES))
  13914.       && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
  13915.     {
  13916.       char bad[2];
  13917.  
  13918.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  13919.       ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
  13920.                ffelex_token_where_column (ffeexpr_tokens_[0]));
  13921.       bad[0] = *(p - 1);
  13922.       bad[1] = '\0';
  13923.       ffebad_string (bad);
  13924.       ffebad_finish ();
  13925.     }
  13926. #endif
  13927.       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
  13928.                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
  13929.                  ffeexpr_tokens_[2], NULL, NULL, NULL);
  13930.  
  13931.       ffelex_token_kill (ffeexpr_tokens_[0]);
  13932.       ffelex_token_kill (ffeexpr_tokens_[1]);
  13933.       ffelex_token_kill (ffeexpr_tokens_[2]);
  13934.       return (ffelexHandler) ffeexpr_token_binary_ (t);
  13935.     }
  13936.  
  13937.   /* Just exponent character by itself?     In which case, PLUS or MINUS must
  13938.      surely be next, followed by a NUMBER token. */
  13939.  
  13940.   if (*p == '\0')
  13941.     {
  13942.       ffeexpr_tokens_[3] = ffelex_token_use (t);
  13943.       return (ffelexHandler) ffeexpr_token_number_real_exp_;
  13944.     }
  13945.  
  13946.   ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
  13947.                  ffeexpr_tokens_[2], t, NULL, NULL);
  13948.  
  13949.   ffelex_token_kill (ffeexpr_tokens_[0]);
  13950.   ffelex_token_kill (ffeexpr_tokens_[1]);
  13951.   ffelex_token_kill (ffeexpr_tokens_[2]);
  13952.   return (ffelexHandler) ffeexpr_token_binary_;
  13953. }
  13954.  
  13955. /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
  13956.  
  13957.    Return a pointer to this function to the lexer (ffelex), which will
  13958.    invoke it for the next token.
  13959.  
  13960.    Make sure token is a NUMBER, make a real constant out of all we have and
  13961.    push it onto the expression stack.  Else issue diagnostic and pretend
  13962.    exponent field was a zero.  */
  13963.  
  13964. static ffelexHandler
  13965. ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
  13966. {
  13967.   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
  13968.     {
  13969.       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
  13970.     {
  13971.       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
  13972.                ffelex_token_where_column (ffeexpr_tokens_[2]));
  13973.       ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
  13974.       ffebad_finish ();
  13975.     }
  13976.  
  13977.       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
  13978.                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
  13979.                  NULL, NULL, NULL, NULL);
  13980.  
  13981.       ffelex_token_kill (ffeexpr_tokens_[0]);
  13982.       ffelex_token_kill (ffeexpr_tokens_[1]);
  13983.       ffelex_token_kill (ffeexpr_tokens_[2]);
  13984.       ffelex_token_kill (ffeexpr_tokens_[3]);
  13985.       return (ffelexHandler) ffeexpr_token_binary_ (t);
  13986.     }
  13987.  
  13988.   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
  13989.                  ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
  13990.                  ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
  13991.  
  13992.   ffelex_token_kill (ffeexpr_tokens_[0]);
  13993.   ffelex_token_kill (ffeexpr_tokens_[1]);
  13994.   ffelex_token_kill (ffeexpr_tokens_[2]);
  13995.   ffelex_token_kill (ffeexpr_tokens_[3]);
  13996.   return (ffelexHandler) ffeexpr_token_binary_;
  13997. }
  13998.  
  13999. /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
  14000.  
  14001.    Return a pointer to this function to the lexer (ffelex), which will
  14002.    invoke it for the next token.
  14003.  
  14004.    Ensures this token is PLUS or MINUS, preserves it, goes to final state
  14005.    for real number (exponent digits).  Else issues diagnostic, assumes a
  14006.    zero exponent field for number, passes token on to binary state as if
  14007.    previous token had been "E0" instead of "E", for example.  */
  14008.  
  14009. static ffelexHandler
  14010. ffeexpr_token_number_real_exp_ (ffelexToken t)
  14011. {
  14012.   if ((ffelex_token_type (t) != FFELEX_typePLUS)
  14013.       && (ffelex_token_type (t) != FFELEX_typeMINUS))
  14014.     {
  14015.       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
  14016.     {
  14017.       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
  14018.                ffelex_token_where_column (ffeexpr_tokens_[3]));
  14019.       ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
  14020.       ffebad_finish ();
  14021.     }
  14022.  
  14023.       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
  14024.                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
  14025.                  ffeexpr_tokens_[2], NULL, NULL, NULL);
  14026.  
  14027.       ffelex_token_kill (ffeexpr_tokens_[0]);
  14028.       ffelex_token_kill (ffeexpr_tokens_[1]);
  14029.       ffelex_token_kill (ffeexpr_tokens_[2]);
  14030.       ffelex_token_kill (ffeexpr_tokens_[3]);
  14031.       return (ffelexHandler) ffeexpr_token_binary_ (t);
  14032.     }
  14033.  
  14034.   ffeexpr_tokens_[4] = ffelex_token_use (t);
  14035.   return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
  14036. }
  14037.  
  14038. /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
  14039.                   PLUS/MINUS
  14040.  
  14041.    Return a pointer to this function to the lexer (ffelex), which will
  14042.    invoke it for the next token.
  14043.  
  14044.    Make sure token is a NUMBER, make a real constant out of all we have and
  14045.    push it onto the expression stack.  Else issue diagnostic and pretend
  14046.    exponent field was a zero.  */
  14047.  
  14048. static ffelexHandler
  14049. ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
  14050. {
  14051.   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
  14052.     {
  14053.       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
  14054.     {
  14055.       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
  14056.                ffelex_token_where_column (ffeexpr_tokens_[3]));
  14057.       ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
  14058.       ffebad_finish ();
  14059.     }
  14060.  
  14061.       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
  14062.                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
  14063.                  ffeexpr_tokens_[2], NULL, NULL, NULL);
  14064.  
  14065.       ffelex_token_kill (ffeexpr_tokens_[0]);
  14066.       ffelex_token_kill (ffeexpr_tokens_[1]);
  14067.       ffelex_token_kill (ffeexpr_tokens_[2]);
  14068.       ffelex_token_kill (ffeexpr_tokens_[3]);
  14069.       ffelex_token_kill (ffeexpr_tokens_[4]);
  14070.       return (ffelexHandler) ffeexpr_token_binary_ (t);
  14071.     }
  14072.  
  14073.   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
  14074.                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
  14075.                  ffeexpr_tokens_[2], ffeexpr_tokens_[3],
  14076.                  ffeexpr_tokens_[4], t);
  14077.  
  14078.   ffelex_token_kill (ffeexpr_tokens_[0]);
  14079.   ffelex_token_kill (ffeexpr_tokens_[1]);
  14080.   ffelex_token_kill (ffeexpr_tokens_[2]);
  14081.   ffelex_token_kill (ffeexpr_tokens_[3]);
  14082.   ffelex_token_kill (ffeexpr_tokens_[4]);
  14083.   return (ffelexHandler) ffeexpr_token_binary_;
  14084. }
  14085.  
  14086. /* ffeexpr_token_binary_ -- Handle binary operator possibility
  14087.  
  14088.    Return a pointer to this function to the lexer (ffelex), which will
  14089.    invoke it for the next token.
  14090.  
  14091.    The possibility of a binary operator is handled here, meaning the previous
  14092.    token was an operand.  */
  14093.  
  14094. static ffelexHandler
  14095. ffeexpr_token_binary_ (ffelexToken t)
  14096. {
  14097.   ffeexprExpr_ e;
  14098.  
  14099.   if (!ffeexpr_stack_->is_rhs)
  14100.     return (ffelexHandler) ffeexpr_finished_ (t);    /* For now. */
  14101.  
  14102.   switch (ffelex_token_type (t))
  14103.     {
  14104.     case FFELEX_typePLUS:
  14105.       e = ffeexpr_expr_new_ ();
  14106.       e->type = FFEEXPR_exprtypeBINARY_;
  14107.       e->token = ffelex_token_use (t);
  14108.       e->u.operator.op = FFEEXPR_operatorADD_;
  14109.       e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
  14110.       e->u.operator.as = FFEEXPR_operatorassociativityADD_;
  14111.       ffeexpr_exprstack_push_binary_ (e);
  14112.       return (ffelexHandler) ffeexpr_token_rhs_;
  14113.  
  14114.     case FFELEX_typeMINUS:
  14115.       e = ffeexpr_expr_new_ ();
  14116.       e->type = FFEEXPR_exprtypeBINARY_;
  14117.       e->token = ffelex_token_use (t);
  14118.       e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
  14119.       e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
  14120.       e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
  14121.       ffeexpr_exprstack_push_binary_ (e);
  14122.       return (ffelexHandler) ffeexpr_token_rhs_;
  14123.  
  14124.     case FFELEX_typeASTERISK:
  14125.       switch (ffeexpr_stack_->context)
  14126.     {
  14127.     case FFEEXPR_contextDATA:
  14128.       return (ffelexHandler) ffeexpr_finished_ (t);
  14129.  
  14130.     default:
  14131.       break;
  14132.     }
  14133.       e = ffeexpr_expr_new_ ();
  14134.       e->type = FFEEXPR_exprtypeBINARY_;
  14135.       e->token = ffelex_token_use (t);
  14136.       e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
  14137.       e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
  14138.       e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
  14139.       ffeexpr_exprstack_push_binary_ (e);
  14140.       return (ffelexHandler) ffeexpr_token_rhs_;
  14141.  
  14142.     case FFELEX_typeSLASH:
  14143.       switch (ffeexpr_stack_->context)
  14144.     {
  14145.     case FFEEXPR_contextDATA:
  14146.       return (ffelexHandler) ffeexpr_finished_ (t);
  14147.  
  14148.     default:
  14149.       break;
  14150.     }
  14151.       e = ffeexpr_expr_new_ ();
  14152.       e->type = FFEEXPR_exprtypeBINARY_;
  14153.       e->token = ffelex_token_use (t);
  14154.       e->u.operator.op = FFEEXPR_operatorDIVIDE_;
  14155.       e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
  14156.       e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
  14157.       ffeexpr_exprstack_push_binary_ (e);
  14158.       return (ffelexHandler) ffeexpr_token_rhs_;
  14159.  
  14160.     case FFELEX_typePOWER:
  14161.       e = ffeexpr_expr_new_ ();
  14162.       e->type = FFEEXPR_exprtypeBINARY_;
  14163.       e->token = ffelex_token_use (t);
  14164.       e->u.operator.op = FFEEXPR_operatorPOWER_;
  14165.       e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
  14166.       e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
  14167.       ffeexpr_exprstack_push_binary_ (e);
  14168.       return (ffelexHandler) ffeexpr_token_rhs_;
  14169.  
  14170.     case FFELEX_typeCONCAT:
  14171.       e = ffeexpr_expr_new_ ();
  14172.       e->type = FFEEXPR_exprtypeBINARY_;
  14173.       e->token = ffelex_token_use (t);
  14174.       e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
  14175.       e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
  14176.       e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
  14177.       ffeexpr_exprstack_push_binary_ (e);
  14178.       return (ffelexHandler) ffeexpr_token_rhs_;
  14179.  
  14180.     case FFELEX_typeOPEN_ANGLE:
  14181.       switch (ffeexpr_stack_->context)
  14182.     {
  14183.     case FFEEXPR_contextFORMAT:
  14184.       ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
  14185.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  14186.       ffebad_finish ();
  14187.       break;
  14188.  
  14189.     default:
  14190.       break;
  14191.     }
  14192.       e = ffeexpr_expr_new_ ();
  14193.       e->type = FFEEXPR_exprtypeBINARY_;
  14194.       e->token = ffelex_token_use (t);
  14195.       e->u.operator.op = FFEEXPR_operatorLT_;
  14196.       e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
  14197.       e->u.operator.as = FFEEXPR_operatorassociativityLT_;
  14198.       ffeexpr_exprstack_push_binary_ (e);
  14199.       return (ffelexHandler) ffeexpr_token_rhs_;
  14200.  
  14201.     case FFELEX_typeCLOSE_ANGLE:
  14202.       switch (ffeexpr_stack_->context)
  14203.     {
  14204.     case FFEEXPR_contextFORMAT:
  14205.       return ffeexpr_finished_ (t);
  14206.  
  14207.     default:
  14208.       break;
  14209.     }
  14210.       e = ffeexpr_expr_new_ ();
  14211.       e->type = FFEEXPR_exprtypeBINARY_;
  14212.       e->token = ffelex_token_use (t);
  14213.       e->u.operator.op = FFEEXPR_operatorGT_;
  14214.       e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
  14215.       e->u.operator.as = FFEEXPR_operatorassociativityGT_;
  14216.       ffeexpr_exprstack_push_binary_ (e);
  14217.       return (ffelexHandler) ffeexpr_token_rhs_;
  14218.  
  14219.     case FFELEX_typeREL_EQ:
  14220.       switch (ffeexpr_stack_->context)
  14221.     {
  14222.     case FFEEXPR_contextFORMAT:
  14223.       ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
  14224.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  14225.       ffebad_finish ();
  14226.       break;
  14227.  
  14228.     default:
  14229.       break;
  14230.     }
  14231.       e = ffeexpr_expr_new_ ();
  14232.       e->type = FFEEXPR_exprtypeBINARY_;
  14233.       e->token = ffelex_token_use (t);
  14234.       e->u.operator.op = FFEEXPR_operatorEQ_;
  14235.       e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
  14236.       e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
  14237.       ffeexpr_exprstack_push_binary_ (e);
  14238.       return (ffelexHandler) ffeexpr_token_rhs_;
  14239.  
  14240.     case FFELEX_typeREL_NE:
  14241.       switch (ffeexpr_stack_->context)
  14242.     {
  14243.     case FFEEXPR_contextFORMAT:
  14244.       ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
  14245.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  14246.       ffebad_finish ();
  14247.       break;
  14248.  
  14249.     default:
  14250.       break;
  14251.     }
  14252.       e = ffeexpr_expr_new_ ();
  14253.       e->type = FFEEXPR_exprtypeBINARY_;
  14254.       e->token = ffelex_token_use (t);
  14255.       e->u.operator.op = FFEEXPR_operatorNE_;
  14256.       e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
  14257.       e->u.operator.as = FFEEXPR_operatorassociativityNE_;
  14258.       ffeexpr_exprstack_push_binary_ (e);
  14259.       return (ffelexHandler) ffeexpr_token_rhs_;
  14260.  
  14261.     case FFELEX_typeREL_LE:
  14262.       switch (ffeexpr_stack_->context)
  14263.     {
  14264.     case FFEEXPR_contextFORMAT:
  14265.       ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
  14266.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  14267.       ffebad_finish ();
  14268.       break;
  14269.  
  14270.     default:
  14271.       break;
  14272.     }
  14273.       e = ffeexpr_expr_new_ ();
  14274.       e->type = FFEEXPR_exprtypeBINARY_;
  14275.       e->token = ffelex_token_use (t);
  14276.       e->u.operator.op = FFEEXPR_operatorLE_;
  14277.       e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
  14278.       e->u.operator.as = FFEEXPR_operatorassociativityLE_;
  14279.       ffeexpr_exprstack_push_binary_ (e);
  14280.       return (ffelexHandler) ffeexpr_token_rhs_;
  14281.  
  14282.     case FFELEX_typeREL_GE:
  14283.       switch (ffeexpr_stack_->context)
  14284.     {
  14285.     case FFEEXPR_contextFORMAT:
  14286.       ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
  14287.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  14288.       ffebad_finish ();
  14289.       break;
  14290.  
  14291.     default:
  14292.       break;
  14293.     }
  14294.       e = ffeexpr_expr_new_ ();
  14295.       e->type = FFEEXPR_exprtypeBINARY_;
  14296.       e->token = ffelex_token_use (t);
  14297.       e->u.operator.op = FFEEXPR_operatorGE_;
  14298.       e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
  14299.       e->u.operator.as = FFEEXPR_operatorassociativityGE_;
  14300.       ffeexpr_exprstack_push_binary_ (e);
  14301.       return (ffelexHandler) ffeexpr_token_rhs_;
  14302.  
  14303.     case FFELEX_typePERIOD:
  14304.       ffeexpr_tokens_[0] = ffelex_token_use (t);
  14305.       return (ffelexHandler) ffeexpr_token_binary_period_;
  14306.  
  14307. #if 0
  14308.     case FFELEX_typeOPEN_PAREN:
  14309.     case FFELEX_typeCLOSE_PAREN:
  14310.     case FFELEX_typeEQUALS:
  14311.     case FFELEX_typePOINTS:
  14312.     case FFELEX_typeCOMMA:
  14313.     case FFELEX_typeCOLON:
  14314.     case FFELEX_typeEOS:
  14315.     case FFELEX_typeSEMICOLON:
  14316.     case FFELEX_typeNAME:
  14317.     case FFELEX_typeNAMES:
  14318. #endif
  14319.     default:
  14320.       return (ffelexHandler) ffeexpr_finished_ (t);
  14321.     }
  14322. }
  14323.  
  14324. /* ffeexpr_token_binary_period_ -- Binary PERIOD
  14325.  
  14326.    Return a pointer to this function to the lexer (ffelex), which will
  14327.    invoke it for the next token.
  14328.  
  14329.    Handle a period detected at binary (expecting binary op or end) state.
  14330.    Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
  14331.    valid.  */
  14332.  
  14333. static ffelexHandler
  14334. ffeexpr_token_binary_period_ (ffelexToken t)
  14335. {
  14336.   ffeexprExpr_ operand;
  14337.  
  14338.   switch (ffelex_token_type (t))
  14339.     {
  14340.     case FFELEX_typeNAME:
  14341.     case FFELEX_typeNAMES:
  14342.       ffeexpr_current_dotdot_ = ffeexpr_dotdot_ (t);
  14343.       switch (ffeexpr_current_dotdot_)
  14344.     {
  14345.     case FFEEXPR_dotdotTRUE_:
  14346.     case FFEEXPR_dotdotFALSE_:
  14347.     case FFEEXPR_dotdotNOT_:
  14348.       if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
  14349.         {
  14350.           operand = ffeexpr_stack_->exprstack;
  14351.           assert (operand != NULL);
  14352.           assert (operand->type == FFEEXPR_exprtypeOPERAND_);
  14353.           ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
  14354.           ffebad_here (1, ffelex_token_where_line (t),
  14355.                ffelex_token_where_column (t));
  14356.           ffebad_finish ();
  14357.         }
  14358.       ffelex_token_kill (ffeexpr_tokens_[0]);
  14359.       return (ffelexHandler) ffeexpr_token_binary_sw_per_;
  14360.  
  14361.     case FFEEXPR_dotdotNONE_:
  14362.       if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
  14363.         {
  14364.           ffebad_string (ffelex_token_text (t));
  14365.           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
  14366.                ffelex_token_where_column (ffeexpr_tokens_[0]));
  14367.           ffebad_finish ();
  14368.         }
  14369.       ffeexpr_current_dotdot_ = FFEEXPR_dotdotEQ_;
  14370.       /* Fall through here, pretending we got a .EQ. operator. */
  14371.     default:
  14372.       ffeexpr_tokens_[1] = ffelex_token_use (t);
  14373.       return (ffelexHandler) ffeexpr_token_binary_end_per_;
  14374.     }
  14375.       break;            /* Nothing really reaches here. */
  14376.  
  14377.     default:
  14378.       if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
  14379.     {
  14380.       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
  14381.                ffelex_token_where_column (ffeexpr_tokens_[0]));
  14382.       ffebad_finish ();
  14383.     }
  14384.       ffelex_token_kill (ffeexpr_tokens_[0]);
  14385.       return (ffelexHandler) ffeexpr_token_binary_ (t);
  14386.     }
  14387. }
  14388.  
  14389. /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
  14390.  
  14391.    Return a pointer to this function to the lexer (ffelex), which will
  14392.    invoke it for the next token.
  14393.  
  14394.    Expecting a period to close a dot-dot at binary (binary op
  14395.    or operator) state.    If period isn't found, issue a diagnostic but
  14396.    pretend we saw one.    ffeexpr_current_dotdot_ must already contained the
  14397.    dotdot representation of the name in between the two PERIOD tokens.    */
  14398.  
  14399. static ffelexHandler
  14400. ffeexpr_token_binary_end_per_ (ffelexToken t)
  14401. {
  14402.   ffeexprExpr_ e;
  14403.  
  14404.   if (ffelex_token_type (t) != FFELEX_typePERIOD)
  14405.     {
  14406.       if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
  14407.     {
  14408.       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
  14409.                ffelex_token_where_column (ffeexpr_tokens_[0]));
  14410.       ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
  14411.       ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
  14412.       ffebad_finish ();
  14413.     }
  14414.     }
  14415.  
  14416.   ffelex_token_kill (ffeexpr_tokens_[1]);    /* Kill dot-dot token. */
  14417.  
  14418.   e = ffeexpr_expr_new_ ();
  14419.   e->type = FFEEXPR_exprtypeBINARY_;
  14420.   e->token = ffeexpr_tokens_[0];
  14421.  
  14422.   switch (ffeexpr_current_dotdot_)
  14423.     {
  14424.     case FFEEXPR_dotdotAND_:
  14425.       e->u.operator.op = FFEEXPR_operatorAND_;
  14426.       e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
  14427.       e->u.operator.as = FFEEXPR_operatorassociativityAND_;
  14428.       break;
  14429.  
  14430.     case FFEEXPR_dotdotOR_:
  14431.       e->u.operator.op = FFEEXPR_operatorOR_;
  14432.       e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
  14433.       e->u.operator.as = FFEEXPR_operatorassociativityOR_;
  14434.       break;
  14435.  
  14436.     case FFEEXPR_dotdotXOR_:
  14437.       e->u.operator.op = FFEEXPR_operatorXOR_;
  14438.       e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
  14439.       e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
  14440.       break;
  14441.  
  14442.     case FFEEXPR_dotdotEQV_:
  14443.       e->u.operator.op = FFEEXPR_operatorEQV_;
  14444.       e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
  14445.       e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
  14446.       break;
  14447.  
  14448.     case FFEEXPR_dotdotNEQV_:
  14449.       e->u.operator.op = FFEEXPR_operatorNEQV_;
  14450.       e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
  14451.       e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
  14452.       break;
  14453.  
  14454.     case FFEEXPR_dotdotLT_:
  14455.       e->u.operator.op = FFEEXPR_operatorLT_;
  14456.       e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
  14457.       e->u.operator.as = FFEEXPR_operatorassociativityLT_;
  14458.       break;
  14459.  
  14460.     case FFEEXPR_dotdotLE_:
  14461.       e->u.operator.op = FFEEXPR_operatorLE_;
  14462.       e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
  14463.       e->u.operator.as = FFEEXPR_operatorassociativityLE_;
  14464.       break;
  14465.  
  14466.     case FFEEXPR_dotdotEQ_:
  14467.       e->u.operator.op = FFEEXPR_operatorEQ_;
  14468.       e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
  14469.       e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
  14470.       break;
  14471.  
  14472.     case FFEEXPR_dotdotNE_:
  14473.       e->u.operator.op = FFEEXPR_operatorNE_;
  14474.       e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
  14475.       e->u.operator.as = FFEEXPR_operatorassociativityNE_;
  14476.       break;
  14477.  
  14478.     case FFEEXPR_dotdotGT_:
  14479.       e->u.operator.op = FFEEXPR_operatorGT_;
  14480.       e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
  14481.       e->u.operator.as = FFEEXPR_operatorassociativityGT_;
  14482.       break;
  14483.  
  14484.     case FFEEXPR_dotdotGE_:
  14485.       e->u.operator.op = FFEEXPR_operatorGE_;
  14486.       e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
  14487.       e->u.operator.as = FFEEXPR_operatorassociativityGE_;
  14488.       break;
  14489.  
  14490.     default:
  14491.       assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
  14492.     }
  14493.  
  14494.   ffeexpr_exprstack_push_binary_ (e);
  14495.  
  14496.   if (ffelex_token_type (t) != FFELEX_typePERIOD)
  14497.     return (ffelexHandler) ffeexpr_token_rhs_ (t);
  14498.   return (ffelexHandler) ffeexpr_token_rhs_;
  14499. }
  14500.  
  14501. /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
  14502.  
  14503.    Return a pointer to this function to the lexer (ffelex), which will
  14504.    invoke it for the next token.
  14505.  
  14506.    A diagnostic has already been issued; just swallow a period if there is
  14507.    one, then continue with ffeexpr_token_binary_.  */
  14508.  
  14509. static ffelexHandler
  14510. ffeexpr_token_binary_sw_per_ (ffelexToken t)
  14511. {
  14512.   if (ffelex_token_type (t) != FFELEX_typePERIOD)
  14513.     return (ffelexHandler) ffeexpr_token_binary_ (t);
  14514.  
  14515.   return (ffelexHandler) ffeexpr_token_binary_;
  14516. }
  14517.  
  14518. /* ffeexpr_token_quote_ -- Rhs QUOTE
  14519.  
  14520.    Return a pointer to this function to the lexer (ffelex), which will
  14521.    invoke it for the next token.
  14522.  
  14523.    Expecting a NUMBER that we'll treat as an octal integer.  */
  14524.  
  14525. static ffelexHandler
  14526. ffeexpr_token_quote_ (ffelexToken t)
  14527. {
  14528.   ffeexprExpr_ e;
  14529.   ffebld anyexpr;
  14530.  
  14531.   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
  14532.     {
  14533.       if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
  14534.     {
  14535.       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
  14536.                ffelex_token_where_column (ffeexpr_tokens_[0]));
  14537.       ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
  14538.       ffebad_finish ();
  14539.     }
  14540.       ffelex_token_kill (ffeexpr_tokens_[0]);
  14541.       return (ffelexHandler) ffeexpr_token_rhs_ (t);
  14542.     }
  14543.  
  14544.   /* This is kind of a kludge to prevent any whining about magical numbers
  14545.      that start out as these octal integers, so "20000000000 (on a 32-bit
  14546.      2's-complement machine) by itself won't produce an error. */
  14547.  
  14548.   anyexpr = ffebld_new_any ();
  14549.   ffebld_set_info (anyexpr, ffeinfo_new_any ());
  14550.  
  14551.   e = ffeexpr_expr_new_ ();
  14552.   e->type = FFEEXPR_exprtypeOPERAND_;
  14553.   e->token = ffeexpr_tokens_[0];
  14554.   e->u.operand = ffebld_new_conter_with_orig
  14555.     (ffebld_constant_new_integeroctal (t), anyexpr);
  14556.   ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
  14557.               FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
  14558.                FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
  14559.   ffeexpr_exprstack_push_operand_ (e);
  14560.   return (ffelexHandler) ffeexpr_token_binary_;
  14561. }
  14562.  
  14563. /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
  14564.  
  14565.    Return a pointer to this function to the lexer (ffelex), which will
  14566.    invoke it for the next token.
  14567.  
  14568.    Handle an open-apostrophe, which begins either a character ('char-const'),
  14569.    typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
  14570.    'hex-const'X) constant.  */
  14571.  
  14572. static ffelexHandler
  14573. ffeexpr_token_apostrophe_ (ffelexToken t)
  14574. {
  14575.   assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
  14576.   if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
  14577.     {
  14578.       ffebad_start (FFEBAD_NULL_CHAR_CONST);
  14579.       ffebad_here (0, ffelex_token_where_line (t),
  14580.            ffelex_token_where_column (t));
  14581.       ffebad_finish ();
  14582.     }
  14583.   ffeexpr_tokens_[1] = ffelex_token_use (t);
  14584.   return (ffelexHandler) ffeexpr_token_apos_char_;
  14585. }
  14586.  
  14587. /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
  14588.  
  14589.    Return a pointer to this function to the lexer (ffelex), which will
  14590.    invoke it for the next token.
  14591.  
  14592.    Close-apostrophe is implicit; if this token is NAME, it is a possible
  14593.    typeless-constant radix specifier.  */
  14594.  
  14595. static ffelexHandler
  14596. ffeexpr_token_apos_char_ (ffelexToken t)
  14597. {
  14598.   ffeexprExpr_ e;
  14599.   ffeinfo ni;
  14600.   char c;
  14601.   ffetargetCharacterSize size;
  14602.  
  14603.   if ((ffelex_token_type (t) == FFELEX_typeNAME)
  14604.       || (ffelex_token_type (t) == FFELEX_typeNAMES))
  14605.     {
  14606.       if ((ffelex_token_length (t) == 1)
  14607.       && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
  14608.                       'b')
  14609.           || ffesrc_char_match_init (c, 'O', 'o')
  14610.           || ffesrc_char_match_init (c, 'X', 'x')
  14611.           || ffesrc_char_match_init (c, 'Z', 'z')))
  14612.     {
  14613.       e = ffeexpr_expr_new_ ();
  14614.       e->type = FFEEXPR_exprtypeOPERAND_;
  14615.       e->token = ffeexpr_tokens_[0];
  14616.       switch (c)
  14617.         {
  14618.         case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
  14619.           e->u.operand = ffebld_new_conter
  14620.         (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
  14621.           size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
  14622.           break;
  14623.  
  14624.         case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
  14625.           e->u.operand = ffebld_new_conter
  14626.         (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
  14627.           size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
  14628.           break;
  14629.  
  14630.         case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
  14631.           e->u.operand = ffebld_new_conter
  14632.         (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
  14633.           size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
  14634.           break;
  14635.  
  14636.         case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
  14637.           e->u.operand = ffebld_new_conter
  14638.         (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
  14639.           size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
  14640.           break;
  14641.  
  14642.         default:
  14643.         no_match:        /* :::::::::::::::::::: */
  14644.           assert ("not BOXZ!" == NULL);
  14645.           size = 0;
  14646.           break;
  14647.         }
  14648.       ffebld_set_info (e->u.operand,
  14649.            ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
  14650.                0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
  14651.       ffeexpr_exprstack_push_operand_ (e);
  14652.       ffelex_token_kill (ffeexpr_tokens_[1]);
  14653.       return (ffelexHandler) ffeexpr_token_binary_;
  14654.     }
  14655.     }
  14656.   e = ffeexpr_expr_new_ ();
  14657.   e->type = FFEEXPR_exprtypeOPERAND_;
  14658.   e->token = ffeexpr_tokens_[0];
  14659.   e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
  14660.                     (ffeexpr_tokens_[1]));
  14661.   ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
  14662.             0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
  14663.             ffelex_token_length (ffeexpr_tokens_[1]));
  14664.   ffebld_set_info (e->u.operand, ni);
  14665.   ffelex_token_kill (ffeexpr_tokens_[1]);
  14666.   ffeexpr_exprstack_push_operand_ (e);
  14667.   if ((ffelex_token_type (t) == FFELEX_typeNAME)
  14668.       || (ffelex_token_type (t) == FFELEX_typeNAMES))
  14669.     {
  14670.       if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
  14671.     {
  14672.       ffebad_string (ffelex_token_text (t));
  14673.       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  14674.       ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
  14675.                ffelex_token_where_column (ffeexpr_tokens_[0]));
  14676.       ffebad_finish ();
  14677.     }
  14678.       e = ffeexpr_expr_new_ ();
  14679.       e->type = FFEEXPR_exprtypeBINARY_;
  14680.       e->token = ffelex_token_use (t);
  14681.       e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
  14682.       e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
  14683.       e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
  14684.       ffeexpr_exprstack_push_binary_ (e);
  14685.       return (ffelexHandler) ffeexpr_token_rhs_ (t);
  14686.     }
  14687.   ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 ();    /* Allow "'hello'(3:5)". */
  14688.   return (ffelexHandler) ffeexpr_token_substrp_ (t);
  14689. }
  14690.  
  14691. /* ffeexpr_token_name_lhs_ -- Lhs NAME
  14692.  
  14693.    Return a pointer to this function to the lexer (ffelex), which will
  14694.    invoke it for the next token.
  14695.  
  14696.    Handle a name followed by open-paren, period (RECORD.MEMBER), percent
  14697.    (RECORD%MEMBER), or nothing at all.    */
  14698.  
  14699. static ffelexHandler
  14700. ffeexpr_token_name_lhs_ (ffelexToken t)
  14701. {
  14702.   ffeexprExpr_ e;
  14703.   ffeexprParenType_ paren_type;
  14704.   ffesymbol s;
  14705.   ffebld expr;
  14706.   ffeinfo info;
  14707.  
  14708.   switch (ffelex_token_type (t))
  14709.     {
  14710.     case FFELEX_typeOPEN_PAREN:
  14711.       switch (ffeexpr_stack_->context)
  14712.     {
  14713.     case FFEEXPR_contextASSIGN:
  14714.     case FFEEXPR_contextAGOTO:
  14715.     case FFEEXPR_contextFILEUNIT_DF:
  14716.       goto just_name;    /* :::::::::::::::::::: */
  14717.  
  14718.     default:
  14719.       break;
  14720.     }
  14721.       e = ffeexpr_expr_new_ ();
  14722.       e->type = FFEEXPR_exprtypeOPERAND_;
  14723.       e->token = ffelex_token_use (ffeexpr_tokens_[0]);
  14724.       s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
  14725.                       &paren_type);
  14726.  
  14727.       switch (ffesymbol_where (s))
  14728.     {
  14729.     case FFEINFO_whereLOCAL:
  14730.       if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
  14731.         ffesymbol_error (s, ffeexpr_tokens_[0]);    /* Recursion. */
  14732.       break;
  14733.  
  14734.     case FFEINFO_whereINTRINSIC:
  14735.     case FFEINFO_whereGLOBAL:
  14736.       if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
  14737.         ffesymbol_error (s, ffeexpr_tokens_[0]);    /* Can call intrin. */
  14738.       break;
  14739.  
  14740.     case FFEINFO_whereCOMMON:
  14741.     case FFEINFO_whereDUMMY:
  14742.     case FFEINFO_whereRESULT:
  14743.       break;
  14744.  
  14745.     case FFEINFO_whereNONE:
  14746.       break;
  14747.  
  14748.     default:
  14749.       ffesymbol_error (s, ffeexpr_tokens_[0]);
  14750.       break;
  14751.     }
  14752.  
  14753.       if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
  14754.     {
  14755.       e->u.operand = ffebld_new_any ();
  14756.       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
  14757.     }
  14758.       else
  14759.     {
  14760.       e->u.operand = ffebld_new_symter (s,
  14761.                         ffesymbol_generic (s),
  14762.                         ffesymbol_specific (s),
  14763.                         ffesymbol_implementation (s));
  14764.       ffebld_set_info (e->u.operand, ffesymbol_info (s));
  14765.     }
  14766.       ffeexpr_exprstack_push_ (e);    /* Not a complete operand yet. */
  14767.       ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
  14768.       switch (paren_type)
  14769.     {
  14770.     case FFEEXPR_parentypeSUBROUTINE_:
  14771.       ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
  14772.       return
  14773.         (ffelexHandler)
  14774.         ffeexpr_rhs (ffeexpr_stack_->pool,
  14775.              FFEEXPR_contextACTUALARG_,
  14776.              ffeexpr_token_arguments_);
  14777.  
  14778.     case FFEEXPR_parentypeARRAY_:
  14779.       ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
  14780.       ffeexpr_stack_->bound_list = ffesymbol_dims (s);
  14781.       ffeexpr_stack_->rank = 0;
  14782.       ffeexpr_stack_->constant = TRUE;
  14783.       ffeexpr_stack_->immediate = TRUE;
  14784.       switch (ffeexpr_stack_->context)
  14785.         {
  14786.         case FFEEXPR_contextDATAIMPDOITEM_:
  14787.           return
  14788.         (ffelexHandler)
  14789.         ffeexpr_rhs (ffeexpr_stack_->pool,
  14790.                  FFEEXPR_contextDATAIMPDOINDEX_,
  14791.                  ffeexpr_token_elements_);
  14792.  
  14793.         case FFEEXPR_contextEQUIVALENCE:
  14794.           return
  14795.         (ffelexHandler)
  14796.         ffeexpr_rhs (ffeexpr_stack_->pool,
  14797.                  FFEEXPR_contextEQVINDEX_,
  14798.                  ffeexpr_token_elements_);
  14799.  
  14800.         default:
  14801.           return
  14802.         (ffelexHandler)
  14803.         ffeexpr_rhs (ffeexpr_stack_->pool,
  14804.                  FFEEXPR_contextINDEX_,
  14805.                  ffeexpr_token_elements_);
  14806.         }
  14807.  
  14808.     case FFEEXPR_parentypeSUBSTRING_:
  14809.       e->u.operand = ffeexpr_collapse_symter (e->u.operand,
  14810.                           ffeexpr_tokens_[0]);
  14811.       return
  14812.         (ffelexHandler)
  14813.         ffeexpr_rhs (ffeexpr_stack_->pool,
  14814.              FFEEXPR_contextINDEX_,
  14815.              ffeexpr_token_substring_);
  14816.  
  14817.     case FFEEXPR_parentypeEQUIVALENCE_:
  14818.       ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
  14819.       ffeexpr_stack_->bound_list = ffesymbol_dims (s);
  14820.       ffeexpr_stack_->rank = 0;
  14821.       ffeexpr_stack_->constant = TRUE;
  14822.       ffeexpr_stack_->immediate = TRUE;
  14823.       return
  14824.         (ffelexHandler)
  14825.         ffeexpr_rhs (ffeexpr_stack_->pool,
  14826.              FFEEXPR_contextEQVINDEX_,
  14827.              ffeexpr_token_equivalence_);
  14828.  
  14829.     case FFEEXPR_parentypeFUNCTION_:    /* Invalid case. */
  14830.     case FFEEXPR_parentypeFUNSUBSTR_:    /* Invalid case. */
  14831.       ffesymbol_error (s, ffeexpr_tokens_[0]);
  14832.       /* Fall through. */
  14833.     case FFEEXPR_parentypeANY_:
  14834.       e->u.operand = ffebld_new_any ();
  14835.       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
  14836.       return
  14837.         (ffelexHandler)
  14838.         ffeexpr_rhs (ffeexpr_stack_->pool,
  14839.              FFEEXPR_contextACTUALARG_,
  14840.              ffeexpr_token_anything_);
  14841.  
  14842.     default:
  14843.       assert ("bad paren type" == NULL);
  14844.       break;
  14845.     }
  14846.  
  14847.     case FFELEX_typeEQUALS:    /* As in "VAR=". */
  14848.       switch (ffeexpr_stack_->context)
  14849.     {
  14850.     case FFEEXPR_contextIMPDOITEM_:    /* within
  14851.                            "(,VAR=start,end[,incr])". */
  14852.     case FFEEXPR_contextIMPDOITEMDF_:
  14853.       ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
  14854.       break;
  14855.  
  14856.     case FFEEXPR_contextDATAIMPDOITEM_:
  14857.       ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
  14858.       break;
  14859.  
  14860.     default:
  14861.       break;
  14862.     }
  14863.       break;
  14864.  
  14865. #if 0
  14866.     case FFELEX_typePERIOD:
  14867.     case FFELEX_typePERCENT:
  14868.       assert ("FOO%, FOO. not yet supported!~~" == NULL);
  14869.       break;
  14870. #endif
  14871.  
  14872.     default:
  14873.       break;
  14874.     }
  14875.  
  14876. just_name:            /* :::::::::::::::::::: */
  14877.   e = ffeexpr_expr_new_ ();
  14878.   e->type = FFEEXPR_exprtypeOPERAND_;
  14879.   e->token = ffeexpr_tokens_[0];
  14880.   s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
  14881.                   (ffeexpr_stack_->context
  14882.                    == FFEEXPR_contextSUBROUTINEREF));
  14883.  
  14884.   switch (ffesymbol_where (s))
  14885.     {
  14886.     case FFEINFO_whereCONSTANT:
  14887.       if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
  14888.       || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
  14889.     ffesymbol_error (s, ffeexpr_tokens_[0]);
  14890.       break;
  14891.  
  14892.     case FFEINFO_whereIMMEDIATE:
  14893.       if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
  14894.       && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
  14895.     ffesymbol_error (s, ffeexpr_tokens_[0]);
  14896.       break;
  14897.  
  14898.     case FFEINFO_whereLOCAL:
  14899.       if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
  14900.     ffesymbol_error (s, ffeexpr_tokens_[0]);    /* Recurse!. */
  14901.       break;
  14902.  
  14903.     case FFEINFO_whereINTRINSIC:
  14904.       if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
  14905.     ffesymbol_error (s, ffeexpr_tokens_[0]);    /* Can call intrin. */
  14906.       break;
  14907.  
  14908.     default:
  14909.       break;
  14910.     }
  14911.  
  14912.   if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
  14913.     {
  14914.       expr = ffebld_new_any ();
  14915.       info = ffeinfo_new_any ();
  14916.       ffebld_set_info (expr, info);
  14917.     }
  14918.   else
  14919.     {
  14920.       expr = ffebld_new_symter (s,
  14921.                 ffesymbol_generic (s),
  14922.                 ffesymbol_specific (s),
  14923.                 ffesymbol_implementation (s));
  14924.       info = ffesymbol_info (s);
  14925.       ffebld_set_info (expr, info);
  14926.       if (ffesymbol_is_doiter (s))
  14927.     {
  14928.       ffebad_start (FFEBAD_DOITER);
  14929.       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
  14930.                ffelex_token_where_column (ffeexpr_tokens_[0]));
  14931.       ffest_ffebad_here_doiter (1, s);
  14932.       ffebad_string (ffesymbol_text (s));
  14933.       ffebad_finish ();
  14934.     }
  14935.       expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
  14936.     }
  14937.  
  14938.   if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
  14939.     {
  14940.       if (ffebld_op (expr) == FFEBLD_opANY)
  14941.     {
  14942.       expr = ffebld_new_any ();
  14943.       ffebld_set_info (expr, ffeinfo_new_any ());
  14944.     }
  14945.       else
  14946.     {
  14947.       expr = ffebld_new_subrref (expr, NULL);    /* No argument list. */
  14948.       if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
  14949.         ffeintrin_fulfill_generic (&expr, &info, e->token);
  14950.       else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
  14951.         ffeintrin_fulfill_specific (&expr, &info, e->token);
  14952.       ffebld_set_info (expr,
  14953.                ffeinfo_new (ffeinfo_basictype (info),
  14954.                     ffeinfo_kindtype (info),
  14955.                     0,
  14956.                     FFEINFO_kindENTITY,
  14957.                     FFEINFO_whereFLEETING,
  14958.                     ffeinfo_size (info)));
  14959.     }
  14960.     }
  14961.  
  14962.   e->u.operand = expr;
  14963.   ffeexpr_exprstack_push_operand_ (e);
  14964.   return (ffelexHandler) ffeexpr_finished_ (t);
  14965. }
  14966.  
  14967. /* ffeexpr_token_name_arg_ -- Rhs NAME
  14968.  
  14969.    Return a pointer to this function to the lexer (ffelex), which will
  14970.    invoke it for the next token.
  14971.  
  14972.    Handle first token in an actual-arg (or possible actual-arg) context
  14973.    being a NAME, and use second token to refine the context.  */
  14974.  
  14975. static ffelexHandler
  14976. ffeexpr_token_name_arg_ (ffelexToken t)
  14977. {
  14978.   switch (ffelex_token_type (t))
  14979.     {
  14980.     case FFELEX_typeCLOSE_PAREN:
  14981.     case FFELEX_typeCOMMA:
  14982.       switch (ffeexpr_stack_->context)
  14983.     {
  14984.     case FFEEXPR_contextINDEXORACTUALARG_:
  14985.       ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
  14986.       break;
  14987.  
  14988.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  14989.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
  14990.       break;
  14991.  
  14992.     default:
  14993.       break;
  14994.     }
  14995.       break;
  14996.  
  14997.     default:
  14998.       switch (ffeexpr_stack_->context)
  14999.     {
  15000.     case FFEEXPR_contextACTUALARG_:
  15001.       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
  15002.       break;
  15003.  
  15004.     case FFEEXPR_contextINDEXORACTUALARG_:
  15005.       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
  15006.       break;
  15007.  
  15008.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  15009.       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
  15010.       break;
  15011.  
  15012.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  15013.       ffeexpr_stack_->context
  15014.         = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
  15015.       break;
  15016.  
  15017.     default:
  15018.       assert ("bad context in _name_arg_" == NULL);
  15019.       break;
  15020.     }
  15021.       break;
  15022.     }
  15023.  
  15024.   return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
  15025. }
  15026.  
  15027. /* ffeexpr_token_name_rhs_ -- Rhs NAME
  15028.  
  15029.    Return a pointer to this function to the lexer (ffelex), which will
  15030.    invoke it for the next token.
  15031.  
  15032.    Handle a name followed by open-paren, apostrophe (O'octal-const',
  15033.    Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
  15034.  
  15035.    26-Nov-91  JCB  1.2
  15036.       When followed by apostrophe or quote, set lex hexnum flag on so
  15037.       [0-9] as first char of next token seen as starting a potentially
  15038.       hex number (NAME).
  15039.    04-Oct-91  JCB  1.1
  15040.       In case of intrinsic, decorate its SYMTER with the type info for
  15041.       the specific intrinsic.  */
  15042.  
  15043. static ffelexHandler
  15044. ffeexpr_token_name_rhs_ (ffelexToken t)
  15045. {
  15046.   ffeexprExpr_ e;
  15047.   ffeexprParenType_ paren_type;
  15048.   ffesymbol s;
  15049.   bool sfdef;
  15050.  
  15051.   switch (ffelex_token_type (t))
  15052.     {
  15053.     case FFELEX_typeQUOTE:
  15054.     case FFELEX_typeAPOSTROPHE:
  15055.       ffeexpr_tokens_[1] = ffelex_token_use (t);
  15056.       ffelex_set_hexnum (TRUE);
  15057.       return (ffelexHandler) ffeexpr_token_name_apos_;
  15058.  
  15059.     case FFELEX_typeOPEN_PAREN:
  15060.       e = ffeexpr_expr_new_ ();
  15061.       e->type = FFEEXPR_exprtypeOPERAND_;
  15062.       e->token = ffelex_token_use (ffeexpr_tokens_[0]);
  15063.       s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
  15064.                       &paren_type);
  15065.       if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
  15066.     e->u.operand = ffebld_new_any ();
  15067.       else
  15068.     e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
  15069.                       ffesymbol_specific (s),
  15070.                       ffesymbol_implementation (s));
  15071.       ffeexpr_exprstack_push_ (e);    /* Not a complete operand yet. */
  15072.       ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
  15073.       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
  15074.     {
  15075.     case FFEEXPR_contextSFUNCDEF:
  15076.     case FFEEXPR_contextSFUNCDEFINDEX_:
  15077.     case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
  15078.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
  15079.       sfdef = TRUE;
  15080.       break;
  15081.  
  15082.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  15083.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  15084.       assert ("weird context!" == NULL);
  15085.       sfdef = FALSE;
  15086.       break;
  15087.  
  15088.     default:
  15089.       sfdef = FALSE;
  15090.       break;
  15091.     }
  15092.       switch (paren_type)
  15093.     {
  15094.     case FFEEXPR_parentypeFUNCTION_:
  15095.       ffebld_set_info (e->u.operand, ffesymbol_info (s));
  15096.       ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
  15097.       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
  15098.         {            /* A statement function. */
  15099.           ffeexpr_stack_->num_args
  15100.         = ffebld_list_length
  15101.           (ffeexpr_stack_->next_dummy
  15102.            = ffesymbol_dummyargs (s));
  15103.           ffeexpr_stack_->tokens[1] = NULL;    /* !=NULL when > num_args. */
  15104.         }
  15105.       else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
  15106.            && !ffe_is_pedantic_not_90 ()
  15107.            && ((ffesymbol_implementation (s)
  15108.             == FFEINTRIN_impICHAR)
  15109.                || (ffesymbol_implementation (s)
  15110.                == FFEINTRIN_impIACHAR)
  15111.                || (ffesymbol_implementation (s)
  15112.                == FFEINTRIN_impLEN)))
  15113.         {            /* Allow arbitrary concatenations. */
  15114.           return
  15115.         (ffelexHandler)
  15116.           ffeexpr_rhs (ffeexpr_stack_->pool,
  15117.                    sfdef
  15118.                    ? FFEEXPR_contextSFUNCDEF
  15119.                    : FFEEXPR_contextLET,
  15120.                    ffeexpr_token_arguments_);
  15121.         }
  15122.       return
  15123.         (ffelexHandler)
  15124.         ffeexpr_rhs (ffeexpr_stack_->pool,
  15125.              sfdef
  15126.              ? FFEEXPR_contextSFUNCDEFACTUALARG_
  15127.              : FFEEXPR_contextACTUALARG_,
  15128.              ffeexpr_token_arguments_);
  15129.  
  15130.     case FFEEXPR_parentypeARRAY_:
  15131.       ffebld_set_info (e->u.operand,
  15132.                ffesymbol_info (ffebld_symter (e->u.operand)));
  15133.       ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
  15134.       ffeexpr_stack_->bound_list = ffesymbol_dims (s);
  15135.       ffeexpr_stack_->rank = 0;
  15136.       ffeexpr_stack_->constant = TRUE;
  15137.       ffeexpr_stack_->immediate = TRUE;
  15138.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  15139.                           sfdef
  15140.                           ? FFEEXPR_contextSFUNCDEFINDEX_
  15141.                           : FFEEXPR_contextINDEX_,
  15142.                           ffeexpr_token_elements_);
  15143.  
  15144.     case FFEEXPR_parentypeSUBSTRING_:
  15145.       ffebld_set_info (e->u.operand,
  15146.                ffesymbol_info (ffebld_symter (e->u.operand)));
  15147.       e->u.operand = ffeexpr_collapse_symter (e->u.operand,
  15148.                           ffeexpr_tokens_[0]);
  15149.       return
  15150.         (ffelexHandler)
  15151.         ffeexpr_rhs (ffeexpr_stack_->pool,
  15152.              sfdef
  15153.              ? FFEEXPR_contextSFUNCDEFINDEX_
  15154.              : FFEEXPR_contextINDEX_,
  15155.              ffeexpr_token_substring_);
  15156.  
  15157.     case FFEEXPR_parentypeFUNSUBSTR_:
  15158.       return
  15159.         (ffelexHandler)
  15160.         ffeexpr_rhs (ffeexpr_stack_->pool,
  15161.              sfdef
  15162.              ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
  15163.              : FFEEXPR_contextINDEXORACTUALARG_,
  15164.              ffeexpr_token_funsubstr_);
  15165.  
  15166.     case FFEEXPR_parentypeSUBROUTINE_:    /* Invalid case. */
  15167.     case FFEEXPR_parentypeANY_:
  15168.       ffebld_set_info (e->u.operand, ffesymbol_info (s));
  15169.       return
  15170.         (ffelexHandler)
  15171.         ffeexpr_rhs (ffeexpr_stack_->pool,
  15172.              sfdef
  15173.              ? FFEEXPR_contextSFUNCDEFACTUALARG_
  15174.              : FFEEXPR_contextACTUALARG_,
  15175.              ffeexpr_token_anything_);
  15176.  
  15177.     default:
  15178.       assert ("bad paren type" == NULL);
  15179.       break;
  15180.     }
  15181.  
  15182.     case FFELEX_typeEQUALS:    /* As in "VAR=". */
  15183.       switch (ffeexpr_stack_->context)
  15184.     {
  15185.     case FFEEXPR_contextIMPDOITEM_:    /* "(,VAR=start,end[,incr])". */
  15186.     case FFEEXPR_contextIMPDOITEMDF_:
  15187.       ffeexpr_stack_->is_rhs = FALSE;    /* Really an lhs construct. */
  15188.       ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
  15189.       break;
  15190.  
  15191.     default:
  15192.       break;
  15193.     }
  15194.       break;
  15195.  
  15196. #if 0
  15197.     case FFELEX_typePERIOD:
  15198.     case FFELEX_typePERCENT:
  15199.       ~~Support these two someday, though not required
  15200.     assert ("FOO%, FOO. not yet supported!~~" == NULL);
  15201.       break;
  15202. #endif
  15203.  
  15204.     default:
  15205.       break;
  15206.     }
  15207.  
  15208.   switch (ffeexpr_stack_->context)
  15209.     {
  15210.     case FFEEXPR_contextINDEXORACTUALARG_:
  15211.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  15212.       assert ("strange context" == NULL);
  15213.       break;
  15214.  
  15215.     default:
  15216.       break;
  15217.     }
  15218.  
  15219.   e = ffeexpr_expr_new_ ();
  15220.   e->type = FFEEXPR_exprtypeOPERAND_;
  15221.   e->token = ffeexpr_tokens_[0];
  15222.   s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
  15223.   if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
  15224.     {
  15225.       e->u.operand = ffebld_new_any ();
  15226.       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
  15227.     }
  15228.   else
  15229.     {
  15230.       e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
  15231.                     ffesymbol_specific (s),
  15232.                     ffesymbol_implementation (s));
  15233.       if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
  15234.     ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
  15235.       else
  15236.     {            /* Decorate the SYMTER with the actual type
  15237.                    of the intrinsic. */
  15238.       ffebld_set_info (e->u.operand, ffeinfo_new
  15239.             (ffeintrin_basictype (ffesymbol_implementation (s)),
  15240.              ffeintrin_kindtype (ffesymbol_implementation (s)),
  15241.              0,
  15242.              ffesymbol_kind (s),
  15243.              ffesymbol_where (s),
  15244.              FFETARGET_charactersizeNONE));
  15245.     }
  15246.       if (ffesymbol_is_doiter (s))
  15247.     ffebld_symter_set_is_doiter (e->u.operand, TRUE);
  15248.       e->u.operand = ffeexpr_collapse_symter (e->u.operand,
  15249.                           ffeexpr_tokens_[0]);
  15250.     }
  15251.   ffeexpr_exprstack_push_operand_ (e);
  15252.   return (ffelexHandler) ffeexpr_token_binary_ (t);
  15253. }
  15254.  
  15255. /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
  15256.  
  15257.    Return a pointer to this function to the lexer (ffelex), which will
  15258.    invoke it for the next token.
  15259.  
  15260.    Expecting a NAME token, analyze the previous NAME token to see what kind,
  15261.    if any, typeless constant we've got.
  15262.  
  15263.    01-Sep-90  JCB  1.1
  15264.       Expect a NAME instead of CHARACTER in this situation.  */
  15265.  
  15266. static ffelexHandler
  15267. ffeexpr_token_name_apos_ (ffelexToken t)
  15268. {
  15269.   ffeexprExpr_ e;
  15270.  
  15271.   ffelex_set_hexnum (FALSE);
  15272.  
  15273.   switch (ffelex_token_type (t))
  15274.     {
  15275.     case FFELEX_typeNAME:
  15276.       ffeexpr_tokens_[2] = ffelex_token_use (t);
  15277.       return (ffelexHandler) ffeexpr_token_name_apos_name_;
  15278.  
  15279.     default:
  15280.       break;
  15281.     }
  15282.  
  15283.   if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
  15284.     {
  15285.       ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
  15286.       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
  15287.            ffelex_token_where_column (ffeexpr_tokens_[0]));
  15288.       ffebad_here (1, ffelex_token_where_line (t),
  15289.            ffelex_token_where_column (t));
  15290.       ffebad_finish ();
  15291.     }
  15292.  
  15293.   ffelex_token_kill (ffeexpr_tokens_[1]);
  15294.  
  15295.   e = ffeexpr_expr_new_ ();
  15296.   e->type = FFEEXPR_exprtypeOPERAND_;
  15297.   e->u.operand = ffebld_new_any ();
  15298.   ffebld_set_info (e->u.operand, ffeinfo_new_any ());
  15299.   e->token = ffeexpr_tokens_[0];
  15300.   ffeexpr_exprstack_push_operand_ (e);
  15301.  
  15302.   return (ffelexHandler) ffeexpr_token_binary_ (t);
  15303. }
  15304.  
  15305. /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
  15306.  
  15307.    Return a pointer to this function to the lexer (ffelex), which will
  15308.    invoke it for the next token.
  15309.  
  15310.    Expecting an APOSTROPHE token, analyze the previous NAME token to see
  15311.    what kind, if any, typeless constant we've got.  */
  15312.  
  15313. static ffelexHandler
  15314. ffeexpr_token_name_apos_name_ (ffelexToken t)
  15315. {
  15316.   ffeexprExpr_ e;
  15317.   char c;
  15318.  
  15319.   e = ffeexpr_expr_new_ ();
  15320.   e->type = FFEEXPR_exprtypeOPERAND_;
  15321.   e->token = ffeexpr_tokens_[0];
  15322.  
  15323.   if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
  15324.       && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
  15325.       && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
  15326.                   'B', 'b')
  15327.       || ffesrc_char_match_init (c, 'O', 'o')
  15328.       || ffesrc_char_match_init (c, 'X', 'x')
  15329.       || ffesrc_char_match_init (c, 'Z', 'z')))
  15330.     {
  15331.       ffetargetCharacterSize size;
  15332.  
  15333.       switch (c)
  15334.     {
  15335.     case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
  15336.       e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
  15337.                         (ffeexpr_tokens_[2]));
  15338.       size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
  15339.       break;
  15340.  
  15341.     case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
  15342.       e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
  15343.                         (ffeexpr_tokens_[2]));
  15344.       size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
  15345.       break;
  15346.  
  15347.     case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
  15348.       e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
  15349.                         (ffeexpr_tokens_[2]));
  15350.       size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
  15351.       break;
  15352.  
  15353.     case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
  15354.       e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
  15355.                         (ffeexpr_tokens_[2]));
  15356.       size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
  15357.       break;
  15358.  
  15359.     default:
  15360.     no_match:        /* :::::::::::::::::::: */
  15361.       assert ("not BOXZ!" == NULL);
  15362.       e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
  15363.                         (ffeexpr_tokens_[2]));
  15364.       size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
  15365.       break;
  15366.     }
  15367.       ffebld_set_info (e->u.operand,
  15368.            ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
  15369.                0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
  15370.       ffeexpr_exprstack_push_operand_ (e);
  15371.       ffelex_token_kill (ffeexpr_tokens_[1]);
  15372.       ffelex_token_kill (ffeexpr_tokens_[2]);
  15373.       return (ffelexHandler) ffeexpr_token_binary_;
  15374.     }
  15375.  
  15376.   if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
  15377.     {
  15378.       ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
  15379.       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
  15380.            ffelex_token_where_column (ffeexpr_tokens_[0]));
  15381.       ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
  15382.       ffebad_finish ();
  15383.     }
  15384.  
  15385.   ffelex_token_kill (ffeexpr_tokens_[1]);
  15386.   ffelex_token_kill (ffeexpr_tokens_[2]);
  15387.  
  15388.   e->type = FFEEXPR_exprtypeOPERAND_;
  15389.   e->u.operand = ffebld_new_any ();
  15390.   ffebld_set_info (e->u.operand, ffeinfo_new_any ());
  15391.   e->token = ffeexpr_tokens_[0];
  15392.   ffeexpr_exprstack_push_operand_ (e);
  15393.  
  15394.   switch (ffelex_token_type (t))
  15395.     {
  15396.     case FFELEX_typeAPOSTROPHE:
  15397.     case FFELEX_typeQUOTE:
  15398.       return (ffelexHandler) ffeexpr_token_binary_;
  15399.  
  15400.     default:
  15401.       return (ffelexHandler) ffeexpr_token_binary_ (t);
  15402.     }
  15403. }
  15404.  
  15405. /* ffeexpr_token_percent_ -- Rhs PERCENT
  15406.  
  15407.    Handle a percent sign possibly followed by "LOC".  If followed instead
  15408.    by "VAL", "REF", or "DESCR", issue an error message and substitute
  15409.    "LOC".  If followed by something else, treat the percent sign as a
  15410.    spurious incorrect token and reprocess the token via _rhs_.    */
  15411.  
  15412. static ffelexHandler
  15413. ffeexpr_token_percent_ (ffelexToken t)
  15414. {
  15415.   switch (ffelex_token_type (t))
  15416.     {
  15417.     case FFELEX_typeNAME:
  15418.     case FFELEX_typeNAMES:
  15419.       ffeexpr_stack_->percent = ffeexpr_percent_ (t);
  15420.       ffeexpr_tokens_[1] = ffelex_token_use (t);
  15421.       return (ffelexHandler) ffeexpr_token_percent_name_;
  15422.  
  15423.     default:
  15424.       if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
  15425.     {
  15426.       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
  15427.                ffelex_token_where_column (ffeexpr_tokens_[0]));
  15428.       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
  15429.            ffelex_token_where_column (ffeexpr_stack_->first_token));
  15430.       ffebad_finish ();
  15431.     }
  15432.       ffelex_token_kill (ffeexpr_tokens_[0]);
  15433.       return (ffelexHandler) ffeexpr_token_rhs_ (t);
  15434.     }
  15435. }
  15436.  
  15437. /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
  15438.  
  15439.    Make sure the token is OPEN_PAREN and prepare for the one-item list of
  15440.    LHS expressions.  Else display an error message.  */
  15441.  
  15442. static ffelexHandler
  15443. ffeexpr_token_percent_name_ (ffelexToken t)
  15444. {
  15445.   ffelexHandler nexthandler;
  15446.  
  15447.   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
  15448.     {
  15449.       if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
  15450.     {
  15451.       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
  15452.                ffelex_token_where_column (ffeexpr_tokens_[0]));
  15453.       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
  15454.            ffelex_token_where_column (ffeexpr_stack_->first_token));
  15455.       ffebad_finish ();
  15456.     }
  15457.       ffelex_token_kill (ffeexpr_tokens_[0]);
  15458.       nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
  15459.       ffelex_token_kill (ffeexpr_tokens_[1]);
  15460.       return (ffelexHandler) (*nexthandler) (t);
  15461.     }
  15462.  
  15463.   switch (ffeexpr_stack_->percent)
  15464.     {
  15465.     default:
  15466.       if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
  15467.     {
  15468.       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
  15469.                ffelex_token_where_column (ffeexpr_tokens_[0]));
  15470.       ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
  15471.       ffebad_finish ();
  15472.     }
  15473.       ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
  15474.       /* Fall through. */
  15475.     case FFEEXPR_percentLOC_:
  15476.       ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
  15477.       ffelex_token_kill (ffeexpr_tokens_[1]);
  15478.       ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
  15479.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  15480.                       FFEEXPR_contextLOC_,
  15481.                       ffeexpr_cb_end_loc_);
  15482.     }
  15483. }
  15484.  
  15485. /* ffeexpr_make_float_const_ -- Make a floating-point constant
  15486.  
  15487.    See prototype.
  15488.  
  15489.    Pass 'E', 'D', or 'Q' for exponent letter.  */
  15490.  
  15491. static void
  15492. ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
  15493.                ffelexToken decimal, ffelexToken fraction,
  15494.                ffelexToken exponent, ffelexToken exponent_sign,
  15495.                ffelexToken exponent_digits)
  15496. {
  15497.   ffeexprExpr_ e;
  15498.  
  15499.   e = ffeexpr_expr_new_ ();
  15500.   e->type = FFEEXPR_exprtypeOPERAND_;
  15501.   if (integer != NULL)
  15502.     e->token = ffelex_token_use (integer);
  15503.   else
  15504.     {
  15505.       assert (decimal != NULL);
  15506.       e->token = ffelex_token_use (decimal);
  15507.     }
  15508.  
  15509.   switch (exp_letter)
  15510.     {
  15511. #if !FFETARGET_okREALQUAD
  15512.     case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
  15513.       if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
  15514.     {
  15515.       ffebad_here (0, ffelex_token_where_line (e->token),
  15516.                ffelex_token_where_column (e->token));
  15517.       ffebad_finish ();
  15518.     }
  15519.       goto match_d;        /* The FFESRC_CASE_* macros don't
  15520.                    allow fall-through! */
  15521. #endif
  15522.  
  15523.     case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
  15524.       e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
  15525.                     (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
  15526.       ffebld_set_info (e->u.operand,
  15527.          ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
  15528.               0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
  15529.       break;
  15530.  
  15531.     case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
  15532.       e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
  15533.                     (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
  15534.       ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
  15535.              FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
  15536.                FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
  15537.       break;
  15538.  
  15539. #if FFETARGET_okREALQUAD
  15540.     case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
  15541.       e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
  15542.                     (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
  15543.       ffebld_set_info (e->u.operand,
  15544.            ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
  15545.                 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
  15546.       break;
  15547. #endif
  15548.  
  15549.     default:
  15550.     no_match:            /* :::::::::::::::::::: */
  15551.       assert ("Lost the exponent letter!" == NULL);
  15552.     }
  15553.  
  15554.   ffeexpr_exprstack_push_operand_ (e);
  15555. }
  15556.  
  15557. /* Just like ffesymbol_declare_local, except performs any implicit info
  15558.    assignment necessary.  */
  15559.  
  15560. static ffesymbol
  15561. ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
  15562. {
  15563.   ffesymbol s;
  15564.   ffeinfoKind k;
  15565.   bool bad;
  15566.  
  15567.   s = ffesymbol_declare_local (t, maybe_intrin);
  15568.  
  15569.   switch ((ffesymbol_sfdummyparent (s) == NULL)
  15570.       ? ffesymbol_state (s)
  15571.       : FFESYMBOL_stateUNDERSTOOD)
  15572.     {
  15573.     case FFESYMBOL_stateNONE:    /* Before first exec, not seen in expr
  15574.                    context. */
  15575.       if (!ffest_seen_first_exec ())
  15576.     goto seen;        /* :::::::::::::::::::: */
  15577.       /* Fall through. */
  15578.     case FFESYMBOL_stateUNCERTAIN:    /* Unseen since first exec. */
  15579.       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
  15580.     {
  15581.     case FFEEXPR_contextSUBROUTINEREF:
  15582.       s = ffeexpr_sym_lhs_call_ (s, t);
  15583.       break;
  15584.  
  15585.     case FFEEXPR_contextFILEEXTFUNC:
  15586.       s = ffeexpr_sym_lhs_extfunc_ (s, t);
  15587.       break;
  15588.  
  15589.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  15590.       s = ffecom_sym_exec_transition (s);
  15591.       if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
  15592.         goto understood;    /* :::::::::::::::::::: */
  15593.       /* Fall through. */
  15594.     case FFEEXPR_contextACTUALARG_:
  15595.       s = ffeexpr_sym_rhs_actualarg_ (s, t);
  15596.       break;
  15597.  
  15598.     case FFEEXPR_contextDATA:
  15599.       if (ffeexpr_stack_->is_rhs)
  15600.         s = ffeexpr_sym_rhs_let_ (s, t);
  15601.       else
  15602.         s = ffeexpr_sym_lhs_data_ (s, t);
  15603.       break;
  15604.  
  15605.     case FFEEXPR_contextDATAIMPDOITEM_:
  15606.       s = ffeexpr_sym_lhs_data_ (s, t);
  15607.       break;
  15608.  
  15609.     case FFEEXPR_contextDATAIMPDOINDEX_:
  15610.     case FFEEXPR_contextDATAIMPDOCTRL_:
  15611.       break;        /* UNDERSTOOD case still needs to call fns,
  15612.                    let it do this. */
  15613.  
  15614.     case FFEEXPR_contextSFUNCDEF:
  15615.     case FFEEXPR_contextSFUNCDEFINDEX_:
  15616.     case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
  15617.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
  15618.       s = ffecom_sym_exec_transition (s);
  15619.       if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
  15620.         goto understood;    /* :::::::::::::::::::: */
  15621.       /* Fall through. */
  15622.     case FFEEXPR_contextLET:
  15623.     case FFEEXPR_contextPAREN_:
  15624.     case FFEEXPR_contextACTUALARGEXPR_:
  15625.     case FFEEXPR_contextINDEXORACTUALARGEXPR_:
  15626.     case FFEEXPR_contextASSIGN:
  15627.     case FFEEXPR_contextIOLIST:
  15628.     case FFEEXPR_contextIOLISTDF:
  15629.     case FFEEXPR_contextDO:
  15630.     case FFEEXPR_contextDOWHILE:
  15631.     case FFEEXPR_contextAGOTO:
  15632.     case FFEEXPR_contextCGOTO:
  15633.     case FFEEXPR_contextIF:
  15634.     case FFEEXPR_contextARITHIF:
  15635.     case FFEEXPR_contextFORMAT:
  15636.     case FFEEXPR_contextSTOP:
  15637.     case FFEEXPR_contextRETURN:
  15638.     case FFEEXPR_contextSELECTCASE:
  15639.     case FFEEXPR_contextCASE:
  15640.     case FFEEXPR_contextFILEASSOC:
  15641.     case FFEEXPR_contextFILEINT:
  15642.     case FFEEXPR_contextFILEDFINT:
  15643.     case FFEEXPR_contextFILELOG:
  15644.     case FFEEXPR_contextFILENUM:
  15645.     case FFEEXPR_contextFILENUMAMBIG:
  15646.     case FFEEXPR_contextFILECHAR:
  15647.     case FFEEXPR_contextFILENUMCHAR:
  15648.     case FFEEXPR_contextFILEDFCHAR:
  15649.     case FFEEXPR_contextFILEKEY:
  15650.     case FFEEXPR_contextFILEUNIT:
  15651.     case FFEEXPR_contextFILEUNIT_DF:
  15652.     case FFEEXPR_contextFILEUNITAMBIG:
  15653.     case FFEEXPR_contextFILEFORMAT:
  15654.     case FFEEXPR_contextFILENAMELIST:
  15655.     case FFEEXPR_contextFILEVXTCODE:
  15656.     case FFEEXPR_contextINDEX_:
  15657.     case FFEEXPR_contextIMPDOITEM_:
  15658.     case FFEEXPR_contextIMPDOITEMDF_:
  15659.     case FFEEXPR_contextIMPDOCTRL_:
  15660.     case FFEEXPR_contextLOC_:
  15661.       if (ffeexpr_stack_->is_rhs)
  15662.         s = ffeexpr_sym_rhs_let_ (s, t);
  15663.       else
  15664.         s = ffeexpr_sym_lhs_let_ (s, t);
  15665.       break;
  15666.  
  15667.     case FFEEXPR_contextCHARACTERSIZE:
  15668.     case FFEEXPR_contextEQUIVALENCE:
  15669.     case FFEEXPR_contextINCLUDE:
  15670.     case FFEEXPR_contextPARAMETER:
  15671.     case FFEEXPR_contextDIMLIST:
  15672.     case FFEEXPR_contextDIMLISTCOMMON:
  15673.     case FFEEXPR_contextKINDTYPE:
  15674.     case FFEEXPR_contextINITVAL:
  15675.     case FFEEXPR_contextEQVINDEX_:
  15676.       break;        /* Will turn into errors below. */
  15677.  
  15678.     default:
  15679.       assert ("UNCERTAIN/NONE bad context" == NULL);
  15680.       break;
  15681.     }
  15682.       /* Fall through. */
  15683.     case FFESYMBOL_stateUNDERSTOOD:    /* Nothing much more to learn. */
  15684.     understood:        /* :::::::::::::::::::: */
  15685.       k = ffesymbol_kind (s);
  15686.       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
  15687.     {
  15688.     case FFEEXPR_contextSUBROUTINEREF:
  15689.       bad = (k != FFEINFO_kindSUBROUTINE);
  15690.       break;
  15691.  
  15692.     case FFEEXPR_contextFILEEXTFUNC:
  15693.       bad = (k != FFEINFO_kindFUNCTION)
  15694.         || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
  15695.       break;
  15696.  
  15697.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  15698.     case FFEEXPR_contextACTUALARG_:
  15699.       switch (k)
  15700.         {
  15701.         case FFEINFO_kindENTITY:
  15702.           bad = FALSE;
  15703.           break;
  15704.  
  15705.         case FFEINFO_kindFUNCTION:
  15706.         case FFEINFO_kindSUBROUTINE:
  15707.           bad
  15708.         = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
  15709.            && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
  15710.            && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
  15711.                || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
  15712.           break;
  15713.  
  15714.         case FFEINFO_kindNONE:
  15715.  
  15716.           /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
  15717.          and in the former case, attrsTYPE is set, so we
  15718.          see this as an error as we should, since CHAR*(*)
  15719.          cannot be actually referenced in a main/block data
  15720.          program unit.  */
  15721.  
  15722.           if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
  15723.                       | FFESYMBOL_attrsEXTERNAL
  15724.                       | FFESYMBOL_attrsTYPE))
  15725.           == FFESYMBOL_attrsEXTERNAL)
  15726.         bad = FALSE;
  15727.           else
  15728.         bad = TRUE;
  15729.           break;
  15730.  
  15731.         default:
  15732.           bad = TRUE;
  15733.           break;
  15734.         }
  15735.       break;
  15736.  
  15737.     case FFEEXPR_contextDATA:
  15738.       if (ffeexpr_stack_->is_rhs)
  15739.         bad = (k != FFEINFO_kindENTITY)
  15740.           || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
  15741.       else
  15742.         bad = (k != FFEINFO_kindENTITY)
  15743.           || ((ffesymbol_where (s) != FFEINFO_whereNONE)
  15744.           && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
  15745.           && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
  15746.       break;
  15747.  
  15748.     case FFEEXPR_contextDATAIMPDOITEM_:
  15749.       bad = TRUE;        /* Unadorned item never valid. */
  15750.       break;
  15751.  
  15752.     case FFEEXPR_contextDATAIMPDOINDEX_:
  15753.       s = ffeexpr_sym_impdoitem_ (s, t);
  15754.       k = ffesymbol_kind (s);
  15755.       bad = (k != FFEINFO_kindENTITY)
  15756.         || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
  15757.         && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
  15758.       break;
  15759.  
  15760.     case FFEEXPR_contextDATAIMPDOCTRL_:
  15761.       if (ffeexpr_stack_->is_rhs)
  15762.         s = ffeexpr_sym_impdoitem_ (s, t);
  15763.       else
  15764.         s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
  15765.       k = ffesymbol_kind (s);
  15766.       bad = (k != FFEINFO_kindENTITY)
  15767.         || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
  15768.         && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
  15769.       break;
  15770.  
  15771.     case FFEEXPR_contextSFUNCDEF:
  15772.     case FFEEXPR_contextSFUNCDEFINDEX_:
  15773.     case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
  15774.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
  15775.     case FFEEXPR_contextLET:
  15776.     case FFEEXPR_contextPAREN_:
  15777.     case FFEEXPR_contextACTUALARGEXPR_:
  15778.     case FFEEXPR_contextINDEXORACTUALARGEXPR_:
  15779.     case FFEEXPR_contextASSIGN:
  15780.     case FFEEXPR_contextIOLIST:
  15781.     case FFEEXPR_contextIOLISTDF:
  15782.     case FFEEXPR_contextDO:
  15783.     case FFEEXPR_contextDOWHILE:
  15784.     case FFEEXPR_contextAGOTO:
  15785.     case FFEEXPR_contextCGOTO:
  15786.     case FFEEXPR_contextIF:
  15787.     case FFEEXPR_contextARITHIF:
  15788.     case FFEEXPR_contextFORMAT:
  15789.     case FFEEXPR_contextSTOP:
  15790.     case FFEEXPR_contextRETURN:
  15791.     case FFEEXPR_contextSELECTCASE:
  15792.     case FFEEXPR_contextCASE:
  15793.     case FFEEXPR_contextFILEASSOC:
  15794.     case FFEEXPR_contextFILEINT:
  15795.     case FFEEXPR_contextFILEDFINT:
  15796.     case FFEEXPR_contextFILELOG:
  15797.     case FFEEXPR_contextFILENUM:
  15798.     case FFEEXPR_contextFILENUMAMBIG:
  15799.     case FFEEXPR_contextFILECHAR:
  15800.     case FFEEXPR_contextFILENUMCHAR:
  15801.     case FFEEXPR_contextFILEDFCHAR:
  15802.     case FFEEXPR_contextFILEKEY:
  15803.     case FFEEXPR_contextFILEUNIT:
  15804.     case FFEEXPR_contextFILEUNIT_DF:
  15805.     case FFEEXPR_contextFILEUNITAMBIG:
  15806.     case FFEEXPR_contextFILEFORMAT:
  15807.     case FFEEXPR_contextFILENAMELIST:
  15808.     case FFEEXPR_contextFILEVXTCODE:
  15809.     case FFEEXPR_contextINDEX_:
  15810.     case FFEEXPR_contextIMPDOITEM_:
  15811.     case FFEEXPR_contextIMPDOITEMDF_:
  15812.     case FFEEXPR_contextIMPDOCTRL_:
  15813.     case FFEEXPR_contextLOC_:
  15814.       bad = (k != FFEINFO_kindENTITY);    /* This catches "SUBROUTINE
  15815.                            X(A);EXTERNAL A;CALL
  15816.                            Y(A);B=A", for example. */
  15817.       break;
  15818.  
  15819.     case FFEEXPR_contextCHARACTERSIZE:
  15820.     case FFEEXPR_contextEQUIVALENCE:
  15821.     case FFEEXPR_contextPARAMETER:
  15822.     case FFEEXPR_contextDIMLIST:
  15823.     case FFEEXPR_contextDIMLISTCOMMON:
  15824.     case FFEEXPR_contextKINDTYPE:
  15825.     case FFEEXPR_contextINITVAL:
  15826.     case FFEEXPR_contextEQVINDEX_:
  15827.       bad = (k != FFEINFO_kindENTITY)
  15828.         || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
  15829.       break;
  15830.  
  15831.     case FFEEXPR_contextINCLUDE:
  15832.       bad = TRUE;
  15833.       break;
  15834.  
  15835.     default:
  15836.       assert ("UNDERSTOOD bad context" == NULL);
  15837.       bad = TRUE;
  15838.       break;
  15839.     }
  15840.       if (bad && (k != FFEINFO_kindANY))
  15841.     ffesymbol_error (s, t);
  15842.       return s;
  15843.  
  15844.     case FFESYMBOL_stateSEEN:    /* Seen but not yet in exec portion. */
  15845.     seen:            /* :::::::::::::::::::: */
  15846.       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
  15847.     {
  15848.     case FFEEXPR_contextPARAMETER:
  15849.       if (ffeexpr_stack_->is_rhs)
  15850.         ffesymbol_error (s, t);
  15851.       else
  15852.         s = ffeexpr_sym_lhs_parameter_ (s, t);
  15853.       break;
  15854.  
  15855.     case FFEEXPR_contextDATA:
  15856.       s = ffecom_sym_exec_transition (s);
  15857.       if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
  15858.         goto understood;    /* :::::::::::::::::::: */
  15859.       if (ffeexpr_stack_->is_rhs)
  15860.         ffesymbol_error (s, t);
  15861.       else
  15862.         s = ffeexpr_sym_lhs_data_ (s, t);
  15863.       goto understood;    /* :::::::::::::::::::: */
  15864.  
  15865.     case FFEEXPR_contextDATAIMPDOITEM_:
  15866.       s = ffecom_sym_exec_transition (s);
  15867.       if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
  15868.         goto understood;    /* :::::::::::::::::::: */
  15869.       s = ffeexpr_sym_lhs_data_ (s, t);
  15870.       goto understood;    /* :::::::::::::::::::: */
  15871.  
  15872.     case FFEEXPR_contextDATAIMPDOINDEX_:
  15873.       s = ffecom_sym_exec_transition (s);
  15874.       if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
  15875.         goto understood;    /* :::::::::::::::::::: */
  15876.       s = ffeexpr_sym_impdoitem_ (s, t);
  15877.       goto understood;    /* :::::::::::::::::::: */
  15878.  
  15879.     case FFEEXPR_contextDATAIMPDOCTRL_:
  15880.       s = ffecom_sym_exec_transition (s);
  15881.       if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
  15882.         goto understood;    /* :::::::::::::::::::: */
  15883.       if (ffeexpr_stack_->is_rhs)
  15884.         s = ffeexpr_sym_impdoitem_ (s, t);
  15885.       else
  15886.         s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
  15887.       goto understood;    /* :::::::::::::::::::: */
  15888.  
  15889.     case FFEEXPR_contextEQUIVALENCE:
  15890.       s = ffeexpr_sym_lhs_equivalence_ (s, t);
  15891.       break;
  15892.  
  15893.     case FFEEXPR_contextDIMLIST:
  15894.       s = ffeexpr_sym_rhs_dimlist_ (s, t);
  15895.       break;
  15896.  
  15897.     case FFEEXPR_contextCHARACTERSIZE:
  15898.     case FFEEXPR_contextKINDTYPE:
  15899.     case FFEEXPR_contextDIMLISTCOMMON:
  15900.     case FFEEXPR_contextINITVAL:
  15901.     case FFEEXPR_contextEQVINDEX_:
  15902.       ffesymbol_error (s, t);
  15903.       break;
  15904.  
  15905.     case FFEEXPR_contextINCLUDE:
  15906.       ffesymbol_error (s, t);
  15907.       break;
  15908.  
  15909.     case FFEEXPR_contextACTUALARG_:    /* E.g. I in REAL A(Y(I)). */
  15910.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  15911.       s = ffecom_sym_exec_transition (s);
  15912.       if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
  15913.         goto understood;    /* :::::::::::::::::::: */
  15914.       s = ffeexpr_sym_rhs_actualarg_ (s, t);
  15915.       goto understood;    /* :::::::::::::::::::: */
  15916.  
  15917.     case FFEEXPR_contextINDEX_:
  15918.     case FFEEXPR_contextACTUALARGEXPR_:
  15919.     case FFEEXPR_contextINDEXORACTUALARGEXPR_:
  15920.     case FFEEXPR_contextSFUNCDEF:
  15921.     case FFEEXPR_contextSFUNCDEFINDEX_:
  15922.     case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
  15923.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
  15924.       assert (ffeexpr_stack_->is_rhs);
  15925.       s = ffecom_sym_exec_transition (s);
  15926.       if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
  15927.         goto understood;    /* :::::::::::::::::::: */
  15928.       s = ffeexpr_sym_rhs_let_ (s, t);
  15929.       goto understood;    /* :::::::::::::::::::: */
  15930.  
  15931.     default:
  15932.       assert ("SEEN bad context" == NULL);
  15933.       break;
  15934.     }
  15935.       return s;
  15936.  
  15937.     default:
  15938.       assert ("bad symbol state" == NULL);
  15939.       return NULL;
  15940.       break;
  15941.     }
  15942. }
  15943.  
  15944. /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
  15945.    Could be found via the "statement-function" name space (in which case
  15946.    it should become an iterator) or the local name space (in which case
  15947.    it should be either a named constant, or a variable that will have an
  15948.    sfunc name space sibling that should become an iterator).  */
  15949.  
  15950. static ffesymbol
  15951. ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
  15952. {
  15953.   ffesymbol s;
  15954.   ffesymbolAttrs sa;
  15955.   ffesymbolAttrs na;
  15956.   ffesymbolState ss;
  15957.   ffesymbolState ns;
  15958.   ffeinfoKind kind;
  15959.   ffeinfoWhere where;
  15960.  
  15961.   ss = ffesymbol_state (sp);
  15962.  
  15963.   if (ffesymbol_sfdummyparent (sp) != NULL)
  15964.     {                /* Have symbol in sfunc name space. */
  15965.       switch (ss)
  15966.     {
  15967.     case FFESYMBOL_stateNONE:    /* Used as iterator already. */
  15968.       if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
  15969.         ffesymbol_error (sp, t);    /* Can't use dead iterator. */
  15970.       else
  15971.         {            /* Can use dead iterator because we're at at
  15972.                    least an innermore (higher-numbered) level
  15973.                    than the iterator's outermost
  15974.                    (lowest-numbered) level. */
  15975.           ffesymbol_signal_change (sp);
  15976.           ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
  15977.           ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
  15978.           ffesymbol_signal_unreported (sp);
  15979.         }
  15980.       break;
  15981.  
  15982.     case FFESYMBOL_stateSEEN:    /* Seen already in this or other
  15983.                        implied-DO.  Set symbol level
  15984.                        number to outermost value, as that
  15985.                        tells us we can see it as iterator
  15986.                        at that level at the innermost. */
  15987.       if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
  15988.         {
  15989.           ffesymbol_signal_change (sp);
  15990.           ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
  15991.           ffesymbol_signal_unreported (sp);
  15992.         }
  15993.       break;
  15994.  
  15995.     case FFESYMBOL_stateUNCERTAIN:    /* Iterator. */
  15996.       assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
  15997.       ffesymbol_error (sp, t);    /* (,,,I=I,10). */
  15998.       break;
  15999.  
  16000.     case FFESYMBOL_stateUNDERSTOOD:
  16001.       break;        /* ANY. */
  16002.  
  16003.     default:
  16004.       assert ("Foo Bar!!" == NULL);
  16005.       break;
  16006.     }
  16007.  
  16008.       return sp;
  16009.     }
  16010.  
  16011.   /* Got symbol in local name space, so we haven't seen it in impdo yet.
  16012.      First, if it is brand-new and we're in executable statements, set the
  16013.      attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
  16014.      Second, if it is now a constant (PARAMETER), then just return it, it
  16015.      can't be an implied-do iterator.  If it is understood, complain if it is
  16016.      not a valid variable, but make the inner name space iterator anyway and
  16017.      return that.  If it is not understood, improve understanding of the
  16018.      symbol accordingly, complain accordingly, in either case make the inner
  16019.      name space iterator and return that.  */
  16020.  
  16021.   sa = ffesymbol_attrs (sp);
  16022.  
  16023.   if (ffesymbol_state_is_specable (ss)
  16024.       && ffest_seen_first_exec ())
  16025.     {
  16026.       assert (sa == FFESYMBOL_attrsetNONE);
  16027.       ffesymbol_signal_change (sp);
  16028.       ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
  16029.       ffesymbol_resolve_intrin (sp);
  16030.       if (ffeimplic_establish_symbol (sp))
  16031.     ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
  16032.       else
  16033.     ffesymbol_error (sp, t);
  16034.  
  16035.       /* After the exec transition, the state will either be UNCERTAIN (could
  16036.          be a dummy or local var) or UNDERSTOOD (local var, because this is a
  16037.          PROGRAM/BLOCKDATA program unit).  */
  16038.  
  16039.       sp = ffecom_sym_exec_transition (sp);
  16040.       sa = ffesymbol_attrs (sp);
  16041.       ss = ffesymbol_state (sp);
  16042.     }
  16043.  
  16044.   ns = ss;
  16045.   kind = ffesymbol_kind (sp);
  16046.   where = ffesymbol_where (sp);
  16047.  
  16048.   if (ss == FFESYMBOL_stateUNDERSTOOD)
  16049.     {
  16050.       if (kind != FFEINFO_kindENTITY)
  16051.     ffesymbol_error (sp, t);
  16052.       if (where == FFEINFO_whereCONSTANT)
  16053.     return sp;
  16054.     }
  16055.   else
  16056.     {
  16057.       /* Enhance understanding of local symbol.  This used to imply exec
  16058.          transition, but that doesn't seem necessary, since the local symbol
  16059.          doesn't actually get put into an ffebld tree here -- we just learn
  16060.          more about it, just like when we see a local symbol's name in the
  16061.          dummy-arg list of a statement function.  */
  16062.  
  16063.       if (ss != FFESYMBOL_stateUNCERTAIN)
  16064.     {
  16065.       /* Figure out what kind of object we've got based on previous
  16066.          declarations of or references to the object. */
  16067.  
  16068.       ns = FFESYMBOL_stateSEEN;
  16069.  
  16070.       if (sa & FFESYMBOL_attrsANY)
  16071.         na = sa;
  16072.       else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
  16073.                 | FFESYMBOL_attrsANY
  16074.                 | FFESYMBOL_attrsCOMMON
  16075.                 | FFESYMBOL_attrsDUMMY
  16076.                 | FFESYMBOL_attrsEQUIV
  16077.                 | FFESYMBOL_attrsINIT
  16078.                 | FFESYMBOL_attrsNAMELIST
  16079.                 | FFESYMBOL_attrsRESULT
  16080.                 | FFESYMBOL_attrsSAVE
  16081.                 | FFESYMBOL_attrsSFARG
  16082.                 | FFESYMBOL_attrsTYPE)))
  16083.         na = sa | FFESYMBOL_attrsSFARG;
  16084.       else
  16085.         na = FFESYMBOL_attrsetNONE;
  16086.     }
  16087.       else
  16088.     {            /* stateUNCERTAIN. */
  16089.       na = sa | FFESYMBOL_attrsSFARG;
  16090.       ns = FFESYMBOL_stateUNDERSTOOD;
  16091.  
  16092.       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
  16093.                | FFESYMBOL_attrsANYLEN
  16094.                | FFESYMBOL_attrsARRAY
  16095.                | FFESYMBOL_attrsDUMMY
  16096.                | FFESYMBOL_attrsEXTERNAL
  16097.                | FFESYMBOL_attrsSFARG
  16098.                | FFESYMBOL_attrsTYPE)));
  16099.  
  16100.       if (sa & FFESYMBOL_attrsEXTERNAL)
  16101.         {
  16102.           assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
  16103.                    | FFESYMBOL_attrsDUMMY
  16104.                    | FFESYMBOL_attrsEXTERNAL
  16105.                    | FFESYMBOL_attrsTYPE)));
  16106.  
  16107.           na = FFESYMBOL_attrsetNONE;
  16108.         }
  16109.       else if (sa & FFESYMBOL_attrsDUMMY)
  16110.         {
  16111.           assert (!(sa & FFESYMBOL_attrsEXTERNAL));    /* Handled above. */
  16112.           assert (!(sa & ~(FFESYMBOL_attrsDUMMY
  16113.                    | FFESYMBOL_attrsEXTERNAL
  16114.                    | FFESYMBOL_attrsTYPE)));
  16115.  
  16116.           kind = FFEINFO_kindENTITY;
  16117.         }
  16118.       else if (sa & FFESYMBOL_attrsARRAY)
  16119.         {
  16120.           assert (!(sa & ~(FFESYMBOL_attrsARRAY
  16121.                    | FFESYMBOL_attrsTYPE)));
  16122.  
  16123.           na = FFESYMBOL_attrsetNONE;
  16124.         }
  16125.       else if (sa & FFESYMBOL_attrsSFARG)
  16126.         {
  16127.           assert (!(sa & ~(FFESYMBOL_attrsSFARG
  16128.                    | FFESYMBOL_attrsTYPE)));
  16129.  
  16130.           ns = FFESYMBOL_stateUNCERTAIN;
  16131.         }
  16132.       else if (sa & FFESYMBOL_attrsTYPE)
  16133.         {
  16134.           assert (!(sa & (FFESYMBOL_attrsARRAY
  16135.                   | FFESYMBOL_attrsDUMMY
  16136.                   | FFESYMBOL_attrsEXTERNAL
  16137.                   | FFESYMBOL_attrsSFARG)));    /* Handled above. */
  16138.           assert (!(sa & ~(FFESYMBOL_attrsANYLEN
  16139.                    | FFESYMBOL_attrsARRAY
  16140.                    | FFESYMBOL_attrsDUMMY
  16141.                    | FFESYMBOL_attrsEXTERNAL
  16142.                    | FFESYMBOL_attrsSFARG
  16143.                    | FFESYMBOL_attrsTYPE)));
  16144.  
  16145.           kind = FFEINFO_kindENTITY;
  16146.  
  16147.           if (sa & FFESYMBOL_attrsANYLEN)
  16148.         na = FFESYMBOL_attrsetNONE;
  16149.           else if (ffest_is_entry_valid ())
  16150.         ns = FFESYMBOL_stateUNCERTAIN;    /* Could be DUMMY or LOCAL. */
  16151.           else
  16152.         where = FFEINFO_whereLOCAL;
  16153.         }
  16154.       else
  16155.         na = FFESYMBOL_attrsetNONE;    /* Error. */
  16156.     }
  16157.  
  16158.       /* Now see what we've got for a new object: NONE means a new error
  16159.          cropped up; ANY means an old error to be ignored; otherwise,
  16160.          everything's ok, update the object (symbol) and continue on. */
  16161.  
  16162.       if (na == FFESYMBOL_attrsetNONE)
  16163.     ffesymbol_error (sp, t);
  16164.       else if (!(na & FFESYMBOL_attrsANY))
  16165.     {
  16166.       ffesymbol_signal_change (sp);    /* May need to back up to previous
  16167.                        version. */
  16168.       if (!ffeimplic_establish_symbol (sp))
  16169.         ffesymbol_error (sp, t);
  16170.       ffesymbol_set_info (sp,
  16171.                   ffeinfo_new (ffesymbol_basictype (sp),
  16172.                        ffesymbol_kindtype (sp),
  16173.                        ffesymbol_rank (sp),
  16174.                        kind,
  16175.                        where,
  16176.                        ffesymbol_size (sp)));
  16177.       ffesymbol_set_attrs (sp, na);
  16178.       ffesymbol_set_state (sp, ns);
  16179.       ffesymbol_resolve_intrin (sp);
  16180.       if (!ffesymbol_state_is_specable (ns))
  16181.         sp = ffecom_sym_learned (sp);
  16182.       ffesymbol_signal_unreported (sp);    /* For debugging purposes. */
  16183.     }
  16184.     }
  16185.  
  16186.   /* Here we create the sfunc-name-space symbol representing what should
  16187.      become an iterator in this name space at this or an outermore (lower-
  16188.      numbered) expression level, else the implied-DO construct is in error.  */
  16189.  
  16190.   s = ffesymbol_declare_sfdummy (t);    /* Sets maxentrynum to 0 for new obj;
  16191.                        also sets sfa_dummy_parent to
  16192.                        parent symbol. */
  16193.   assert (sp == ffesymbol_sfdummyparent (s));
  16194.  
  16195.   ffesymbol_signal_change (s);
  16196.   ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
  16197.   ffesymbol_set_maxentrynum (s, ffeexpr_level_);
  16198.   ffesymbol_set_info (s,
  16199.               ffeinfo_new (FFEINFO_basictypeINTEGER,
  16200.                    FFEINFO_kindtypeINTEGERDEFAULT,
  16201.                    0,
  16202.                    FFEINFO_kindENTITY,
  16203.                    FFEINFO_whereIMMEDIATE,
  16204.                    FFETARGET_charactersizeNONE));
  16205.   ffesymbol_signal_unreported (s);
  16206.  
  16207.   if (((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
  16208.        && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
  16209.       || ((ffesymbol_kindtype (sp) != FFEINFO_kindtypeINTEGERDEFAULT)
  16210.       && (ffesymbol_kindtype (sp) != FFEINFO_kindtypeANY)))
  16211.     ffesymbol_error (s, t);
  16212.  
  16213.   return s;
  16214. }
  16215.  
  16216. /* Have FOO in CALL FOO.  Local name space, executable context only.  */
  16217.  
  16218. static ffesymbol
  16219. ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
  16220. {
  16221.   ffesymbolAttrs sa;
  16222.   ffesymbolAttrs na;
  16223.   ffeinfoKind kind;
  16224.   ffeinfoWhere where;
  16225.   ffeintrinGen gen;
  16226.   ffeintrinSpec spec;
  16227.   ffeintrinImp imp;
  16228.  
  16229.   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
  16230.       || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
  16231.  
  16232.   na = sa = ffesymbol_attrs (s);
  16233.  
  16234.   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
  16235.            | FFESYMBOL_attrsANYLEN
  16236.            | FFESYMBOL_attrsARRAY
  16237.            | FFESYMBOL_attrsDUMMY
  16238.            | FFESYMBOL_attrsEXTERNAL
  16239.            | FFESYMBOL_attrsSFARG
  16240.            | FFESYMBOL_attrsTYPE)));
  16241.  
  16242.   kind = ffesymbol_kind (s);
  16243.   where = ffesymbol_where (s);
  16244.  
  16245.   /* Figure out what kind of object we've got based on previous declarations
  16246.      of or references to the object. */
  16247.  
  16248.   if (sa & FFESYMBOL_attrsEXTERNAL)
  16249.     {
  16250.       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
  16251.                | FFESYMBOL_attrsDUMMY
  16252.                | FFESYMBOL_attrsEXTERNAL
  16253.                | FFESYMBOL_attrsTYPE)));
  16254.  
  16255.       if (sa & FFESYMBOL_attrsTYPE)
  16256.     na = FFESYMBOL_attrsetNONE;
  16257.       else
  16258.     /* Not TYPE. */
  16259.     {
  16260.       kind = FFEINFO_kindSUBROUTINE;
  16261.  
  16262.       if (sa & FFESYMBOL_attrsDUMMY)
  16263.         ;            /* Not TYPE. */
  16264.       else if (sa & FFESYMBOL_attrsACTUALARG)
  16265.         ;            /* Not DUMMY or TYPE. */
  16266.       else            /* Not ACTUALARG, DUMMY, or TYPE. */
  16267.         where = FFEINFO_whereGLOBAL;
  16268.     }
  16269.     }
  16270.   else if (sa & FFESYMBOL_attrsDUMMY)
  16271.     {
  16272.       assert (!(sa & FFESYMBOL_attrsEXTERNAL));    /* Handled above. */
  16273.       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
  16274.                | FFESYMBOL_attrsEXTERNAL
  16275.                | FFESYMBOL_attrsTYPE)));
  16276.  
  16277.       if (sa & FFESYMBOL_attrsTYPE)
  16278.     na = FFESYMBOL_attrsetNONE;
  16279.       else
  16280.     kind = FFEINFO_kindSUBROUTINE;
  16281.     }
  16282.   else if (sa & FFESYMBOL_attrsARRAY)
  16283.     {
  16284.       assert (!(sa & ~(FFESYMBOL_attrsARRAY
  16285.                | FFESYMBOL_attrsTYPE)));
  16286.  
  16287.       na = FFESYMBOL_attrsetNONE;
  16288.     }
  16289.   else if (sa & FFESYMBOL_attrsSFARG)
  16290.     {
  16291.       assert (!(sa & ~(FFESYMBOL_attrsSFARG
  16292.                | FFESYMBOL_attrsTYPE)));
  16293.  
  16294.       na = FFESYMBOL_attrsetNONE;
  16295.     }
  16296.   else if (sa & FFESYMBOL_attrsTYPE)
  16297.     {
  16298.       assert (!(sa & (FFESYMBOL_attrsARRAY
  16299.               | FFESYMBOL_attrsDUMMY
  16300.               | FFESYMBOL_attrsEXTERNAL
  16301.               | FFESYMBOL_attrsSFARG)));    /* Handled above. */
  16302.       assert (!(sa & ~(FFESYMBOL_attrsANYLEN
  16303.                | FFESYMBOL_attrsARRAY
  16304.                | FFESYMBOL_attrsDUMMY
  16305.                | FFESYMBOL_attrsEXTERNAL
  16306.                | FFESYMBOL_attrsSFARG
  16307.                | FFESYMBOL_attrsTYPE)));
  16308.  
  16309.       na = FFESYMBOL_attrsetNONE;
  16310.     }
  16311.   else if (sa == FFESYMBOL_attrsetNONE)
  16312.     {
  16313.       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
  16314.  
  16315.       if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
  16316.                   &gen, &spec, &imp, &kind))
  16317.     {
  16318.       ffesymbol_signal_change (s);    /* May need to back up to previous
  16319.                        version. */
  16320.       ffesymbol_set_generic (s, gen);
  16321.       ffesymbol_set_specific (s, spec);
  16322.       ffesymbol_set_implementation (s, imp);
  16323.       ffesymbol_set_info (s,
  16324.                   ffeinfo_new (FFEINFO_basictypeNONE,
  16325.                        FFEINFO_kindtypeNONE,
  16326.                        0,
  16327.                        kind,
  16328.                        FFEINFO_whereINTRINSIC,
  16329.                        FFETARGET_charactersizeNONE));
  16330.       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
  16331.       ffesymbol_resolve_intrin (s);
  16332.       s = ffecom_sym_learned (s);
  16333.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  16334.  
  16335.       return s;
  16336.     }
  16337.  
  16338.       kind = FFEINFO_kindSUBROUTINE;
  16339.       where = FFEINFO_whereGLOBAL;
  16340.       na = FFESYMBOL_attrsACTUALARG;    /* Just not NONE nor ANY. */
  16341.     }
  16342.   else
  16343.     na = FFESYMBOL_attrsetNONE;    /* Error. */
  16344.  
  16345.   /* Now see what we've got for a new object: NONE means a new error cropped
  16346.      up; ANY means an old error to be ignored; otherwise, everything's ok,
  16347.      update the object (symbol) and continue on. */
  16348.  
  16349.   if (na == FFESYMBOL_attrsetNONE)
  16350.     ffesymbol_error (s, t);
  16351.   else if (!(na & FFESYMBOL_attrsANY))
  16352.     {
  16353.       ffesymbol_signal_change (s);    /* May need to back up to previous
  16354.                        version. */
  16355.       ffesymbol_set_info (s,
  16356.               ffeinfo_new (ffesymbol_basictype (s),
  16357.                        ffesymbol_kindtype (s),
  16358.                        ffesymbol_rank (s),
  16359.                        kind,    /* SUBROUTINE. */
  16360.                        where,    /* GLOBAL or DUMMY. */
  16361.                        ffesymbol_size (s)));
  16362.       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
  16363.       ffesymbol_resolve_intrin (s);
  16364.       s = ffecom_sym_learned (s);
  16365.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  16366.     }
  16367.  
  16368.   return s;
  16369. }
  16370.  
  16371. /* Have FOO in DATA FOO/.../.  Local name space and executable context
  16372.    only.  (This will change in the future when DATA FOO may be followed
  16373.    by COMMON FOO or even INTEGER FOO(10), etc.)  */
  16374.  
  16375. static ffesymbol
  16376. ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
  16377. {
  16378.   ffesymbolAttrs sa;
  16379.   ffesymbolAttrs na;
  16380.   ffeinfoKind kind;
  16381.   ffeinfoWhere where;
  16382.  
  16383.   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
  16384.       || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
  16385.  
  16386.   na = sa = ffesymbol_attrs (s);
  16387.  
  16388.   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
  16389.            | FFESYMBOL_attrsANYLEN
  16390.            | FFESYMBOL_attrsARRAY
  16391.            | FFESYMBOL_attrsDUMMY
  16392.            | FFESYMBOL_attrsEXTERNAL
  16393.            | FFESYMBOL_attrsSFARG
  16394.            | FFESYMBOL_attrsTYPE)));
  16395.  
  16396.   kind = ffesymbol_kind (s);
  16397.   where = ffesymbol_where (s);
  16398.  
  16399.   /* Figure out what kind of object we've got based on previous declarations
  16400.      of or references to the object. */
  16401.  
  16402.   if (sa & FFESYMBOL_attrsEXTERNAL)
  16403.     {
  16404.       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
  16405.                | FFESYMBOL_attrsDUMMY
  16406.                | FFESYMBOL_attrsEXTERNAL
  16407.                | FFESYMBOL_attrsTYPE)));
  16408.  
  16409.       na = FFESYMBOL_attrsetNONE;
  16410.     }
  16411.   else if (sa & FFESYMBOL_attrsDUMMY)
  16412.     {
  16413.       assert (!(sa & FFESYMBOL_attrsEXTERNAL));    /* Handled above. */
  16414.       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
  16415.                | FFESYMBOL_attrsEXTERNAL
  16416.                | FFESYMBOL_attrsTYPE)));
  16417.  
  16418.       na = FFESYMBOL_attrsetNONE;
  16419.     }
  16420.   else if (sa & FFESYMBOL_attrsARRAY)
  16421.     {
  16422.       assert (!(sa & ~(FFESYMBOL_attrsARRAY
  16423.                | FFESYMBOL_attrsTYPE)));
  16424.  
  16425.       where = FFEINFO_whereLOCAL;
  16426.     }
  16427.   else if (sa & FFESYMBOL_attrsSFARG)
  16428.     {
  16429.       assert (!(sa & ~(FFESYMBOL_attrsSFARG
  16430.                | FFESYMBOL_attrsTYPE)));
  16431.  
  16432.       where = FFEINFO_whereLOCAL;
  16433.     }
  16434.   else if (sa & FFESYMBOL_attrsTYPE)
  16435.     {
  16436.       assert (!(sa & (FFESYMBOL_attrsARRAY
  16437.               | FFESYMBOL_attrsDUMMY
  16438.               | FFESYMBOL_attrsEXTERNAL
  16439.               | FFESYMBOL_attrsSFARG)));    /* Handled above. */
  16440.       assert (!(sa & ~(FFESYMBOL_attrsANYLEN
  16441.                | FFESYMBOL_attrsARRAY
  16442.                | FFESYMBOL_attrsDUMMY
  16443.                | FFESYMBOL_attrsEXTERNAL
  16444.                | FFESYMBOL_attrsSFARG
  16445.                | FFESYMBOL_attrsTYPE)));
  16446.  
  16447.       if (sa & FFESYMBOL_attrsANYLEN)
  16448.     na = FFESYMBOL_attrsetNONE;
  16449.       else
  16450.     {
  16451.       kind = FFEINFO_kindENTITY;
  16452.       where = FFEINFO_whereLOCAL;
  16453.     }
  16454.     }
  16455.   else if (sa == FFESYMBOL_attrsetNONE)
  16456.     {
  16457.       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
  16458.       kind = FFEINFO_kindENTITY;
  16459.       where = FFEINFO_whereLOCAL;
  16460.       na = FFESYMBOL_attrsSAVE;    /* Just not NONE nor ANY. */
  16461.     }
  16462.   else
  16463.     na = FFESYMBOL_attrsetNONE;    /* Error. */
  16464.  
  16465.   /* Now see what we've got for a new object: NONE means a new error cropped
  16466.      up; ANY means an old error to be ignored; otherwise, everything's ok,
  16467.      update the object (symbol) and continue on. */
  16468.  
  16469.   if (na == FFESYMBOL_attrsetNONE)
  16470.     ffesymbol_error (s, t);
  16471.   else if (!(na & FFESYMBOL_attrsANY))
  16472.     {
  16473.       ffesymbol_signal_change (s);    /* May need to back up to previous
  16474.                        version. */
  16475.       if (!ffeimplic_establish_symbol (s))
  16476.     {
  16477.       ffesymbol_error (s, t);
  16478.       return s;
  16479.     }
  16480.       ffesymbol_set_info (s,
  16481.               ffeinfo_new (ffesymbol_basictype (s),
  16482.                        ffesymbol_kindtype (s),
  16483.                        ffesymbol_rank (s),
  16484.                        kind,    /* ENTITY. */
  16485.                        where,    /* LOCAL. */
  16486.                        ffesymbol_size (s)));
  16487.       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
  16488.       ffesymbol_resolve_intrin (s);
  16489.       s = ffecom_sym_learned (s);
  16490.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  16491.     }
  16492.  
  16493.   return s;
  16494. }
  16495.  
  16496. /* Have FOO in EQUIVALENCE (...,FOO,...).  Does not include
  16497.    EQUIVALENCE (...,BAR(FOO),...).  */
  16498.  
  16499. static ffesymbol
  16500. ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
  16501. {
  16502.   ffesymbolAttrs sa;
  16503.   ffesymbolAttrs na;
  16504.   ffeinfoKind kind;
  16505.   ffeinfoWhere where;
  16506.  
  16507.   na = sa = ffesymbol_attrs (s);
  16508.   kind = FFEINFO_kindENTITY;
  16509.   where = ffesymbol_where (s);
  16510.  
  16511.   /* Figure out what kind of object we've got based on previous declarations
  16512.      of or references to the object. */
  16513.  
  16514.   if (!(sa & ~(FFESYMBOL_attrsADJUSTS
  16515.            | FFESYMBOL_attrsARRAY
  16516.            | FFESYMBOL_attrsCOMMON
  16517.            | FFESYMBOL_attrsEQUIV
  16518.            | FFESYMBOL_attrsINIT
  16519.            | FFESYMBOL_attrsNAMELIST
  16520.            | FFESYMBOL_attrsSAVE
  16521.            | FFESYMBOL_attrsSFARG
  16522.            | FFESYMBOL_attrsTYPE)))
  16523.     na = sa | FFESYMBOL_attrsEQUIV;
  16524.   else
  16525.     na = FFESYMBOL_attrsetNONE;
  16526.  
  16527.   /* Don't know why we're bothering to set kind and where in this code, but
  16528.      added the following to make it complete, in case it's really important.
  16529.      Generally this is left up to symbol exec transition.  */
  16530.  
  16531.   if (where == FFEINFO_whereNONE)
  16532.     {
  16533.       if (na & (FFESYMBOL_attrsADJUSTS
  16534.         | FFESYMBOL_attrsCOMMON))
  16535.     where = FFEINFO_whereCOMMON;
  16536.       else if (na & FFESYMBOL_attrsSAVE)
  16537.     where = FFEINFO_whereLOCAL;
  16538.     }
  16539.  
  16540.   /* Now see what we've got for a new object: NONE means a new error cropped
  16541.      up; ANY means an old error to be ignored; otherwise, everything's ok,
  16542.      update the object (symbol) and continue on. */
  16543.  
  16544.   if (na == FFESYMBOL_attrsetNONE)
  16545.     ffesymbol_error (s, t);
  16546.   else if (!(na & FFESYMBOL_attrsANY))
  16547.     {
  16548.       ffesymbol_signal_change (s);    /* May need to back up to previous
  16549.                        version. */
  16550.       ffesymbol_set_info (s,
  16551.               ffeinfo_new (ffesymbol_basictype (s),
  16552.                        ffesymbol_kindtype (s),
  16553.                        ffesymbol_rank (s),
  16554.                        kind,    /* Always ENTITY. */
  16555.                        where,    /* NONE, COMMON, or LOCAL. */
  16556.                        ffesymbol_size (s)));
  16557.       ffesymbol_set_attrs (s, na);
  16558.       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
  16559.       ffesymbol_resolve_intrin (s);
  16560.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  16561.     }
  16562.  
  16563.   return s;
  16564. }
  16565.  
  16566. /* Have FOO in OPEN(...,USEROPEN=FOO,...).  Executable context only.
  16567.  
  16568.    Note that I think this should be considered semantically similar to
  16569.    doing CALL XYZ(FOO), in that it should be considered like an
  16570.    ACTUALARG context.  In particular, without EXTERNAL being specified,
  16571.    it should not be allowed.  */
  16572.  
  16573. static ffesymbol
  16574. ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
  16575. {
  16576.   ffesymbolAttrs sa;
  16577.   ffesymbolAttrs na;
  16578.   ffeinfoKind kind;
  16579.   ffeinfoWhere where;
  16580.   bool needs_type = FALSE;
  16581.  
  16582.   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
  16583.       || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
  16584.  
  16585.   na = sa = ffesymbol_attrs (s);
  16586.  
  16587.   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
  16588.            | FFESYMBOL_attrsANYLEN
  16589.            | FFESYMBOL_attrsARRAY
  16590.            | FFESYMBOL_attrsDUMMY
  16591.            | FFESYMBOL_attrsEXTERNAL
  16592.            | FFESYMBOL_attrsSFARG
  16593.            | FFESYMBOL_attrsTYPE)));
  16594.  
  16595.   kind = ffesymbol_kind (s);
  16596.   where = ffesymbol_where (s);
  16597.  
  16598.   /* Figure out what kind of object we've got based on previous declarations
  16599.      of or references to the object. */
  16600.  
  16601.   if (sa & FFESYMBOL_attrsEXTERNAL)
  16602.     {
  16603.       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
  16604.                | FFESYMBOL_attrsDUMMY
  16605.                | FFESYMBOL_attrsEXTERNAL
  16606.                | FFESYMBOL_attrsTYPE)));
  16607.  
  16608.       if (sa & FFESYMBOL_attrsTYPE)
  16609.     where = FFEINFO_whereGLOBAL;
  16610.       else
  16611.     /* Not TYPE. */
  16612.     {
  16613.       kind = FFEINFO_kindFUNCTION;
  16614.       needs_type = TRUE;
  16615.  
  16616.       if (sa & FFESYMBOL_attrsDUMMY)
  16617.         ;            /* Not TYPE. */
  16618.       else if (sa & FFESYMBOL_attrsACTUALARG)
  16619.         ;            /* Not DUMMY or TYPE. */
  16620.       else            /* Not ACTUALARG, DUMMY, or TYPE. */
  16621.         where = FFEINFO_whereGLOBAL;
  16622.     }
  16623.     }
  16624.   else if (sa & FFESYMBOL_attrsDUMMY)
  16625.     {
  16626.       assert (!(sa & FFESYMBOL_attrsEXTERNAL));    /* Handled above. */
  16627.       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
  16628.                | FFESYMBOL_attrsEXTERNAL
  16629.                | FFESYMBOL_attrsTYPE)));
  16630.  
  16631.       kind = FFEINFO_kindFUNCTION;
  16632.       if (!(sa & FFESYMBOL_attrsTYPE))
  16633.     needs_type = TRUE;
  16634.     }
  16635.   else if (sa & FFESYMBOL_attrsARRAY)
  16636.     {
  16637.       assert (!(sa & ~(FFESYMBOL_attrsARRAY
  16638.                | FFESYMBOL_attrsTYPE)));
  16639.  
  16640.       na = FFESYMBOL_attrsetNONE;
  16641.     }
  16642.   else if (sa & FFESYMBOL_attrsSFARG)
  16643.     {
  16644.       assert (!(sa & ~(FFESYMBOL_attrsSFARG
  16645.                | FFESYMBOL_attrsTYPE)));
  16646.  
  16647.       na = FFESYMBOL_attrsetNONE;
  16648.     }
  16649.   else if (sa & FFESYMBOL_attrsTYPE)
  16650.     {
  16651.       assert (!(sa & (FFESYMBOL_attrsARRAY
  16652.               | FFESYMBOL_attrsDUMMY
  16653.               | FFESYMBOL_attrsEXTERNAL
  16654.               | FFESYMBOL_attrsSFARG)));    /* Handled above. */
  16655.       assert (!(sa & ~(FFESYMBOL_attrsANYLEN
  16656.                | FFESYMBOL_attrsARRAY
  16657.                | FFESYMBOL_attrsDUMMY
  16658.                | FFESYMBOL_attrsEXTERNAL
  16659.                | FFESYMBOL_attrsSFARG
  16660.                | FFESYMBOL_attrsTYPE)));
  16661.  
  16662.       if (sa & FFESYMBOL_attrsANYLEN)
  16663.     na = FFESYMBOL_attrsetNONE;
  16664.       else
  16665.     {
  16666.       kind = FFEINFO_kindFUNCTION;
  16667.       where = FFEINFO_whereGLOBAL;
  16668.     }
  16669.     }
  16670.   else if (sa == FFESYMBOL_attrsetNONE)
  16671.     {
  16672.       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
  16673.       kind = FFEINFO_kindFUNCTION;
  16674.       where = FFEINFO_whereGLOBAL;
  16675.       needs_type = TRUE;
  16676.       na = FFESYMBOL_attrsACTUALARG;    /* Just not NONE nor ANY. */
  16677.     }
  16678.   else
  16679.     na = FFESYMBOL_attrsetNONE;    /* Error. */
  16680.  
  16681.   /* Now see what we've got for a new object: NONE means a new error cropped
  16682.      up; ANY means an old error to be ignored; otherwise, everything's ok,
  16683.      update the object (symbol) and continue on. */
  16684.  
  16685.   if (na == FFESYMBOL_attrsetNONE)
  16686.     ffesymbol_error (s, t);
  16687.   else if (!(na & FFESYMBOL_attrsANY))
  16688.     {
  16689.       ffesymbol_signal_change (s);    /* May need to back up to previous
  16690.                        version. */
  16691.       if (needs_type && !ffeimplic_establish_symbol (s))
  16692.     {
  16693.       ffesymbol_error (s, t);
  16694.       return s;
  16695.     }
  16696.       if (!ffesymbol_explicitwhere (s))
  16697.     {
  16698.       ffebad_start (FFEBAD_NEED_EXTERNAL);
  16699.       ffebad_here (0, ffelex_token_where_line (t),
  16700.                ffelex_token_where_column (t));
  16701.       ffebad_string (ffesymbol_text (s));
  16702.       ffebad_finish ();
  16703.       ffesymbol_set_explicitwhere (s, TRUE);
  16704.     }
  16705.       ffesymbol_set_info (s,
  16706.               ffeinfo_new (ffesymbol_basictype (s),
  16707.                        ffesymbol_kindtype (s),
  16708.                        ffesymbol_rank (s),
  16709.                        kind,    /* FUNCTION. */
  16710.                        where,    /* GLOBAL or DUMMY. */
  16711.                        ffesymbol_size (s)));
  16712.       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
  16713.       ffesymbol_resolve_intrin (s);
  16714.       s = ffecom_sym_learned (s);
  16715.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  16716.     }
  16717.  
  16718.   return s;
  16719. }
  16720.  
  16721. /* Have FOO in DATA (stuff,FOO=1,10)/.../.  */
  16722.  
  16723. static ffesymbol
  16724. ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
  16725. {
  16726.   ffesymbolState ss;
  16727.  
  16728.   /* If the symbol isn't in the sfunc name space, pretend as though we saw a
  16729.      reference to it already within the imp-DO construct at this level, so as
  16730.      to get a symbol that is in the sfunc name space. But this is an
  16731.      erroneous construct, and should be caught elsewhere.  */
  16732.  
  16733.   if (ffesymbol_sfdummyparent (s) == NULL)
  16734.     {
  16735.       s = ffeexpr_sym_impdoitem_ (s, t);
  16736.       if (ffesymbol_sfdummyparent (s) == NULL)
  16737.     {            /* PARAMETER FOO...DATA (A(I),FOO=...). */
  16738.       ffesymbol_error (s, t);
  16739.       return s;
  16740.     }
  16741.     }
  16742.  
  16743.   ss = ffesymbol_state (s);
  16744.  
  16745.   switch (ss)
  16746.     {
  16747.     case FFESYMBOL_stateNONE:    /* Used as iterator already. */
  16748.       if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
  16749.     ffesymbol_error (s, t);    /* Can't reuse dead iterator.  F90 disallows
  16750.                    this; F77 allows it but it is a stupid
  16751.                    feature. */
  16752.       else
  16753.     {            /* Can use dead iterator because we're at at
  16754.                    least a innermore (higher-numbered) level
  16755.                    than the iterator's outermost
  16756.                    (lowest-numbered) level.  This should be
  16757.                    diagnosed later, because it means an item
  16758.                    in this list didn't reference this
  16759.                    iterator. */
  16760. #if 1
  16761.       ffesymbol_error (s, t);    /* For now, complain. */
  16762. #else /* Someday will detect all cases where initializer doesn't reference
  16763.          all applicable iterators, in which case reenable this code. */
  16764.       ffesymbol_signal_change (s);
  16765.       ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
  16766.       ffesymbol_set_maxentrynum (s, ffeexpr_level_);
  16767.       ffesymbol_signal_unreported (s);
  16768. #endif
  16769.     }
  16770.       break;
  16771.  
  16772.     case FFESYMBOL_stateSEEN:    /* Seen already in this or other implied-DO.
  16773.                    If seen in outermore level, can't be an
  16774.                    iterator here, so complain.  If not seen
  16775.                    at current level, complain for now,
  16776.                    because that indicates something F90
  16777.                    rejects (though we currently don't detect
  16778.                    all such cases for now). */
  16779.       if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
  16780.     {
  16781.       ffesymbol_signal_change (s);
  16782.       ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
  16783.       ffesymbol_signal_unreported (s);
  16784.     }
  16785.       else
  16786.     ffesymbol_error (s, t);
  16787.       break;
  16788.  
  16789.     case FFESYMBOL_stateUNCERTAIN:    /* Already iterator! */
  16790.       assert ("DATA implied-DO control var seen twice!!" == NULL);
  16791.       ffesymbol_error (s, t);
  16792.       break;
  16793.  
  16794.     case FFESYMBOL_stateUNDERSTOOD:
  16795.       break;            /* ANY. */
  16796.  
  16797.     default:
  16798.       assert ("Foo Bletch!!" == NULL);
  16799.       break;
  16800.     }
  16801.  
  16802.   return s;
  16803. }
  16804.  
  16805. /* Have FOO in PARAMETER (FOO=...).  */
  16806.  
  16807. static ffesymbol
  16808. ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
  16809. {
  16810.   ffesymbolAttrs sa;
  16811.  
  16812.   sa = ffesymbol_attrs (s);
  16813.  
  16814.   /* Figure out what kind of object we've got based on previous declarations
  16815.      of or references to the object. */
  16816.  
  16817.   if (sa & ~(FFESYMBOL_attrsANYLEN
  16818.          | FFESYMBOL_attrsTYPE))
  16819.     {
  16820.       if (!(sa & FFESYMBOL_attrsANY))
  16821.     ffesymbol_error (s, t);
  16822.     }
  16823.   else
  16824.     {
  16825.       ffesymbol_signal_change (s);    /* May need to back up to previous
  16826.                        version. */
  16827.       if (!ffeimplic_establish_symbol (s))
  16828.     {
  16829.       ffesymbol_error (s, t);
  16830.       return s;
  16831.     }
  16832.       ffesymbol_set_info (s,
  16833.               ffeinfo_new (ffesymbol_basictype (s),
  16834.                        ffesymbol_kindtype (s),
  16835.                        ffesymbol_rank (s),
  16836.                        FFEINFO_kindENTITY,
  16837.                        FFEINFO_whereCONSTANT,
  16838.                        ffesymbol_size (s)));
  16839.       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
  16840.       ffesymbol_resolve_intrin (s);
  16841.       s = ffecom_sym_learned (s);
  16842.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  16843.     }
  16844.  
  16845.   return s;
  16846. }
  16847.  
  16848. /* Have FOO in CALL XYZ(...,FOO,...).  Does not include any other
  16849.    embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1).  */
  16850.  
  16851. static ffesymbol
  16852. ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
  16853. {
  16854.   ffesymbolAttrs sa;
  16855.   ffesymbolAttrs na;
  16856.   ffeinfoKind kind;
  16857.   ffeinfoWhere where;
  16858.   ffesymbolState ns;
  16859.   bool needs_type = FALSE;
  16860.  
  16861.   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
  16862.       || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
  16863.  
  16864.   na = sa = ffesymbol_attrs (s);
  16865.  
  16866.   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
  16867.            | FFESYMBOL_attrsANYLEN
  16868.            | FFESYMBOL_attrsARRAY
  16869.            | FFESYMBOL_attrsDUMMY
  16870.            | FFESYMBOL_attrsEXTERNAL
  16871.            | FFESYMBOL_attrsSFARG
  16872.            | FFESYMBOL_attrsTYPE)));
  16873.  
  16874.   kind = ffesymbol_kind (s);
  16875.   where = ffesymbol_where (s);
  16876.  
  16877.   /* Figure out what kind of object we've got based on previous declarations
  16878.      of or references to the object. */
  16879.  
  16880.   ns = FFESYMBOL_stateUNDERSTOOD;
  16881.  
  16882.   if (sa & FFESYMBOL_attrsEXTERNAL)
  16883.     {
  16884.       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
  16885.                | FFESYMBOL_attrsDUMMY
  16886.                | FFESYMBOL_attrsEXTERNAL
  16887.                | FFESYMBOL_attrsTYPE)));
  16888.  
  16889.       if (sa & FFESYMBOL_attrsTYPE)
  16890.     where = FFEINFO_whereGLOBAL;
  16891.       else
  16892.     /* Not TYPE. */
  16893.     {
  16894.       ns = FFESYMBOL_stateUNCERTAIN;
  16895.  
  16896.       if (sa & FFESYMBOL_attrsDUMMY)
  16897.         assert (kind == FFEINFO_kindNONE);    /* FUNCTION, SUBROUTINE. */
  16898.       else if (sa & FFESYMBOL_attrsACTUALARG)
  16899.         ;            /* Not DUMMY or TYPE. */
  16900.       else
  16901.         /* Not ACTUALARG, DUMMY, or TYPE. */
  16902.         {
  16903.           assert (kind == FFEINFO_kindNONE);    /* FUNCTION, SUBROUTINE. */
  16904.           na |= FFESYMBOL_attrsACTUALARG;
  16905.           where = FFEINFO_whereGLOBAL;
  16906.         }
  16907.     }
  16908.     }
  16909.   else if (sa & FFESYMBOL_attrsDUMMY)
  16910.     {
  16911.       assert (!(sa & FFESYMBOL_attrsEXTERNAL));    /* Handled above. */
  16912.       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
  16913.                | FFESYMBOL_attrsEXTERNAL
  16914.                | FFESYMBOL_attrsTYPE)));
  16915.  
  16916.       kind = FFEINFO_kindENTITY;
  16917.       if (!(sa & FFESYMBOL_attrsTYPE))
  16918.     needs_type = TRUE;
  16919.     }
  16920.   else if (sa & FFESYMBOL_attrsARRAY)
  16921.     {
  16922.       assert (!(sa & ~(FFESYMBOL_attrsARRAY
  16923.                | FFESYMBOL_attrsTYPE)));
  16924.  
  16925.       where = FFEINFO_whereLOCAL;
  16926.     }
  16927.   else if (sa & FFESYMBOL_attrsSFARG)
  16928.     {
  16929.       assert (!(sa & ~(FFESYMBOL_attrsSFARG
  16930.                | FFESYMBOL_attrsTYPE)));
  16931.  
  16932.       where = FFEINFO_whereLOCAL;
  16933.     }
  16934.   else if (sa & FFESYMBOL_attrsTYPE)
  16935.     {
  16936.       assert (!(sa & (FFESYMBOL_attrsARRAY
  16937.               | FFESYMBOL_attrsDUMMY
  16938.               | FFESYMBOL_attrsEXTERNAL
  16939.               | FFESYMBOL_attrsSFARG)));    /* Handled above. */
  16940.       assert (!(sa & ~(FFESYMBOL_attrsANYLEN
  16941.                | FFESYMBOL_attrsARRAY
  16942.                | FFESYMBOL_attrsDUMMY
  16943.                | FFESYMBOL_attrsEXTERNAL
  16944.                | FFESYMBOL_attrsSFARG
  16945.                | FFESYMBOL_attrsTYPE)));
  16946.  
  16947.       if (sa & FFESYMBOL_attrsANYLEN)
  16948.     na = FFESYMBOL_attrsetNONE;
  16949.       else
  16950.     {
  16951.       kind = FFEINFO_kindENTITY;
  16952.       where = FFEINFO_whereLOCAL;
  16953.     }
  16954.     }
  16955.   else if (sa == FFESYMBOL_attrsetNONE)
  16956.     {
  16957.       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
  16958.       kind = FFEINFO_kindENTITY;
  16959.       where = FFEINFO_whereLOCAL;
  16960.       na = FFESYMBOL_attrsACTUALARG;    /* Just not NONE nor ANY. */
  16961.       needs_type = TRUE;
  16962.     }
  16963.   else
  16964.     na = FFESYMBOL_attrsetNONE;    /* Error. */
  16965.  
  16966.   /* Now see what we've got for a new object: NONE means a new error cropped
  16967.      up; ANY means an old error to be ignored; otherwise, everything's ok,
  16968.      update the object (symbol) and continue on. */
  16969.  
  16970.   if (na == FFESYMBOL_attrsetNONE)
  16971.     ffesymbol_error (s, t);
  16972.   else if (!(na & FFESYMBOL_attrsANY))
  16973.     {
  16974.       ffesymbol_signal_change (s);    /* May need to back up to previous
  16975.                        version. */
  16976.       if (needs_type && !ffeimplic_establish_symbol (s))
  16977.     {
  16978.       ffesymbol_error (s, t);
  16979.       return s;
  16980.     }
  16981.       ffesymbol_set_info (s,
  16982.               ffeinfo_new (ffesymbol_basictype (s),
  16983.                        ffesymbol_kindtype (s),
  16984.                        ffesymbol_rank (s),
  16985.                        kind,
  16986.                        where,
  16987.                        ffesymbol_size (s)));
  16988.       ffesymbol_set_attrs (s, na);
  16989.       ffesymbol_set_state (s, ns);
  16990.       s = ffecom_sym_learned (s);
  16991.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  16992.     }
  16993.  
  16994.   return s;
  16995. }
  16996.  
  16997. /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
  16998.    a reference to FOO.  */
  16999.  
  17000. static ffesymbol
  17001. ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
  17002. {
  17003.   ffesymbolAttrs sa;
  17004.   ffesymbolAttrs na;
  17005.   ffeinfoKind kind;
  17006.   ffeinfoWhere where;
  17007.  
  17008.   na = sa = ffesymbol_attrs (s);
  17009.   kind = FFEINFO_kindENTITY;
  17010.   where = ffesymbol_where (s);
  17011.  
  17012.   /* Figure out what kind of object we've got based on previous declarations
  17013.      of or references to the object. */
  17014.  
  17015.   if (!(sa & ~(FFESYMBOL_attrsADJUSTS
  17016.            | FFESYMBOL_attrsCOMMON
  17017.            | FFESYMBOL_attrsDUMMY
  17018.            | FFESYMBOL_attrsEQUIV
  17019.            | FFESYMBOL_attrsINIT
  17020.            | FFESYMBOL_attrsNAMELIST
  17021.            | FFESYMBOL_attrsSFARG
  17022.            | FFESYMBOL_attrsTYPE)))
  17023.     na = sa | FFESYMBOL_attrsADJUSTS;
  17024.   else
  17025.     na = FFESYMBOL_attrsetNONE;
  17026.  
  17027.   /* Since this symbol definitely is going into an expression (the
  17028.      dimension-list for some dummy array, presumably), figure out WHERE if
  17029.      possible.  */
  17030.  
  17031.   if (where == FFEINFO_whereNONE)
  17032.     {
  17033.       if (na & (FFESYMBOL_attrsCOMMON
  17034.         | FFESYMBOL_attrsEQUIV
  17035.         | FFESYMBOL_attrsINIT
  17036.         | FFESYMBOL_attrsNAMELIST))
  17037.     where = FFEINFO_whereCOMMON;
  17038.       else if (na & FFESYMBOL_attrsDUMMY)
  17039.     where = FFEINFO_whereDUMMY;
  17040.     }
  17041.  
  17042.   /* Now see what we've got for a new object: NONE means a new error cropped
  17043.      up; ANY means an old error to be ignored; otherwise, everything's ok,
  17044.      update the object (symbol) and continue on. */
  17045.  
  17046.   if (na == FFESYMBOL_attrsetNONE)
  17047.     ffesymbol_error (s, t);
  17048.   else if (!(na & FFESYMBOL_attrsANY))
  17049.     {
  17050.       ffesymbol_signal_change (s);    /* May need to back up to previous
  17051.                        version. */
  17052.       if (!ffeimplic_establish_symbol (s))
  17053.     {
  17054.       ffesymbol_error (s, t);
  17055.       return s;
  17056.     }
  17057.       ffesymbol_set_info (s,
  17058.               ffeinfo_new (ffesymbol_basictype (s),
  17059.                        ffesymbol_kindtype (s),
  17060.                        ffesymbol_rank (s),
  17061.                        kind,    /* Always ENTITY. */
  17062.                        where,    /* NONE, COMMON, or DUMMY. */
  17063.                        ffesymbol_size (s)));
  17064.       ffesymbol_set_attrs (s, na);
  17065.       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
  17066.       ffesymbol_resolve_intrin (s);
  17067.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  17068.     }
  17069.  
  17070.   return s;
  17071. }
  17072.  
  17073. /* Have FOO in XYZ = ...FOO....  Does not include cases like FOO in
  17074.    XYZ = BAR(FOO), as such cases are handled elsewhere.  */
  17075.  
  17076. static ffesymbol
  17077. ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
  17078. {
  17079.   ffesymbolAttrs sa;
  17080.   ffesymbolAttrs na;
  17081.   ffeinfoKind kind;
  17082.   ffeinfoWhere where;
  17083.  
  17084.   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
  17085.       || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
  17086.  
  17087.   na = sa = ffesymbol_attrs (s);
  17088.  
  17089.   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
  17090.            | FFESYMBOL_attrsANYLEN
  17091.            | FFESYMBOL_attrsARRAY
  17092.            | FFESYMBOL_attrsDUMMY
  17093.            | FFESYMBOL_attrsEXTERNAL
  17094.            | FFESYMBOL_attrsSFARG
  17095.            | FFESYMBOL_attrsTYPE)));
  17096.  
  17097.   kind = ffesymbol_kind (s);
  17098.   where = ffesymbol_where (s);
  17099.  
  17100.   /* Figure out what kind of object we've got based on previous declarations
  17101.      of or references to the object. */
  17102.  
  17103.   if (sa & FFESYMBOL_attrsEXTERNAL)
  17104.     {
  17105.       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
  17106.                | FFESYMBOL_attrsDUMMY
  17107.                | FFESYMBOL_attrsEXTERNAL
  17108.                | FFESYMBOL_attrsTYPE)));
  17109.  
  17110.       na = FFESYMBOL_attrsetNONE;
  17111.     }
  17112.   else if (sa & FFESYMBOL_attrsDUMMY)
  17113.     {
  17114.       assert (!(sa & FFESYMBOL_attrsEXTERNAL));    /* Handled above. */
  17115.       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
  17116.                | FFESYMBOL_attrsEXTERNAL
  17117.                | FFESYMBOL_attrsTYPE)));
  17118.  
  17119.       kind = FFEINFO_kindENTITY;
  17120.     }
  17121.   else if (sa & FFESYMBOL_attrsARRAY)
  17122.     {
  17123.       assert (!(sa & ~(FFESYMBOL_attrsARRAY
  17124.                | FFESYMBOL_attrsTYPE)));
  17125.  
  17126.       where = FFEINFO_whereLOCAL;    /* Actually an error, but at least we
  17127.                        know it's a local array, and since
  17128.                        this is the only difference wrt
  17129.                        _paren_lhs_let_, this function
  17130.                        does that too. */
  17131.     }
  17132.   else if (sa & FFESYMBOL_attrsSFARG)
  17133.     {
  17134.       assert (!(sa & ~(FFESYMBOL_attrsSFARG
  17135.                | FFESYMBOL_attrsTYPE)));
  17136.  
  17137.       where = FFEINFO_whereLOCAL;
  17138.     }
  17139.   else if (sa & FFESYMBOL_attrsTYPE)
  17140.     {
  17141.       assert (!(sa & (FFESYMBOL_attrsARRAY
  17142.               | FFESYMBOL_attrsDUMMY
  17143.               | FFESYMBOL_attrsEXTERNAL
  17144.               | FFESYMBOL_attrsSFARG)));    /* Handled above. */
  17145.       assert (!(sa & ~(FFESYMBOL_attrsANYLEN
  17146.                | FFESYMBOL_attrsARRAY
  17147.                | FFESYMBOL_attrsDUMMY
  17148.                | FFESYMBOL_attrsEXTERNAL
  17149.                | FFESYMBOL_attrsSFARG
  17150.                | FFESYMBOL_attrsTYPE)));
  17151.  
  17152.       if (sa & FFESYMBOL_attrsANYLEN)
  17153.     na = FFESYMBOL_attrsetNONE;
  17154.       else
  17155.     {
  17156.       kind = FFEINFO_kindENTITY;
  17157.       where = FFEINFO_whereLOCAL;
  17158.     }
  17159.     }
  17160.   else if (sa == FFESYMBOL_attrsetNONE)
  17161.     {
  17162.       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
  17163.       kind = FFEINFO_kindENTITY;
  17164.       where = FFEINFO_whereLOCAL;
  17165.       na = FFESYMBOL_attrsTYPE;    /* Just not NONE nor ANY. */
  17166.     }
  17167.   else
  17168.     na = FFESYMBOL_attrsetNONE;    /* Error. */
  17169.  
  17170.   /* Now see what we've got for a new object: NONE means a new error cropped
  17171.      up; ANY means an old error to be ignored; otherwise, everything's ok,
  17172.      update the object (symbol) and continue on. */
  17173.  
  17174.   if (na == FFESYMBOL_attrsetNONE)
  17175.     ffesymbol_error (s, t);
  17176.   else if (!(na & FFESYMBOL_attrsANY))
  17177.     {
  17178.       ffesymbol_signal_change (s);    /* May need to back up to previous
  17179.                        version. */
  17180.       if (!ffeimplic_establish_symbol (s))
  17181.     {
  17182.       ffesymbol_error (s, t);
  17183.       return s;
  17184.     }
  17185.       ffesymbol_set_info (s,
  17186.               ffeinfo_new (ffesymbol_basictype (s),
  17187.                        ffesymbol_kindtype (s),
  17188.                        ffesymbol_rank (s),
  17189.                        kind,    /* ENTITY. */
  17190.                        where,    /* LOCAL. */
  17191.                        ffesymbol_size (s)));
  17192.       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
  17193.       ffesymbol_resolve_intrin (s);
  17194.       s = ffecom_sym_learned (s);
  17195.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  17196.     }
  17197.  
  17198.   return s;
  17199. }
  17200.  
  17201. /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
  17202.  
  17203.    ffelexToken t;
  17204.    bool maybe_intrin;
  17205.    ffeexprParenType_ paren_type;
  17206.    ffesymbol s;
  17207.    s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
  17208.  
  17209.    Just like ffesymbol_declare_local, except performs any implicit info
  17210.    assignment necessary, and it returns the type of the parenthesized list
  17211.    (list of function args, list of array args, or substring spec).  */
  17212.  
  17213. static ffesymbol
  17214. ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
  17215.                 ffeexprParenType_ *paren_type)
  17216. {
  17217.   ffesymbol s;
  17218.   ffesymbolState st;        /* Effective state. */
  17219.   ffeinfoKind k;
  17220.   bool bad;
  17221.  
  17222.   if (maybe_intrin && ffesrc_check_symbol ())
  17223.     {                /* Knock off some easy cases. */
  17224.       switch (ffeexpr_stack_->context)
  17225.     {
  17226.     case FFEEXPR_contextSUBROUTINEREF:
  17227.     case FFEEXPR_contextDATA:
  17228.     case FFEEXPR_contextDATAIMPDOINDEX_:
  17229.     case FFEEXPR_contextSFUNCDEF:
  17230.     case FFEEXPR_contextSFUNCDEFINDEX_:
  17231.     case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
  17232.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
  17233.     case FFEEXPR_contextLET:
  17234.     case FFEEXPR_contextPAREN_:
  17235.     case FFEEXPR_contextACTUALARGEXPR_:
  17236.     case FFEEXPR_contextINDEXORACTUALARGEXPR_:
  17237.     case FFEEXPR_contextIOLIST:
  17238.     case FFEEXPR_contextIOLISTDF:
  17239.     case FFEEXPR_contextDO:
  17240.     case FFEEXPR_contextDOWHILE:
  17241.     case FFEEXPR_contextACTUALARG_:
  17242.     case FFEEXPR_contextCGOTO:
  17243.     case FFEEXPR_contextIF:
  17244.     case FFEEXPR_contextARITHIF:
  17245.     case FFEEXPR_contextFORMAT:
  17246.     case FFEEXPR_contextSTOP:
  17247.     case FFEEXPR_contextRETURN:
  17248.     case FFEEXPR_contextSELECTCASE:
  17249.     case FFEEXPR_contextCASE:
  17250.     case FFEEXPR_contextFILEASSOC:
  17251.     case FFEEXPR_contextFILEINT:
  17252.     case FFEEXPR_contextFILEDFINT:
  17253.     case FFEEXPR_contextFILELOG:
  17254.     case FFEEXPR_contextFILENUM:
  17255.     case FFEEXPR_contextFILENUMAMBIG:
  17256.     case FFEEXPR_contextFILECHAR:
  17257.     case FFEEXPR_contextFILENUMCHAR:
  17258.     case FFEEXPR_contextFILEDFCHAR:
  17259.     case FFEEXPR_contextFILEKEY:
  17260.     case FFEEXPR_contextFILEUNIT:
  17261.     case FFEEXPR_contextFILEUNIT_DF:
  17262.     case FFEEXPR_contextFILEUNITAMBIG:
  17263.     case FFEEXPR_contextFILEFORMAT:
  17264.     case FFEEXPR_contextFILENAMELIST:
  17265.     case FFEEXPR_contextFILEVXTCODE:
  17266.     case FFEEXPR_contextINDEX_:
  17267.     case FFEEXPR_contextIMPDOITEM_:
  17268.     case FFEEXPR_contextIMPDOITEMDF_:
  17269.     case FFEEXPR_contextIMPDOCTRL_:
  17270.     case FFEEXPR_contextDATAIMPDOCTRL_:
  17271.     case FFEEXPR_contextCHARACTERSIZE:
  17272.     case FFEEXPR_contextPARAMETER:
  17273.     case FFEEXPR_contextDIMLIST:
  17274.     case FFEEXPR_contextDIMLISTCOMMON:
  17275.     case FFEEXPR_contextKINDTYPE:
  17276.     case FFEEXPR_contextINITVAL:
  17277.     case FFEEXPR_contextEQVINDEX_:
  17278.       break;        /* These could be intrinsic invocations. */
  17279.  
  17280.     case FFEEXPR_contextAGOTO:
  17281.     case FFEEXPR_contextFILEFORMATNML:
  17282.     case FFEEXPR_contextALLOCATE:
  17283.     case FFEEXPR_contextDEALLOCATE:
  17284.     case FFEEXPR_contextHEAPSTAT:
  17285.     case FFEEXPR_contextNULLIFY:
  17286.     case FFEEXPR_contextDATAIMPDOITEM_:
  17287.     case FFEEXPR_contextLOC_:
  17288.     case FFEEXPR_contextINDEXORACTUALARG_:
  17289.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  17290.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  17291.     case FFEEXPR_contextPARENFILENUM_:
  17292.     case FFEEXPR_contextPARENFILEUNIT_:
  17293.       maybe_intrin = FALSE;
  17294.       break;        /* Can't be intrinsic invocation. */
  17295.  
  17296.     default:
  17297.       assert ("blah! blah! waaauuggh!" == NULL);
  17298.       break;
  17299.     }
  17300.     }
  17301.  
  17302.   s = ffesymbol_declare_local (t, maybe_intrin);
  17303.  
  17304.   switch ((ffesymbol_sfdummyparent (s) == NULL)
  17305.       ? ffesymbol_state (s)
  17306.       : FFESYMBOL_stateUNDERSTOOD)
  17307.     {
  17308.     case FFESYMBOL_stateNONE:    /* Before first exec, not seen in expr
  17309.                    context. */
  17310.       if (!ffest_seen_first_exec ())
  17311.     goto seen;        /* :::::::::::::::::::: */
  17312.       /* Fall through. */
  17313.     case FFESYMBOL_stateUNCERTAIN:    /* Unseen since first exec. */
  17314.       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
  17315.     {
  17316.     case FFEEXPR_contextSUBROUTINEREF:
  17317.       s = ffeexpr_sym_lhs_call_ (s, t);    /* "CALL FOO"=="CALL
  17318.                            FOO(...)". */
  17319.       break;
  17320.  
  17321.     case FFEEXPR_contextDATA:
  17322.       if (ffeexpr_stack_->is_rhs)
  17323.         s = ffeexpr_sym_rhs_let_ (s, t);
  17324.       else
  17325.         s = ffeexpr_sym_lhs_data_ (s, t);
  17326.       break;
  17327.  
  17328.     case FFEEXPR_contextDATAIMPDOITEM_:
  17329.       s = ffeexpr_sym_lhs_data_ (s, t);
  17330.       break;
  17331.  
  17332.     case FFEEXPR_contextDATAIMPDOINDEX_:
  17333.     case FFEEXPR_contextDATAIMPDOCTRL_:
  17334.       break;        /* UNDERSTOOD case still needs to call fns,
  17335.                    let it do this. */
  17336.  
  17337.     case FFEEXPR_contextSFUNCDEF:
  17338.     case FFEEXPR_contextSFUNCDEFINDEX_:
  17339.     case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
  17340.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
  17341.       s = ffecom_sym_exec_transition (s);
  17342.       if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
  17343.         goto understood;    /* :::::::::::::::::::: */
  17344.       /* Fall through. */
  17345.     case FFEEXPR_contextLET:
  17346.     case FFEEXPR_contextPAREN_:
  17347.     case FFEEXPR_contextACTUALARGEXPR_:
  17348.     case FFEEXPR_contextINDEXORACTUALARGEXPR_:
  17349.     case FFEEXPR_contextIOLIST:
  17350.     case FFEEXPR_contextIOLISTDF:
  17351.     case FFEEXPR_contextDO:
  17352.     case FFEEXPR_contextDOWHILE:
  17353.     case FFEEXPR_contextACTUALARG_:
  17354.     case FFEEXPR_contextCGOTO:
  17355.     case FFEEXPR_contextIF:
  17356.     case FFEEXPR_contextARITHIF:
  17357.     case FFEEXPR_contextFORMAT:
  17358.     case FFEEXPR_contextSTOP:
  17359.     case FFEEXPR_contextRETURN:
  17360.     case FFEEXPR_contextSELECTCASE:
  17361.     case FFEEXPR_contextCASE:
  17362.     case FFEEXPR_contextFILEASSOC:
  17363.     case FFEEXPR_contextFILEINT:
  17364.     case FFEEXPR_contextFILEDFINT:
  17365.     case FFEEXPR_contextFILELOG:
  17366.     case FFEEXPR_contextFILENUM:
  17367.     case FFEEXPR_contextFILENUMAMBIG:
  17368.     case FFEEXPR_contextFILECHAR:
  17369.     case FFEEXPR_contextFILENUMCHAR:
  17370.     case FFEEXPR_contextFILEDFCHAR:
  17371.     case FFEEXPR_contextFILEKEY:
  17372.     case FFEEXPR_contextFILEUNIT:
  17373.     case FFEEXPR_contextFILEUNIT_DF:
  17374.     case FFEEXPR_contextFILEUNITAMBIG:
  17375.     case FFEEXPR_contextFILEFORMAT:
  17376.     case FFEEXPR_contextFILENAMELIST:
  17377.     case FFEEXPR_contextFILEVXTCODE:
  17378.     case FFEEXPR_contextINDEX_:
  17379.     case FFEEXPR_contextIMPDOITEM_:
  17380.     case FFEEXPR_contextIMPDOITEMDF_:
  17381.     case FFEEXPR_contextIMPDOCTRL_:
  17382.     case FFEEXPR_contextLOC_:
  17383.       if (ffeexpr_stack_->is_rhs)
  17384.         s = ffeexpr_paren_rhs_let_ (s, t);
  17385.       else
  17386.         s = ffeexpr_paren_lhs_let_ (s, t);
  17387.       break;
  17388.  
  17389.     case FFEEXPR_contextASSIGN:
  17390.     case FFEEXPR_contextAGOTO:
  17391.     case FFEEXPR_contextCHARACTERSIZE:
  17392.     case FFEEXPR_contextEQUIVALENCE:
  17393.     case FFEEXPR_contextINCLUDE:
  17394.     case FFEEXPR_contextPARAMETER:
  17395.     case FFEEXPR_contextDIMLIST:
  17396.     case FFEEXPR_contextDIMLISTCOMMON:
  17397.     case FFEEXPR_contextKINDTYPE:
  17398.     case FFEEXPR_contextINITVAL:
  17399.     case FFEEXPR_contextEQVINDEX_:
  17400.       break;        /* Will turn into errors below. */
  17401.  
  17402.     default:
  17403.       assert ("UNCERTAIN/NONE bad context" == NULL);
  17404.       break;
  17405.     }
  17406.       /* Fall through. */
  17407.     case FFESYMBOL_stateUNDERSTOOD:    /* Nothing much more to learn. */
  17408.     understood:        /* :::::::::::::::::::: */
  17409.  
  17410.       /* State might have changed, update it.  */
  17411.       st = ((ffesymbol_sfdummyparent (s) == NULL)
  17412.         ? ffesymbol_state (s)
  17413.         : FFESYMBOL_stateUNDERSTOOD);
  17414.  
  17415.       k = ffesymbol_kind (s);
  17416.       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
  17417.     {
  17418.     case FFEEXPR_contextSUBROUTINEREF:
  17419.       bad = (k != FFEINFO_kindSUBROUTINE);
  17420.       break;
  17421.  
  17422.     case FFEEXPR_contextDATA:
  17423.       if (ffeexpr_stack_->is_rhs)
  17424.         bad = (k != FFEINFO_kindENTITY)
  17425.           || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
  17426.       else
  17427.         bad = (k != FFEINFO_kindENTITY)
  17428.           || ((ffesymbol_where (s) != FFEINFO_whereNONE)
  17429.           && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
  17430.           && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
  17431.       break;
  17432.  
  17433.     case FFEEXPR_contextDATAIMPDOITEM_:
  17434.       bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
  17435.         || ((ffesymbol_where (s) != FFEINFO_whereNONE)
  17436.         && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
  17437.         && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
  17438.       break;
  17439.  
  17440.     case FFEEXPR_contextDATAIMPDOINDEX_:
  17441.       s = ffeexpr_sym_impdoitem_ (s, t);
  17442.       bad = TRUE;
  17443.       break;
  17444.  
  17445.     case FFEEXPR_contextDATAIMPDOCTRL_:
  17446.       s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
  17447.       bad = TRUE;
  17448.       break;
  17449.  
  17450.     case FFEEXPR_contextSFUNCDEF:
  17451.     case FFEEXPR_contextSFUNCDEFINDEX_:
  17452.     case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
  17453.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
  17454.     case FFEEXPR_contextLET:
  17455.     case FFEEXPR_contextPAREN_:
  17456.     case FFEEXPR_contextACTUALARGEXPR_:
  17457.     case FFEEXPR_contextINDEXORACTUALARGEXPR_:
  17458.     case FFEEXPR_contextIOLIST:
  17459.     case FFEEXPR_contextIOLISTDF:
  17460.     case FFEEXPR_contextDO:
  17461.     case FFEEXPR_contextDOWHILE:
  17462.     case FFEEXPR_contextACTUALARG_:
  17463.     case FFEEXPR_contextCGOTO:
  17464.     case FFEEXPR_contextIF:
  17465.     case FFEEXPR_contextARITHIF:
  17466.     case FFEEXPR_contextFORMAT:
  17467.     case FFEEXPR_contextSTOP:
  17468.     case FFEEXPR_contextRETURN:
  17469.     case FFEEXPR_contextSELECTCASE:
  17470.     case FFEEXPR_contextCASE:
  17471.     case FFEEXPR_contextFILEASSOC:
  17472.     case FFEEXPR_contextFILEINT:
  17473.     case FFEEXPR_contextFILEDFINT:
  17474.     case FFEEXPR_contextFILELOG:
  17475.     case FFEEXPR_contextFILENUM:
  17476.     case FFEEXPR_contextFILENUMAMBIG:
  17477.     case FFEEXPR_contextFILECHAR:
  17478.     case FFEEXPR_contextFILENUMCHAR:
  17479.     case FFEEXPR_contextFILEDFCHAR:
  17480.     case FFEEXPR_contextFILEKEY:
  17481.     case FFEEXPR_contextFILEUNIT:
  17482.     case FFEEXPR_contextFILEUNIT_DF:
  17483.     case FFEEXPR_contextFILEUNITAMBIG:
  17484.     case FFEEXPR_contextFILEFORMAT:
  17485.     case FFEEXPR_contextFILENAMELIST:
  17486.     case FFEEXPR_contextFILEVXTCODE:
  17487.     case FFEEXPR_contextINDEX_:
  17488.     case FFEEXPR_contextIMPDOITEM_:
  17489.     case FFEEXPR_contextIMPDOITEMDF_:
  17490.     case FFEEXPR_contextIMPDOCTRL_:
  17491.     case FFEEXPR_contextLOC_:
  17492.       bad = FALSE;        /* Let paren-switch handle the cases. */
  17493.       break;
  17494.  
  17495.     case FFEEXPR_contextASSIGN:
  17496.     case FFEEXPR_contextAGOTO:
  17497.     case FFEEXPR_contextCHARACTERSIZE:
  17498.     case FFEEXPR_contextEQUIVALENCE:
  17499.     case FFEEXPR_contextPARAMETER:
  17500.     case FFEEXPR_contextDIMLIST:
  17501.     case FFEEXPR_contextDIMLISTCOMMON:
  17502.     case FFEEXPR_contextKINDTYPE:
  17503.     case FFEEXPR_contextINITVAL:
  17504.     case FFEEXPR_contextEQVINDEX_:
  17505.       bad = (k != FFEINFO_kindENTITY)
  17506.         || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
  17507.       break;
  17508.  
  17509.     case FFEEXPR_contextINCLUDE:
  17510.       bad = TRUE;
  17511.       break;
  17512.  
  17513.     default:
  17514.       assert ("UNDERSTOOD bad context" == NULL);
  17515.       bad = TRUE;
  17516.       break;
  17517.     }
  17518.  
  17519.       switch (bad ? FFEINFO_kindANY : k)
  17520.     {
  17521.     case FFEINFO_kindNONE:    /* Case "CHARACTER X,Y; Y=X(?". */
  17522.       if (st == FFESYMBOL_stateUNDERSTOOD)
  17523.         {
  17524.           bad = TRUE;
  17525.           *paren_type = FFEEXPR_parentypeANY_;
  17526.         }
  17527.       else
  17528.         *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
  17529.       break;
  17530.  
  17531.     case FFEINFO_kindFUNCTION:
  17532.       *paren_type = FFEEXPR_parentypeFUNCTION_;
  17533.       switch (ffesymbol_where (s))
  17534.         {
  17535.         case FFEINFO_whereLOCAL:
  17536.           bad = TRUE;    /* Attempt to recurse! */
  17537.           break;
  17538.  
  17539.         case FFEINFO_whereCONSTANT:
  17540.           bad = ((ffesymbol_sfexpr (s) == NULL)
  17541.              || (ffebld_op (ffesymbol_sfexpr (s))
  17542.              == FFEBLD_opANY));    /* Attempt to recurse! */
  17543.           break;
  17544.  
  17545.         default:
  17546.           break;
  17547.         }
  17548.       break;
  17549.  
  17550.     case FFEINFO_kindSUBROUTINE:
  17551.       if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
  17552.           || (ffeexpr_stack_->previous != NULL))
  17553.         {
  17554.           bad = TRUE;
  17555.           *paren_type = FFEEXPR_parentypeANY_;
  17556.           break;
  17557.         }
  17558.  
  17559.       *paren_type = FFEEXPR_parentypeSUBROUTINE_;
  17560.       switch (ffesymbol_where (s))
  17561.         {
  17562.         case FFEINFO_whereLOCAL:
  17563.         case FFEINFO_whereCONSTANT:
  17564.           bad = TRUE;    /* Attempt to recurse! */
  17565.           break;
  17566.  
  17567.         default:
  17568.           break;
  17569.         }
  17570.       break;
  17571.  
  17572.     case FFEINFO_kindENTITY:
  17573.       if (ffesymbol_rank (s) == 0)
  17574.         if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
  17575.           *paren_type = FFEEXPR_parentypeSUBSTRING_;
  17576.         else
  17577.           {
  17578.         bad = TRUE;
  17579.         *paren_type = FFEEXPR_parentypeANY_;
  17580.           }
  17581.       else
  17582.         *paren_type = FFEEXPR_parentypeARRAY_;
  17583.       break;
  17584.  
  17585.     default:
  17586.       bad = TRUE;
  17587.       /* Fall through. */
  17588.     case FFEINFO_kindANY:
  17589.       *paren_type = FFEEXPR_parentypeANY_;
  17590.       break;
  17591.     }
  17592.  
  17593.       if (bad && (k != FFEINFO_kindANY))
  17594.     ffesymbol_error (s, t);
  17595.  
  17596.       return s;
  17597.  
  17598.     case FFESYMBOL_stateSEEN:    /* Seen but not yet in exec portion. */
  17599.     seen:            /* :::::::::::::::::::: */
  17600.       bad = TRUE;
  17601.       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
  17602.     {
  17603.     case FFEEXPR_contextPARAMETER:
  17604.       if (ffeexpr_stack_->is_rhs)
  17605.         ffesymbol_error (s, t);
  17606.       else
  17607.         s = ffeexpr_sym_lhs_parameter_ (s, t);
  17608.       break;
  17609.  
  17610.     case FFEEXPR_contextDATA:
  17611.       s = ffecom_sym_exec_transition (s);
  17612.       if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
  17613.         goto understood;    /* :::::::::::::::::::: */
  17614.       if (ffeexpr_stack_->is_rhs)
  17615.         ffesymbol_error (s, t);
  17616.       else
  17617.         s = ffeexpr_sym_lhs_data_ (s, t);
  17618.       goto understood;    /* :::::::::::::::::::: */
  17619.  
  17620.     case FFEEXPR_contextDATAIMPDOITEM_:
  17621.       s = ffecom_sym_exec_transition (s);
  17622.       if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
  17623.         goto understood;    /* :::::::::::::::::::: */
  17624.       s = ffeexpr_sym_lhs_data_ (s, t);
  17625.       goto understood;    /* :::::::::::::::::::: */
  17626.  
  17627.     case FFEEXPR_contextDATAIMPDOINDEX_:
  17628.       s = ffecom_sym_exec_transition (s);
  17629.       if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
  17630.         goto understood;    /* :::::::::::::::::::: */
  17631.       s = ffeexpr_sym_impdoitem_ (s, t);
  17632.       goto understood;    /* :::::::::::::::::::: */
  17633.  
  17634.     case FFEEXPR_contextDATAIMPDOCTRL_:
  17635.       s = ffecom_sym_exec_transition (s);
  17636.       if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
  17637.         goto understood;    /* :::::::::::::::::::: */
  17638.       s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
  17639.       goto understood;    /* :::::::::::::::::::: */
  17640.  
  17641.     case FFEEXPR_contextEQUIVALENCE:
  17642.       s = ffeexpr_sym_lhs_equivalence_ (s, t);
  17643.       bad = FALSE;
  17644.       break;
  17645.  
  17646.     case FFEEXPR_contextDIMLIST:
  17647.       s = ffeexpr_sym_rhs_dimlist_ (s, t);
  17648.       break;
  17649.  
  17650.     case FFEEXPR_contextCHARACTERSIZE:
  17651.     case FFEEXPR_contextKINDTYPE:
  17652.     case FFEEXPR_contextDIMLISTCOMMON:
  17653.     case FFEEXPR_contextINITVAL:
  17654.     case FFEEXPR_contextEQVINDEX_:
  17655.       ffesymbol_error (s, t);
  17656.       break;
  17657.  
  17658.     case FFEEXPR_contextINCLUDE:
  17659.       bad = TRUE;
  17660.       break;
  17661.  
  17662.     case FFEEXPR_contextINDEX_:
  17663.     case FFEEXPR_contextACTUALARGEXPR_:
  17664.     case FFEEXPR_contextINDEXORACTUALARGEXPR_:
  17665.     case FFEEXPR_contextSFUNCDEF:
  17666.     case FFEEXPR_contextSFUNCDEFINDEX_:
  17667.     case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
  17668.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
  17669.       assert (ffeexpr_stack_->is_rhs);
  17670.       s = ffecom_sym_exec_transition (s);
  17671.       if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
  17672.         goto understood;    /* :::::::::::::::::::: */
  17673.       s = ffeexpr_paren_rhs_let_ (s, t);
  17674.       goto understood;    /* :::::::::::::::::::: */
  17675.  
  17676.     default:
  17677.       assert ("SEEN bad context" == NULL);
  17678.       break;
  17679.     }
  17680.       k = ffesymbol_kind (s);
  17681.       switch (bad ? FFEINFO_kindANY : k)
  17682.     {
  17683.     case FFEINFO_kindNONE:    /* Case "CHARACTER X,Y; Y=X(?". */
  17684.       *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
  17685.       break;
  17686.  
  17687.     case FFEINFO_kindFUNCTION:
  17688.       *paren_type = FFEEXPR_parentypeFUNCTION_;
  17689.       switch (ffesymbol_where (s))
  17690.         {
  17691.         case FFEINFO_whereLOCAL:
  17692.           bad = TRUE;    /* Attempt to recurse! */
  17693.           break;
  17694.  
  17695.         case FFEINFO_whereCONSTANT:
  17696.           bad = ((ffesymbol_sfexpr (s) == NULL)
  17697.              || (ffebld_op (ffesymbol_sfexpr (s))
  17698.              == FFEBLD_opANY));    /* Attempt to recurse! */
  17699.           break;
  17700.  
  17701.         default:
  17702.           break;
  17703.         }
  17704.       break;
  17705.  
  17706.     case FFEINFO_kindSUBROUTINE:
  17707.       *paren_type = FFEEXPR_parentypeANY_;
  17708.       bad = TRUE;        /* Cannot possibly be in
  17709.                    contextSUBROUTINEREF. */
  17710.       break;
  17711.  
  17712.     case FFEINFO_kindENTITY:
  17713.       if (ffesymbol_rank (s) == 0)
  17714.         if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
  17715.           *paren_type = FFEEXPR_parentypeEQUIVALENCE_;
  17716.         else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
  17717.           *paren_type = FFEEXPR_parentypeSUBSTRING_;
  17718.         else
  17719.           {
  17720.         bad = TRUE;
  17721.         *paren_type = FFEEXPR_parentypeANY_;
  17722.           }
  17723.       else
  17724.         *paren_type = FFEEXPR_parentypeARRAY_;
  17725.       break;
  17726.  
  17727.     default:
  17728.       bad = TRUE;
  17729.       /* Fall through. */
  17730.     case FFEINFO_kindANY:
  17731.       *paren_type = FFEEXPR_parentypeANY_;
  17732.       break;
  17733.     }
  17734.  
  17735.       if (bad && (k != FFEINFO_kindANY))
  17736.     ffesymbol_error (s, t);
  17737.  
  17738.       return s;
  17739.  
  17740.     default:
  17741.       assert ("bad symbol state" == NULL);
  17742.       return NULL;
  17743.     }
  17744. }
  17745.  
  17746. /* Have FOO in XYZ = ...FOO(...)....  Executable context only.  */
  17747.  
  17748. static ffesymbol
  17749. ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
  17750. {
  17751.   ffesymbolAttrs sa;
  17752.   ffesymbolAttrs na;
  17753.   ffeinfoKind kind;
  17754.   ffeinfoWhere where;
  17755.   ffeintrinGen gen;
  17756.   ffeintrinSpec spec;
  17757.   ffeintrinImp imp;
  17758.   bool maybe_ambig = FALSE;
  17759.  
  17760.   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
  17761.       || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
  17762.  
  17763.   na = sa = ffesymbol_attrs (s);
  17764.  
  17765.   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
  17766.            | FFESYMBOL_attrsANYLEN
  17767.            | FFESYMBOL_attrsARRAY
  17768.            | FFESYMBOL_attrsDUMMY
  17769.            | FFESYMBOL_attrsEXTERNAL
  17770.            | FFESYMBOL_attrsSFARG
  17771.            | FFESYMBOL_attrsTYPE)));
  17772.  
  17773.   kind = ffesymbol_kind (s);
  17774.   where = ffesymbol_where (s);
  17775.  
  17776.   /* Figure out what kind of object we've got based on previous declarations
  17777.      of or references to the object. */
  17778.  
  17779.   if (sa & FFESYMBOL_attrsEXTERNAL)
  17780.     {
  17781.       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
  17782.                | FFESYMBOL_attrsDUMMY
  17783.                | FFESYMBOL_attrsEXTERNAL
  17784.                | FFESYMBOL_attrsTYPE)));
  17785.  
  17786.       if (sa & FFESYMBOL_attrsTYPE)
  17787.     where = FFEINFO_whereGLOBAL;
  17788.       else
  17789.     /* Not TYPE. */
  17790.     {
  17791.       kind = FFEINFO_kindFUNCTION;
  17792.  
  17793.       if (sa & FFESYMBOL_attrsDUMMY)
  17794.         ;            /* Not TYPE. */
  17795.       else if (sa & FFESYMBOL_attrsACTUALARG)
  17796.         ;            /* Not DUMMY or TYPE. */
  17797.       else            /* Not ACTUALARG, DUMMY, or TYPE. */
  17798.         where = FFEINFO_whereGLOBAL;
  17799.     }
  17800.     }
  17801.   else if (sa & FFESYMBOL_attrsDUMMY)
  17802.     {
  17803.       assert (!(sa & FFESYMBOL_attrsEXTERNAL));    /* Handled above. */
  17804.       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
  17805.                | FFESYMBOL_attrsEXTERNAL
  17806.                | FFESYMBOL_attrsTYPE)));
  17807.  
  17808.       kind = FFEINFO_kindFUNCTION;
  17809.       maybe_ambig = TRUE;    /* If basictypeCHARACTER, can't be sure; kind
  17810.                    could be ENTITY w/substring ref. */
  17811.     }
  17812.   else if (sa & FFESYMBOL_attrsARRAY)
  17813.     {
  17814.       assert (!(sa & ~(FFESYMBOL_attrsARRAY
  17815.                | FFESYMBOL_attrsTYPE)));
  17816.  
  17817.       where = FFEINFO_whereLOCAL;
  17818.     }
  17819.   else if (sa & FFESYMBOL_attrsSFARG)
  17820.     {
  17821.       assert (!(sa & ~(FFESYMBOL_attrsSFARG
  17822.                | FFESYMBOL_attrsTYPE)));
  17823.  
  17824.       where = FFEINFO_whereLOCAL;    /* Actually an error, but at least we
  17825.                        know it's a local var. */
  17826.     }
  17827.   else if (sa & FFESYMBOL_attrsTYPE)
  17828.     {
  17829.       assert (!(sa & (FFESYMBOL_attrsARRAY
  17830.               | FFESYMBOL_attrsDUMMY
  17831.               | FFESYMBOL_attrsEXTERNAL
  17832.               | FFESYMBOL_attrsSFARG)));    /* Handled above. */
  17833.       assert (!(sa & ~(FFESYMBOL_attrsANYLEN
  17834.                | FFESYMBOL_attrsARRAY
  17835.                | FFESYMBOL_attrsDUMMY
  17836.                | FFESYMBOL_attrsEXTERNAL
  17837.                | FFESYMBOL_attrsSFARG
  17838.                | FFESYMBOL_attrsTYPE)));
  17839.  
  17840.       if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
  17841.                   &gen, &spec, &imp, &kind))
  17842.     {
  17843.       if (!(sa & FFESYMBOL_attrsANYLEN)
  17844.           && (ffeimplic_peek_symbol_type (s, NULL)
  17845.           == FFEINFO_basictypeCHARACTER))
  17846.         return s;        /* Haven't learned anything yet. */
  17847.  
  17848.       ffesymbol_signal_change (s);    /* May need to back up to previous
  17849.                        version. */
  17850.       ffesymbol_set_generic (s, gen);
  17851.       ffesymbol_set_specific (s, spec);
  17852.       ffesymbol_set_implementation (s, imp);
  17853.       ffesymbol_set_info (s,
  17854.                   ffeinfo_new (FFEINFO_basictypeNONE,
  17855.                        FFEINFO_kindtypeNONE,
  17856.                        0,
  17857.                        kind,
  17858.                        FFEINFO_whereINTRINSIC,
  17859.                        FFETARGET_charactersizeNONE));
  17860.       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
  17861.       ffesymbol_resolve_intrin (s);
  17862.       s = ffecom_sym_learned (s);
  17863.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  17864.  
  17865.       return s;
  17866.     }
  17867.       if (sa & FFESYMBOL_attrsANYLEN)
  17868.     na = FFESYMBOL_attrsetNONE;    /* Error, since the only way we can,
  17869.                        given CHARACTER*(*) FOO, accept
  17870.                        FOO(...) is for FOO to be a dummy
  17871.                        arg or constant, but it can't
  17872.                        become either now. */
  17873.       else
  17874.     {
  17875.       kind = FFEINFO_kindFUNCTION;
  17876.       where = FFEINFO_whereGLOBAL;
  17877.       maybe_ambig = TRUE;    /* If basictypeCHARACTER, can't be sure;
  17878.                    could be ENTITY/LOCAL w/substring ref. */
  17879.     }
  17880.     }
  17881.   else if (sa == FFESYMBOL_attrsetNONE)
  17882.     {
  17883.       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
  17884.  
  17885.       if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
  17886.                   &gen, &spec, &imp, &kind))
  17887.     {
  17888.       if (ffeimplic_peek_symbol_type (s, NULL)
  17889.           == FFEINFO_basictypeCHARACTER)
  17890.         return s;        /* Haven't learned anything yet. */
  17891.  
  17892.       ffesymbol_signal_change (s);    /* May need to back up to previous
  17893.                        version. */
  17894.       ffesymbol_set_generic (s, gen);
  17895.       ffesymbol_set_specific (s, spec);
  17896.       ffesymbol_set_implementation (s, imp);
  17897.       ffesymbol_set_info (s,
  17898.                   ffeinfo_new (FFEINFO_basictypeNONE,
  17899.                        FFEINFO_kindtypeNONE,
  17900.                        0,
  17901.                        kind,
  17902.                        FFEINFO_whereINTRINSIC,
  17903.                        FFETARGET_charactersizeNONE));
  17904.       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
  17905.       ffesymbol_resolve_intrin (s);
  17906.       s = ffecom_sym_learned (s);
  17907.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  17908.  
  17909.       return s;
  17910.     }
  17911.  
  17912.       kind = FFEINFO_kindFUNCTION;
  17913.       where = FFEINFO_whereGLOBAL;
  17914.       na = FFESYMBOL_attrsEXTERNAL;    /* Just not NONE nor ANY. */
  17915.       maybe_ambig = TRUE;    /* If basictypeCHARACTER, can't be sure;
  17916.                    could be ENTITY/LOCAL w/substring ref. */
  17917.     }
  17918.   else
  17919.     na = FFESYMBOL_attrsetNONE;    /* Error. */
  17920.  
  17921.   /* Now see what we've got for a new object: NONE means a new error cropped
  17922.      up; ANY means an old error to be ignored; otherwise, everything's ok,
  17923.      update the object (symbol) and continue on. */
  17924.  
  17925.   if (na == FFESYMBOL_attrsetNONE)
  17926.     ffesymbol_error (s, t);
  17927.   else if (!(na & FFESYMBOL_attrsANY))
  17928.     {
  17929.       ffesymbol_signal_change (s);    /* May need to back up to previous
  17930.                        version. */
  17931.       if (!ffeimplic_establish_symbol (s))
  17932.     {
  17933.       ffesymbol_error (s, t);
  17934.       return s;
  17935.     }
  17936.       if (maybe_ambig
  17937.       && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
  17938.     return s;        /* Still not sure, let caller deal with it
  17939.                    based on (...). */
  17940.       ffesymbol_set_info (s,
  17941.               ffeinfo_new (ffesymbol_basictype (s),
  17942.                        ffesymbol_kindtype (s),
  17943.                        ffesymbol_rank (s),
  17944.                        kind,
  17945.                        where,
  17946.                        ffesymbol_size (s)));
  17947.       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
  17948.       ffesymbol_resolve_intrin (s);
  17949.       s = ffecom_sym_learned (s);
  17950.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  17951.     }
  17952.  
  17953.   return s;
  17954. }
  17955.  
  17956. /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
  17957.  
  17958.    Return a pointer to this function to the lexer (ffelex), which will
  17959.    invoke it for the next token.
  17960.  
  17961.    Handle expression (which might be null) and COMMA or CLOSE_PAREN.  */
  17962.  
  17963. static ffelexHandler
  17964. ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
  17965. {
  17966.   ffeexprExpr_ procedure;
  17967.   ffebld reduced;
  17968.   ffeinfo info;
  17969.   bool is_function;
  17970.   ffeexprContext ctx;
  17971.  
  17972.   procedure = ffeexpr_stack_->exprstack;
  17973.   info = ffebld_info (procedure->u.operand);
  17974.  
  17975.   if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
  17976.     {                /* Statement function (or subroutine, if
  17977.                    there was such a thing). */
  17978.       if ((expr == NULL)
  17979.       && ((ffe_is_pedantic ()
  17980.            && (ffeexpr_stack_->expr != NULL))
  17981.           || (ffelex_token_type (t) == FFELEX_typeCOMMA)))
  17982.     {
  17983.       if (ffebad_start (FFEBAD_NULL_ARGUMENT))
  17984.         {
  17985.           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
  17986.              ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
  17987.           ffebad_here (1, ffelex_token_where_line (t),
  17988.                ffelex_token_where_column (t));
  17989.           ffebad_finish ();
  17990.         }
  17991.       if (ffeexpr_stack_->next_dummy != NULL)
  17992.         {            /* Don't bother if we're going to complain
  17993.                    later! */
  17994.           expr = ffebld_new_conter
  17995.         (ffebld_constant_new_integerdefault_val (0));
  17996.           ffebld_set_info (expr, ffeinfo_new_any ());
  17997.         }
  17998.     }
  17999.  
  18000.       if (expr == NULL)
  18001.     ;
  18002.       else
  18003.     {
  18004.       if (ffeexpr_stack_->next_dummy == NULL)
  18005.         {            /* Report later which was the first extra
  18006.                    argument. */
  18007.           if (ffeexpr_stack_->tokens[1] == NULL)
  18008.         {
  18009.           ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
  18010.           ffeexpr_stack_->num_args = 0;
  18011.         }
  18012.           ++ffeexpr_stack_->num_args;    /* Count # of extra
  18013.                            arguments. */
  18014.         }
  18015.       else
  18016.         {
  18017.           if (ffeinfo_rank (ffebld_info (expr)) != 0)
  18018.         {
  18019.           if (ffebad_start (FFEBAD_ARRAY_AS_SFARG))
  18020.             {
  18021.               ffebad_here (0,
  18022.             ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
  18023.               ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
  18024.               ffebad_here (1, ffelex_token_where_line (ft),
  18025.                    ffelex_token_where_column (ft));
  18026.               ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
  18027.                          (ffebld_symter (ffebld_head
  18028.                        (ffeexpr_stack_->next_dummy)))));
  18029.               ffebad_finish ();
  18030.             }
  18031.         }
  18032.           else
  18033.         {
  18034.           expr = ffeexpr_convert_expr (expr, ft,
  18035.                    ffebld_head (ffeexpr_stack_->next_dummy),
  18036.                            ffeexpr_stack_->tokens[0],
  18037.                            FFEEXPR_contextLET);
  18038.           ffebld_append_item (&ffeexpr_stack_->bottom, expr);
  18039.         }
  18040.           --ffeexpr_stack_->num_args;    /* Count down # of args. */
  18041.           ffeexpr_stack_->next_dummy
  18042.         = ffebld_trail (ffeexpr_stack_->next_dummy);
  18043.         }
  18044.     }
  18045.     }
  18046.   else if ((expr != NULL) || ffe_is_ugly ()
  18047.        || (ffelex_token_type (t) == FFELEX_typeCOMMA))
  18048.     ffebld_append_item (&ffeexpr_stack_->bottom, expr);
  18049.  
  18050.   switch (ffelex_token_type (t))
  18051.     {
  18052.     case FFELEX_typeCOMMA:
  18053.       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
  18054.     {
  18055.     case FFEEXPR_contextSFUNCDEF:
  18056.     case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
  18057.     case FFEEXPR_contextSFUNCDEFINDEX_:
  18058.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
  18059.       ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
  18060.       break;
  18061.  
  18062.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  18063.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  18064.       assert ("bad context" == NULL);
  18065.       ctx = FFEEXPR_context;
  18066.       break;
  18067.  
  18068.     default:
  18069.       ctx = FFEEXPR_contextACTUALARG_;
  18070.       break;
  18071.     }
  18072.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
  18073.                       ffeexpr_token_arguments_);
  18074.  
  18075.     default:
  18076.       break;
  18077.     }
  18078.  
  18079.   is_function = (ffeinfo_kind (info) != FFEINFO_kindSUBROUTINE);
  18080.   if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
  18081.       && (ffeexpr_stack_->next_dummy != NULL))
  18082.     {                /* Too few arguments. */
  18083.       if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
  18084.     {
  18085.       char num[10];
  18086.  
  18087.       sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
  18088.  
  18089.       ffebad_here (0, ffelex_token_where_line (t),
  18090.                ffelex_token_where_column (t));
  18091.       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
  18092.              ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
  18093.       ffebad_string (num);
  18094.       ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
  18095.                   (ffebld_head (ffeexpr_stack_->next_dummy)))));
  18096.       ffebad_finish ();
  18097.     }
  18098.       for (;
  18099.        ffeexpr_stack_->next_dummy != NULL;
  18100.        ffeexpr_stack_->next_dummy
  18101.        = ffebld_trail (ffeexpr_stack_->next_dummy))
  18102.     {
  18103.       expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
  18104.       ffebld_set_info (expr, ffeinfo_new_any ());
  18105.       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
  18106.     }
  18107.     }
  18108.  
  18109.   if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
  18110.       && (ffeexpr_stack_->tokens[1] != NULL))
  18111.     {                /* Too many arguments to statement function. */
  18112.       if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
  18113.     {
  18114.       char num[10];
  18115.  
  18116.       sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
  18117.  
  18118.       ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
  18119.              ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
  18120.       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
  18121.              ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
  18122.       ffebad_string (num);
  18123.       ffebad_finish ();
  18124.     }
  18125.       ffelex_token_kill (ffeexpr_stack_->tokens[1]);
  18126.     }
  18127.   ffebld_end_list (&ffeexpr_stack_->bottom);
  18128.  
  18129.   if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
  18130.     {
  18131.       reduced = ffebld_new_any ();
  18132.       ffebld_set_info (reduced, ffeinfo_new_any ());
  18133.     }
  18134.   else
  18135.     {
  18136.       if (is_function)
  18137.     reduced = ffebld_new_funcref (procedure->u.operand,
  18138.                       ffeexpr_stack_->expr);
  18139.       else
  18140.     reduced = ffebld_new_subrref (procedure->u.operand,
  18141.                       ffeexpr_stack_->expr);
  18142.       if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
  18143.     ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
  18144.       else if (ffebld_symter_specific (procedure->u.operand)
  18145.            != FFEINTRIN_specNONE)
  18146.     ffeintrin_fulfill_specific (&reduced, &info,
  18147.                     ffeexpr_stack_->tokens[0]);
  18148.       ffebld_set_info (reduced,
  18149.                ffeinfo_new (ffeinfo_basictype (info),
  18150.                     ffeinfo_kindtype (info),
  18151.                     0,
  18152.                     FFEINFO_kindENTITY,
  18153.                     FFEINFO_whereFLEETING,
  18154.                     ffeinfo_size (info)));
  18155.     }
  18156.   if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
  18157.     reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
  18158.   ffeexpr_stack_->exprstack = procedure->previous;    /* Pops
  18159.                                not-quite-operand off
  18160.                                stack. */
  18161.   procedure->u.operand = reduced;    /* Save the line/column ffewhere
  18162.                        info. */
  18163.   ffeexpr_exprstack_push_operand_ (procedure);    /* Push it back on stack. */
  18164.   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
  18165.     {
  18166.       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
  18167.       ffeexpr_is_substr_ok_ = FALSE;    /* Nobody likes "FUNC(3)(1:1)".... */
  18168.       return (ffelexHandler) ffeexpr_token_substrp_;
  18169.     }
  18170.  
  18171.   if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
  18172.     {
  18173.       ffebad_here (0, ffelex_token_where_line (t),
  18174.            ffelex_token_where_column (t));
  18175.       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
  18176.            ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
  18177.       ffebad_finish ();
  18178.     }
  18179.   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
  18180.   ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
  18181.   return
  18182.     (ffelexHandler) ffeexpr_find_close_paren_ (t,
  18183.                            (ffelexHandler)
  18184.                            ffeexpr_token_substrp_);
  18185. }
  18186.  
  18187. /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
  18188.  
  18189.    Return a pointer to this array to the lexer (ffelex), which will
  18190.    invoke it for the next token.
  18191.  
  18192.    Handle expression and COMMA or CLOSE_PAREN.    */
  18193.  
  18194. static ffelexHandler
  18195. ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
  18196. {
  18197.   ffeexprExpr_ array;
  18198.   ffebld reduced;
  18199.   ffeinfo info;
  18200.   ffeinfoWhere where;
  18201.   ffetargetIntegerDefault val;
  18202.   ffetargetIntegerDefault lval = 0;
  18203.   ffetargetIntegerDefault uval = 0;
  18204.   ffebld lbound;
  18205.   ffebld ubound;
  18206.   bool lcheck;
  18207.   bool ucheck;
  18208.  
  18209.   array = ffeexpr_stack_->exprstack;
  18210.   info = ffebld_info (array->u.operand);
  18211.  
  18212.   if ((expr == NULL)        /* && ((ffeexpr_stack_->rank != 0) ||
  18213.                    (ffelex_token_type(t) ==
  18214.          FFELEX_typeCOMMA)) */ )
  18215.     {
  18216.       if (ffebad_start (FFEBAD_NULL_ELEMENT))
  18217.     {
  18218.       ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
  18219.              ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
  18220.       ffebad_here (1, ffelex_token_where_line (t),
  18221.                ffelex_token_where_column (t));
  18222.       ffebad_finish ();
  18223.     }
  18224.       if (ffeexpr_stack_->rank < ffeinfo_rank (info))
  18225.     {            /* Don't bother if we're going to complain
  18226.                    later! */
  18227.       expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
  18228.       ffebld_set_info (expr, ffeinfo_new_any ());
  18229.     }
  18230.     }
  18231.  
  18232.   if (expr == NULL)
  18233.     ;
  18234.   else if (ffeinfo_rank (info) == 0)
  18235.     {                /* In EQUIVALENCE context, ffeinfo_rank(info)
  18236.                    may == 0. */
  18237.       ++ffeexpr_stack_->rank;    /* Track anyway, may need for new VXT
  18238.                    feature. */
  18239.       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
  18240.     }
  18241.   else
  18242.     {
  18243.       ++ffeexpr_stack_->rank;
  18244.       if (ffeexpr_stack_->rank > ffeinfo_rank (info))
  18245.     {            /* Report later which was the first extra
  18246.                    element. */
  18247.       if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
  18248.         ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
  18249.     }
  18250.       else
  18251.     {
  18252.       switch (ffeinfo_where (ffebld_info (expr)))
  18253.         {
  18254.         case FFEINFO_whereCONSTANT:
  18255.           break;
  18256.  
  18257.         case FFEINFO_whereIMMEDIATE:
  18258.           ffeexpr_stack_->constant = FALSE;
  18259.           break;
  18260.  
  18261.         default:
  18262.           ffeexpr_stack_->constant = FALSE;
  18263.           ffeexpr_stack_->immediate = FALSE;
  18264.           break;
  18265.         }
  18266.       if (ffebld_op (expr) == FFEBLD_opCONTER)
  18267.         {
  18268.           val = ffebld_constant_integerdefault (ffebld_conter (expr));
  18269.  
  18270.           lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
  18271.           if (lbound == NULL)
  18272.         {
  18273.           lcheck = TRUE;
  18274.           lval = 1;
  18275.         }
  18276.           else if (ffebld_op (lbound) == FFEBLD_opCONTER)
  18277.         {
  18278.           lcheck = TRUE;
  18279.           lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
  18280.         }
  18281.           else
  18282.         lcheck = FALSE;
  18283.  
  18284.           ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
  18285.           assert (ubound != NULL);
  18286.           if (ffebld_op (ubound) == FFEBLD_opCONTER)
  18287.         {
  18288.           ucheck = TRUE;
  18289.           uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
  18290.         }
  18291.           else
  18292.         ucheck = FALSE;
  18293.  
  18294.           if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
  18295.         {
  18296.           ffebad_start (FFEBAD_RANGE_ARRAY);
  18297.           ffebad_here (0, ffelex_token_where_line (ft),
  18298.                    ffelex_token_where_column (ft));
  18299.           ffebad_finish ();
  18300.         }
  18301.         }
  18302.       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
  18303.       ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
  18304.     }
  18305.     }
  18306.  
  18307.   switch (ffelex_token_type (t))
  18308.     {
  18309.     case FFELEX_typeCOMMA:
  18310.       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
  18311.     {
  18312.     case FFEEXPR_contextDATAIMPDOITEM_:
  18313.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  18314.                           FFEEXPR_contextDATAIMPDOINDEX_,
  18315.                           ffeexpr_token_elements_);
  18316.  
  18317.     case FFEEXPR_contextEQUIVALENCE:
  18318.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  18319.                           FFEEXPR_contextEQVINDEX_,
  18320.                           ffeexpr_token_elements_);
  18321.  
  18322.     case FFEEXPR_contextSFUNCDEF:
  18323.     case FFEEXPR_contextSFUNCDEFINDEX_:
  18324.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  18325.                           FFEEXPR_contextSFUNCDEFINDEX_,
  18326.                           ffeexpr_token_elements_);
  18327.  
  18328.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  18329.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  18330.       assert ("bad context" == NULL);
  18331.       break;
  18332.  
  18333.     default:
  18334.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  18335.                           FFEEXPR_contextINDEX_,
  18336.                           ffeexpr_token_elements_);
  18337.     }
  18338.  
  18339.     default:
  18340.       break;
  18341.     }
  18342.  
  18343.   if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
  18344.       && (ffeinfo_rank (info) != 0))
  18345.     {
  18346.       char num[10];
  18347.  
  18348.       if (ffeexpr_stack_->rank < ffeinfo_rank (info))
  18349.     {
  18350.       if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
  18351.         {
  18352.           sprintf (num, "%d",
  18353.                (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
  18354.  
  18355.           ffebad_here (0, ffelex_token_where_line (t),
  18356.                ffelex_token_where_column (t));
  18357.           ffebad_here (1,
  18358.             ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
  18359.              ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
  18360.           ffebad_string (num);
  18361.           ffebad_finish ();
  18362.         }
  18363.     }
  18364.       else
  18365.     {
  18366.       if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
  18367.         {
  18368.           sprintf (num, "%d",
  18369.                (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
  18370.  
  18371.           ffebad_here (0,
  18372.             ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
  18373.              ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
  18374.           ffebad_here (1,
  18375.             ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
  18376.              ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
  18377.           ffebad_string (num);
  18378.           ffebad_finish ();
  18379.         }
  18380.       ffelex_token_kill (ffeexpr_stack_->tokens[1]);
  18381.     }
  18382.       while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
  18383.     {
  18384.       expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
  18385.       ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
  18386.                           FFEINFO_kindtypeINTEGERDEFAULT,
  18387.                           0, FFEINFO_kindENTITY,
  18388.                           FFEINFO_whereCONSTANT,
  18389.                           FFETARGET_charactersizeNONE));
  18390.       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
  18391.     }
  18392.     }
  18393.   ffebld_end_list (&ffeexpr_stack_->bottom);
  18394.  
  18395.   if (ffebld_op (array->u.operand) == FFEBLD_opANY)
  18396.     reduced = ffebld_new_any ();
  18397.   else
  18398.     reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
  18399.   if (ffeexpr_stack_->constant)
  18400.     where = FFEINFO_whereFLEETING_CADDR;
  18401.   else if (ffeexpr_stack_->immediate)
  18402.     where = FFEINFO_whereFLEETING_IADDR;
  18403.   else
  18404.     where = FFEINFO_whereFLEETING;
  18405.   ffebld_set_info (reduced,
  18406.            ffeinfo_new (ffeinfo_basictype (info),
  18407.                 ffeinfo_kindtype (info),
  18408.                 0,
  18409.                 FFEINFO_kindENTITY,
  18410.                 where,
  18411.                 ffeinfo_size (info)));
  18412.   reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
  18413.  
  18414.   ffeexpr_stack_->exprstack = array->previous;    /* Pops not-quite-operand off
  18415.                            stack. */
  18416.   array->u.operand = reduced;    /* Save the line/column ffewhere info. */
  18417.   ffeexpr_exprstack_push_operand_ (array);    /* Push it back on stack. */
  18418.  
  18419.   switch (ffeinfo_basictype (info))
  18420.     {
  18421.     case FFEINFO_basictypeCHARACTER:
  18422.       ffeexpr_is_substr_ok_ = TRUE;    /* Everyone likes "FOO(3)(1:1)".... */
  18423.       break;
  18424.  
  18425.     case FFEINFO_basictypeNONE:
  18426.       ffeexpr_is_substr_ok_ = TRUE;
  18427.       assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
  18428.       break;
  18429.  
  18430.     default:
  18431.       ffeexpr_is_substr_ok_ = FALSE;
  18432.       break;
  18433.     }
  18434.  
  18435.   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
  18436.     {
  18437.       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
  18438.       return (ffelexHandler) ffeexpr_token_substrp_;
  18439.     }
  18440.  
  18441.   if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
  18442.     {
  18443.       ffebad_here (0, ffelex_token_where_line (t),
  18444.            ffelex_token_where_column (t));
  18445.       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
  18446.            ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
  18447.       ffebad_finish ();
  18448.     }
  18449.   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
  18450.   return
  18451.     (ffelexHandler) ffeexpr_find_close_paren_ (t,
  18452.                            (ffelexHandler)
  18453.                            ffeexpr_token_substrp_);
  18454. }
  18455.  
  18456. /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
  18457.  
  18458.    Return a pointer to this array to the lexer (ffelex), which will
  18459.    invoke it for the next token.
  18460.  
  18461.    If token is COLON, pass off to _substr_, else init list and pass off
  18462.    to _elements_.  This handles the case "EQUIVALENCE (FOO(expr?", where
  18463.    ? marks the token, and where FOO's rank/type has not yet been established,
  18464.    meaning we could be in a list of indices or in a substring
  18465.    specification.  */
  18466.  
  18467. static ffelexHandler
  18468. ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
  18469. {
  18470.   if (ffelex_token_type (t) == FFELEX_typeCOLON)
  18471.     return ffeexpr_token_substring_ (ft, expr, t);
  18472.  
  18473.   ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
  18474.   return ffeexpr_token_elements_ (ft, expr, t);
  18475. }
  18476.  
  18477. /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
  18478.  
  18479.    Return a pointer to this function to the lexer (ffelex), which will
  18480.    invoke it for the next token.
  18481.  
  18482.    Handle expression (which may be null) and COLON.  */
  18483.  
  18484. static ffelexHandler
  18485. ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
  18486. {
  18487.   ffeexprExpr_ string;
  18488.   ffeinfo info;
  18489.   ffetargetIntegerDefault i;
  18490.   ffeexprContext ctx;
  18491.   ffetargetCharacterSize size;
  18492.  
  18493.   string = ffeexpr_stack_->exprstack;
  18494.   info = ffebld_info (string->u.operand);
  18495.   size = ffebld_size_max (string->u.operand);
  18496.  
  18497.   if (ffelex_token_type (t) == FFELEX_typeCOLON)
  18498.     {
  18499.       if ((expr != NULL)
  18500.       && (ffebld_op (expr) == FFEBLD_opCONTER)
  18501.       && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
  18502.            < 1)
  18503.           || ((size != FFETARGET_charactersizeNONE) && (i > size))))
  18504.     {
  18505.       ffebad_start (FFEBAD_RANGE_SUBSTR);
  18506.       ffebad_here (0, ffelex_token_where_line (ft),
  18507.                ffelex_token_where_column (ft));
  18508.       ffebad_finish ();
  18509.     }
  18510.       ffeexpr_stack_->expr = expr;
  18511.  
  18512.       switch (ffeexpr_stack_->context)
  18513.     {
  18514.     case FFEEXPR_contextSFUNCDEF:
  18515.     case FFEEXPR_contextSFUNCDEFINDEX_:
  18516.       ctx = FFEEXPR_contextSFUNCDEFINDEX_;
  18517.       break;
  18518.  
  18519.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  18520.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  18521.       assert ("bad context" == NULL);
  18522.       ctx = FFEEXPR_context;
  18523.       break;
  18524.  
  18525.     default:
  18526.       ctx = FFEEXPR_contextINDEX_;
  18527.       break;
  18528.     }
  18529.  
  18530.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
  18531.                       ffeexpr_token_substring_1_);
  18532.     }
  18533.  
  18534.   if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
  18535.     {
  18536.       ffebad_here (0, ffelex_token_where_line (t),
  18537.            ffelex_token_where_column (t));
  18538.       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
  18539.            ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
  18540.       ffebad_finish ();
  18541.     }
  18542.  
  18543.   ffeexpr_stack_->expr = NULL;
  18544.   return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
  18545. }
  18546.  
  18547. /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
  18548.  
  18549.    Return a pointer to this function to the lexer (ffelex), which will
  18550.    invoke it for the next token.
  18551.  
  18552.    Handle expression (which might be null) and CLOSE_PAREN.  */
  18553.  
  18554. static ffelexHandler
  18555. ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
  18556. {
  18557.   ffeexprExpr_ string;
  18558.   ffebld reduced;
  18559.   ffebld substrlist;
  18560.   ffebld first = ffeexpr_stack_->expr;
  18561.   ffebld strop;
  18562.   ffeinfo info;
  18563.   ffeinfoWhere lwh;
  18564.   ffeinfoWhere rwh;
  18565.   ffeinfoWhere where;
  18566.   ffeinfoKindtype first_kt;
  18567.   ffeinfoKindtype last_kt;
  18568.   ffetargetIntegerDefault first_val;
  18569.   ffetargetIntegerDefault last_val;
  18570.   ffetargetCharacterSize size;
  18571.   ffetargetCharacterSize strop_size_max;
  18572.  
  18573.   string = ffeexpr_stack_->exprstack;
  18574.   strop = string->u.operand;
  18575.   info = ffebld_info (strop);
  18576.  
  18577.   if ((first == NULL) || (ffebld_op (first) == FFEBLD_opCONTER))
  18578.     {                /* The starting point is known. */
  18579.       first_val = (first == NULL) ? 1
  18580.     : ffebld_constant_integerdefault (ffebld_conter (first));
  18581.     }
  18582.   else
  18583.     {                /* Assume start of the entity. */
  18584.       first_val = 1;
  18585.     }
  18586.  
  18587.   if ((last != NULL) && (ffebld_op (last) == FFEBLD_opCONTER))
  18588.     {                /* The ending point is known. */
  18589.       last_val = ffebld_constant_integerdefault (ffebld_conter (last));
  18590.  
  18591.       if ((first == NULL) || (ffebld_op (first) == FFEBLD_opCONTER))
  18592.     {            /* The beginning point is a constant. */
  18593.       if (first_val <= last_val)
  18594.         size = last_val - first_val + 1;
  18595.       else
  18596.         {
  18597.           if (0 && ffe_is_90 ())
  18598.         size = 0;
  18599.           else
  18600.         {
  18601.           size = 1;
  18602.           ffebad_start (FFEBAD_ZERO_SIZE);
  18603.           ffebad_here (0, ffelex_token_where_line (ft),
  18604.                    ffelex_token_where_column (ft));
  18605.           ffebad_finish ();
  18606.         }
  18607.         }
  18608.     }
  18609.       else
  18610.     size = FFETARGET_charactersizeNONE;
  18611.  
  18612.       strop_size_max = ffebld_size_max (strop);
  18613.  
  18614.       if ((strop_size_max != FFETARGET_charactersizeNONE)
  18615.       && (last_val > strop_size_max))
  18616.     {            /* Beyond maximum possible end of string. */
  18617.       ffebad_start (FFEBAD_RANGE_SUBSTR);
  18618.       ffebad_here (0, ffelex_token_where_line (ft),
  18619.                ffelex_token_where_column (ft));
  18620.       ffebad_finish ();
  18621.     }
  18622.     }
  18623.   else
  18624.     size = FFETARGET_charactersizeNONE;    /* The size is not known. */
  18625.  
  18626. #if 0                /* Don't do this, or "is size of target
  18627.                    known?" would no longer be easily
  18628.                    answerable.    To see if there is a max
  18629.                    size, use ffebld_size_max; to get only the
  18630.                    known size, else NONE, use
  18631.                    ffebld_size_known; use ffebld_size if
  18632.                    values are sure to be the same (not
  18633.                    opSUBSTR or opCONCATENATE or known to have
  18634.                    known length). By getting rid of this
  18635.                    "useful info" stuff, we don't end up
  18636.                    blank-padding the constant in the
  18637.                    assignment "A(I:J)='XYZ'" to the known
  18638.                    length of A. */
  18639.   if (size == FFETARGET_charactersizeNONE)
  18640.     size = strop_size_max;    /* Assume we use the entire string. */
  18641. #endif
  18642.  
  18643.   substrlist
  18644.     = ffebld_new_item
  18645.     (first,
  18646.      ffebld_new_item
  18647.      (last,
  18648.       NULL
  18649.      )
  18650.     )
  18651.     ;
  18652.  
  18653.   if (first == NULL)
  18654.     lwh = FFEINFO_whereCONSTANT;
  18655.   else
  18656.     lwh = ffeinfo_where (ffebld_info (first));
  18657.   if (last == NULL)
  18658.     rwh = FFEINFO_whereCONSTANT;
  18659.   else
  18660.     rwh = ffeinfo_where (ffebld_info (last));
  18661.  
  18662.   switch (lwh)
  18663.     {
  18664.     case FFEINFO_whereCONSTANT:
  18665.       switch (rwh)
  18666.     {
  18667.     case FFEINFO_whereCONSTANT:
  18668.       where = FFEINFO_whereCONSTANT;
  18669.       break;
  18670.  
  18671.     case FFEINFO_whereIMMEDIATE:
  18672.       where = FFEINFO_whereIMMEDIATE;
  18673.       break;
  18674.  
  18675.     default:
  18676.       where = FFEINFO_whereFLEETING;
  18677.       break;
  18678.     }
  18679.       break;
  18680.  
  18681.     case FFEINFO_whereIMMEDIATE:
  18682.       switch (rwh)
  18683.     {
  18684.     case FFEINFO_whereCONSTANT:
  18685.     case FFEINFO_whereIMMEDIATE:
  18686.       where = FFEINFO_whereIMMEDIATE;
  18687.       break;
  18688.  
  18689.     default:
  18690.       where = FFEINFO_whereFLEETING;
  18691.       break;
  18692.     }
  18693.       break;
  18694.  
  18695.     default:
  18696.       where = FFEINFO_whereFLEETING;
  18697.       break;
  18698.     }
  18699.  
  18700.   if (first == NULL)
  18701.     first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
  18702.   else
  18703.     first_kt = ffeinfo_kindtype (ffebld_info (first));
  18704.   if (last == NULL)
  18705.     last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
  18706.   else
  18707.     last_kt = ffeinfo_kindtype (ffebld_info (last));
  18708.  
  18709.   switch (where)
  18710.     {
  18711.     case FFEINFO_whereCONSTANT:
  18712.       switch (ffeinfo_where (info))
  18713.     {
  18714.     case FFEINFO_whereCONSTANT:
  18715.       break;
  18716.  
  18717.     case FFEINFO_whereIMMEDIATE:    /* Not possible, actually. */
  18718.       where = FFEINFO_whereIMMEDIATE;
  18719.       break;
  18720.  
  18721.     default:
  18722.       where = FFEINFO_whereFLEETING_CADDR;
  18723.       break;
  18724.     }
  18725.       break;
  18726.  
  18727.     case FFEINFO_whereIMMEDIATE:
  18728.       switch (ffeinfo_where (info))
  18729.     {
  18730.     case FFEINFO_whereCONSTANT:
  18731.     case FFEINFO_whereIMMEDIATE:    /* Not possible, actually. */
  18732.       break;
  18733.  
  18734.     default:
  18735.       where = FFEINFO_whereFLEETING_IADDR;
  18736.       break;
  18737.     }
  18738.       break;
  18739.  
  18740.     default:
  18741.       switch (ffeinfo_where (info))
  18742.     {
  18743.     case FFEINFO_whereCONSTANT:
  18744.       where = FFEINFO_whereCONSTANT_SUBOBJECT;    /* An F90 concept. */
  18745.       break;
  18746.  
  18747.     case FFEINFO_whereIMMEDIATE:    /* Not possible, actually. */
  18748.     default:
  18749.       where = FFEINFO_whereFLEETING;
  18750.       break;
  18751.     }
  18752.       break;
  18753.     }
  18754.  
  18755.   if (ffebld_op (strop) == FFEBLD_opANY)
  18756.     {
  18757.       reduced = ffebld_new_any ();
  18758.       ffebld_set_info (reduced, ffeinfo_new_any ());
  18759.     }
  18760.   else
  18761.     {
  18762.       reduced = ffebld_new_substr (strop, substrlist);
  18763.       ffebld_set_info (reduced, ffeinfo_new
  18764.                (FFEINFO_basictypeCHARACTER,
  18765.             ffeinfo_kindtype (info),
  18766.             0,
  18767.             FFEINFO_kindENTITY,
  18768.             where,
  18769.             size));
  18770.       reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
  18771.     }
  18772.  
  18773.   ffeexpr_stack_->exprstack = string->previous;    /* Pops not-quite-operand off
  18774.                            stack. */
  18775.   string->u.operand = reduced;    /* Save the line/column ffewhere info. */
  18776.   ffeexpr_exprstack_push_operand_ (string);    /* Push it back on stack. */
  18777.  
  18778.   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
  18779.     {
  18780.       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
  18781.       ffeexpr_is_substr_ok_ = FALSE;    /* Nobody likes "FOO(3:5)(1:1)".... */
  18782.       return (ffelexHandler) ffeexpr_token_substrp_;
  18783.     }
  18784.  
  18785.   if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
  18786.     {
  18787.       ffebad_here (0, ffelex_token_where_line (t),
  18788.            ffelex_token_where_column (t));
  18789.       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
  18790.            ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
  18791.       ffebad_finish ();
  18792.     }
  18793.  
  18794.   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
  18795.   ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
  18796.   return
  18797.     (ffelexHandler) ffeexpr_find_close_paren_ (t,
  18798.                            (ffelexHandler)
  18799.                            ffeexpr_token_substrp_);
  18800. }
  18801.  
  18802. /* ffeexpr_token_substrp_ -- Rhs <character entity>
  18803.  
  18804.    Return a pointer to this function to the lexer (ffelex), which will
  18805.    invoke it for the next token.
  18806.  
  18807.    If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
  18808.    issue error message if flag (serves as argument) is set.  Else, just
  18809.    forward token to binary_.  */
  18810.  
  18811. static ffelexHandler
  18812. ffeexpr_token_substrp_ (ffelexToken t)
  18813. {
  18814.   ffeexprContext ctx;
  18815.  
  18816.   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
  18817.     return (ffelexHandler) ffeexpr_token_binary_ (t);
  18818.  
  18819.   ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
  18820.  
  18821.   switch (ffeexpr_stack_->context)
  18822.     {
  18823.     case FFEEXPR_contextSFUNCDEF:
  18824.     case FFEEXPR_contextSFUNCDEFINDEX_:
  18825.       ctx = FFEEXPR_contextSFUNCDEFINDEX_;
  18826.       break;
  18827.  
  18828.     case FFEEXPR_contextSFUNCDEFACTUALARG_:
  18829.     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
  18830.       assert ("bad context" == NULL);
  18831.       ctx = FFEEXPR_context;
  18832.       break;
  18833.  
  18834.     default:
  18835.       ctx = FFEEXPR_contextINDEX_;
  18836.       break;
  18837.     }
  18838.  
  18839.   if (!ffeexpr_is_substr_ok_)
  18840.     {
  18841.       if (ffebad_start (FFEBAD_BAD_SUBSTR))
  18842.     {
  18843.       ffebad_here (0, ffelex_token_where_line (t),
  18844.                ffelex_token_where_column (t));
  18845.       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
  18846.                ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
  18847.       ffebad_finish ();
  18848.     }
  18849.  
  18850.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
  18851.                       ffeexpr_token_anything_);
  18852.     }
  18853.  
  18854.   return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
  18855.                       ffeexpr_token_substring_);
  18856. }
  18857.  
  18858. /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
  18859.  
  18860.    Return a pointer to this function to the lexer (ffelex), which will
  18861.    invoke it for the next token.
  18862.  
  18863.    If COLON, do everything we would have done since _parenthesized_ if
  18864.    we had known NAME represented a kindENTITY instead of a kindFUNCTION.
  18865.    If not COLON, do likewise for kindFUNCTION instead.    */
  18866.  
  18867. static ffelexHandler
  18868. ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
  18869. {
  18870.   ffeinfoKind kind;
  18871.   ffeinfoWhere where;
  18872.   ffesymbol s;
  18873.   ffesymbolAttrs sa;
  18874.   ffebld symter = ffeexpr_stack_->exprstack->u.operand;
  18875.   bool needs_type;
  18876.   ffeintrinGen gen;
  18877.   ffeintrinSpec spec;
  18878.   ffeintrinImp imp;
  18879.  
  18880.   s = ffebld_symter (symter);
  18881.   sa = ffesymbol_attrs (s);
  18882.   where = ffesymbol_where (s);
  18883.  
  18884.   /* We get here only if we don't already know enough about FOO when seeing a
  18885.      FOO(stuff) reference, and FOO might turn out to be a CHARACTER type.  If
  18886.      "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
  18887.      Else FOO is a function, either intrinsic or external.  If intrinsic, it
  18888.      wouldn't necessarily be CHARACTER type, so unless it has already been
  18889.      declared DUMMY, it hasn't had its type established yet.  It can't be
  18890.      CHAR*(*) in any case, though it can have an explicit CHAR*n type.  */
  18891.  
  18892.   assert (!(sa & ~(FFESYMBOL_attrsDUMMY
  18893.            | FFESYMBOL_attrsTYPE)));
  18894.  
  18895.   needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
  18896.  
  18897.   ffesymbol_signal_change (s);    /* Probably already done, but in case.... */
  18898.  
  18899.   if (ffelex_token_type (t) == FFELEX_typeCOLON)
  18900.     {                /* Definitely an ENTITY (char substring). */
  18901.       if (needs_type && !ffeimplic_establish_symbol (s))
  18902.     {
  18903.       ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
  18904.       return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
  18905.     }
  18906.  
  18907.       ffesymbol_set_info (s,
  18908.               ffeinfo_new (ffesymbol_basictype (s),
  18909.                        ffesymbol_kindtype (s),
  18910.                        ffesymbol_rank (s),
  18911.                        FFEINFO_kindENTITY,
  18912.                        (where == FFEINFO_whereNONE)
  18913.                        ? FFEINFO_whereLOCAL
  18914.                        : where,
  18915.                        ffesymbol_size (s)));
  18916.       ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
  18917.  
  18918.       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
  18919.       ffesymbol_resolve_intrin (s);
  18920.       s = ffecom_sym_learned (s);
  18921.       ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  18922.  
  18923.       ffeexpr_stack_->exprstack->u.operand
  18924.     = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
  18925.  
  18926.       return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
  18927.     }
  18928.  
  18929.   /* The "stuff" isn't a substring notation, so we now know the overall
  18930.      reference is to a function.  */
  18931.  
  18932.   if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
  18933.                   FALSE, &gen, &spec, &imp, &kind))
  18934.     {
  18935.       ffebld_symter_set_generic (symter, gen);
  18936.       ffebld_symter_set_specific (symter, spec);
  18937.       ffesymbol_set_generic (s, gen);
  18938.       ffesymbol_set_specific (s, spec);
  18939.       ffesymbol_set_implementation (s, imp);
  18940.       ffesymbol_set_info (s,
  18941.               ffeinfo_new (FFEINFO_basictypeNONE,
  18942.                        FFEINFO_kindtypeNONE,
  18943.                        0,
  18944.                        kind,
  18945.                        FFEINFO_whereINTRINSIC,
  18946.                        FFETARGET_charactersizeNONE));
  18947.     }
  18948.   else
  18949.     {                /* Not intrinsic, now needs CHAR type. */
  18950.       if (!ffeimplic_establish_symbol (s))
  18951.     {
  18952.       ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
  18953.       return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
  18954.     }
  18955.  
  18956.       ffesymbol_set_info (s,
  18957.               ffeinfo_new (ffesymbol_basictype (s),
  18958.                        ffesymbol_kindtype (s),
  18959.                        ffesymbol_rank (s),
  18960.                        FFEINFO_kindFUNCTION,
  18961.                        (where == FFEINFO_whereNONE)
  18962.                        ? FFEINFO_whereGLOBAL
  18963.                        : where,
  18964.                        ffesymbol_size (s)));
  18965.     }
  18966.   ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
  18967.  
  18968.   ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
  18969.   ffesymbol_resolve_intrin (s);
  18970.   s = ffecom_sym_learned (s);
  18971.   ffesymbol_signal_unreported (s);    /* For debugging purposes. */
  18972.  
  18973.   ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
  18974.   return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
  18975. }
  18976.  
  18977. /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
  18978.  
  18979.    Handle basically any expression, looking for CLOSE_PAREN.  */
  18980.  
  18981. static ffelexHandler
  18982. ffeexpr_token_anything_ (ffelexToken ft, ffebld expr, ffelexToken t)
  18983. {
  18984.   ffeexprExpr_ e = ffeexpr_stack_->exprstack;
  18985.  
  18986.   switch (ffelex_token_type (t))
  18987.     {
  18988.     case FFELEX_typeCOMMA:
  18989.     case FFELEX_typeCOLON:
  18990.       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
  18991.                       FFEEXPR_contextACTUALARG_,
  18992.                       ffeexpr_token_anything_);
  18993.  
  18994.     default:
  18995.       e->u.operand = ffebld_new_any ();
  18996.       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
  18997.       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
  18998.       ffeexpr_is_substr_ok_ = FALSE;
  18999.       if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
  19000.     return (ffelexHandler) ffeexpr_token_substrp_;
  19001.       return (ffelexHandler) ffeexpr_token_substrp_ (t);
  19002.     }
  19003. }
  19004.  
  19005. /* Terminate module.  */
  19006.  
  19007. void
  19008. ffeexpr_terminate_2 ()
  19009. {
  19010.   assert (ffeexpr_stack_ == NULL);
  19011.   assert (ffeexpr_level_ == 0);
  19012. }
  19013.