Exemplo n.º 1
0
int main (int	 argc,
	   char *argv[])
# endif

{
   int		column_num;
   long		field_len;
   int		line_num;
   char	       *msg_name;
   int		save_statement_number = 0;

# if (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))
   		double		end_time;
   		double		start_time;
		/* char		time[20]; */
   		double		total_cpu_time;
   struct	rusage		ru;
# else

# if !defined(_HOST_OS_UNICOS)
   long		end_clock;
# endif
   		float		end_time;
   		float		start_time;
   		float		total_cpu_time;
# endif

# if defined(_HOST_OS_UNICOS) && defined(_DEBUG)
   lowmem_check();
# endif

# if defined(_TARGET32) && defined(_DEBUG)
   setbuf(stdout, NULL);
   setbuf(stderr, NULL);
# endif


# if defined(_HOST_OS_UNICOS)

   /* Lots of start up - ignore first call.  See the comment block that       */
   /* precedes procedure cif_summary_rec in fecif.c for a discussion of the   */
   /* timing methods used by the different platforms.			      */

   SECOND(&start_time);


   /* M_LOWFIT will eventually be in malloc.h. */
   /* When it is remove this definition.       */

# define M_LOWFIT	0107	 /* Use lowest-fit algorithm for allocation. */

   mallopt(M_LOWFIT, 1);

# elif defined(_HOST_OS_MAX)

   /* Use clock() on MPP's (in particular T3E's) because at the time this     */
   /* change was made, neither SECOND() nor SECONDR() worked on T3E's.        */
   /*                                                  LRR  4 Mar 1997        */

   clock();
   start_time = 0;

   /* M_LOWFIT will eventually be in malloc.h. */
   /* When it is remove this definition.       */

# define M_LOWFIT	0107	 /* Use lowest-fit algorithm for allocation. */

   mallopt(M_LOWFIT, 1);

# elif defined(_HOST_OS_SOLARIS)

   /* clock() is only semi-useful on a Sun because it rolls over in just over */
   /* 2147 seconds (about 36 minutes).  So on a Sun, we use clock() and       */
   /* time() both.  If elapsed time <= 2147 seconds, the accounting info will */
   /* show milliseconds (from clock()), else it will show seconds (because    */
   /* that is the accuracy of time()).  This resolution should be good enough */
   /* for a compilation exceeding 36 minutes.                                 */

   start_time = (float) time(NULL);
   clock();

# elif (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))

   getrusage (RUSAGE_SELF, &ru);
   start_time = (double) ru.ru_utime.tv_sec +
                (double) ru.ru_utime.tv_usec * 1e-6 +
                (double) ru.ru_stime.tv_sec +
                (double) ru.ru_stime.tv_usec * 1e-6;

# else

   start_time = 0;

# endif


   comp_phase = Pass1_Parsing;
   stmt_start_line = 1;			/* Set in case mem problems */

   init_compiler(argc, argv);			/* init and process cmd line */

   if (on_off_flags.preprocess_only) {
      goto PREPROCESS_ONLY_SKIP;
   }

   stmt_start_line = 0;

   while (LA_CH_CLASS != Ch_Class_EOF) {

      comp_phase = Pass1_Parsing;
      num_prog_unit_errors = 0;		/* Accum errs for pgm unit */

      OUTPUT_PASS_HEADER(Syntax_Pass);

      if (save_statement_number != 0) {
         statement_number = save_statement_number;
      }

      parse_prog_unit();

      save_statement_number = statement_number;

      if (LA_CH_CLASS == Ch_Class_EOF) {
         issue_deferred_msgs();
      }

      /* get current field length and save largest value */

      field_len = (long) sbrk(0);

# if defined(_HOST_OS_MAX)
      field_len &= (1 << 32) - 1;
# endif

      if (field_len > max_field_len) {		/* Max set in init_compiler */
	 max_field_len = field_len;		/* Track max usage */
      }

      PRINT_IR_TBL;	/* If -u ir and DEBUG compiler, print ir. */

      OUTPUT_PASS_HEADER(Semantics_Pass);

      semantics_pass_driver();			/* PASS 2 */

      if (SCP_IN_ERR(curr_scp_idx)) {
         some_scp_in_err = TRUE;
      }

      PRINT_ALL_SYM_TBLS;	/* If debug print -u options */
      PRINT_FORTRAN_OUT;	/* Print ir in a fortran format */

      line_num = SH_GLB_LINE(SCP_LAST_SH_IDX(curr_scp_idx));
      column_num = SH_COL_NUM(SCP_LAST_SH_IDX(curr_scp_idx));

      if (num_prog_unit_errors == 0) {
         if (opt_flags.inline_lvl > Inline_Lvl_0) {
            comp_phase = Inlining;
            inline_processing(SCP_FIRST_SH_IDX(curr_scp_idx));
            PRINT_IR_TBL3;	
         }
      }

      insert_global_directives = TRUE;

      comp_phase = Pdg_Conversion;
      if (dump_flags.preinline) { /* Do not do a full compile */

         if (ATP_PGM_UNIT(SCP_ATTR_IDX(MAIN_SCP_IDX)) == Module ||
             ATP_PGM_UNIT(SCP_ATTR_IDX(MAIN_SCP_IDX)) == Function ||
             ATP_PGM_UNIT(SCP_ATTR_IDX(MAIN_SCP_IDX)) == Subroutine) {
            curr_scp_idx = MAIN_SCP_IDX;
#ifdef KEY /* Bug 3477 */
            if (create_mod_info_file()) {  /* Creates a name for the file. */
	      create_mod_info_tbl();        /* Creates the table. */
	      output_mod_info_file();       /* Writes the table.  */
	      }
#else
            create_mod_info_file();  /* Creates a name for the file. */
            create_mod_info_tbl();        /* Creates the table. */
            output_mod_info_file();       /* Writes the table.  */
#endif /* KEY Bug 3477 */
            free_tables();                /* Frees the tables. */
         }
      }
      else {
#ifdef KEY /* Bug 3477 */
	 int do_output_file = FALSE;
#endif /* KEY Bug 3477 */
         if (ATP_PGM_UNIT(SCP_ATTR_IDX(MAIN_SCP_IDX)) == Module) {
#ifdef KEY /* Bug 3477 */
            do_output_file = create_mod_info_file();  /* Creates a name for the file. */
#else
            create_mod_info_file();  /* Creates a name for the file. */
#endif /* KEY Bug 3477 */
         }

         if (num_prog_unit_errors == 0 && (binary_output || assembly_output)) {
            cvrt_to_pdg(compiler_gen_date);
         }
         else if (ATP_PGM_UNIT(SCP_ATTR_IDX(MAIN_SCP_IDX)) == Module) {

            if (!SCP_IN_ERR(MAIN_SCP_IDX)) {
               curr_scp_idx = MAIN_SCP_IDX;
#ifdef KEY /* Bug 3477 */
	       if (do_output_file) {
		 create_mod_info_tbl();   /* Creates the table. */
		 output_mod_info_file();  /* Writes the table.  */
		 }
#else
               create_mod_info_tbl();   /* Creates the table. */
               output_mod_info_file();  /* Writes the table.  */
#endif /* KEY Bug 3477 */
            }

            free_tables();           /* Frees the tables. */
         }
         else {
            free_tables();           /* Frees the tables. */
         }
      }

      /* ALERT - At this point, the symbol tables are invalid. */

      /* Spit out the End Unit for the current program unit.  The End Unit    */
      /* is needed if the Compiler Information File (CIF) is being produced   */
      /* and for the buffered message file.				      */

      stmt_start_line = line_num;
      stmt_start_col = column_num;

      if (scp_tbl == NULL_IDX) {                  /* Table has been freed. */
         cif_end_unit_rec(program_unit_name);
      }
      else {
         cif_end_unit_rec(AT_OBJ_NAME_PTR(SCP_ATTR_IDX(curr_scp_idx)));
      }

   }  /* while */

   clean_up_module_files();

# ifdef _NAME_SUBSTITUTION_INLINING
   if (!dump_flags.preinline)
# endif
      terminate_PDGCS();

   PRINT_GL_TBL;              /* Prints to debug_file ifdef _DEBUG and -u gl */
   PRINT_GN_TBL;              /* Prints to debug_file ifdef _DEBUG and -u gn */


PREPROCESS_ONLY_SKIP:


# if defined(_HOST_OS_UNICOS) 

   SECOND(&end_time);

# elif defined(_HOST_OS_MAX)

   end_clock = clock();
   end_time  = 0;

# elif defined(_HOST_OS_SOLARIS)

   end_time  = (float) time(NULL);
   end_clock = clock();

# elif (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))

   getrusage(RUSAGE_SELF, &ru);
   end_time = (double) ru.ru_utime.tv_sec +
              (double) ru.ru_utime.tv_usec * 1e-6 +
              (double) ru.ru_stime.tv_sec +
              (double) ru.ru_stime.tv_usec * 1e-6;

# else

   end_time = 0;

# endif


   total_cpu_time = end_time - start_time;

   if (cif_need_unit_rec  &&  cif_first_pgm_unit) {

      /* Catastrophic errors, like a free source form program was compiled    */
      /* in fixed source form mode, so no Unit record was output.  Output     */
      /* enough records to keep libcif tools happy.  This routine needs to be */
      /* called whether or not a CIF is being written because the buffered    */
      /* message file also must have the correct format.		      */

      cif_fake_a_unit();
   }


   /* CAUTION:  The following code assumes that non-Cray platforms measure    */
   /* memory usage in terms of bytes and that there are 4 bytes per word.     */

   cif_summary_rec(release_level,
                   compiler_gen_date,
                   compiler_gen_time,
                   total_cpu_time,

# if defined(_HOST_OS_UNICOS)

                   (long) 0,
                   (some_scp_in_err) ? -3 : max_field_len);

# elif defined(_HOST_OS_MAX) 

                   end_clock,
                   (some_scp_in_err) ? -3 : max_field_len);

