intrin.c

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

	  if (optional == '*')
	    continue;	/* Go ahead and try another arg. */
	  if (required == '\0')
	    break;
	  if ((required == 'n')
	      || (required == '+'))
	    {
	      optional = '*';
	      required = '\0';
	    }
	  else if (required == 'p')
	    required = 'n';
	} while (TRUE);
    }

  if (arg != NULL)
    return FFEBAD_INTRINSIC_TOOMANY;

  /* Set up the initial type for the return value of the function.  */

  need_col = FALSE;
  switch (c[0])
    {
    case 'A':
      bt = FFEINFO_basictypeCHARACTER;
      sz = (c[2] == '*') ? FFETARGET_charactersizeNONE : 1;
      break;

    case 'C':
      bt = FFEINFO_basictypeCOMPLEX;
      break;

    case 'I':
      bt = FFEINFO_basictypeINTEGER;
      break;

    case 'L':
      bt = FFEINFO_basictypeLOGICAL;
      break;

    case 'R':
      bt = FFEINFO_basictypeREAL;
      break;

    case 'B':
    case 'F':
    case 'N':
    case 'S':
      need_col = TRUE;
      /* Fall through.  */
    case '-':
    default:
      bt = FFEINFO_basictypeNONE;
      break;
    }

  switch (c[1])
    {
    case '1': case '2': case '3': case '4': case '5':
    case '6': case '7': case '8': case '9':
      kt = (c[1] - '0');
      if ((bt == FFEINFO_basictypeINTEGER)
	  || (bt == FFEINFO_basictypeLOGICAL))
	{
	  switch (kt)
	    {	/* Translate to internal kinds for now! */
	    default:
	      break;

	    case 2:
	      kt = 4;
	      break;

	    case 3:
	      kt = 2;
	      break;

	    case 4:
	      kt = 5;
	      break;

	    case 6:
	      kt = 3;
	      break;

	    case 7:
	      kt = ffecom_pointer_kind ();
	      break;
	    }
	}
      break;

    case 'C':
      if (ffe_is_90 ())
	need_col = TRUE;
      kt = 1;
      break;

    case '=':
      need_col = TRUE;
      /* Fall through.  */
    case '-':
    default:
      kt = FFEINFO_kindtypeNONE;
      break;
    }

  /* Determine collective type of COL, if there is one.  */

  if (need_col || c[colon + 1] != '-')
    {
      bool okay = TRUE;
      bool have_anynum = FALSE;

      for (arg = args;
	   arg != NULL;
	   arg = (c[colon + 1] == '*') ? ffebld_trail (arg) : NULL)
	{
	  ffebld a = ffebld_head (arg);
	  ffeinfo i;
	  bool anynum;

	  if (a == NULL)
	    continue;
	  i = ffebld_info (a);

	  anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
	    || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);
	  if (anynum)
	    {
	      have_anynum = TRUE;
	      continue;
	    }

	  if ((col_bt == FFEINFO_basictypeNONE)
	      && (col_kt == FFEINFO_kindtypeNONE))
	    {
	      col_bt = ffeinfo_basictype (i);
	      col_kt = ffeinfo_kindtype (i);
	    }
	  else
	    {
	      ffeexpr_type_combine (&col_bt, &col_kt,
				    col_bt, col_kt,
				    ffeinfo_basictype (i),
				    ffeinfo_kindtype (i),
				    NULL);
	      if ((col_bt == FFEINFO_basictypeNONE)
		  || (col_kt == FFEINFO_kindtypeNONE))
		return FFEBAD_INTRINSIC_REF;
	    }
	}

      if (have_anynum
	  && ((col_bt == FFEINFO_basictypeNONE)
	      || (col_kt == FFEINFO_kindtypeNONE)))
	{
	  /* No type, but have hollerith/typeless.  Use type of return
	     value to determine type of COL.  */

	  switch (c[0])
	    {
	    case 'A':
	      return FFEBAD_INTRINSIC_REF;

	    case 'B':
	    case 'I':
	    case 'L':
	      if ((col_bt != FFEINFO_basictypeNONE)
		  && (col_bt != FFEINFO_basictypeINTEGER))
		return FFEBAD_INTRINSIC_REF;
	      /* Fall through.  */
	    case 'N':
	    case 'S':
	    case '-':
	    default:
	      col_bt = FFEINFO_basictypeINTEGER;
	      col_kt = FFEINFO_kindtypeINTEGER1;
	      break;

	    case 'C':
	      if ((col_bt != FFEINFO_basictypeNONE)
		  && (col_bt != FFEINFO_basictypeCOMPLEX))
		return FFEBAD_INTRINSIC_REF;
	      col_bt = FFEINFO_basictypeCOMPLEX;
	      col_kt = FFEINFO_kindtypeREAL1;
	      break;

	    case 'R':
	      if ((col_bt != FFEINFO_basictypeNONE)
		  && (col_bt != FFEINFO_basictypeREAL))
		return FFEBAD_INTRINSIC_REF;
	      /* Fall through.  */
	    case 'F':
	      col_bt = FFEINFO_basictypeREAL;
	      col_kt = FFEINFO_kindtypeREAL1;
	      break;
	    }
	}

      switch (c[0])
	{
	case 'B':
	  okay = (col_bt == FFEINFO_basictypeINTEGER)
	    || (col_bt == FFEINFO_basictypeLOGICAL);
	  if (need_col)
	    bt = col_bt;
	  break;

	case 'F':
	  okay = (col_bt == FFEINFO_basictypeCOMPLEX)
	    || (col_bt == FFEINFO_basictypeREAL);
	  if (need_col)
	    bt = col_bt;
	  break;

	case 'N':
	  okay = (col_bt == FFEINFO_basictypeCOMPLEX)
	    || (col_bt == FFEINFO_basictypeINTEGER)
	    || (col_bt == FFEINFO_basictypeREAL);
	  if (need_col)
	    bt = col_bt;
	  break;

	case 'S':
	  okay = (col_bt == FFEINFO_basictypeINTEGER)
	    || (col_bt == FFEINFO_basictypeREAL)
	    || (col_bt == FFEINFO_basictypeCOMPLEX);
	  if (need_col)
	    bt = ((col_bt != FFEINFO_basictypeCOMPLEX) ? col_bt
		  : FFEINFO_basictypeREAL);
	  break;
	}

      switch (c[1])
	{
	case '=':
	  if (need_col)
	    kt = col_kt;
	  break;

	case 'C':
	  if (col_bt == FFEINFO_basictypeCOMPLEX)
	    {
	      if (col_kt != FFEINFO_kindtypeREALDEFAULT)
		*check_intrin = TRUE;
	      if (need_col)
		kt = col_kt;
	    }
	  break;
	}

      if (!okay)
	return FFEBAD_INTRINSIC_REF;
    }

  /* Now, convert args in the arglist to the final type of the COL.  */

  for (argno = 0, argc = &c[colon + 3],
	 arg = args;
       *argc != '\0';
       ++argno)
    {
      char optional = '\0';
      char required = '\0';
      char extra = '\0';
      char basic;
      char kind;
      int length;
      int elements;
      bool lastarg_complex = FALSE;

      /* We don't do anything with keywords yet.  */
      do
	{
	} while (*(++argc) != '=');

      ++argc;
      if ((*argc == '?')
	  || (*argc == '!')
	  || (*argc == '*'))
	optional = *(argc++);
      if ((*argc == '+')
	  || (*argc == 'n')
	  || (*argc == 'p'))
	required = *(argc++);
      basic = *(argc++);
      kind = *(argc++);
      if (*argc == '[')
	{
	  length = *++argc - '0';
	  if (*++argc != ']')
	    length = 10 * length + (*(argc++) - '0');
	  ++argc;
	}
      else
	length = -1;
      if (*argc == '(')
	{
	  elements = *++argc - '0';
	  if (*++argc != ')')
	    elements = 10 * elements + (*(argc++) - '0');
	  ++argc;
	}
      else if (*argc == '&')
	{
	  elements = -1;
	  ++argc;
	}
      else
	elements = 0;
      if ((*argc == '&')
	  || (*argc == 'i')
	  || (*argc == 'w')
	  || (*argc == 'x'))
	extra = *(argc++);
      if (*argc == ',')
	++argc;

      /* Break out of this loop only when current arg spec completely
	 processed.  */

      do
	{
	  bool okay;
	  ffebld a;
	  ffeinfo i;
	  bool anynum;
	  ffeinfoBasictype abt = FFEINFO_basictypeNONE;
	  ffeinfoKindtype akt = FFEINFO_kindtypeNONE;

	  if ((arg == NULL)
	      || (ffebld_head (arg) == NULL))
	    {
	      if (arg != NULL)
		arg = ffebld_trail (arg);
	      break;	/* Try next argspec. */
	    }

	  a = ffebld_head (arg);
	  i = ffebld_info (a);
	  anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
	    || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);

	  /* Determine what the default type for anynum would be.  */

	  if (anynum)
	    {
	      switch (c[colon + 1])
		{
		case '-':
		  break;
		case '0': case '1': case '2': case '3': case '4':
		case '5': case '6': case '7': case '8': case '9':
		  if (argno != (c[colon + 1] - '0'))
		    break;
		case '*':
		  abt = col_bt;
		  akt = col_kt;
		  break;
		}
	    }

	  /* Again, match arg up to the spec.  We go through all of
	     this again to properly follow the contour of optional
	     arguments.  Probably this level of flexibility is not
	     needed, perhaps it's even downright naughty.  */

	  switch (basic)
	    {
	    case 'A':
	      okay = (ffeinfo_basictype (i) == FFEINFO_basictypeCHARACTER)
		&& ((length == -1)
		    || (ffeinfo_size (i) == (ffetargetCharacterSize) length));
	      break;

	    case 'C':
	      okay = anynum
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
	      abt = FFEINFO_basictypeCOMPLEX;
	      break;

	    case 'I':
	      okay = anynum
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER);
	      abt = FFEINFO_basictypeINTEGER;
	      break;

	    case 'L':
	      okay = anynum
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
	      abt = FFEINFO_basictypeLOGICAL;
	      break;

	    case 'R':
	      okay = anynum
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
	      abt = FFEINFO_basictypeREAL;
	      break;

	    case 'B':
	      okay = anynum
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
	      break;

	    case 'F':
	      okay = anynum
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
	      break;

	    case 'N':
	      okay = anynum
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
	      break;

	    case 'S':
	      okay = anynum
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
	      break;

	    case 'g':
	      okay = ((ffebld_op (a) == FFEBLD_opLABTER)
		      || (ffebld_op (a) == FFEBLD_opLABTOK));
	      elements = -1;
	      extra = '-';
	      break;

	    case 's':
	      okay = (((((ffeinfo_basictype (i) == FFEINFO_basictypeNONE)
			 && (ffeinfo_kindtype (i) == FFEINFO_kindtypeNONE)
			 && (ffeinfo_kind (i) == FFEINFO_kindSUBROUTINE))
			|| ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
			    && (ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGERDEFAULT)
			    && (ffeinfo_kind (i) == FFEINFO_kindFUNCTION))
			|| (ffeinfo_kind (i) == FFEINFO_kindNONE))
		       && ((ffeinfo_where (i) == FFEINFO_whereDUMMY)
			   || (ffeinfo_where (i) == FFEINFO_whereGLOBAL)))
		      || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
			  && (ffeinfo_kind (i) == FFEINFO_kindENTITY)));
	      elements = -1;
	      extra = '-';
	      break;

	    case '-':
	    default:
	      okay = TRUE;
	      break;
	    }

	  switch (kind)
	    {
	    case '1': case '2': case '3': case '4': case '5':
	    case '6': case '7': case '8': case '9':
	      akt = (kind - '0');
	      if ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
		  || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL))
		{
		  switch (akt)
		    {	/* Translate to internal kinds for now! */
		    default:
		      break;

		    case 2:
		      akt = 4;
		      break;

		    case 3:
		      akt = 2;
		      break;

		    case 4:
		      akt = 5;
		      break;

		    case 6:
		      akt = 3;
		      break;

		    case 7:
		      akt = ffecom_pointer_kind ();
		      break;
		    }
		}
	      okay &= anynum || (ffeinfo_kindtype (i) == akt);
	      break;

	    case 'A':
	      okay &= anynum || (ffeinfo_kindtype (i) == firstarg_kt);
	      akt = (firstarg_kt == FFEINFO_kindtype) ? FFEINFO_kindtypeNONE
		: firstarg_kt;
	      break;

	    case '*':
	    default:
	      break;
	    }

	  switch (elements)
	    {
	      ffebld b;

	    case -1:
	      break;

	    case 0:
	      if (ffeinfo_rank (i) != 0)
		okay = FALSE;
	      break;

	    default:
	      if ((ffeinfo_rank (i) != 1)
		  || (ffebld_op (a) != FFEBLD_opSYMTER)
		  || ((b = ffesymbol_arraysize (ffebld_symter (a))) == NULL)
		  || (ffebld_op (b) != FFEBLD_opCONTER)
		  || (ffeinfo_basictype (ffebld_info (b)) != FFEINFO_basictypeINTEGER)
		  || (ffeinfo_kindtype (ffebld_info (b)) != FFEINFO_kindtypeINTEGERDEFAULT)
		  || (ffebld_constant_integer1 (ffebld_conter (b)) != elements))