stc.c

gcc-2.95.3 Linux下最常用的C编译器

	}
    }

  ffestc_local_.decl.kind_type = kt;

  /* Now check length specification for CHARACTER data type. */

  if (((len == NULL) && (lent == NULL))
      || (bt != FFEINFO_basictypeCHARACTER))
    val = ffestc_local_.decl.stmt_size;
  else
    {
      if (len == NULL)
	{
	  assert (ffelex_token_type (lent) == FFELEX_typeNUMBER);
	  val = atol (ffelex_token_text (lent));
	}
      else if (ffebld_op (len) == FFEBLD_opSTAR)
	val = FFETARGET_charactersizeNONE;
      else if (ffebld_op (len) == FFEBLD_opANY)
	val = FFETARGET_charactersizeNONE;
      else
	{
	  assert (ffebld_op (len) == FFEBLD_opCONTER);
	  assert (ffeinfo_basictype (ffebld_info (len))
		  == FFEINFO_basictypeINTEGER);
	  assert (ffeinfo_kindtype (ffebld_info (len))
		  == FFEINFO_kindtypeINTEGERDEFAULT);
	  val = ffebld_constant_integerdefault (ffebld_conter (len));
	}
    }

  if ((val == 0) && !(0 && ffe_is_90 ()))
    {
      val = 1;
      ffebad_start (FFEBAD_ZERO_SIZE);
      ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent));
      ffebad_finish ();
    }
  ffestc_local_.decl.size = val;
}

/* ffestc_establish_declstmt_ -- Establish host-specific type/params info

   ffestc_establish_declstmt_(type,type_token,kind,kind_token,len,
	 len_token);  */

static void
ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet, ffebld kind,
			    ffelexToken kindt, ffebld len, ffelexToken lent)
{
  ffeinfoBasictype bt;
  ffeinfoKindtype ktd;		/* Default kindtype. */
  ffeinfoKindtype kt;
  ffetargetCharacterSize val;
  bool per_var_kind_ok = TRUE;

  /* Determine basictype and default kindtype. */

  switch (type)
    {
    case FFESTP_typeINTEGER:
      bt = FFEINFO_basictypeINTEGER;
      ktd = FFEINFO_kindtypeINTEGERDEFAULT;
      break;

    case FFESTP_typeBYTE:
      bt = FFEINFO_basictypeINTEGER;
      ktd = FFEINFO_kindtypeINTEGER2;
      break;

    case FFESTP_typeWORD:
      bt = FFEINFO_basictypeINTEGER;
      ktd = FFEINFO_kindtypeINTEGER3;
      break;

    case FFESTP_typeREAL:
      bt = FFEINFO_basictypeREAL;
      ktd = FFEINFO_kindtypeREALDEFAULT;
      break;

    case FFESTP_typeCOMPLEX:
      bt = FFEINFO_basictypeCOMPLEX;
      ktd = FFEINFO_kindtypeREALDEFAULT;
      break;

    case FFESTP_typeLOGICAL:
      bt = FFEINFO_basictypeLOGICAL;
      ktd = FFEINFO_kindtypeLOGICALDEFAULT;
      break;

    case FFESTP_typeCHARACTER:
      bt = FFEINFO_basictypeCHARACTER;
      ktd = FFEINFO_kindtypeCHARACTERDEFAULT;
      break;

    case FFESTP_typeDBLPRCSN:
      bt = FFEINFO_basictypeREAL;
      ktd = FFEINFO_kindtypeREALDOUBLE;
      per_var_kind_ok = FALSE;
      break;

    case FFESTP_typeDBLCMPLX:
      bt = FFEINFO_basictypeCOMPLEX;
#if FFETARGET_okCOMPLEX2
      ktd = FFEINFO_kindtypeREALDOUBLE;
#else
      ktd = FFEINFO_kindtypeREALDEFAULT;
      ffebad_start (FFEBAD_BAD_DBLCMPLX);
      ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
		   ffelex_token_where_column (ffesta_tokens[0]));
      ffebad_finish ();
#endif
      per_var_kind_ok = FALSE;
      break;

    default:
      assert ("Unexpected type (F90 TYPE?)!" == NULL);
      bt = FFEINFO_basictypeNONE;
      ktd = FFEINFO_kindtypeNONE;
      break;
    }

  if (kindt == NULL)
    kt = ktd;
  else
    {				/* Not necessarily default kind type. */
      if (kind == NULL)
	{			/* Shouldn't happen for CHARACTER. */
	  assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER);
	  val = atol (ffelex_token_text (kindt));
	  kt = ffestc_kindtype_star_ (bt, val);
	}
      else if (ffebld_op (kind) == FFEBLD_opANY)
	kt = ktd;
      else
	{
	  assert (ffebld_op (kind) == FFEBLD_opCONTER);
	  assert (ffeinfo_basictype (ffebld_info (kind))
		  == FFEINFO_basictypeINTEGER);
	  assert (ffeinfo_kindtype (ffebld_info (kind))
		  == FFEINFO_kindtypeINTEGERDEFAULT);
	  val = ffebld_constant_integerdefault (ffebld_conter (kind));
	  kt = ffestc_kindtype_kind_ (bt, val);
	}

      if (kt == FFEINFO_kindtypeNONE)
	{			/* Not valid kind type. */
	  ffebad_start (FFEBAD_KINDTYPE);
	  ffebad_here (0, ffelex_token_where_line (kindt),
		       ffelex_token_where_column (kindt));
	  ffebad_here (1, ffelex_token_where_line (typet),
		       ffelex_token_where_column (typet));
	  ffebad_finish ();
	  kt = ktd;
	}
    }

  ffestc_local_.decl.basic_type = bt;
  ffestc_local_.decl.stmt_kind_type = kt;
  ffestc_local_.decl.per_var_kind_ok = per_var_kind_ok;

  /* Now check length specification for CHARACTER data type. */

  if (((len == NULL) && (lent == NULL))
      || (type != FFESTP_typeCHARACTER))
    val = (type == FFESTP_typeCHARACTER) ? 1 : FFETARGET_charactersizeNONE;
  else
    {
      if (len == NULL)
	{
	  assert (ffelex_token_type (lent) == FFELEX_typeNUMBER);
	  val = atol (ffelex_token_text (lent));
	}
      else if (ffebld_op (len) == FFEBLD_opSTAR)
	val = FFETARGET_charactersizeNONE;
      else if (ffebld_op (len) == FFEBLD_opANY)
	val = FFETARGET_charactersizeNONE;
      else
	{
	  assert (ffebld_op (len) == FFEBLD_opCONTER);
	  assert (ffeinfo_basictype (ffebld_info (len))
		  == FFEINFO_basictypeINTEGER);
	  assert (ffeinfo_kindtype (ffebld_info (len))
		  == FFEINFO_kindtypeINTEGERDEFAULT);
	  val = ffebld_constant_integerdefault (ffebld_conter (len));
	}
    }

  if ((val == 0) && !(0 && ffe_is_90 ()))
    {
      val = 1;
      ffebad_start (FFEBAD_ZERO_SIZE);
      ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent));
      ffebad_finish ();
    }
  ffestc_local_.decl.stmt_size = val;
}

