gcc/f/intdoc.c

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