Example #1
0
void end_forall_semantics (void)

{
   int                  ir_idx;
   int			list_idx;
   int                  sh_idx;


   TRACE (Func_Entry, "end_forall_semantics", NULL);

   sh_idx = SH_PARENT_BLK_IDX(curr_stmt_sh_idx);

   if (SH_ERR_FLG(curr_stmt_sh_idx) || SH_ERR_FLG(sh_idx)) {
      goto EXIT;
   }

# ifdef _DEBUG
   if (sh_idx == NULL_IDX) {
      PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 626, Internal,
               SH_COL_NUM(curr_stmt_sh_idx),
               "SH_PARENT_BLK_IDX", "end_forall_semantics");
   }
# endif

   ir_idx = SH_IR_IDX(sh_idx);

# ifdef _DEBUG
   if (IR_OPR(ir_idx) != Forall_Opr) {
      PRINTMSG(SH_GLB_LINE(curr_stmt_sh_idx), 626, Internal,
               SH_COL_NUM(curr_stmt_sh_idx),
               "Forall_Opr", "end_forall_semantics");
   }
# endif

   list_idx = IR_IDX_R(ir_idx);

   while (list_idx &&
          IL_FLD(list_idx) == IL_Tbl_Idx) {

      AT_ATTR_LINK(IL_IDX(IL_IDX(list_idx))) = NULL_IDX;
      AT_IGNORE_ATTR_LINK(IL_IDX(IL_IDX(list_idx))) = FALSE;

      list_idx = IL_NEXT_LIST_IDX(list_idx);
   }

EXIT:

   active_forall_sh_idx = SH_PARENT_BLK_IDX(active_forall_sh_idx);

   if (active_forall_sh_idx == NULL_IDX) {
      within_forall_construct = FALSE;
   }

   TRACE (Func_Exit, "end_forall_semantics", NULL);

   return;

}  /* end_forall_semantics */
Example #2
0
void gen_default_init_code(int	 attr_idx)