/* ffestc_establish_impletter_ -- Establish type/params for IMPLICIT letter(s)

   ffestc_establish_impletter_(first_letter_token,last_letter_token);  */

static void
ffestc_establish_impletter_ (ffelexToken first, ffelexToken last)
{
  bool ok = FALSE;		/* Stays FALSE if first letter > last. */
  char c;

  if (last == NULL)
    ok = ffeimplic_establish_initial (c = *(ffelex_token_text (first)),
				      ffestc_local_.decl.basic_type,
				      ffestc_local_.decl.kind_type,
				      ffestc_local_.decl.size);
  else
    {
      for (c = *(ffelex_token_text (first));
	   c <= *(ffelex_token_text (last));
	   c++)
	{
	  ok = ffeimplic_establish_initial (c,
					    ffestc_local_.decl.basic_type,
					    ffestc_local_.decl.kind_type,
					    ffestc_local_.decl.size);
	  if (!ok)
	    break;
	}
    }

  if (!ok)
    {
      char cs[2];

      cs[0] = c;
      cs[1] = '\0';

      ffebad_start (FFEBAD_BAD_IMPLICIT);
      ffebad_here (0, ffelex_token_where_line (first), ffelex_token_where_column (first));
      ffebad_string (cs);
      ffebad_finish ();
    }
}

/* ffestc_init_3 -- Initialize ffestc for new program unit

   ffestc_init_3();  */

void
ffestc_init_3 ()
{
  ffestv_save_state_ = FFESTV_savestateNONE;
  ffestc_entry_num_ = 0;
  ffestv_num_label_defines_ = 0;
}

/* ffestc_init_4 -- Initialize ffestc for new scoping unit

   ffestc_init_4();

   For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE-
   defs, and statement function defs.  */

void
ffestc_init_4 ()
{
  ffestc_saved_entry_num_ = ffestc_entry_num_;
  ffestc_entry_num_ = 0;
}

/* ffestc_kindtype_kind_ -- Determine kindtype from basictype and KIND= value

   ffeinfoKindtype kt;
   ffeinfoBasictype bt;
   ffetargetCharacterSize val;
   kt = ffestc_kindtype_kind_(bt,val);
   if (kt == FFEINFO_kindtypeNONE)
       // unsupported/invalid KIND= value for type  */

static ffeinfoKindtype
ffestc_kindtype_kind_ (ffeinfoBasictype bt, ffetargetCharacterSize val)
{
  ffetype type;
  ffetype base_type;
  ffeinfoKindtype kt;

  base_type = ffeinfo_type (bt, 1);	/* ~~ */
  assert (base_type != NULL);

  type = ffetype_lookup_kind (base_type, (int) val);
  if (type == NULL)
    return FFEINFO_kindtypeNONE;

  for (kt = 1; kt < FFEINFO_kindtype; ++kt)
    if (ffeinfo_type (bt, kt) == type)
      return kt;

  return FFEINFO_kindtypeNONE;
}