# elif (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX)) 

                   (long) 0,
                   (some_scp_in_err) ? -3 : max_field_len/4);

# else /* defined(_HOST_OS_SOLARIS) */

                   end_clock,
                   (some_scp_in_err) ? -3 : max_field_len/4);

# endif                         
   

   /* Output compilation summary info if the -V option was specified on the   */
   /* command line.  Also, issue the summary information if any messages were */
   /* actually issued.          					      */

   if (cmd_line_flags.verify_option || 
       num_errors > 0               || 
       num_warnings > 0             ||
       num_cautions > 0             ||
       num_notes > 0                ||
       num_comments > 0             ||
       num_ansi > 0                 ||
       (num_optz_msgs > 0  &&  opt_flags.msgs)) { 
      print_buffered_messages();
      print_id_line();

      /* Output the summary lines.  The compilation time is in seconds.       */
      /* CAUTION:  The following non-Cray code assumes a 32-bit word.         */

# if defined(_HOST_OS_UNICOS)

      PRINTMSG (0, 104, Log_Summary, 0, (double) total_cpu_time);
      msg_name	= "cf90";

# elif defined(_HOST_OS_MAX)

      PRINTMSG (0, 104, Log_Summary, 0, (double) end_clock/1000000.0);
      msg_name	= "cf90";

# elif defined(_HOST_OS_LINUX)
      msg_name	= PSC_NAME_PREFIX "f95";

# elif (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))

      /* IRIX cannot handle the int to float change necessary to get the      */
      /* time printed correctly, so we'll convert it to a character string    */
      /* and use a different message.                                         */
      /*							    	      */
      /* LRR  4/28/97  In an email message from Rich Shapiro to me, he stated */
      /* he did not want this line in the summary lines.		      */

/*    sprintf(time, "%-1.2f", (double) total_cpu_time);
      PRINTMSG (0, 1310, Log_Summary, 0, time);             */
      msg_name	= "cf90";

# elif defined(_HOST_OS_SOLARIS)

      PRINTMSG (0, 104, Log_Summary, 0,
                (total_cpu_time <= 2147.0) ? (float) end_clock/1000000.0 :
                                             (float) total_cpu_time);
      msg_name	= "cf90";

# endif


      /* Maximum field length (maximum amount of memory used) in words        */
      /* (decimal).  							      */
      /* CAUTION:  Non-Cray platforms are assumed to measure memory usage in  */
      /* bytes and we assume 4 bytes per word.         			      */

# if defined(_HOST_OS_UNICOS)

      PRINTMSG (0, 105, Log_Summary, 0, max_field_len);

# elif ! (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX))

      /* LRR  4/28/97  In an email message from Rich Shapiro to me, he stated */
      /* he did not want this line in the summary lines.		      */

      PRINTMSG (0, 105, Log_Summary, 0, max_field_len/4);

# endif


      /* Number of source lines compiled.				      */

# if (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX)) && !defined(_TARGET_SV2)

      PRINTMSG (0, 1401, Log_Summary, 0, --curr_glb_line);

# else

      PRINTMSG (0, 106, Log_Summary, 0, --curr_glb_line);

# endif


      /* Number of messages issued.					      */

# if (defined(_HOST_OS_IRIX) || defined(_HOST_OS_LINUX)) && !defined(_TARGET_SV2)

      PRINTMSG (0, 1403, Log_Summary, 0,
                num_errors,
                num_warnings,
                (opt_flags.msgs == 0) ?
                   (num_cautions + num_notes + num_comments) :
                   (num_cautions + num_notes + num_comments + num_optz_msgs),
                num_ansi);

# else

      PRINTMSG (0, 107, Log_Summary, 0,
                num_errors,
                num_warnings,
                (opt_flags.msgs == 0) ?
                   (num_cautions + num_notes + num_comments) :
                   (num_cautions + num_notes + num_comments + num_optz_msgs),
                num_ansi);


      /* Code: in words; data: in words.				      */

      /* LRR  4/28/97  In an email message from Rich Shapiro to me, he stated */
      /* he did not want this line in the summary lines.		      */

# if !defined(_TARGET_SV2)   /* Prints blank for sv2 right now. */
      PRINTMSG (0, 108, Log_Summary, 0, code_size, data_size);
# endif

# endif

      if (num_errors > 0               || 
          num_warnings > 0             ||
          num_cautions > 0             ||
          num_notes > 0                ||
          num_comments > 0             ||
          num_ansi > 0                 ||
          (num_optz_msgs > 0  &&  opt_flags.msgs)) { 
         PRINTMSG (0, 1636, Log_Summary, 0, msg_name, msg_name);
      }
   }  /* End of summary printing. */


