Open64: osprey/crayf90/fe90/s_utils.c Source File

00001 /*
00002  *  Copyright (C) 2006. QLogic Corporation. All Rights Reserved.
00003  */
00004 
00005 /*
00006  * Copyright 2003, 2004, 2005, 2006 PathScale, Inc.  All Rights Reserved.
00007  */
00008 
00009 /*
00010 
00011   Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.
00012 
00013   This program is free software; you can redistribute it and/or modify it
00014   under the terms of version 2 of the GNU General Public License as
00015   published by the Free Software Foundation.
00016 
00017   This program is distributed in the hope that it would be useful, but
00018   WITHOUT ANY WARRANTY; without even the implied warranty of
00019   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  
00020 
00021   Further, this software is distributed without any warranty that it is
00022   free of the rightful claim of any third person regarding infringement 
00023   or the like.  Any license provided herein, whether implied or 
00024   otherwise, applies only to this software file.  Patent licenses, if 
00025   any, provided herein do not apply to combinations of this program with 
00026   other software, or any other product whatsoever.  
00027 
00028   You should have received a copy of the GNU General Public License along
00029   with this program; if not, write the Free Software Foundation, Inc., 59
00030   Temple Place - Suite 330, Boston MA 02111-1307, USA.
00031 
00032   Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
00033   Mountain View, CA 94043, or:
00034 
00035   http://www.sgi.com
00036 
00037   For further information regarding this notice, see:
00038 
00039   http://oss.sgi.com/projects/GenInfo/NoticeExplan
00040 
00041 */
00042 
00043 
00044 
00045 static char USMID[] = "\n@(#)5.0_pl/sources/s_utils.c 5.12  10/19/99 17:14:30\n";
00046 
00047 
00048 # include "defines.h"   /* Machine dependent ifdefs */
00049 
00050 # include "host.m"    /* Host machine dependent macros.*/
00051 # include "host.h"    /* Host machine dependent header.*/
00052 # include "target.m"    /* Target machine dependent macros.*/
00053 # include "target.h"    /* Target machine dependent header.*/
00054 
00055 # include "globals.m"
00056 # include "tokens.m"
00057 # include "sytb.m"
00058 # include "s_globals.m"
00059 # include "debug.m"
00060 # include "s_utils.m"
00061 
00062 # include "globals.h"
00063 # include "tokens.h"
00064 # include "sytb.h"
00065 # include "s_globals.h"
00066 
00067 # if defined(_HOST_OS_UNICOS) && defined(_TARGET_OS_UNICOS)
00068 # include <fortran.h>
00069 # endif
00070 #ifdef KEY /* Bug 6845 */
00071 /* Incredibly, there seems to be no single central definition for the limit
00072  * on subscripts in this front end. Often it's a hard-coded "7". This gives
00073  * us STATIC_SUBSCRIPT_SIZE, which is used in only one other place. Sigh. */
00074 #include "i_cvrt.h"
00075 #endif /* KEY Bug 6845 */
00076 
00077 
00078 /*****************************************************************\
00079 |* function prototypes of static functions declared in this file *|
00080 \*****************************************************************/
00081 
00082 static int      opr_to_str(operator_type, char *);
00083 static int      create_dv_type_code(int);
00084 static long64   create_imp_do_loops(opnd_type *);
00085 static void     just_find_dope_and_rank(opnd_type *, int *, int *);
00086 static void     compute_char_element_len(opnd_type *,
00087                        opnd_type *, opnd_type *);
00088 static void gen_conform_check_call(opnd_type *, opnd_type *, int, int, int);
00089 static void gen_bounds_check_call(char *, opnd_type *, opnd_type *,
00090                                       opnd_type *, int, int, int);
00091 static void gen_rbounds_check_call(char *, opnd_type *, opnd_type *,
00092                                        opnd_type *, opnd_type *,
00093                                        opnd_type *, int, int, int);
00094 static void gen_sbounds_check_call(char *, opnd_type *, opnd_type *, 
00095                                        opnd_type *, int, int);
00096 static void gen_ptr_chk_call(char *, int, opnd_type *, int, int);
00097 static int  put_file_name_in_cn(int);
00098 static int  put_c_str_in_cn(char *);
00099 static void gen_dv_def_loops(opnd_type *);
00100 static void gen_init_stmt(opnd_type *, int, sh_position_type);
00101 static void reshape_reference_subscripts(opnd_type *);
00102 static void gen_dv_stride_mult(opnd_type *, int, opnd_type *,
00103                                    expr_arg_type *, int, int, int);
00104 
00105 
00106 /******************************************************************************\
00107 |*                        *|
00108 |* Description:                     *|
00109 |*  resolve defined operators and assignment.                             *|
00110 |*                        *|
00111 |* Input parameters:                    *|
00112 |*  opnd - sub tree of operator.                                          *|
00113 |*                        *|
00114 |* Output parameters:                   *|
00115 |*                        *|
00116 |* Returns:                     *|
00117 |*  TRUE - if operator resolved ok.                                       *|
00118 |*                        *|
00119 \******************************************************************************/
00120 
00121 boolean resolve_ext_opr(opnd_type   *opnd,
00122                         boolean          issue_msg,
00123                         boolean    save_in_call_list,
00124       boolean    err_res,
00125                         boolean         *semantically_correct,
00126                         expr_arg_type   *exp_desc_l,
00127                         expr_arg_type   *exp_desc_r)
00128 
00129 {
00130    opnd_type  arg_1_opnd;
00131    opnd_type  arg_2_opnd;
00132    int    arg_idx;
00133    int    attr_idx;
00134    int    col;
00135    int    darg_idx;
00136 
00137 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
00138    int    false_list_idx    = NULL_IDX;
00139 # endif
00140 
00141    boolean  found     = FALSE;
00142    int    gen_idx     = NULL_IDX;
00143    int    i;
00144    int    idx;
00145    int    info_idx;
00146    int          ir_idx;
00147    boolean      is_function   = TRUE;
00148    int          len;
00149    int    line;
00150    int    list_idx;
00151    int    list1_idx;
00152    int    list2_idx;
00153    int    loc_idx;
00154    int    name_idx;
00155    int    num_args;
00156    boolean  ok      = TRUE;
00157    int    opnd_column;
00158    int    opnd_line;
00159    int    rslt_idx;
00160    int          save_arg_info_list_base;
00161    int    save_curr_stmt_sh_idx;
00162    int    save_defer_stmt_expansion;
00163    int    spec_idx    = NULL_IDX;
00164    int          sn_idx      = NULL_IDX;
00165    char         str_word[32];
00166    opnd_type    tmp_opnd;
00167    char         type_str_l[45];
00168    char         type_str_r[45];
00169 
00170 
00171    TRACE (Func_Entry, "resolve_ext_opr", NULL);
00172 
00173    /* do memory management stuff to make sure the tables are big enough */
00174 
00175    if (max_call_list_size >= arg_list_size) {
00176       enlarge_call_list_tables();
00177    }
00178 
00179    save_arg_info_list_base = arg_info_list_base;
00180    arg_info_list_base      = arg_info_list_top;
00181    arg_info_list_top       = arg_info_list_base + 2;
00182 
00183    if (arg_info_list_top >= arg_info_list_size) {
00184       enlarge_info_list_table();
00185    }
00186 
00187    ir_idx = OPND_IDX((*opnd));
00188    line = IR_LINE_NUM(ir_idx);
00189    col  = IR_COL_NUM(ir_idx);
00190 
00191    if (IR_OPR(ir_idx) == Defined_Bin_Opr) {
00192 
00193       gen_idx  = IR_IDX_L(ir_idx);
00194       strncpy(str_word, AT_OBJ_NAME_PTR(gen_idx), AT_NAME_LEN(gen_idx));
00195       str_word[AT_NAME_LEN(gen_idx)] = '\0';
00196       num_args = 2;
00197       COPY_OPND(arg_1_opnd, IL_OPND(IR_IDX_R(ir_idx)));
00198       COPY_OPND(arg_2_opnd, IL_OPND(IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx))));
00199 
00200       if (cif_flags & XREF_RECS) {
00201          cif_usage_rec(gen_idx, AT_Tbl_Idx, line, col, CIF_Symbol_Reference);
00202       }
00203    }
00204    else if (IR_OPR(ir_idx) == Defined_Un_Opr) {
00205       gen_idx  = IR_IDX_L(ir_idx);
00206       strncpy(str_word, AT_OBJ_NAME_PTR(gen_idx), AT_NAME_LEN(gen_idx));
00207       str_word[AT_NAME_LEN(gen_idx)] = '\0';
00208       num_args = 1;
00209       COPY_OPND(arg_1_opnd, IR_OPND_R(ir_idx));
00210 
00211       if (cif_flags & XREF_RECS) {
00212          cif_usage_rec(gen_idx, AT_Tbl_Idx, line, col, CIF_Symbol_Reference);
00213       }
00214    }
00215    else {
00216       len = opr_to_str(IR_OPR(ir_idx), str_word);
00217       gen_idx = srch_sym_tbl(str_word, len, &name_idx);
00218 
00219       if (gen_idx == NULL_IDX) {
00220          gen_idx   = srch_host_sym_tbl(str_word, len, &name_idx, TRUE);
00221       }
00222 
00223       COPY_OPND(arg_1_opnd, IR_OPND_L(ir_idx));
00224 
00225       if (IR_FLD_R(ir_idx) == NO_Tbl_Idx) {
00226          num_args = 1;
00227       }
00228       else {
00229          num_args = 2;
00230          COPY_OPND(arg_2_opnd, IR_OPND_R(ir_idx));
00231       }
00232    }
00233 
00234    if (IR_OPR(ir_idx) == Asg_Opr) {
00235       is_function = FALSE;
00236    }
00237 
00238    if (gen_idx   == NULL_IDX               ||
00239        AT_OBJ_CLASS(gen_idx) != Interface) {
00240       gen_idx = NULL_IDX;
00241       goto EXIT;
00242    }
00243 
00244    for (i = 0; i < ATI_NUM_SPECIFICS(gen_idx); i++) {
00245 
00246       sn_idx  = (sn_idx == NULL_IDX) ? ATI_FIRST_SPECIFIC_IDX(gen_idx) :
00247                                          SN_SIBLING_LINK(sn_idx);
00248       spec_idx  = SN_ATTR_IDX(sn_idx);
00249 
00250       /* check number, type etc. for match with arg list */
00251 
00252       if (ATP_EXTRA_DARG(spec_idx)) {
00253 
00254          if (num_args != ATP_NUM_DARGS(spec_idx) - 1) {
00255             continue;
00256          }
00257 
00258          darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + 1);
00259       }
00260       else {
00261 
00262          if (num_args != ATP_NUM_DARGS(spec_idx)) {
00263             continue;
00264          }
00265 
00266          darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx));
00267       }
00268 
00269       /* look at each actual arg for match */
00270 
00271       if (darg_idx == NULL_IDX) {
00272          continue;
00273       }
00274 
00275       if (AT_OBJ_CLASS(darg_idx) == Data_Obj) {
00276 
00277          if (ATD_IGNORE_TKR(darg_idx)) {
00278             /* intentionally blank */
00279             /* This dummy arg will match any type, so skip */
00280             /* the type and kind type checking below.      */
00281          }
00282          else if (OPND_FLD(arg_1_opnd) == IR_Tbl_Idx &&
00283                   IR_OPR(OPND_IDX(arg_1_opnd)) == Null_Intrinsic_Opr) {
00284             /* intentionally blank */
00285             /* Don't know type or rank yet, they come from dummy */
00286          }
00287          else if (TYP_TYPE(ATD_TYPE_IDX(darg_idx)) != exp_desc_l->type) {
00288             continue;
00289          }
00290          else if (exp_desc_l->type == Structure) {
00291 
00292             if (!compare_derived_types(exp_desc_l->type_idx,
00293                                        ATD_TYPE_IDX(darg_idx))) {
00294                continue;
00295             }
00296          }
00297          else if (exp_desc_l->type != Character   &&
00298            TYP_LINEAR(ATD_TYPE_IDX(darg_idx)) != exp_desc_l->linear_type) {
00299             continue;
00300          }
00301 
00302          if (ATD_IGNORE_TKR(darg_idx)) {
00303             /* intentionally blank */
00304             /* This dummy arg will match any rank, so skip */
00305             /* the rank checking below.      */
00306          }
00307          else if (OPND_FLD(arg_1_opnd) == IR_Tbl_Idx &&
00308                   IR_OPR(OPND_IDX(arg_1_opnd)) == Null_Intrinsic_Opr) {
00309             /* intentionally blank */
00310             /* Don't know type or rank yet, they come from dummy */
00311          }
00312          else if (ATP_ELEMENTAL(spec_idx)) {
00313             /* intentionally blank, don't check array conformance */
00314          }
00315          else if (ATD_ARRAY_IDX(darg_idx) == NULL_IDX) {
00316        
00317             if (exp_desc_l->rank) {
00318                continue;
00319             }
00320          }
00321          else {
00322 
00323             if (BD_RANK(ATD_ARRAY_IDX(darg_idx)) != exp_desc_l->rank) {
00324                continue;
00325             }
00326          }
00327       }
00328       else if (AT_OBJ_CLASS(darg_idx) == Pgm_Unit) {
00329          /* not sure this is possible */
00330       }
00331 
00332       if (num_args == 2) {
00333          if (ATP_EXTRA_DARG(spec_idx)) {
00334             darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + 2);
00335          }
00336          else {
00337             darg_idx = SN_ATTR_IDX(ATP_FIRST_IDX(spec_idx) + 1);
00338          }
00339          /* look at each actual arg for match */
00340    
00341          if (darg_idx == NULL_IDX) {
00342             continue;
00343          }
00344       
00345          if (AT_OBJ_CLASS(darg_idx) == Data_Obj) {
00346 
00347             if (ATD_IGNORE_TKR(darg_idx)) {
00348                /* intentionally blank */
00349                /* This dummy arg will match any type, so skip */
00350                /* the type and kind type checking below.      */
00351             }
00352             else if (OPND_FLD(arg_2_opnd) == IR_Tbl_Idx &&
00353                      IR_OPR(OPND_IDX(arg_2_opnd)) == Null_Intrinsic_Opr) {
00354                /* intentionally blank */
00355                /* Don't know type or rank yet, they come from dummy */
00356             }
00357             else if (TYP_TYPE(ATD_TYPE_IDX(darg_idx)) != exp_desc_r->type) {
00358                continue;
00359             }
00360             else if (exp_desc_r->type == Structure) {
00361 
00362                if (!compare_derived_types(exp_desc_r->type_idx, 
00363                                           ATD_TYPE_IDX(darg_idx))) {
00364                   continue;
00365                }
00366             }
00367             else if (exp_desc_r->type != Character && 
00368             TYP_LINEAR(ATD_TYPE_IDX(darg_idx)) != exp_desc_r->linear_type) {
00369                continue;
00370             }
00371 
00372             if (ATD_IGNORE_TKR(darg_idx)) {
00373                /* intentionally blank */
00374                /* This dummy arg will match any rank, so skip */
00375                /* the rank checking below.      */
00376             }
00377             else if (OPND_FLD(arg_2_opnd) == IR_Tbl_Idx &&
00378                      IR_OPR(OPND_IDX(arg_2_opnd)) == Null_Intrinsic_Opr) {
00379                /* intentionally blank */
00380                /* Don't know type or rank yet, they come from dummy */
00381             }
00382             else if (ATP_ELEMENTAL(spec_idx)) {
00383                /* intentionally blank, don't check array conformance */
00384             }
00385             else if (ATD_ARRAY_IDX(darg_idx) == NULL_IDX) {
00386           
00387                if (exp_desc_r->rank) {
00388                   continue;
00389                }
00390             }
00391             else {
00392 
00393                if (BD_RANK(ATD_ARRAY_IDX(darg_idx)) != exp_desc_r->rank) {
00394                   continue;
00395                }
00396             }
00397          }
00398          else if (AT_OBJ_CLASS(darg_idx) == Pgm_Unit) {
00399             /* not sure this is possible */
00400          }
00401       }
00402 
00403       /* if still here, I found it */
00404 
00405       /* only issue usage rec here if overloaded intrinsic opr. */
00406       /* user defined opers (.opr.) are handled earlier.        */
00407 
00408       if (cif_flags & XREF_RECS &&
00409           IR_OPR(ir_idx) != Defined_Bin_Opr &&
00410           IR_OPR(ir_idx) != Defined_Un_Opr) {
00411 
00412          cif_usage_rec(gen_idx, AT_Tbl_Idx, line, col, CIF_Symbol_Reference);
00413       }
00414 
00415       if (ATP_SCP_IDX(spec_idx) != curr_scp_idx || AT_NOT_VISIBLE(spec_idx)) {
00416 
00417          /* Not visible is checked, because a not visible procedure */
00418          /* may be referenced via its interface name, even though   */
00419          /* it cannot be referenced via its own name.               */
00420 
00421          attr_idx = srch_sym_tbl(AT_OBJ_NAME_PTR(spec_idx),
00422                                  AT_NAME_LEN(spec_idx),
00423                                  &name_idx);
00424 
00425          if (attr_idx != spec_idx) {
00426 
00427             /* This attr is not in this scope.  It is either host associated */
00428             /* here, via the interface block, or it is USE_ASSOCIATED, but   */
00429             /* is not in the local symbol table.                             */
00430 
00431             ADD_ATTR_TO_LOCAL_LIST(spec_idx);
00432          }
00433       }
00434 
00435       AT_REFERENCED(spec_idx) = Referenced;
00436 
00437       if (exp_desc_l->reference           &&
00438           (cif_flags & XREF_RECS) != 0    &&
00439           xref_state != CIF_No_Usage_Rec) {
00440 
00441          COPY_OPND(tmp_opnd, arg_1_opnd);
00442 
00443          while (OPND_FLD(tmp_opnd)         == IR_Tbl_Idx  &&
00444                 IR_OPR(OPND_IDX(tmp_opnd)) != Struct_Opr) {
00445 
00446             COPY_OPND(tmp_opnd, IR_OPND_L(OPND_IDX(tmp_opnd)));
00447          }
00448 
00449          find_opnd_line_and_column(&tmp_opnd, &opnd_line, &opnd_column);
00450 
00451          cif_usage_rec(OPND_IDX(tmp_opnd), 
00452                        OPND_FLD(tmp_opnd), 
00453                        opnd_line,
00454                        opnd_column,
00455                        CIF_Symbol_Defined_Opr_Actual_Arg);
00456       }
00457 
00458       NTR_IR_LIST_TBL(list1_idx);
00459       IL_ARG_DESC_VARIANT(list1_idx) = TRUE;
00460       COPY_OPND(IL_OPND(list1_idx), arg_1_opnd);
00461 
00462       info_idx                               = arg_info_list_base + 1;
00463       arg_info_list[info_idx]                = init_arg_info;
00464       arg_info_list[info_idx].ed             = *exp_desc_l;
00465       arg_info_list[info_idx].maybe_modified = TRUE;
00466       IL_ARG_DESC_IDX(list1_idx)             = info_idx;
00467    
00468       if (num_args == 2) {
00469 
00470          if (exp_desc_r->reference           &&
00471              (cif_flags & XREF_RECS) != 0    &&
00472              xref_state != CIF_No_Usage_Rec) {
00473 
00474             COPY_OPND(tmp_opnd, arg_2_opnd);
00475 
00476             while (OPND_FLD(tmp_opnd)         == IR_Tbl_Idx  &&
00477                    IR_OPR(OPND_IDX(tmp_opnd)) != Struct_Opr) {
00478 
00479                COPY_OPND(tmp_opnd, IR_OPND_L(OPND_IDX(tmp_opnd)));
00480             }
00481 
00482             find_opnd_line_and_column(&tmp_opnd, &opnd_line, &opnd_column);
00483 
00484             cif_usage_rec(OPND_IDX(tmp_opnd),
00485                           OPND_FLD(tmp_opnd), 
00486                           opnd_line,
00487                           opnd_column,
00488                           CIF_Symbol_Defined_Opr_Actual_Arg);
00489          }
00490 
00491 
00492          NTR_IR_LIST_TBL(list2_idx);
00493          IL_ARG_DESC_VARIANT(list2_idx) = TRUE;
00494          COPY_OPND(IL_OPND(list2_idx), arg_2_opnd);
00495          IL_NEXT_LIST_IDX(list1_idx) = list2_idx;
00496 
00497          info_idx++;
00498 
00499          arg_info_list[info_idx]                = init_arg_info;
00500          arg_info_list[info_idx].ed             = *exp_desc_r;
00501          arg_info_list[info_idx].maybe_modified = TRUE;
00502          IL_ARG_DESC_IDX(list2_idx)             = info_idx;
00503       }
00504 
00505       IR_FLD_L(ir_idx)         = AT_Tbl_Idx;
00506       IR_IDX_L(ir_idx)         = spec_idx;
00507       IR_LINE_NUM_L(ir_idx)    = IR_LINE_NUM(ir_idx);
00508       IR_COL_NUM_L(ir_idx)     = IR_COL_NUM(ir_idx);
00509       IR_FLD_R(ir_idx)         = IL_Tbl_Idx;
00510       IR_IDX_R(ir_idx)         = list1_idx;
00511       IR_LIST_CNT_R(ir_idx)    = num_args;
00512       IR_OPR(ir_idx)           = Call_Opr;
00513       /* set the type to short typeless for now. */
00514       /* will be changed later.                  */
00515       IR_TYPE_IDX(ir_idx)      = TYPELESS_DEFAULT_TYPE;
00516 
00517       if (defer_stmt_expansion) {
00518          number_of_functions++;
00519       }
00520 
00521       save_curr_stmt_sh_idx = curr_stmt_sh_idx;
00522 
00523       SCP_HAS_CALLS(curr_scp_idx) = TRUE;
00524 
00525 
00526       /* If Usage records are not being generated, then don't produce a Call  */
00527       /* Site record either.  Example:                */
00528       /*                      */
00529       /*     result = func(arg)                 */
00530       /*                      */
00531       /* where FUNC is a generic identifier pulled in from a module where     */
00532       /* the specific procedure being called is declared something like       */
00533       /*                      */
00534       /*     FUNCTION func(string) RESULT(char)             */
00535       /*                      */
00536       /* where CHAR result depends on the value of an expression like       */
00537       /*                      */
00538       /*     CHARACTER(LEN=SIZE(string%content)) :: char          */
00539       /*                      */
00540       /* As a part of evaluating FUNC, we don't want to see a Call Site       */
00541       /* record generated as a part of processing SIZE (it will also have     */
00542       /* line numbers from the module in its IR tree which are meaningless.   */
00543       /* See also the cif_call_site_rec call in s_call.c.         */
00544    
00545       if ((cif_flags & MISC_RECS) != 0  &&  xref_state != CIF_No_Usage_Rec) {
00546          cif_call_site_rec(ir_idx, gen_idx);
00547       }
00548 
00549       if (AT_OBJ_CLASS(spec_idx)  == Pgm_Unit   &&
00550           ATP_SCP_ALIVE(spec_idx))              {
00551 
00552          if (ATP_PGM_UNIT(spec_idx)  == Function && 
00553              !ATP_RSLT_NAME(spec_idx)) {
00554             PRINTMSG(IR_LINE_NUM(ir_idx), 344, Ansi, IR_COL_NUM(ir_idx));
00555          }
00556 
00557          if (!ATP_RECURSIVE(spec_idx) && !AT_DCL_ERR(spec_idx) &&
00558              !on_off_flags.recursive) {
00559             PRINTMSG(IR_LINE_NUM(ir_idx), 343, Error, IR_COL_NUM(ir_idx));
00560             *semantically_correct = FALSE;
00561          }
00562       }
00563 
00564       if (AT_DCL_ERR(spec_idx)) {
00565          /* don't do any further processing on this bad boy */
00566 
00567          *semantically_correct = FALSE;
00568          curr_stmt_sh_idx = save_curr_stmt_sh_idx;
00569          found = TRUE;
00570          goto EXIT;
00571       }
00572 
00573       stmt_expansion_control_start();
00574       save_defer_stmt_expansion = defer_stmt_expansion;
00575       defer_stmt_expansion = FALSE;
00576 
00577       if (is_function) {
00578 
00579          /* need to do temp and assign here */
00580 
00581          in_call_list   = save_in_call_list;
00582          rslt_idx   = ATP_RSLT_IDX(spec_idx);
00583          (*exp_desc_l)    = init_exp_desc;
00584 
00585          exp_desc_l->type_idx    = ATD_TYPE_IDX(rslt_idx);
00586          exp_desc_l->type        = TYP_TYPE(exp_desc_l->type_idx);
00587          exp_desc_l->linear_type = TYP_LINEAR(exp_desc_l->type_idx);
00588          exp_desc_l->pointer     = ATD_POINTER(rslt_idx);
00589          exp_desc_l->target      = ATD_TARGET(rslt_idx);
00590          exp_desc_l->allocatable = ATD_ALLOCATABLE(rslt_idx);
00591          exp_desc_l->dope_vector = ATD_IM_A_DOPE(rslt_idx);
00592 
00593          IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(rslt_idx);
00594 
00595          if (ATD_ARRAY_IDX(ATP_RSLT_IDX(spec_idx))) {
00596             exp_desc_l->assumed_shape =
00597                     (BD_ARRAY_CLASS(ATD_ARRAY_IDX(rslt_idx)) == Assumed_Shape);
00598             exp_desc_l->assumed_size  =
00599                     (BD_ARRAY_CLASS(ATD_ARRAY_IDX(rslt_idx)) == Assumed_Size);
00600             exp_desc_l->rank = BD_RANK(ATD_ARRAY_IDX(rslt_idx));
00601          }
00602 
00603 
00604          if (!no_func_expansion)   {
00605 
00606             flatten_function_call(opnd);
00607 
00608             if (ATP_ELEMENTAL(spec_idx)) {
00609 
00610                attr_idx = find_base_attr(opnd, &line, &col);
00611                exp_desc_l->rank = BD_RANK(ATD_ARRAY_IDX(attr_idx));
00612             }
00613 
00614 
00615             /* Now that the types for the function result, etc. have been     */
00616             /* resolved, the Object record that represents the function       */
00617             /* result can now be output.                                      */
00618 
00619             if ((cif_flags & MISC_RECS) != 0  && 
00620                 xref_state != CIF_No_Usage_Rec) {
00621                cif_object_rec_for_func_result(spec_idx);
00622             }
00623 
00624             exp_desc_l->tmp_reference = TRUE;
00625 
00626             if (exp_desc_l->type == Character ||
00627                 exp_desc_l->rank)             {
00628 
00629                attr_idx = find_base_attr(opnd, &line, &col);
00630 
00631                if (exp_desc_l->type == Character) {
00632                   IR_TYPE_IDX(ir_idx)      = ATD_TYPE_IDX(attr_idx);
00633                   exp_desc_l->type_idx     = ATD_TYPE_IDX(attr_idx);
00634                   exp_desc_l->type     = TYP_TYPE(exp_desc_l->type_idx);
00635                   exp_desc_l->linear_type  = TYP_LINEAR(exp_desc_l->type_idx);
00636                   get_char_len(opnd, &(exp_desc_l->char_len));
00637                }
00638 
00639                if (exp_desc_l->rank) {
00640                   get_shape_from_attr(exp_desc_l,
00641                                       attr_idx,
00642                                       exp_desc_l->rank,
00643                                       line,
00644                                       col);
00645 
00646                   exp_desc_l->contig_array = TRUE;
00647                }
00648             }
00649          }
00650          else {
00651             set_shape_for_deferred_funcs(exp_desc_l, ir_idx);
00652          }
00653 
00654          IR_TYPE_IDX(ir_idx)  = exp_desc_l->type_idx;
00655          IR_RANK(ir_idx)  = exp_desc_l->rank;
00656       }
00657 
00658       if (!no_func_expansion)   {
00659 
00660          if (! is_function) {
00661             /* this was done for functions under flatten_func_call */
00662 
00663             COPY_OPND(tmp_opnd, IR_OPND_R(ir_idx));
00664             ok = final_arg_work(&tmp_opnd, spec_idx, num_args, NULL) && ok;
00665             COPY_OPND(IR_OPND_R(ir_idx), tmp_opnd);
00666          }
00667 
00668          if (ATP_PROC(spec_idx) != Dummy_Proc &&
00669              ATP_PROC(spec_idx) != Intrin_Proc &&
00670              ! ATP_VFUNCTION(spec_idx) &&
00671              (cmd_line_flags.runtime_argument ||
00672              cmd_line_flags.runtime_arg_call)) {
00673 
00674 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
00675             list1_idx = IR_IDX_R(ir_idx);
00676             list2_idx = NULL_IDX;
00677 
00678             idx = 0;
00679 
00680             while (list1_idx) {
00681                if (IL_FLD(list1_idx) == IR_Tbl_Idx &&
00682                    IR_OPR(IL_IDX(list1_idx)) == False_Parm_Opr) {
00683 
00684                   false_list_idx = list1_idx;
00685 
00686                   IL_NEXT_LIST_IDX(list2_idx) = NULL_IDX;
00687                   break;
00688                }
00689 
00690                list2_idx = list1_idx;
00691                list1_idx = IL_NEXT_LIST_IDX(list1_idx);
00692                idx++;
00693             }
00694 
00695             IR_LIST_CNT_R(ir_idx) = idx;
00696 # endif
00697 
00698             ATP_ARGCHCK_CALL(spec_idx) = TRUE;
00699 
00700             NTR_IR_TBL(loc_idx);
00701             IR_OPR(loc_idx) = Aloc_Opr;
00702             IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
00703             IR_LINE_NUM(loc_idx) = line;
00704             IR_COL_NUM(loc_idx) = col;
00705             IR_FLD_L(loc_idx) = AT_Tbl_Idx;
00706 
00707             OPND_FLD(tmp_opnd) = IR_Tbl_Idx;
00708             OPND_IDX(tmp_opnd) = ir_idx;
00709             idx = create_argchck_descriptor(&tmp_opnd);
00710             IR_IDX_L(loc_idx) = idx;
00711             IR_LINE_NUM_L(loc_idx) = line;
00712             IR_COL_NUM_L(loc_idx) = col;
00713 
00714             NTR_IR_LIST_TBL(list2_idx);
00715             IL_ARG_DESC_VARIANT(list2_idx) = TRUE;
00716             IL_FLD(list2_idx) = IR_Tbl_Idx;
00717             IL_IDX(list2_idx) = loc_idx;
00718 
00719             if (IR_LIST_CNT_R(ir_idx) == 0) {
00720                IR_FLD_R(ir_idx) = IL_Tbl_Idx;
00721                IR_IDX_R(ir_idx) = list2_idx;
00722                IR_LIST_CNT_R(ir_idx) = 1;
00723             }
00724             else {
00725                list1_idx = IR_IDX_R(ir_idx);
00726                while (IL_NEXT_LIST_IDX(list1_idx)) {
00727                   list1_idx = IL_NEXT_LIST_IDX(list1_idx);
00728                }
00729 
00730                IL_NEXT_LIST_IDX(list1_idx) = list2_idx;
00731                (IR_LIST_CNT_R(ir_idx))++;
00732             }
00733 
00734 # if (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
00735             if (false_list_idx != NULL_IDX) {
00736                IL_NEXT_LIST_IDX(list2_idx) = false_list_idx;
00737                list1_idx = false_list_idx;
00738                while (list1_idx) {
00739                   (IR_LIST_CNT_R(ir_idx))++;
00740                   list1_idx = IL_NEXT_LIST_IDX(list1_idx);
00741                }
00742             }
00743 # endif
00744          }
00745       }
00746 
00747       defer_stmt_expansion = save_defer_stmt_expansion;
00748       stmt_expansion_control_end(opnd);
00749 
00750       curr_stmt_sh_idx = save_curr_stmt_sh_idx;
00751 
00752       found = TRUE;
00753       break;
00754    }
00755 
00756 EXIT:
00757 
00758    if (ok && found && (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx)) ||
00759                        ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx)))) {
00760 
00761       if (ATP_PURE(SCP_ATTR_IDX(curr_scp_idx))) {
00762 
00763          if (!ATP_PURE(spec_idx) && !ATP_ELEMENTAL(spec_idx)) {
00764             PRINTMSG(IR_LINE_NUM(ir_idx), 1274, Error, IR_COL_NUM(ir_idx),
00765                      AT_OBJ_NAME_PTR(spec_idx),
00766                      "pure or elemental",
00767                      "pure");
00768 
00769          }
00770       }
00771       else if (ATP_ELEMENTAL(SCP_ATTR_IDX(curr_scp_idx))) {
00772 
00773          if (!ATP_PURE(spec_idx) && !ATP_ELEMENTAL(spec_idx)) {
00774             PRINTMSG(IR_LINE_NUM(ir_idx), 1274, Error, IR_COL_NUM(ir_idx),
00775                      AT_OBJ_NAME_PTR(spec_idx),
00776                      "pure or elemental",
00777                      "elemental");
00778 
00779          }
00780       }
00781 
00782       /* Check to make sure that actual arguments are definable if */
00783       /* the dummy arg has INTENT(out), INTENT(inout) or POINTER.  */
00784 
00785       list_idx  = IR_IDX_R(ir_idx);
00786 
00787       if (ATP_EXTRA_DARG(spec_idx)) {
00788          arg_idx        = ATP_FIRST_IDX(spec_idx) + 1;
00789          idx            = ATP_NUM_DARGS(spec_idx) - 1;
00790       }
00791       else {
00792          arg_idx        = ATP_FIRST_IDX(spec_idx);
00793          idx            = ATP_NUM_DARGS(spec_idx);
00794       }
00795       for (;idx > 0; idx--) {
00796 
00797          if (AT_OBJ_CLASS(SN_ATTR_IDX(arg_idx)) == Data_Obj &&
00798              (ATD_POINTER(SN_ATTR_IDX(arg_idx)) ||
00799               ATD_INTENT(SN_ATTR_IDX(arg_idx)) == Intent_Inout ||
00800               ATD_INTENT(SN_ATTR_IDX(arg_idx)) == Intent_Out)) {
00801             COPY_OPND(tmp_opnd, IL_OPND(list_idx));
00802             attr_idx = find_left_attr(&tmp_opnd);
00803 
00804             if (AT_OBJ_CLASS(attr_idx) == Data_Obj && ATD_PURE(attr_idx)) {
00805                find_opnd_line_and_column((opnd_type *) &IL_OPND(list_idx),
00806                                          &opnd_line,
00807                                          &opnd_column);
00808                PRINTMSG(opnd_line, 1273, Error, opnd_column,
00809                        AT_OBJ_NAME_PTR(attr_idx),
00810                        AT_OBJ_NAME_PTR(SN_ATTR_IDX(arg_idx)),
00811                        ATP_PURE(SCP_ATTR_IDX(curr_scp_idx))?"pure":"elemental");
00812                ok       = FALSE;
00813 
00814 
00815             }
00816          }
00817          arg_idx++;
00818          list_idx       = IL_NEXT_LIST_IDX(list_idx);
00819       }
00820    }
00821 
00822    if (found) {
00823 
00824       /* If spec is not equal to gen, that means the names are not the same. */
00825       /* If the names are not the same, then we didn't actually specify the  */
00826       /* specific name, so we don't care if it is invisible.                 */
00827 
00828       if (spec_idx == gen_idx && AT_NOT_VISIBLE(spec_idx)) {
00829           PRINTMSG(IR_LINE_NUM(ir_idx), 486, Error, 
00830                    IR_COL_NUM(ir_idx),
00831                    AT_OBJ_NAME_PTR(spec_idx),
00832                    AT_OBJ_NAME_PTR(AT_MODULE_IDX((spec_idx))));
00833          *semantically_correct = FALSE;
00834       }
00835 
00836       switch (expr_mode) {
00837          case Restricted_Imp_Do_Expr:
00838          case Data_Stmt_Target_Expr:
00839             PRINTMSG(IR_LINE_NUM(ir_idx), 62, Error, 
00840                      IR_COL_NUM(ir_idx),
00841                      str_word);
00842             *semantically_correct = FALSE;
00843             break;
00844 
00845          case Specification_Expr:
00846             PRINTMSG(IR_LINE_NUM(ir_idx), 880, Error,
00847                      IR_COL_NUM(ir_idx),
00848                      str_word);
00849             *semantically_correct = FALSE;
00850             break;
00851 
00852          case Stmt_Func_Expr:
00853             PRINTMSG(IR_LINE_NUM(ir_idx), 757, Error,
00854                      IR_COL_NUM(ir_idx),
00855                      str_word);
00856             *semantically_correct = FALSE;
00857             break;
00858       }
00859    }
00860    else if (issue_msg) {
00861 
00862       if (gen_idx != NULL_IDX)  {
00863          PRINTMSG(IR_LINE_NUM(ir_idx), 380, Error, 
00864                    IR_COL_NUM(ir_idx), str_word);
00865          *semantically_correct = FALSE;
00866       }
00867       else {
00868       
00869          if (exp_desc_l->linear_type == Long_Typeless ||
00870              (num_args == 2 && exp_desc_r->linear_type == Long_Typeless)) {
00871 
00872             if (exp_desc_l->linear_type == Long_Typeless) {
00873                find_opnd_line_and_column((opnd_type *) &IR_OPND_L(ir_idx),
00874                                          &opnd_line,
00875                                          &opnd_column);
00876                PRINTMSG(opnd_line, 1133, Error, opnd_column);
00877                *semantically_correct = FALSE;
00878             }
00879 
00880             if (num_args == 2 &&
00881                 exp_desc_r->linear_type == Long_Typeless) {
00882                find_opnd_line_and_column((opnd_type *) &IR_OPND_R(ir_idx),
00883                                          &opnd_line,
00884                                          &opnd_column);
00885                PRINTMSG(opnd_line, 1133, Error, opnd_column);
00886                *semantically_correct = FALSE;
00887             }
00888          }
00889          else if (! is_function) { /* assignment */
00890 
00891             if (exp_desc_r->rank != exp_desc_l->rank && exp_desc_r->rank != 0) {
00892 
00893                /* rank error */
00894 
00895                PRINTMSG(IR_LINE_NUM(ir_idx), 324, Error, IR_COL_NUM(ir_idx),
00896                         exp_desc_r->rank, exp_desc_l->rank);
00897                *semantically_correct = FALSE;
00898             }
00899 
00900             if (err_res) {
00901                strcpy(type_str_l, get_basic_type_str(exp_desc_l->type_idx));
00902                strcpy(type_str_r, get_basic_type_str(exp_desc_r->type_idx));
00903 
00904                PRINTMSG(IR_LINE_NUM(ir_idx), 356, Error,
00905                         IR_COL_NUM(ir_idx),
00906                         type_str_r,
00907                         type_str_l);
00908                *semantically_correct = FALSE;
00909             }
00910          }
00911          else if (expr_mode == Restricted_Imp_Do_Expr ||
00912                   expr_mode == Data_Stmt_Target_Expr) {
00913 
00914             PRINTMSG(IR_LINE_NUM(ir_idx), 62, Error,
00915                      IR_COL_NUM(ir_idx), str_word);
00916             *semantically_correct = FALSE;
00917          }
00918          else if (num_args == 1) { /* unary operator */
00919 
00920             PRINTMSG(IR_LINE_NUM(ir_idx), 392, Error,
00921                      IR_COL_NUM(ir_idx), 
00922                      get_basic_type_str(exp_desc_l->type_idx),
00923                      str_word);
00924             *semantically_correct = FALSE;
00925          }
00926          else {
00927             /* binary operator */
00928 
00929             if (exp_desc_r->rank != exp_desc_l->rank      &&
00930                 exp_desc_r->rank * exp_desc_l->rank != 0) {
00931 
00932                /* rank error */
00933 
00934                PRINTMSG(IR_LINE_NUM(ir_idx), 302, Error, IR_COL_NUM(ir_idx),
00935                         exp_desc_l->rank, exp_desc_r->rank, str_word);
00936                *semantically_correct = FALSE;
00937             }
00938 
00939             if (err_res) {
00940 
00941 #ifdef KEY /* Bug 5710, 8094 */
00942        /* If we're allowing intrinsic .eq. on logical operands as an
00943         * extension, the absence of an overloaded function is not an
00944         * error; we'll return to our caller who will use the intrinsic
00945         * operator. */
00946        if (!((Eq_Opr == IR_OPR(ir_idx) || Ne_Opr == IR_OPR(ir_idx)) &&
00947          eq_ne_on_logical(0, exp_desc_l, exp_desc_r))) {
00948 #endif /* KEY Bug 5710, 8094 */
00949 
00950                strcpy(type_str_l, get_basic_type_str(exp_desc_l->type_idx));
00951                strcpy(type_str_r, get_basic_type_str(exp_desc_r->type_idx));
00952 
00953                PRINTMSG(IR_LINE_NUM(ir_idx), 303, Error,
00954                         IR_COL_NUM(ir_idx),
00955                         type_str_l,
00956                         type_str_r,
00957                         str_word);
00958                *semantically_correct = FALSE;
00959 #ifdef KEY /* Bug 5710 */
00960        }
00961 #endif /* KEY Bug 5710 */
00962             }
00963          }
00964       }
00965    }
00966 
00967    if (*semantically_correct &&
00968        found &&
00969        ATP_PROC(spec_idx) != Intrin_Proc) {
00970 
00971 #ifdef KEY /* Bug 7726 */
00972       /* Fortran 95 says every elemental procedure is pure */
00973       if (! (ATP_PURE(spec_idx) || ATP_ELEMENTAL(spec_idx)))
00974 #else /* KEY Bug 7726 */
00975       if (! ATP_PURE(spec_idx))
00976 #endif /* KEY Bug 7726 */
00977       {
00978          if (within_forall_mask_expr) {
00979             PRINTMSG(IR_LINE_NUM(ir_idx), 1611, Error, IR_COL_NUM(ir_idx), 
00980                      AT_OBJ_NAME_PTR(spec_idx),
00981                      "forall scalar-mask-expr");
00982             *semantically_correct = FALSE;
00983          }
00984          else if (within_forall_construct) {
00985             PRINTMSG(IR_LINE_NUM(ir_idx), 1611, Error, IR_COL_NUM(ir_idx), 
00986                      AT_OBJ_NAME_PTR(spec_idx),
00987                      "forall-body-construct");
00988             *semantically_correct = FALSE;
00989          }
00990       }
00991    }
00992 
00993    if (found) {
00994       PRINTMSG(IR_LINE_NUM(ir_idx), 399, Comment, IR_COL_NUM(ir_idx),
00995                str_word, AT_OBJ_NAME_PTR(spec_idx));
00996    }
00997 
00998    /* restore arg_info_list to previous "stack frame" */
00999 
01000    arg_info_list_top  = arg_info_list_base;
01001    arg_info_list_base = save_arg_info_list_base;
01002 
01003    TRACE (Func_Exit, "resolve_ext_opr", NULL);
01004 
01005    return(found);
01006 
01007 }  /* resolve_ext_opr */
01008 
01009 /******************************************************************************\
01010 |*                        *|
01011 |* Description:                     *|
01012 |*  Return a string for any expression opr.                               *|
01013 |*                        *|
01014 |* Input parameters:                    *|
01015 |*  opr - the operator.                                                   *|
01016 |*                        *|
01017 |* Output parameters:                   *|
01018 |*  str - the string.                                                     *|
01019 |*                        *|
01020 |* Returns:                     *|
01021 |*  length of str                   *|
01022 |*                        *|
01023 \******************************************************************************/
01024 
01025 static int  opr_to_str(operator_type  opr,
01026                        char        *str)
01027 
01028 {
01029    int  i;
01030    int  len = 0;
01031 
01032    TRACE (Func_Entry, "opr_to_str", NULL);
01033 
01034    for (i = 0; i < 8; i++) {
01035       str[i] = '\0';
01036    }
01037 
01038    switch (opr) {
01039       case Uplus_Opr  :
01040          strncpy(str, "+", 1);
01041          len = 1;
01042          break;
01043       case Uminus_Opr :
01044          strncpy(str, "-", 1);
01045          len = 1;
01046          break;
01047       case Power_Opr  :
01048          strncpy(str, "**", 2);
01049          len = 2;
01050          break;
01051       case Mult_Opr   :
01052          strncpy(str, "*", 1);
01053          len = 1;
01054          break;
01055       case Div_Opr    :
01056          strncpy(str, "/", 1);
01057          len = 1;
01058          break;
01059       case Plus_Opr   :
01060          strncpy(str, "+", 1);
01061          len = 1;
01062          break;
01063       case Minus_Opr  :
01064          strncpy(str, "-", 1);
01065          len = 1;
01066          break;
01067       case Concat_Opr :
01068          strncpy(str, "//", 2);
01069          len = 2;
01070          break;
01071       case Eq_Opr     :
01072          strncpy(str, "eq", 2);
01073          len = 2;
01074          break;
01075       case Ne_Opr     :
01076          strncpy(str, "ne", 2);
01077          len = 2;
01078          break;
01079       case Lg_Opr     :
01080          strncpy(str, "lg", 2);
01081          len = 2;
01082          break;
01083       case Lt_Opr     :
01084          strncpy(str, "lt", 2);
01085          len = 2;
01086          break;
01087       case Le_Opr     :
01088          strncpy(str, "le", 2);
01089          len = 2;
01090          break;
01091       case Gt_Opr     :
01092          strncpy(str, "gt", 2);
01093          len = 2;
01094          break;
01095       case Ge_Opr     :
01096          strncpy(str, "ge", 2);
01097          len = 2;
01098          break;
01099       case Not_Opr    :
01100          strncpy(str, "not", 3);
01101          len = 3;
01102          break;
01103       case And_Opr    :
01104          strncpy(str, "and", 3);
01105          len = 3;
01106          break;
01107       case Or_Opr     :
01108          strncpy(str, "or", 2);
01109          len = 2;
01110          break;
01111       case Eqv_Opr    :
01112          strncpy(str, "eqv", 3);
01113          len = 3;
01114          break;
01115       case Neqv_Opr   :
01116          strncpy(str, "neqv", 4);
01117          len = 4;
01118          break;
01119       case Asg_Opr    :
01120          strncpy(str, "=", 1);
01121          len = 1;
01122          break;
01123    }
01124 
01125    TRACE (Func_Exit, "opr_to_str", NULL);
01126 
01127    return(len);
01128 
01129 }  /* opr_to_str */
01130 
01131 /******************************************************************************\
01132 |*                        *|
01133 |* Description:                     *|
01134 |*  finds the base attr pointer from reference tree.                      *|
01135 |*  The difference between find_base_attr and find_left_attr is:          *|
01136 |*                        *|
01137 |*       a%b%c(1:10)(1:3)                                                     *|
01138 |*                        *|
01139 |*       find_base_attr finds 'c'                                             *|
01140 |*       find_left_attr finds 'a'                                             *|
01141 |*                        *|
01142 |* Input parameters:                    *|
01143 |*  NONE                      *|
01144 |*                        *|
01145 |* Output parameters:                   *|
01146 |*  NONE                      *|
01147 |*                        *|
01148 |* Returns:                     *|
01149 |*  NOTHING                     *|
01150 |*                        *|
01151 \******************************************************************************/
01152 
01153 int find_base_attr(opnd_type       *root_opnd,
01154                        int         *line,
01155                        int         *col)
01156 
01157 {
01158    int    attr_idx = NULL_IDX;
01159    opnd_type  opnd;
01160 
01161    TRACE (Func_Entry, "find_base_attr", NULL);
01162 
01163    *line = 0;
01164    *col  = 0;
01165 
01166    COPY_OPND(opnd, (*root_opnd));
01167 
01168    while (attr_idx == NULL_IDX) {
01169       switch (OPND_FLD(opnd)) {
01170          case AT_Tbl_Idx :
01171             attr_idx = OPND_IDX(opnd);
01172             *line    = OPND_LINE_NUM(opnd);
01173             *col     = OPND_COL_NUM(opnd);
01174             goto EXIT;
01175 
01176          case IR_Tbl_Idx :
01177 
01178             if (IR_OPR(OPND_IDX(opnd)) == Struct_Opr) {
01179                COPY_OPND(opnd, IR_OPND_R(OPND_IDX(opnd)));
01180             }
01181             else {
01182                COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
01183             }
01184             break;
01185 
01186          case CN_Tbl_Idx :
01187             *line = OPND_LINE_NUM(opnd);
01188             *col  = OPND_COL_NUM(opnd);
01189             goto EXIT;
01190 
01191          default         :
01192             goto EXIT;
01193       }
01194    }
01195    
01196 EXIT:
01197 
01198    TRACE (Func_Exit, "find_base_attr", ((attr_idx == NULL_IDX) ? NULL :
01199                                         AT_OBJ_NAME_PTR(attr_idx)));
01200 
01201    return(attr_idx);
01202 
01203 }  /* find_base_attr */
01204 
01205 /******************************************************************************\
01206 |*                        *|
01207 |* Description:                     *|
01208 |*  Find the left most attr in a reference tree.                          *|
01209 |*                        *|
01210 |*  The difference between find_base_attr and find_left_attr is:          *|
01211 |*                        *|
01212 |*       a%b%c(1:10)(1:3)                                                     *|
01213 |*                        *|
01214 |*       find_base_attr finds 'c'                                             *|
01215 |*       find_left_attr finds 'a'                                             *|
01216 |*                        *|
01217 |* Input parameters:                    *|
01218 |*  NONE                      *|
01219 |*                        *|
01220 |* Output parameters:                   *|
01221 |*  NONE                      *|
01222 |*                        *|
01223 |* Returns:                     *|
01224 |*  NOTHING                     *|
01225 |*                        *|
01226 \******************************************************************************/
01227 
01228 int find_left_attr(opnd_type *root_opnd)
01229 
01230 {
01231    int          attr_idx = NULL_IDX;
01232    opnd_type    opnd;
01233 
01234 
01235    TRACE (Func_Entry, "find_left_attr", NULL);
01236 
01237    COPY_OPND(opnd, (*root_opnd));
01238 
01239    while (attr_idx == NULL_IDX) {
01240       switch (OPND_FLD(opnd)) {
01241          case AT_Tbl_Idx :
01242             attr_idx = OPND_IDX(opnd);
01243             goto EXIT;
01244 
01245          case IR_Tbl_Idx :
01246 
01247             COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
01248             break;
01249 
01250          default         :
01251             goto EXIT;
01252       }
01253    }
01254 
01255 EXIT:
01256 
01257    TRACE (Func_Exit, "find_left_attr", NULL);
01258 
01259    return(attr_idx);
01260 
01261 }  /* find_left_attr */
01262 
01263 /******************************************************************************\
01264 |*                                                                            *|
01265 |* Description:                                                               *|
01266 |*      Compares reference subtrees to see if they reference the same object. *|
01267 |*                                                                            *|
01268 |* Input parameters:                                                          *|
01269 |*      opnd1, opnd2 - the roots of the two trees.                            *|
01270 |*                                                                            *|
01271 |* Output parameters:                                                         *|
01272 |*      NONE                                                                  *|
01273 |*                                                                            *|
01274 |* Returns:                                                                   *|
01275 |*      TRUE for match.                                                       *|
01276 |*                                                                            *|
01277 \******************************************************************************/
01278 
01279 boolean cmp_ref_trees(opnd_type *opnd1,
01280                       opnd_type *opnd2)
01281 
01282 {
01283    int    column;
01284    int    line;
01285    int    list1_idx;
01286    int    list2_idx;
01287    boolean  match   = TRUE;
01288 
01289 
01290    TRACE (Func_Entry, "cmp_ref_trees", NULL);
01291 
01292    if (OPND_FLD((*opnd1)) != OPND_FLD((*opnd2))) {
01293       match = FALSE;
01294    }
01295    else {
01296       switch(OPND_FLD((*opnd1))) {
01297          case NO_Tbl_Idx   :
01298             match = TRUE;
01299             break;
01300 
01301          case CN_Tbl_Idx :
01302          case AT_Tbl_Idx :
01303 
01304             if (OPND_IDX((*opnd1)) == OPND_IDX((*opnd2))) {
01305                match = TRUE;
01306             }
01307             else {
01308                match = FALSE;
01309             }
01310             break;
01311 
01312          case IL_Tbl_Idx :
01313 
01314             if (OPND_LIST_CNT((*opnd1)) == OPND_LIST_CNT((*opnd2))) {
01315                list1_idx = OPND_IDX((*opnd1));
01316                list2_idx = OPND_IDX((*opnd2));
01317 
01318                while (list1_idx != NULL_IDX && match) {
01319                   match = cmp_ref_trees((opnd_type *)&IL_OPND(list1_idx),
01320                                         (opnd_type *)&IL_OPND(list2_idx));
01321                   list1_idx = IL_NEXT_LIST_IDX(list1_idx);
01322                   list2_idx = IL_NEXT_LIST_IDX(list2_idx);
01323                }
01324             }
01325             else {
01326                match = FALSE;
01327             }
01328             break;
01329 
01330          case SH_Tbl_Idx :
01331             find_opnd_line_and_column(opnd1, &line, &column);
01332             PRINTMSG(line, 963, Internal, column);
01333             break;
01334 
01335          case IR_Tbl_Idx :
01336 
01337             if (IR_OPR(OPND_IDX((*opnd1))) == IR_OPR(OPND_IDX((*opnd2)))) { 
01338                match = cmp_ref_trees((opnd_type*)&IR_OPND_L(OPND_IDX((*opnd1))),
01339                                     (opnd_type*)&IR_OPND_L(OPND_IDX((*opnd2))));
01340                match = match &&
01341                      cmp_ref_trees((opnd_type *)&IR_OPND_R(OPND_IDX((*opnd1))),
01342                                    (opnd_type *)&IR_OPND_R(OPND_IDX((*opnd2))));
01343             }
01344             else {
01345                match = FALSE;
01346             }
01347             break;
01348       }
01349    }
01350 
01351    TRACE (Func_Exit, "cmp_ref_trees", NULL);
01352 
01353    return(match);
01354 
01355 }  /* cmp_ref_trees */
01356 
01357 /******************************************************************************\
01358 |*                        *|
01359 |* Description:                     *|
01360 |*  malloc or realloc the call list arrays.                               *|
01361 |*                        *|
01362 |* Input parameters:                    *|
01363 |*  NONE                      *|
01364 |*                        *|
01365 |* Output parameters:                   *|
01366 |*  NONE                      *|
01367 |*                        *|
01368 |* Returns:                     *|
01369 |*  NOTHING                     *|
01370 |*                        *|
01371 \******************************************************************************/
01372 
01373 void enlarge_call_list_tables(void)
01374 
01375 {
01376    int    new_size;
01377 
01378    TRACE (Func_Entry, "enlarge_call_list_tables", NULL);
01379 
01380    /* CALL_LIST_TBL_INC defined in s_utils.m */
01381    new_size = ((max_call_list_size/CALL_LIST_TBL_INC) + 1)
01382               * CALL_LIST_TBL_INC;
01383 
01384    if (arg_list_size == 0) {
01385 
01386       /* must do original malloc */
01387 
01388       MEM_ALLOC(arg_list, int, new_size);
01389 
01390    }
01391    else { /* do realloc */
01392 
01393       MEM_REALLOC(arg_list, int, new_size);
01394 
01395    }
01396 
01397    arg_list_size = new_size;
01398 
01399    TRACE (Func_Exit, "enlarge_call_list_tables", NULL);
01400 
01401    return;
01402 
01403 }  /* enlarge_call_list_tables */
01404 
01405 /******************************************************************************\
01406 |*                        *|
01407 |* Description:                     *|
01408 |*  Table manager for arg_info_list table.                                *|
01409 |*                        *|
01410 |* Input parameters:                    *|
01411 |*  NONE                      *|
01412 |*                        *|
01413 |* Output parameters:                   *|
01414 |*  NONE                      *|
01415 |*                        *|
01416 |* Returns:                     *|
01417 |*  NOTHING                     *|
01418 |*                        *|
01419 \******************************************************************************/
01420 
01421 void enlarge_info_list_table(void)
01422 
01423 {
01424    int          new_size;
01425 
01426    TRACE (Func_Entry, "enlarge_info_list_table", NULL);
01427 
01428    /* CALL_LIST_TBL_INC defined in s_utils.m */
01429    new_size = arg_info_list_size + ((max_call_list_size/CALL_LIST_TBL_INC) + 1)
01430               * CALL_LIST_TBL_INC;
01431 
01432    if (arg_info_list_size == 0) {
01433 
01434       /* must do original malloc */
01435 
01436       MEM_ALLOC(arg_info_list, arg_strct_type, new_size);
01437 
01438    }
01439    else { /* do realloc */
01440 
01441       MEM_REALLOC(arg_info_list, arg_strct_type, new_size);
01442 
01443    }
01444 
01445    arg_info_list_size = new_size;
01446 
01447    TRACE (Func_Exit, "enlarge_info_list_table", NULL);
01448 
01449    return;
01450 
01451 }  /* enlarge_info_list_table */
01452 
01453 /******************************************************************************\
01454 |*                        *|
01455 |* Description:                     *|
01456 |*  Creates all the dope vector assignments for a ptr assign from a target*|
01457 |*                        *|
01458 |* Input parameters:                    *|
01459 |*  NONE                      *|
01460 |*                        *|
01461 |* Output parameters:                   *|
01462 |*  NONE                      *|
01463 |*                        *|
01464 |* Returns:                     *|
01465 |*  NOTHING                     *|
01466 |*                        *|
01467 \******************************************************************************/
01468 
01469 void dope_vector_setup(opnd_type  *r_opnd,
01470                         expr_arg_type *exp_desc,
01471             opnd_type *l_opnd,
01472             boolean    ptr_assign)
01473 
01474 {
01475    act_arg_type a_type;
01476    int    attr_idx = NULL_IDX;
01477    opnd_type  base_opnd;
01478    int    col;
01479    int          dim = 1;
01480    int    dope_idx = NULL_IDX;
01481    int    dv_idx;
01482    int    dv2_idx;
01483    int    i;
01484    int    line;
01485    int    list_idx;
01486    int    loc_idx;
01487    int    max_idx;
01488    int    mult_idx;
01489    opnd_type    opnd;
01490    int    opnd_column;
01491    int    opnd_line;
01492    opnd_type  r_dv_opnd;
01493    int          rank_idx = NULL_IDX;
01494    int    stride_idx;
01495    opnd_type  stride_opnd;
01496 #ifdef KEY /* Bug 10177 */
01497    int    subscript_idx = 0;
01498 #else /* KEY Bug 10177 */
01499    int    subscript_idx;
01500 #endif /* KEY Bug 10177 */
01501    boolean      whole_array;
01502 
01503 
01504    TRACE (Func_Entry, "dope_vector_setup", NULL);
01505 
01506    /* This routine expects the left operand to be a dope vector */
01507    /* reference. Either an attr or a Struct_Opr                 */
01508 
01509     find_opnd_line_and_column(l_opnd, &opnd_line, &opnd_column);
01510 
01511 # ifdef _DEBUG
01512 
01513    if (OPND_FLD((*l_opnd)) != AT_Tbl_Idx &&
01514        (OPND_FLD((*l_opnd)) != IR_Tbl_Idx || 
01515         IR_OPR(OPND_IDX((*l_opnd))) != Struct_Opr)) {
01516        PRINTMSG(opnd_line, 624, Internal, opnd_column);
01517    }
01518 # endif
01519    /********************\
01520    |* set BASE address *|
01521    \********************/
01522 
01523 
01524    if (! ptr_assign) {
01525       NTR_IR_TBL(dv_idx);
01526       IR_OPR(dv_idx) = Dv_Set_Base_Addr;
01527       IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
01528       IR_LINE_NUM(dv_idx) = opnd_line;
01529       IR_COL_NUM(dv_idx)  = opnd_column;
01530       COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01531       NTR_IR_TBL(loc_idx);
01532       IR_OPR(loc_idx)  = Loc_Opr;
01533 
01534       if (exp_desc->type == Character) {
01535          IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
01536       }
01537       else {
01538          IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
01539       }
01540 
01541       IR_LINE_NUM(loc_idx) = opnd_line;
01542       IR_COL_NUM(loc_idx)  = opnd_column;
01543 
01544       IR_FLD_R(dv_idx) = IR_Tbl_Idx;
01545       IR_IDX_R(dv_idx) = loc_idx;
01546    
01547       if (exp_desc->rank == 0) {
01548          COPY_OPND(IR_OPND_L(loc_idx), (*r_opnd));
01549          just_find_dope_and_rank(r_opnd, &rank_idx, &dope_idx);
01550       }
01551       else {
01552          make_base_subtree(r_opnd, &base_opnd, &rank_idx, &dope_idx);
01553          COPY_OPND(IR_OPND_L(loc_idx), base_opnd);
01554       }
01555 
01556 # ifdef _TRANSFORM_CHAR_SEQUENCE
01557 # ifdef _TARGET_OS_UNICOS
01558       if (exp_desc->type == Structure &&
01559           ATT_CHAR_SEQ(TYP_IDX(exp_desc->type_idx))) {
01560 
01561          IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
01562          COPY_OPND(opnd, IR_OPND_L(loc_idx));
01563          transform_char_sequence_ref(&opnd, exp_desc->type_idx);
01564          COPY_OPND(IR_OPND_L(loc_idx), opnd);
01565       }
01566 # endif
01567 # endif
01568 
01569       gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01570                    FALSE, FALSE, TRUE);
01571 
01572       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01573       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01574 
01575    }
01576    else {
01577       just_find_dope_and_rank(r_opnd, &rank_idx, &dope_idx);
01578    }
01579 
01580 
01581 
01582    /*************************\
01583    |* check for whole array *|
01584    \*************************/
01585 
01586    if (rank_idx != NULL_IDX) {
01587       attr_idx      = find_base_attr(&IR_OPND_L(rank_idx), &line, &col);
01588 
01589       if (ATD_IM_A_DOPE(attr_idx)) {
01590          COPY_OPND(r_dv_opnd, IR_OPND_L(IR_IDX_L(rank_idx)));
01591       }
01592       subscript_idx = IR_IDX_R(rank_idx);
01593    }
01594    else if (exp_desc->rank != 0)              {
01595       attr_idx    = find_base_attr(r_opnd, &line, &col);
01596  
01597       if (ATD_IM_A_DOPE(attr_idx)) {
01598          COPY_OPND(r_dv_opnd, IR_OPND_L(OPND_IDX((*r_opnd))));
01599       }
01600    }
01601    else {
01602       find_opnd_line_and_column(r_opnd, &line, &col);
01603    }
01604 
01605    if (exp_desc->rank > 0 &&
01606        ! exp_desc->section) {
01607 
01608       whole_array = TRUE;
01609    }
01610    else {
01611       whole_array = FALSE;
01612    }
01613 
01614    /*************************\
01615    |* set the a_contig flag *|
01616    \*************************/
01617 
01618    a_type = get_act_arg_type(exp_desc);
01619 
01620    if (a_type == Array_Ptr ||
01621        a_type == Array_Tmp_Ptr ||
01622        a_type == Whole_Ass_Shape ||
01623        a_type == Dv_Contig_Section) {
01624 
01625       NTR_IR_TBL(dv_idx);
01626       IR_OPR(dv_idx) = Dv_Set_A_Contig;
01627       IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
01628       IR_LINE_NUM(dv_idx) = opnd_line;
01629       IR_COL_NUM(dv_idx)  = opnd_column;
01630       COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01631 
01632       NTR_IR_TBL(dv2_idx);
01633       IR_OPR(dv2_idx) = Dv_Access_A_Contig;
01634       IR_TYPE_IDX(dv2_idx)   = CG_INTEGER_DEFAULT_TYPE;
01635       IR_LINE_NUM(dv2_idx) = opnd_line;
01636       IR_COL_NUM(dv2_idx)  = opnd_column;
01637       COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
01638       IR_FLD_R(dv_idx) = IR_Tbl_Idx;
01639       IR_IDX_R(dv_idx) = dv2_idx;
01640 
01641       gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01642                       FALSE, FALSE, TRUE);
01643 
01644       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01645       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01646 
01647    }
01648    else if (a_type == Whole_Allocatable ||
01649             a_type == Whole_Tmp_Allocatable ||
01650             a_type == Whole_Sequence ||
01651             a_type == Whole_Tmp_Sequence ||
01652             a_type == Whole_Array_Constant ||
01653             a_type == Contig_Section) {
01654 
01655       NTR_IR_TBL(dv_idx);
01656       IR_OPR(dv_idx) = Dv_Set_A_Contig;
01657       IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
01658       IR_LINE_NUM(dv_idx) = opnd_line;
01659       IR_COL_NUM(dv_idx)  = opnd_column;
01660       COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01661       IR_FLD_R(dv_idx) = CN_Tbl_Idx;
01662       IR_IDX_R(dv_idx) = CN_INTEGER_ONE_IDX;
01663       IR_LINE_NUM_R(dv_idx) = opnd_line;
01664       IR_COL_NUM_R(dv_idx)  = opnd_column;
01665 
01666       gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01667                       FALSE, FALSE, TRUE);
01668 
01669       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01670       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01671    }
01672    else {
01673       NTR_IR_TBL(dv_idx);
01674       IR_OPR(dv_idx) = Dv_Set_A_Contig;
01675       IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
01676       IR_LINE_NUM(dv_idx) = opnd_line;
01677       IR_COL_NUM(dv_idx)  = opnd_column;
01678       COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01679       IR_FLD_R(dv_idx) = CN_Tbl_Idx;
01680       IR_IDX_R(dv_idx) = CN_INTEGER_ZERO_IDX;
01681       IR_LINE_NUM_R(dv_idx) = opnd_line;
01682       IR_COL_NUM_R(dv_idx)  = opnd_column;
01683 
01684       gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01685                       FALSE, FALSE, TRUE);
01686 
01687       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01688       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01689    }
01690         
01691    /******************\
01692    |* set ASSOC flag *|
01693    \******************/
01694 
01695    NTR_IR_TBL(dv_idx);
01696    IR_OPR(dv_idx) = Dv_Set_Assoc;
01697    IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
01698    IR_LINE_NUM(dv_idx) = opnd_line;
01699    IR_COL_NUM(dv_idx)  = opnd_column;
01700    COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01701    IR_FLD_R(dv_idx) = CN_Tbl_Idx;
01702    IR_IDX_R(dv_idx) = CN_INTEGER_ONE_IDX;
01703    IR_LINE_NUM_R(dv_idx) = opnd_line;
01704    IR_COL_NUM_R(dv_idx)  = opnd_column;
01705 
01706    gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01707                    FALSE, FALSE, TRUE);
01708 
01709    SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01710    SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01711 
01712 
01713    for (i = 1; i <= exp_desc->rank; i++) {
01714 
01715       /************************************\
01716       |* set LOW_BOUND for each dimension *|
01717       \************************************/
01718 
01719       NTR_IR_TBL(dv_idx);
01720       IR_OPR(dv_idx) = Dv_Set_Low_Bound;
01721       IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
01722       IR_LINE_NUM(dv_idx) = opnd_line;
01723       IR_COL_NUM(dv_idx)  = opnd_column;
01724       COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01725 
01726       if (whole_array) {
01727          /* need arrays low bound */
01728          if (ATD_IM_A_DOPE(attr_idx) &&
01729              BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) != Assumed_Shape) {
01730             NTR_IR_TBL(dv2_idx);
01731             IR_OPR(dv2_idx)    = Dv_Access_Low_Bound;
01732             IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE;
01733             IR_LINE_NUM(dv2_idx) = opnd_line;
01734             IR_COL_NUM(dv2_idx)  = opnd_column;
01735             COPY_OPND(IR_OPND_L(dv2_idx), r_dv_opnd);
01736             IR_DV_DIM(dv2_idx) = i;
01737             IR_FLD_R(dv_idx)   = IR_Tbl_Idx;
01738             IR_IDX_R(dv_idx)   = dv2_idx;
01739          }
01740          else {
01741             IR_FLD_R(dv_idx) = BD_LB_FLD(ATD_ARRAY_IDX(attr_idx), i);
01742             IR_IDX_R(dv_idx) = BD_LB_IDX(ATD_ARRAY_IDX(attr_idx), i);
01743             IR_LINE_NUM_R(dv_idx) = opnd_line;
01744             IR_COL_NUM_R(dv_idx)  = opnd_column;
01745 
01746             if (IR_FLD_R(dv_idx) == AT_Tbl_Idx) {
01747                ADD_TMP_TO_SHARED_LIST(IR_IDX_R(dv_idx));
01748             }
01749          }
01750       }
01751       else {
01752          /* set to one */
01753          IR_FLD_R(dv_idx) = CN_Tbl_Idx;
01754          IR_IDX_R(dv_idx) = CN_INTEGER_ONE_IDX;
01755          IR_LINE_NUM_R(dv_idx) = opnd_line;
01756          IR_COL_NUM_R(dv_idx)  = opnd_column;
01757       }
01758 
01759       IR_DV_DIM(dv_idx) = i;
01760 
01761       gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01762                    FALSE, FALSE, TRUE);
01763 
01764       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01765       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01766 
01767 
01768       /*********************************\
01769       |* set EXTENT for each dimension *|
01770       \*********************************/
01771 
01772       NTR_IR_TBL(dv_idx);
01773       IR_OPR(dv_idx) = Dv_Set_Extent;
01774       IR_TYPE_IDX(dv_idx) = CG_INTEGER_DEFAULT_TYPE;
01775       IR_LINE_NUM(dv_idx) = opnd_line;
01776       IR_COL_NUM(dv_idx)  = opnd_column;
01777       COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01778 
01779       NTR_IR_TBL(max_idx);
01780       IR_OPR(max_idx) = Max_Opr;
01781       IR_TYPE_IDX(max_idx) = CG_INTEGER_DEFAULT_TYPE;
01782       IR_LINE_NUM(max_idx) = opnd_line;
01783       IR_COL_NUM(max_idx)  = opnd_column;
01784 
01785       NTR_IR_LIST_TBL(list_idx);
01786       IR_FLD_L(max_idx) = IL_Tbl_Idx;
01787       IR_LIST_CNT_L(max_idx) = 2;
01788       IR_IDX_L(max_idx) = list_idx;
01789 
01790       IL_FLD(list_idx) = CN_Tbl_Idx;
01791       IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
01792       IL_LINE_NUM(list_idx) = opnd_line;
01793       IL_COL_NUM(list_idx)  = opnd_column;
01794 
01795       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
01796       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
01797       list_idx = IL_NEXT_LIST_IDX(list_idx);
01798 
01799       COPY_OPND(IL_OPND(list_idx), exp_desc->shape[i-1]);
01800       IL_LINE_NUM(list_idx) = opnd_line;
01801       IL_COL_NUM(list_idx) = opnd_column;
01802  
01803       IR_FLD_R(dv_idx) = IR_Tbl_Idx;
01804       IR_IDX_R(dv_idx) = max_idx;
01805       
01806       IR_DV_DIM(dv_idx) = i;
01807 
01808       gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01809                    FALSE, FALSE, TRUE);
01810 
01811       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01812       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01813       
01814       /**************************************\
01815       |* set STRIDE_MULT for each dimension *|
01816       \**************************************/
01817 
01818       NTR_IR_TBL(dv_idx);
01819       IR_OPR(dv_idx) = Dv_Set_Stride_Mult;
01820       IR_TYPE_IDX(dv_idx) = SA_INTEGER_DEFAULT_TYPE;
01821       IR_LINE_NUM(dv_idx) = opnd_line;
01822       IR_COL_NUM(dv_idx)  = opnd_column;
01823       COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01824 
01825       if (whole_array) {
01826 
01827          gen_dv_stride_mult(&stride_opnd,
01828                              attr_idx,
01829                             &r_dv_opnd,
01830                              exp_desc,
01831                              i,
01832                              opnd_line,
01833                              opnd_column);
01834 
01835          COPY_OPND(IR_OPND_R(dv_idx), stride_opnd);
01836       }
01837       else {
01838          while (IL_FLD(subscript_idx) != IR_Tbl_Idx ||
01839                 IR_OPR(IL_IDX(subscript_idx)) != Triplet_Opr) {
01840             subscript_idx = IL_NEXT_LIST_IDX(subscript_idx);
01841             dim++;
01842          }
01843 
01844          gen_dv_stride_mult(&stride_opnd,
01845                              attr_idx,
01846                             &r_dv_opnd,
01847                              exp_desc,
01848                              dim,
01849                              opnd_line,
01850                              opnd_column);
01851 
01852          stride_idx = IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_L(
01853                                                       IL_IDX(subscript_idx))));
01854          mult_idx = gen_ir(OPND_FLD(stride_opnd), OPND_IDX(stride_opnd),
01855                      Mult_Opr, CG_INTEGER_DEFAULT_TYPE, opnd_line, opnd_column,
01856                            IL_FLD(stride_idx), IL_IDX(stride_idx));
01857 
01858          IR_FLD_R(dv_idx) = IR_Tbl_Idx;;
01859          IR_IDX_R(dv_idx) = mult_idx;
01860 
01861          subscript_idx = IL_NEXT_LIST_IDX(subscript_idx);
01862          dim++;
01863       }
01864 
01865       IR_DV_DIM(dv_idx) = i;
01866 
01867       gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01868                    FALSE, FALSE, TRUE);
01869 
01870       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01871       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01872 
01873    }
01874 
01875    /*******************\
01876    |* clear PTR_ALLOC *|
01877    \*******************/
01878 
01879    NTR_IR_TBL(dv_idx);
01880    IR_OPR(dv_idx) = Dv_Set_Ptr_Alloc;
01881    IR_TYPE_IDX(dv_idx)   = CG_INTEGER_DEFAULT_TYPE;
01882    IR_LINE_NUM(dv_idx) = opnd_line;
01883    IR_COL_NUM(dv_idx)  = opnd_column;
01884    COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01885 
01886    if (dope_idx != NULL_IDX) {
01887       NTR_IR_TBL(dv2_idx);
01888       IR_OPR(dv2_idx) = Dv_Access_Ptr_Alloc;
01889       IR_TYPE_IDX(dv2_idx)   = CG_INTEGER_DEFAULT_TYPE;
01890       IR_LINE_NUM(dv2_idx) = opnd_line;
01891       IR_COL_NUM(dv2_idx)  = opnd_column;
01892       COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
01893       IR_FLD_R(dv_idx) = IR_Tbl_Idx;
01894       IR_IDX_R(dv_idx) = dv2_idx;
01895    }
01896    else {
01897       IR_FLD_R(dv_idx) = CN_Tbl_Idx;
01898 #ifdef KEY /* Bug 4933 */
01899       /* If RHS of pointer assignment is a dummy argument, we generally
01900        * lack dope info for the corresponding formal argument which
01901        * would tell us whether that formal argument was allocated by
01902        * pointer. It's too late to change our "Fortran ABI" to pass
01903        * dope information when a dummy is a pointer target.
01904        * Optimistically assume that it was allocated by pointer so
01905        * that subsequent "deallocate" doesn't reject it. */
01906       IR_IDX_R(dv_idx) = (ptr_assign && NULL_IDX == dope_idx &&
01907     AT_Tbl_Idx == OPND_FLD((*r_opnd)) &&
01908     AT_IS_DARG(OPND_IDX((*r_opnd)))) ?
01909         CN_INTEGER_ONE_IDX :
01910   CN_INTEGER_ZERO_IDX;
01911 #else
01912       IR_IDX_R(dv_idx) = CN_INTEGER_ZERO_IDX;
01913 #endif /* KEY Bug 4933 */
01914       IR_LINE_NUM_R(dv_idx) = opnd_line;
01915       IR_COL_NUM_R(dv_idx)  = opnd_column;
01916    }
01917 
01918    gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01919                    FALSE, FALSE, TRUE);
01920 
01921    SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01922    SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01923 
01924    /*******************\
01925    |* clear ORIG_BASE *|
01926    \*******************/
01927 
01928    NTR_IR_TBL(dv_idx);
01929    IR_OPR(dv_idx) = Dv_Set_Orig_Base;
01930    IR_TYPE_IDX(dv_idx)   = CG_INTEGER_DEFAULT_TYPE;
01931    IR_LINE_NUM(dv_idx) = opnd_line;
01932    IR_COL_NUM(dv_idx)  = opnd_column;
01933    COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01934 
01935    if (dope_idx != NULL_IDX) {
01936       NTR_IR_TBL(dv2_idx);
01937       IR_OPR(dv2_idx) = Dv_Access_Orig_Base;
01938       IR_TYPE_IDX(dv2_idx)   = SA_INTEGER_DEFAULT_TYPE;
01939       IR_LINE_NUM(dv2_idx) = opnd_line;
01940       IR_COL_NUM(dv2_idx)  = opnd_column;
01941       COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
01942       IR_FLD_R(dv_idx) = IR_Tbl_Idx;
01943       IR_IDX_R(dv_idx) = dv2_idx;
01944    }
01945    else {
01946       IR_FLD_R(dv_idx) = CN_Tbl_Idx;
01947       IR_IDX_R(dv_idx) = CN_INTEGER_ZERO_IDX;
01948       IR_LINE_NUM_R(dv_idx) = opnd_line;
01949       IR_COL_NUM_R(dv_idx)  = opnd_column;
01950    }
01951 
01952    gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01953                    FALSE, FALSE, TRUE);
01954 
01955    SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01956    SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01957 
01958    /*******************\
01959    |* clear ORIG_SIZE *|
01960    \*******************/
01961 
01962    NTR_IR_TBL(dv_idx);
01963    IR_OPR(dv_idx) = Dv_Set_Orig_Size;
01964    IR_TYPE_IDX(dv_idx)   = CG_INTEGER_DEFAULT_TYPE;
01965    IR_LINE_NUM(dv_idx) = opnd_line;
01966    IR_COL_NUM(dv_idx)  = opnd_column;
01967    COPY_OPND(IR_OPND_L(dv_idx), (*l_opnd));
01968 
01969    if (dope_idx != NULL_IDX) {
01970       NTR_IR_TBL(dv2_idx);
01971       IR_OPR(dv2_idx) = Dv_Access_Orig_Size;
01972       IR_TYPE_IDX(dv2_idx)   = SA_INTEGER_DEFAULT_TYPE;
01973       IR_LINE_NUM(dv2_idx) = opnd_line;
01974       IR_COL_NUM(dv2_idx)  = opnd_column;
01975       COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
01976       IR_FLD_R(dv_idx) = IR_Tbl_Idx;
01977       IR_IDX_R(dv_idx) = dv2_idx;
01978    }
01979    else {
01980       IR_FLD_R(dv_idx) = CN_Tbl_Idx;
01981       IR_IDX_R(dv_idx) = CN_INTEGER_ZERO_IDX;
01982       IR_LINE_NUM_R(dv_idx) = opnd_line;
01983       IR_COL_NUM_R(dv_idx)  = opnd_column;
01984    }
01985 
01986    gen_sh(Before, Assignment_Stmt, stmt_start_line, stmt_start_col,
01987                    FALSE, FALSE, TRUE);
01988 
01989    SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = dv_idx;
01990    SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
01991 
01992    TRACE (Func_Exit, "dope_vector_setup", NULL);
01993 
01994    return;
01995 
01996 }  /* dope_vector_setup */
01997 
01998 /******************************************************************************\
01999 |*                        *|
02000 |* Description:                     *|
02001 |*  Given the input type, an io type code is assembled.                   *|
02002 |*                        *|
02003 |* Input parameters:                    *|
02004 |*  type_idx - index into type table                                      *|
02005 |*                        *|
02006 |* Output parameters:                   *|
02007 |*  value    - pointer to either a long or a 2 word array of longs.       *|
02008 |*                        *|
02009 |* Returns:                     *|
02010 |*  NOTHING                     *|
02011 |*                        *|
02012 \******************************************************************************/
02013 
02014 void make_io_type_code(int       type_idx,   /* BRIANJ */
02015            long_type    *value)
02016 
02017 {
02018    long_type  dec_len = 0;
02019    int          dp_flag = 0;
02020 #ifdef KEY /* Bug 10177 */
02021    int    dv_type = 0;
02022 #else /* KEY Bug 10177 */
02023    int    dv_type;
02024 #endif /* KEY Bug 10177 */
02025    long_type  int_len = 0;
02026    int    kind_star = 0;
02027 
02028    f90_type_t *type_code;
02029 
02030 
02031    TRACE (Func_Entry, "make_io_type_code", NULL);
02032 
02033    switch(TYP_DESC(type_idx)) {
02034       case Default_Typed:
02035          kind_star = DV_DEFAULT_TYPED;
02036          break;
02037 
02038       case Star_Typed:
02039          kind_star = DV_STAR_TYPED;
02040          break;
02041 
02042       case Kind_Typed:
02043          if (TYP_TYPE(type_idx) == Real &&
02044              TYP_KIND_DOUBLE(type_idx)) {
02045             kind_star = DV_KIND_DOUBLE;
02046          }
02047          else if (TYP_KIND_CONST(type_idx)) {
02048             kind_star = DV_KIND_CONST;
02049          }
02050          else {
02051             kind_star = DV_KIND_TYPED;
02052          }
02053          break;
02054    }
02055 
02056 # ifndef _TARGET_OS_MAX
02057    if (TYP_DECLARED_DBL(type_idx) &&
02058        kind_star == DV_DEFAULT_TYPED) {
02059 
02060       dp_flag = 1;
02061    }
02062 # endif
02063 
02064    switch (TYP_TYPE(type_idx)) {
02065       case Typeless:
02066 
02067          /* BRIANJ - These could be long64 type */
02068 
02069          dec_len = (long) TYP_BIT_LEN(type_idx) / TARGET_BYTES_PER_WORD;
02070          int_len = (long) TYP_BIT_LEN(type_idx);
02071          dv_type = DV_TYPELESS;
02072 
02073          break;
02074 
02075       case Integer:
02076 
02077          dec_len = (long) TYP_DCL_VALUE(type_idx);
02078          int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)];
02079          dv_type = DV_INTEGER;
02080 
02081          break;
02082 
02083       case Logical:
02084 
02085          dec_len = (long) TYP_DCL_VALUE(type_idx);
02086          int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)];
02087          dv_type = DV_LOGICAL;
02088 
02089          break;
02090 
02091       case Real:
02092 
02093          dec_len = (long) TYP_DCL_VALUE(type_idx);
02094          int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)];
02095          dv_type = DV_REAL;
02096 
02097          break;
02098 
02099       case Complex:
02100 
02101          dec_len = (long) TYP_DCL_VALUE(type_idx);
02102          int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)];
02103          dv_type = DV_COMPLEX;
02104 
02105          break;
02106 
02107       case Character:
02108 
02109          if (kind_star == DV_DEFAULT_TYPED) {
02110             dec_len = 0;
02111          }
02112          else {
02113             dec_len = 1;
02114          }
02115          int_len = 8;
02116          dv_type = DV_ASCII_CHAR;
02117 
02118          break;
02119 
02120       case Structure:
02121 
02122          if (ATT_CHAR_SEQ(TYP_IDX(type_idx))) {
02123             dv_type = DV_ASCII_CHAR_SEQUENCE_STRUCT;
02124          }
02125          else {
02126             dv_type = DV_STRUCT;
02127          }
02128 
02129          break;
02130 
02131       case CRI_Ptr:
02132       case CRI_Ch_Ptr:
02133 
02134          int_len = storage_bit_size_tbl[TYP_LINEAR(type_idx)];
02135          dv_type = DV_INTEGER;
02136 
02137          break;
02138    }
02139 
02140 # ifdef _TYPE_CODE_64_BIT
02141    type_code = (f90_type_t *)value;
02142 
02143    type_code->unused = 0;
02144    type_code->type = dv_type;
02145    type_code->dpflag = dp_flag;
02146    type_code->kind_or_star = kind_star;
02147    type_code->int_len = int_len;
02148    type_code->dec_len = dec_len;
02149 # else
02150 
02151    *value = ((dv_type   << DV_TYPE_SHIFT)         |
02152              (dp_flag   << DV_DP_SHIFT)           |
02153              (kind_star << DV_KIND_STAR_SHIFT)  |
02154              (int_len   << DV_INT_LEN_SHIFT)      |
02155              (dec_len   << DV_DEC_LEN_SHIFT));
02156 # endif
02157 
02158    TRACE (Func_Exit, "make_io_type_code", NULL);
02159 
02160    return;
02161 
02162 }  /* make_io_type_code */
02163 
02164 /******************************************************************************\
02165 |*                        *|
02166 |* Description:                     *|
02167 |*  This routine creates a constant table entry for a dope vector type    *|
02168 |*      code.                                                                 *|
02169 |*                        *|
02170 |* Input parameters:                    *|
02171 |*  attr_idx - index for attr.                                            *|
02172 |*                        *|
02173 |* Output parameters:                   *|
02174 |*  NONE                      *|
02175 |*                        *|
02176 |* Returns:                     *|
02177 |*  constant table idx for type code.                                     *|
02178 |*                        *|
02179 \******************************************************************************/
02180 
02181 static int create_dv_type_code(int  attr_idx)
02182 
02183 {
02184    int    constant_idx = NULL_IDX;
02185    long_type    constant[2];
02186 
02187    TRACE (Func_Entry, "create_dv_type_code", NULL);
02188 
02189    make_io_type_code(ATD_TYPE_IDX(attr_idx), constant);
02190 
02191    constant_idx = ntr_const_tbl(IO_TYPE_CODE_TYPE, FALSE, constant);
02192 
02193    TRACE (Func_Exit, "create_dv_type_code", NULL);
02194 
02195    return(constant_idx);
02196 
02197 }  /* create_dv_type_code */
02198 
02199 /******************************************************************************\
02200 |*                        *|
02201 |* Description:                     *|
02202 |*  <description>                   *|
02203 |*                        *|
02204 |* Input parameters:                    *|
02205 |*  NONE                      *|
02206 |*                        *|
02207 |* Output parameters:                   *|
02208 |*  NONE                      *|
02209 |*                        *|
02210 |* Returns:                     *|
02211 |*  NOTHING                     *|
02212 |*                        *|
02213 \******************************************************************************/
02214 
02215 void gen_common_dv_init(opnd_type            *dv_opnd,
02216                         int                  dv_attr_idx,
02217                         sh_position_type     position)
02218 
02219 {
02220    int            col;
02221    int      ir_idx;
02222    size_offset_type length;
02223    int      line;
02224    int      mult_idx;
02225    size_offset_type result;
02226    int            type_idx;
02227 
02228 
02229    TRACE (Func_Entry, "gen_common_dv_init", NULL);
02230 
02231    find_opnd_line_and_column(dv_opnd, &line, &col);
02232 
02233    /*************\
02234    |* BASE ADDR *|
02235    \*************/
02236 
02237    /* Do not set */
02238 
02239    /*************\
02240    |* EL_LEN    *|
02241    \*************/
02242 
02243    NTR_IR_TBL(ir_idx);
02244    IR_OPR(ir_idx) = Dv_Set_El_Len;
02245    IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
02246    IR_LINE_NUM(ir_idx) = line;
02247    IR_COL_NUM(ir_idx) = col;
02248 
02249    COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd));
02250 
02251    type_idx = ATD_TYPE_IDX(dv_attr_idx);
02252 
02253    if (TYP_TYPE(type_idx) == Structure) {
02254       IR_FLD_R(ir_idx)  = (fld_type) ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx));
02255       IR_IDX_R(ir_idx)  = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));
02256       IR_LINE_NUM_R(ir_idx) = line;
02257       IR_COL_NUM_R(ir_idx)  = col;
02258    }
02259    else if (TYP_TYPE(type_idx) == Character) {
02260 
02261       IR_FLD_R(ir_idx)      = TYP_FLD(type_idx);
02262       IR_IDX_R(ir_idx)      = TYP_IDX(type_idx);
02263       IR_LINE_NUM_R(ir_idx) = line;
02264       IR_COL_NUM_R(ir_idx)  = col;
02265 
02266       if (IR_FLD_R(ir_idx) == AT_Tbl_Idx) {
02267          ADD_TMP_TO_SHARED_LIST(IR_IDX_R(ir_idx));
02268       }
02269 
02270       if (! char_len_in_bytes) {
02271 
02272          /* Len is in bytes on solaris */
02273          /* Len is in bits for everyone else */
02274 
02275          if (TYP_FLD(type_idx) == CN_Tbl_Idx) {
02276             result.fld    = CN_Tbl_Idx;
02277             result.idx    = CN_INTEGER_CHAR_BIT_IDX;
02278             length.fld    = TYP_FLD(type_idx);
02279             length.idx    = TYP_IDX(type_idx);
02280 
02281             size_offset_binary_calc(&length,
02282                                     &result,
02283                                      Mult_Opr,
02284                                     &result);
02285 
02286             if (result.fld == NO_Tbl_Idx) {
02287                IR_FLD_R(ir_idx)       = CN_Tbl_Idx;
02288                IR_IDX_R(ir_idx)       = ntr_const_tbl(result.type_idx,
02289                                                       FALSE,
02290                                                       result.constant);
02291             }
02292             else {
02293                IR_FLD_R(ir_idx)       = result.fld;
02294                IR_IDX_R(ir_idx)       = result.idx;
02295             }
02296 
02297             IR_LINE_NUM_R(ir_idx) = line;
02298             IR_COL_NUM_R(ir_idx)  = col;
02299          }
02300          else {
02301             NTR_IR_TBL(mult_idx);
02302             IR_OPR(mult_idx) = Mult_Opr;
02303             IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
02304             IR_LINE_NUM(mult_idx) = line;
02305             IR_COL_NUM(mult_idx)  = col;
02306             IR_FLD_L(mult_idx)    = CN_Tbl_Idx;
02307             IR_IDX_L(mult_idx)    = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 8);
02308             IR_LINE_NUM_L(mult_idx) = line;
02309             IR_COL_NUM_L(mult_idx)  = col;
02310 
02311             IR_FLD_R(mult_idx)    = TYP_FLD(type_idx);
02312             IR_IDX_R(mult_idx)    = TYP_IDX(type_idx);
02313             IR_LINE_NUM_R(mult_idx) = line;
02314             IR_COL_NUM_R(mult_idx)  = col;
02315 
02316             IR_FLD_R(ir_idx)      = IR_Tbl_Idx;
02317             IR_IDX_R(ir_idx)      = mult_idx;
02318          }
02319       }
02320    }
02321    else {
02322       IR_FLD_R(ir_idx) = CN_Tbl_Idx;
02323       IR_IDX_R(ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
02324                                   storage_bit_size_tbl[TYP_LINEAR(type_idx)]);
02325       IR_LINE_NUM_R(ir_idx) = line;
02326       IR_COL_NUM_R(ir_idx)  = col;
02327    }
02328 
02329    gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
02330 
02331    if (position == After) {
02332       SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02333       SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02334    }
02335    else {
02336       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
02337       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02338    }
02339 
02340 
02341 
02342    /*************\
02343    |* ASSOC     *|
02344    \*************/
02345 
02346    /* Do not set */
02347 
02348    /*************\
02349    |* PTR_ALLOC *|
02350    \*************/
02351 
02352    /* Do not set */
02353 
02354    /*************\
02355    |* P_OR_A    *|
02356    \*************/
02357 
02358    NTR_IR_TBL(ir_idx);
02359    IR_OPR(ir_idx) = Dv_Set_P_Or_A;
02360    IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
02361    IR_LINE_NUM(ir_idx) = line;
02362    IR_COL_NUM(ir_idx) = col;
02363 
02364    COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd));
02365 
02366    IR_FLD_R(ir_idx) = CN_Tbl_Idx;
02367 
02368    if (ATD_ALLOCATABLE(dv_attr_idx)) {
02369       IR_IDX_R(ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 2);
02370    }
02371    else if (ATD_POINTER(dv_attr_idx)) {
02372       IR_IDX_R(ir_idx) = CN_INTEGER_ONE_IDX;
02373    }
02374    else {
02375       IR_IDX_R(ir_idx) = CN_INTEGER_ZERO_IDX;
02376    }
02377    IR_LINE_NUM_R(ir_idx) = line;
02378    IR_COL_NUM_R(ir_idx)  = col;
02379 
02380    gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
02381 
02382    if (position == After) {
02383       SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02384       SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02385    }
02386    else {
02387       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
02388       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02389    }
02390 
02391 
02392    /*************\
02393    |* A_CONTIG  *|
02394    \*************/
02395 
02396    /* if it is in common block, this bit is left untouched */
02397    if (!ATD_IN_COMMON(dv_attr_idx))
02398    {
02399    NTR_IR_TBL(ir_idx);
02400    IR_OPR(ir_idx) = Dv_Set_A_Contig;
02401    IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
02402    IR_LINE_NUM(ir_idx) = line;
02403    IR_COL_NUM(ir_idx) = col;
02404 
02405    COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd));
02406 
02407    IR_FLD_R(ir_idx) = CN_Tbl_Idx;
02408 
02409    if (ATD_ALLOCATABLE(dv_attr_idx)) {
02410       IR_IDX_R(ir_idx) = CN_INTEGER_ONE_IDX;
02411    }
02412    else {
02413       IR_IDX_R(ir_idx) = CN_INTEGER_ZERO_IDX;
02414    }
02415    IR_LINE_NUM_R(ir_idx) = line;
02416    IR_COL_NUM_R(ir_idx)  = col;
02417 
02418    gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
02419 
02420    if (position == After) {
02421       SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02422       SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02423    }
02424    else {
02425       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
02426       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02427    }
02428    }
02429 
02430 
02431    /*************\
02432    |* N_DIM     *|
02433    \*************/
02434 
02435    NTR_IR_TBL(ir_idx);
02436    IR_OPR(ir_idx) =Dv_Set_N_Dim ;
02437    IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
02438    IR_LINE_NUM(ir_idx) = line;
02439    IR_COL_NUM(ir_idx) = col;
02440 
02441    COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd));
02442 
02443    IR_FLD_R(ir_idx) = CN_Tbl_Idx;
02444    IR_IDX_R(ir_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
02445                                   (ATD_ARRAY_IDX(dv_attr_idx) ? 
02446                                    BD_RANK(ATD_ARRAY_IDX(dv_attr_idx)) : 0));
02447    IR_LINE_NUM_R(ir_idx) = line;
02448    IR_COL_NUM_R(ir_idx)  = col;
02449 
02450    gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
02451 
02452    if (position == After) {
02453       SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02454       SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02455    }
02456    else {
02457       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
02458       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02459    }
02460 
02461 
02462    /*************\
02463    |* TYPE_CODE *|
02464    \*************/
02465 
02466    NTR_IR_TBL(ir_idx);
02467    IR_OPR(ir_idx) = Dv_Set_Typ_Code;
02468    IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
02469    IR_LINE_NUM(ir_idx) = line;
02470    IR_COL_NUM(ir_idx) = col;
02471 
02472    COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd));
02473 
02474    IR_FLD_R(ir_idx) = CN_Tbl_Idx;
02475    IR_IDX_R(ir_idx) = create_dv_type_code(dv_attr_idx);
02476    IR_LINE_NUM_R(ir_idx) = line;
02477    IR_COL_NUM_R(ir_idx)  = col;
02478 
02479    gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
02480 
02481    if (position == After) {
02482       SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02483       SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02484    }
02485    else {
02486       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
02487       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02488    }
02489 
02490 
02491    /*************\
02492    |* ORIG_BASE *|
02493    \*************/
02494 
02495    /* Do not set */
02496 
02497    /*************\
02498    |* ORIG_SIZE *|
02499    \*************/
02500 
02501    /* Do not set */
02502 
02503    TRACE (Func_Exit, "gen_common_dv_init", NULL);
02504 
02505    return;
02506 
02507 }  /* gen_common_dv_init */
02508 
02509 /******************************************************************************\
02510 |*                                                                            *|
02511 |* Description:                                                               *|
02512 |*      Create a whole def of a dope vector that is in a module block.        *|
02513 |*                                                                            *|
02514 |* Input parameters:                                                          *|
02515 |*      NONE                                                                  *|
02516 |*                                                                            *|
02517 |* Output parameters:                                                         *|
02518 |*      NONE                                                                  *|
02519 |*                                                                            *|
02520 |* Returns:                                                                   *|
02521 |*      NOTHING                                                               *|
02522 |*                                                                            *|
02523 \******************************************************************************/
02524 
02525 void gen_static_dv_whole_def(opnd_type         *dv_opnd,
02526                              int                attr_idx,
02527            sh_position_type position)
02528 
02529 {
02530    int            col;
02531    long_type    constant[2];
02532    int      const_idx;
02533    ext_dope_type  *dv_ptr;
02534    int      ir_idx;
02535    int      i;
02536    int            line;
02537    int      mult_idx;
02538    int      num_words;
02539    long_type          rank;  /* BRIANJ */
02540    int                  type_idx;
02541 
02542 
02543    TRACE (Func_Entry, "gen_static_dv_whole_def", NULL);
02544 
02545    find_opnd_line_and_column(dv_opnd, &line, &col);
02546 
02547    rank = (ATD_ARRAY_IDX(attr_idx) ? (long)BD_RANK(ATD_ARRAY_IDX(attr_idx)) :0);
02548 
02549    num_words  = DV_HD_WORD_SIZE + (rank * DV_DIM_WORD_SIZE);
02550 
02551    CLEAR_TBL_NTRY(type_tbl, TYP_WORK_IDX);
02552    TYP_TYPE(TYP_WORK_IDX) = Typeless;
02553 #if defined (TARG_X8664) && defined (_HOST64)
02554    TYP_BIT_LEN(TYP_WORK_IDX)    = num_words * ((SET_POINTER_SIZE)?64:32);
02555 #else
02556    TYP_BIT_LEN(TYP_WORK_IDX)  = num_words * TARGET_BITS_PER_WORD;
02557 #endif
02558    type_idx     = ntr_type_tbl();
02559 
02560    const_idx  = ntr_const_tbl(type_idx, FALSE, NULL);
02561 
02562    /* NULL() intrinsic */
02563    if (ATD_CLASS(attr_idx) == Compiler_Tmp) {
02564       ATD_FLD(attr_idx) = CN_Tbl_Idx;
02565       ATD_TMP_IDX(attr_idx) = const_idx;
02566       ATD_TMP_INIT_NOT_DONE(attr_idx) = TRUE;
02567    }
02568    else {
02569       gen_init_stmt(dv_opnd,
02570                     const_idx,
02571                     position);
02572    }
02573 
02574    dv_ptr = (ext_dope_type *)&CN_CONST(const_idx);
02575    type_idx = ATD_TYPE_IDX(attr_idx);
02576 
02577    /* the entire constant is initialized to 0's */
02578    /* so just fill in the non zero parts.       */
02579 
02580    /*************\
02581    |* EL_LEN    *|
02582    \*************/
02583 
02584    if (TYP_TYPE(type_idx) == Structure) {
02585 
02586       if (compare_cn_and_value(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx)),
02587                                MAX_DV_EL_LEN,
02588                                Ge_Opr)) {
02589          PRINTMSG(line, 1174, Error, col,
02590                   CN_INT_TO_C(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx))),
02591                   MAX_DV_EL_LEN);
02592          DV_SET_EL_LEN(*dv_ptr, MAX_DV_EL_LEN);
02593       }
02594       else {  /* BRIANJ */
02595          DV_SET_EL_LEN(*dv_ptr,
02596                 CN_INT_TO_C(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx))));
02597       }
02598    }
02599    else if (TYP_TYPE(type_idx) == Character) {
02600 
02601       if (TYP_FLD(type_idx) == CN_Tbl_Idx) {
02602 
02603          if (char_len_in_bytes) {
02604 
02605             if (compare_cn_and_value(TYP_IDX(type_idx),
02606                                      MAX_DV_EL_LEN,
02607                                      Ge_Opr)) {
02608                PRINTMSG(line, 1174, Error, col, 
02609                         CN_INT_TO_C(TYP_IDX(type_idx)),
02610                         MAX_DV_EL_LEN);
02611                DV_SET_EL_LEN(*dv_ptr, MAX_DV_EL_LEN);
02612             }
02613             else {  /* BRIANJ */
02614                DV_SET_EL_LEN(*dv_ptr, CN_INT_TO_C(TYP_IDX(type_idx)));
02615             }
02616          }
02617          else {
02618 
02619             if (compare_cn_and_value(TYP_IDX(type_idx),
02620                                      MAX_DV_EL_LEN/8,
02621                                      Ge_Opr)) {
02622                PRINTMSG(line, 1174, Error, col, 
02623                         CN_INT_TO_C(TYP_IDX(type_idx)),
02624                         MAX_DV_EL_LEN/8);
02625                DV_SET_EL_LEN(*dv_ptr, MAX_DV_EL_LEN);
02626             }
02627             else {  /* BRIANJ */
02628                DV_SET_EL_LEN(*dv_ptr, CN_INT_TO_C(TYP_IDX(type_idx)) * 8);
02629             }
02630          }
02631       }
02632       else {
02633          /* We are here only for variable length char pointers */
02634          /* They cannot be inside a derived type, so just generate */
02635          /* an assignment statement to fill in the length at runtime. */
02636 
02637          NTR_IR_TBL(ir_idx);
02638          IR_OPR(ir_idx) = Dv_Set_El_Len;
02639          IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
02640          IR_LINE_NUM(ir_idx) = line;
02641          IR_COL_NUM(ir_idx) = col;
02642 
02643          COPY_OPND(IR_OPND_L(ir_idx), (*dv_opnd));
02644 
02645          if (char_len_in_bytes) {
02646 
02647             /* Len is in bytes for solaris */
02648             IR_FLD_R(ir_idx)      = TYP_FLD(type_idx);
02649             IR_IDX_R(ir_idx)      = TYP_IDX(type_idx);
02650             IR_LINE_NUM_R(ir_idx) = line;
02651             IR_COL_NUM_R(ir_idx)  = col;
02652          }
02653          else {
02654             NTR_IR_TBL(mult_idx);
02655             IR_OPR(mult_idx) = Mult_Opr;
02656             IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
02657             IR_LINE_NUM(mult_idx) = line;
02658             IR_COL_NUM(mult_idx)  = col;
02659             IR_FLD_L(mult_idx)    = CN_Tbl_Idx;
02660             IR_IDX_L(mult_idx)    = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 8);
02661             IR_LINE_NUM_L(mult_idx) = line;
02662             IR_COL_NUM_L(mult_idx)  = col;
02663 
02664             IR_FLD_R(mult_idx)    = TYP_FLD(type_idx);
02665             IR_IDX_R(mult_idx)    = TYP_IDX(type_idx);
02666             IR_LINE_NUM_R(mult_idx) = line;
02667             IR_COL_NUM_R(mult_idx)  = col;
02668 
02669             IR_FLD_R(ir_idx)      = IR_Tbl_Idx;
02670             IR_IDX_R(ir_idx)      = mult_idx;
02671          }
02672 
02673          gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
02674 
02675          if (position == After) {
02676             SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
02677             SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
02678          }
02679          else {
02680             SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
02681             SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
02682          }
02683       }
02684    }
02685    else {
02686       DV_SET_EL_LEN(*dv_ptr, storage_bit_size_tbl[TYP_LINEAR(type_idx)]);
02687    }
02688 
02689    /*************\
02690    |* P_OR_A    *|
02691    \*************/
02692 
02693    if (ATD_ALLOCATABLE(attr_idx)) {
02694       DV_SET_P_OR_A(*dv_ptr, 2);
02695    }
02696    else if (ATD_POINTER(attr_idx)) {
02697       DV_SET_P_OR_A(*dv_ptr, 1);
02698    }
02699 
02700    /*************\
02701    |* N_DIM     *|
02702    \*************/
02703 
02704    DV_SET_NUM_DIMS(*dv_ptr, rank);
02705 
02706    /*************\
02707    |* TYPE_CODE *|
02708    \*************/
02709 
02710    make_io_type_code(type_idx, constant);
02711 # ifdef _TYPE_CODE_64_BIT
02712    DV_SET_TYPE_CODE(*dv_ptr, *(f90_type_t *)constant);
02713 # else
02714    DV_SET_TYPE_CODE(*dv_ptr, *constant);
02715 # endif
02716 
02717    if (cmd_line_flags.runtime_bounds &&
02718        ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
02719 
02720       for (i = 0; i < BD_RANK(ATD_ARRAY_IDX(attr_idx)); i++) {
02721 
02722          /************************************\
02723          |* set LOW_BOUND for each dimension *|
02724          \************************************/
02725 
02726          DV_SET_LOW_BOUND(*dv_ptr, i, 1);
02727 
02728          /*********************************\
02729          |* set EXTENT for each dimension *|
02730          \*********************************/
02731 
02732          /* leave as zero */
02733 
02734          /**************************************\
02735          |* set STRIDE_MULT for each dimension *|
02736          \**************************************/
02737 
02738          DV_SET_STRIDE_MULT(*dv_ptr, i, 1);
02739 
02740       }
02741    }
02742 
02743 #ifdef KEY /* Bug 9608 */
02744    /*
02745     * When we set assoc=0 for an array, we also set contig=1 so that
02746     * copyinout doesn't blow up if user (illegally) passes the null
02747     * pointer to a procedure lacking an explicit interface, in the
02748     * (unjustified) expectation that the pointer won't be
02749     * dereferenced if the procedure doesn't refer to the dummy
02750     * argument. This seems cheaper than adding a test for null
02751     * before and after every call.
02752     */
02753    if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX && !DV_ASSOC(*dv_ptr)) {
02754      DV_SET_A_CONTIG(*dv_ptr, 1);
02755    }
02756 #endif /* KEY Bug 9608 */
02757 
02758    TRACE (Func_Exit, "gen_static_dv_whole_def", NULL);
02759 
02760    return;
02761 
02762 }  /* gen_static_dv_whole_def */
02763 
02764 /******************************************************************************\
02765 |*                        *|
02766 |* Description:                     *|
02767 |*  <description>                   *|
02768 |*                        *|
02769 |* Input parameters:                    *|
02770 |*  NONE                      *|
02771 |*                        *|
02772 |* Output parameters:                   *|
02773 |*  NONE                      *|
02774 |*                        *|
02775 |* Returns:                     *|
02776 |*  NOTHING                     *|
02777 |*                        *|
02778 \******************************************************************************/
02779 
02780 static long64 create_imp_do_loops(opnd_type *top_opnd)
02781 
02782 {
02783 
02784    int      col;
02785    long64   count = 1;
02786    long64   end;
02787    int      i;
02788    int      imp_idx;  
02789    int      line;
02790    int      list_idx;
02791    opnd_type    opnd;
02792    long64   start;
02793    int      tmp_idx;
02794    int      trip_list_idx;
02795 
02796 
02797    TRACE (Func_Entry, "create_imp_do_loops", NULL);
02798 
02799    COPY_OPND(opnd, (*top_opnd));
02800    find_opnd_line_and_column(&opnd, &line, &col);
02801 
02802    while (OPND_FLD(opnd) == IR_Tbl_Idx) {
02803 
02804       if (IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr) {
02805 
02806          trip_list_idx = IR_IDX_R(OPND_IDX(opnd));
02807 
02808          for (i = 0; i < IR_LIST_CNT_R(OPND_IDX(opnd)); i++) {
02809 
02810             NTR_IR_TBL(imp_idx);
02811             IR_OPR(imp_idx)        = Implied_Do_Opr;
02812             IR_TYPE_IDX(imp_idx)   = TYPELESS_DEFAULT_TYPE;
02813             IR_LINE_NUM(imp_idx)   = line;
02814             IR_COL_NUM(imp_idx)    = col;
02815 
02816             NTR_IR_LIST_TBL(list_idx);
02817             IR_FLD_L(imp_idx)      = IL_Tbl_Idx;
02818             IR_LIST_CNT_L(imp_idx) = 1;
02819             IR_IDX_L(imp_idx)      = list_idx;
02820 
02821             COPY_OPND(IL_OPND(list_idx), (*top_opnd));
02822             OPND_FLD((*top_opnd)) = IR_Tbl_Idx;
02823             OPND_IDX((*top_opnd)) = imp_idx;
02824 
02825             /* create the tmp implied do control variable. */
02826 
02827             tmp_idx                   = gen_compiler_tmp(line, col, Priv, TRUE);
02828             ATD_TYPE_IDX(tmp_idx)     = CG_INTEGER_DEFAULT_TYPE;
02829             AT_SEMANTICS_DONE(tmp_idx)= TRUE;
02830             ATD_STOR_BLK_IDX(tmp_idx) = SCP_SB_STACK_IDX(curr_scp_idx);
02831             ATD_IMP_DO_LCV(tmp_idx)   = TRUE;
02832             ATD_LCV_IS_CONST(tmp_idx) = TRUE;
02833 
02834             /* hook in control var. */
02835 
02836             NTR_IR_LIST_TBL(list_idx);
02837             IR_FLD_R(imp_idx)      = IL_Tbl_Idx;
02838             IR_LIST_CNT_R(imp_idx) = 4;
02839             IR_IDX_R(imp_idx)      = list_idx;
02840 
02841             IL_FLD(list_idx)   = AT_Tbl_Idx;
02842             IL_IDX(list_idx)   = tmp_idx;
02843             IL_LINE_NUM(list_idx) = line;
02844             IL_COL_NUM(list_idx)  = col;
02845 
02846             /* second is start opnd */
02847 
02848             NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02849             IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02850             list_idx = IL_NEXT_LIST_IDX(list_idx);
02851 
02852             COPY_OPND(IL_OPND(list_idx),
02853                       IL_OPND(IR_IDX_L(IL_IDX(trip_list_idx))));
02854 
02855             start = CN_INT_TO_C(IL_IDX(list_idx));
02856 
02857             /* third is end opnd */
02858 
02859             NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02860             IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02861             list_idx = IL_NEXT_LIST_IDX(list_idx);
02862 
02863             COPY_OPND(IL_OPND(list_idx),
02864                       IL_OPND(IL_NEXT_LIST_IDX(IR_IDX_L(
02865                                IL_IDX(trip_list_idx)))));
02866 
02867             end = CN_INT_TO_C(IL_IDX(list_idx));
02868 
02869             count = count * ((end - start) + 1);
02870 
02871             /* fourth is stride opnd */
02872 
02873             NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
02874             IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
02875             list_idx = IL_NEXT_LIST_IDX(list_idx);
02876 
02877             COPY_OPND(IL_OPND(list_idx),
02878                       IL_OPND(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(
02879                                     IR_IDX_L(IL_IDX(trip_list_idx))))));
02880 
02881 
02882             /* replace triplet with tmp control variable */
02883 
02884             IL_FLD(trip_list_idx) = AT_Tbl_Idx;
02885             IL_IDX(trip_list_idx) = tmp_idx;
02886             IL_LINE_NUM(trip_list_idx) = line;
02887             IL_COL_NUM(trip_list_idx)  = col;
02888 
02889             trip_list_idx = IL_NEXT_LIST_IDX(trip_list_idx);
02890          }
02891       }
02892 
02893       COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
02894    }
02895 
02896 
02897    TRACE (Func_Exit, "create_imp_do_loops", NULL);
02898 
02899    return(count);
02900 
02901 }  /* create_imp_do_loops */
02902 
02903 /******************************************************************************\
02904 |*                        *|
02905 |* Description:                     *|
02906 |*  This routine creates a chain of stmts to initialize a dope vector     *|
02907 |*      or a structure with pointers.                                         *|
02908 |*                        *|
02909 |* Input parameters:                    *|
02910 |*  attr_idx - idx of variable to process.                                *|
02911 |*                        *|
02912 |* Output parameters:                   *|
02913 |*      exit_sh_idx - exit code chain if needed.                              *|
02914 |*                        *|
02915 |* Returns:                     *|
02916 |*  NOTHING                     *|
02917 |*                        *|
02918 \******************************************************************************/
02919 
02920 void gen_entry_dope_code(int   attr_idx)
02921 
02922 {
02923    expr_arg_type exp_desc;
02924    void          (*func)();
02925    opnd_type     opnd;
02926    int     opr;
02927 
02928 
02929    TRACE (Func_Entry, "gen_entry_dope_code", NULL);
02930 
02931    if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module) {
02932       func = gen_static_dv_whole_def;
02933       opr = Init_Opr;
02934    }
02935    else if (ATD_AUTOMATIC(attr_idx) ||
02936             ATD_CLASS(attr_idx) == Function_Result) {
02937       func = gen_dv_whole_def_init;
02938       opr = Asg_Opr;
02939    }
02940    else if (ATD_IN_COMMON(attr_idx)) {
02941 
02942 # if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
02943       func = gen_common_dv_init;
02944       opr = Init_Opr;
02945 # else
02946       func = gen_static_dv_whole_def;
02947       opr = Init_Opr;
02948 # endif
02949    }
02950    else if (ATD_SAVED(attr_idx) ||
02951 #ifdef KEY /* Bug 10467 */
02952             ATD_DATA_INIT(attr_idx) ||
02953 #endif /* KEY Bug 10467 */
02954             ATP_SAVE_ALL(SCP_ATTR_IDX(curr_scp_idx))) {
02955       func = gen_static_dv_whole_def;
02956       opr = Init_Opr;
02957    }
02958    else {
02959       func = gen_dv_whole_def_init;
02960       opr = Asg_Opr;
02961    }
02962 
02963    if (AT_DCL_ERR(attr_idx)) {
02964       goto EXIT;
02965    }
02966 
02967 # if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
02968 
02969    if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Module &&
02970        ATD_IN_COMMON(attr_idx)) {
02971 
02972       /* intentionally blank. We can't initialize common block */
02973       /* dope vectors from multiple .o's on solaris.           */
02974    }
02975    else 
02976 # endif
02977    if (ATD_IM_A_DOPE(attr_idx)) {
02978       OPND_FLD(opnd) = AT_Tbl_Idx;
02979       OPND_IDX(opnd) = attr_idx;
02980       OPND_LINE_NUM(opnd) = SH_GLB_LINE(curr_stmt_sh_idx);
02981       OPND_COL_NUM(opnd)  = SH_COL_NUM(curr_stmt_sh_idx);
02982       (*func)(&opnd, attr_idx, After);
02983    }
02984    else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure           &&
02985             (ATT_POINTER_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx))) ||
02986 #ifdef KEY /* Bug 6845 */
02987             ATT_ALLOCATABLE_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx))) ||
02988 #endif /* KEY Bug 6845 */
02989              ATT_DEFAULT_INITIALIZED(TYP_IDX(ATD_TYPE_IDX(attr_idx))))  &&
02990             ! AT_DCL_ERR(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) {
02991 
02992       OPND_FLD(opnd)      = AT_Tbl_Idx;
02993       OPND_IDX(opnd)      = attr_idx;
02994       OPND_LINE_NUM(opnd) = SH_GLB_LINE(curr_stmt_sh_idx);
02995       OPND_COL_NUM(opnd)  = SH_COL_NUM(curr_stmt_sh_idx);
02996 
02997 # if defined(_TARGET_OS_MAX)
02998       if (ATD_ARRAY_IDX(attr_idx) ||
02999           ATD_PE_ARRAY_IDX(attr_idx))
03000 # else
03001       if (ATD_ARRAY_IDX(attr_idx))
03002 # endif
03003                                     {
03004          gen_whole_subscript(&opnd, &exp_desc);
03005       }
03006 
03007       process_cpnt_inits(&opnd, 
03008                          TYP_IDX(ATD_TYPE_IDX(attr_idx)),
03009                          func,
03010        opr,
03011                          After);
03012    }
03013 
03014 EXIT:
03015 
03016    TRACE (Func_Exit, "gen_entry_dope_code", NULL);
03017 
03018    return;
03019 
03020 }  /* gen_entry_dope_code */
03021 
03022 /******************************************************************************\
03023 |*                        *|
03024 |* Description:                     *|
03025 |*  recursively go through all components of a structure to look for      *|
03026 |*      pointers. Then call the supplied routine func for processing.         *|
03027 |*                        *|
03028 |* Input parameters:                    *|
03029 |*  left_opnd - current base of sub-object reference.                     *|
03030 |*      type_idx  - defined type attr.                                        *|
03031 |*      func      - function to call for processing.                          *|
03032 |*                        *|
03033 |* Output parameters:                   *|
03034 |*  NONE                      *|
03035 |*                        *|
03036 |* Returns:                     *|
03037 |*  NOTHING                     *|
03038 |*                        *|
03039 \******************************************************************************/
03040 
03041 
03042 void process_cpnt_inits(opnd_type   *left_opnd,
03043       int         type_idx,
03044       void      (*func)(),
03045       int   opr,
03046       sh_position_type  position)
03047 
03048 {
03049    int     attr_idx;
03050    opnd_type   cn_opnd;
03051    int     col;
03052 #ifdef KEY /* Bug 10177 */
03053    int     const_idx = 0;
03054 #else /* KEY Bug 10177 */
03055    int     const_idx;
03056 #endif /* KEY Bug 10177 */
03057    expr_arg_type exp_desc;
03058    int     i;
03059    int     init_idx;
03060    int     ir_idx;
03061    int     line;
03062    int     list_idx;
03063    boolean   need_loops = FALSE;
03064    opnd_type     opnd;
03065    int           placeholder_sh_idx = NULL_IDX;
03066    int           save_curr_stmt_sh_idx;
03067    int     save_target_array_idx;
03068    int     sub_idx;
03069    int     sn_idx;
03070    int     tmp_idx;
03071    opnd_type   tmp_opnd;
03072 
03073    TRACE (Func_Entry, "process_cpnt_inits", NULL);
03074 
03075    find_opnd_line_and_column(left_opnd, &line, &col);
03076 
03077 # ifdef _DEBUG
03078    if (opr != Asg_Opr &&
03079        opr != Init_Opr) {
03080       PRINTMSG(line, 626, Internal, col,
03081                "Asg_Opr or Init_Opr", "process_cpnt_inits");
03082    }
03083 # endif
03084 
03085    save_curr_stmt_sh_idx = curr_stmt_sh_idx;
03086 
03087    if (position == After) {
03088       save_curr_stmt_sh_idx = SH_NEXT_IDX(save_curr_stmt_sh_idx);
03089    }
03090 
03091 # if defined(_GEN_LOOPS_FOR_DV_WHOLE_DEF)
03092    if (func == (void (*)())gen_dv_whole_def_init ||
03093        func == (void (*)())gen_dv_whole_def ||
03094        func == (void (*)())gen_sf_dv_whole_def) {
03095 
03096       need_loops = TRUE;
03097    }
03098 # endif
03099 
03100    if (ATT_DEFAULT_INITIALIZED(type_idx) &&
03101        opr == Asg_Opr) {
03102       need_loops = TRUE;
03103    }
03104 
03105    if (need_loops) {
03106       gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
03107 
03108       if (position == Before) {
03109          curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
03110       }
03111       placeholder_sh_idx = curr_stmt_sh_idx;
03112 
03113       gen_dv_def_loops(left_opnd);
03114 
03115 # ifdef _DEBUG
03116       if (placeholder_sh_idx != curr_stmt_sh_idx) {
03117          PRINTMSG(line, 626, Internal, col,
03118                   "placeholder_sh_idx == curr_stmt_sh_idx",
03119                   "process_cpnt_inits");
03120       }
03121 # endif
03122    }
03123 
03124    sn_idx = ATT_FIRST_CPNT_IDX(type_idx);
03125 
03126    while (sn_idx != NULL_IDX) {
03127       attr_idx = SN_ATTR_IDX(sn_idx);
03128 
03129 #ifdef KEY /* Bug 6845 */
03130       if (ATD_POINTER(attr_idx) || ATD_ALLOCATABLE(attr_idx))
03131 #else /* KEY Bug 6845 */
03132       if (ATD_POINTER(attr_idx))
03133 #endif /* KEY Bug 6845 */
03134       {
03135          NTR_IR_TBL(ir_idx);
03136          IR_OPR(ir_idx) = Struct_Opr;
03137          IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx);
03138          IR_LINE_NUM(ir_idx) = line;
03139          IR_COL_NUM(ir_idx)  = col;
03140          COPY_OPND(IR_OPND_L(ir_idx), (*left_opnd));
03141          IR_FLD_R(ir_idx) = AT_Tbl_Idx;
03142          IR_IDX_R(ir_idx) = attr_idx;
03143          IR_LINE_NUM_R(ir_idx) = line;
03144          IR_COL_NUM_R(ir_idx)  = col;
03145          OPND_FLD(opnd) = IR_Tbl_Idx;
03146          OPND_IDX(opnd) = ir_idx;
03147 
03148          if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) {
03149              IR_RANK(ir_idx) = IR_RANK(IR_IDX_L(ir_idx));
03150          }
03151 
03152          (*func)(&opnd, attr_idx, position);
03153       }
03154       else if (ATD_CPNT_INIT_IDX(attr_idx) != NULL_IDX) {
03155 
03156          NTR_IR_TBL(ir_idx);
03157 
03158          IR_OPR(ir_idx)         = Struct_Opr;
03159          IR_TYPE_IDX(ir_idx)    = ATD_TYPE_IDX(attr_idx);
03160          IR_LINE_NUM(ir_idx)    = line;
03161          IR_COL_NUM(ir_idx)     = col;
03162 
03163          COPY_OPND(IR_OPND_L(ir_idx), (*left_opnd));
03164 
03165          IR_FLD_R(ir_idx)       = AT_Tbl_Idx;
03166          IR_IDX_R(ir_idx)       = attr_idx;
03167          IR_LINE_NUM_R(ir_idx)  = line;
03168          IR_COL_NUM_R(ir_idx)   = col;
03169 
03170          if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) {
03171              IR_RANK(ir_idx)    = IR_RANK(IR_IDX_L(ir_idx));
03172          }
03173 
03174          gen_opnd(&opnd, ir_idx, IR_Tbl_Idx, line, col);
03175 
03176          if (opr == Asg_Opr) {
03177 
03178             if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
03179                exp_desc = init_exp_desc;
03180                gen_whole_subscript(&opnd, &exp_desc);
03181             }
03182             else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {
03183                gen_whole_substring(&opnd, 0);
03184             }
03185 
03186             NTR_IR_TBL(init_idx);
03187 
03188             IR_OPR(init_idx)       = Asg_Opr;
03189             IR_LINE_NUM(init_idx)  = line;
03190             IR_COL_NUM(init_idx)   = col;
03191             IR_TYPE_IDX(init_idx)  = ATD_TYPE_IDX(attr_idx);
03192             COPY_OPND(IR_OPND_L(init_idx), opnd);
03193             IR_LINE_NUM_L(init_idx)= line;
03194             IR_COL_NUM_L(init_idx) = col;
03195 
03196 
03197             IR_IDX_R(init_idx)       = ATD_CPNT_INIT_IDX(attr_idx);
03198             IR_FLD_R(init_idx)       = (fld_type) ATD_FLD(attr_idx);
03199             IR_LINE_NUM_R(init_idx)  = line;
03200             IR_COL_NUM_R(init_idx)   = col;
03201 
03202             gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
03203 
03204             if (position == After) {
03205                SH_IR_IDX(curr_stmt_sh_idx) = init_idx;
03206                SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
03207             }
03208             else {
03209                SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = init_idx;
03210                SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
03211             }
03212          }
03213          else {
03214             /* Init_Opr */
03215 
03216             if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
03217                NTR_IR_TBL(sub_idx);
03218                IR_OPR(sub_idx) = Subscript_Opr;
03219                IR_TYPE_IDX(sub_idx) = ATD_TYPE_IDX(attr_idx);
03220                IR_LINE_NUM(sub_idx) = line;
03221                IR_COL_NUM(sub_idx) = col;
03222 
03223                COPY_OPND(IR_OPND_L(sub_idx), opnd);
03224 
03225                NTR_IR_LIST_TBL(list_idx);
03226                IR_FLD_R(sub_idx) = IL_Tbl_Idx;
03227                IR_IDX_R(sub_idx) = list_idx;
03228                IR_LIST_CNT_R(sub_idx) = 1;
03229 
03230                IL_FLD(list_idx) = BD_LB_FLD(ATD_ARRAY_IDX(attr_idx),1);
03231                IL_IDX(list_idx) = BD_LB_IDX(ATD_ARRAY_IDX(attr_idx),1);
03232                IL_LINE_NUM(list_idx) = line;
03233                IL_COL_NUM(list_idx) = col;
03234 
03235                for (i = 2; i<= BD_RANK(ATD_ARRAY_IDX(attr_idx)); i++) {
03236                   NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03237                   IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03238                   list_idx = IL_NEXT_LIST_IDX(list_idx);
03239 
03240                   IR_LIST_CNT_R(sub_idx) += 1;
03241 
03242                   IL_FLD(list_idx) = BD_LB_FLD(ATD_ARRAY_IDX(attr_idx),i);
03243                   IL_IDX(list_idx) = BD_LB_IDX(ATD_ARRAY_IDX(attr_idx),i);
03244                   IL_LINE_NUM(list_idx) = line;
03245                   IL_COL_NUM(list_idx) = col;
03246                }
03247 
03248                gen_opnd(&opnd, sub_idx, IR_Tbl_Idx, line, col);
03249             }
03250 
03251             if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {
03252                gen_whole_substring(&opnd, 0);
03253             }
03254 
03255             if (ATD_FLD(attr_idx) != CN_Tbl_Idx) {
03256 
03257                gen_opnd(&tmp_opnd, ATD_CPNT_INIT_IDX(attr_idx),
03258                         (fld_type) ATD_FLD(attr_idx), line, col);
03259 
03260                tmp_idx = find_left_attr(&tmp_opnd);
03261 
03262                if (ATD_FLD(tmp_idx) == CN_Tbl_Idx) {
03263                   const_idx = ATD_TMP_IDX(tmp_idx);
03264                }
03265                else if (ATD_FLD(tmp_idx) == IR_Tbl_Idx &&
03266                         IR_OPR(ATD_TMP_IDX(tmp_idx)) == Mult_Opr) {
03267             
03268                   /* this is a scalar broadcast */
03269                   /* so broadcast it now. */
03270 
03271                   const_idx = IR_IDX_R(ATD_TMP_IDX(tmp_idx));
03272 
03273                   save_target_array_idx = target_array_idx;
03274                   target_array_idx = ATD_ARRAY_IDX(attr_idx);
03275 
03276                   exp_desc = init_exp_desc;
03277                   exp_desc.type_idx = CN_TYPE_IDX(const_idx);
03278                   exp_desc.type = TYP_TYPE(exp_desc.type_idx);
03279                   exp_desc.linear_type = TYP_LINEAR(exp_desc.type_idx);
03280                   exp_desc.constant = TRUE;
03281                   exp_desc.foldable = TRUE;
03282 
03283                   gen_opnd(&cn_opnd, const_idx, CN_Tbl_Idx, line, col);
03284                   fold_aggragate_expression(&cn_opnd,
03285                                             &exp_desc,
03286                                              TRUE); /* return constant */
03287                   target_array_idx = save_target_array_idx;
03288 
03289                   const_idx = OPND_IDX(cn_opnd);
03290                }
03291             }
03292             else {
03293                const_idx = ATD_CPNT_INIT_IDX(attr_idx);
03294             }
03295 
03296             gen_init_stmt(&opnd,
03297                           const_idx,
03298                           position);
03299          }
03300       }
03301       else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure           &&
03302                (ATT_POINTER_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx))) ||
03303 #ifdef KEY /* Bug 6845 */
03304                ATT_ALLOCATABLE_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx))) ||
03305 #endif /* KEY Bug 6845 */
03306                 ATT_DEFAULT_INITIALIZED(TYP_IDX(ATD_TYPE_IDX(attr_idx))))) {
03307 
03308          NTR_IR_TBL(ir_idx);
03309          IR_OPR(ir_idx) = Struct_Opr;
03310          IR_TYPE_IDX(ir_idx) = ATD_TYPE_IDX(attr_idx);
03311          IR_LINE_NUM(ir_idx) = line;
03312          IR_COL_NUM(ir_idx)  = col;
03313          COPY_OPND(IR_OPND_L(ir_idx), (*left_opnd));
03314          IR_FLD_R(ir_idx) = AT_Tbl_Idx;
03315          IR_IDX_R(ir_idx) = attr_idx;
03316          IR_LINE_NUM_R(ir_idx) = line;
03317          IR_COL_NUM_R(ir_idx)  = col;
03318          OPND_FLD(opnd) = IR_Tbl_Idx;
03319          OPND_IDX(opnd) = ir_idx;
03320 
03321          if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) {
03322              IR_RANK(ir_idx) = IR_RANK(IR_IDX_L(ir_idx));
03323          }
03324 
03325          if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
03326             exp_desc = init_exp_desc;
03327             gen_whole_subscript(&opnd, &exp_desc);
03328          }
03329 
03330          process_cpnt_inits(&opnd, 
03331                             TYP_IDX(ATD_TYPE_IDX(attr_idx)),
03332                             func,
03333           opr,
03334                             position);
03335 
03336       }
03337 
03338       sn_idx = SN_SIBLING_LINK(sn_idx);
03339    }
03340 
03341    /* remove placeholder_sh_idx */
03342 
03343    if (placeholder_sh_idx != NULL_IDX) {
03344       remove_sh(placeholder_sh_idx);
03345       FREE_SH_NODE(placeholder_sh_idx);
03346    }
03347 
03348    if (position == Before) {
03349       curr_stmt_sh_idx = save_curr_stmt_sh_idx;
03350    }
03351    else {
03352       if (save_curr_stmt_sh_idx != NULL_IDX) {
03353          curr_stmt_sh_idx = SH_PREV_IDX(save_curr_stmt_sh_idx);
03354       }
03355       else {
03356          /* find end of stmts */
03357           while (SH_NEXT_IDX(curr_stmt_sh_idx) != NULL_IDX) {
03358             curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
03359          }
03360       }
03361    }
03362 
03363    TRACE (Func_Exit, "process_cpnt_inits", NULL);
03364 
03365    return;
03366 
03367 }  /* process_cpnt_inits */
03368 
03369 /******************************************************************************\
03370 |*                        *|
03371 |* Description:                     *|
03372 |*  <description>                   *|
03373 |*                        *|
03374 |* Input parameters:                    *|
03375 |*  NONE                      *|
03376 |*                        *|
03377 |* Output parameters:                   *|
03378 |*  NONE                      *|
03379 |*                        *|
03380 |* Returns:                     *|
03381 |*  NOTHING                     *|
03382 |*                        *|
03383 \******************************************************************************/
03384 
03385 static void gen_init_stmt(opnd_type   *left_opnd,
03386                           int     const_idx,
03387                           sh_position_type  position)
03388 
03389 {
03390    int                  array_attr_idx;
03391    opnd_type            base_opnd;
03392    int                  bd_idx;
03393    int                  col;
03394    long64               count = 0;
03395    int                  init_idx;
03396    int                  line;
03397    int                  list_idx;
03398    int                  mult_idx;
03399    int                  num_loops = 0;
03400    opnd_type            opnd;
03401    int                  rank_idx = NULL_IDX;
03402    long_type            result[MAX_WORDS_FOR_INTEGER];
03403    long64         sm_bits;
03404    int                  type_idx;
03405    int                  unused = NULL_IDX;
03406    int                  unused2;
03407    long_type            the_constant[MAX_WORDS_FOR_INTEGER];
03408 
03409 
03410    TRACE (Func_Entry, "gen_init_stmt", NULL);
03411 
03412    find_opnd_line_and_column(left_opnd, &line, &col);
03413 
03414    NTR_IR_TBL(init_idx);
03415    IR_OPR(init_idx) = Init_Opr;
03416    IR_TYPE_IDX(init_idx) = TYPELESS_DEFAULT_TYPE;
03417    IR_LINE_NUM(init_idx) = line;
03418    IR_COL_NUM(init_idx)  = col;
03419 
03420    COPY_OPND(IR_OPND_L(init_idx), (*left_opnd));
03421 
03422    COPY_OPND(opnd, (*left_opnd));
03423    while (OPND_FLD(opnd) == IR_Tbl_Idx) {
03424       if (IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr) {
03425          num_loops++;
03426       }
03427       COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
03428    }
03429 
03430    if (num_loops > 0) {
03431 
03432       if (num_loops == 1) {
03433          /* set up as a single init with rep count and stride */
03434          COPY_OPND(opnd, (*left_opnd));
03435          make_base_subtree(&opnd, &base_opnd, &rank_idx, &unused);
03436 
03437 # ifdef _DEBUG
03438          if (rank_idx == NULL_IDX) {
03439             PRINTMSG(line, 626, Internal, col,
03440                      "whole array subscript",
03441                      "gen_init_stmt");
03442          }
03443 # endif
03444          array_attr_idx = find_base_attr(&IR_OPND_L(rank_idx),
03445                                          &unused,
03446                                          &unused2);
03447 
03448          bd_idx = ATD_ARRAY_IDX(array_attr_idx);
03449 
03450          COPY_OPND(IR_OPND_L(init_idx), base_opnd);
03451 
03452          NTR_IR_LIST_TBL(list_idx);
03453          IR_FLD_R(init_idx) = IL_Tbl_Idx;
03454          IR_IDX_R(init_idx) = list_idx;
03455          IR_LIST_CNT_R(init_idx) = 3;
03456 
03457          /* value */
03458 
03459          IL_FLD(list_idx) = CN_Tbl_Idx;
03460          IL_IDX(list_idx) = const_idx;
03461          IL_LINE_NUM(list_idx) = line;
03462          IL_COL_NUM(list_idx) = col;
03463 
03464          /* rep count */
03465 
03466          NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03467          IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03468          list_idx = IL_NEXT_LIST_IDX(list_idx);
03469 
03470 # ifdef _DEBUG
03471          if (BD_LEN_FLD(bd_idx) != CN_Tbl_Idx) {
03472             PRINTMSG(line, 626, Internal, col,
03473                      "constant array length",
03474                      "gen_init_stmt");
03475          }
03476 # endif
03477          IL_FLD(list_idx) = CN_Tbl_Idx;
03478          IL_IDX(list_idx) = BD_LEN_IDX(bd_idx);
03479          IL_LINE_NUM(list_idx) = line;
03480          IL_COL_NUM(list_idx) = col;
03481 
03482          /* stride in bits */
03483 
03484          NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03485          IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03486          list_idx = IL_NEXT_LIST_IDX(list_idx);
03487 
03488 # ifdef _SM_UNIT_IS_ELEMENT
03489          sm_bits = sm_unit_in_bits(ATD_TYPE_IDX(array_attr_idx));
03490          C_TO_F_INT(the_constant, sm_bits, Integer_8);
03491 # else
03492          if (TYP_TYPE(ATD_TYPE_IDX(array_attr_idx)) == Structure &&
03493              ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(array_attr_idx)))) {
03494             C_TO_F_INT(the_constant, 8, CG_INTEGER_DEFAULT_TYPE);
03495          }
03496          else {
03497             sm_bits = sm_unit_in_bits(ATD_TYPE_IDX(array_attr_idx));
03498             C_TO_F_INT(the_constant, sm_bits, Integer_8);
03499          }
03500 # endif
03501 
03502          type_idx = (CG_INTEGER_DEFAULT_TYPE >
03503                      TYP_LINEAR(CN_TYPE_IDX(BD_SM_IDX(bd_idx, 1))) ?
03504                       CG_INTEGER_DEFAULT_TYPE :
03505                              CN_TYPE_IDX(BD_SM_IDX(bd_idx, 1)));
03506 
03507 
03508          if (folder_driver((char *)&CN_CONST(BD_SM_IDX(bd_idx, 1)),
03509                            CN_TYPE_IDX(BD_SM_IDX(bd_idx, 1)),
03510                            (char *) the_constant,
03511                            CG_INTEGER_DEFAULT_TYPE,
03512                            result,
03513                           &type_idx,
03514                            line,
03515                            col,
03516                            2,
03517                            Mult_Opr)) {
03518 
03519             IL_FLD(list_idx) = CN_Tbl_Idx;
03520             IL_IDX(list_idx) = ntr_const_tbl(type_idx,
03521                                              FALSE,
03522                                              result);
03523             IL_LINE_NUM(list_idx) = line;
03524             IL_COL_NUM(list_idx) = col;
03525          }
03526       }
03527       else {
03528          /* must be all implied do loops */
03529 
03530          copy_subtree(left_opnd, &opnd);
03531          count = create_imp_do_loops(&opnd);
03532          COPY_OPND(IR_OPND_L(init_idx), opnd);
03533 
03534          NTR_IR_LIST_TBL(list_idx);
03535          IR_FLD_R(init_idx) = IL_Tbl_Idx;
03536          IR_IDX_R(init_idx) = list_idx;
03537          IR_LIST_CNT_R(init_idx) = 1;
03538 
03539          NTR_IR_TBL(mult_idx);
03540          IR_OPR(mult_idx) = Mult_Opr;
03541          IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
03542          IR_LINE_NUM(mult_idx) = line;
03543          IR_COL_NUM(mult_idx)  = col;
03544          IR_FLD_L(mult_idx) = CN_Tbl_Idx;
03545          IR_IDX_L(mult_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, count);
03546 
03547          IR_LINE_NUM_L(mult_idx) = line;
03548          IR_COL_NUM_L(mult_idx)  = col;
03549          IR_FLD_R(mult_idx) = CN_Tbl_Idx;
03550          IR_IDX_R(mult_idx) = const_idx;
03551          IR_LINE_NUM_R(mult_idx) = line;
03552          IR_COL_NUM_R(mult_idx)  = col;
03553 
03554          IL_FLD(list_idx) = IR_Tbl_Idx;
03555          IL_IDX(list_idx) = mult_idx;
03556       }
03557    }
03558    else {
03559 
03560       NTR_IR_LIST_TBL(list_idx);
03561       IR_FLD_R(init_idx) = IL_Tbl_Idx;
03562       IR_IDX_R(init_idx) = list_idx;
03563       IR_LIST_CNT_R(init_idx) = 3;
03564 
03565       IL_FLD(list_idx) = CN_Tbl_Idx;
03566       IL_IDX(list_idx) = const_idx;
03567       IL_LINE_NUM(list_idx) = line;
03568       IL_COL_NUM(list_idx)  = col;
03569 
03570       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03571       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03572       list_idx = IL_NEXT_LIST_IDX(list_idx);
03573 
03574       IL_FLD(list_idx) = CN_Tbl_Idx;
03575       IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
03576       IL_LINE_NUM(list_idx) = line;
03577       IL_COL_NUM(list_idx)  = col;
03578 
03579       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03580       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03581       list_idx = IL_NEXT_LIST_IDX(list_idx);
03582 
03583       IL_FLD(list_idx) = CN_Tbl_Idx;
03584       IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
03585       IL_LINE_NUM(list_idx) = line;
03586       IL_COL_NUM(list_idx)  = col;
03587    }
03588 
03589    gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
03590 
03591    if (position == After) {
03592       SH_IR_IDX(curr_stmt_sh_idx)     = init_idx;
03593       SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
03594    }
03595    else {
03596       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = init_idx;
03597       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
03598    }
03599 
03600 
03601    TRACE (Func_Exit, "gen_init_stmt", NULL);
03602 
03603    return;
03604 
03605 }  /* gen_init_stmt */
03606 #ifdef KEY /* Bug 6845 */
03607 
03608 /*
03609  * attr_idx Attribute table index of entity which dope vector represents
03610  * is_array True if dope vector represents an array
03611  * return If entity is an allocatable array whose element type is a
03612  *    derived type, and component(s) of the derived type are
03613  *    themselves allocatable, return the number of allocatable
03614  *    components; otherwise, return 0. If a component is itself
03615  *    a structure containing allocatable array subcomponents, we
03616  *    count them as well.
03617  */
03618 int
03619 do_count_allocatable_cpnt(int attr_idx, int is_array) {
03620   if (!is_array) { /* Not an array */
03621     return 0;
03622     }
03623   int element_type_idx = ATD_TYPE_IDX(attr_idx);
03624   if (TYP_TYPE(element_type_idx) != Structure ||
03625     !ATT_ALLOCATABLE_CPNT(TYP_IDX(element_type_idx))) {
03626     return 0;
03627     }
03628   int count = 0;
03629   for (int sn_idx = ATT_FIRST_CPNT_IDX(TYP_IDX(element_type_idx));
03630     sn_idx != NULL_IDX;
03631     sn_idx = SN_SIBLING_LINK(sn_idx)) {
03632     int cpnt_attr_idx = SN_ATTR_IDX(sn_idx);
03633     if (ATD_ALLOCATABLE(cpnt_attr_idx)) {
03634       count += 1;
03635     }
03636     /* Child structure contains components which are allocatable arrays */
03637     else if (TYP_TYPE(ATD_TYPE_IDX(cpnt_attr_idx)) == Structure) {
03638       count += do_count_allocatable_cpnt(cpnt_attr_idx, 1);
03639     }
03640   }
03641   return count;
03642 }
03643 
03644 /*
03645  * Used by do_alloc_cpnt_offset to append one operand to list
03646  *
03647  * line   source line
03648  * col    source column
03649  * list_idx index of current operand list item
03650  * fld    which table the index belongs to
03651  * idx    index of value of operand
03652  * returns  index of newly created operand list item
03653  */
03654 static int
03655 do_one_operand(int line, int col, int list_idx, fld_type fld, int idx) {
03656    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03657    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03658    list_idx = IL_NEXT_LIST_IDX(list_idx);
03659 
03660    IL_FLD(list_idx) = fld;
03661    IL_IDX(list_idx) = idx;
03662    IL_LINE_NUM(list_idx) = line;
03663    IL_COL_NUM(list_idx)  = col;
03664    return list_idx;
03665 }
03666 
03667 /*
03668  * Append to list of operands of dv_whole_def_opr a boolean indicating
03669  * whether the dope vector has a list of allocatable component offsets
03670  *
03671  * line   source line
03672  * col    source column
03673  * list_idx index of current list item
03674  * n_allocatable_cpnt number of allocatable components
03675  * return index of newly created list item
03676  */
03677 static int
03678 do_alloc_cpnt(int line, int col, int list_idx, int n_allocatable_cpnt) {
03679 
03680    /**************\
03681    |* ALLOC_CPNT *|
03682    \**************/
03683 
03684    return do_one_operand(line, col, list_idx, CN_Tbl_Idx,
03685      (n_allocatable_cpnt ? CN_INTEGER_ONE_IDX : CN_INTEGER_ZERO_IDX));
03686       
03687 }
03688 
03689 /*
03690  * If the dope vector represents an an allocatable array whose element type
03691  * is a derived type having allocatable components, append to the list of
03692  * operands of dv_whole_def_opr a series of byte offsets to the allocatable
03693  * components
03694  *
03695  * line   source line
03696  * col    source column
03697  * list_idx index of current list item (stride of highest dimension of
03698  *    array)
03699  * attr_idx Attribute table index of entity which dope vector represents
03700  * n_allocatable_cpnt number of allocatable components
03701  * return index of last newly created list item (last offset)
03702  */
03703 static int
03704 do_alloc_cpnt_offset(int line, int col, int list_idx, int attr_idx,
03705    int n_allocatable_cpnt) {
03706 
03707    if (0 == n_allocatable_cpnt) {
03708      return list_idx;
03709    }
03710 
03711    /*********************\
03712    |* ALLOC CPNT OFFSET *|
03713    \*********************/
03714 
03715   int element_type_idx = ATD_TYPE_IDX(attr_idx);
03716   for (int sn_idx = ATT_FIRST_CPNT_IDX(TYP_IDX(element_type_idx));
03717     sn_idx != NULL_IDX;
03718     sn_idx = SN_SIBLING_LINK(sn_idx)) {
03719     int cpnt_attr_idx = SN_ATTR_IDX(sn_idx);
03720     if (ATD_ALLOCATABLE(cpnt_attr_idx)) {
03721       list_idx = do_one_operand(line, col, list_idx,
03722   ATD_OFFSET_FLD(cpnt_attr_idx), ATD_CPNT_OFFSET_IDX(cpnt_attr_idx));
03723     }
03724     /* Child structure contains components which are allocatable arrays */
03725     else if (TYP_TYPE(ATD_TYPE_IDX(cpnt_attr_idx)) == Structure) {
03726       list_idx = do_alloc_cpnt_offset(line, col, list_idx, cpnt_attr_idx,
03727         n_allocatable_cpnt);
03728     }
03729   }
03730   return list_idx;
03731 }
03732 #endif /* KEY Bug 6845 */
03733 
03734 /******************************************************************************\
03735 |*                        *|
03736 |* Description:                     *|
03737 |*  Gen the dv_whole_def_opr to set a dope vector in one operation.       *|
03738 |*                        *|
03739 |* Input parameters:                    *|
03740 |*  NONE                      *|
03741 |*                        *|
03742 |* Output parameters:                   *|
03743 |*  NONE                      *|
03744 |*                        *|
03745 |* Returns:                     *|
03746 |*  NOTHING                     *|
03747 |*                        *|
03748 \******************************************************************************/
03749 
03750 void gen_dv_whole_def(opnd_type   *dv_opnd,
03751           opnd_type   *r_opnd,
03752           expr_arg_type     *exp_desc)
03753 
03754 {
03755    act_arg_type a_type;
03756    int    asg_idx;
03757 #ifdef KEY /* Bug 10177 */
03758    int    attr_idx = 0;
03759 #else /* KEY Bug 10177 */
03760    int    attr_idx;
03761 #endif /* KEY Bug 10177 */
03762    opnd_type  base_opnd;
03763    int    col;
03764    int    dim = 1;
03765    int    dope_idx = NULL_IDX;
03766    int    dv_attr_idx;
03767    int    dv2_idx;
03768    int    i;
03769    int    ir_idx;
03770    opnd_type  len_opnd;
03771    int    line;
03772    int    list_idx;
03773    int    list2_idx;
03774    int    loc_idx;
03775    int    max_idx;
03776    int    mult_idx;
03777    opnd_type    opnd;
03778    long   rank;
03779    int    rank_idx = NULL_IDX;
03780    opnd_type    r_dv_opnd;
03781    int          stride_idx;
03782    opnd_type  stride_opnd;
03783 #ifdef KEY /* Bug 10177 */
03784    int          subscript_idx = 0;
03785 #else /* KEY Bug 10177 */
03786    int          subscript_idx;
03787 #endif /* KEY Bug 10177 */
03788    int          type_idx;
03789    boolean      whole_array;
03790 
03791 
03792    TRACE (Func_Entry, "gen_dv_whole_def", NULL);
03793 
03794    dv_attr_idx = find_base_attr(dv_opnd, &line, &col);
03795 
03796    NTR_IR_TBL(asg_idx);
03797    IR_OPR(asg_idx) = Dv_Def_Asg_Opr;
03798    IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
03799    IR_LINE_NUM(asg_idx) = line;
03800    IR_COL_NUM(asg_idx)  = col;
03801 
03802    NTR_IR_TBL(ir_idx);
03803    IR_OPR(ir_idx) = Dv_Whole_Def_Opr;
03804    IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
03805    IR_LINE_NUM(ir_idx) = line;
03806    IR_COL_NUM(ir_idx)  = col;
03807 
03808    COPY_OPND(IR_OPND_L(asg_idx), (*dv_opnd));
03809    IR_FLD_R(asg_idx) = IR_Tbl_Idx;
03810    IR_IDX_R(asg_idx) = ir_idx;
03811 
03812    NTR_IR_LIST_TBL(list_idx);
03813    IR_FLD_L(ir_idx) = IL_Tbl_Idx;
03814    IR_IDX_L(ir_idx) = list_idx;
03815 
03816    rank = (ATD_ARRAY_IDX(dv_attr_idx) ? 
03817                          (long) BD_RANK(ATD_ARRAY_IDX(dv_attr_idx)) : 0);
03818 #ifdef KEY /* Bug 6845 */
03819    int n_allocatable_cpnt = IR_DV_N_ALLOC_CPNT(ir_idx) =
03820      do_count_allocatable_cpnt(dv_attr_idx, rank);
03821    IR_LIST_CNT_L(ir_idx) = 11 + (3 * rank) + n_allocatable_cpnt;
03822 #else /* KEY Bug 6845 */
03823    IR_LIST_CNT_L(ir_idx) = 10 + (3 * rank);
03824 #endif /* KEY Bug 6845 */
03825    IR_DV_DIM(ir_idx) = rank;
03826 
03827    /*************\
03828    |* BASE ADDR *|
03829    \*************/
03830 
03831    NTR_IR_TBL(loc_idx);
03832    IR_OPR(loc_idx)  = Loc_Opr;
03833    IR_LINE_NUM(loc_idx) = line;
03834    IR_COL_NUM(loc_idx)  = col;
03835 
03836    if (exp_desc->type == Character) {
03837       IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
03838    }
03839    else {
03840       IR_TYPE_IDX(loc_idx) = CRI_Ptr_8;
03841    }
03842 
03843    IL_FLD(list_idx) = IR_Tbl_Idx;
03844    IL_IDX(list_idx) = loc_idx;
03845 
03846    if (exp_desc->rank == 0) {
03847       COPY_OPND(IR_OPND_L(loc_idx), (*r_opnd));
03848       just_find_dope_and_rank(r_opnd, &rank_idx, &dope_idx);
03849    }
03850    else {
03851       make_base_subtree(r_opnd, &base_opnd, &rank_idx, &dope_idx);
03852       COPY_OPND(IR_OPND_L(loc_idx), base_opnd);
03853    }
03854 
03855 # ifdef _TRANSFORM_CHAR_SEQUENCE
03856 # ifdef _TARGET_OS_UNICOS
03857    if (exp_desc->type == Structure &&
03858        ATT_CHAR_SEQ(TYP_IDX(exp_desc->type_idx))) {
03859 
03860       IR_TYPE_IDX(loc_idx) = CRI_Ch_Ptr_8;
03861       COPY_OPND(opnd, IR_OPND_L(loc_idx));
03862       transform_char_sequence_ref(&opnd, exp_desc->type_idx);
03863       COPY_OPND(IR_OPND_L(loc_idx), opnd);
03864    }
03865 # endif
03866 # endif
03867 
03868 
03869    /*************************\
03870    |* check for whole array *|
03871    \*************************/
03872 
03873    if (rank_idx != NULL_IDX) {
03874       attr_idx      = find_base_attr(&IR_OPND_L(rank_idx), &line, &col);
03875   
03876       if (ATD_IM_A_DOPE(attr_idx)) {
03877          COPY_OPND(r_dv_opnd, IR_OPND_L(IR_IDX_L(rank_idx)));
03878       }
03879       subscript_idx = IR_IDX_R(rank_idx);
03880    }
03881    else if (exp_desc->rank != 0)              {
03882       attr_idx    = find_base_attr(r_opnd, &line, &col);
03883  
03884       if (ATD_IM_A_DOPE(attr_idx)) {
03885          COPY_OPND(r_dv_opnd, IR_OPND_L(OPND_IDX((*r_opnd))));
03886       }
03887    }
03888    else {
03889       find_opnd_line_and_column(r_opnd, &line, &col);
03890    }
03891 
03892    if (exp_desc->rank > 0 &&
03893        ! exp_desc->section) {
03894 
03895       whole_array = TRUE;
03896    }
03897    else {
03898       whole_array = FALSE;
03899    }
03900 
03901    /*************\
03902    |* EL_LEN    *|
03903    \*************/
03904 
03905    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03906    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03907    list_idx = IL_NEXT_LIST_IDX(list_idx);
03908    type_idx = ATD_TYPE_IDX(dv_attr_idx);
03909 
03910    if (TYP_TYPE(type_idx) == Structure) {
03911       IL_FLD(list_idx)    = ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx));
03912       IL_IDX(list_idx)    = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));
03913       IL_LINE_NUM(list_idx) = line;
03914       IL_COL_NUM(list_idx)  = col;
03915    }
03916    else if (TYP_TYPE(type_idx) == Character) {
03917 
03918       COPY_OPND(opnd, exp_desc->char_len);
03919       OPND_LINE_NUM(opnd) = line;
03920       OPND_COL_NUM(opnd) = col;
03921       compute_char_element_len(&opnd, r_opnd, &len_opnd);
03922 
03923       COPY_OPND(IL_OPND(list_idx), len_opnd);
03924       IL_LINE_NUM(list_idx) = line;
03925       IL_COL_NUM(list_idx) = col;
03926    }
03927    else {
03928       IL_FLD(list_idx) = CN_Tbl_Idx;
03929       IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
03930                                     storage_bit_size_tbl[TYP_LINEAR(type_idx)]);
03931       IL_LINE_NUM(list_idx) = line;
03932       IL_COL_NUM(list_idx)  = col;
03933    }
03934 
03935    /*************\
03936    |* ASSOC     *|
03937    \*************/
03938 
03939    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03940    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03941    list_idx = IL_NEXT_LIST_IDX(list_idx);
03942 
03943    IL_FLD(list_idx) = CN_Tbl_Idx;
03944    IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
03945    IL_LINE_NUM(list_idx) = line;
03946    IL_COL_NUM(list_idx)  = col;
03947 
03948    /*************\
03949    |* PTR_ALLOC *|
03950    \*************/
03951 
03952    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03953    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03954    list_idx = IL_NEXT_LIST_IDX(list_idx);
03955 
03956    if (dope_idx != NULL_IDX) {
03957 
03958       NTR_IR_TBL(dv2_idx);
03959       IR_OPR(dv2_idx) = Dv_Access_Ptr_Alloc;
03960       IR_TYPE_IDX(dv2_idx) = CG_INTEGER_DEFAULT_TYPE;
03961       IR_LINE_NUM(dv2_idx) = line;
03962       IR_COL_NUM(dv2_idx)  = col;
03963       COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
03964       IL_FLD(list_idx) = IR_Tbl_Idx;
03965       IL_IDX(list_idx) = dv2_idx;
03966    }
03967    else {
03968       IL_FLD(list_idx) = CN_Tbl_Idx;
03969       IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
03970       IL_LINE_NUM(list_idx) = line;
03971       IL_COL_NUM(list_idx)  = col;
03972    }
03973 
03974 
03975    /*************\
03976    |* P_OR_A    *|
03977    \*************/
03978 
03979    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
03980    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
03981    list_idx = IL_NEXT_LIST_IDX(list_idx);
03982 
03983    IL_FLD(list_idx) = CN_Tbl_Idx;
03984 
03985    if (ATD_ALLOCATABLE(dv_attr_idx)) {
03986       IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 2);
03987    }
03988    else if (ATD_POINTER(dv_attr_idx)) {
03989       IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
03990    }
03991    else {
03992       IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
03993    }
03994    IL_LINE_NUM(list_idx) = line;
03995    IL_COL_NUM(list_idx)  = col;
03996 
03997 
03998 
03999    /*************\
04000    |* A_CONTIG  *|
04001    \*************/
04002 
04003    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04004    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04005    list_idx = IL_NEXT_LIST_IDX(list_idx);
04006 
04007    a_type = get_act_arg_type(exp_desc);
04008 
04009    if (a_type == Array_Ptr ||
04010        a_type == Array_Tmp_Ptr ||
04011        a_type == Whole_Ass_Shape ||
04012        a_type == Dv_Contig_Section) {
04013 
04014       NTR_IR_TBL(dv2_idx);
04015       IR_OPR(dv2_idx) = Dv_Access_A_Contig;
04016       IR_TYPE_IDX(dv2_idx)   = CG_INTEGER_DEFAULT_TYPE;
04017       IR_LINE_NUM(dv2_idx) = line;
04018       IR_COL_NUM(dv2_idx)  = col;
04019       COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
04020       IL_FLD(list_idx) = IR_Tbl_Idx;
04021       IL_IDX(list_idx) = dv2_idx;
04022 
04023    }
04024    else if (a_type == Whole_Allocatable ||
04025             a_type == Whole_Tmp_Allocatable ||
04026             a_type == Whole_Sequence ||
04027             a_type == Whole_Tmp_Sequence ||
04028             a_type == Whole_Array_Constant ||
04029             a_type == Contig_Section) {
04030 
04031       IL_FLD(list_idx) = CN_Tbl_Idx;
04032       IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
04033       IL_LINE_NUM(list_idx) = line;
04034       IL_COL_NUM(list_idx)  = col;
04035    }
04036    else {
04037       IL_FLD(list_idx) = CN_Tbl_Idx;
04038       IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
04039       IL_LINE_NUM(list_idx) = line;
04040       IL_COL_NUM(list_idx)  = col;
04041    }
04042 
04043 
04044    /*************\
04045    |* N_DIM     *|
04046    \*************/
04047 
04048    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04049    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04050    list_idx = IL_NEXT_LIST_IDX(list_idx);
04051 
04052    IL_FLD(list_idx) = CN_Tbl_Idx;
04053    IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, rank);
04054    IL_LINE_NUM(list_idx) = line;
04055    IL_COL_NUM(list_idx)  = col;
04056 
04057 
04058    /*************\
04059    |* TYPE_CODE *|
04060    \*************/
04061 
04062    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04063    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04064    list_idx = IL_NEXT_LIST_IDX(list_idx);
04065 
04066    IL_FLD(list_idx) = CN_Tbl_Idx;
04067    IL_IDX(list_idx) = create_dv_type_code(dv_attr_idx);
04068    IL_LINE_NUM(list_idx) = line;
04069    IL_COL_NUM(list_idx)  = col;
04070 
04071    /*************\
04072    |* ORIG_BASE *|
04073    \*************/
04074 
04075    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04076    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04077    list_idx = IL_NEXT_LIST_IDX(list_idx);
04078 
04079    if (dope_idx != NULL_IDX) {
04080 
04081       NTR_IR_TBL(dv2_idx);
04082       IR_OPR(dv2_idx) = Dv_Access_Orig_Base;
04083       IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE;
04084       IR_LINE_NUM(dv2_idx) = line;
04085       IR_COL_NUM(dv2_idx)  = col;
04086       COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
04087       IL_FLD(list_idx) = IR_Tbl_Idx;
04088       IL_IDX(list_idx) = dv2_idx;
04089    }
04090    else {
04091       IL_FLD(list_idx) = CN_Tbl_Idx;
04092       IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
04093       IL_LINE_NUM(list_idx) = line;
04094       IL_COL_NUM(list_idx)  = col;
04095    }
04096 
04097 
04098    /*************\
04099    |* ORIG_SIZE *|
04100    \*************/
04101 
04102    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04103    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04104    list_idx = IL_NEXT_LIST_IDX(list_idx);
04105 
04106    if (dope_idx != NULL_IDX) {
04107 
04108       NTR_IR_TBL(dv2_idx);
04109       IR_OPR(dv2_idx) = Dv_Access_Orig_Size;
04110       IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE;
04111       IR_LINE_NUM(dv2_idx) = line;
04112       IR_COL_NUM(dv2_idx)  = col;
04113       COPY_OPND(IR_OPND_L(dv2_idx), IR_OPND_L(dope_idx));
04114       IL_FLD(list_idx) = IR_Tbl_Idx;
04115       IL_IDX(list_idx) = dv2_idx;
04116    }
04117    else {
04118       IL_FLD(list_idx) = CN_Tbl_Idx;
04119       IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
04120       IL_LINE_NUM(list_idx) = line;
04121       IL_COL_NUM(list_idx)  = col;
04122    }
04123 
04124 #ifdef KEY /* Bug 6845 */
04125    list_idx = do_alloc_cpnt(line, col, list_idx, n_allocatable_cpnt);
04126 #endif /* KEY Bug 6845 */
04127 
04128    for (i = 1; i <= rank; i++) {
04129 
04130       /*************\
04131       |* DIM i LB  *|
04132       \*************/
04133 
04134       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04135       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04136       list_idx = IL_NEXT_LIST_IDX(list_idx);
04137 
04138       if (whole_array) {
04139          /* need arrays low bound */
04140          if (ATD_IM_A_DOPE(attr_idx) &&
04141              BD_ARRAY_CLASS(ATD_ARRAY_IDX(attr_idx)) != Assumed_Shape) {
04142             NTR_IR_TBL(dv2_idx);
04143             IR_OPR(dv2_idx)    = Dv_Access_Low_Bound;
04144             IR_TYPE_IDX(dv2_idx) = SA_INTEGER_DEFAULT_TYPE;
04145             IR_LINE_NUM(dv2_idx) = line;
04146             IR_COL_NUM(dv2_idx)  = col;
04147             COPY_OPND(IR_OPND_L(dv2_idx), r_dv_opnd);
04148             IR_DV_DIM(dv2_idx) = i;
04149             IL_FLD(list_idx)   = IR_Tbl_Idx;
04150             IL_IDX(list_idx)   = dv2_idx;
04151          }
04152          else {
04153             IL_FLD(list_idx) = BD_LB_FLD(ATD_ARRAY_IDX(attr_idx), i);
04154             IL_IDX(list_idx) = BD_LB_IDX(ATD_ARRAY_IDX(attr_idx), i);
04155             IL_LINE_NUM(list_idx) = line;
04156             IL_COL_NUM(list_idx)  = col;
04157 
04158             if (IL_FLD(list_idx) == AT_Tbl_Idx) {
04159                ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx));
04160             }
04161          }
04162       }
04163       else {
04164          /* set to one */
04165          IL_FLD(list_idx) = CN_Tbl_Idx;
04166          IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
04167          IL_LINE_NUM(list_idx) = line;
04168          IL_COL_NUM(list_idx)  = col;
04169       }
04170 
04171 
04172       /*************\
04173       |* DIM i EX  *|
04174       \*************/
04175 
04176       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04177       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04178       list_idx = IL_NEXT_LIST_IDX(list_idx);
04179 
04180       NTR_IR_TBL(max_idx);
04181       IR_OPR(max_idx) = Max_Opr;
04182       IR_TYPE_IDX(max_idx) = CG_INTEGER_DEFAULT_TYPE;
04183       IR_LINE_NUM(max_idx) = line;
04184       IR_COL_NUM(max_idx)  = col;
04185 
04186       NTR_IR_LIST_TBL(list2_idx);
04187       IR_FLD_L(max_idx) = IL_Tbl_Idx;
04188       IR_LIST_CNT_L(max_idx) = 2;
04189       IR_IDX_L(max_idx) = list2_idx;
04190 
04191       IL_FLD(list2_idx) = CN_Tbl_Idx;
04192       IL_IDX(list2_idx) = CN_INTEGER_ZERO_IDX;
04193       IL_LINE_NUM(list2_idx) = line;
04194       IL_COL_NUM(list2_idx)  = col;
04195 
04196       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list2_idx));
04197       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list2_idx)) = list2_idx;
04198       list2_idx = IL_NEXT_LIST_IDX(list2_idx);
04199 
04200       COPY_OPND(IL_OPND(list2_idx), exp_desc->shape[i-1]);
04201       IL_LINE_NUM(list2_idx) = line;
04202       IL_COL_NUM(list2_idx) = col;
04203 
04204       IL_FLD(list_idx) = IR_Tbl_Idx;
04205       IL_IDX(list_idx) = max_idx;
04206 
04207       /*************\
04208       |* DIM i SM  *|
04209       \*************/
04210 
04211       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04212       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04213       list_idx = IL_NEXT_LIST_IDX(list_idx);
04214 
04215       if (whole_array) {
04216 
04217          gen_dv_stride_mult(&stride_opnd,
04218                              attr_idx,
04219                             &r_dv_opnd,
04220                              exp_desc,
04221                              i,
04222                              line,
04223                              col);
04224                             
04225          COPY_OPND(IL_OPND(list_idx), stride_opnd);
04226 
04227       }
04228       else {
04229          while (IL_FLD(subscript_idx) != IR_Tbl_Idx ||
04230                 IR_OPR(IL_IDX(subscript_idx)) != Triplet_Opr) {
04231             subscript_idx = IL_NEXT_LIST_IDX(subscript_idx);
04232             dim++;
04233          }
04234 
04235          gen_dv_stride_mult(&stride_opnd,
04236                              attr_idx,
04237                             &r_dv_opnd,
04238                              exp_desc,
04239                              dim,
04240                              line,
04241                              col);
04242 
04243          stride_idx = IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_L(
04244                                                       IL_IDX(subscript_idx))));
04245 
04246          mult_idx = gen_ir(OPND_FLD(stride_opnd), OPND_IDX(stride_opnd),
04247                        Mult_Opr, CG_INTEGER_DEFAULT_TYPE, line, col,
04248                            IL_FLD(stride_idx), IL_IDX(stride_idx));
04249 
04250          IL_FLD(list_idx) = IR_Tbl_Idx;
04251          IL_IDX(list_idx) = mult_idx;
04252 
04253          subscript_idx = IL_NEXT_LIST_IDX(subscript_idx);
04254          dim++;
04255       }
04256    }
04257 
04258 #ifdef KEY /* Bug 6845 */
04259    list_idx = do_alloc_cpnt_offset(line, col, list_idx, dv_attr_idx,
04260      n_allocatable_cpnt);
04261 #endif /* KEY Bug 6845 */
04262 
04263    gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
04264 
04265    SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
04266    SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
04267 
04268    TRACE (Func_Exit, "gen_dv_whole_def", NULL);
04269 
04270    return;
04271 
04272 }  /* gen_dv_whole_def */
04273 
04274 /******************************************************************************\
04275 |*                        *|
04276 |* Description:                     *|
04277 |*  <description>                   *|
04278 |*                        *|
04279 |* Input parameters:                    *|
04280 |*  NONE                      *|
04281 |*                        *|
04282 |* Output parameters:                   *|
04283 |*  NONE                      *|
04284 |*                        *|
04285 |* Returns:                     *|
04286 |*  NOTHING                     *|
04287 |*                        *|
04288 \******************************************************************************/
04289 
04290 static void gen_dv_stride_mult(opnd_type  *stride_opnd,
04291                                int     attr_idx,
04292                                opnd_type  *r_dv_opnd,
04293                                expr_arg_type  *exp_desc,
04294                                int     dim,
04295                                int     line,
04296                                int     col)
04297 
04298 {
04299 # if defined(_EXTENDED_CRI_CHAR_POINTER)
04300    int    clen_idx;
04301 # endif
04302 
04303    int    cn_idx;
04304    int    dv_idx;
04305    int    ir_idx;
04306    long64 res_sm_unit_in_bits;
04307    long64 src_sm_unit_in_bits;
04308 
04309 
04310    TRACE (Func_Entry, "gen_dv_stride_mult", NULL);
04311 
04312    /* res_sm_unit_in_bits describes the sm unit for the result dv */
04313 
04314    if (exp_desc->type == Structure &&
04315        ATT_CHAR_SEQ(TYP_IDX(exp_desc->type_idx))) {
04316       res_sm_unit_in_bits = sm_unit_in_bits(Character_1);
04317    }
04318    else {
04319       res_sm_unit_in_bits = sm_unit_in_bits(exp_desc->type_idx);
04320 #if 0 /* OSP_467, #5, do not adjust the size because 
04321    we patch the stride_multi_unit_in_bits during the compiler initialization */
04322 # ifdef _WHIRL_HOST64_TARGET64
04323       if (res_sm_unit_in_bits > 32)
04324         res_sm_unit_in_bits = 32;
04325 # endif /* _WHIRL_HOST64_TARGET64 */
04326 #endif
04327    }
04328 
04329    /* src_sm_unit_in_bits describes the sm unit for the arrays bd entry */
04330 
04331    if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure &&
04332        ATT_CHAR_SEQ(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) {
04333       src_sm_unit_in_bits = sm_unit_in_bits(Character_1);
04334    }
04335    else {
04336       src_sm_unit_in_bits = sm_unit_in_bits(ATD_TYPE_IDX(attr_idx));
04337    }
04338 
04339 # ifdef _DEBUG
04340    if (res_sm_unit_in_bits == 0 || src_sm_unit_in_bits == 0) {
04341       PRINTMSG(line, 626, Internal, col,
04342                "stride_mult_unit_in_bits",
04343                "gen_dv_stride_mult");
04344    }
04345 # endif
04346 
04347 
04348    if (ATD_IM_A_DOPE(attr_idx)) {
04349       NTR_IR_TBL(dv_idx);
04350       IR_OPR(dv_idx) = Dv_Access_Stride_Mult;
04351       IR_TYPE_IDX(dv_idx) = SA_INTEGER_DEFAULT_TYPE;
04352       IR_LINE_NUM(dv_idx) = line;
04353       IR_COL_NUM(dv_idx)  = col;
04354       COPY_OPND(IR_OPND_L(dv_idx), (*r_dv_opnd));
04355       IR_DV_DIM(dv_idx) = dim;
04356 
04357       OPND_FLD((*stride_opnd)) = IR_Tbl_Idx;
04358       OPND_IDX((*stride_opnd)) = dv_idx;
04359 #ifdef _WHIRL_HOST64_TARGET64
04360     /*
04361      if we are generating a new dope vector from an existing dope vector
04362      we do not need to generate the mulitplier
04363      About the stride muliplier:
04364      Normal vectors have a multiplier of 1
04365      Dope vector(allocatable array) has a multiplier of size(type)/size(int)
04366     */
04367     res_sm_unit_in_bits=src_sm_unit_in_bits;
04368 #endif
04369    }
04370    else {
04371       OPND_FLD((*stride_opnd)) = BD_SM_FLD(ATD_ARRAY_IDX(attr_idx), dim);
04372       OPND_IDX((*stride_opnd)) = BD_SM_IDX(ATD_ARRAY_IDX(attr_idx), dim);
04373       OPND_LINE_NUM((*stride_opnd)) = line;
04374       OPND_COL_NUM((*stride_opnd))  = col;
04375 
04376       if (OPND_FLD((*stride_opnd)) == AT_Tbl_Idx) {
04377          ADD_TMP_TO_SHARED_LIST(OPND_IDX((*stride_opnd)));
04378       }
04379 
04380 # if defined(_EXTENDED_CRI_CHAR_POINTER) 
04381       if (ATD_CLASS(attr_idx) == CRI__Pointee &&
04382 # if defined(KEY)
04383           AT_IS_DARG(attr_idx) &&
04384 # endif
04385           TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {
04386 
04387          NTR_IR_TBL(ir_idx);
04388          IR_OPR(ir_idx)        = Mult_Opr;
04389          IR_TYPE_IDX(ir_idx)   = CG_INTEGER_DEFAULT_TYPE;
04390          IR_LINE_NUM(ir_idx)   = line;
04391          IR_COL_NUM(ir_idx)    = col;
04392 
04393          COPY_OPND(IR_OPND_L(ir_idx), (*stride_opnd));
04394 
04395          NTR_IR_TBL(clen_idx);
04396          IR_OPR(clen_idx) = Clen_Opr;
04397          IR_TYPE_IDX(clen_idx) = CG_INTEGER_DEFAULT_TYPE;
04398          IR_LINE_NUM(clen_idx)   = line;
04399          IR_COL_NUM(clen_idx)    = col;
04400          IR_FLD_L(clen_idx) = AT_Tbl_Idx;
04401          IR_IDX_L(clen_idx) = attr_idx;
04402          IR_LINE_NUM_L(clen_idx)   = line;
04403          IR_COL_NUM_L(clen_idx)    = col;
04404 
04405          IR_FLD_R(ir_idx) = IR_Tbl_Idx;
04406          IR_IDX_R(ir_idx) = clen_idx;
04407 
04408          OPND_FLD((*stride_opnd))   = IR_Tbl_Idx;
04409          OPND_IDX((*stride_opnd))   = ir_idx;
04410       }
04411 # endif
04412    }
04413 
04414 # ifndef _SM_UNIT_IS_ELEMENT
04415    if (src_sm_unit_in_bits != res_sm_unit_in_bits) {
04416 
04417       /* BRIANJ - C_INT_TO_CN has the capability of switching this to */
04418       /* Integer_8 automatically.  See me  KAY */
04419 
04420 
04421       cn_idx =  C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE,
04422                             (src_sm_unit_in_bits / res_sm_unit_in_bits));
04423 
04424       ir_idx = gen_ir(OPND_FLD((*stride_opnd)), 
04425                       OPND_IDX((*stride_opnd)),
04426                       Mult_Opr, 
04427                       CG_INTEGER_DEFAULT_TYPE, 
04428                       line,
04429                       col,
04430                       CN_Tbl_Idx,
04431                       cn_idx);
04432 
04433       OPND_FLD((*stride_opnd))   = IR_Tbl_Idx;
04434       OPND_IDX((*stride_opnd))   = ir_idx;
04435    }
04436 # endif
04437 
04438 
04439    TRACE (Func_Exit, "gen_dv_stride_mult", NULL);
04440 
04441    return;
04442 
04443 }  /* gen_dv_stride_mult */
04444 
04445 #ifdef KEY /* Bug 6845 */
04446 /*
04447  * Insert Dv_Deref_Opr between Subscript_Opr and array
04448  *
04449  * line   Source line
04450  * col    Source column
04451  * parent_idx IR_Tbl_Idx index of parent (Subscript_Opr) node
04452  * child_idx  AT_Tbl_Idx index of child (array) node
04453  */
04454 static void
04455 insert_dv_deref(int line, int col, int parent_idx, int child_idx) {
04456   int dv_deref_idx;
04457   NTR_IR_TBL(dv_deref_idx);
04458   IR_OPR(dv_deref_idx) = Dv_Deref_Opr;
04459   IR_TYPE_IDX(dv_deref_idx) = ATD_TYPE_IDX(child_idx);
04460   IR_LINE_NUM_L(dv_deref_idx) = IR_LINE_NUM(dv_deref_idx) = line;
04461   IR_COL_NUM_L(dv_deref_idx) = IR_COL_NUM(dv_deref_idx)  = col;
04462   IR_FLD_L(dv_deref_idx) = AT_Tbl_Idx;
04463   IR_IDX_L(dv_deref_idx) = child_idx;
04464   IR_FLD_R(dv_deref_idx) = NO_Tbl_Idx;
04465   IR_IDX_R(dv_deref_idx) = NULL_IDX;
04466   IR_FLD_L(parent_idx) = IR_Tbl_Idx;
04467   IR_IDX_L(parent_idx) = dv_deref_idx;
04468 }
04469 
04470 /*
04471  * Call this before gen_loops()
04472  *
04473  * line   Source line
04474  * col    Source column
04475  * return idx of placeholder for use in post_gen_loops()
04476  * next_sh_idx  idx of statement that will follow the end of the last loop
04477  *    once we finish generating loops
04478  */
04479 int
04480 pre_gen_loops(int line, int col, int *next_sh_idx) {
04481   gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
04482   *next_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
04483   return curr_stmt_sh_idx;
04484 }
04485 
04486 /*
04487  * After calling gen_loops() and creating the body of the loops, call this.
04488  *
04489  * placeholder_sh_idx idx from pre_gen_loops()
04490  * next_sh_idx    idx of the statement that follows the end of the last
04491  *      loop
04492  */
04493 void
04494 post_gen_loops(int placeholder_sh_idx, int next_sh_idx) {
04495   remove_sh(placeholder_sh_idx);
04496   FREE_SH_NODE(placeholder_sh_idx);
04497   if (next_sh_idx != NULL_IDX) {
04498     curr_stmt_sh_idx = SH_PREV_IDX(next_sh_idx);
04499   }
04500   else {
04501     while (SH_NEXT_IDX(curr_stmt_sh_idx) != NULL_IDX) {
04502       curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
04503     }
04504   }
04505 }
04506 
04507 /*
04508  * Generate loops to traverse all elements of an array represented by
04509  * Whole_Subscript_Opr or Section_Subscript_Opr opnd_l. Transform opnd_l to
04510  * use the loop index variables as its subscripts. If optional argument
04511  * opnd_r is present, transform it likewise.
04512  *
04513  * The illogic of the statement structure (inherited from gen_dv_def_loops,
04514  * which we generalized to make gen_loops) is that the loops will surround
04515  * the statement associated with curr_stmt_sh_idx, leaving curr_stmt_sh_idx
04516  * set to that statement rather than to the end of the last loop. The usual
04517  * technique is to create a placeholder, save its index, create the loops,
04518  * add statements after the placeholder, delete the placeholder, move
04519  * curr_stmt_sh_idx to the end of the last loop. Yuck. See pre_gen_loops()
04520  * and post_gen_loops().
04521  *
04522  * opnd_l Whole_Subscript_Opr or Section_Subscript_Opr for destination
04523  *    array
04524  * opnd_r Whole_Subscript_Opr or Section_Subscript_Opr for source
04525  *    array which must be conformable with opnd_l (or else null)
04526  * deref  If true, generate dv_deref_idx between the Subscript_Opr and
04527  *    the array variable if that variable is a dope vector
04528  */
04529 void
04530 gen_loops(opnd_type *opnd_l, opnd_type *opnd_r, boolean deref)
04531 {
04532    int    col;
04533    int    line;
04534    opnd_type  temp_l;
04535 
04536    TRACE (Func_Entry, "gen_loops", NULL);
04537 
04538    find_opnd_line_and_column(opnd_l, &line, &col);
04539 
04540    opnd_type next;
04541    int subscripts[STATIC_SUBSCRIPT_SIZE];
04542    int subscript_cnt = 0;
04543    for (COPY_OPND(temp_l, *opnd_l);
04544       (OPND_FLD(temp_l) == IR_Tbl_Idx);
04545       COPY_OPND(temp_l, next)) {
04546 
04547       operator_type ir_opr = IR_OPR(OPND_IDX(temp_l));
04548       if (ir_opr == Whole_Subscript_Opr || ir_opr == Section_Subscript_Opr) {
04549 
04550          IR_OPR(OPND_IDX(temp_l)) = Subscript_Opr;
04551 
04552          for (int list_idx = IR_IDX_R(OPND_IDX(temp_l));
04553       list_idx != NULL_IDX;
04554       list_idx = IL_NEXT_LIST_IDX(list_idx)) {
04555 
04556             if (IL_FLD(list_idx) == IR_Tbl_Idx &&
04557                 IR_OPR(IL_IDX(list_idx)) == Triplet_Opr) {
04558 
04559                int tmp_idx = subscripts[subscript_cnt++] =
04560            gen_compiler_tmp(line, col, Priv, TRUE);
04561             
04562                ATD_TYPE_IDX(tmp_idx) = CG_INTEGER_DEFAULT_TYPE;
04563                ATD_STOR_BLK_IDX(tmp_idx)  = SCP_SB_STACK_IDX(curr_scp_idx);
04564                AT_SEMANTICS_DONE(tmp_idx) = TRUE;
04565 
04566                int list_idx2 = IR_IDX_L(IL_IDX(list_idx));
04567          opnd_type start_opnd;
04568          opnd_type stride_opnd;
04569          opnd_type end_opnd;
04570 
04571                COPY_OPND(start_opnd, IL_OPND(list_idx2));
04572 
04573                list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
04574                COPY_OPND(end_opnd, IL_OPND(list_idx2));
04575 
04576                list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
04577                COPY_OPND(stride_opnd, IL_OPND(list_idx2));
04578 
04579                create_loop_stmts(tmp_idx, &start_opnd, &end_opnd, &stride_opnd,
04580                                  curr_stmt_sh_idx,     /* body start sh idx */
04581                                  curr_stmt_sh_idx);    /* body end sh idx */
04582 
04583                IL_FLD(list_idx) = AT_Tbl_Idx;
04584                IL_IDX(list_idx) = tmp_idx;
04585                IL_LINE_NUM(list_idx) = line;
04586                IL_COL_NUM(list_idx) = col;
04587             }
04588          }
04589       }
04590 
04591       next = IR_OPND_L(OPND_IDX(temp_l));
04592       if (deref && ir_opr != Dv_Deref_Opr && OPND_FLD(next) == AT_Tbl_Idx &&
04593         ATD_IM_A_DOPE(OPND_IDX(next))) {
04594   insert_dv_deref(line, col, OPND_IDX(temp_l), OPND_IDX(next));
04595       }
04596    }
04597 
04598    if (opnd_r) {
04599       subscript_cnt = 0;
04600       opnd_type temp_r;
04601       for (COPY_OPND(temp_r, (*opnd_r));
04602   OPND_FLD(temp_r) == IR_Tbl_Idx;
04603   COPY_OPND(temp_r, next)) {
04604 
04605   operator_type ir_opr = IR_OPR(OPND_IDX(temp_r));
04606   if (ir_opr == Whole_Subscript_Opr || ir_opr == Section_Subscript_Opr) {
04607 
04608      IR_OPR(OPND_IDX(temp_r)) = Subscript_Opr;
04609 
04610      for (int list_idx = IR_IDX_R(OPND_IDX(temp_r));
04611         list_idx != NULL_IDX;
04612         list_idx = IL_NEXT_LIST_IDX(list_idx)) {
04613 
04614         if (IL_FLD(list_idx) == IR_Tbl_Idx &&
04615      IR_OPR(IL_IDX(list_idx)) == Triplet_Opr) {
04616 
04617      IL_FLD(list_idx) = AT_Tbl_Idx;
04618      IL_IDX(list_idx) = subscripts[subscript_cnt++];
04619      IL_LINE_NUM(list_idx) = line;
04620      IL_COL_NUM(list_idx) = col;
04621         }
04622      }
04623   }
04624 
04625   next = IR_OPND_L(OPND_IDX(temp_r));
04626   if (deref && ir_opr != Dv_Deref_Opr && OPND_FLD(next) == AT_Tbl_Idx &&
04627     ATD_IM_A_DOPE(OPND_IDX(next))) {
04628     insert_dv_deref(line, col, OPND_IDX(temp_r), OPND_IDX(next));
04629   }
04630      }
04631    }
04632 
04633    TRACE (Func_Exit, "gen_loops", NULL);
04634 }  /* gen_loops */
04635 
04636 /******************************************************************************\
04637 |*                        *|
04638 |* Description:                     *|
04639 |*  <description>                   *|
04640 |*                        *|
04641 |* Input parameters:                    *|
04642 |*  NONE                      *|
04643 |*                        *|
04644 |* Output parameters:                   *|
04645 |*  NONE                      *|
04646 |*                        *|
04647 |* Returns:                     *|
04648 |*  NOTHING                     *|
04649 |*                        *|
04650 \******************************************************************************/
04651 
04652 static void
04653 gen_dv_def_loops(opnd_type  *dv_opnd)
04654 
04655 {
04656    gen_loops(dv_opnd, 0, FALSE);
04657 }
04658 #endif /* KEY Bug 6845 */
04659 /******************************************************************************\
04660 |*                                                                            *|
04661 |* Description:                                                               *|
04662 |*      Gen the dv_whole_def_opr to set a dope vector in one operation.       *|
04663 |*                                                                            *|
04664 |* Input parameters:                                                          *|
04665 |*      NONE                                                                  *|
04666 |*                                                                            *|
04667 |* Output parameters:                                                         *|
04668 |*      NONE                                                                  *|
04669 |*                                                                            *|
04670 |* Returns:                                                                   *|
04671 |*      NOTHING                                                               *|
04672 |*                                                                            *|
04673 \******************************************************************************/
04674 
04675 void gen_dv_whole_def_init(opnd_type    *dv_opnd,
04676          int      dv_attr_idx,
04677          sh_position_type position)
04678 
04679 {
04680    int      asg_idx;
04681    int      col;
04682    int      i;
04683    int      ir_idx;
04684    size_offset_type length;
04685    int      line;
04686    int      list_idx;
04687    int      mult_idx;
04688    long     rank;
04689    size_offset_type result;
04690    int      type_idx;
04691 
04692 
04693    TRACE (Func_Entry, "gen_dv_whole_def_init", NULL);
04694 
04695    find_opnd_line_and_column(dv_opnd, &line, &col);
04696 
04697    NTR_IR_TBL(asg_idx);
04698    IR_OPR(asg_idx) = Dv_Def_Asg_Opr;
04699    IR_TYPE_IDX(asg_idx) = CG_INTEGER_DEFAULT_TYPE;
04700    IR_LINE_NUM(asg_idx) = line;
04701    IR_COL_NUM(asg_idx)  = col;
04702 
04703    NTR_IR_TBL(ir_idx);
04704    IR_OPR(ir_idx) = Dv_Whole_Def_Opr;
04705    IR_TYPE_IDX(ir_idx) = CG_INTEGER_DEFAULT_TYPE;
04706    IR_LINE_NUM(ir_idx) = line;
04707    IR_COL_NUM(ir_idx)  = col;
04708 
04709    COPY_OPND(IR_OPND_L(asg_idx), (*dv_opnd));
04710    IR_FLD_R(asg_idx) = IR_Tbl_Idx;
04711    IR_IDX_R(asg_idx) = ir_idx;
04712 
04713    NTR_IR_LIST_TBL(list_idx);
04714    IR_FLD_L(ir_idx) = IL_Tbl_Idx;
04715    IR_IDX_L(ir_idx) = list_idx;
04716 
04717    rank = ATD_ARRAY_IDX(dv_attr_idx) ?
04718                         (long) BD_RANK(ATD_ARRAY_IDX(dv_attr_idx)) : 0;
04719 #ifdef KEY /* Bug 6845 */
04720    int n_allocatable_cpnt = IR_DV_N_ALLOC_CPNT(ir_idx) =
04721      do_count_allocatable_cpnt(dv_attr_idx, rank);
04722    IR_LIST_CNT_L(ir_idx) = 11 + (3 * rank) + n_allocatable_cpnt;
04723 #else /* KEY Bug 6845 */
04724    IR_LIST_CNT_L(ir_idx) = 10 + (3 * rank);
04725 #endif /* KEY Bug 6845 */
04726    IR_DV_DIM(ir_idx) = rank;
04727 
04728    /*************\
04729    |* BASE ADDR *|
04730    \*************/
04731 
04732 #ifdef KEY /* Bug 6106 */
04733    /* We want to set the base address to null explicitly so the code behaves
04734     * reproducibly if the user fails to allocate or initialize the variable.
04735     */
04736    IL_FLD(list_idx) = IR_Tbl_Idx;
04737    IL_LINE_NUM(list_idx) = line;
04738    IL_COL_NUM(list_idx) = col;
04739 
04740    int fcd_idx;
04741    NTR_IR_TBL(fcd_idx);
04742    IL_IDX(list_idx) = fcd_idx;
04743    IR_OPR(fcd_idx) = Aloc_Opr;
04744    IR_TYPE_IDX(fcd_idx) = CRI_Ptr_8;
04745    IR_LINE_NUM(fcd_idx) = line;
04746    IR_COL_NUM(fcd_idx)  = col;
04747 
04748    IR_FLD_L(fcd_idx) = CN_Tbl_Idx;
04749    IR_IDX_L(fcd_idx) = (SA_INTEGER_DEFAULT_TYPE == CG_INTEGER_DEFAULT_TYPE) ?
04750      CN_INTEGER_ZERO_IDX : 
04751      C_INT_TO_CN(SA_INTEGER_DEFAULT_TYPE, 0);
04752    IR_LINE_NUM_L(fcd_idx) = line;
04753    IR_COL_NUM_L(fcd_idx)  = col;
04754 #else /* KEY Bug 6106 */
04755    /* leave as null ops */
04756 #endif /* KEY Bug 6106 */
04757 
04758    /*************\
04759    |* EL_LEN    *|
04760    \*************/
04761 
04762    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04763    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04764    list_idx = IL_NEXT_LIST_IDX(list_idx);
04765    type_idx = ATD_TYPE_IDX(dv_attr_idx);
04766 
04767    if (TYP_TYPE(type_idx) == Structure) {
04768       IL_FLD(list_idx)  = (fld_type) ATT_STRUCT_BIT_LEN_FLD(TYP_IDX(type_idx));
04769       IL_IDX(list_idx)  = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));
04770       IL_LINE_NUM(list_idx) = line;
04771       IL_COL_NUM(list_idx)  = col;
04772    }
04773    else if (TYP_TYPE(type_idx) == Character) {
04774 
04775       IL_FLD(list_idx)      = TYP_FLD(type_idx);
04776       IL_IDX(list_idx)      = TYP_IDX(type_idx);
04777       IL_LINE_NUM(list_idx) = line;
04778       IL_COL_NUM(list_idx)  = col;
04779 
04780       if (IL_FLD(list_idx) == AT_Tbl_Idx) {
04781          ADD_TMP_TO_SHARED_LIST(IL_IDX(list_idx));
04782       }
04783 
04784       if (! char_len_in_bytes) {
04785          /* Len is in bytes on solaris */
04786          /* Len is in bits for everyone else */
04787 
04788          if (TYP_FLD(type_idx) == CN_Tbl_Idx) {
04789             result.fld    = CN_Tbl_Idx;
04790             result.idx    = CN_INTEGER_CHAR_BIT_IDX;
04791             length.fld    = TYP_FLD(type_idx);
04792             length.idx    = TYP_IDX(type_idx);
04793    
04794             size_offset_binary_calc(&length,
04795                                     &result,
04796                                      Mult_Opr,
04797                                     &result);
04798 
04799             if (result.fld == NO_Tbl_Idx) {
04800                IL_FLD(list_idx)       = CN_Tbl_Idx;
04801                IL_IDX(list_idx)       = ntr_const_tbl(result.type_idx,
04802                                                       FALSE,
04803                                                       result.constant);
04804             }
04805             else {
04806                IL_FLD(list_idx)       = result.fld;
04807                IL_IDX(list_idx)       = result.idx;
04808             }
04809 
04810             IL_LINE_NUM(list_idx) = line;
04811             IL_COL_NUM(list_idx)  = col;
04812          }
04813          else {
04814             NTR_IR_TBL(mult_idx);
04815             IR_OPR(mult_idx) = Mult_Opr;
04816             IR_TYPE_IDX(mult_idx) = CG_INTEGER_DEFAULT_TYPE;
04817             IR_LINE_NUM(mult_idx) = line;
04818             IR_COL_NUM(mult_idx)  = col;
04819             IR_FLD_L(mult_idx)    = CN_Tbl_Idx;
04820             IR_IDX_L(mult_idx)    = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 8);
04821             IR_LINE_NUM_L(mult_idx) = line;
04822             IR_COL_NUM_L(mult_idx)  = col;
04823    
04824             IR_FLD_R(mult_idx)    = TYP_FLD(type_idx);
04825             IR_IDX_R(mult_idx)    = TYP_IDX(type_idx);
04826             IR_LINE_NUM_R(mult_idx) = line;
04827             IR_COL_NUM_R(mult_idx)  = col;
04828 
04829             IL_FLD(list_idx)      = IR_Tbl_Idx;
04830             IL_IDX(list_idx)      = mult_idx;
04831          }
04832       }
04833    }
04834    else {
04835       IL_FLD(list_idx) = CN_Tbl_Idx;
04836       IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, 
04837                                     storage_bit_size_tbl[TYP_LINEAR(type_idx)]);
04838       IL_LINE_NUM(list_idx) = line;
04839       IL_COL_NUM(list_idx)  = col;
04840    }
04841 
04842    /*************\
04843    |* ASSOC     *|
04844    \*************/
04845 
04846    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04847    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04848    list_idx = IL_NEXT_LIST_IDX(list_idx);
04849 
04850    IL_FLD(list_idx) = CN_Tbl_Idx;
04851    IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
04852    IL_LINE_NUM(list_idx) = line;
04853    IL_COL_NUM(list_idx)  = col;
04854 
04855    /*************\
04856    |* PTR_ALLOC *|
04857    \*************/
04858 
04859    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04860    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04861    list_idx = IL_NEXT_LIST_IDX(list_idx);
04862 
04863    IL_FLD(list_idx) = CN_Tbl_Idx;
04864    IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
04865    IL_LINE_NUM(list_idx) = line;
04866    IL_COL_NUM(list_idx)  = col;
04867 
04868 
04869    /*************\
04870    |* P_OR_A    *|
04871    \*************/
04872 
04873    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04874    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04875    list_idx = IL_NEXT_LIST_IDX(list_idx);
04876 
04877    IL_FLD(list_idx) = CN_Tbl_Idx;
04878 
04879    if (ATD_ALLOCATABLE(dv_attr_idx)) {
04880       IL_IDX(list_idx) = CN_INTEGER_TWO_IDX;
04881    }
04882    else if (ATD_POINTER(dv_attr_idx)) {
04883       IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
04884    }
04885    else {
04886       IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
04887    }
04888    IL_LINE_NUM(list_idx) = line;
04889    IL_COL_NUM(list_idx)  = col;
04890 
04891 
04892 
04893    /*************\
04894    |* A_CONTIG  *|
04895    \*************/
04896 
04897    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04898    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04899    list_idx = IL_NEXT_LIST_IDX(list_idx);
04900 
04901    IL_FLD(list_idx) = CN_Tbl_Idx;
04902 
04903    if (ATD_ALLOCATABLE(dv_attr_idx)) {
04904       IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
04905    }
04906    else {
04907 #ifdef KEY /* Bug 9608 */
04908       /*
04909        * When we set assoc=0 for an array, we also set contig=1 so that
04910        * copyinout doesn't blow up if user (illegally) passes the null pointer
04911        * to a procedure lacking an explicit interface, in the (unjustified)
04912        * expectation that the pointer won't be dereferenced if the procedure
04913        * doesn't refer to the dummy argument. This seems cheaper than adding
04914        * a test for null before and after every call.
04915        */
04916       IL_IDX(list_idx) = rank ? CN_INTEGER_ONE_IDX : CN_INTEGER_ZERO_IDX;
04917 #else /* KEY Bug 9608 */
04918       IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
04919 #endif /* KEY Bug 9608 */
04920    }
04921    IL_LINE_NUM(list_idx) = line;
04922    IL_COL_NUM(list_idx)  = col;
04923 
04924 
04925    /*************\
04926    |* N_DIM     *|
04927    \*************/
04928 
04929    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04930    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04931    list_idx = IL_NEXT_LIST_IDX(list_idx);
04932 
04933    IL_FLD(list_idx) = CN_Tbl_Idx;
04934    IL_IDX(list_idx) = C_INT_TO_CN(CG_INTEGER_DEFAULT_TYPE, rank);
04935    IL_LINE_NUM(list_idx) = line;
04936    IL_COL_NUM(list_idx)  = col;
04937 
04938 
04939    /*************\
04940    |* TYPE_CODE *|
04941    \*************/
04942 
04943    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04944    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04945    list_idx = IL_NEXT_LIST_IDX(list_idx);
04946 
04947    IL_FLD(list_idx) = CN_Tbl_Idx;
04948    IL_IDX(list_idx) = create_dv_type_code(dv_attr_idx);
04949    IL_LINE_NUM(list_idx) = line;
04950    IL_COL_NUM(list_idx)  = col;
04951 
04952    /*************\
04953    |* ORIG_BASE *|
04954    \*************/
04955 
04956    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04957    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04958    list_idx = IL_NEXT_LIST_IDX(list_idx);
04959 
04960    IL_FLD(list_idx) = CN_Tbl_Idx;
04961    IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
04962    IL_LINE_NUM(list_idx) = line;
04963    IL_COL_NUM(list_idx)  = col;
04964 
04965    /*************\
04966    |* ORIG_SIZE *|
04967    \*************/
04968 
04969    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04970    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04971    list_idx = IL_NEXT_LIST_IDX(list_idx);
04972 
04973    IL_FLD(list_idx) = CN_Tbl_Idx;
04974    IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
04975    IL_LINE_NUM(list_idx) = line;
04976    IL_COL_NUM(list_idx)  = col;
04977 
04978 #ifdef KEY /* Bug 6845 */
04979    list_idx = do_alloc_cpnt(line, col, list_idx, n_allocatable_cpnt);
04980 #endif /* KEY Bug 6845 */
04981 
04982    for (i = 1; i <= rank; i++) {
04983 
04984       /*************\
04985       |* DIM i LB  *|
04986       \*************/
04987 
04988       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
04989       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
04990       list_idx = IL_NEXT_LIST_IDX(list_idx);
04991 
04992       if (cmd_line_flags.runtime_bounds) {
04993          IL_FLD(list_idx) = CN_Tbl_Idx;
04994          IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
04995          IL_LINE_NUM(list_idx) = line;
04996          IL_COL_NUM(list_idx) = col;
04997       }
04998 
04999       /*************\
05000       |* DIM i EX  *|
05001       \*************/
05002 
05003       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
05004       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
05005       list_idx = IL_NEXT_LIST_IDX(list_idx);
05006 
05007       if (cmd_line_flags.runtime_bounds) {
05008          IL_FLD(list_idx) = CN_Tbl_Idx;
05009          IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
05010          IL_LINE_NUM(list_idx) = line;
05011          IL_COL_NUM(list_idx) = col;
05012       }
05013 
05014       /*************\
05015       |* DIM i SM  *|
05016       \*************/
05017 
05018       NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
05019       IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
05020       list_idx = IL_NEXT_LIST_IDX(list_idx);
05021 
05022       if (cmd_line_flags.runtime_bounds) {
05023          IL_FLD(list_idx) = CN_Tbl_Idx;
05024          IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
05025          IL_LINE_NUM(list_idx) = line;
05026          IL_COL_NUM(list_idx) = col;
05027       }
05028    }
05029 
05030 #ifdef KEY /* Bug 6845 */
05031    list_idx = do_alloc_cpnt_offset(line, col, list_idx, dv_attr_idx,
05032      n_allocatable_cpnt);
05033 #endif /* KEY Bug 6845 */
05034 
05035    gen_sh(position, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
05036 
05037    if (position == After) {
05038       SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
05039       SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
05040    }
05041    else {
05042       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = asg_idx;
05043       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
05044    }
05045 
05046    TRACE (Func_Exit, "gen_dv_whole_def_init", NULL);
05047 
05048    return;
05049 
05050 } /* gen_dv_whole_def_init */
05051 
05052 /******************************************************************************\
05053 |*                                                                            *|
05054 |* Description:                                                               *|
05055 |*      Make a copy of a reference subtree where sections are replace by      *|
05056 |*      the start value (or lower bound). This is to get the base address     *|
05057 |*      of an array section.                                                  *|
05058 |*                                                                            *|
05059 |* Input parameters:                                                          *|
05060 |*      old_opnd - root of original tree.                                     *|
05061 |*                                                                            *|
05062 |* Output parameters:                                                         *|
05063 |*      new_opnd - root of copy.                                              *|
05064 |*      rank_idx - ir idx to subscript opr that creates the rank.             *|
05065 |*      dope_idx - idx to dv_deref_opr if there is one.                       *|
05066 |*                                                                            *|
05067 |* Returns:                                                                   *|
05068 |*      NOTHING                                                               *|
05069 |*                                                                            *|
05070 \******************************************************************************/
05071 
05072 void make_base_subtree(opnd_type  *old_opnd,
05073                        opnd_type  *new_opnd,
05074                        int        *rank_idx,
05075                        int        *dope_idx)
05076 
05077 {
05078    int    col;
05079    int          dummy_idx;
05080    fld_type     fld;
05081    int          idx;
05082    int    line;
05083    int          list_idx;
05084    int          list2_idx;
05085    int          new_root = NULL_IDX;
05086    opnd_type    n_opnd;
05087    opnd_type    o_opnd;
05088 
05089 
05090    TRACE (Func_Entry, "make_base_subtree", NULL);
05091 
05092    find_opnd_line_and_column(old_opnd, &line, &col);
05093 
05094    OPND_FLD((*new_opnd)) = OPND_FLD((*old_opnd));
05095    idx = OPND_IDX((*old_opnd));
05096    fld = OPND_FLD((*old_opnd));
05097    
05098 
05099    if (idx != NULL_IDX) {
05100 
05101       switch(fld) {
05102 
05103          case NO_Tbl_Idx   :
05104             break;
05105 
05106          case IR_Tbl_Idx :
05107 
05108             if (IR_OPR(idx) == Triplet_Opr) {
05109                COPY_OPND(o_opnd, IL_OPND(IR_IDX_L(idx)));
05110                make_base_subtree(&o_opnd, new_opnd, rank_idx, &dummy_idx);
05111                goto SKIP;
05112             }
05113             else if (IR_OPR(idx) == Call_Opr) {
05114                /* don't process a call and it's arguments. This means that */
05115                /* make_base_subtree was called before deferred function    */
05116                /* flattening occured.                                      */
05117 
05118                new_root = idx;
05119             }
05120             else {
05121 
05122                NTR_IR_TBL(new_root);
05123 
05124                COPY_TBL_NTRY(ir_tbl, new_root, idx);
05125 
05126                /* assume that all ir is now scalar */
05127                IR_RANK(new_root) = 0;
05128 
05129                if (IR_OPR(new_root) == Whole_Subscript_Opr    ||
05130                    IR_OPR(new_root) == Section_Subscript_Opr) {
05131 
05132                   if (*rank_idx != NULL_IDX) {
05133                      PRINTMSG(IR_LINE_NUM(idx), 545, Internal, IR_COL_NUM(idx));
05134                   }
05135                   *rank_idx = idx;
05136 
05137                   IR_OPR(new_root)  = Subscript_Opr;
05138                }
05139                else if (IR_OPR(idx) == Dv_Deref_Opr &&
05140                         *dope_idx   == NULL_IDX)    {
05141                   *dope_idx = idx;
05142                }
05143 
05144                COPY_OPND(o_opnd, IR_OPND_L(idx));
05145                make_base_subtree(&o_opnd, &n_opnd, rank_idx, dope_idx);
05146                COPY_OPND(IR_OPND_L(new_root), n_opnd);
05147 
05148                COPY_OPND(o_opnd, IR_OPND_R(idx));
05149                make_base_subtree(&o_opnd, &n_opnd, rank_idx, &dummy_idx);
05150                COPY_OPND(IR_OPND_R(new_root), n_opnd);
05151             }
05152 
05153             break;
05154 
05155          case AT_Tbl_Idx :
05156          case CN_Tbl_Idx :
05157 
05158             new_root = idx;
05159             OPND_LINE_NUM((*new_opnd)) = line;
05160             OPND_COL_NUM((*new_opnd))  = col;
05161             break;
05162 
05163          case IL_Tbl_Idx :
05164 
05165             NTR_IR_LIST_TBL(new_root);
05166             COPY_TBL_NTRY(ir_list_tbl, new_root, idx);
05167             OPND_LIST_CNT((*new_opnd)) = OPND_LIST_CNT((*old_opnd));
05168             COPY_OPND(o_opnd, IL_OPND(idx));
05169             make_base_subtree(&o_opnd, &n_opnd, rank_idx, &dummy_idx);
05170             COPY_OPND(IL_OPND(new_root), n_opnd);
05171             list2_idx        = new_root;
05172             idx              = IL_NEXT_LIST_IDX(idx);
05173 
05174             while (idx != NULL_IDX) {
05175                NTR_IR_LIST_TBL(list_idx);
05176                COPY_TBL_NTRY(ir_list_tbl, list_idx, idx);
05177 
05178                if (! IL_ARG_DESC_VARIANT(list_idx)) {
05179                   IL_PREV_LIST_IDX(list_idx)  = list2_idx;
05180                }
05181                IL_NEXT_LIST_IDX(list2_idx) = list_idx;
05182                list2_idx                   = list_idx;
05183 
05184                COPY_OPND(o_opnd, IL_OPND(idx));
05185                make_base_subtree(&o_opnd, &n_opnd, rank_idx, &dummy_idx);
05186                COPY_OPND(IL_OPND(list_idx), n_opnd);
05187                idx              = IL_NEXT_LIST_IDX(idx);
05188             }
05189             break;
05190       }
05191    }
05192 
05193    OPND_IDX((*new_opnd)) = new_root;
05194    OPND_FLD((*new_opnd)) = fld;
05195 
05196 SKIP:
05197 
05198    TRACE (Func_Exit, "make_base_subtree", NULL);
05199 
05200    return;
05201 
05202 }  /* make_base_subtree */
05203 
05204 /******************************************************************************\
05205 |*                                                                            *|
05206 |* Description:                                                               *|
05207 |*      Finds the subcript opr that describes the section of an array         *|
05208 |*      section reference and the Dv_Deref_Opr ir idx if there is one.        *|
05209 |*                                                                            *|
05210 |* Input parameters:                                                          *|
05211 |*      old_opnd - root of original tree.                                     *|
05212 |*                                                                            *|
05213 |* Output parameters:                                                         *|
05214 |*      rank_idx - idx of subscript opr that is the section.                  *|
05215 |*      dope_idx - idx of deref opr if there is one.                          *|
05216 |*                                                                            *|
05217 |* Returns:                                                                   *|
05218 |*      NOTHING                                                               *|
05219 |*                                                                            *|
05220 \******************************************************************************/
05221 
05222 static void just_find_dope_and_rank(opnd_type  *old_opnd,
05223                                     int        *rank_idx,
05224                                     int        *dope_idx)
05225 
05226 {
05227    opnd_type    opnd;
05228 
05229    TRACE (Func_Entry, "just_find_dope_and_rank", NULL);
05230 
05231    COPY_OPND(opnd, (*old_opnd));
05232 
05233    while (OPND_FLD(opnd) == IR_Tbl_Idx) {
05234 
05235       if (IR_OPR(OPND_IDX(opnd)) == Section_Subscript_Opr ||
05236           IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr)  {
05237 
05238          if (*rank_idx != NULL_IDX) {
05239             PRINTMSG(IR_LINE_NUM(OPND_IDX(opnd)), 545, Internal,
05240                      IR_COL_NUM(OPND_IDX(opnd)));
05241          }
05242          *rank_idx = OPND_IDX(opnd);
05243       }
05244       else if (IR_OPR(OPND_IDX(opnd)) == Dv_Deref_Opr &&
05245                *dope_idx              == NULL_IDX)    {
05246          *dope_idx = OPND_IDX(opnd);
05247       }
05248 
05249       COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
05250    }
05251 
05252    TRACE (Func_Exit, "just_find_dope_and_rank", NULL);
05253 
05254    return;
05255 
05256 }  /* just_find_dope_and_rank */
05257 
05258 
05259 /******************************************************************************\
05260 |*                        *|
05261 |* Description:                     *|
05262 |*  <description>                   *|
05263 |*                        *|
05264 |* Input parameters:                    *|
05265 |*  NONE                      *|
05266 |*                        *|
05267 |* Output parameters:                   *|
05268 |*  NONE                      *|
05269 |*                        *|
05270 |* Returns:                     *|
05271 |*  NOTHING                     *|
05272 |*                        *|
05273 \******************************************************************************/
05274 
05275 void process_deferred_functions(opnd_type *opnd)
05276 
05277 {
05278    int    col;
05279    int    ir_idx;
05280    int    line;
05281    int    list_idx;
05282    opnd_type  loc_opnd;
05283    int    save_curr_stmt_sh_idx;
05284    int    sh_idx;
05285 
05286    TRACE (Func_Entry, "process_deferred_functions", NULL);
05287 
05288    find_opnd_line_and_column(opnd, &line, &col);
05289 
05290    switch (OPND_FLD((*opnd))) {
05291    case IR_Tbl_Idx:
05292 
05293       ir_idx = OPND_IDX((*opnd));
05294 
05295       if (IR_OPR(ir_idx) == Stmt_Expansion_Opr) {
05296 # ifdef _DEBUG
05297          if (IR_FLD_L(ir_idx) == NO_Tbl_Idx) {
05298             PRINTMSG(IR_LINE_NUM(ir_idx), 626, Internal, IR_COL_NUM(ir_idx),
05299                      "no dags", "process_deferred_functions");
05300          }
05301 # endif
05302          if (STMT_EXPAND_BEFORE_START_SH(ir_idx)) {
05303 
05304             OPND_FLD(loc_opnd) = SH_Tbl_Idx;
05305             OPND_IDX(loc_opnd) = STMT_EXPAND_BEFORE_START_SH(ir_idx);
05306             save_curr_stmt_sh_idx = curr_stmt_sh_idx;
05307             curr_stmt_sh_idx = STMT_EXPAND_BEFORE_START_SH(ir_idx);
05308             process_deferred_functions(&loc_opnd);
05309             curr_stmt_sh_idx = save_curr_stmt_sh_idx;
05310 
05311             sh_idx = STMT_EXPAND_BEFORE_START_SH(ir_idx);
05312             while (SH_PREV_IDX(sh_idx)) {
05313                sh_idx = SH_PREV_IDX(sh_idx);
05314             }
05315             STMT_EXPAND_BEFORE_START_SH(ir_idx) = sh_idx;
05316 
05317             sh_idx = STMT_EXPAND_BEFORE_END_SH(ir_idx);
05318             while (SH_NEXT_IDX(sh_idx)) {
05319                sh_idx = SH_NEXT_IDX(sh_idx);
05320             }
05321             STMT_EXPAND_BEFORE_END_SH(ir_idx) = sh_idx;
05322 
05323             insert_sh_chain(STMT_EXPAND_BEFORE_START_SH(ir_idx),
05324                             STMT_EXPAND_BEFORE_END_SH(ir_idx),
05325                             Before);
05326          }
05327 
05328          if (STMT_EXPAND_AFTER_START_SH(ir_idx)) {
05329 
05330             OPND_FLD(loc_opnd) = SH_Tbl_Idx;
05331             OPND_IDX(loc_opnd) = STMT_EXPAND_AFTER_START_SH(ir_idx);
05332             save_curr_stmt_sh_idx = curr_stmt_sh_idx;
05333             curr_stmt_sh_idx = STMT_EXPAND_AFTER_START_SH(ir_idx);
05334             process_deferred_functions(&loc_opnd);
05335             curr_stmt_sh_idx = save_curr_stmt_sh_idx;
05336 
05337             sh_idx = STMT_EXPAND_AFTER_START_SH(ir_idx);
05338             while (SH_PREV_IDX(sh_idx)) {
05339                sh_idx = SH_PREV_IDX(sh_idx);
05340             }
05341             STMT_EXPAND_AFTER_START_SH(ir_idx) = sh_idx;
05342 
05343             sh_idx = STMT_EXPAND_AFTER_END_SH(ir_idx);
05344             while (SH_NEXT_IDX(sh_idx)) {
05345                sh_idx = SH_NEXT_IDX(sh_idx);
05346             }
05347             STMT_EXPAND_AFTER_END_SH(ir_idx) = sh_idx;
05348 
05349             insert_sh_chain(STMT_EXPAND_AFTER_START_SH(ir_idx),
05350                             STMT_EXPAND_AFTER_END_SH(ir_idx),
05351                             After);
05352          }
05353 
05354          COPY_OPND((*opnd), IR_OPND_L(ir_idx));
05355          IR_OPND_L(ir_idx) = null_opnd;
05356 /*
05357          free_stmt_expansion_opr(ir_idx);
05358 */
05359       }
05360       else {
05361    if (IR_FLD_L(ir_idx) != SH_Tbl_Idx) {
05362       process_deferred_functions(&IR_OPND_L(ir_idx));
05363    }
05364 
05365    if (IR_FLD_R(ir_idx) != SH_Tbl_Idx) {
05366       process_deferred_functions(&IR_OPND_R(ir_idx));
05367    }
05368       }
05369       break;
05370 
05371    case SH_Tbl_Idx:
05372       save_curr_stmt_sh_idx = curr_stmt_sh_idx;
05373       curr_stmt_sh_idx = OPND_IDX((*opnd));
05374 
05375       while (curr_stmt_sh_idx != NULL_IDX) {
05376          OPND_FLD(loc_opnd) = IR_Tbl_Idx;
05377          OPND_IDX(loc_opnd) = SH_IR_IDX(curr_stmt_sh_idx);
05378          process_deferred_functions(&loc_opnd);
05379          SH_IR_IDX(curr_stmt_sh_idx) = OPND_IDX(loc_opnd);
05380          curr_stmt_sh_idx = SH_NEXT_IDX(curr_stmt_sh_idx);
05381       }
05382       curr_stmt_sh_idx = save_curr_stmt_sh_idx;
05383       break;
05384 
05385    case IL_Tbl_Idx:
05386       list_idx = OPND_IDX((*opnd));
05387       while (list_idx) {
05388    if (IL_FLD(list_idx) != SH_Tbl_Idx) {
05389        process_deferred_functions(&IL_OPND(list_idx));
05390    }
05391          list_idx = IL_NEXT_LIST_IDX(list_idx);
05392       }
05393       break;
05394 
05395    }
05396 
05397    TRACE (Func_Exit, "process_deferred_functions", NULL);
05398 
05399    return;
05400 
05401 }  /* process_deferred_functions */
05402 
05403 /******************************************************************************\
05404 |*                                                                            *|
05405 |* Description:                                                               *|
05406 |*      Perform short circuiting on Br_True_Opr stmts.                        *|
05407 |*      Assumes that curr_stmt_sh_idx is the branch stmt.                     *|
05408 |*      This routine is only called when there was a function encountered     *|
05409 |*      in the condition, so process_deferred_functions must always be called *|
05410 |*      whether short circuiting is done or not.                              *|
05411 |*      The top operator (after NOT is de'morganed) must be logical .and. or  *|
05412 |*      .or. in order for this routine to short circuit.                      *|
05413 |*      The "opt" setting must be considered here to possibly prevent         *|
05414 |*      any short circuiting.                                                 *|
05415 |*                                                                            *|
05416 |* Input parameters:                                                          *|
05417 |*      NONE                                                                  *|
05418 |*                                                                            *|
05419 |* Output parameters:                                                         *|
05420 |*      NONE                                                                  *|
05421 |*                                                                            *|
05422 |* Returns:                                                                   *|
05423 |*      NOTHING                                                               *|
05424 |*                                                                            *|
05425 \******************************************************************************/
05426 
05427 void    short_circuit_branch(void)
05428 
05429 {
05430    int    asg_idx;
05431    int          br_true_idx;
05432    int    col;
05433    int          ir_idx;
05434    int    label_idx;
05435    boolean  left_is_worse;
05436    int    line;
05437    int    log_idx;
05438    int          not_cnt   = 0;
05439    int    not_idx;
05440    opnd_type    not_opnd;
05441    opnd_type    opnd;
05442    int    opnd_column;
05443    int    opnd_line;
05444    int          save_curr_stmt_sh_idx;
05445    int    tmp_idx;
05446 
05447 
05448    TRACE (Func_Entry, "short_circuit_branch", NULL);
05449 
05450    br_true_idx = SH_IR_IDX(curr_stmt_sh_idx);
05451 
05452    line = IR_LINE_NUM(br_true_idx);
05453    col  = IR_COL_NUM(br_true_idx);
05454 
05455    COPY_OPND(opnd, IR_OPND_L(br_true_idx));
05456 
05457    while (OPND_FLD(opnd) == IR_Tbl_Idx) {
05458 
05459       switch(IR_OPR(OPND_IDX(opnd))) {
05460          case Not_Opr:
05461             not_cnt++;
05462 
05463             if (not_cnt == 1) {
05464                COPY_OPND(not_opnd, opnd);
05465             }
05466             COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
05467             break;
05468 
05469          case Or_Opr:
05470          case And_Opr:
05471 
05472             log_idx = OPND_IDX(opnd);
05473 
05474             if (IR_SHORT_CIRCUIT_L(log_idx)) {
05475                left_is_worse = TRUE;
05476             }
05477 # if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
05478             else {
05479                left_is_worse = FALSE;
05480             }
05481 # else
05482 /* in case we change our minds about short circuiting decisions, save this */
05483             else if (IR_SHORT_CIRCUIT_R(log_idx)) {
05484                left_is_worse = FALSE;
05485             }
05486             else {
05487                /* no more functions below this operator. */
05488                if (not_cnt%2 == 0) {
05489                   /* nots cancel out */
05490                   COPY_OPND(IR_OPND_L(br_true_idx), opnd);
05491                }
05492                else {
05493                   COPY_OPND(IR_OPND_L(OPND_IDX(not_opnd)), opnd);
05494                   COPY_OPND(IR_OPND_L(br_true_idx), not_opnd);
05495                }
05496                goto OUT;
05497             }
05498 # endif
05499 
05500             if (not_cnt%2 == 0) {
05501                /* nots cancel out */
05502                COPY_OPND(IR_OPND_L(br_true_idx), opnd);
05503             }
05504             else {
05505                /* demorgan it */
05506                COPY_OPND(IR_OPND_L(br_true_idx), opnd);
05507 
05508                if (IR_OPR(log_idx) == Or_Opr) {
05509                   IR_OPR(log_idx) = And_Opr;
05510                }
05511                else {
05512                   IR_OPR(log_idx) = Or_Opr;
05513                }
05514                COPY_OPND(IR_OPND_L(OPND_IDX(not_opnd)), 
05515                          IR_OPND_L(log_idx));
05516                COPY_OPND(IR_OPND_L(log_idx), not_opnd);
05517 
05518                NTR_IR_TBL(ir_idx);
05519                IR_OPR(ir_idx) = Not_Opr;
05520                IR_TYPE_IDX(ir_idx) = LOGICAL_DEFAULT_TYPE;
05521                IR_LINE_NUM(ir_idx) = IR_LINE_NUM(OPND_IDX(not_opnd));
05522                IR_COL_NUM(ir_idx)  = IR_COL_NUM(OPND_IDX(not_opnd));
05523                COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(log_idx));
05524                IR_FLD_R(log_idx) = IR_Tbl_Idx;
05525                IR_IDX_R(log_idx) = ir_idx;
05526             }
05527 
05528             if (IR_OPR(log_idx) == Or_Opr) {
05529 
05530                /* split condition, share label */
05531 
05532                gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
05533 
05534                NTR_IR_TBL(ir_idx);
05535                IR_OPR(ir_idx)      = Br_True_Opr;
05536                IR_TYPE_IDX(ir_idx) = LOGICAL_DEFAULT_TYPE;
05537                IR_LINE_NUM(ir_idx) = line;
05538                IR_COL_NUM(ir_idx)  = col;
05539 
05540 
05541                /* Brian:  This is from s_end.c.  If I'm wrong about needing   */
05542                /* the temp, let me know and I'll get rid of it in both places.*/
05543                /* If we're working on an IF construct expression, transfer the*/
05544                /* branch-around label to the right operand of the Br_True IR  */
05545                /* (replacing the IL list).  The IL_OPND is copied to a temp   */
05546                /* first because sometimes assignments get a little funky      */
05547                /* using these macros if the target is also being used to      */
05548                /* access the source.                      */
05549                /* If we're getting tight on space, could also delete the IL   */
05550                /* nodes.                  */
05551 
05552                if (IR_FLD_R(br_true_idx) == IL_Tbl_Idx) {
05553                   COPY_OPND(opnd, IL_OPND(IR_IDX_R(br_true_idx)));
05554                   COPY_OPND(IR_OPND_R(ir_idx), opnd);
05555                }
05556                else {
05557                   COPY_OPND(IR_OPND_R(ir_idx), IR_OPND_R(br_true_idx));
05558                }
05559 
05560 
05561                if (left_is_worse) {
05562                   COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_R(log_idx));
05563                   COPY_OPND(IR_OPND_L(br_true_idx), IR_OPND_L(log_idx));
05564                }
05565                else {
05566                   COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(log_idx));
05567                   COPY_OPND(IR_OPND_L(br_true_idx), IR_OPND_R(log_idx));
05568                }
05569 
05570                save_curr_stmt_sh_idx = curr_stmt_sh_idx;
05571                curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
05572 
05573                SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
05574                SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
05575 
05576                short_circuit_branch(); 
05577 
05578                curr_stmt_sh_idx = save_curr_stmt_sh_idx;
05579 
05580                short_circuit_branch();
05581             }
05582             else {
05583 
05584                /* generate label */
05585                label_idx = gen_internal_lbl(stmt_start_line);
05586 
05587                gen_sh(After, Continue_Stmt, line, col, FALSE, TRUE, TRUE);
05588 
05589                NTR_IR_TBL(ir_idx);
05590                SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
05591                IR_OPR(ir_idx)              = Label_Opr;
05592                IR_TYPE_IDX(ir_idx)         = TYPELESS_DEFAULT_TYPE;
05593                IR_LINE_NUM(ir_idx)         = line;
05594                IR_COL_NUM(ir_idx)          = col;
05595                IR_FLD_L(ir_idx)            = AT_Tbl_Idx;
05596                IR_IDX_L(ir_idx)            = label_idx;
05597                AT_REFERENCED(label_idx)    = Referenced;
05598                IR_COL_NUM_L(ir_idx)        = col;
05599                IR_LINE_NUM_L(ir_idx)       = line;
05600 
05601                AT_DEFINED(label_idx)       = TRUE;
05602                ATL_DEF_STMT_IDX(label_idx) = curr_stmt_sh_idx;
05603 
05604                SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
05605                curr_stmt_sh_idx                = SH_PREV_IDX(curr_stmt_sh_idx);
05606 
05607                NTR_IR_TBL(ir_idx);
05608                IR_OPR(ir_idx)        = Br_True_Opr;
05609                IR_TYPE_IDX(ir_idx)   = LOGICAL_DEFAULT_TYPE;
05610                IR_LINE_NUM(ir_idx)   = line;
05611                IR_COL_NUM(ir_idx)    = col;
05612                IR_FLD_R(ir_idx)      = AT_Tbl_Idx;
05613                IR_IDX_R(ir_idx)      = label_idx;
05614                IR_LINE_NUM_R(ir_idx) = line;
05615                IR_COL_NUM_R(ir_idx)  = col;
05616 
05617                NTR_IR_TBL(not_idx);
05618                IR_OPR(not_idx)       = Not_Opr;
05619                IR_TYPE_IDX(not_idx)  = LOGICAL_DEFAULT_TYPE;
05620                IR_LINE_NUM(not_idx)  = line;
05621                IR_COL_NUM(not_idx)   = col;
05622                IR_FLD_L(ir_idx)      = IR_Tbl_Idx;
05623                IR_IDX_L(ir_idx)      = not_idx;
05624 
05625                if (left_is_worse) {
05626                   COPY_OPND(IR_OPND_L(not_idx), IR_OPND_R(log_idx));
05627                   COPY_OPND(IR_OPND_L(br_true_idx), IR_OPND_L(log_idx));
05628                }
05629                else {
05630                   COPY_OPND(IR_OPND_L(not_idx), IR_OPND_L(log_idx));
05631                   COPY_OPND(IR_OPND_L(br_true_idx), IR_OPND_R(log_idx));
05632                }
05633                
05634                gen_sh(Before, If_Stmt, line, col, FALSE, FALSE, TRUE);
05635 
05636                save_curr_stmt_sh_idx = curr_stmt_sh_idx;
05637                curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
05638 
05639                SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
05640                SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
05641 
05642                short_circuit_branch();
05643 
05644                curr_stmt_sh_idx = save_curr_stmt_sh_idx;
05645 
05646                short_circuit_branch();
05647             }
05648 
05649             goto EXIT;
05650 
05651          case Paren_Opr:
05652             COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
05653             break;
05654 
05655          default:
05656             if (not_cnt%2 == 0) {
05657                /* nots cancel out */
05658                COPY_OPND(IR_OPND_L(br_true_idx), opnd);
05659             }
05660             else {
05661                COPY_OPND(IR_OPND_L(OPND_IDX(not_opnd)), opnd);
05662                COPY_OPND(IR_OPND_L(br_true_idx), not_opnd);
05663             }
05664 
05665             goto OUT;
05666       }
05667    }
05668 
05669 OUT:
05670 
05671    COPY_OPND(opnd, IR_OPND_L(br_true_idx));
05672 
05673    /* Brian:                      */
05674    /* Just a reminder that the following block of code was duped into         */
05675    /* if_stmt-semantics to avoid short-circuiting the IF conditional          */
05676    /* expression for the high-level form of IF requested by the Mongoose      */
05677    /* optimizer.          LRR Oct-Nov, 1997     */
05678 
05679    if (tree_produces_dealloc(&opnd)) { /* make logical tmp asg */
05680       save_curr_stmt_sh_idx = curr_stmt_sh_idx;
05681       find_opnd_line_and_column(&opnd, &opnd_line, &opnd_column);
05682 
05683       GEN_COMPILER_TMP_ASG(asg_idx,
05684                            tmp_idx,
05685                            TRUE,       /* Semantics done */
05686                            opnd_line,
05687                            opnd_column,
05688                            LOGICAL_DEFAULT_TYPE,
05689                            Priv);
05690 
05691       gen_sh(Before, Assignment_Stmt, opnd_line,
05692              opnd_column, FALSE, FALSE, TRUE);
05693 
05694       curr_stmt_sh_idx = SH_PREV_IDX(curr_stmt_sh_idx);
05695 
05696       SH_IR_IDX(curr_stmt_sh_idx)     = asg_idx;
05697       SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
05698 
05699       process_deferred_functions(&opnd);
05700       COPY_OPND(IR_OPND_R(asg_idx), opnd);
05701 
05702       IR_FLD_L(br_true_idx)      = AT_Tbl_Idx;
05703       IR_IDX_L(br_true_idx)      = tmp_idx;
05704       IR_LINE_NUM_L(br_true_idx) = opnd_line;
05705       IR_COL_NUM_L(br_true_idx)  = opnd_column;
05706       curr_stmt_sh_idx           = save_curr_stmt_sh_idx;
05707    }
05708    else {
05709       process_deferred_functions(&opnd);
05710       COPY_OPND(IR_OPND_L(br_true_idx), opnd);
05711    }
05712 
05713 
05714 EXIT:
05715 
05716    TRACE (Func_Exit, "short_circuit_branch", NULL);
05717 
05718    return;
05719 
05720 }  /* short_circuit_branch */
05721 
05722 /******************************************************************************\
05723 |*                        *|
05724 |* Description:                     *|
05725 |*  Search a subtree to see if it has a variable size function call or    *|
05726 |*      a run time constructor, or dope vector result intrinsic.              *|
05727 |*      All of these produce some sort of dealloc stmt (or stmts) after       *|
05728 |*      the current stmt. The result of the tree must be pulled into a        *|
05729 |*      logical tmp if this routine returns TRUE so that the dealloc          *|
05730 |*      stmts are executed before any branch occurs.                          *|
05731 |*                        *|
05732 |* Input parameters:                    *|
05733 |*  NONE                      *|
05734 |*                        *|
05735 |* Output parameters:                   *|
05736 |*  NONE                      *|
05737 |*                        *|
05738 |* Returns:                     *|
05739 |*  NOTHING                     *|
05740 |*                        *|
05741 \******************************************************************************/
05742 
05743 boolean tree_produces_dealloc(opnd_type *root)
05744 
05745 {
05746    int    i;
05747    int    list_idx;
05748    opnd_type    opnd;
05749    boolean  has_dealloc = FALSE;
05750 
05751 
05752    TRACE (Func_Entry, "tree_produces_dealloc", NULL);
05753 
05754    if (OPND_FLD((*root)) == IR_Tbl_Idx) {
05755 
05756       if (IR_OPR(OPND_IDX((*root))) == Stmt_Expansion_Opr) {
05757 
05758          if (STMT_EXPAND_AFTER_START_SH(OPND_IDX((*root))) != NULL_IDX) {
05759             has_dealloc = TRUE;
05760          }
05761       }
05762       else if (IR_OPR(OPND_IDX((*root))) == Array_Construct_Opr ||
05763                IR_OPR(OPND_IDX((*root))) == Adjustl_Opr         ||
05764                IR_OPR(OPND_IDX((*root))) == Adjustr_Opr)        {
05765 
05766          has_dealloc = TRUE;
05767          goto EXIT;
05768       }
05769       else {
05770 
05771          if (IR_FLD_L(OPND_IDX((*root))) == IR_Tbl_Idx ||
05772              IR_FLD_L(OPND_IDX((*root))) == IL_Tbl_Idx) {
05773 
05774             COPY_OPND(opnd, IR_OPND_L(OPND_IDX((*root))));
05775             has_dealloc = tree_produces_dealloc(&opnd);
05776 
05777             if (has_dealloc) {
05778                goto EXIT;
05779             }
05780          }
05781 
05782          if (IR_FLD_R(OPND_IDX((*root))) == IR_Tbl_Idx ||
05783              IR_FLD_R(OPND_IDX((*root))) == IL_Tbl_Idx) {
05784 
05785             COPY_OPND(opnd, IR_OPND_R(OPND_IDX((*root))));
05786             has_dealloc = tree_produces_dealloc(&opnd);
05787 
05788             if (has_dealloc) {
05789                goto EXIT;
05790             }
05791          }
05792       }
05793    }
05794    else if (OPND_FLD((*root)) == IL_Tbl_Idx) {
05795 
05796       list_idx = OPND_IDX((*root));
05797  
05798       for (i = 0; i < OPND_LIST_CNT((*root)); i++) {
05799 
05800          if (IL_FLD(list_idx) == IR_Tbl_Idx ||
05801              IL_FLD(list_idx) == IL_Tbl_Idx) {
05802 
05803             COPY_OPND(opnd, IL_OPND(list_idx));
05804             has_dealloc = tree_produces_dealloc(&opnd);
05805 
05806             if (has_dealloc) {
05807                goto EXIT;
05808             }
05809          }
05810 
05811          list_idx = IL_NEXT_LIST_IDX(list_idx);
05812       }
05813    }
05814 
05815 EXIT:
05816 
05817    TRACE (Func_Exit, "tree_produces_dealloc", NULL);
05818 
05819    return(has_dealloc);
05820 
05821 }  /* tree_produces_dealloc */
05822 
05823 /******************************************************************************\
05824 |*                        *|
05825 |* Description:                     *|
05826 |*  <description>                   *|
05827 |*                        *|
05828 |* Input parameters:                    *|
05829 |*  NONE                      *|
05830 |*                        *|
05831 |* Output parameters:                   *|
05832 |*  NONE                      *|
05833 |*                        *|
05834 |* Returns:                     *|
05835 |*  NOTHING                     *|
05836 |*                        *|
05837 \******************************************************************************/
05838 
05839 void create_loop_stmts(int    lcv_attr,
05840            opnd_type       *start_opnd,
05841            opnd_type       *end_opnd,
05842            opnd_type       *inc_opnd,
05843            int    body_start_sh_idx,
05844            int    body_end_sh_idx)
05845 
05846 {
05847    int           col;
05848    int           ir_idx;
05849    int           line;
05850    int           save_curr_stmt_sh_idx;
05851 
05852 # if !defined(_HIGH_LEVEL_DO_LOOP_FORM)
05853    int           asg_idx;
05854    int           br_around_label;
05855    int           br_back_label;
05856    int           div_idx;
05857    opnd_type         end_tmp_opnd;
05858    expr_arg_type       exp_desc;
05859    opnd_type         inc_tmp_opnd;
05860    int           log_idx;
05861    int           minus_idx;
05862    int           mult_idx;
05863    opnd_type           opnd;
05864    int           opnd_col;
05865    int           opnd_line;
05866    int           plus_idx;
05867    cif_usage_code_type save_xref_state;
05868    opnd_type         start_tmp_opnd;
05869    int           tmp_idx;
05870    opnd_type         trip_count_tmp_opnd;
05871    opnd_type         trip_counter_tmp_opnd;
05872 # else
05873    int           list_idx;
05874    int           list_idx2;
05875 # endif
05876 
05877 
05878    TRACE (Func_Entry, "create_loop_stmts", NULL);
05879 
05880    save_curr_stmt_sh_idx = curr_stmt_sh_idx;
05881 
05882    line = stmt_start_line;
05883    col  = stmt_start_col;
05884 
05885 # if defined(_HIGH_LEVEL_DO_LOOP_FORM)
05886    curr_stmt_sh_idx = body_end_sh_idx;
05887 
05888    ir_idx = gen_ir(NO_Tbl_Idx, NULL_IDX,
05889                Loop_End_Opr, TYPELESS_DEFAULT_TYPE, line, col,
05890                    NO_Tbl_Idx, NULL_IDX);
05891 
05892    gen_sh(After, Continue_Stmt, line, col, FALSE, FALSE, TRUE);
05893    SH_IR_IDX(curr_stmt_sh_idx)     = ir_idx;
05894    SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
05895    SH_LOOP_END(curr_stmt_sh_idx) = TRUE;
05896 
05897    curr_stmt_sh_idx = body_start_sh_idx;
05898 
05899    NTR_IR_LIST_TBL(list_idx);
05900    gen_opnd(&IL_OPND(list_idx), lcv_attr, AT_Tbl_Idx, line, col);
05901 
05902    NTR_IR_LIST_TBL(list_idx2);
05903    IL_NEXT_LIST_IDX(list_idx) = list_idx2;
05904    IL_PREV_LIST_IDX(list_idx2) = list_idx;
05905 
05906    COPY_OPND(IL_OPND(list_idx2), (*start_opnd));
05907 
05908    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2));
05909    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2;
05910    list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
05911 
05912    COPY_OPND(IL_OPND(list_idx2), (*end_opnd));
05913 
05914    NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx2));
05915    IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx2)) = list_idx2;
05916    list_idx2 = IL_NEXT_LIST_IDX(list_idx2);
05917 
05918    COPY_OPND(IL_OPND(list_idx2), (*inc_opnd));
05919 
05920 
05921    ir_idx = gen_ir(SH_Tbl_Idx, SH_NEXT_IDX(body_end_sh_idx),
05922                Loop_Info_Opr, TYPELESS_DEFAULT_TYPE, line, col,
05923                    IL_Tbl_Idx, list_idx);
05924 
05925    gen_sh(Before, Do_Iterative_Stmt, line, col, FALSE, FALSE, TRUE);
05926    SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = ir_idx;
05927    SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
05928 
05929    SH_PARENT_BLK_IDX(SH_NEXT_IDX(body_end_sh_idx)) = 
05930                                            SH_PREV_IDX(curr_stmt_sh_idx);
05931 
05932 # else
05933    /***************************************************************************\
05934    |* branch around label. Do this first.                                     *|
05935    \***************************************************************************/
05936 
05937    curr_stmt_sh_idx = body_end_sh_idx;
05938 
05939    br_around_label = gen_internal_lbl(line);
05940 
05941    ir_idx = gen_ir(AT_Tbl_Idx, br_around_label,
05942                Label_Opr, TYPELESS_DEFAULT_TYPE, line, col,
05943                    NO_Tbl_Idx, NULL_IDX);
05944 
05945    gen_sh(After, Continue_Stmt, line, col, FALSE, TRUE, TRUE);
05946    SH_IR_IDX(curr_stmt_sh_idx) = ir_idx;
05947 
05948    AT_DEFINED(br_around_label)       = TRUE;
05949    ATL_DEF_STMT_IDX(br_around_label) = curr_stmt_sh_idx;
05950 
05951    SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
05952 
05953 
05954    /***************************************************************************\
05955    |***************************************************************************|
05956    |**                        PREFIX CODE                                    **|
05957    |***************************************************************************|
05958    \***************************************************************************/
05959 
05960    curr_stmt_sh_idx = body_start_sh_idx;
05961 
05962 
05963    /***************************************************************************\
05964    |* temp = start value                                                      *|
05965    \***************************************************************************/
05966 
05967    if (OPND_FLD((*start_opnd)) == CN_Tbl_Idx &&
05968        TYP_LINEAR(CN_TYPE_IDX(OPND_IDX((*start_opnd)))) == 
05969                                                        Short_Typeless_Const) {
05970 
05971       find_opnd_line_and_column(start_opnd, &opnd_line, &opnd_col);
05972       OPND_IDX((*start_opnd)) = cast_typeless_constant(OPND_IDX((*start_opnd)),
05973                                                        ATD_TYPE_IDX(lcv_attr),
05974                                                        opnd_line,
05975                                                        opnd_col);
05976    }
05977 
05978    if (OPND_FLD((*start_opnd)) == CN_Tbl_Idx ||
05979        (OPND_FLD((*start_opnd)) == AT_Tbl_Idx &&
05980         ATD_CLASS(OPND_IDX((*start_opnd))) == Compiler_Tmp)) {
05981 
05982       COPY_OPND(start_tmp_opnd, (*start_opnd));
05983    }
05984    else {
05985 
05986       GEN_COMPILER_TMP_ASG(asg_idx,
05987                            tmp_idx,
05988                            TRUE,  /* Semantics done */
05989                            line,
05990                            col,
05991                            ATD_TYPE_IDX(lcv_attr),
05992                            Priv);
05993 
05994       COPY_OPND(IR_OPND_R(asg_idx), (*start_opnd));
05995 
05996       gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
05997 
05998       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = asg_idx;
05999       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06000 
06001       gen_opnd(&start_tmp_opnd, tmp_idx, AT_Tbl_Idx, line, col);
06002    }
06003    
06004    /***************************************************************************\
06005    |* temp = end value                                                        *|
06006    \***************************************************************************/
06007 
06008    if (OPND_FLD((*end_opnd)) == CN_Tbl_Idx &&
06009        TYP_LINEAR(CN_TYPE_IDX(OPND_IDX((*end_opnd)))) ==
06010                                                        Short_Typeless_Const) {
06011 
06012       find_opnd_line_and_column(end_opnd, &opnd_line, &opnd_col);
06013       OPND_IDX((*end_opnd)) = cast_typeless_constant(OPND_IDX((*end_opnd)),
06014                                                        ATD_TYPE_IDX(lcv_attr),
06015                                                        opnd_line,
06016                                                        opnd_col);
06017    }
06018 
06019    if (OPND_FLD((*end_opnd)) == CN_Tbl_Idx ||
06020        (OPND_FLD((*end_opnd)) == AT_Tbl_Idx &&
06021         ATD_CLASS(OPND_IDX((*end_opnd))) == Compiler_Tmp)) {
06022 
06023       COPY_OPND(end_tmp_opnd, (*end_opnd));
06024    }
06025    else {
06026 
06027       GEN_COMPILER_TMP_ASG(asg_idx,
06028                            tmp_idx,
06029                            TRUE,  /* Semantics done */
06030                            line,
06031                            col,
06032                            ATD_TYPE_IDX(lcv_attr),
06033                            Priv);
06034 
06035       COPY_OPND(IR_OPND_R(asg_idx), (*end_opnd));
06036 
06037       gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
06038 
06039       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = asg_idx;
06040       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06041 
06042       gen_opnd(&end_tmp_opnd, tmp_idx, AT_Tbl_Idx, line, col);
06043    }
06044 
06045    /***************************************************************************\
06046    |* temp = increment value                                                  *|
06047    \***************************************************************************/
06048 
06049    if (OPND_FLD((*inc_opnd)) == CN_Tbl_Idx &&
06050        TYP_LINEAR(CN_TYPE_IDX(OPND_IDX((*inc_opnd)))) ==
06051                                                        Short_Typeless_Const) {
06052 
06053       find_opnd_line_and_column(inc_opnd, &opnd_line, &opnd_col);
06054       OPND_IDX((*inc_opnd)) = cast_typeless_constant(OPND_IDX((*inc_opnd)),
06055                                                        ATD_TYPE_IDX(lcv_attr),
06056                                                        opnd_line,
06057                                                        opnd_col);
06058    }
06059 
06060    if (OPND_FLD((*inc_opnd)) == CN_Tbl_Idx ||
06061        (OPND_FLD((*inc_opnd)) == AT_Tbl_Idx &&
06062         ATD_CLASS(OPND_IDX((*inc_opnd))) == Compiler_Tmp)) {
06063 
06064       COPY_OPND(inc_tmp_opnd, (*inc_opnd));
06065    }
06066    else {
06067 
06068       GEN_COMPILER_TMP_ASG(asg_idx,
06069                            tmp_idx,
06070                            TRUE,  /* Semantics done */
06071                            line,
06072                            col,
06073                            ATD_TYPE_IDX(lcv_attr),
06074                            Priv);
06075 
06076       COPY_OPND(IR_OPND_R(asg_idx), (*inc_opnd));
06077 
06078       gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
06079 
06080       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = asg_idx;
06081       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06082 
06083       gen_opnd(&inc_tmp_opnd, tmp_idx, AT_Tbl_Idx, line, col);
06084    }
06085 
06086    /***************************************************************************\
06087    |* lcv attr = start temp                                                   *|
06088    \***************************************************************************/
06089 
06090    asg_idx = gen_ir(AT_Tbl_Idx, lcv_attr,
06091                Asg_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
06092                     OPND_FLD(start_tmp_opnd), OPND_IDX(start_tmp_opnd));
06093 
06094    gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
06095 
06096    SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = asg_idx;
06097    SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06098 
06099    /***************************************************************************\
06100    |* temp = trip count expression. ((end - start) + inc)/inc                 *|
06101    \***************************************************************************/
06102 
06103 
06104    minus_idx = gen_ir(OPND_FLD(end_tmp_opnd), OPND_IDX(end_tmp_opnd),
06105                  Minus_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
06106                       OPND_FLD(start_tmp_opnd), OPND_IDX(start_tmp_opnd));
06107 
06108    plus_idx = gen_ir(IR_Tbl_Idx, minus_idx,
06109                  Plus_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
06110                      OPND_FLD(inc_tmp_opnd), OPND_IDX(inc_tmp_opnd));
06111 
06112    div_idx = gen_ir(IR_Tbl_Idx, plus_idx,
06113                  Div_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
06114                     OPND_FLD(inc_tmp_opnd), OPND_IDX(inc_tmp_opnd));
06115 
06116    OPND_FLD(opnd) = IR_Tbl_Idx;
06117    OPND_IDX(opnd) = div_idx;
06118 
06119    save_xref_state = xref_state;
06120    xref_state      = CIF_No_Usage_Rec;
06121    expr_semantics(&opnd, &exp_desc);
06122    xref_state      = save_xref_state;
06123 
06124    if (OPND_FLD(opnd) == CN_Tbl_Idx ||
06125        (OPND_FLD(opnd) == AT_Tbl_Idx &&
06126         ATD_CLASS(OPND_IDX(opnd)) == Compiler_Tmp)) {
06127 
06128       COPY_OPND(trip_count_tmp_opnd, opnd);
06129    }
06130    else {
06131 
06132       GEN_COMPILER_TMP_ASG(asg_idx,
06133                            tmp_idx,
06134                            TRUE,  /* Semantics done */
06135                            line,
06136                            col,
06137                            exp_desc.type_idx,
06138                            Priv);
06139 
06140       COPY_OPND(IR_OPND_R(asg_idx), opnd);
06141 
06142       gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
06143    
06144       SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = asg_idx;
06145       SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06146 
06147       gen_opnd(&trip_count_tmp_opnd, tmp_idx, AT_Tbl_Idx, line, col);
06148    }
06149 
06150 
06151    /***************************************************************************\
06152    |* branch around test for trip count <= 0                                  *|
06153    \***************************************************************************/
06154 
06155    log_idx = gen_ir(OPND_FLD(trip_count_tmp_opnd),OPND_IDX(trip_count_tmp_opnd),
06156                 Le_Opr, LOGICAL_DEFAULT_TYPE, line, col,
06157                     CN_Tbl_Idx, CN_INTEGER_ZERO_IDX);
06158 
06159    ir_idx = gen_ir(IR_Tbl_Idx, log_idx,
06160                Br_True_Opr, LOGICAL_DEFAULT_TYPE, line, col,
06161                    AT_Tbl_Idx, br_around_label);
06162 
06163    gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
06164 
06165    SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = ir_idx;
06166    SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06167 
06168    /***************************************************************************\
06169    |* trip counter temp = 0                                                   *|
06170    \***************************************************************************/
06171 
06172    GEN_COMPILER_TMP_ASG(asg_idx,
06173                         tmp_idx,
06174                         TRUE, /* Semantics done */
06175                         line,
06176                         col,
06177                         CG_INTEGER_DEFAULT_TYPE,
06178                         Priv);
06179 
06180    gen_opnd(&IR_OPND_R(asg_idx), CN_INTEGER_ZERO_IDX, CN_Tbl_Idx, line, col);
06181 
06182    gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
06183 
06184    SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = asg_idx;
06185    SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06186 
06187    gen_opnd(&trip_counter_tmp_opnd, tmp_idx, AT_Tbl_Idx, line, col);
06188 
06189    /***************************************************************************\
06190    |* branch back label                                                       *|
06191    \***************************************************************************/
06192 
06193    br_back_label = gen_internal_lbl(line);
06194 
06195    ir_idx = gen_ir(AT_Tbl_Idx, br_back_label,
06196                Label_Opr, TYPELESS_DEFAULT_TYPE, line, col,
06197                    NO_Tbl_Idx, NULL_IDX);
06198 
06199    gen_sh(Before, Continue_Stmt, line, col, FALSE, TRUE, TRUE);
06200    SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx)) = ir_idx;
06201 
06202    AT_DEFINED(br_back_label)       = TRUE;
06203    ATL_DEF_STMT_IDX(br_back_label) = SH_PREV_IDX(curr_stmt_sh_idx);
06204 
06205    if (in_constructor) {
06206       ATL_CONSTRUCTOR_LOOP(br_back_label) = TRUE;
06207    }
06208 
06209    SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06210 
06211    /***************************************************************************\
06212    |* lcv attr = start temp + (trip counter temp * increment temp)            *|
06213    \***************************************************************************/
06214 
06215    mult_idx = gen_ir(OPND_FLD(trip_counter_tmp_opnd), 
06216                                      OPND_IDX(trip_counter_tmp_opnd),
06217                  Mult_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
06218                      OPND_FLD(inc_tmp_opnd), OPND_IDX(inc_tmp_opnd));
06219 
06220    plus_idx = gen_ir(OPND_FLD(start_tmp_opnd), OPND_IDX(start_tmp_opnd),
06221                  Plus_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
06222                      IR_Tbl_Idx, mult_idx);
06223 
06224    asg_idx = gen_ir(AT_Tbl_Idx, lcv_attr,
06225                 Asg_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
06226                     IR_Tbl_Idx, plus_idx);
06227 
06228    gen_sh(Before, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
06229 
06230    SH_IR_IDX(SH_PREV_IDX(curr_stmt_sh_idx))     = asg_idx;
06231    SH_P2_SKIP_ME(SH_PREV_IDX(curr_stmt_sh_idx)) = TRUE;
06232 
06233 
06234 
06235    /***************************************************************************\
06236    |***************************************************************************|
06237    |**                        SUFFIX CODE                                    **|
06238    |***************************************************************************|
06239    \***************************************************************************/
06240 
06241    curr_stmt_sh_idx = body_end_sh_idx;
06242 
06243    /***************************************************************************\
06244    |* trip counter temp = trip counter temp + 1                               *|
06245    \***************************************************************************/
06246 
06247    plus_idx = gen_ir(OPND_FLD(trip_counter_tmp_opnd), 
06248                                   OPND_IDX(trip_counter_tmp_opnd),
06249                  Plus_Opr, CG_INTEGER_DEFAULT_TYPE, line, col,
06250                      CN_Tbl_Idx, CN_INTEGER_ONE_IDX);
06251 
06252    asg_idx = gen_ir(OPND_FLD(trip_counter_tmp_opnd), 
06253                                   OPND_IDX(trip_counter_tmp_opnd),
06254                 Asg_Opr, CG_INTEGER_DEFAULT_TYPE, line, col,
06255                     IR_Tbl_Idx, plus_idx);
06256 
06257    gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
06258    SH_IR_IDX(curr_stmt_sh_idx) = asg_idx;
06259    SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
06260 
06261    /***************************************************************************\
06262    |* branch back test for trip counter temp < trip count                     *|
06263    \***************************************************************************/
06264 
06265    log_idx = gen_ir(OPND_FLD(trip_counter_tmp_opnd),
06266                              OPND_IDX(trip_counter_tmp_opnd),
06267                 Lt_Opr, LOGICAL_DEFAULT_TYPE, line, col,
06268                    OPND_FLD(trip_count_tmp_opnd),OPND_IDX(trip_count_tmp_opnd));
06269 
06270    ir_idx = gen_ir(IR_Tbl_Idx, log_idx,
06271                Br_True_Opr, LOGICAL_DEFAULT_TYPE, line, col,
06272                    AT_Tbl_Idx, br_back_label);
06273 
06274    gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
06275 
06276    SH_IR_IDX(curr_stmt_sh_idx)     = ir_idx;
06277    SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
06278 
06279 
06280    /***************************************************************************\
06281    |* lcv attr = start temp + (trip count temp * increment temp)              *|
06282    \***************************************************************************/
06283 
06284    mult_idx =gen_ir(OPND_FLD(trip_count_tmp_opnd),OPND_IDX(trip_count_tmp_opnd),
06285                  Mult_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
06286                      OPND_FLD(inc_tmp_opnd), OPND_IDX(inc_tmp_opnd));
06287 
06288    plus_idx = gen_ir(OPND_FLD(start_tmp_opnd), OPND_IDX(start_tmp_opnd),
06289                  Plus_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
06290                      IR_Tbl_Idx, mult_idx);
06291 
06292    asg_idx = gen_ir(AT_Tbl_Idx, lcv_attr,
06293                 Asg_Opr, ATD_TYPE_IDX(lcv_attr), line, col,
06294                     IR_Tbl_Idx, plus_idx);
06295 
06296    gen_sh(After, Assignment_Stmt, line, col, FALSE, FALSE, TRUE);
06297 
06298    SH_IR_IDX(curr_stmt_sh_idx)     = asg_idx;
06299    SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
06300 
06301 # endif
06302 
06303 
06304    curr_stmt_sh_idx = save_curr_stmt_sh_idx;
06305 
06306    TRACE (Func_Exit, "create_loop_stmts", NULL);
06307 
06308    return;
06309 
06310 }  /* create_loop_stmts */
06311 
06312 /******************************************************************************\
06313 |*                        *|
06314 |* Description:                     *|
06315 |*  Create an array bounds table entry from an expr_arg_type arg          *|
06316 |*      All bounds info must be constant.                                     *|
06317 |*                        *|
06318 |* Input parameters:                    *|
06319 |*  NONE                      *|
06320 |*                        *|
06321 |* Output parameters:                   *|
06322 |*  NONE                      *|
06323 |*                        *|
06324 |* Returns:                     *|
06325 |*  NOTHING                     *|
06326 |*                        *|
06327 \******************************************************************************/
06328 
06329 int create_bd_ntry_for_const(expr_arg_type  *exp_desc,
06330                                  int     line,
06331          int     col)
06332 
06333 {
06334    int      bd_idx;
06335    size_offset_type extent;
06336    int      i;
06337    size_offset_type num_elements;
06338    size_offset_type stride;
06339 
06340 
06341    TRACE (Func_Entry, "create_bd_ntry_for_const", NULL);
06342 
06343    bd_idx     = reserve_array_ntry(exp_desc->rank);
06344    BD_RANK(bd_idx)    = exp_desc->rank;
06345    BD_LINE_NUM(bd_idx)    = line;
06346    BD_COLUMN_NUM(bd_idx)  = col;
06347    BD_ARRAY_SIZE(bd_idx)  = Constant_Size;
06348    BD_ARRAY_CLASS(bd_idx) = Explicit_Shape;
06349    BD_RESOLVED(bd_idx)    = TRUE;
06350 
06351    num_elements.idx     = CN_INTEGER_ONE_IDX;
06352    num_elements.fld   = CN_Tbl_Idx;
06353 
06354    for (i = 1; i <= exp_desc->rank; i++) {
06355       BD_LB_FLD(bd_idx,i) = CN_Tbl_Idx;
06356       BD_LB_IDX(bd_idx,i) = CN_INTEGER_ONE_IDX;
06357 
06358       if (OPND_FLD(exp_desc->shape[i-1]) == CN_Tbl_Idx) {
06359          BD_UB_FLD(bd_idx,i) = OPND_FLD(exp_desc->shape[i-1]);
06360          BD_UB_IDX(bd_idx,i) = OPND_IDX(exp_desc->shape[i-1]);
06361       }
06362       else {
06363          PRINTMSG(line, 966, Internal, col);
06364       }
06365 
06366       BD_XT_FLD(bd_idx,i) = BD_UB_FLD(bd_idx,i);
06367       BD_XT_IDX(bd_idx,i) = BD_UB_IDX(bd_idx,i);
06368 
06369       extent.fld  = BD_XT_FLD(bd_idx,i);
06370       extent.idx  = BD_XT_IDX(bd_idx,i);
06371 
06372       size_offset_binary_calc(&extent,
06373                               &num_elements,
06374                                Mult_Opr,
06375                               &num_elements);
06376    }
06377 
06378    if (num_elements.fld == NO_Tbl_Idx) {
06379       BD_LEN_FLD(bd_idx) = CN_Tbl_Idx;
06380       BD_LEN_IDX(bd_idx) = ntr_const_tbl(num_elements.type_idx,
06381                                          FALSE,
06382                                          num_elements.constant);
06383    }
06384    else {
06385       BD_LEN_FLD(bd_idx) = num_elements.fld;
06386       BD_LEN_IDX(bd_idx) = num_elements.idx;
06387    }
06388 
06389    /* fill in stride multipliers now */
06390 
06391    set_stride_for_first_dim(exp_desc->type_idx, &stride);
06392 
06393    BD_SM_FLD(bd_idx, 1) = stride.fld;
06394    BD_SM_IDX(bd_idx, 1) = stride.idx;
06395 
06396    for (i = 2; i <= BD_RANK(bd_idx); i++) {
06397       extent.fld  = BD_XT_FLD(bd_idx,i-1);
06398       extent.idx  = BD_XT_IDX(bd_idx,i-1);
06399 
06400       size_offset_binary_calc(&extent, &stride, Mult_Opr, &stride);
06401 
06402       if (stride.fld == NO_Tbl_Idx) {
06403          stride.fld = CN_Tbl_Idx;
06404          stride.idx = ntr_const_tbl(stride.type_idx,
06405                                         FALSE,
06406                                         stride.constant);
06407       }
06408 
06409       BD_SM_FLD(bd_idx, i)  = stride.fld;
06410       BD_SM_IDX(bd_idx, i)  = stride.idx;
06411    }
06412 
06413    bd_idx =  ntr_array_in_bd_tbl(bd_idx);
06414 
06415    TRACE (Func_Exit, "create_bd_ntry_for_const", NULL);
06416 
06417    return(bd_idx);
06418 
06419 }  /* create_bd_ntry_for_const */
06420 
06421 /******************************************************************************\
06422 |*                        *|
06423 |* Description:                     *|
06424 |*  Fold the clen_opr if possible.                                        *|
06425 |*                        *|
06426 |* Input parameters:                    *|
06427 |*  NONE                      *|
06428 |*                        *|
06429 |* Output parameters:                   *|
06430 |*  NONE                      *|
06431 |*                        *|
06432 |* Returns:                     *|
06433 |*  NOTHING                     *|
06434 |*                        *|
06435 \******************************************************************************/
06436 
06437 void fold_clen_opr(opnd_type    *opnd,
06438        expr_arg_type  *exp_desc)
06439 
06440 {
06441    int    attr_idx;
06442    int    clen_idx;
06443    int    col;
06444    int    ir_idx;
06445    int    line;
06446    int    list_idx;
06447    int    shift_idx;
06448    int    type_idx;
06449 
06450 
06451    TRACE (Func_Entry, "fold_clen_opr", NULL);
06452 
06453    find_opnd_line_and_column(opnd, &line, &col);
06454 
06455    if (OPND_FLD((*opnd)) != IR_Tbl_Idx ||
06456        IR_OPR(OPND_IDX((*opnd))) != Clen_Opr) {
06457 
06458       goto EXIT;
06459    }
06460 
06461    clen_idx = OPND_IDX((*opnd));
06462 
06463    exp_desc->type_idx    = IR_TYPE_IDX(clen_idx);
06464    exp_desc->type        = TYP_TYPE(exp_desc->type_idx);
06465    exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);
06466 
06467    switch (IR_FLD_L(clen_idx)) {
06468       case AT_Tbl_Idx :
06469          attr_idx = IR_IDX_L(clen_idx);
06470 
06471          if (AT_OBJ_CLASS(attr_idx) == Data_Obj &&
06472              (ATD_IM_A_DOPE(attr_idx)    ||
06473               ATD_POINTER(attr_idx)      ||
06474               ATD_ALLOCATABLE(attr_idx))) {
06475 
06476             if (char_len_in_bytes) {
06477 
06478                /* the length is already in bytes for solaris */
06479 
06480                NTR_IR_TBL(ir_idx);
06481                IR_OPR(ir_idx)           = Dv_Access_El_Len;
06482                IR_TYPE_IDX(ir_idx)      = SA_INTEGER_DEFAULT_TYPE;
06483                IR_LINE_NUM(ir_idx)      = line;
06484                IR_COL_NUM(ir_idx)       = col;
06485                COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(clen_idx));
06486 
06487                OPND_FLD((*opnd)) = IR_Tbl_Idx;
06488                OPND_IDX((*opnd)) = ir_idx;
06489             }
06490             else {
06491 
06492                /* must shift the bits to bytes */
06493 
06494                NTR_IR_TBL(ir_idx);
06495                IR_OPR(ir_idx)           = Dv_Access_El_Len;
06496                IR_TYPE_IDX(ir_idx)      = SA_INTEGER_DEFAULT_TYPE;
06497                IR_LINE_NUM(ir_idx)      = line;
06498                IR_COL_NUM(ir_idx)       = col;
06499                COPY_OPND(IR_OPND_L(ir_idx), IR_OPND_L(clen_idx));
06500                NTR_IR_TBL(shift_idx);
06501                IR_OPR(shift_idx)        = Shiftr_Opr;
06502                IR_TYPE_IDX(shift_idx)   = SA_INTEGER_DEFAULT_TYPE;
06503                IR_LINE_NUM(shift_idx)   = line;
06504                IR_COL_NUM(shift_idx)    = col;
06505 
06506                NTR_IR_LIST_TBL(list_idx);
06507     
06508                IR_FLD_L(shift_idx)      = IL_Tbl_Idx;
06509                IR_IDX_L(shift_idx)      = list_idx;
06510                IR_LIST_CNT_L(shift_idx) = 2;
06511                IL_FLD(list_idx)         = IR_Tbl_Idx;
06512                IL_IDX(list_idx)         = ir_idx;
06513 
06514                NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
06515                IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
06516                list_idx = IL_NEXT_LIST_IDX(list_idx);
06517 
06518                IL_FLD(list_idx)      = CN_Tbl_Idx;
06519                IL_LINE_NUM(list_idx) = line;
06520                IL_COL_NUM(list_idx)  = col;
06521                IL_IDX(list_idx) = CN_INTEGER_THREE_IDX;
06522    
06523                OPND_FLD((*opnd)) = IR_Tbl_Idx;
06524                OPND_IDX((*opnd)) = shift_idx;
06525             }
06526 
06527             exp_desc->type_idx = CG_INTEGER_DEFAULT_TYPE;
06528             exp_desc->type     = Integer;
06529             exp_desc->linear_type = CG_INTEGER_DEFAULT_TYPE;
06530          }
06531          break;
06532 
06533       case CN_Tbl_Idx :
06534          type_idx   = CN_TYPE_IDX(IR_IDX_L(clen_idx));
06535          OPND_FLD((*opnd))  = TYP_FLD(type_idx);
06536          OPND_IDX((*opnd))  = TYP_IDX(type_idx);
06537          OPND_LINE_NUM((*opnd)) = line;
06538          OPND_COL_NUM((*opnd))  = col;
06539          exp_desc->constant = TRUE;
06540          exp_desc->foldable = TRUE;
06541 
06542          if (TYP_FLD(type_idx) == CN_Tbl_Idx) {
06543             exp_desc->type_idx = CN_TYPE_IDX(TYP_IDX(type_idx));
06544          }
06545          else {
06546             exp_desc->type_idx = ATD_TYPE_IDX(TYP_IDX(type_idx));
06547          }
06548 
06549          exp_desc->type = TYP_TYPE(exp_desc->type_idx);
06550          exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);
06551          break;
06552 
06553       case IR_Tbl_Idx :
06554 
06555          ir_idx = IR_IDX_L(clen_idx);
06556 
06557          if ((IR_OPR(ir_idx) == Substring_Opr        ||
06558               IR_OPR(ir_idx) == Whole_Substring_Opr)  &&
06559              IL_FLD(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(IR_IDX_R(ir_idx)))) 
06560                                                              != NO_Tbl_Idx) {
06561 
06562             COPY_OPND((*opnd), IL_OPND(IL_NEXT_LIST_IDX(IL_NEXT_LIST_IDX(
06563                                     IR_IDX_R(ir_idx)))));
06564 
06565             if (OPND_FLD((*opnd)) == CN_Tbl_Idx) {
06566                exp_desc->type_idx = CN_TYPE_IDX(OPND_IDX((*opnd)));
06567                exp_desc->constant = TRUE;
06568                exp_desc->foldable = TRUE;
06569             }
06570             else if (OPND_FLD((*opnd)) == IR_Tbl_Idx) {
06571                exp_desc->type_idx = IR_TYPE_IDX(OPND_IDX((*opnd)));
06572             }
06573             else if (OPND_FLD((*opnd)) == AT_Tbl_Idx) {
06574                exp_desc->type_idx = ATD_TYPE_IDX(OPND_IDX((*opnd)));
06575             }
06576 
06577             exp_desc->type = TYP_TYPE(exp_desc->type_idx);
06578             exp_desc->linear_type = TYP_LINEAR(exp_desc->type_idx);
06579          }
06580          break;
06581    }
06582 
06583 EXIT:
06584 
06585    TRACE (Func_Exit, "fold_clen_opr", NULL);
06586 
06587    return;
06588 
06589 }  /* fold_clen_opr */
06590 
06591 /******************************************************************************\
06592 |*                                                                            *|
06593 |* Description:                                                               *|
06594 |*      <description>                                                         *|
06595 |*                                                                            *|
06596 |* Input parameters:                                                          *|
06597 |*      NONE                                                                  *|
06598 |*                                                                            *|
06599 |* Output parameters:                                                         *|
06600 |*      NONE                                                                  *|
06601 |*                                                                            *|
06602 |* Returns:                                                                   *|
06603 |*      NOTHING                                                               *|
06604 |*                                                                            *|
06605 \******************************************************************************/
06606 
06607 void set_shape_for_deferred_funcs(expr_arg_type         *exp_desc,
06608                                   int                    call_idx)
06609 
06610 {
06611    int            attr_idx;
06612    int            bd_idx;
06613    int      ch_idx = NULL_IDX;
06614    int      col;
06615    int      dummy_idx;
06616    boolean    has_sf = FALSE;
06617    int      i;
06618    int      ir_idx;
06619    int      line;
06620    int            list_idx;
06621    expr_arg_type  loc_exp_desc;
06622    int            minus_idx;
06623    opnd_type      opnd;
06624    int            plus_idx;
06625    int      pgm_idx;
06626    cif_usage_code_type  save_xref_state;
06627    int      sn_idx;
06628 
06629 
06630    TRACE (Func_Entry, "set_shape_for_deferred_funcs", NULL);
06631 
06632    pgm_idx = IR_IDX_L(call_idx);
06633    attr_idx = ATP_RSLT_IDX(IR_IDX_L(call_idx));
06634    bd_idx = ATD_ARRAY_IDX(attr_idx);
06635 
06636    if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {
06637       ch_idx = ATD_TYPE_IDX(attr_idx);
06638    }
06639 
06640    if ((bd_idx && BD_ARRAY_SIZE(bd_idx) == Var_Len_Array)  ||
06641        (ch_idx && TYP_FLD(ch_idx) == AT_Tbl_Idx)) {
06642 
06643       has_sf = TRUE;
06644 
06645       /* set up the dummy args as stmt func dargs */
06646 
06647       list_idx = IR_IDX_R(call_idx);
06648       sn_idx = ATP_FIRST_IDX(pgm_idx);
06649 
06650       if (ATP_EXTRA_DARG(pgm_idx)) {
06651          sn_idx++;
06652       }
06653 
06654       for (i = 0; i < IR_LIST_CNT_R(call_idx); i++) {
06655          dummy_idx = SN_ATTR_IDX(sn_idx);
06656 
06657          ATD_SF_DARG(dummy_idx) = TRUE;
06658 
06659          ATD_SF_LINK(dummy_idx) = IL_ARG_DESC_IDX(list_idx);
06660          COPY_OPND(opnd, IL_OPND(list_idx));
06661 
06662          if (arg_info_list[ATD_SF_LINK(dummy_idx)].ed.reference &&
06663              OPND_FLD(opnd) == IR_Tbl_Idx)                      {
06664 
06665             if (IR_OPR(OPND_IDX(opnd)) == Whole_Substring_Opr) {
06666                COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
06667             }
06668 
06669             if (OPND_FLD(opnd) == IR_Tbl_Idx &&
06670                 IR_OPR(OPND_IDX(opnd)) == Whole_Subscript_Opr) {
06671 
06672                COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
06673             }
06674 
06675            /* whole subscript and substring need to be removed       */
06676            /* since we don't know how these args will be referenced. */
06677            /* I don't think dv_deref_oprs need to be removed.        */
06678          }
06679 
06680          ATD_FLD(dummy_idx)        = OPND_FLD(opnd);
06681          ATD_SF_ARG_IDX(dummy_idx) = OPND_IDX(opnd);
06682 
06683          sn_idx++;
06684          list_idx = IL_NEXT_LIST_IDX(list_idx);
06685       }
06686    }
06687 
06688    line = IR_LINE_NUM(call_idx);
06689    col  = IR_COL_NUM(call_idx);
06690 
06691    if (ch_idx) {
06692       /* fill in exp_desc->char_len */
06693 
06694       if (TYP_CHAR_CLASS(ch_idx) == Const_Len_Char) {
06695          exp_desc->char_len.fld = TYP_FLD(ch_idx);
06696          exp_desc->char_len.idx = TYP_IDX(ch_idx);
06697       }
06698       else if (TYP_FLD(ch_idx) == AT_Tbl_Idx) {
06699 
06700          if (TYP_CHAR_CLASS(ch_idx) == Assumed_Size_Char) {
06701             /* TYP_ORIG_LEN_IDX not set for Assumed_Size_Char */
06702             COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(TYP_IDX(ch_idx))));
06703          }
06704          else {
06705             COPY_OPND(opnd, IR_OPND_R(ATD_TMP_IDX(TYP_ORIG_LEN_IDX(ch_idx))));
06706          }
06707 
06708          copy_subtree(&opnd, &opnd);
06709 
06710          loc_exp_desc.rank = 0;
06711          save_xref_state   = xref_state;
06712          xref_state        = CIF_No_Usage_Rec;
06713          expr_semantics(&opnd, &loc_exp_desc);
06714          xref_state        = save_xref_state;
06715 
06716          COPY_OPND((exp_desc->char_len), opnd);
06717       }
06718    }
06719 
06720    if (bd_idx) {
06721 
06722       switch (BD_ARRAY_CLASS(bd_idx)) {
06723 
06724          case Explicit_Shape :
06725 
06726             if (BD_ARRAY_SIZE(bd_idx) == Constant_Size)   {
06727                get_shape_from_attr(exp_desc, 
06728                                    attr_idx,
06729                                    exp_desc->rank,
06730                                    IR_LINE_NUM(call_idx),
06731                                    IR_COL_NUM(call_idx));
06732             }
06733             else if (BD_ARRAY_SIZE(bd_idx) == Var_Len_Array) {
06734 
06735                /* set up extent expression for each dim */
06736 
06737                for (i = 0; i < BD_RANK(bd_idx); i++) {
06738 
06739                   NTR_IR_TBL(plus_idx);
06740                   IR_OPR(plus_idx) = Plus_Opr;
06741                   IR_TYPE_IDX(plus_idx)   = CG_INTEGER_DEFAULT_TYPE;
06742                   IR_LINE_NUM(plus_idx) = line;
06743                   IR_COL_NUM(plus_idx) = col;
06744 
06745                   IR_FLD_R(plus_idx) = CN_Tbl_Idx;
06746                   IR_IDX_R(plus_idx) = CN_INTEGER_ONE_IDX;
06747                   IR_LINE_NUM_R(plus_idx) = line;
06748                   IR_COL_NUM_R(plus_idx) = col;
06749 
06750                   NTR_IR_TBL(minus_idx);
06751                   IR_OPR(minus_idx) = Minus_Opr;
06752                   IR_TYPE_IDX(minus_idx)   = CG_INTEGER_DEFAULT_TYPE;
06753                   IR_LINE_NUM(minus_idx) = line;
06754                   IR_COL_NUM(minus_idx) = col;
06755 
06756                   IR_FLD_L(plus_idx) = IR_Tbl_Idx;
06757                   IR_IDX_L(plus_idx) = minus_idx;
06758 
06759                   if (BD_LB_FLD(bd_idx,i+1) == AT_Tbl_Idx) {
06760                      COPY_OPND(IR_OPND_R(minus_idx), 
06761                                IR_OPND_R(ATD_TMP_IDX(BD_LB_IDX(bd_idx,i+1))));
06762                   }
06763                   else {
06764                      IR_FLD_R(minus_idx) = BD_LB_FLD(bd_idx, i+1);
06765                      IR_IDX_R(minus_idx) = BD_LB_IDX(bd_idx, i+1);
06766                      IR_LINE_NUM_R(minus_idx) = line;
06767                      IR_COL_NUM_R(minus_idx) = col;
06768                   }
06769 
06770                   COPY_OPND(opnd, IR_OPND_R(minus_idx));
06771                   copy_subtree(&opnd, &opnd);
06772                   COPY_OPND(IR_OPND_R(minus_idx), opnd);
06773 
06774                   if (BD_UB_FLD(bd_idx,i+1) == AT_Tbl_Idx) {
06775                      COPY_OPND(IR_OPND_L(minus_idx), 
06776                                IR_OPND_R(ATD_TMP_IDX(BD_UB_IDX(bd_idx,i+1))));
06777                   }
06778                   else {
06779                      IR_FLD_L(minus_idx) = BD_UB_FLD(bd_idx, i+1);
06780                      IR_IDX_L(minus_idx) = BD_UB_IDX(bd_idx, i+1);
06781                      IR_LINE_NUM_L(minus_idx) = line;
06782                      IR_COL_NUM_L(minus_idx) = col;
06783                   }
06784 
06785                   COPY_OPND(opnd, IR_OPND_L(minus_idx));
06786                   copy_subtree(&opnd, &opnd);
06787                   COPY_OPND(IR_OPND_L(minus_idx), opnd);
06788 
06789                   OPND_FLD(opnd) = IR_Tbl_Idx;
06790                   OPND_IDX(opnd) = plus_idx;
06791 
06792                   loc_exp_desc.rank = 0;
06793                   save_xref_state   = xref_state;
06794                   xref_state        = CIF_No_Usage_Rec;
06795                   expr_semantics(&opnd, &loc_exp_desc);
06796                   xref_state        = save_xref_state;
06797 
06798                   COPY_OPND((exp_desc->shape[i]), opnd);
06799                   SHAPE_FOLDABLE(exp_desc->shape[i]) = loc_exp_desc.foldable;
06800                   SHAPE_WILL_FOLD_LATER(exp_desc->shape[i]) = 
06801                                                loc_exp_desc.will_fold_later;
06802                }
06803             }
06804             break;
06805 
06806          case Assumed_Size   :
06807             /* don't know what to do here */
06808             /* probable shouldn't get here */
06809             PRINTMSG(IR_LINE_NUM(call_idx), 968, Internal,
06810                      IR_COL_NUM(call_idx));
06811 
06812             break;
06813 
06814          case Deferred_Shape :
06815          case Assumed_Shape  :
06816 
06817             /* these are dope vectors */
06818 
06819             for (i = 0; i < BD_RANK(bd_idx); i++) {
06820 
06821                NTR_IR_TBL(ir_idx);
06822                IR_OPR(ir_idx) = Dv_Access_Extent;
06823                IR_TYPE_IDX(ir_idx)   = SA_INTEGER_DEFAULT_TYPE;
06824                IR_DV_DIM(ir_idx) = i + 1;
06825 
06826                IR_FLD_L(ir_idx) = AT_Tbl_Idx;
06827                IR_IDX_L(ir_idx) = attr_idx;
06828 
06829                IR_LINE_NUM(ir_idx) = IR_LINE_NUM(call_idx);
06830                IR_COL_NUM(ir_idx) = IR_COL_NUM(call_idx);
06831                IR_LINE_NUM_L(ir_idx) = IR_LINE_NUM(call_idx);
06832                IR_COL_NUM_L(ir_idx) = IR_COL_NUM(call_idx);
06833 
06834                exp_desc->shape[i].fld = IR_Tbl_Idx;
06835                exp_desc->shape[i].idx = ir_idx;
06836                SHAPE_FOLDABLE(exp_desc->shape[i]) = FALSE;
06837                SHAPE_WILL_FOLD_LATER(exp_desc->shape[i]) = FALSE;
06838             }
06839             break;
06840 
06841    
06842       }
06843    }
06844 
06845    if (has_sf) {
06846       sn_idx = ATP_FIRST_IDX(pgm_idx);
06847 
06848       if (ATP_EXTRA_DARG(pgm_idx)) {
06849          sn_idx++;
06850       }
06851 
06852       for (i = 0; i < IR_LIST_CNT_R(call_idx); i++) {
06853          ATD_SF_DARG(SN_ATTR_IDX(sn_idx)) = FALSE;
06854          sn_idx++;
06855       }
06856    }
06857 
06858 
06859    TRACE (Func_Exit, "set_shape_for_deferred_funcs", NULL);
06860 
06861    return;
06862 
06863 }  /* set_shape_for_deferred_funcs */
06864 
06865 /******************************************************************************\
06866 |*                                                                            *|
06867 |* Description:                                                               *|
06868 |*      Create an internal dope vector for use in folding array intrinsics.   *|
06869 |*                                                                            *|
06870 |* Input parameters:                                                          *|
06871 |*      dope_vec - address of internal dope vector to fill in.                *|
06872 |*      r_opnd   - address of opnd pointing to "target".                      *|
06873 |*      just_init- TRUE => just initialize header.                            *|
06874 |*      exp_desc - address of the expression descriptor of target.            *|
06875 |*                                                                            *|
06876 |* Output parameters:                                                         *|
06877 |*      NONE                                                                  *|
06878 |*                                                                            *|
06879 |* Returns:                                                                   *|
06880 |*      NOTHING                                                               *|
06881 |*                                                                            *|
06882 \******************************************************************************/
06883 
06884 boolean gen_internal_dope_vector(int_dope_type    *dope_vec,
06885          opnd_type    *r_opnd,
06886          boolean     just_init,
06887          expr_arg_type    *exp_desc)
06888 
06889 {
06890 #ifdef KEY /* Bug 10177 */
06891    int      bd_idx = 0;
06892    int      cn_idx = 0;
06893 #else /* KEY Bug 10177 */
06894    int      bd_idx;
06895    int      cn_idx;
06896 #endif /* KEY Bug 10177 */
06897    int      column;
06898    long_type          constant[2];
06899    int            i;
06900 # if defined(_HOST_OS_UNICOS) && defined(_TARGET_OS_UNICOS)
06901    _fcd                 fcd_r;
06902 # endif
06903    int      line;
06904    boolean    ok    = TRUE;
06905    opnd_type    opnd;
06906    int            type_idx;
06907 
06908 
06909    TRACE (Func_Entry, "gen_internal_dope_vector", NULL);
06910 
06911    type_idx = exp_desc->type_idx;
06912 
06913    /*********************************************\
06914    |* see if we need to assign r_opnd to a tmp. *|
06915    \*********************************************/
06916 
06917    if (just_init) {
06918       /* intentionally blank */
06919    }
06920    else if (OPND_FLD((*r_opnd)) == CN_Tbl_Idx) {
06921       cn_idx = OPND_IDX((*r_opnd));
06922    }
06923    else if ((exp_desc->reference  ||
06924              exp_desc->tmp_reference) &&
06925             ! exp_desc->section)      {
06926 
06927       COPY_OPND(opnd, (*r_opnd));
06928 
06929       while (OPND_FLD(opnd) == IR_Tbl_Idx) {
06930          COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
06931       }
06932 
06933       if (ATD_FLD(OPND_IDX(opnd)) == IR_Tbl_Idx) {
06934          COPY_OPND(opnd, (*r_opnd));
06935 
06936          if (fold_aggragate_expression(&opnd, exp_desc, TRUE)) {
06937             cn_idx = OPND_IDX(opnd);
06938 
06939             if (exp_desc->rank) {
06940                bd_idx = create_bd_ntry_for_const(exp_desc,
06941                                                  stmt_start_line,
06942                                                  stmt_start_col);
06943             }
06944          }
06945          else {
06946             ok = FALSE;
06947             goto EXIT;
06948          }
06949       }
06950       else {
06951          if (ATD_CLASS(OPND_IDX(opnd)) == Constant) {
06952             cn_idx = ATD_CONST_IDX(OPND_IDX(opnd));
06953          }
06954          else {
06955             cn_idx = ATD_TMP_IDX(OPND_IDX(opnd));
06956          }
06957 
06958          bd_idx = ATD_ARRAY_IDX(OPND_IDX(opnd));
06959       }
06960    }
06961    else {
06962       COPY_OPND(opnd, (*r_opnd));
06963 
06964       if (fold_aggragate_expression(&opnd, exp_desc, TRUE)) {
06965          cn_idx = OPND_IDX(opnd);
06966 
06967          if (exp_desc->rank) {
06968             bd_idx = create_bd_ntry_for_const(exp_desc, 
06969                                               stmt_start_line,
06970                                               stmt_start_col);
06971          }
06972       }
06973       else {
06974          ok = FALSE;
06975          goto EXIT;
06976       }
06977    }
06978 
06979 # ifdef _TARGET_OS_MAX  /* BRIANJ */
06980    if (! just_init &&
06981        TYP_LINEAR(CN_TYPE_IDX(cn_idx)) == Complex_4) {
06982       /* must pack it into one word (an Integer_8 constant) */
06983 
06984       constant[0] = CN_CONST(cn_idx) << 32;
06985       constant[0] |= (CP_CONSTANT(CN_POOL_IDX(cn_idx) + 1) & 0xFFFFFFFF);
06986 
06987       cn_idx = ntr_const_tbl(Integer_8,
06988                              FALSE,
06989                              constant);
06990    }
06991    else 
06992 # endif
06993    if (! just_init &&
06994        exp_desc->rank == 0 &&
06995        exp_desc->type != Character &&
06996        exp_desc->type != Structure &&
06997        storage_bit_size_tbl[TYP_LINEAR(CN_TYPE_IDX(cn_idx))] <
06998                      TARGET_BITS_PER_WORD) {
06999 
07000       /* must shift the constant so that it is left justified */
07001       /* word size integer (CG_INTEGER_DEFAULT_TYPE)          */
07002 
07003       constant[0] = CN_CONST(cn_idx) << (TARGET_BITS_PER_WORD -
07004                        storage_bit_size_tbl[TYP_LINEAR(CN_TYPE_IDX(cn_idx))]);
07005 
07006       cn_idx = ntr_const_tbl(CG_INTEGER_DEFAULT_TYPE,
07007                              FALSE,
07008                             constant);
07009    }
07010 
07011    /*************\
07012    |* BASE ADDR *|
07013    \*************/
07014 
07015    if (just_init) {
07016       dope_vec->base_addr = 0;
07017    }
07018 # if defined(_HOST_OS_UNICOS) && defined(_TARGET_OS_UNICOS)
07019 
07020     /* BRIANJ */
07021 
07022    else if (exp_desc->type == Character) {
07023       fcd_r = _cptofcd((char *)&CN_CONST(cn_idx),
07024                        CN_INT_TO_C(TYP_IDX(exp_desc->type_idx)));
07025       dope_vec->base_addr = *(int *)&fcd_r;
07026    }
07027    else if (exp_desc->type == Structure &&
07028             ATT_CHAR_SEQ(TYP_IDX(exp_desc->type_idx))) {
07029       fcd_r = _cptofcd((char *)&CN_CONST(cn_idx),
07030      (CN_INT_TO_C(ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(exp_desc->type_idx)))) >> 3);
07031       dope_vec->base_addr = *(int *)&fcd_r;
07032    }
07033 # endif
07034    else {
07035       dope_vec->base_addr = (long)&CN_CONST(cn_idx);
07036    }
07037 
07038    /*************\
07039    |* EL_LEN    *|
07040    \*************/
07041 
07042    find_opnd_line_and_column(r_opnd, &line, &column);
07043 
07044    if (exp_desc->type == Structure) {
07045 
07046       cn_idx = ATT_STRUCT_BIT_LEN_IDX(TYP_IDX(type_idx));
07047       if (compare_cn_and_value(cn_idx,
07048                                MAX_DV_EL_LEN,
07049                                Ge_Opr)) {
07050          PRINTMSG(line, 1174, Error, column, CN_INT_TO_C(cn_idx),MAX_DV_EL_LEN);
07051          dope_vec->el_len = MAX_DV_EL_LEN;
07052       }
07053       else { /* BRIANJ */
07054          dope_vec->el_len = CN_INT_TO_C(cn_idx);
07055       }
07056    }
07057    else if (exp_desc->type == Character) {
07058 
07059       if (exp_desc->char_len.fld == CN_Tbl_Idx) {
07060 
07061          if (char_len_in_bytes) {
07062 
07063             if (compare_cn_and_value(exp_desc->char_len.idx,
07064                                      MAX_DV_EL_LEN,
07065                                      Ge_Opr)) {
07066                PRINTMSG(line, 1174, Error, column,
07067                         CN_INT_TO_C(exp_desc->char_len.idx),
07068                         MAX_DV_EL_LEN);
07069                dope_vec->el_len = MAX_DV_EL_LEN;
07070             }
07071             else {
07072                dope_vec->el_len = CN_INT_TO_C(exp_desc->char_len.idx);
07073             }
07074          }
07075          else {
07076 
07077             if (compare_cn_and_value(exp_desc->char_len.idx,
07078                                      MAX_DV_EL_LEN/8,
07079                                      Ge_Opr)) {
07080                PRINTMSG(line, 1174, Error, column,
07081                         CN_INT_TO_C(exp_desc->char_len.idx),
07082                         MAX_DV_EL_LEN/8);
07083                dope_vec->el_len = MAX_DV_EL_LEN;
07084             }
07085             else {
07086                dope_vec->el_len = CN_INT_TO_C(exp_desc->char_len.idx)*8;
07087             }
07088          }
07089       }
07090       else {
07091          PRINTMSG(line, 969, Internal, column);
07092       }
07093    }
07094    else {
07095       dope_vec->el_len = storage_bit_size_tbl[exp_desc->linear_type];
07096    }
07097 
07098    /*************\
07099    |* ASSOC     *|
07100    \*************/
07101 
07102    if (just_init) {
07103       dope_vec->assoc = 0;
07104    }
07105    else {
07106       dope_vec->assoc = 1;
07107    }
07108 
07109    /*************\
07110    |* PTR_ALLOC *|
07111    \*************/
07112 
07113    dope_vec->ptr_alloc = 0;
07114 
07115    /*************\
07116    |* P_OR_A    *|
07117    \*************/
07118 
07119    dope_vec->p_or_a = 1;    /* pointer */
07120 
07121    /*************\
07122    |* A_CONTIG  *|
07123    \*************/
07124 
07125    dope_vec->a_contig = 0;
07126 
07127    /*************\
07128    |* UNUSED 1  *|
07129    \*************/
07130 
07131    dope_vec->unused_1 = 0;
07132 
07133 # if defined(_TARGET64) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
07134    /*************\
07135    |* UNUSED 2  *|
07136    \*************/
07137 
07138    dope_vec->unused_2 = 0;
07139 # endif
07140 
07141 
07142    /*************\
07143    |* N_DIM     *|
07144    \*************/
07145 
07146    dope_vec->num_dims = exp_desc->rank;
07147 
07148 # if defined(_TARGET64) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
07149 # ifndef _TYPE_CODE_64_BIT
07150    /*************\
07151    |* UNUSED 3  *|
07152    \*************/
07153 
07154    dope_vec->unused_3 = 0;
07155 # endif
07156 # endif
07157 
07158    /*************\
07159    |* TYPE_CODE *|
07160    \*************/
07161 
07162    make_io_type_code(type_idx, constant);
07163 # ifdef _TYPE_CODE_64_BIT
07164    dope_vec->type_code = *(f90_type_t *)constant;
07165 # else
07166    dope_vec->type_code = *constant;
07167 # endif
07168 
07169    /*************\
07170    |* ORIG_BASE *|
07171    \*************/
07172 
07173    dope_vec->orig_base = 0;
07174 
07175    /*************\
07176    |* ORIG_SIZE *|
07177    \*************/
07178 
07179 #ifdef KEY /* Bug 6845 */
07180    /* If this dope vector could have allocatable components, we need to do
07181     * something here */
07182 #endif /* KEY Bug 6845 */
07183 
07184    dope_vec->orig_size = 0;
07185 
07186    for (i = 0; i < exp_desc->rank; i++) {
07187 
07188       /*************\
07189       |* DIM i LB  *|
07190       \*************/
07191 
07192       if (just_init) {
07193          dope_vec->dim[i].low_bound = 0;
07194       }
07195       else {
07196          /* set to one */
07197          dope_vec->dim[i].