/* ffestc_kindtype_star_ -- Determine kindtype from basictype and * value

   ffeinfoKindtype kt;
   ffeinfoBasictype bt;
   ffetargetCharacterSize val;
   kt = ffestc_kindtype_star_(bt,val);
   if (kt == FFEINFO_kindtypeNONE)
       // unsupported/invalid * value for type	*/

static ffeinfoKindtype
ffestc_kindtype_star_ (ffeinfoBasictype bt, ffetargetCharacterSize val)
{
  ffetype type;
  ffetype base_type;
  ffeinfoKindtype kt;

  base_type = ffeinfo_type (bt, 1);	/* ~~ */
  assert (base_type != NULL);

  type = ffetype_lookup_star (base_type, (int) val);
  if (type == NULL)
    return FFEINFO_kindtypeNONE;

  for (kt = 1; kt < FFEINFO_kindtype; ++kt)
    if (ffeinfo_type (bt, kt) == type)
      return kt;

  return FFEINFO_kindtypeNONE;
}

/* Define label as usable for anything without complaint.  */

static void
ffestc_labeldef_any_ ()
{
  if ((ffesta_label_token == NULL)
      || !ffestc_labeldef_begin_ ())
    return;

  ffelab_set_type (ffestc_label_, FFELAB_typeANY);
  ffestd_labeldef_any (ffestc_label_);

  ffestc_labeldef_branch_end_ ();
}

/* ffestc_labeldef_begin_ -- Define label as unknown, initially

   ffestc_labeldef_begin_();  */

static bool
ffestc_labeldef_begin_ ()
{
  ffelabValue label_value;
  ffelab label;

  label_value = (ffelabValue) atol (ffelex_token_text (ffesta_label_token));
  if ((label_value == 0) || (label_value > FFELAB_valueMAX))
    {
      ffebad_start (FFEBAD_LABEL_NUMBER_INVALID);
      ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
		   ffelex_token_where_column (ffesta_label_token));
      ffebad_finish ();
    }

  label = ffelab_find (label_value);
  if (label == NULL)
    {
      label = ffestc_label_ = ffelab_new (label_value);
      ffestv_num_label_defines_++;
      ffelab_set_definition_line (label,
	  ffewhere_line_use (ffelex_token_where_line (ffesta_label_token)));
      ffelab_set_definition_column (label,
      ffewhere_column_use (ffelex_token_where_column (ffesta_label_token)));

      return TRUE;
    }

  if (ffewhere_line_is_unknown (ffelab_definition_line (label)))
    {
      ffestv_num_label_defines_++;
      ffestc_label_ = label;
      ffelab_set_definition_line (label,
	  ffewhere_line_use (ffelex_token_where_line (ffesta_label_token)));
      ffelab_set_definition_column (label,
      ffewhere_column_use (ffelex_token_where_column (ffesta_label_token)));

      return TRUE;
    }

  ffebad_start (FFEBAD_LABEL_ALREADY_DEFINED);
  ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
	       ffelex_token_where_column (ffesta_label_token));
  ffebad_here (1, ffelab_definition_line (label),
	       ffelab_definition_column (label));
  ffebad_string (ffelex_token_text (ffesta_label_token));
  ffebad_finish ();

  ffelex_token_kill (ffesta_label_token);
  ffesta_label_token = NULL;
  return FALSE;
}

/* ffestc_labeldef_branch_begin_ -- Define label as a branch target one

   ffestc_labeldef_branch_begin_();  */

static void
ffestc_labeldef_branch_begin_ ()
{
  if ((ffesta_label_token == NULL)
      || (ffestc_shriek_after1_ != NULL)
      || !ffestc_labeldef_begin_ ())
    return;

  switch (ffelab_type (ffestc_label_))
    {
    case FFELAB_typeUNKNOWN:
    case FFELAB_typeASSIGNABLE:
      ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP);
      ffelab_set_blocknum (ffestc_label_,
			   ffestw_blocknum (ffestw_stack_top ()));
      ffestd_labeldef_branch (ffestc_label_);
      break;

    case FFELAB_typeNOTLOOP:
      if (ffelab_blocknum (ffestc_label_)
	  < ffestw_blocknum (ffestw_stack_top ()))
	{
	  ffebad_start (FFEBAD_LABEL_BLOCK);
	  ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
		       ffelex_token_where_column (ffesta_label_token));
	  ffebad_here (1, ffelab_firstref_line (ffestc_label_),
		       ffelab_firstref_column (ffestc_label_));
	  ffebad_finish ();
	}
      ffelab_set_blocknum (ffestc_label_,
			   ffestw_blocknum (ffestw_stack_top ()));
      ffestd_labeldef_branch (ffestc_label_);
      break;

    case FFELAB_typeLOOPEND:
      if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO)
	  || (ffestw_label (ffestw_stack_top ()) != ffestc_label_))
	{			/* Unterminated block. */