# ifdef _DEBUG

   /* Get memory usage reports for these global tables. */

   final_src_input();

   MEM_REPORT(file_path_tbl);
   MEM_REPORT(global_attr_tbl);
   MEM_REPORT(global_bounds_tbl);
   MEM_REPORT(global_line_tbl);
   MEM_REPORT(global_name_tbl);
   MEM_REPORT(global_type_tbl);
   MEM_REPORT(str_pool);

# endif

   exit_compiler ((num_errors == 0) ? RC_OKAY : RC_USER_ERROR);

}  /* main */
Exemplo n.º 2
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 */
Exemplo n.º 3
0
static	boolean	attr_init_semantics(opnd_type		*init_opnd,
				    int			 attr_idx,
				    int			 ir_idx,
				    expr_arg_type	*expr_desc)

{
   int			c_type_idx;
   int			column;
   int			i;
   int			line;
   boolean		ok		= TRUE;
   int			opnd_column;
   int			opnd_line;
   char			type_str[40];


   TRACE (Func_Entry, "attr_init_semantics", NULL);

   line		= IR_LINE_NUM_L(ir_idx);
   column	= IR_COL_NUM_L(ir_idx);
   c_type_idx	= expr_desc->type_idx;

   find_opnd_line_and_column(init_opnd, &opnd_line, &opnd_column);

   if (TYP_LINEAR(c_type_idx) == Long_Typeless) {
      PRINTMSG(opnd_line, 1133, Error, opnd_column);
      ok = FALSE;
   }
   else if (!check_asg_semantics(ATD_TYPE_IDX(attr_idx),
                                 c_type_idx,
                                 opnd_line,
                                 opnd_column)) {
      type_str[0] = '\0';
      strcat(type_str, get_basic_type_str(ATD_TYPE_IDX(attr_idx)));

      PRINTMSG(line, 843, Error, column, AT_OBJ_NAME_PTR(attr_idx),
               type_str,
               get_basic_type_str(c_type_idx));
      ok = FALSE;
   }
   else if (expr_desc->rank > 0) {         /* check array conformance */

      if (ATD_ARRAY_IDX(attr_idx) == NULL_IDX) {
         PRINTMSG(line, 844, Error, column, AT_OBJ_NAME_PTR(attr_idx));
         ok = FALSE;
      }
      else if (expr_desc->rank == BD_RANK(ATD_ARRAY_IDX(attr_idx))) {

         for (i = 1; i <= expr_desc->rank; i++) {

            if (fold_relationals(expr_desc->shape[i-1].idx,
                                 BD_XT_IDX(ATD_ARRAY_IDX(attr_idx),i),
                                 Ne_Opr)) {

               PRINTMSG(line, 845, Error, column, AT_OBJ_NAME_PTR(attr_idx));
               ok = FALSE;
               break;
            }
         }
      }
      else {
         PRINTMSG(line, 845, Error, column, AT_OBJ_NAME_PTR(attr_idx));
         ok = FALSE;
      }
   }

   TRACE (Func_Exit, "attr_init_semantics", NULL);

   return(ok);

}  /* attr_init_semantics */
Exemplo n.º 4
0
static boolean const_init_semantics(opnd_type		*init_opnd,
				    int			 attr_idx,
				    int			 ir_idx)