{
   expr_arg_type	expr_desc;
   operator_type	operator;
   opnd_type    	opnd;


   TRACE (Func_Entry, "gen_default_init_code", NULL);

   if (AT_DCL_ERR(attr_idx)) {
      goto EXIT;
   }

   if (SB_RUNTIME_INIT(ATD_STOR_BLK_IDX(attr_idx))) {

      /* The var is on the stack, or is automatic, a darg or a func  */
      /* result.  Generate runtime code for the initialization.      */

      operator = Asg_Opr;
   }
   else if (ATD_IN_COMMON(attr_idx)) {
      operator = Init_Opr;

# if 0
# if defined(_TARGET_OS_SOLARIS) || (defined(_TARGET_OS_IRIX) || defined(_TARGET_OS_LINUX) || defined(_TARGET_OS_DARWIN))
      func = gen_common_dv_init;
# else
      func = gen_static_dv_whole_def;
# endif
# endif
   }
   else {
      operator = Init_Opr;
   }

   if (!ATD_IM_A_DOPE(attr_idx) &&
       TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure           &&
       ATT_DEFAULT_INITIALIZED(TYP_IDX(ATD_TYPE_IDX(attr_idx))) &&
       !AT_DCL_ERR(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) {

      OPND_FLD(opnd)      = AT_Tbl_Idx;
      OPND_IDX(opnd)      = attr_idx;
      OPND_LINE_NUM(opnd) = AT_DEF_LINE(attr_idx);
      OPND_COL_NUM(opnd)  = AT_DEF_COLUMN(attr_idx);

# if defined(_F_MINUS_MINUS)
      if (ATD_ARRAY_IDX(attr_idx) || ATD_PE_ARRAY_IDX(attr_idx)) {
# else
      if (ATD_ARRAY_IDX(attr_idx)) {
# endif
         gen_whole_subscript(&opnd, &expr_desc);
      }

      process_all_initialized_cpnts(&opnd, 
                                    TYP_IDX(ATD_TYPE_IDX(attr_idx)),
                                    operator);
   }

EXIT:

   TRACE (Func_Exit, "gen_default_init_code", NULL);

   return;

}  /* gen_default_init_code */

/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	recursively go through all components of a structure to look for      *|
|*      default initialization. Then call the supplied routine func for       *|
|*	processing.							      *|
|*									      *|
|* Input parameters:							      *|
|*	left_opnd - current base of sub-object reference.                     *|
|*      type_idx  - defined type attr.                                        *|
|*      operator  - Whether to use Init_Opr or Asg_Opr.                       *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/

static void process_all_initialized_cpnts(opnd_type    *left_opnd,
					  int		type_idx,
					  operator_type	operator)

{
   int			attr_idx;
   expr_arg_type	expr_desc;
   opnd_type		expr_opnd;
   int			init_idx;
   int			ir_idx;
   int			list_idx;
   opnd_type		opnd;
   int			sn_idx;


   TRACE (Func_Entry, "process_all_initialized_cpnts", NULL);

   sn_idx = ATT_FIRST_CPNT_IDX(type_idx);

   while (sn_idx != NULL_IDX) {
      attr_idx = SN_ATTR_IDX(sn_idx);  /* A component */

      if (ATD_CPNT_INIT_IDX(attr_idx) != NULL_IDX) {
         NTR_IR_TBL(ir_idx);

         IR_OPR(ir_idx)		= Struct_Opr;
         IR_TYPE_IDX(ir_idx)	= ATD_TYPE_IDX(attr_idx);
         IR_LINE_NUM(ir_idx)	= AT_DEF_LINE(attr_idx);
         IR_COL_NUM(ir_idx)	= AT_DEF_COLUMN(attr_idx);

         COPY_OPND(IR_OPND_L(ir_idx), (*left_opnd));

         IR_FLD_R(ir_idx)	= AT_Tbl_Idx;
         IR_IDX_R(ir_idx)	= attr_idx;
         IR_LINE_NUM_R(ir_idx)	= AT_DEF_LINE(attr_idx);
         IR_COL_NUM_R(ir_idx)	= AT_DEF_COLUMN(attr_idx);

         if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) {
             IR_RANK(ir_idx)	= IR_RANK(IR_IDX_L(ir_idx));
         }

         NTR_IR_TBL(init_idx);

         IR_OPR(init_idx)	= operator;
         IR_LINE_NUM(init_idx)	= AT_DEF_LINE(attr_idx);
         IR_COL_NUM(init_idx)	= AT_DEF_COLUMN(attr_idx);
         IR_TYPE_IDX(init_idx)	= TYPELESS_DEFAULT_TYPE;
         IR_FLD_L(init_idx)	= IR_Tbl_Idx;
         IR_IDX_L(init_idx)	= ir_idx;
         IR_LINE_NUM_L(init_idx)= AT_DEF_LINE(attr_idx);
         IR_COL_NUM_L(init_idx)	= AT_DEF_COLUMN(attr_idx);

         if (operator == Asg_Opr) {

            if (ATD_FLD(attr_idx) == IR_Tbl_Idx) {

               /* This should be an Init_Opr */

               if (IR_OPR(ATD_CPNT_INIT_IDX(attr_idx)) != Init_Opr) {
                  PRINTMSG(AT_DEF_LINE(attr_idx), 626, Internal,
                           AT_DEF_COLUMN(attr_idx),
                           "An Init Opr",
                           "process_all_initialized_cpnts");
               }

               COPY_OPND(IR_OPND_R(init_idx),
                         IL_OPND(IR_IDX_R(ATD_CPNT_INIT_IDX(attr_idx))));
            }
            else {
               IR_IDX_R(init_idx)	= ATD_CPNT_INIT_IDX(attr_idx);
               IR_FLD_R(init_idx)	= (fld_type) ATD_FLD(attr_idx);
               IR_LINE_NUM_R(init_idx)	= AT_DEF_LINE(attr_idx);
               IR_COL_NUM_R(init_idx)	= AT_DEF_COLUMN(attr_idx);
            }

            if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX ||
                TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Character) {   
               xref_state		= CIF_No_Usage_Rec;
               expr_desc.rank		= 0;
               OPND_FLD(expr_opnd)	= IR_Tbl_Idx;
               OPND_IDX(expr_opnd)	= ir_idx;;

               if (expr_semantics(&expr_opnd, &expr_desc)) {
                  COPY_OPND(IR_OPND_L(init_idx), expr_opnd);
               }
            }

            gen_sh(After,
                   Assignment_Stmt,
                   AT_DEF_LINE(attr_idx),
                   AT_DEF_COLUMN(attr_idx),
                   FALSE,
                   FALSE,
                   TRUE);
         }
         else {  /* Init_Opr */

            if (ATD_FLD(attr_idx) == IR_Tbl_Idx) {

               /* This should be an Init_Opr */

               if (IR_OPR(ATD_CPNT_INIT_IDX(attr_idx)) != Init_Opr) {
                  PRINTMSG(AT_DEF_LINE(attr_idx), 626, Internal,
                           AT_DEF_COLUMN(attr_idx),
                           "An Init Opr",
                           "process_all_initialized_cpnts");
               }

               IR_FLD_R(init_idx)	= IL_Tbl_Idx;
               IR_IDX_R(init_idx)	= IR_IDX_R(ATD_CPNT_INIT_IDX(attr_idx));
               IR_LIST_CNT_R(init_idx)	= 3;
            }
            else {
               NTR_IR_LIST_TBL(list_idx);
               IR_FLD_R(init_idx)	= IL_Tbl_Idx;
               IR_IDX_R(init_idx)	= list_idx;
               IR_LIST_CNT_R(init_idx)	= 3;
               IL_IDX(list_idx)		= ATD_CPNT_INIT_IDX(attr_idx);
               IL_FLD(list_idx)		= (fld_type) ATD_FLD(attr_idx);
               IL_LINE_NUM(list_idx)	= AT_DEF_LINE(attr_idx);
               IL_COL_NUM(list_idx)	= AT_DEF_COLUMN(attr_idx);
       
               NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));

               IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;

               list_idx			= IL_NEXT_LIST_IDX(list_idx);
               IL_FLD(list_idx)		= CN_Tbl_Idx;
               IL_IDX(list_idx)		= CN_INTEGER_ONE_IDX;
               IL_LINE_NUM(list_idx)	= AT_DEF_LINE(attr_idx);
               IL_COL_NUM(list_idx)	= AT_DEF_COLUMN(attr_idx);

               NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));

               IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;

               list_idx			= IL_NEXT_LIST_IDX(list_idx);
               IL_FLD(list_idx)		= CN_Tbl_Idx;
               IL_IDX(list_idx)		= CN_INTEGER_ZERO_IDX;
               IL_LINE_NUM(list_idx)	= AT_DEF_LINE(attr_idx);
               IL_COL_NUM(list_idx)	= AT_DEF_COLUMN(attr_idx);
            }

            gen_sh(After,
                   Type_Init_Stmt,
                   AT_DEF_LINE(attr_idx),
                   AT_DEF_COLUMN(attr_idx),
                   FALSE,
                   FALSE,
                   TRUE);
         }

         SH_P2_SKIP_ME(curr_stmt_sh_idx) = TRUE;
         SH_IR_IDX(curr_stmt_sh_idx)	 = init_idx;
      }
      else if (TYP_TYPE(ATD_TYPE_IDX(attr_idx)) == Structure           &&
               ATT_DEFAULT_INITIALIZED(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) {

         NTR_IR_TBL(ir_idx);
         IR_OPR(ir_idx)		= Struct_Opr;
         IR_TYPE_IDX(ir_idx)	= ATD_TYPE_IDX(attr_idx);
         IR_LINE_NUM(ir_idx)	= AT_DEF_LINE(attr_idx);
         IR_COL_NUM(ir_idx)	= AT_DEF_COLUMN(attr_idx);

         COPY_OPND(IR_OPND_L(ir_idx), (*left_opnd));

         IR_FLD_R(ir_idx)	= AT_Tbl_Idx;
         IR_IDX_R(ir_idx)	= attr_idx;
         IR_LINE_NUM_R(ir_idx)	= AT_DEF_LINE(attr_idx);
         IR_COL_NUM_R(ir_idx)	= AT_DEF_COLUMN(attr_idx);
         OPND_FLD(opnd)		= IR_Tbl_Idx;
         OPND_IDX(opnd)		= ir_idx;

         if (IR_FLD_L(ir_idx) == IR_Tbl_Idx) {
             IR_RANK(ir_idx)	= IR_RANK(IR_IDX_L(ir_idx));
         }

         if (ATD_ARRAY_IDX(attr_idx) != NULL_IDX) {
            gen_whole_subscript(&opnd, &expr_desc);
         }

         process_all_initialized_cpnts(&opnd, 
                                       TYP_IDX(ATD_TYPE_IDX(attr_idx)),
                                       operator);

      }

      sn_idx = SN_SIBLING_LINK(sn_idx);
   }

   TRACE (Func_Exit, "process_all_initialized_cpnts", NULL);

   return;

}  /* process_all_initialized_cpnts */
Example #3
0
void type_init_semantics (void)

