intdoc.c

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

      if ((*argc == '&')
	  || (*argc == 'i')
	  || (*argc == 'w')
	  || (*argc == 'x'))
	extra = *(argc++);
      if (*argc == ',')
	++argc;

      switch (basic)
	{
	case '-':
	  switch (kind)
	    {
	    case '*':
	      printf ("Any type");
	      break;

	    default:
	      assert ("kind arg" == NULL);
	      break;
	    }
	  break;

	case 'A':
	  assert ((kind == '1') || (kind == '*'));
	  printf ("@code{CHARACTER");
	  if (length != -1)
	    printf ("*%d", length);
	  printf ("}");
	  break;

	case 'C':
	  switch (kind)
	    {
	    case '*':
	      printf ("@code{COMPLEX}");
	      break;

	    case '1': case '2': case '3': case '4': case '5':
	    case '6': case '7': case '8': case '9':
	      printf ("@code{COMPLEX(KIND=%d)}", (kind - '0'));
	      break;

	    case 'A':
	      printf ("Same @samp{KIND=} value as for @var{%s}",
		      argument_name_string (imp, 0));
	      break;

	    default:
	      assert ("Ca" == NULL);
	      break;
	    }
	  break;

	case 'I':
	  switch (kind)
	    {
	    case '*':
	      printf ("@code{INTEGER}");
	      break;

	    case '1': case '2': case '3': case '4': case '5':
	    case '6': case '7': case '8': case '9':
	      printf ("@code{INTEGER(KIND=%d)}", (kind - '0'));
	      break;

	    case 'A':
	      printf ("@code{INTEGER} with same @samp{KIND=} value as for @var{%s}",
		      argument_name_string (imp, 0));
	      break;

	    default:
	      assert ("Ia" == NULL);
	      break;
	    }
	  break;

	case 'L':
	  switch (kind)
	    {
	    case '*':
	      printf ("@code{LOGICAL}");
	      break;

	    case '1': case '2': case '3': case '4': case '5':
	    case '6': case '7': case '8': case '9':
	      printf ("@code{LOGICAL(KIND=%d)}", (kind - '0'));
	      break;

	    case 'A':
	      printf ("@code{LOGICAL} with same @samp{KIND=} value as for @var{%s}",
		      argument_name_string (imp, 0));
	      break;

	    default:
	      assert ("La" == NULL);
	      break;
	    }
	  break;

	case 'R':
	  switch (kind)
	    {
	    case '*':
	      printf ("@code{REAL}");
	      break;

	    case '1': case '2': case '3': case '4': case '5':
	    case '6': case '7': case '8': case '9':
	      printf ("@code{REAL(KIND=%d)}", (kind - '0'));
	      break;

	    case 'A':
	      printf ("@code{REAL} with same @samp{KIND=} value as for @var{%s}",
		      argument_name_string (imp, 0));
	      break;

	    default:
	      assert ("Ra" == NULL);
	      break;
	    }
	  break;

	case 'B':
	  switch (kind)
	    {
	    case '*':
	      printf ("@code{INTEGER} or @code{LOGICAL}");
	      break;

	    case '1': case '2': case '3': case '4': case '5':
	    case '6': case '7': case '8': case '9':
	      printf ("@code{INTEGER(KIND=%d)} or @code{LOGICAL(KIND=%d)}",
		      (kind - '0'), (kind - '0'));
	      break;

	    case 'A':
	      printf ("Same type and @samp{KIND=} value as for @var{%s}",
		      argument_name_string (imp, 0));
	      break;

	    default:
	      assert ("Ba" == NULL);
	      break;
	    }
	  break;

	case 'F':
	  switch (kind)
	    {
	    case '*':
	      printf ("@code{REAL} or @code{COMPLEX}");
	      break;

	    case '1': case '2': case '3': case '4': case '5':
	    case '6': case '7': case '8': case '9':
	      printf ("@code{REAL(KIND=%d)} or @code{COMPLEX(KIND=%d)}",
		      (kind - '0'), (kind - '0'));
	      break;

	    case 'A':
	      printf ("Same type as @var{%s}",
		      argument_name_string (imp, 0));
	      break;

	    default:
	      assert ("Fa" == NULL);
	      break;
	    }
	  break;

	case 'N':
	  switch (kind)
	    {
	    case '*':
	      printf ("@code{INTEGER}, @code{REAL}, or @code{COMPLEX}");
	      break;

	    case '1': case '2': case '3': case '4': case '5':
	    case '6': case '7': case '8': case '9':
	      printf ("@code{INTEGER(KIND=%d)}, @code{REAL(KIND=%d)}, or @code{COMPLEX(KIND=%d)}",
		      (kind - '0'), (kind - '0'), (kind - '0'));
	      break;

	    default:
	      assert ("N1" == NULL);
	      break;
	    }
	  break;

	case 'S':
	  switch (kind)
	    {
	    case '*':
	      printf ("@code{INTEGER} or @code{REAL}");
	      break;

	    case '1': case '2': case '3': case '4': case '5':
	    case '6': case '7': case '8': case '9':
	      printf ("@code{INTEGER(KIND=%d)} or @code{REAL(KIND=%d)}",
		      (kind - '0'), (kind - '0'));
	      break;

	    case 'A':
	      printf ("@code{INTEGER} or @code{REAL} with same @samp{KIND=} value as for @var{%s}",
		      argument_name_string (imp, 0));
	      break;

	    default:
	      assert ("Sa" == NULL);
	      break;
	    }
	  break;

	case 'g':
	  printf ("@samp{*@var{label}}, where @var{label} is the label\n\
of an executable statement");
	  break;

	case 's':
	  printf ("Signal handler (@code{INTEGER FUNCTION} or @code{SUBROUTINE})\n\
or dummy/global @code{INTEGER(KIND=1)} scalar");
	  break;

	default:
	  assert ("arg type?" == NULL);
	  break;
	}

      switch (optionality)
	{
	case '\0':
	  break;

	case '!':
	  printf ("; OPTIONAL (must be omitted if @var{%s} is @code{COMPLEX})",
		  argument_name_string (imp, argno-1));
	  break;

	case '?':
	  printf ("; OPTIONAL");
	  break;

	case '*':
	  printf ("; OPTIONAL");
	  break;

	case 'n':
	case '+':
	  break;

	case 'p':
	  printf ("; at least two such arguments must be provided");
	  break;

	default:
	  assert ("optionality!" == NULL);
	  break;
	}

      switch (elements)
	{
	case -1:
	  break;

	case 0:
	  if ((basic != 'g')
	      && (basic != 's'))
	    printf ("; scalar");
	  break;

	default:
	  assert (extra != '\0');
	  printf ("; DIMENSION(%d)", elements);
	  break;
	}

      switch (extra)
	{
	case '\0':
	  if ((basic != 'g')
	      && (basic != 's'))
	    printf ("; INTENT(IN)");
	  break;

	case 'i':
	  break;

	case '&':
	  printf ("; cannot be a constant or expression");
	  break;

	case 'w':
	  printf ("; INTENT(OUT)");
	  break;

	case 'x':
	  printf ("; INTENT(INOUT)");
	  break;
	}

      printf (".\n\n");
    }

  printf ("\
@noindent\n\
Intrinsic groups: ");
  switch (family)
    {
    case FFEINTRIN_familyF77:
      printf ("(standard FORTRAN 77).");
      break;

    case FFEINTRIN_familyGNU:
      printf ("@code{gnu}.");
      break;

    case FFEINTRIN_familyASC:
      printf ("@code{f2c}, @code{f90}.");
      break;

    case FFEINTRIN_familyMIL:
      printf ("@code{mil}, @code{f90}, @code{vxt}.");
      break;

    case FFEINTRIN_familyF90:
      printf ("@code{f90}.");
      break;

    case FFEINTRIN_familyVXT:
      printf ("@code{vxt}.");
      break;

    case FFEINTRIN_familyFVZ:
      printf ("@code{f2c}, @code{vxt}.");
      break;

    case FFEINTRIN_familyF2C:
      printf ("@code{f2c}.");
      break;

    case FFEINTRIN_familyF2U:
      printf ("@code{unix}.");
      break;

    case FFEINTRIN_familyBADU77:
      printf ("@code{badu77}.");
      break;

    default:
      assert ("bad family" == NULL);
      printf ("@code{???}.");
      break;
    }
  printf ("\n\n");

  if (descriptions[imp] != NULL)
    {
      const char *c = descriptions[imp];

      printf ("\
@noindent\n\
Description:\n\
\n");

      while (c[0] != '\0')
	{
	  if ((c[0] == '@')
	      && (c[1] >= '0')
	  && (c[1] <= '9'))
	    {
	      int argno = c[1] - '0';

	      c += 2;
	      while ((c[0] >= '0')
		     && (c[0] <= '9'))
		{
		  argno = 10 * argno + (c[0] - '0');
		  ++c;
		}
	      assert (c[0] == '@');
	      if (argno == 0)
		printf ("%s", name_uc);
	      else
		printf ("%s", argument_name_string (imp, argno - 1));
	    }
	  else
	    fputc (c[0], stdout);
	  ++c;
	}

      printf ("\n");
    }
}