{
   int			a_type_idx;
   long_type	        another_constant[MAX_WORDS_FOR_NUMERIC];
   int			c_type_idx;
   char			*char_ptr;
   char			*c_char_ptr;
   int			column;
   int			const_idx;
   long64		i;
   int			line;
   boolean		ok		= TRUE;
   int			opnd_column;
   int			opnd_line;
   opnd_type		tar_opnd;
   char			type_str[40];


   TRACE (Func_Entry, "const_init_semantics", NULL);

   line		= IR_LINE_NUM_L(ir_idx);
   column	= IR_COL_NUM_L(ir_idx);
   a_type_idx	= ATD_TYPE_IDX(attr_idx);
   c_type_idx	= CN_TYPE_IDX(OPND_IDX((*init_opnd)));

   find_opnd_line_and_column(init_opnd, &opnd_line, &opnd_column);

   if (TYP_LINEAR(c_type_idx) == Long_Typeless) {
      PRINTMSG(opnd_line, 1133, Error, opnd_column);
      ok = FALSE;
      goto EXIT;
   }
   else if (!check_asg_semantics(a_type_idx,
                                 c_type_idx,
                                 opnd_line,
                                 opnd_column)) {
      type_str[0] = '\0';
      strcat(type_str, get_basic_type_str(a_type_idx));

      PRINTMSG(line, 843, Error, column, AT_OBJ_NAME_PTR(attr_idx),
               type_str,
               get_basic_type_str(c_type_idx));
      ok = FALSE;
      goto EXIT;
   }

   if (TYP_TYPE(a_type_idx) == Character) {

      if (fold_relationals(TYP_IDX(a_type_idx),
                           TYP_IDX(c_type_idx),
                           Ne_Opr)) {

         /* assumes that these are both CN_Tbl_Idx */

         /* create new constant for the right length and put the */
         /* original string in it. Truncate or blank pad to fit. */

         const_idx	= ntr_const_tbl(a_type_idx, TRUE, NULL);
         char_ptr	= (char *)&CN_CONST(const_idx);
         c_char_ptr	= (char *)&CN_CONST(OPND_IDX((*init_opnd)));

         for (i = 0; i < CN_INT_TO_C(TYP_IDX(a_type_idx)); i++) {
            char_ptr[i] = (i >= CN_INT_TO_C(TYP_IDX(c_type_idx))) ?
                          ' ' : c_char_ptr[i];
         }

         while (i % TARGET_CHARS_PER_WORD != 0) {
            char_ptr[i] = ' ';
            i++;
         }

         OPND_IDX((*init_opnd)) = const_idx;
      }

      /* If this is default initialization, the substring reference will */
      /* need to be generated when something is actually initialized.    */

      if (ATD_CLASS(attr_idx) != Struct_Component) {
         COPY_OPND(tar_opnd, IR_OPND_L(ir_idx));

         if (gen_whole_substring(&tar_opnd, 0)) {
            COPY_OPND(IR_OPND_L(ir_idx), tar_opnd);
         }
      }
   }
   else if (TYP_TYPE(c_type_idx) == Character ||
            TYP_TYPE(c_type_idx) == Typeless) {

      /* cast the character or typeless constant to the target type */

      OPND_IDX((*init_opnd)) = cast_typeless_constant(OPND_IDX((*init_opnd)),
                                                      a_type_idx,
                                                      opnd_line,
                                                      opnd_column);
   }
   else if (TYP_TYPE(c_type_idx) != Character  &&
            TYP_TYPE(c_type_idx) != Typeless   &&
            TYP_LINEAR(c_type_idx) != TYP_LINEAR(a_type_idx)) {

      /* PDGCS does not like it if the value is not the same size as the   */
      /* target; for example, the value is a double precision constant and */
      /* the target is a single precision variable.  So explicitly convert */
      /* the value to the type and kind type parameter of the target for   */
      /* all combinations to be consistent.                                */

      if (folder_driver( (char *) &CN_CONST(OPND_IDX((*init_opnd))),
                         c_type_idx,
                         NULL,
                         NULL_IDX,
                         another_constant,
                        &a_type_idx,
                         opnd_line,
                         opnd_column,
                         1,
                         Cvrt_Opr)) {

         OPND_IDX((*init_opnd)) = ntr_const_tbl(ATD_TYPE_IDX(attr_idx),
                                                FALSE,
                                                another_constant);
      }
   }

EXIT:

   TRACE (Func_Exit, "const_init_semantics", NULL);

   return(ok);

}  /* const_init_semantics */
Exemplo n.º 5
0
/******************************************************************************\
|*									      *|
|* Description:								      *|
|*	Do semantics for type declaration initializations.                    *|
|*									      *|
|* Input parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Output parameters:							      *|
|*	NONE								      *|
|*									      *|
|* Returns:								      *|
|*	NOTHING								      *|
|*									      *|
\******************************************************************************/
void default_init_semantics(int	attr_idx)
{

   int			column;
   expr_arg_type	expr_desc;
   opnd_type		init_opnd;
   int			line;
   int			next_sh_idx;
   boolean		null_init;
   int			old_curr_stmt_sh_idx;
   opnd_type		opnd;
   int			sh_idx;
   int			type_idx;
   int			type_init_sh_idx;


   TRACE (Func_Entry, "default_init_semantics", NULL);

# ifdef _DEBUG
   if (ATD_CPNT_INIT_IDX(attr_idx) == NULL_IDX ||
       ATD_FLD(attr_idx) != IR_Tbl_Idx ||
       (IR_OPR(ATD_CPNT_INIT_IDX(attr_idx)) != Init_Opr &&
        IR_OPR(ATD_CPNT_INIT_IDX(attr_idx)) != Null_Opr)) {

      PRINTMSG(AT_DEF_LINE(attr_idx), 626, Internal,
               AT_DEF_COLUMN(attr_idx),
               "Init_Opr or Null_Opr", "default_init_semantics");
   }
# endif

   /* Generate a type init statement so that expression semantics gets */
   /* anything it generates in the correct order.  This statement will */
   /* be removed.                                                      */

   old_curr_stmt_sh_idx	= curr_stmt_sh_idx;

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

   type_init_sh_idx	= curr_stmt_sh_idx;
   target_array_idx	= ATD_ARRAY_IDX(attr_idx);
   type_idx		= ATD_TYPE_IDX(attr_idx);
   null_init		= FALSE;

   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;
   expr_desc.rank	= 0;

   COPY_OPND(init_opnd, IR_OPND_R(ATD_CPNT_INIT_IDX(attr_idx)));

   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))) {
         find_opnd_line_and_column(&init_opnd, &line, &column);
         PRINTMSG(line, 1559, Error, column, AT_OBJ_NAME_PTR(attr_idx));
         AT_DCL_ERR(attr_idx)		= TRUE;
         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) {

            /* Pointer components are null'd by default, so we  */
            /* do not need to keep the null information around. */

            null_init	= TRUE;
            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, &line, &column);
	    PRINTMSG(line, 1680, Error, column, AT_OBJ_NAME_PTR(attr_idx));
	    AT_DCL_ERR(attr_idx)	= TRUE;
	    goto EXIT;
	 }
