contrib/gcc/f/intdoc.c

   1 /* intdoc.c
   2    Copyright (C) 1997 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley.
   4
   5 This file is part of GNU Fortran.
   6
   7 GNU Fortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 GNU Fortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Fortran; see the file COPYING.  If not, write to
  19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.  */
  21
  22 /* From f/proj.h, which uses #error -- not all C compilers
  23    support that, and we want *this* program to be compilable
  24    by pretty much any C compiler.  */
  25 #include "hconfig.j"
  26 #include "system.j"
  27 #include "assert.j"
  28 #if HAVE_STDDEF_H
  29 #include <stddef.h>
  30 #endif
  31
  32 typedef enum
  33   {
  34 #if !defined(false) || !defined(true)
  35     false = 0, true = 1,
  36 #endif
  37 #if !defined(FALSE) || !defined(TRUE)
  38     FALSE = 0, TRUE = 1,
  39 #endif
  40     Doggone_Trailing_Comma_Dont_Work = 1
  41   } bool;
  42
  43 #define ARRAY_SIZE(a) (sizeof(a)/sizeof(a[0]))
  44
  45 /* Pull in the intrinsics info, but only the doc parts.  */
  46 #define FFEINTRIN_DOC 1
  47 #include "intrin.h"
  48
  49 const char *family_name (ffeintrinFamily family);
  50 static void dumpif (ffeintrinFamily fam);
  51 static void dumpendif (void);
  52 static void dumpclearif (void);
  53 static void dumpem (void);
  54 static void dumpgen (int menu, const char *name, const char *name_uc,
  55                      ffeintrinGen gen);
  56 static void dumpspec (int menu, const char *name, const char *name_uc,
  57                       ffeintrinSpec spec);
  58 static void dumpimp (int menu, const char *name, const char *name_uc, size_t genno, ffeintrinFamily family,
  59                      ffeintrinImp imp, ffeintrinSpec spec);
  60 static const char *argument_info_ptr (ffeintrinImp imp, int argno);
  61 static const char *argument_info_string (ffeintrinImp imp, int argno);
  62 static const char *argument_name_ptr (ffeintrinImp imp, int argno);
  63 static const char *argument_name_string (ffeintrinImp imp, int argno);
  64 #if 0
  65 static const char *elaborate_if_complex (ffeintrinImp imp, int argno);
  66 static const char *elaborate_if_maybe_complex (ffeintrinImp imp, int argno);
  67 static const char *elaborate_if_real (ffeintrinImp imp, int argno);
  68 #endif
  69 static void print_type_string (const char *c);
  70
  71 int
  72 main (int argc, char **argv ATTRIBUTE_UNUSED)
  73 {
  74   if (argc != 1)
  75     {
  76       fprintf (stderr, "\
  77 Usage: intdoc > intdoc.texi\n\
  78   Collects and dumps documentation on g77 intrinsics\n\
  79   to the file named intdoc.texi.\n");
  80       exit (1);
  81     }
  82
  83   dumpem ();
  84   return 0;
  85 }
  86
  87 struct _ffeintrin_name_
  88   {
  89     const char *name_uc;
  90     const char *name_lc;
  91     const char *name_ic;
  92     ffeintrinGen generic;
  93     ffeintrinSpec specific;
  94   };
  95
  96 struct _ffeintrin_gen_
  97   {
  98     const char *name;           /* Name as seen in program. */
  99     ffeintrinSpec specs[2];
 100   };
 101
 102 struct _ffeintrin_spec_
 103   {
 104     const char *name;           /* Uppercase name as seen in source code,
 105                                    lowercase if no source name, "none" if no
 106                                    name at all (NONE case). */
 107     bool is_actualarg;          /* Ok to pass as actual arg if -pedantic. */
 108     ffeintrinFamily family;
 109     ffeintrinImp implementation;
 110   };
 111
 112 struct _ffeintrin_imp_
 113   {
 114     const char *name;                   /* Name of implementation. */
 115 #if 0   /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 116     ffecomGfrt gfrt;            /* gfrt index in library. */
 117 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 118     const char *control;
 119   };
 120
 121 static struct _ffeintrin_name_ names[] = {
 122 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) \
 123   { UPPER, LOWER, MIXED, FFEINTRIN_ ## GEN, FFEINTRIN_ ## SPEC },
 124 #define DEFGEN(CODE,NAME,SPEC1,SPEC2)
 125 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
 126 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
 127 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
 128 #include "intrin.def"
 129 #undef DEFNAME
 130 #undef DEFGEN
 131 #undef DEFSPEC
 132 #undef DEFIMP
 133 #undef DEFIMPY
 134 };
 135
 136 static struct _ffeintrin_gen_ gens[] = {
 137 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
 138 #define DEFGEN(CODE,NAME,SPEC1,SPEC2) \
 139   { NAME, { SPEC1, SPEC2, }, },
 140 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
 141 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
 142 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
 143 #include "intrin.def"
 144 #undef DEFNAME
 145 #undef DEFGEN
 146 #undef DEFSPEC
 147 #undef DEFIMP
 148 #undef DEFIMPY
 149 };
 150
 151 static struct _ffeintrin_imp_ imps[] = {
 152 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
 153 #define DEFGEN(CODE,NAME,SPEC1,SPEC2)
 154 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
 155 #if 0   /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 156 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
 157   { NAME, FFECOM_gfrt ## GFRT, CONTROL },
 158 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
 159   { NAME, FFECOM_gfrt ## GFRT, CONTROL },
 160 #elif 1 /* FFECOM_targetCURRENT == FFECOM_targetFFE */
 161 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
 162   { NAME, CONTROL },
 163 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
 164   { NAME, CONTROL },
 165 #else
 166 #error
 167 #endif
 168 #include "intrin.def"
 169 #undef DEFNAME
 170 #undef DEFGEN
 171 #undef DEFSPEC
 172 #undef DEFIMP
 173 #undef DEFIMPY
 174 };
 175
 176 static struct _ffeintrin_spec_ specs[] = {
 177 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
 178 #define DEFGEN(CODE,NAME,SPEC1,SPEC2)
 179 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) \
 180   { NAME, CALLABLE, FAMILY, IMP, },
 181 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
 182 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
 183 #include "intrin.def"
 184 #undef DEFGEN
 185 #undef DEFSPEC
 186 #undef DEFIMP
 187 #undef DEFIMPY
 188 };
 189
 190 struct cc_pair { ffeintrinImp imp; const char *text; };
 191
 192 static const char *descriptions[FFEINTRIN_imp] = { 0 };
 193 static struct cc_pair cc_descriptions[] = {
 194 #define DEFDOC(IMP,SUMMARY,DESCRIPTION) { FFEINTRIN_imp ## IMP, DESCRIPTION },
 195 #include "intdoc.h0"
 196 #undef DEFDOC
 197 };
 198
 199 static const char *summaries[FFEINTRIN_imp] = { 0 };
 200 static struct cc_pair cc_summaries[] = {
 201 #define DEFDOC(IMP,SUMMARY,DESCRIPTION) { FFEINTRIN_imp ## IMP, SUMMARY },
 202 #include "intdoc.h0"
 203 #undef DEFDOC
 204 };
 205
 206 const char *
 207 family_name (ffeintrinFamily family)
 208 {
 209   switch (family)
 210     {
 211     case FFEINTRIN_familyF77:
 212       return "familyF77";
 213
 214     case FFEINTRIN_familyASC:
 215       return "familyASC";
 216
 217     case FFEINTRIN_familyMIL:
 218       return "familyMIL";
 219
 220     case FFEINTRIN_familyGNU:
 221       return "familyGNU";
 222
 223     case FFEINTRIN_familyF90:
 224       return "familyF90";
 225
 226     case FFEINTRIN_familyVXT:
 227       return "familyVXT";
 228
 229     case FFEINTRIN_familyFVZ:
 230       return "familyFVZ";
 231
 232     case FFEINTRIN_familyF2C:
 233       return "familyF2C";
 234
 235     case FFEINTRIN_familyF2U:
 236       return "familyF2U";
 237
 238     case FFEINTRIN_familyBADU77:
 239       return "familyBADU77";
 240
 241     default:
 242       assert ("bad family" == NULL);
 243       return "??";
 244     }
 245 }
 246
 247 static int in_ifset = 0;
 248 static ffeintrinFamily latest_family = FFEINTRIN_familyNONE;
 249
 250 static void
 251 dumpif (ffeintrinFamily fam)
 252 {
 253   assert (fam != FFEINTRIN_familyNONE);
 254   if ((in_ifset != 2)
 255       || (fam != latest_family))
 256     {
 257       if (in_ifset == 2)
 258         printf ("@end ifset\n");
 259       latest_family = fam;
 260       printf ("@ifset %s\n", family_name (fam));
 261     }
 262   in_ifset = 1;
 263 }
 264
 265 static void
 266 dumpendif ()
 267 {
 268   in_ifset = 2;
 269 }
 270
 271 static void
 272 dumpclearif ()
 273 {
 274   if ((in_ifset == 2)
 275       || (latest_family != FFEINTRIN_familyNONE))
 276     printf ("@end ifset\n");
 277   latest_family = FFEINTRIN_familyNONE;
 278   in_ifset = 0;
 279 }
 280
 281 static void
 282 dumpem ()
 283 {
 284   int i;
 285
 286   for (i = 0; ((size_t) i) < ARRAY_SIZE (cc_descriptions); ++i)
 287     {
 288       assert (descriptions[cc_descriptions[i].imp] == NULL);
 289       descriptions[cc_descriptions[i].imp] = cc_descriptions[i].text;
 290     }
 291
 292   for (i = 0; ((size_t) i) < ARRAY_SIZE (cc_summaries); ++i)
 293     {
 294       assert (summaries[cc_summaries[i].imp] == NULL);
 295       summaries[cc_summaries[i].imp] = cc_summaries[i].text;
 296     }
 297
 298   printf ("@c This file is automatically derived from intdoc.c, intdoc.in,\n");
 299   printf ("@c ansify.c, intrin.def, and intrin.h.  Edit those files instead.\n");
 300   printf ("@menu\n");
 301   for (i = 0; ((size_t) i) < ARRAY_SIZE (names); ++i)
 302     {
 303       if (names[i].generic != FFEINTRIN_genNONE)
 304         dumpgen (1, names[i].name_ic, names[i].name_uc,
 305                  names[i].generic);
 306       if (names[i].specific != FFEINTRIN_specNONE)
 307         dumpspec (1, names[i].name_ic, names[i].name_uc,
 308                   names[i].specific);
 309     }
 310   dumpclearif ();
 311
 312   printf ("@end menu\n\n");
 313
 314   for (i = 0; ((size_t) i) < ARRAY_SIZE (names); ++i)
 315     {
 316       if (names[i].generic != FFEINTRIN_genNONE)
 317         dumpgen (0, names[i].name_ic, names[i].name_uc,
 318                  names[i].generic);
 319       if (names[i].specific != FFEINTRIN_specNONE)
 320         dumpspec (0, names[i].name_ic, names[i].name_uc,
 321                   names[i].specific);
 322     }
 323   dumpclearif ();
 324 }
 325
 326 static void
 327 dumpgen (int menu, const char *name, const char *name_uc, ffeintrinGen gen)
 328 {
 329   size_t i;
 330   int total = 0;
 331
 332   if (!menu)
 333     {
 334       for (i = 0; i < ARRAY_SIZE (gens[gen].specs); ++i)
 335         {
 336           if (gens[gen].specs[i] != FFEINTRIN_specNONE)
 337             ++total;
 338         }
 339     }
 340
 341   for (i = 0; i < ARRAY_SIZE (gens[gen].specs); ++i)
 342     {
 343       ffeintrinSpec spec;
 344       size_t j;
 345
 346       if ((spec = gens[gen].specs[i]) == FFEINTRIN_specNONE)
 347         continue;
 348
 349       dumpif (specs[spec].family);
 350       dumpimp (menu, name, name_uc, i, specs[spec].family, specs[spec].implementation,
 351                spec);
 352       if (!menu && (total > 0))
 353         {
 354           if (total == 1)
 355             {
 356               printf ("\
 357 For information on another intrinsic with the same name:\n");
 358             }
 359           else
 360             {
 361               printf ("\
 362 For information on other intrinsics with the same name:\n");
 363             }
 364           for (j = 0; j < ARRAY_SIZE (gens[gen].specs); ++j)
 365             {
 366               if (j == i)
 367                 continue;
 368               if ((spec = gens[gen].specs[j]) == FFEINTRIN_specNONE)
 369                 continue;
 370               printf ("@xref{%s Intrinsic (%s)}.\n",
 371                       name, specs[spec].name);
 372             }
 373           printf ("\n");
 374         }
 375       dumpendif ();
 376     }
 377 }
 378
 379 static void
 380 dumpspec (int menu, const char *name, const char *name_uc, ffeintrinSpec spec)
 381 {
 382   dumpif (specs[spec].family);
 383   dumpimp (menu, name, name_uc, 0, specs[spec].family, specs[spec].implementation,
 384            FFEINTRIN_specNONE);
 385   dumpendif ();
 386 }
 387
 388 static void
 389 dumpimp (int menu, const char *name, const char *name_uc, size_t genno,
 390          ffeintrinFamily family, ffeintrinImp imp, ffeintrinSpec spec)
 391 {
 392   const char *c;
 393   bool subr;
 394   const char *argc;
 395   const char *argi;
 396   int colon;
 397   int argno;
 398
 399   assert ((imp != FFEINTRIN_impNONE) || !genno);
 400
 401   if (menu)
 402     {
 403       printf ("* %s Intrinsic",
 404               name);
 405       if (spec != FFEINTRIN_specNONE)
 406         printf (" (%s)", specs[spec].name);     /* See XYZZY1 below */
 407       printf ("::");
 408 #define INDENT_SUMMARY 24
 409       if ((imp == FFEINTRIN_impNONE)
 410           || (summaries[imp] != NULL))
 411         {
 412           int spaces = INDENT_SUMMARY - 14 - strlen (name);
 413           const char *c;
 414
 415           if (spec != FFEINTRIN_specNONE)
 416             spaces -= (3 + strlen (specs[spec].name));  /* See XYZZY1 above */
 417           if (spaces < 1)
 418             spaces = 1;
 419           while (spaces--)
 420             fputc (' ', stdout);
 421
 422           if (imp == FFEINTRIN_impNONE)
 423             {
 424               printf ("(Reserved for future use.)\n");
 425               return;
 426             }
 427
 428           for (c = summaries[imp]; c[0] != '\0'; ++c)
 429             {
 430               if ((c[0] == '@')
 431                   && (c[1] >= '0')
 432               && (c[1] <= '9'))
 433                 {
 434                   int argno = c[1] - '0';
 435
 436                   c += 2;
 437                   while ((c[0] >= '0')
 438                          && (c[0] <= '9'))
 439                     {
 440                       argno = 10 * argno + (c[0] - '0');
 441                       ++c;
 442                     }
 443                   assert (c[0] == '@');
 444                   if (argno == 0)
 445                     printf ("%s", name);
 446                   else if (argno == 99)
 447                     {   /* Yeah, this is a major kludge. */
 448                       printf ("\n");
 449                       spaces = INDENT_SUMMARY + 1;
 450                       while (spaces--)
 451                         fputc (' ', stdout);
 452                     }
 453                   else
 454                     printf ("%s", argument_name_string (imp, argno - 1));
 455                 }
 456               else
 457                 fputc (c[0], stdout);
 458             }
 459         }
 460       printf ("\n");
 461       return;
 462     }
 463
 464   printf ("@node %s Intrinsic", name);
 465   if (spec != FFEINTRIN_specNONE)
 466     printf (" (%s)", specs[spec].name);
 467   printf ("\n@subsubsection %s Intrinsic", name);
 468   if (spec != FFEINTRIN_specNONE)
 469     printf (" (%s)", specs[spec].name);
 470   printf ("\n@cindex %s intrinsic\n@cindex intrinsics, %s\n",
 471           name, name);
 472
 473   if (imp == FFEINTRIN_impNONE)
 474     {
 475       printf ("\n\
 476 This intrinsic is not yet implemented.\n\
 477 The name is, however, reserved as an intrinsic.\n\
 478 Use @samp{EXTERNAL %s} to use this name for an\n\
 479 external procedure.\n\
 480 \n\
 481 ",
 482               name);
 483       return;
 484     }
 485
 486   c = imps[imp].control;
 487   subr = (c[0] == '-');
 488   colon = (c[2] == ':') ? 2 : 3;
 489
 490   printf ("\n\
 491 @noindent\n\
 492 @example\n\
 493 %s%s(",
 494           (subr ? "CALL " : ""), name);
 495
 496   fflush (stdout);
 497
 498   for (argno = 0; ; ++argno)
 499     {
 500       argc = argument_name_ptr (imp, argno);
 501       if (argc == NULL)
 502         break;
 503       if (argno > 0)
 504         printf (", ");
 505       printf ("@var{%s}", argc);
 506       argi = argument_info_string (imp, argno);
 507       if ((argi[0] == '*')
 508           || (argi[0] == 'n')
 509           || (argi[0] == '+')
 510           || (argi[0] == 'p'))
 511         printf ("-1, @var{%s}-2, @dots{}, @var{%s}-n",
 512                 argc, argc);
 513     }
 514
 515   printf (")\n\
 516 @end example\n\
 517 \n\
 518 ");
 519
 520   if (!subr)
 521     {
 522       int other_arg;
 523       const char *arg_string;
 524       const char *arg_info;
 525
 526       if ((c[colon + 1] >= '0')
 527           && (c[colon + 1] <= '9'))
 528         {
 529           other_arg = c[colon + 1] - '0';
 530           arg_string = argument_name_string (imp, other_arg);
 531           arg_info = argument_info_string (imp, other_arg);
 532         }
 533       else
 534         {
 535           other_arg = -1;
 536           arg_string = NULL;
 537           arg_info = NULL;
 538         }
 539
 540       printf ("\
 541 @noindent\n\
 542 %s: ", name);
 543       print_type_string (c);
 544       printf (" function");
 545
 546       if ((c[0] == 'R')
 547           && (c[1] == 'C'))
 548         {
 549           assert (other_arg >= 0);
 550
 551           if ((arg_info[0] == '?') || (arg_info[0] == '!') || (arg_info[0] == '+')
 552           || (arg_info[0] == '*') || (arg_info[0] == 'n') || (arg_info[0] == 'p'))
 553             ++arg_info;
 554           if ((arg_info[0] == 'F') || (arg_info[0] == 'N'))
 555             printf (".\n\
 556 The exact type is @samp{REAL(KIND=1)} when argument @var{%s} is\n\
 557 any type other than @code{COMPLEX}, or when it is @code{COMPLEX(KIND=1)}.\n\
 558 When @var{%s} is any @code{COMPLEX} type other than @code{COMPLEX(KIND=1)},\n\
 559 this intrinsic is valid only when used as the argument to\n\
 560 @code{REAL()}, as explained below.\n\n",
 561                     arg_string,
 562                     arg_string);
 563           else
 564             printf (".\n\
 565 This intrinsic is valid when argument @var{%s} is\n\
 566 @code{COMPLEX(KIND=1)}.\n\
 567 When @var{%s} is any other @code{COMPLEX} type,\n\
 568 this intrinsic is valid only when used as the argument to\n\
 569 @code{REAL()}, as explained below.\n\n",
 570                     arg_string,
 571                     arg_string);
 572         }
 573 #if 0
 574       else if ((c[0] == 'I')
 575                && (c[1] == '7'))
 576         printf (", the exact type being wide enough to hold a pointer\n\
 577 on the target system (typically @code{INTEGER(KIND=1)} or @code{INTEGER(KIND=4)}).\n\n");
 578 #endif
 579       else if ((c[1] == '=')
 580                && (c[colon + 1] >= '0')
 581                && (c[colon + 1] <= '9'))
 582         {
 583           assert (other_arg >= 0);
 584
 585           if ((arg_info[0] == '?') || (arg_info[0] == '!') || (arg_info[0] == '+')
 586           || (arg_info[0] == '*') || (arg_info[0] == 'n') || (arg_info[0] == 'p'))
 587             ++arg_info;
 588
 589           if (((c[0] == arg_info[0])
 590                && ((c[0] == 'A') || (c[0] == 'C') || (c[0] == 'I')
 591                    || (c[0] == 'L') || (c[0] == 'R')))
 592               || ((c[0] == 'R')
 593                   && (arg_info[0] == 'C'))
 594               || ((c[0] == 'C')
 595                   && (arg_info[0] == 'R')))
 596             printf (", the @samp{KIND=} value of the type being that of argument @var{%s}.\n\n",
 597                     arg_string);
 598           else if ((c[0] == 'S')
 599                    && ((arg_info[0] == 'C')
 600                        || (arg_info[0] == 'F')
 601                        || (arg_info[0] == 'N')))
 602             printf (".\n\
 603 The exact type depends on that of argument @var{%s}---if @var{%s} is\n\
 604 @code{COMPLEX}, this function's type is @code{REAL}\n\
 605 with the same @samp{KIND=} value as the type of @var{%s}.\n\
 606 Otherwise, this function's type is the same as that of @var{%s}.\n\n",
 607                     arg_string, arg_string, arg_string, arg_string);
 608           else
 609             printf (", the exact type being that of argument @var{%s}.\n\n",
 610                     arg_string);
 611         }
 612       else if ((c[1] == '=')
 613                && (c[colon + 1] == '*'))
 614         printf (", the exact type being the result of cross-promoting the\n\
 615 types of all the arguments.\n\n");
 616       else if (c[1] == '=')
 617         assert ("?0:?:" == NULL);
 618       else
 619         printf (".\n\n");
 620     }
 621
 622   for (argno = 0, argc = &c[colon + 3]; *argc != '\0'; ++argno)
 623     {
 624       char optionality = '\0';
 625       char extra = '\0';
 626       char basic;
 627       char kind;
 628       int length;
 629       int elements;
 630
 631       printf ("\
 632 @noindent\n\
 633 @var{");
 634       for (; ; ++argc)
 635         {
 636           if (argc[0] == '=')
 637             break;
 638           printf ("%c", *argc);
 639         }
 640       printf ("}: ");
 641
 642       ++argc;
 643       if ((*argc == '?')
 644           || (*argc == '!')
 645           || (*argc == '*')
 646           || (*argc == '+')
 647           || (*argc == 'n')
 648           || (*argc == 'p'))
 649         optionality = *(argc++);
 650       basic = *(argc++);
 651       kind = *(argc++);
 652       if (*argc == '[')
 653         {
 654           length = *++argc - '0';
 655           if (*++argc != ']')
 656             length = 10 * length + (*(argc++) - '0');
 657           ++argc;
 658         }
 659       else
 660         length = -1;
 661       if (*argc == '(')
 662         {
 663           elements = *++argc - '0';
 664           if (*++argc != ')')
 665             elements = 10 * elements + (*(argc++) - '0');
 666           ++argc;
 667         }
 668       else if (*argc == '&')
 669         {
 670           elements = -1;
 671           ++argc;
 672         }
 673       else
 674         elements = 0;
 675       if ((*argc == '&')
 676           || (*argc == 'i')
 677           || (*argc == 'w')
 678           || (*argc == 'x'))
 679         extra = *(argc++);
 680       if (*argc == ',')
 681         ++argc;
 682
 683       switch (basic)
 684         {
 685         case '-':
 686           switch (kind)
 687             {
 688             case '*':
 689               printf ("Any type");
 690               break;
 691
 692             default:
 693               assert ("kind arg" == NULL);
 694               break;
 695             }
 696           break;
 697
 698         case 'A':
 699           assert ((kind == '1') || (kind == '*'));
 700           printf ("@code{CHARACTER");
 701           if (length != -1)
 702             printf ("*%d", length);
 703           printf ("}");
 704           break;
 705
 706         case 'C':
 707           switch (kind)
 708             {
 709             case '*':
 710               printf ("@code{COMPLEX}");
 711               break;
 712
 713             case '1': case '2': case '3': case '4': case '5':
 714             case '6': case '7': case '8': case '9':
 715               printf ("@code{COMPLEX(KIND=%d)}", (kind - '0'));
 716               break;
 717
 718             case 'A':
 719               printf ("Same @samp{KIND=} value as for @var{%s}",
 720                       argument_name_string (imp, 0));
 721               break;
 722
 723             default:
 724               assert ("Ca" == NULL);
 725               break;
 726             }
 727           break;
 728
 729         case 'I':
 730           switch (kind)
 731             {
 732             case '*':
 733               printf ("@code{INTEGER}");
 734               break;
 735
 736             case '1': case '2': case '3': case '4': case '5':
 737             case '6': case '7': case '8': case '9':
 738               printf ("@code{INTEGER(KIND=%d)}", (kind - '0'));
 739               break;
 740
 741             case 'A':
 742               printf ("@code{INTEGER} with same @samp{KIND=} value as for @var{%s}",
 743                       argument_name_string (imp, 0));
 744               break;
 745
 746             default:
 747               assert ("Ia" == NULL);
 748               break;
 749             }
 750           break;
 751
 752         case 'L':
 753           switch (kind)
 754             {
 755             case '*':
 756               printf ("@code{LOGICAL}");
 757               break;
 758
 759             case '1': case '2': case '3': case '4': case '5':
 760             case '6': case '7': case '8': case '9':
 761               printf ("@code{LOGICAL(KIND=%d)}", (kind - '0'));
 762               break;
 763
 764             case 'A':
 765               printf ("@code{LOGICAL} with same @samp{KIND=} value as for @var{%s}",
 766                       argument_name_string (imp, 0));
 767               break;
 768
 769             default:
 770               assert ("La" == NULL);
 771               break;
 772             }
 773           break;
 774
 775         case 'R':
 776           switch (kind)
 777             {
 778             case '*':
 779               printf ("@code{REAL}");
 780               break;
 781
 782             case '1': case '2': case '3': case '4': case '5':
 783             case '6': case '7': case '8': case '9':
 784               printf ("@code{REAL(KIND=%d)}", (kind - '0'));
 785               break;
 786
 787             case 'A':
 788               printf ("@code{REAL} with same @samp{KIND=} value as for @var{%s}",
 789                       argument_name_string (imp, 0));
 790               break;
 791
 792             default:
 793               assert ("Ra" == NULL);
 794               break;
 795             }
 796           break;
 797
 798         case 'B':
 799           switch (kind)
 800             {
 801             case '*':
 802               printf ("@code{INTEGER} or @code{LOGICAL}");
 803               break;
 804
 805             case '1': case '2': case '3': case '4': case '5':
 806             case '6': case '7': case '8': case '9':
 807               printf ("@code{INTEGER(KIND=%d)} or @code{LOGICAL(KIND=%d)}",
 808                       (kind - '0'), (kind - '0'));
 809               break;
 810
 811             case 'A':
 812               printf ("Same type and @samp{KIND=} value as for @var{%s}",
 813                       argument_name_string (imp, 0));
 814               break;
 815
 816             default:
 817               assert ("Ba" == NULL);
 818               break;
 819             }
 820           break;
 821
 822         case 'F':
 823           switch (kind)
 824             {
 825             case '*':
 826               printf ("@code{REAL} or @code{COMPLEX}");
 827               break;
 828
 829             case '1': case '2': case '3': case '4': case '5':
 830             case '6': case '7': case '8': case '9':
 831               printf ("@code{REAL(KIND=%d)} or @code{COMPLEX(KIND=%d)}",
 832                       (kind - '0'), (kind - '0'));
 833               break;
 834
 835             case 'A':
 836               printf ("Same type as @var{%s}",
 837                       argument_name_string (imp, 0));
 838               break;
 839
 840             default:
 841               assert ("Fa" == NULL);
 842               break;
 843             }
 844           break;
 845
 846         case 'N':
 847           switch (kind)
 848             {
 849             case '*':
 850               printf ("@code{INTEGER}, @code{REAL}, or @code{COMPLEX}");
 851               break;
 852
 853             case '1': case '2': case '3': case '4': case '5':
 854             case '6': case '7': case '8': case '9':
 855               printf ("@code{INTEGER(KIND=%d)}, @code{REAL(KIND=%d)}, or @code{COMPLEX(KIND=%d)}",
 856                       (kind - '0'), (kind - '0'), (kind - '0'));
 857               break;
 858
 859             default:
 860               assert ("N1" == NULL);
 861               break;
 862             }
 863           break;
 864
 865         case 'S':
 866           switch (kind)
 867             {
 868             case '*':
 869               printf ("@code{INTEGER} or @code{REAL}");
 870               break;
 871
 872             case '1': case '2': case '3': case '4': case '5':
 873             case '6': case '7': case '8': case '9':
 874               printf ("@code{INTEGER(KIND=%d)} or @code{REAL(KIND=%d)}",
 875                       (kind - '0'), (kind - '0'));
 876               break;
 877
 878             case 'A':
 879               printf ("@code{INTEGER} or @code{REAL} with same @samp{KIND=} value as for @var{%s}",
 880                       argument_name_string (imp, 0));
 881               break;
 882
 883             default:
 884               assert ("Sa" == NULL);
 885               break;
 886             }
 887           break;
 888
 889         case 'g':
 890           printf ("@samp{*@var{label}}, where @var{label} is the label\n\
 891 of an executable statement");
 892           break;
 893
 894         case 's':
 895           printf ("Signal handler (@code{INTEGER FUNCTION} or @code{SUBROUTINE})\n\
 896 or dummy/global @code{INTEGER(KIND=1)} scalar");
 897           break;
 898
 899         default:
 900           assert ("arg type?" == NULL);
 901           break;
 902         }
 903
 904       switch (optionality)
 905         {
 906         case '\0':
 907           break;
 908
 909         case '!':
 910           printf ("; OPTIONAL (must be omitted if @var{%s} is @code{COMPLEX})",
 911                   argument_name_string (imp, argno-1));
 912           break;
 913
 914         case '?':
 915           printf ("; OPTIONAL");
 916           break;
 917
 918         case '*':
 919           printf ("; OPTIONAL");
 920           break;
 921
 922         case 'n':
 923         case '+':
 924           break;
 925
 926         case 'p':
 927           printf ("; at least two such arguments must be provided");
 928           break;
 929
 930         default:
 931           assert ("optionality!" == NULL);
 932           break;
 933         }
 934
 935       switch (elements)
 936         {
 937         case -1:
 938           break;
 939
 940         case 0:
 941           if ((basic != 'g')
 942               && (basic != 's'))
 943             printf ("; scalar");
 944           break;
 945
 946         default:
 947           assert (extra != '\0');
 948           printf ("; DIMENSION(%d)", elements);
 949           break;
 950         }
 951
 952       switch (extra)
 953         {
 954         case '\0':
 955           if ((basic != 'g')
 956               && (basic != 's'))
 957             printf ("; INTENT(IN)");
 958           break;
 959
 960         case 'i':
 961           break;
 962
 963         case '&':
 964           printf ("; cannot be a constant or expression");
 965           break;
 966
 967         case 'w':
 968           printf ("; INTENT(OUT)");
 969           break;
 970
 971         case 'x':
 972           printf ("; INTENT(INOUT)");
 973           break;
 974         }
 975
 976       printf (".\n\n");
 977     }
 978
 979   printf ("\
 980 @noindent\n\
 981 Intrinsic groups: ");
 982   switch (family)
 983     {
 984     case FFEINTRIN_familyF77:
 985       printf ("(standard FORTRAN 77).");
 986       break;
 987
 988     case FFEINTRIN_familyGNU:
 989       printf ("@code{gnu}.");
 990       break;
 991
 992     case FFEINTRIN_familyASC:
 993       printf ("@code{f2c}, @code{f90}.");
 994       break;
 995
 996     case FFEINTRIN_familyMIL:
 997       printf ("@code{mil}, @code{f90}, @code{vxt}.");
 998       break;
 999
1000     case FFEINTRIN_familyF90:
1001       printf ("@code{f90}.");
1002       break;
1003
1004     case FFEINTRIN_familyVXT:
1005       printf ("@code{vxt}.");
1006       break;
1007
1008     case FFEINTRIN_familyFVZ:
1009       printf ("@code{f2c}, @code{vxt}.");
1010       break;
1011
1012     case FFEINTRIN_familyF2C:
1013       printf ("@code{f2c}.");
1014       break;
1015
1016     case FFEINTRIN_familyF2U:
1017       printf ("@code{unix}.");
1018       break;
1019
1020     case FFEINTRIN_familyBADU77:
1021       printf ("@code{badu77}.");
1022       break;
1023
1024     default:
1025       assert ("bad family" == NULL);
1026       printf ("@code{???}.");
1027       break;
1028     }
1029   printf ("\n\n");
1030
1031   if (descriptions[imp] != NULL)
1032     {
1033       const char *c = descriptions[imp];
1034
1035       printf ("\
1036 @noindent\n\
1037 Description:\n\
1038 \n");
1039
1040       while (c[0] != '\0')
1041         {
1042           if ((c[0] == '@')
1043               && (c[1] >= '0')
1044           && (c[1] <= '9'))
1045             {
1046               int argno = c[1] - '0';
1047
1048               c += 2;
1049               while ((c[0] >= '0')
1050                      && (c[0] <= '9'))
1051                 {
1052                   argno = 10 * argno + (c[0] - '0');
1053                   ++c;
1054                 }
1055               assert (c[0] == '@');
1056               if (argno == 0)
1057                 printf ("%s", name_uc);
1058               else
1059                 printf ("%s", argument_name_string (imp, argno - 1));
1060             }
1061           else
1062             fputc (c[0], stdout);
1063           ++c;
1064         }
1065
1066       printf ("\n");
1067     }
1068 }
1069
1070 static const char *
1071 argument_info_ptr (ffeintrinImp imp, int argno)
1072 {
1073   const char *c = imps[imp].control;
1074   static char arginfos[8][32];
1075   static int argx = 0;
1076   int i;
1077
1078   if (c[2] == ':')
1079     c += 5;
1080   else
1081     c += 6;
1082
1083   while (argno--)
1084     {
1085       while ((c[0] != ',') && (c[0] != '\0'))
1086         ++c;
1087       if (c[0] != ',')
1088         break;
1089       ++c;
1090     }
1091
1092   if (c[0] == '\0')
1093     return NULL;
1094
1095   for (; (c[0] != '=') && (c[0] != '\0'); ++c)
1096     ;
1097
1098   assert (c[0] == '=');
1099
1100   for (i = 0, ++c; (c[0] != ',') && (c[0] != '\0'); ++c, ++i)
1101     arginfos[argx][i] = c[0];
1102
1103   arginfos[argx][i] = '\0';
1104
1105   c = &arginfos[argx][0];
1106   ++argx;
1107   if (((size_t) argx) >= ARRAY_SIZE (arginfos))
1108     argx = 0;
1109
1110   return c;
1111 }
1112
1113 static const char *
1114 argument_info_string (ffeintrinImp imp, int argno)
1115 {
1116   const char *p;
1117
1118   p = argument_info_ptr (imp, argno);
1119   assert (p != NULL);
1120   return p;
1121 }
1122
1123 static const char *
1124 argument_name_ptr (ffeintrinImp imp, int argno)
1125 {
1126   const char *c = imps[imp].control;
1127   static char argnames[8][32];
1128   static int argx = 0;
1129   int i;
1130
1131   if (c[2] == ':')
1132     c += 5;
1133   else
1134     c += 6;
1135
1136   while (argno--)
1137     {
1138       while ((c[0] != ',') && (c[0] != '\0'))
1139         ++c;
1140       if (c[0] != ',')
1141         break;
1142       ++c;
1143     }
1144
1145   if (c[0] == '\0')
1146     return NULL;
1147
1148   for (i = 0; (c[0] != '=') && (c[0] != '\0'); ++c, ++i)
1149     argnames[argx][i] = c[0];
1150
1151   assert (c[0] == '=');
1152   argnames[argx][i] = '\0';
1153
1154   c = &argnames[argx][0];
1155   ++argx;
1156   if (((size_t) argx) >= ARRAY_SIZE (argnames))
1157     argx = 0;
1158
1159   return c;
1160 }
1161
1162 static const char *
1163 argument_name_string (ffeintrinImp imp, int argno)
1164 {
1165   const char *p;
1166
1167   p = argument_name_ptr (imp, argno);
1168   assert (p != NULL);
1169   return p;
1170 }
1171
1172 static void
1173 print_type_string (const char *c)
1174 {
1175   char basic = c[0];
1176   char kind = c[1];
1177
1178   switch (basic)
1179     {
1180     case 'A':
1181       assert ((kind == '1') || (kind == '='));
1182       if (c[2] == ':')
1183         printf ("@code{CHARACTER*1}");
1184       else
1185         {
1186           assert (c[2] == '*');
1187           printf ("@code{CHARACTER*(*)}");
1188         }
1189       break;
1190
1191     case 'C':
1192       switch (kind)
1193         {
1194         case '=':
1195           printf ("@code{COMPLEX}");
1196           break;
1197
1198         case '1': case '2': case '3': case '4': case '5':
1199         case '6': case '7': case '8': case '9':
1200           printf ("@code{COMPLEX(KIND=%d)}", (kind - '0'));
1201           break;
1202
1203         default:
1204           assert ("Ca" == NULL);
1205           break;
1206         }
1207       break;
1208
1209     case 'I':
1210       switch (kind)
1211         {
1212         case '=':
1213           printf ("@code{INTEGER}");
1214           break;
1215
1216         case '1': case '2': case '3': case '4': case '5':
1217         case '6': case '7': case '8': case '9':
1218           printf ("@code{INTEGER(KIND=%d)}", (kind - '0'));
1219           break;
1220
1221         default:
1222           assert ("Ia" == NULL);
1223           break;
1224         }
1225       break;
1226
1227     case 'L':
1228       switch (kind)
1229         {
1230         case '=':
1231           printf ("@code{LOGICAL}");
1232           break;
1233
1234         case '1': case '2': case '3': case '4': case '5':
1235         case '6': case '7': case '8': case '9':
1236           printf ("@code{LOGICAL(KIND=%d)}", (kind - '0'));
1237           break;
1238
1239         default:
1240           assert ("La" == NULL);
1241           break;
1242         }
1243       break;
1244
1245     case 'R':
1246       switch (kind)
1247         {
1248         case '=':
1249           printf ("@code{REAL}");
1250           break;
1251
1252         case '1': case '2': case '3': case '4': case '5':
1253         case '6': case '7': case '8': case '9':
1254           printf ("@code{REAL(KIND=%d)}", (kind - '0'));
1255           break;
1256
1257         case 'C':
1258           printf ("@code{REAL}");
1259           break;
1260
1261         default:
1262           assert ("Ra" == NULL);
1263           break;
1264         }
1265       break;
1266
1267     case 'B':
1268       switch (kind)
1269         {
1270         case '=':
1271           printf ("@code{INTEGER} or @code{LOGICAL}");
1272           break;
1273
1274         case '1': case '2': case '3': case '4': case '5':
1275         case '6': case '7': case '8': case '9':
1276           printf ("@code{INTEGER(KIND=%d)} or @code{LOGICAL(KIND=%d)}",
1277                   (kind - '0'), (kind - '0'));
1278           break;
1279
1280         default:
1281           assert ("Ba" == NULL);
1282           break;
1283         }
1284       break;
1285
1286     case 'F':
1287       switch (kind)
1288         {
1289         case '=':
1290           printf ("@code{REAL} or @code{COMPLEX}");
1291           break;
1292
1293         case '1': case '2': case '3': case '4': case '5':
1294         case '6': case '7': case '8': case '9':
1295           printf ("@code{REAL(KIND=%d)} or @code{COMPLEX(KIND=%d)}",
1296                   (kind - '0'), (kind - '0'));
1297           break;
1298
1299         default:
1300           assert ("Fa" == NULL);
1301           break;
1302         }
1303       break;
1304
1305     case 'N':
1306       switch (kind)
1307         {
1308         case '=':
1309           printf ("@code{INTEGER}, @code{REAL}, or @code{COMPLEX}");
1310           break;
1311
1312         case '1': case '2': case '3': case '4': case '5':
1313         case '6': case '7': case '8': case '9':
1314           printf ("@code{INTEGER(KIND=%d)}, @code{REAL(KIND=%d)}, or @code{COMPLEX(KIND=%d)}",
1315                   (kind - '0'), (kind - '0'), (kind - '0'));
1316           break;
1317
1318         default:
1319           assert ("N1" == NULL);
1320           break;
1321         }
1322       break;
1323
1324     case 'S':
1325       switch (kind)
1326         {
1327         case '=':
1328           printf ("@code{INTEGER} or @code{REAL}");
1329           break;
1330
1331         case '1': case '2': case '3': case '4': case '5':
1332         case '6': case '7': case '8': case '9':
1333           printf ("@code{INTEGER(KIND=%d)} or @code{REAL(KIND=%d)}",
1334                   (kind - '0'), (kind - '0'));
1335           break;
1336
1337         default:
1338           assert ("Sa" == NULL);
1339           break;
1340         }
1341       break;
1342
1343     default:
1344       assert ("type?" == NULL);
1345       break;
1346     }
1347 }