static const char *
argument_info_ptr (ffeintrinImp imp, int argno)
{
  const char *c = imps[imp].control;
  static char arginfos[8][32];
  static int argx = 0;
  int i;

  if (c[2] == ':')
    c += 5;
  else
    c += 6;

  while (argno--)
    {
      while ((c[0] != ',') && (c[0] != '\0'))
	++c;
      if (c[0] != ',')
	break;
      ++c;
    }

  if (c[0] == '\0')
    return NULL;

  for (; (c[0] != '=') && (c[0] != '\0'); ++c)
    ;

  assert (c[0] == '=');

  for (i = 0, ++c; (c[0] != ',') && (c[0] != '\0'); ++c, ++i)
    arginfos[argx][i] = c[0];

  arginfos[argx][i] = '\0';

  c = &arginfos[argx][0];
  ++argx;
  if (((size_t) argx) >= ARRAY_SIZE (arginfos))
    argx = 0;

  return c;
}

static const char *
argument_info_string (ffeintrinImp imp, int argno)
{
  const char *p;

  p = argument_info_ptr (imp, argno);
  assert (p != NULL);
  return p;
}

static const char *
argument_name_ptr (ffeintrinImp imp, int argno)
{
  const char *c = imps[imp].control;
  static char argnames[8][32];
  static int argx = 0;
  int i;

  if (c[2] == ':')
    c += 5;
  else
    c += 6;

  while (argno--)
    {
      while ((c[0] != ',') && (c[0] != '\0'))
	++c;
      if (c[0] != ',')
	break;
      ++c;
    }

  if (c[0] == '\0')
    return NULL;

  for (i = 0; (c[0] != '=') && (c[0] != '\0'); ++c, ++i)
    argnames[argx][i] = c[0];

  assert (c[0] == '=');
  argnames[argx][i] = '\0';

  c = &argnames[argx][0];
  ++argx;
  if (((size_t) argx) >= ARRAY_SIZE (argnames))
    argx = 0;

  return c;
}

