Open64: osprey/crayf90/fe90/s_typ

00001 /*
00002  *  Copyright (C) 2006. QLogic Corporation. All Rights Reserved.
00003  */
00004 
00005 /*
00006 
00007   Copyright (C) 2000, 2001 Silicon Graphics, Inc.  All Rights Reserved.
00008 
00009   This program is free software; you can redistribute it and/or modify it
00010   under the terms of version 2 of the GNU General Public License as
00011   published by the Free Software Foundation.
00012 
00013   This program is distributed in the hope that it would be useful, but
00014   WITHOUT ANY WARRANTY; without even the implied warranty of
00015   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  
00016 
00017   Further, this software is distributed without any warranty that it is
00018   free of the rightful claim of any third person regarding infringement 
00019   or the like.  Any license provided herein, whether implied or 
00020   otherwise, applies only to this software file.  Patent licenses, if 
00021   any, provided herein do not apply to combinations of this program with 
00022   other software, or any other product whatsoever.  
00023 
00024   You should have received a copy of the GNU General Public License along
00025   with this program; if not, write the Free Software Foundation, Inc., 59
00026   Temple Place - Suite 330, Boston MA 02111-1307, USA.
00027 
00028   Contact information:  Silicon Graphics, Inc., 1600 Amphitheatre Pky,
00029   Mountain View, CA 94043, or:
00030 
00031   http://www.sgi.com
00032 
00033   For further information regarding this notice, see:
00034 
00035   http://oss.sgi.com/projects/GenInfo/NoticeExplan
00036 
00037 */
00038 
00039 
00040 
00041 static char USMID[] = "\n@(#)5.0_pl/sources/s_typ_init.c  5.3 06/16/99 10:02:23\n";
00042 
00043 # include "defines.h"   /* Machine dependent ifdefs */
00044 
00045 # include "host.m"    /* Host machine dependent macros.*/
00046 # include "host.h"    /* Host machine dependent header.*/
00047 # include "target.m"    /* Target machine dependent macros.*/
00048 # include "target.h"    /* Target machine dependent header.*/
00049 
00050 # include "globals.m"
00051 # include "tokens.m"
00052 # include "sytb.m"
00053 # include "s_globals.m"
00054 # include "debug.m"
00055 # include "s_asg_expr.m"
00056 
00057 # include "globals.h"
00058 # include "tokens.h"
00059 # include "sytb.h"
00060 # include "s_globals.h"
00061 
00062 
00063 /*****************************************************************\
00064 |* function prototypes of static functions declared in this file *|
00065 \*****************************************************************/
00066 
00067 static  boolean attr_init_semantics(opnd_type *, int, int, expr_arg_type *);
00068 static  boolean const_init_semantics(opnd_type *, int, int);
00069 static  void  process_all_initialized_cpnts(opnd_type *, int, operator_type);
00070 
00071 
00072 /******************************************************************************\
00073 |*                        *|
00074 |* Description:                     *|
00075 |*  Do semantics for type declaration initializations.                    *|
00076 |*                        *|
00077 |* Input parameters:                    *|
00078 |*  NONE                      *|
00079 |*                        *|
00080 |* Output parameters:                   *|
00081 |*  NONE                      *|
00082 |*                        *|
00083 |* Returns:                     *|
00084 |*  NOTHING                     *|
00085 |*                        *|
00086 \******************************************************************************/
00087 
00088 void type_init_semantics (void)
00089 
00090 {
00091    int      attr_idx;
00092    int      col;
00093    expr_arg_type  expr_desc;
00094    opnd_type    init_opnd;
00095    int      ir_idx;
00096    int      line;
00097    int      list_idx;
00098    int      opnd_column;
00099    int      opnd_line;
00100    int      sh_idx;
00101    int      type_idx;
00102 
00103 
00104    TRACE (Func_Entry, "type_init_semantics", NULL);
00105 
00106    /* set comp_gen_expr to TRUE. This forces the fold of REAL   */
00107    /* constant expressions. When -Oieeeconform is specified,    */
00108    /* the folding of Real and Complex expressions is prevented. */
00109 
00110    comp_gen_expr = TRUE;
00111 
00112    ir_idx = SH_IR_IDX(curr_stmt_sh_idx);
00113    attr_idx = IR_IDX_L(ir_idx);
00114 
00115    COPY_OPND(init_opnd, IR_OPND_R(ir_idx));
00116 
00117    line = IR_LINE_NUM_L(ir_idx);
00118    col  = IR_COL_NUM_L(ir_idx);
00119 
00120    /* Constraint checks:                                                   */
00121    /* * A variable that is a member of blank common should not be          */
00122    /*   initialized.                                                       */
00123    /* * A variable that is a member of a named common block should only be */
00124    /*   initialized in a block data program unit.                          */
00125    /* * A variable that is a member of a task common block must not be     */
00126    /*   initialized.                                                       */
00127    /* * From a CF77 SPR:  If an object in a Block Data program unit is NOT */
00128    /*   in a common block (and is not equivalenced to an object in common) */
00129    /*   but IS initialized, issue a warning.                               */
00130 
00131    if (ATD_IN_COMMON(attr_idx)) {
00132 
00133       if (SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx)) == Common) {
00134 
00135          if (SB_BLANK_COMMON(ATD_STOR_BLK_IDX(attr_idx))) {
00136             PRINTMSG(line, 1109, Ansi, col);
00137          }
00138 
00139          else if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Blockdata) {
00140 
00141 # if defined(_ALLOW_DATA_INIT_OF_COMMON)
00142             PRINTMSG(line, 692, Ansi, col);
00143 # else
00144             PRINTMSG(line, 1542, Warning, col);
00145 # endif
00146          }
00147       }
00148       else if (SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx)) == Task_Common) {
00149          PRINTMSG(line, 851, Error, col);
00150          goto EXIT;
00151       }
00152    }
00153    else if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Blockdata  &&
00154             ! (ATD_EQUIV(attr_idx)  &&
00155                SB_IS_COMMON(ATD_STOR_BLK_IDX(attr_idx)))) {
00156       PRINTMSG(line, 825, Warning, col);
00157    }
00158 
00159    /* There is no way to initialize a CRI character pointer.               */
00160 
00161    type_idx = ATD_TYPE_IDX(attr_idx);
00162 
00163    if (TYP_TYPE(type_idx) == CRI_Ch_Ptr) {
00164       PRINTMSG(line, 695, Error, col);
00165       goto EXIT;
00166    }
00167 
00168    if (AT_DCL_ERR(attr_idx)) {
00169       /* don't do anything else */
00170       goto EXIT;
00171    }
00172 
00173 
00174    OPND_FLD(init_target_opnd) = AT_Tbl_Idx;
00175    OPND_IDX(init_target_opnd) = attr_idx;
00176    OPND_LINE_NUM(init_target_opnd) = line;
00177    OPND_COL_NUM(init_target_opnd) = col;
00178 
00179    target_array_idx   = ATD_ARRAY_IDX(attr_idx);
00180 
00181    if (TYP_TYPE(type_idx) == Integer ||
00182        TYP_TYPE(type_idx) == Real    ||
00183        TYP_TYPE(type_idx) == Complex) {
00184 
00185       check_type_conversion = TRUE;
00186       target_type_idx       = type_idx;
00187    }
00188    else if (TYP_TYPE(type_idx) == Character) {
00189 
00190       if (TYP_CHAR_CLASS(type_idx) == Const_Len_Char) {
00191 
00192          check_type_conversion = TRUE;
00193          target_type_idx       = Character_1;
00194          target_char_len_idx   = TYP_IDX(type_idx);
00195       }
00196    }
00197 
00198    expr_mode  = Initialization_Expr;
00199    xref_state = CIF_Symbol_Reference;
00200 
00201    if (expr_semantics(&init_opnd, &expr_desc)) {
00202 
00203       if (ATD_POINTER(attr_idx) &&
00204           (OPND_FLD(init_opnd) == AT_Tbl_Idx || 
00205            OPND_FLD(init_opnd) == CN_Tbl_Idx ||
00206            (OPND_FLD(init_opnd) == IR_Tbl_Idx &&
00207             IR_OPR(OPND_IDX(init_opnd)) != Null_Intrinsic_Opr))) {
00208          PRINTMSG(line, 1559, Error, col,
00209                   AT_OBJ_NAME_PTR(attr_idx));
00210          goto EXIT;
00211       }
00212 
00213       if (! expr_desc.foldable) {
00214 
00215          /* The initialization expression must be a constant. */
00216 
00217          if (ATD_POINTER(attr_idx) &&
00218              OPND_FLD(init_opnd) == IR_Tbl_Idx &&
00219              IR_OPR(OPND_IDX(init_opnd)) == Null_Intrinsic_Opr) {
00220              goto EXIT;
00221          }
00222 #ifdef KEY /* Bug 6845 */
00223   else if ((AT_OBJ_CLASS(TYP_IDX(ATD_TYPE_IDX(attr_idx)))
00224        == Derived_Type) &&
00225        ATT_ALLOCATABLE_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) {
00226        find_opnd_line_and_column(&init_opnd, &opnd_line, &opnd_column);
00227        PRINTMSG(opnd_line, 1680, Error, opnd_column,
00228          AT_OBJ_NAME_PTR(attr_idx));
00229        goto EXIT;
00230   }
00231 #endif /* KEY Bug 6845 */
00232          else {
00233             find_opnd_line_and_column(&init_opnd, &opnd_line, &opnd_column);
00234             PRINTMSG(opnd_line, 842, Error, opnd_column);
00235             goto EXIT;
00236          }
00237       }
00238 
00239       while (OPND_FLD(init_opnd) == IR_Tbl_Idx) {
00240         COPY_OPND(init_opnd, IR_OPND_L(OPND_IDX(init_opnd)));
00241       }
00242    }
00243    else {
00244       goto EXIT;
00245    }
00246 
00247    if (OPND_FLD(init_opnd) == AT_Tbl_Idx) {
00248 
00249       if (attr_init_semantics(&init_opnd, attr_idx, ir_idx, &expr_desc)) {
00250 
00251          /* pull this init out of stmts. don't need it any more */
00252 
00253          sh_idx         = curr_stmt_sh_idx;
00254          SH_NEXT_IDX(SH_PREV_IDX(sh_idx)) = SH_NEXT_IDX(sh_idx);
00255          SH_PREV_IDX(SH_NEXT_IDX(sh_idx)) = SH_PREV_IDX(sh_idx);
00256          curr_stmt_sh_idx     = SH_PREV_IDX(sh_idx);
00257          FREE_IR_NODE(ir_idx);
00258          FREE_SH_NODE(sh_idx);
00259       }
00260    }
00261    else {
00262 
00263       if (const_init_semantics(&init_opnd, attr_idx, ir_idx)) {
00264          find_opnd_line_and_column(&init_opnd, &opnd_line, &opnd_column);
00265          NTR_IR_LIST_TBL(list_idx);
00266          IR_FLD_R(ir_idx) = IL_Tbl_Idx;
00267          IR_IDX_R(ir_idx) = list_idx;
00268          IR_LIST_CNT_R(ir_idx)  = 3;
00269  
00270          COPY_OPND(IL_OPND(list_idx), init_opnd);
00271        
00272          NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
00273          IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
00274          list_idx   = IL_NEXT_LIST_IDX(list_idx);
00275 
00276          IL_FLD(list_idx) = CN_Tbl_Idx;
00277          IL_IDX(list_idx) = CN_INTEGER_ONE_IDX;
00278          IL_LINE_NUM(list_idx)  = opnd_line;
00279          IL_COL_NUM(list_idx) = opnd_column;
00280 
00281          NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
00282          IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
00283          list_idx   = IL_NEXT_LIST_IDX(list_idx);
00284 
00285          IL_FLD(list_idx) = CN_Tbl_Idx;
00286          IL_IDX(list_idx) = CN_INTEGER_ZERO_IDX;
00287          IL_LINE_NUM(list_idx)  = opnd_line;
00288          IL_COL_NUM(list_idx) = opnd_column;
00289       }
00290    }
00291 
00292 EXIT:
00293 
00294    expr_mode      = Regular_Expr;
00295    check_type_conversion  = FALSE;
00296    target_array_idx   = NULL_IDX;
00297    init_target_opnd   = null_opnd;
00298 
00299    /* reset comp_gen_expr to FALSE. end of compiler generated expression */
00300 
00301    comp_gen_expr = FALSE;
00302 
00303    TRACE (Func_Exit, "type_init_semantics", NULL);
00304 
00305    return;
00306 
00307 }  /* type_init_semantics */
00308 
00309 /******************************************************************************\
00310 |*                        *|
00311 |* Description:                     *|
00312 |*  Do semantics for type declaration initializations.                    *|
00313 |*                        *|
00314 |* Input parameters:                    *|
00315 |*  NONE                      *|
00316 |*                        *|
00317 |* Output parameters:                   *|
00318 |*  NONE                      *|
00319 |*                        *|
00320 |* Returns:                     *|
00321 |*  NOTHING                     *|
00322 |*                        *|
00323 \******************************************************************************/
00324 void default_init_semantics(int attr_idx)
00325 {
00326 
00327    int      column;
00328    expr_arg_type  expr_desc;
00329    opnd_type    init_opnd;
00330    int      line;
00331    int      next_sh_idx;
00332    boolean    null_init;
00333    int      old_curr_stmt_sh_idx;
00334    opnd_type    opnd;
00335    int      sh_idx;
00336    int      type_idx;
00337    int      type_init_sh_idx;
00338 
00339 
00340    TRACE (Func_Entry, "default_init_semantics", NULL);
00341 
00342 # ifdef _DEBUG
00343    if (ATD_CPNT_INIT_IDX(attr_idx) == NULL_IDX ||
00344        ATD_FLD(attr_idx) != IR_Tbl_Idx ||
00345        (IR_OPR(ATD_CPNT_INIT_IDX(attr_idx)) != Init_Opr &&
00346         IR_OPR(ATD_CPNT_INIT_IDX(attr_idx)) != Null_Opr)) {
00347 
00348       PRINTMSG(AT_DEF_LINE(attr_idx), 626, Internal,
00349                AT_DEF_COLUMN(attr_idx),
00350                "Init_Opr or Null_Opr", "default_init_semantics");
00351    }
00352 # endif
00353 
00354    /* Generate a type init statement so that expression semantics gets */
00355    /* anything it generates in the correct order.  This statement will */
00356    /* be removed.                                                      */
00357 
00358    old_curr_stmt_sh_idx = curr_stmt_sh_idx;
00359 
00360    gen_sh(After,
00361           Type_Init_Stmt,
00362           AT_DEF_LINE(attr_idx),
00363           AT_DEF_COLUMN(attr_idx),
00364           FALSE,
00365           FALSE,
00366           TRUE);
00367 
00368    type_init_sh_idx = curr_stmt_sh_idx;
00369    target_array_idx = ATD_ARRAY_IDX(attr_idx);
00370    type_idx   = ATD_TYPE_IDX(attr_idx);
00371    null_init    = FALSE;
00372 
00373    if (TYP_TYPE(type_idx) == Integer ||
00374        TYP_TYPE(type_idx) == Real    ||
00375        TYP_TYPE(type_idx) == Complex) {
00376       check_type_conversion = TRUE;
00377       target_type_idx       = type_idx;
00378    }
00379    else if (TYP_TYPE(type_idx) == Character) {
00380 
00381       if (TYP_CHAR_CLASS(type_idx) == Const_Len_Char) {
00382          check_type_conversion = TRUE;
00383          target_type_idx       = Character_1;
00384          target_char_len_idx   = TYP_IDX(type_idx);
00385       }
00386    }
00387 
00388    expr_mode    = Initialization_Expr;
00389    xref_state   = CIF_Symbol_Reference;
00390    expr_desc.rank = 0;
00391 
00392    COPY_OPND(init_opnd, IR_OPND_R(ATD_CPNT_INIT_IDX(attr_idx)));
00393 
00394    if (expr_semantics(&init_opnd, &expr_desc)) {
00395 
00396       if (ATD_POINTER(attr_idx) &&
00397           (OPND_FLD(init_opnd) == AT_Tbl_Idx || 
00398            OPND_FLD(init_opnd) == CN_Tbl_Idx ||
00399            (OPND_FLD(init_opnd) == IR_Tbl_Idx &&
00400             IR_OPR(OPND_IDX(init_opnd)) != Null_Intrinsic_Opr))) {
00401          find_opnd_line_and_column(&init_opnd, &line, &column);
00402          PRINTMSG(line, 1559, Error, column, AT_OBJ_NAME_PTR(attr_idx));
00403          AT_DCL_ERR(attr_idx)   = TRUE;
00404          goto EXIT;
00405       }
00406 
00407       if (!expr_desc.foldable) {
00408 
00409          /* The initialization expression must be a constant. */
00410 
00411          if (ATD_POINTER(attr_idx) &&
00412              OPND_FLD(init_opnd) == IR_Tbl_Idx &&
00413              IR_OPR(OPND_IDX(init_opnd)) == Null_Intrinsic_Opr) {
00414 
00415             /* Pointer components are null'd by default, so we  */
00416             /* do not need to keep the null information around. */
00417 
00418             null_init = TRUE;
00419             goto EXIT;
00420          }
00421 #ifdef KEY /* Bug 6845 */
00422    else if (AT_OBJ_CLASS(TYP_IDX(ATD_TYPE_IDX(attr_idx))) ==
00423       Derived_Type &&
00424       ATT_ALLOCATABLE_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) {
00425       find_opnd_line_and_column(&init_opnd, &line, &column);
00426       PRINTMSG(line, 1680, Error, column, AT_OBJ_NAME_PTR(attr_idx));
00427       AT_DCL_ERR(attr_idx)  = TRUE;
00428       goto EXIT;
00429    }
00430 #endif /* KEY Bug 6845 */
00431 
00432          find_opnd_line_and_column(&init_opnd, &line, &column);
00433          PRINTMSG(line, 842, Error, column);
00434          AT_DCL_ERR(attr_idx) = TRUE;
00435       }
00436 
00437       /* The assumption is that if this is IR, we will    */
00438       /* never end up with a CN_Tbl_Idx on the left side. */
00439 
00440       if (OPND_FLD(init_opnd) == CN_Tbl_Idx) {
00441 
00442          if (!const_init_semantics(&init_opnd,
00443                                     attr_idx,
00444                                     ATD_CPNT_INIT_IDX(attr_idx))) {
00445             AT_DCL_ERR(attr_idx) = TRUE;
00446          }
00447       }
00448       else {
00449          COPY_OPND(opnd, init_opnd);
00450 
00451          while (OPND_FLD(opnd) == IR_Tbl_Idx && OPND_IDX(opnd) != NULL_IDX) {
00452            COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
00453          }
00454 
00455          if (OPND_FLD(opnd) == AT_Tbl_Idx) {
00456 
00457             if (!attr_init_semantics(&opnd,
00458                                      attr_idx, 
00459                                      ATD_CPNT_INIT_IDX(attr_idx),
00460                                     &expr_desc)) {
00461                AT_DCL_ERR(attr_idx) = TRUE;
00462             }
00463          }
00464          else {
00465             PRINTMSG(AT_DEF_LINE(attr_idx), 626, Internal,
00466                      AT_DEF_COLUMN(attr_idx), 
00467                      "AT_Tbl_Idx",
00468                      "default_init_semantics");
00469          }
00470       }
00471    }
00472    else {  /* The initialization expression has an error */
00473       AT_DCL_ERR(attr_idx) = TRUE;
00474    }
00475 
00476 EXIT:
00477 
00478    expr_mode      = Regular_Expr;
00479    check_type_conversion  = FALSE;
00480    target_array_idx   = NULL_IDX;
00481    sh_idx     = SH_NEXT_IDX(old_curr_stmt_sh_idx);
00482 
00483    if (old_curr_stmt_sh_idx != NULL_IDX) {
00484       SH_NEXT_IDX(old_curr_stmt_sh_idx) = SH_NEXT_IDX(type_init_sh_idx);
00485    }
00486 
00487    if (SH_NEXT_IDX(type_init_sh_idx) != NULL_IDX) {
00488       SH_PREV_IDX(SH_NEXT_IDX(type_init_sh_idx)) = old_curr_stmt_sh_idx;
00489    }
00490 
00491    curr_stmt_sh_idx = old_curr_stmt_sh_idx;
00492 
00493    while (sh_idx != type_init_sh_idx) {
00494       next_sh_idx = SH_NEXT_IDX(sh_idx);
00495       FREE_SH_NODE(sh_idx);
00496       sh_idx    = next_sh_idx;
00497       
00498    }
00499 
00500    FREE_SH_NODE(type_init_sh_idx);
00501 
00502    if (AT_DCL_ERR(attr_idx) || null_init) {
00503       ATD_CPNT_INIT_IDX(attr_idx) = NULL_IDX;
00504       ATD_FLD(attr_idx)     = NO_Tbl_Idx;
00505    }
00506    else {
00507       ATD_CPNT_INIT_IDX(attr_idx) = OPND_IDX(init_opnd);
00508       ATD_FLD(attr_idx)     = OPND_FLD(init_opnd);
00509    }
00510 
00511    TRACE (Func_Exit, "default_init_semantics", NULL);
00512 
00513    return;
00514 
00515 }  /* default_init_semantics */
00516 
00517 
00518 /******************************************************************************\
00519 |*                        *|
00520 |* Description:                     *|
00521 |*  Do semantics for type declaration initializations.                    *|
00522 |*                        *|
00523 |* Input parameters:                    *|
00524 |*  NONE                      *|
00525 |*                        *|
00526 |* Output parameters:                   *|
00527 |*  NONE                      *|
00528 |*                        *|
00529 |* Returns:                     *|
00530 |*  NOTHING                     *|
00531 |*                        *|
00532 \******************************************************************************/
00533 
00534 static  boolean attr_init_semantics(opnd_type   *init_opnd,
00535             int      attr_idx,
00536             int      ir_idx,
00537             expr_arg_type *expr_desc)
00538 
00539 {
00540    int      c_type_idx;
00541    int      column;
00542    int      i;
00543    int      line;
00544    boolean    ok    = TRUE;
00545    int      opnd_column;
00546    int      opnd_line;
00547    char     type_str[40];
00548 
00549 
00550    TRACE (Func_Entry, "attr_init_semantics", NULL);
00551 
00552    line   = IR_LINE_NUM_L(ir_idx);
00553    column = IR_COL_NUM_L(ir_idx);
00554    c_type_idx = expr_desc->type_idx;
00555 
00556    find_opnd_line_and_column(init_opnd, &opnd_line, &opnd_column);
00557 
00558    if (TYP_LINEAR(c_type_idx) == Long_Typeless) {
00559       PRINTMSG(opnd_line, 1133, Error, opnd_column);
00560       ok = FALSE;
00561    }
00562    else if (!check_asg_semantics(ATD_TYPE_IDX(attr_idx),
00563                                  c_type_idx,
00564                                  opnd_line,
00565                                  opnd_column)) {
00566       type_str[0] = '\0';
00567       strcat(type_str, get_basic_type_str(ATD_TYPE_IDX(attr_idx)));
00568 
00569       PRINTMSG(line, 843, Error, column, AT_OBJ_NAME_PTR(attr_idx),
00570                type_str,
00571                get_basic_type_str(c_type_idx));
00572       ok = FALSE;
00573    }
00574    else if (expr_desc->rank > 0) {         /* check array conformance */
00575 
00576       if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) {
00577          PRINTMSG(line, 844, Error, column, AT_OBJ_NAME_PTR(attr_idx));
00578          ok = FALSE;
00579       }
00580       else if (expr_desc->rank == BD_RANK(ATD_ARRAY_IDX(attr_idx))) {
00581 
00582          for (i = 1; i <= expr_desc->rank; i++) {
00583 
00584             if (fold_relationals(expr_desc->shape[i-1].idx,
00585                                  BD_XT_IDX(ATD_ARRAY_IDX(attr_idx),i),
00586                                  Ne_Opr)) {
00587 
00588                PRINTMSG(line, 845, Error, column, AT_OBJ_NAME_PTR(attr_idx));
00589                ok = FALSE;
00590                break;
00591             }
00592          }
00593       }
00594       else {
00595          PRINTMSG(line, 845, Error, column, AT_OBJ_NAME_PTR(attr_idx));
00596          ok = FALSE;
00597       }
00598    }
00599 
00600    TRACE (Func_Exit, "attr_init_semantics", NULL);
00601 
00602    return(ok);
00603 
00604 }  /* attr_init_semantics */
00605 
00606 /******************************************************************************\
00607 |*                        *|
00608 |* Description:                     *|
00609 |*  Do semantics for type declaration initializations.                    *|
00610 |*                        *|
00611 |* Input parameters:                    *|
00612 |*  NONE                      *|
00613 |*                        *|
00614 |* Output parameters:                   *|
00615 |*  NONE                      *|
00616 |*                        *|
00617 |* Returns:                     *|
00618 |*  NOTHING                     *|
00619 |*                        *|
00620 \******************************************************************************/
00621 
00622 static boolean const_init_semantics(opnd_type   *init_opnd,
00623             int      attr_idx,
00624             int      ir_idx)
00625 
00626 {
00627    int      a_type_idx;
00628    long_type          another_constant[MAX_WORDS_FOR_NUMERIC];
00629    int      c_type_idx;
00630    char     *char_ptr;
00631    char     *c_char_ptr;
00632    int      column;
00633    int      const_idx;
00634    long64   i;
00635    int      line;
00636    boolean    ok    = TRUE;
00637    int      opnd_column;
00638    int      opnd_line;
00639    opnd_type    tar_opnd;
00640    char     type_str[40];
00641 
00642 
00643    TRACE (Func_Entry, "const_init_semantics", NULL);
00644 
00645    line   = IR_LINE_NUM_L(ir_idx);
00646    column = IR_COL_NUM_L(ir_idx);
00647    a_type_idx = ATD_TYPE_IDX(attr_idx);
00648    c_type_idx = CN_TYPE_IDX(OPND_IDX((*init_opnd)));
00649 
00650    find_opnd_line_and_column(init_opnd, &opnd_line, &opnd_column);
00651 
00652    if (TYP_LINEAR(c_type_idx) == Long_Typeless) {
00653       PRINTMSG(opnd_line, 1133, Error, opnd_column);
00654       ok = FALSE;
00655       goto EXIT;
00656    }
00657    else if (!check_asg_semantics(a_type_idx,
00658                                  c_type_idx,
00659                                  opnd_line,
00660                                  opnd_column)) {
00661       type_str[0] = '\0';
00662       strcat(type_str, get_basic_type_str(a_type_idx));
00663 
00664       PRINTMSG(line, 843, Error, column, AT_OBJ_NAME_PTR(attr_idx),
00665                type_str,
00666                get_basic_type_str(c_type_idx));
00667       ok = FALSE;
00668       goto EXIT;
00669    }
00670 
00671    if (TYP_TYPE(a_type_idx) == Character) {
00672 
00673       if (fold_relationals(TYP_IDX(a_type_idx),
00674                            TYP_IDX(c_type_idx),
00675                            Ne_Opr)) {
00676 
00677          /* assumes that these are both CN_Tbl_Idx */
00678 
00679          /* create new constant for the right length and put the */
00680          /* original string in it. Truncate or blank pad to fit. */
00681 
00682          const_idx  = ntr_const_tbl(a_type_idx, TRUE, NULL);
00683          char_ptr = (char *)&CN_CONST(const_idx);
00684          c_char_ptr = (char *)&CN_CONST(OPND_IDX((*init_opnd)));
00685 
00686          for (i = 0; i < CN_INT_TO_C(TYP_IDX(a_type_idx)); i++) {
00687             char_ptr[i] = (i >= CN_INT_TO_C(TYP_IDX(c_type_idx))) ?
00688                           ' ' : c_char_ptr[i];
00689          }
00690 
00691          while (i % TARGET_CHARS_PER_WORD != 0) {
00692             char_ptr[i] = ' ';
00693             i++;
00694          }
00695 
00696          OPND_IDX((*init_opnd)) = const_idx;
00697       }
00698 
00699       /* If this is default initialization, the substring reference will */
00700       /* need to be generated when something is actually initialized.    */
00701 
00702       if (ATD_CLASS(attr_idx) != Struct_Component) {
00703          COPY_OPND(tar_opnd, IR_OPND_L(ir_idx));
00704 
00705          if (gen_whole_substring(&tar_opnd, 0)) {
00706             COPY_OPND(IR_OPND_L(ir_idx), tar_opnd);
00707          }
00708       }
00709    }
00710    else if (TYP_TYPE(c_type_idx) == Character ||
00711             TYP_TYPE(c_type_idx) == Typeless) {
00712 
00713       /* cast the character or typeless constant to the target type */
00714 
00715       OPND_IDX((*init_opnd)) = cast_typeless_constant(OPND_IDX((*init_opnd)),
00716                                                       a_type_idx,
00717                                                       opnd_line,
00718                                                       opnd_column);
00719    }
00720    else if (TYP_TYPE(c_type_idx) != Character  &&
00721             TYP_TYPE(c_type_idx) != Typeless   &&
00722             TYP_LINEAR(c_type_idx) != TYP_LINEAR(a_type_idx)) {
00723 
00724       /* PDGCS does not like it if the value is not the same size as the   */
00725       /* target; for example, the value is a double precision constant and */
00726       /* the target is a single precision variable.  So explicitly convert */
00727       /* the value to the type and kind type parameter of the target for   */
00728       /* all combinations to be consistent.                                */
00729 
00730       if (folder_driver( (char *) &CN_CONST(OPND_IDX((*init_opnd))),
00731                          c_type_idx,
00732                          NULL,
00733                          NULL_IDX,
00734                          another_constant,
00735                         &a_type_idx,
00736                          opnd_line,
00737                          opnd_column,
00738                          1,
00739                          Cvrt_Opr)) {
00740 
00741          OPND_IDX((*init_opnd)) = ntr_const_tbl(ATD_TYPE_IDX(attr_idx),
00742                                                 FALSE,
00743                                                 another_constant);
00744       }
00745    }
00746 
00747 EXIT:
00748 
00749    TRACE (Func_Exit, "const_init_semantics", NULL);
00750 
00751    return(ok);
00752 
00753 }  /* const_init_semantics */
00754 
00755 /******************************************************************************\
00756 |*                        *|
00757 |* Description:                     *|
00758 |*  This routine creates a chain of stmts to handle default initialization*|
00759 |*      of a component or components.                                         *|
00760 |*                        *|
00761 |* Input parameters:                    *|
00762 |*  attr_idx - idx of variable to process.                                *|
00763 |*                        *|
00764 |* Output parameters:                   *|
00765 |*  NONE                      *|
00766 |*                        *|
00767 |* Returns:                     *|
00768 |*  NOTHING                     *|
00769 |*                        *|
00770 \******************************************************************************/
00771 
00772 void gen_default_init_code(int   attr_idx)
00773 
00774 {
00775    expr_arg_type  expr_desc;
00776    operator_type  operator;
00777    opnd_type      opnd;
00778 
00779 
00780    TRACE (Func_Entry, "gen_default_init_code", NULL);
00781 
00782    if (AT_DCL_ERR(attr_idx)) {
00783       goto EXIT;
00784    }
00785 
00786    if (SB_RUNTIME_INIT(ATD_STOR_BLK_IDX(attr_idx))) {
00787 
00788       /* The var is on the stack, or is automatic, a darg or a func  */
00789       /* result.  Generate runtime code for the initialization.      */
00790 
00791       operator = Asg_Opr;
00792    }
00793    else if (ATD_IN_COMMON(attr_idx)) {
00794       operator = Init_Opr;
00795 
00796 # if 0
00797 # if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
00798       func = gen_common_dv_init;
00799 # else
00800       func = gen_static_dv_whole_def;
00801 # endif
00802 # endif
00803    }
00804    else {
00805       operator = Init_Opr;
00806    }
00807 
00808    if (!ATD_IM_A_DOPE(attr_idx) &&
00809        TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure           &&
00810        ATT_DEFAULT_INITIALIZED(TYP_IDX(ATD_TYPE_IDX(attr_idx))) &&
00811        !AT_DCL_ERR(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) {
00812 
00813       OPND_FLD(opnd)      = AT_Tbl_Idx;
00814       OPND_IDX(opnd)      = attr_idx;
00815       OPND_LINE_NUM(opnd) = AT_DEF_LINE(attr_idx);
00816       OPND_COL_NUM(opnd)  = AT_DEF_COLUMN(attr_idx);
00817 
00818 # if defined(_F_MINUS_MINUS)
00819       if (ATD_ARRAY_IDX(attr_idx) || ATD_PE_ARRAY_IDX(attr_idx)) {
00820 # else
00821       if (ATD_ARRAY_IDX(attr_idx)) {
00822 # endif
00823          gen_whole_subscript(&opnd, &expr_desc);
00824       }
00825 
00826       process_all_initialized_cpnts(&opnd, 
00827                                     TYP_IDX(ATD_TYPE_IDX(attr_idx)),
00828                                     operator);
00829    }
00830 
00831 EXIT:
00832 
00833    TRACE (Func_Exit, "gen_default_init_code", NULL);
00834 
00835    return;
00836 
00837 }  /* gen_default_init_code */
00838 
00839 /******************************************************************************\
00840 |*                        *|
00841 |* Description:                     *|
00842 |*  recursively go through all components of a structure to look for      *|
00843 |*      default initialization. Then call the supplied routine func for       *|
00844 |*  processing.                   *|
00845 |*                        *|
00846 |* Input parameters:                    *|
00847 |*  left_opnd - current base of sub-object reference.                     *|
00848 |*      type_idx  - defined type attr.                                        *|
00849 |*      operator  - Whether to use Init_Opr or Asg_Opr.                       *|
00850 |*                        *|
00851 |* Output parameters:                   *|
00852 |*  NONE                      *|
00853 |*                        *|
00854 |* Returns:                     *|
00855 |*  NOTHING                     *|
00856 |*                        *|
00857 \******************************************************************************/
00858 
00859 static void process_all_initialized_cpnts(opnd_type    *left_opnd,
00860             int   type_idx,
00861             operator_type operator)
00862 
00863 {
00864    int      attr_idx;
00865    expr_arg_type  expr_desc;
00866    opnd_type    expr_opnd;
00867    int      init_idx;
00868    int      ir_idx;
00869    int      list_idx;
00870    opnd_type    opnd;
00871    int      sn_idx;
00872 
00873 
00874    TRACE (Func_Entry, "process_all_initialized_cpnts", NULL);
00875 
00876    sn_idx = ATT_FIRST_CPNT_IDX(type_idx);
00877 
00878    while (sn_idx != NULL_IDX) {
00879       attr_idx = SN_ATTR_IDX(sn_idx);  /* A component */
00880 
00881       if (ATD_CPNT_INIT_IDX(attr_idx) != NULL_IDX) {
00882          NTR_IR_TBL(ir_idx);
00883 
00884          IR_OPR(ir_idx)   = Struct_Opr;
00885          IR_TYPE_IDX(ir_idx)  = ATD_TYPE_IDX(attr_idx);
00886          IR_LINE_NUM(ir_idx)  = AT_DEF_LINE(attr_idx);
00887          IR_COL_NUM(ir_idx) = AT_DEF_COLUMN(attr_idx);
00888 
00889          COPY_OPND(IR_OPND_L(ir_idx), (*left_opnd));
00890 
00891          IR_FLD_R(ir_idx) = AT_Tbl_Idx;
00892          IR_IDX_R(ir_idx) = attr_idx;
00893          IR_LINE_NUM_R(ir_idx)  = AT_DEF_LINE(attr_idx);
00894          IR_COL_NUM_R(ir_idx) = AT_DEF_COLUMN(attr_idx);
00895 
00896          if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) {
00897              IR_RANK(ir_idx)  = IR_RANK(IR_IDX_L(ir_idx));
00898          }
00899 
00900          NTR_IR_TBL(init_idx);
00901 
00902          IR_OPR(init_idx) = operator;
00903          IR_LINE_NUM(init_idx)  = AT_DEF_LINE(attr_idx);
00904          IR_COL_NUM(init_idx) = AT_DEF_COLUMN(attr_idx);
00905          IR_TYPE_IDX(init_idx)  = TYPELESS_DEFAULT_TYPE;
00906          IR_FLD_L(init_idx) = IR_Tbl_Idx;
00907          IR_IDX_L(init_idx) = ir_idx;
00908          IR_LINE_NUM_L(init_idx)= AT_DEF_LINE(attr_idx);
00909          IR_COL_NUM_L(init_idx) = AT_DEF_COLUMN(attr_idx);
00910 
00911          if (operator == Asg_Opr) {
00912 
00913             if (ATD_FLD(attr_idx) == IR_Tbl_Idx) {
00914 
00915                /* This should be an Init_Opr */
00916 
00917                if (IR_OPR(ATD_CPNT_INIT_IDX(attr_idx)) != Init_Opr) {
00918                   PRINTMSG(AT_DEF_LINE(attr_idx), 626, Internal,
00919                            AT_DEF_COLUMN(attr_idx),
00920                            "An Init Opr",
00921                            "process_all_initialized_cpnts");
00922                }
00923 
00924                COPY_OPND(IR_OPND_R(init_idx),
00925                          IL_OPND(IR_IDX_R(ATD_CPNT_INIT_IDX(attr_idx))));
00926             }
00927             else {
00928                IR_IDX_R(init_idx) = ATD_CPNT_INIT_IDX(attr_idx);
00929                IR_FLD_R(init_idx) = (fld_type) ATD_FLD(attr_idx);
00930                IR_LINE_NUM_R(init_idx)  = AT_DEF_LINE(attr_idx);
00931                IR_COL_NUM_R(init_idx) = AT_DEF_COLUMN(attr_idx);
00932             }
00933 
00934             if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX ||
00935                 TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {   
00936                xref_state   = CIF_No_Usage_Rec;
00937                expr_desc.rank   = 0;
00938                OPND_FLD(expr_opnd)  = IR_Tbl_Idx;
00939                OPND_IDX(expr_opnd)  = ir_idx;;
00940 
00941                if (expr_semantics(&expr_opnd, &expr_desc)) {
00942                   COPY_OPND(IR_OPND_L(init_idx), expr_opnd);
00943                }
00944             }
00945 
00946             gen_sh(After,
00947                    Assignment_Stmt,
00948                    AT_DEF_LINE(attr_idx),
00949                    AT_DEF_COLUMN(attr_idx),
00950                    FALSE,
00951                    FALSE,
00952                    TRUE);
00953          }
00954          else {  /* Init_Opr */
00955 
00956             if (ATD_FLD(attr_idx) == IR_Tbl_Idx) {
00957 
00958                /* This should be an Init_Opr */
00959 
00960                if (IR_OPR(ATD_CPNT_INIT_IDX(attr_idx)) != Init_Opr) {
00961                   PRINTMSG(AT_DEF_LINE(attr_idx), 626, Internal,
00962                            AT_DEF_COLUMN(attr_idx),
00963                            "An Init Opr",
00964                            "process_all_initialized_cpnts");
00965                }
00966 
00967                IR_FLD_R(init_idx) = IL_Tbl_Idx;
00968                IR_IDX_R(init_idx) = IR_IDX_R(ATD_CPNT_INIT_IDX(attr_idx));
00969                IR_LIST_CNT_R(init_idx)  = 3;
00970             }
00971             else {
00972                NTR_IR_LIST_TBL(list_idx);
00973                IR_FLD_R(init_idx) = IL_Tbl_Idx;
00974                IR_IDX_R(init_idx) = list_idx;
00975                IR_LIST_CNT_R(init_idx)  = 3;
00976                IL_IDX(list_idx)   = ATD_CPNT_INIT_IDX(attr_idx);
00977                IL_FLD(list_idx)   = (fld_type) ATD_FLD(attr_idx);
00978                IL_LINE_NUM(list_idx)  = AT_DEF_LINE(attr_idx);
00979                IL_COL_NUM(list_idx) = AT_DEF_COLUMN(attr_idx);
00980        
00981                NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
00982 
00983                IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
00984 
00985                list_idx     = IL_NEXT_LIST_IDX(list_idx);
00986                IL_FLD(list_idx)   = CN_Tbl_Idx;
00987                IL_IDX(list_idx)   = CN_INTEGER_ONE_IDX;
00988                IL_LINE_NUM(list_idx)  = AT_DEF_LINE(attr_idx);
00989                IL_COL_NUM(list_idx) = AT_DEF_COLUMN(attr_idx);
00990 
00991                NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
00992 
00993                IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
00994 
00995                list_idx     = IL_NEXT_LIST_IDX(list_idx);
00996                IL_FLD(list_idx)   = CN_Tbl_Idx;
00997                IL_IDX(list_idx)   = CN_INTEGER_ZERO_IDX;
00998                IL_LINE_NUM(list_idx)  = AT_DEF_LINE(attr_idx);
00999                IL_COL_NUM(list_idx) = AT_DEF_COLUMN(attr_idx);
01000             }
01001 
01002             gen_sh(After,
01003                    Type_Init_Stmt,
01004                    AT_DEF_LINE(attr_idx),
01005                    AT_DEF_COLUMN(attr_idx),
01006                    FALSE,
01007                    FALSE,
01008                    TRUE);
01009          }
01010 
01011          SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
01012          SH_IR_IDX(curr_stmt_sh_idx)   = init_idx;
01013       }
01014       else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure           &&
01015                ATT_DEFAULT_INITIALIZED(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) {
01016 
01017          NTR_IR_TBL(ir_idx);
01018          IR_OPR(ir_idx)   = Struct_Opr;
01019          IR_TYPE_IDX(ir_idx)  = ATD_TYPE_IDX(attr_idx);
01020          IR_LINE_NUM(ir_idx)  = AT_DEF_LINE(attr_idx);
01021          IR_COL_NUM(ir_idx) = AT_DEF_COLUMN(attr_idx);
01022 
01023          COPY_OPND(IR_OPND_L(ir_idx), (*left_opnd));
01024 
01025          IR_FLD_R(ir_idx) = AT_Tbl_Idx;
01026          IR_IDX_R(ir_idx) = attr_idx;
01027          IR_LINE_NUM_R(ir_idx)  = AT_DEF_LINE(attr_idx);
01028          IR_COL_NUM_R(ir_idx) = AT_DEF_COLUMN(attr_idx);
01029          OPND_FLD(opnd)   = IR_Tbl_Idx;
01030          OPND_IDX(opnd)   = ir_idx;
01031 
01032          if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) {
01033              IR_RANK(ir_idx)  = IR_RANK(IR_IDX_L(ir_idx));
01034          }
01035 
01036          if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
01037             gen_whole_subscript(&opnd, &expr_desc);
01038          }
01039 
01040          process_all_initialized_cpnts(&opnd, 
01041                                        TYP_IDX(ATD_TYPE_IDX(attr_idx)),
01042                                        operator);
01043 
01044       }
01045 
01046       sn_idx = SN_SIBLING_LINK(sn_idx);
01047    }
01048 
01049    TRACE (Func_Exit, "process_all_initialized_cpnts", NULL);
01050 
01051    return;
01052 
01053 }  /* process_all_initialized_cpnts */
osprey/crayf90/fe90/s_typ_init.c
