egcs projects compiler system

Exact copy of the snapshot, except for the removal of
	texinfo/
	gcc/ch/
	libchill/

1 files changed, 1347 insertions, 0 deletions

diff --git a/gnu/egcs/gcc/f/intdoc.c b/gnu/egcs/gcc/f/intdoc.c
new file mode 100644
index 00000000000..7e0a630489f
--- /dev/null
+++ b/gnu/egcs/gcc/f/intdoc.c
@@ -0,0 +1,1347 @@
+/* intdoc.c
+   Copyright (C) 1997 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Fortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.  */
+
+/* From f/proj.h, which uses #error -- not all C compilers
+   support that, and we want *this* program to be compilable
+   by pretty much any C compiler.  */
+#include "hconfig.j"
+#include "system.j"
+#include "assert.j"
+#if HAVE_STDDEF_H
+#include <stddef.h>
+#endif
+
+typedef enum
+  {
+#if !defined(false) || !defined(true)
+    false = 0, true = 1,
+#endif
+#if !defined(FALSE) || !defined(TRUE)
+    FALSE = 0, TRUE = 1,
+#endif
+    Doggone_Trailing_Comma_Dont_Work = 1
+  } bool;
+
+#define ARRAY_SIZE(a) (sizeof(a)/sizeof(a[0]))
+
+/* Pull in the intrinsics info, but only the doc parts.  */
+#define FFEINTRIN_DOC 1
+#include "intrin.h"
+
+const char *family_name (ffeintrinFamily family);
+static void dumpif (ffeintrinFamily fam);
+static void dumpendif (void);
+static void dumpclearif (void);
+static void dumpem (void);
+static void dumpgen (int menu, const char *name, const char *name_uc,
+		     ffeintrinGen gen);
+static void dumpspec (int menu, const char *name, const char *name_uc,
+		      ffeintrinSpec spec);
+static void dumpimp (int menu, const char *name, const char *name_uc, size_t genno, ffeintrinFamily family,
+		     ffeintrinImp imp, ffeintrinSpec spec);
+static const char *argument_info_ptr (ffeintrinImp imp, int argno);
+static const char *argument_info_string (ffeintrinImp imp, int argno);
+static const char *argument_name_ptr (ffeintrinImp imp, int argno);
+static const char *argument_name_string (ffeintrinImp imp, int argno);
+#if 0
+static const char *elaborate_if_complex (ffeintrinImp imp, int argno);
+static const char *elaborate_if_maybe_complex (ffeintrinImp imp, int argno);
+static const char *elaborate_if_real (ffeintrinImp imp, int argno);
+#endif
+static void print_type_string (const char *c);
+
+int
+main (int argc, char **argv ATTRIBUTE_UNUSED)
+{
+  if (argc != 1)
+    {
+      fprintf (stderr, "\
+Usage: intdoc > intdoc.texi\n\
+  Collects and dumps documentation on g77 intrinsics\n\
+  to the file named intdoc.texi.\n");
+      exit (1);
+    }
+
+  dumpem ();
+  return 0;
+}
+
+struct _ffeintrin_name_
+  {
+    const char *name_uc;
+    const char *name_lc;
+    const char *name_ic;
+    ffeintrinGen generic;
+    ffeintrinSpec specific;
+  };
+
+struct _ffeintrin_gen_
+  {
+    const char *name;		/* Name as seen in program. */
+    ffeintrinSpec specs[2];
+  };
+
+struct _ffeintrin_spec_
+  {
+    const char *name;		/* Uppercase name as seen in source code,
+				   lowercase if no source name, "none" if no
+				   name at all (NONE case). */
+    bool is_actualarg;		/* Ok to pass as actual arg if -pedantic. */
+    ffeintrinFamily family;
+    ffeintrinImp implementation;
+  };
+
+struct _ffeintrin_imp_
+  {
+    const char *name;			/* Name of implementation. */
+#if 0	/* FFECOM_targetCURRENT == FFECOM_targetGCC */
+    ffecomGfrt gfrt;		/* gfrt index in library. */
+#endif	/* FFECOM_targetCURRENT == FFECOM_targetGCC */
+    const char *control;
+  };
+
+static struct _ffeintrin_name_ names[] = {
+#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) \
+  { UPPER, LOWER, MIXED, FFEINTRIN_ ## GEN, FFEINTRIN_ ## SPEC },
+#define DEFGEN(CODE,NAME,SPEC1,SPEC2)
+#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
+#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
+#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
+#include "intrin.def"
+#undef DEFNAME
+#undef DEFGEN
+#undef DEFSPEC
+#undef DEFIMP
+#undef DEFIMPY
+};
+
+static struct _ffeintrin_gen_ gens[] = {
+#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
+#define DEFGEN(CODE,NAME,SPEC1,SPEC2) \
+  { NAME, { SPEC1, SPEC2, }, },
+#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
+#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
+#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
+#include "intrin.def"
+#undef DEFNAME
+#undef DEFGEN
+#undef DEFSPEC
+#undef DEFIMP
+#undef DEFIMPY
+};
+
+static struct _ffeintrin_imp_ imps[] = {
+#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
+#define DEFGEN(CODE,NAME,SPEC1,SPEC2)
+#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
+#if 0	/* FFECOM_targetCURRENT == FFECOM_targetGCC */
+#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
+  { NAME, FFECOM_gfrt ## GFRT, CONTROL },
+#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
+  { NAME, FFECOM_gfrt ## GFRT, CONTROL },
+#elif 1	/* FFECOM_targetCURRENT == FFECOM_targetFFE */
+#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
+  { NAME, CONTROL },
+#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
+  { NAME, CONTROL },
+#else
+#error
+#endif
+#include "intrin.def"
+#undef DEFNAME
+#undef DEFGEN
+#undef DEFSPEC
+#undef DEFIMP
+#undef DEFIMPY
+};
+
+static struct _ffeintrin_spec_ specs[] = {
+#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
+#define DEFGEN(CODE,NAME,SPEC1,SPEC2)
+#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) \
+  { NAME, CALLABLE, FAMILY, IMP, },
+#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
+#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
+#include "intrin.def"
+#undef DEFGEN
+#undef DEFSPEC
+#undef DEFIMP
+#undef DEFIMPY
+};
+
+struct cc_pair { ffeintrinImp imp; const char *text; };
+
+static const char *descriptions[FFEINTRIN_imp] = { 0 };
+static struct cc_pair cc_descriptions[] = {
+#define DEFDOC(IMP,SUMMARY,DESCRIPTION) { FFEINTRIN_imp ## IMP, DESCRIPTION },
+#include "intdoc.h0"
+#undef DEFDOC
+};
+
+static const char *summaries[FFEINTRIN_imp] = { 0 };
+static struct cc_pair cc_summaries[] = {
+#define DEFDOC(IMP,SUMMARY,DESCRIPTION) { FFEINTRIN_imp ## IMP, SUMMARY },
+#include "intdoc.h0"
+#undef DEFDOC
+};
+
+const char *
+family_name (ffeintrinFamily family)
+{
+  switch (family)
+    {
+    case FFEINTRIN_familyF77:
+      return "familyF77";
+
+    case FFEINTRIN_familyASC:
+      return "familyASC";
+
+    case FFEINTRIN_familyMIL:
+      return "familyMIL";
+
+    case FFEINTRIN_familyGNU:
+      return "familyGNU";
+
+    case FFEINTRIN_familyF90:
+      return "familyF90";
+
+    case FFEINTRIN_familyVXT:
+      return "familyVXT";
+
+    case FFEINTRIN_familyFVZ:
+      return "familyFVZ";
+
+    case FFEINTRIN_familyF2C:
+      return "familyF2C";
+
+    case FFEINTRIN_familyF2U:
+      return "familyF2U";
+
+    case FFEINTRIN_familyBADU77:
+      return "familyBADU77";
+
+    default:
+      assert ("bad family" == NULL);
+      return "??";
+    }
+}
+
+static int in_ifset = 0;
+static ffeintrinFamily latest_family = FFEINTRIN_familyNONE;
+
+static void
+dumpif (ffeintrinFamily fam)
+{
+  assert (fam != FFEINTRIN_familyNONE);
+  if ((in_ifset != 2)
+      || (fam != latest_family))
+    {
+      if (in_ifset == 2)
+	printf ("@end ifset\n");
+      latest_family = fam;
+      printf ("@ifset %s\n", family_name (fam));
+    }
+  in_ifset = 1;
+}
+
+static void
+dumpendif ()
+{
+  in_ifset = 2;
+}
+
+static void
+dumpclearif ()
+{
+  if ((in_ifset == 2)
+      || (latest_family != FFEINTRIN_familyNONE))
+    printf ("@end ifset\n");
+  latest_family = FFEINTRIN_familyNONE;
+  in_ifset = 0;
+}
+
+static void
+dumpem ()
+{
+  int i;
+
+  for (i = 0; ((size_t) i) < ARRAY_SIZE (cc_descriptions); ++i)
+    {
+      assert (descriptions[cc_descriptions[i].imp] == NULL);
+      descriptions[cc_descriptions[i].imp] = cc_descriptions[i].text;
+    }
+
+  for (i = 0; ((size_t) i) < ARRAY_SIZE (cc_summaries); ++i)
+    {
+      assert (summaries[cc_summaries[i].imp] == NULL);
+      summaries[cc_summaries[i].imp] = cc_summaries[i].text;
+    }
+
+  printf ("@c This file is automatically derived from intdoc.c, intdoc.in,\n");
+  printf ("@c ansify.c, intrin.def, and intrin.h.  Edit those files instead.\n");
+  printf ("@menu\n");
+  for (i = 0; ((size_t) i) < ARRAY_SIZE (names); ++i)
+    {
+      if (names[i].generic != FFEINTRIN_genNONE)
+	dumpgen (1, names[i].name_ic, names[i].name_uc,
+		 names[i].generic);
+      if (names[i].specific != FFEINTRIN_specNONE)
+	dumpspec (1, names[i].name_ic, names[i].name_uc,
+		  names[i].specific);
+    }
+  dumpclearif ();
+
+  printf ("@end menu\n\n");
+
+  for (i = 0; ((size_t) i) < ARRAY_SIZE (names); ++i)
+    {
+      if (names[i].generic != FFEINTRIN_genNONE)
+	dumpgen (0, names[i].name_ic, names[i].name_uc,
+		 names[i].generic);
+      if (names[i].specific != FFEINTRIN_specNONE)
+	dumpspec (0, names[i].name_ic, names[i].name_uc,
+		  names[i].specific);
+    }
+  dumpclearif ();
+}
+
+static void
+dumpgen (int menu, const char *name, const char *name_uc, ffeintrinGen gen)
+{
+  size_t i;
+  int total = 0;
+
+  if (!menu)
+    {
+      for (i = 0; i < ARRAY_SIZE (gens[gen].specs); ++i)
+	{
+	  if (gens[gen].specs[i] != FFEINTRIN_specNONE)
+	    ++total;
+	}
+    }
+
+  for (i = 0; i < ARRAY_SIZE (gens[gen].specs); ++i)
+    {
+      ffeintrinSpec spec;
+      size_t j;
+
+      if ((spec = gens[gen].specs[i]) == FFEINTRIN_specNONE)
+	continue;
+
+      dumpif (specs[spec].family);
+      dumpimp (menu, name, name_uc, i, specs[spec].family, specs[spec].implementation,
+	       spec);
+      if (!menu && (total > 0))
+	{
+	  if (total == 1)
+	    {
+	      printf ("\
+For information on another intrinsic with the same name:\n");
+	    }
+	  else
+	    {
+	      printf ("\
+For information on other intrinsics with the same name:\n");
+	    }
+	  for (j = 0; j < ARRAY_SIZE (gens[gen].specs); ++j)
+	    {
+	      if (j == i)
+		continue;
+	      if ((spec = gens[gen].specs[j]) == FFEINTRIN_specNONE)
+		continue;
+	      printf ("@xref{%s Intrinsic (%s)}.\n",
+		      name, specs[spec].name);
+	    }
+	  printf ("\n");
+	}
+      dumpendif ();
+    }
+}
+
+static void
+dumpspec (int menu, const char *name, const char *name_uc, ffeintrinSpec spec)
+{
+  dumpif (specs[spec].family);
+  dumpimp (menu, name, name_uc, 0, specs[spec].family, specs[spec].implementation,
+	   FFEINTRIN_specNONE);
+  dumpendif ();
+}
+
+static void
+dumpimp (int menu, const char *name, const char *name_uc, size_t genno,
+	 ffeintrinFamily family, ffeintrinImp imp, ffeintrinSpec spec)
+{
+  const char *c;
+  bool subr;
+  const char *argc;
+  const char *argi;
+  int colon;
+  int argno;
+
+  assert ((imp != FFEINTRIN_impNONE) || !genno);
+
+  if (menu)
+    {
+      printf ("* %s Intrinsic",
+	      name);
+      if (spec != FFEINTRIN_specNONE)
+	printf (" (%s)", specs[spec].name);	/* See XYZZY1 below */
+      printf ("::");
+#define INDENT_SUMMARY 24
+      if ((imp == FFEINTRIN_impNONE)
+	  || (summaries[imp] != NULL))
+	{
+	  int spaces = INDENT_SUMMARY - 14 - strlen (name);
+	  const char *c;
+
+	  if (spec != FFEINTRIN_specNONE)
+	    spaces -= (3 + strlen (specs[spec].name));	/* See XYZZY1 above */
+	  if (spaces < 1)
+	    spaces = 1;
+	  while (spaces--)
+	    fputc (' ', stdout);
+
+	  if (imp == FFEINTRIN_impNONE)
+	    {
+	      printf ("(Reserved for future use.)\n");
+	      return;
+	    }
+
+	  for (c = summaries[imp]; c[0] != '\0'; ++c)
+	    {
+	      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);
+		  else if (argno == 99)
+		    {	/* Yeah, this is a major kludge. */
+		      printf ("\n");
+		      spaces = INDENT_SUMMARY + 1;
+		      while (spaces--)
+			fputc (' ', stdout);
+		    }
+		  else
+		    printf ("%s", argument_name_string (imp, argno - 1));
+		}
+	      else
+		fputc (c[0], stdout);
+	    }
+	}
+      printf ("\n");
+      return;
+    }
+
+  printf ("@node %s Intrinsic", name);
+  if (spec != FFEINTRIN_specNONE)
+    printf (" (%s)", specs[spec].name);
+  printf ("\n@subsubsection %s Intrinsic", name);
+  if (spec != FFEINTRIN_specNONE)
+    printf (" (%s)", specs[spec].name);
+  printf ("\n@cindex %s intrinsic\n@cindex intrinsics, %s\n",
+	  name, name);
+
+  if (imp == FFEINTRIN_impNONE)
+    {
+      printf ("\n\
+This intrinsic is not yet implemented.\n\
+The name is, however, reserved as an intrinsic.\n\
+Use @samp{EXTERNAL %s} to use this name for an\n\
+external procedure.\n\
+\n\
+",
+	      name);
+      return;
+    }
+
+  c = imps[imp].control;
+  subr = (c[0] == '-');
+  colon = (c[2] == ':') ? 2 : 3;
+
+  printf ("\n\
+@noindent\n\
+@example\n\
+%s%s(",
+	  (subr ? "CALL " : ""), name);
+
+  fflush (stdout);
+
+  for (argno = 0; ; ++argno)
+    {
+      argc = argument_name_ptr (imp, argno);
+      if (argc == NULL)
+	break;
+      if (argno > 0)
+	printf (", ");
+      printf ("@var{%s}", argc);
+      argi = argument_info_string (imp, argno);
+      if ((argi[0] == '*')
+	  || (argi[0] == 'n')
+	  || (argi[0] == '+')
+	  || (argi[0] == 'p'))
+	printf ("-1, @var{%s}-2, @dots{}, @var{%s}-n",
+		argc, argc);
+    }
+
+  printf (")\n\
+@end example\n\
+\n\
+");
+
+  if (!subr)
+    {
+      int other_arg;
+      const char *arg_string;
+      const char *arg_info;
+
+      if ((c[colon + 1] >= '0')
+	  && (c[colon + 1] <= '9'))
+	{
+	  other_arg = c[colon + 1] - '0';
+	  arg_string = argument_name_string (imp, other_arg);
+	  arg_info = argument_info_string (imp, other_arg);
+	}
+      else
+	{
+	  other_arg = -1;
+	  arg_string = NULL;
+	  arg_info = NULL;
+	}
+
+      printf ("\
+@noindent\n\
+%s: ", name);
+      print_type_string (c);
+      printf (" function");
+
+      if ((c[0] == 'R')
+	  && (c[1] == 'C'))
+	{
+	  assert (other_arg >= 0);
+
+	  if ((arg_info[0] == '?') || (arg_info[0] == '!') || (arg_info[0] == '+')
+	  || (arg_info[0] == '*') || (arg_info[0] == 'n') || (arg_info[0] == 'p'))
+	    ++arg_info;
+	  if ((arg_info[0] == 'F') || (arg_info[0] == 'N'))
+	    printf (".\n\
+The exact type is @samp{REAL(KIND=1)} when argument @var{%s} is\n\
+any type other than @code{COMPLEX}, or when it is @code{COMPLEX(KIND=1)}.\n\
+When @var{%s} is any @code{COMPLEX} type other than @code{COMPLEX(KIND=1)},\n\
+this intrinsic is valid only when used as the argument to\n\
+@code{REAL()}, as explained below.\n\n",
+		    arg_string,
+		    arg_string);
+	  else
+	    printf (".\n\
+This intrinsic is valid when argument @var{%s} is\n\
+@code{COMPLEX(KIND=1)}.\n\
+When @var{%s} is any other @code{COMPLEX} type,\n\
+this intrinsic is valid only when used as the argument to\n\
+@code{REAL()}, as explained below.\n\n",
+		    arg_string,
+		    arg_string);
+	}
+#if 0
+      else if ((c[0] == 'I')
+	       && (c[1] == '7'))
+	printf (", the exact type being wide enough to hold a pointer\n\
+on the target system (typically @code{INTEGER(KIND=1)} or @code{INTEGER(KIND=4)}).\n\n");
+#endif
+      else if ((c[1] == '=')
+	       && (c[colon + 1] >= '0')
+	       && (c[colon + 1] <= '9'))
+	{
+	  assert (other_arg >= 0);
+
+	  if ((arg_info[0] == '?') || (arg_info[0] == '!') || (arg_info[0] == '+')
+	  || (arg_info[0] == '*') || (arg_info[0] == 'n') || (arg_info[0] == 'p'))
+	    ++arg_info;
+
+	  if (((c[0] == arg_info[0])
+	       && ((c[0] == 'A') || (c[0] == 'C') || (c[0] == 'I')
+		   || (c[0] == 'L') || (c[0] == 'R')))
+	      || ((c[0] == 'R')
+		  && (arg_info[0] == 'C'))
+	      || ((c[0] == 'C')
+		  && (arg_info[0] == 'R')))
+	    printf (", the @samp{KIND=} value of the type being that of argument @var{%s}.\n\n",
+		    arg_string);
+	  else if ((c[0] == 'S')
+		   && ((arg_info[0] == 'C')
+		       || (arg_info[0] == 'F')
+		       || (arg_info[0] == 'N')))
+	    printf (".\n\
+The exact type depends on that of argument @var{%s}---if @var{%s} is\n\
+@code{COMPLEX}, this function's type is @code{REAL}\n\
+with the same @samp{KIND=} value as the type of @var{%s}.\n\
+Otherwise, this function's type is the same as that of @var{%s}.\n\n",
+		    arg_string, arg_string, arg_string, arg_string);
+	  else
+	    printf (", the exact type being that of argument @var{%s}.\n\n",
+		    arg_string);
+	}
+      else if ((c[1] == '=')
+	       && (c[colon + 1] == '*'))
+	printf (", the exact type being the result of cross-promoting the\n\
+types of all the arguments.\n\n");
+      else if (c[1] == '=')
+	assert ("?0:?:" == NULL);
+      else
+	printf (".\n\n");
+    }
+
+  for (argno = 0, argc = &c[colon + 3]; *argc != '\0'; ++argno)
+    {
+      char optionality = '\0';
+      char extra = '\0';
+      char basic;
+      char kind;
+      int length;
+      int elements;
+
+      printf ("\
+@noindent\n\
+@var{");
+      for (; ; ++argc)
+	{
+	  if (argc[0] == '=')
+	    break;
+	  printf ("%c", *argc);
+	}
+      printf ("}: ");
+
+      ++argc;
+      if ((*argc == '?')
+	  || (*argc == '!')
+	  || (*argc == '*')
+	  || (*argc == '+')
+	  || (*argc == 'n')
+	  || (*argc == 'p'))
+	optionality = *(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;
+
+      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;
+    }
+}