static const char *
argument_name_string (ffeintrinImp imp, int argno)
{
  const char *p;

  p = argument_name_ptr (imp, argno);
  assert (p != NULL);
  return p;
}

static void
print_type_string (const char *c)
{
  char basic = c[0];
  char kind = c[1];

  switch (basic)
    {
    case 'A':
      assert ((kind == '1') || (kind == '='));
      if (c[2] == ':')
	printf ("@code{CHARACTER*1}");
      else
	{
	  assert (c[2] == '*');
	  printf ("@code{CHARACTER*(*)}");
	}
      break;

    case 'C':
      switch (kind)
	{
	case '=':
	  printf ("@code{COMPLEX}");
	  break;

	case '1': case '2': case '3': case '4': case '5':
	case '6': case '7': case '8': case '9':
	  printf ("@code{COMPLEX(KIND=%d)}", (kind - '0'));
	  break;

	default:
	  assert ("Ca" == NULL);
	  break;
	}
      break;

    case 'I':
      switch (kind)
	{
	case '=':
	  printf ("@code{INTEGER}");
	  break;

	case '1': case '2': case '3': case '4': case '5':
	case '6': case '7': case '8': case '9':
	  printf ("@code{INTEGER(KIND=%d)}", (kind - '0'));
	  break;

	default:
	  assert ("Ia" == NULL);
	  break;
	}
      break;

    case 'L':
      switch (kind)
	{
	case '=':
	  printf ("@code{LOGICAL}");
	  break;

	case '1': case '2': case '3': case '4': case '5':
	case '6': case '7': case '8': case '9':
	  printf ("@code{LOGICAL(KIND=%d)}", (kind - '0'));
	  break;

	default:
	  assert ("La" == NULL);
	  break;
	}
      break;

    case 'R':
      switch (kind)
	{
	case '=':
	  printf ("@code{REAL}");
	  break;

	case '1': case '2': case '3': case '4': case '5':
	case '6': case '7': case '8': case '9':
	  printf ("@code{REAL(KIND=%d)}", (kind - '0'));
	  break;

	case 'C':
	  printf ("@code{REAL}");
	  break;

	default:
	  assert ("Ra" == NULL);
	  break;
	}
      break;

    case 'B':
      switch (kind)
	{
	case '=':
	  printf ("@code{INTEGER} or @code{LOGICAL}");
	  break;

	case '1': case '2': case '3': case '4': case '5':
	case '6': case '7': case '8': case '9':
	  printf ("@code{INTEGER(KIND=%d)} or @code{LOGICAL(KIND=%d)}",
		  (kind - '0'), (kind - '0'));
	  break;

	default:
	  assert ("Ba" == NULL);
	  break;
	}
      break;

    case 'F':
      switch (kind)
	{
	case '=':
	  printf ("@code{REAL} or @code{COMPLEX}");
	  break;

	case '1': case '2': case '3': case '4': case '5':
	case '6': case '7': case '8': case '9':
	  printf ("@code{REAL(KIND=%d)} or @code{COMPLEX(KIND=%d)}",
		  (kind - '0'), (kind - '0'));
	  break;

	default:
	  assert ("Fa" == NULL);
	  break;
	}
      break;

    case 'N':
      switch (kind)
	{
	case '=':
	  printf ("@code{INTEGER}, @code{REAL}, or @code{COMPLEX}");
	  break;

	case '1': case '2': case '3': case '4': case '5':
	case '6': case '7': case '8': case '9':
	  printf ("@code{INTEGER(KIND=%d)}, @code{REAL(KIND=%d)}, or @code{COMPLEX(KIND=%d)}",
		  (kind - '0'), (kind - '0'), (kind - '0'));
	  break;

	default:
	  assert ("N1" == NULL);
	  break;
	}
      break;

    case 'S':
      switch (kind)
	{
	case '=':
	  printf ("@code{INTEGER} or @code{REAL}");
	  break;

	case '1': case '2': case '3': case '4': case '5':
	case '6': case '7': case '8': case '9':
	  printf ("@code{INTEGER(KIND=%d)} or @code{REAL(KIND=%d)}",
		  (kind - '0'), (kind - '0'));
	  break;

	default:
	  assert ("Sa" == NULL);
	  break;
	}
      break;

    default:
      assert ("type?" == NULL);
      break;
    }
}