#endif /* KEY Bug 6845 */

         find_opnd_line_and_column(&init_opnd, &line, &column);
         PRINTMSG(line, 842, Error, column);
         AT_DCL_ERR(attr_idx)	= TRUE;
      }

      /* The assumption is that if this is IR, we will    */
      /* never end up with a CN_Tbl_Idx on the left side. */

      if (OPND_FLD(init_opnd) == CN_Tbl_Idx) {

         if (!const_init_semantics(&init_opnd,
                                    attr_idx,
                                    ATD_CPNT_INIT_IDX(attr_idx))) {
            AT_DCL_ERR(attr_idx) = TRUE;
         }
      }
      else {
         COPY_OPND(opnd, init_opnd);

         while (OPND_FLD(opnd) == IR_Tbl_Idx && OPND_IDX(opnd) != NULL_IDX) {
           COPY_OPND(opnd, IR_OPND_L(OPND_IDX(opnd)));
         }

         if (OPND_FLD(opnd) == AT_Tbl_Idx) {

            if (!attr_init_semantics(&opnd,
                                     attr_idx, 
                                     ATD_CPNT_INIT_IDX(attr_idx),
                                    &expr_desc)) {
               AT_DCL_ERR(attr_idx) = TRUE;
            }
         }
         else {
            PRINTMSG(AT_DEF_LINE(attr_idx), 626, Internal,
                     AT_DEF_COLUMN(attr_idx), 
                     "AT_Tbl_Idx",
                     "default_init_semantics");
         }
      }
   }
   else {  /* The initialization expression has an error */
      AT_DCL_ERR(attr_idx) = TRUE;
   }

