1348 lines
29 KiB
C
1348 lines
29 KiB
C
/* 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;
|
|
}
|
|
}
|