{
   int			attr_idx;
   int			col;
   expr_arg_type	expr_desc;
   opnd_type		init_opnd;
   int			ir_idx;
   int			line;
   int			list_idx;
   int			opnd_column;
   int			opnd_line;
   int			sh_idx;
   int			type_idx;


   TRACE (Func_Entry, "type_init_semantics", NULL);

   /* set comp_gen_expr to TRUE. This forces the fold of REAL   */
   /* constant expressions. When -Oieeeconform is specified,    */
   /* the folding of Real and Complex expressions is prevented. */

   comp_gen_expr = TRUE;

   ir_idx	= SH_IR_IDX(curr_stmt_sh_idx);
   attr_idx	= IR_IDX_L(ir_idx);

   COPY_OPND(init_opnd, IR_OPND_R(ir_idx));

   line	= IR_LINE_NUM_L(ir_idx);
   col  = IR_COL_NUM_L(ir_idx);

   /* Constraint checks:                                                   */
   /* * A variable that is a member of blank common should not be          */
   /*   initialized.                                                       */
   /* * A variable that is a member of a named common block should only be */
   /*   initialized in a block data program unit.                          */
   /* * A variable that is a member of a task common block must not be     */
   /*   initialized.                                                       */
   /* * From a CF77 SPR:  If an object in a Block Data program unit is NOT */
   /*   in a common block (and is not equivalenced to an object in common) */
   /*   but IS initialized, issue a warning.                               */

   if (ATD_IN_COMMON(attr_idx)) {

      if (SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx)) == Common) {

         if (SB_BLANK_COMMON(ATD_STOR_BLK_IDX(attr_idx))) {
            PRINTMSG(line, 1109, Ansi, col);
         }

         else if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) != Blockdata) {

# if defined(_ALLOW_DATA_INIT_OF_COMMON)
            PRINTMSG(line, 692, Ansi, col);
# else
            PRINTMSG(line, 1542, Warning, col);
# endif
         }
      }
      else if (SB_BLK_TYPE(ATD_STOR_BLK_IDX(attr_idx)) == Task_Common) {
         PRINTMSG(line, 851, Error, col);
         goto EXIT;
      }
   }
   else if (ATP_PGM_UNIT(SCP_ATTR_IDX(curr_scp_idx)) == Blockdata  &&
            ! (ATD_EQUIV(attr_idx)  &&
               SB_IS_COMMON(ATD_STOR_BLK_IDX(attr_idx)))) {
      PRINTMSG(line, 825, Warning, col);
   }

   /* There is no way to initialize a CRI character pointer.               */

   type_idx = ATD_TYPE_IDX(attr_idx);

   if (TYP_TYPE(type_idx) == CRI_Ch_Ptr) {
      PRINTMSG(line, 695, Error, col);
      goto EXIT;
   }

   if (AT_DCL_ERR(attr_idx)) {
      /* don't do anything else */
      goto EXIT;
   }


   OPND_FLD(init_target_opnd) = AT_Tbl_Idx;
   OPND_IDX(init_target_opnd) = attr_idx;
   OPND_LINE_NUM(init_target_opnd) = line;
   OPND_COL_NUM(init_target_opnd) = col;

   target_array_idx		= ATD_ARRAY_IDX(attr_idx);

   if (TYP_TYPE(type_idx) == Integer ||
       TYP_TYPE(type_idx) == Real    ||
       TYP_TYPE(type_idx) == Complex) {

      check_type_conversion = TRUE;
      target_type_idx       = type_idx;
   }
   else if (TYP_TYPE(type_idx) == Character) {

      if (TYP_CHAR_CLASS(type_idx) == Const_Len_Char) {

         check_type_conversion = TRUE;
         target_type_idx       = Character_1;
         target_char_len_idx   = TYP_IDX(type_idx);
      }
   }

   expr_mode  = Initialization_Expr;
   xref_state = CIF_Symbol_Reference;

   if (expr_semantics(&init_opnd, &expr_desc)) {

      if (ATD_POINTER(attr_idx) &&
          (OPND_FLD(init_opnd) == AT_Tbl_Idx || 
           OPND_FLD(init_opnd) == CN_Tbl_Idx ||
           (OPND_FLD(init_opnd) == IR_Tbl_Idx &&
            IR_OPR(OPND_IDX(init_opnd)) != Null_Intrinsic_Opr))) {
         PRINTMSG(line, 1559, Error, col,
                  AT_OBJ_NAME_PTR(attr_idx));
         goto EXIT;
      }

      if (! expr_desc.foldable) {

         /* The initialization expression must be a constant. */

         if (ATD_POINTER(attr_idx) &&
             OPND_FLD(init_opnd) == IR_Tbl_Idx &&
             IR_OPR(OPND_IDX(init_opnd)) == Null_Intrinsic_Opr) {
             goto EXIT;
         }
#ifdef KEY /* Bug 6845 */
	else if ((AT_OBJ_CLASS(TYP_IDX(ATD_TYPE_IDX(attr_idx)))
	     == Derived_Type) &&
	     ATT_ALLOCATABLE_CPNT(TYP_IDX(ATD_TYPE_IDX(attr_idx)))) {
	     find_opnd_line_and_column(&init_opnd, &opnd_line, &opnd_column);
	     PRINTMSG(opnd_line, 1680, Error, opnd_column,
	       AT_OBJ_NAME_PTR(attr_idx));
	     goto EXIT;
	}
#endif /* KEY Bug 6845 */
         else {
            find_opnd_line_and_column(&init_opnd, &opnd_line, &opnd_column);
            PRINTMSG(opnd_line, 842, Error, opnd_column);
            goto EXIT;
         }
      }

      while (OPND_FLD(init_opnd) == IR_Tbl_Idx) {
        COPY_OPND(init_opnd, IR_OPND_L(OPND_IDX(init_opnd)));
      }
   }
   else {
      goto EXIT;
   }

   if (OPND_FLD(init_opnd) == AT_Tbl_Idx) {

      if (attr_init_semantics(&init_opnd, attr_idx, ir_idx, &expr_desc)) {

         /* pull this init out of stmts. don't need it any more */

         sh_idx					= curr_stmt_sh_idx;
         SH_NEXT_IDX(SH_PREV_IDX(sh_idx))	= SH_NEXT_IDX(sh_idx);
         SH_PREV_IDX(SH_NEXT_IDX(sh_idx))	= SH_PREV_IDX(sh_idx);
         curr_stmt_sh_idx			= SH_PREV_IDX(sh_idx);
         FREE_IR_NODE(ir_idx);
         FREE_SH_NODE(sh_idx);
      }
   }
   else {

      if (const_init_semantics(&init_opnd, attr_idx, ir_idx)) {
         find_opnd_line_and_column(&init_opnd, &opnd_line, &opnd_column);
         NTR_IR_LIST_TBL(list_idx);
         IR_FLD_R(ir_idx)	= IL_Tbl_Idx;
         IR_IDX_R(ir_idx)	= list_idx;
         IR_LIST_CNT_R(ir_idx)	= 3;
 
         COPY_OPND(IL_OPND(list_idx), init_opnd);
       
         NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
         IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
         list_idx		= IL_NEXT_LIST_IDX(list_idx);

         IL_FLD(list_idx)	= CN_Tbl_Idx;
         IL_IDX(list_idx)	= CN_INTEGER_ONE_IDX;
         IL_LINE_NUM(list_idx)	= opnd_line;
         IL_COL_NUM(list_idx)	= opnd_column;

         NTR_IR_LIST_TBL(IL_NEXT_LIST_IDX(list_idx));
         IL_PREV_LIST_IDX(IL_NEXT_LIST_IDX(list_idx)) = list_idx;
         list_idx		= IL_NEXT_LIST_IDX(list_idx);

         IL_FLD(list_idx)	= CN_Tbl_Idx;
         IL_IDX(list_idx)	= CN_INTEGER_ZERO_IDX;
         IL_LINE_NUM(list_idx)	= opnd_line;
         IL_COL_NUM(list_idx)	= opnd_column;
      }
   }

EXIT:

   expr_mode			= Regular_Expr;
   check_type_conversion	= FALSE;
   target_array_idx		= NULL_IDX;
   init_target_opnd		= null_opnd;

   /* reset comp_gen_expr to FALSE. end of compiler generated expression */

   comp_gen_expr = FALSE;

   TRACE (Func_Exit, "type_init_semantics", NULL);

   return;

}  /* type_init_semantics */