EXIT:

   expr_mode			= Regular_Expr;
   check_type_conversion	= FALSE;
   target_array_idx		= NULL_IDX;
   sh_idx			= SH_NEXT_IDX(old_curr_stmt_sh_idx);

   if (old_curr_stmt_sh_idx != NULL_IDX) {
      SH_NEXT_IDX(old_curr_stmt_sh_idx) = SH_NEXT_IDX(type_init_sh_idx);
   }

   if (SH_NEXT_IDX(type_init_sh_idx) != NULL_IDX) {
      SH_PREV_IDX(SH_NEXT_IDX(type_init_sh_idx)) = old_curr_stmt_sh_idx;
   }

   curr_stmt_sh_idx = old_curr_stmt_sh_idx;

   while (sh_idx != type_init_sh_idx) {
      next_sh_idx	= SH_NEXT_IDX(sh_idx);
      FREE_SH_NODE(sh_idx);
      sh_idx		= next_sh_idx;
      
   }

   FREE_SH_NODE(type_init_sh_idx);

   if (AT_DCL_ERR(attr_idx) || null_init) {
      ATD_CPNT_INIT_IDX(attr_idx) = NULL_IDX;
      ATD_FLD(attr_idx)		  = NO_Tbl_Idx;
   }
   else {
      ATD_CPNT_INIT_IDX(attr_idx) = OPND_IDX(init_opnd);
      ATD_FLD(attr_idx)		  = OPND_FLD(init_opnd);
   }

   TRACE (Func_Exit, "default_init_semantics", NULL);

   return;

}  /* default_init_semantics */