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             case 'N':
 713               printf ("@code{INTEGER} not wider than the default kind");
 714               break;
 715
 716             default:
 717               assert ("Ia" == NULL);
 718               break;
 719             }
 720           break;
 721
 722         case 'L':
 723           switch (kind)
 724             {
 725             case '*':
 726               printf ("@code{LOGICAL}");
 727               break;
 728
 729             case '1': case '2': case '3': case '4': case '5':
 730             case '6': case '7': case '8': case '9':
 731               printf ("@code{LOGICAL(KIND=%d)}", (kind - '0'));
 732               break;
 733
 734             case 'A':
 735               printf ("@code{LOGICAL} with same @samp{KIND=} value as for @var{%s}",
 736                       argument_name_string (imp, 0));
 737               break;
 738
 739             case 'N':
 740               printf ("@code{LOGICAL} not wider than the default kind");
 741               break;
 742
 743             default:
 744               assert ("La" == NULL);
 745               break;
 746             }
 747           break;
 748
 749         case 'R':
 750           switch (kind)
 751             {
 752             case '*':
 753               printf ("@code{REAL}");
 754               break;
 755
 756             case '1': case '2': case '3': case '4': case '5':
 757             case '6': case '7': case '8': case '9':
 758               printf ("@code{REAL(KIND=%d)}", (kind - '0'));
 759               break;
 760
 761             case 'A':
 762               printf ("@code{REAL} with same @samp{KIND=} value as for @var{%s}",
 763                       argument_name_string (imp, 0));
 764               break;
 765
 766             default:
 767               assert ("Ra" == NULL);
 768               break;
 769             }
 770           break;
 771
 772         case 'B':
 773           switch (kind)
 774             {
 775             case '*':
 776               printf ("@code{INTEGER} or @code{LOGICAL}");
 777               break;
 778
 779             case '1': case '2': case '3': case '4': case '5':
 780             case '6': case '7': case '8': case '9':
 781               printf ("@code{INTEGER(KIND=%d)} or @code{LOGICAL(KIND=%d)}",
 782                       (kind - '0'), (kind - '0'));
 783               break;
 784
 785             case 'A':
 786               printf ("Same type and @samp{KIND=} value as for @var{%s}",
 787                       argument_name_string (imp, 0));
 788               break;
 789
 790             case 'N':
 791               printf ("@code{INTEGER} or @code{LOGICAL} not wider than the default kind");
 792               break;
 793
 794             default:
 795               assert ("Ba" == NULL);
 796               break;
 797             }
 798           break;
 799
 800         case 'F':
 801           switch (kind)
 802             {
 803             case '*':
 804               printf ("@code{REAL} or @code{COMPLEX}");
 805               break;
 806
 807             case '1': case '2': case '3': case '4': case '5':
 808             case '6': case '7': case '8': case '9':
 809               printf ("@code{REAL(KIND=%d)} or @code{COMPLEX(KIND=%d)}",
 810                       (kind - '0'), (kind - '0'));
 811               break;
 812
 813             case 'A':
 814               printf ("Same type as @var{%s}",
 815                       argument_name_string (imp, 0));
 816               break;
 817
 818             default:
 819               assert ("Fa" == NULL);
 820               break;
 821             }
 822           break;
 823
 824         case 'N':
 825           switch (kind)
 826             {
 827             case '*':
 828               printf ("@code{INTEGER}, @code{REAL}, or @code{COMPLEX}");
 829               break;
 830
 831             case '1': case '2': case '3': case '4': case '5':
 832             case '6': case '7': case '8': case '9':
 833               printf ("@code{INTEGER(KIND=%d)}, @code{REAL(KIND=%d)}, or @code{COMPLEX(KIND=%d)}",
 834                       (kind - '0'), (kind - '0'), (kind - '0'));
 835               break;
 836
 837             default:
 838               assert ("N1" == NULL);
 839               break;
 840             }
 841           break;
 842
 843         case 'S':
 844           switch (kind)
 845             {
 846             case '*':
 847               printf ("@code{INTEGER} or @code{REAL}");
 848               break;
 849
 850             case '1': case '2': case '3': case '4': case '5':
 851             case '6': case '7': case '8': case '9':
 852               printf ("@code{INTEGER(KIND=%d)} or @code{REAL(KIND=%d)}",
 853                       (kind - '0'), (kind - '0'));
 854               break;
 855
 856             case 'A':
 857               printf ("@code{INTEGER} or @code{REAL} with same @samp{KIND=} value as for @var{%s}",
 858                       argument_name_string (imp, 0));
 859               break;
 860
 861             default:
 862               assert ("Sa" == NULL);
 863               break;
 864             }
 865           break;
 866
 867         case 'g':
 868           printf ("@samp{*@var{label}}, where @var{label} is the label\n\
 869 of an executable statement");
 870           break;
 871
 872         case 's':
 873           printf ("Signal handler (@code{INTEGER FUNCTION} or @code{SUBROUTINE})\n\
 874 or dummy/global @code{INTEGER(KIND=1)} scalar");
 875           break;
 876
 877         default:
 878           assert ("arg type?" == NULL);
 879           break;
 880         }
 881
 882       switch (optionality)
 883         {
 884         case '\0':
 885           break;
 886
 887         case '!':
 888           printf ("; OPTIONAL (must be omitted if @var{%s} is @code{COMPLEX})",
 889                   argument_name_string (imp, argno-1));
 890           break;
 891
 892         case '?':
 893           printf ("; OPTIONAL");
 894           break;
 895
 896         case '*':
 897           printf ("; OPTIONAL");
 898           break;
 899
 900         case 'n':
 901         case '+':
 902           break;
 903
 904         case 'p':
 905           printf ("; at least two such arguments must be provided");
 906           break;
 907
 908         default:
 909           assert ("optionality!" == NULL);
 910           break;
 911         }
 912
 913       switch (elements)
 914         {
 915         case -1:
 916           break;
 917
 918         case 0:
 919           if ((basic != 'g')
 920               && (basic != 's'))
 921             printf ("; scalar");
 922           break;
 923
 924         default:
 925           assert (extra != '\0');
 926           printf ("; DIMENSION(%d)", elements);
 927           break;
 928         }
 929
 930       switch (extra)
 931         {
 932         case '\0':
 933           if ((basic != 'g')
 934               && (basic != 's'))
 935             printf ("; INTENT(IN)");
 936           break;
 937
 938         case 'i':
 939           break;
 940
 941         case '&':
 942           printf ("; cannot be a constant or expression");
 943           break;
 944
 945         case 'w':
 946           printf ("; INTENT(OUT)");
 947           break;
 948
 949         case 'x':
 950           printf ("; INTENT(INOUT)");
 951           break;
 952         }
 953
 954       printf (".\n\n");
 955     }
 956
 957   printf ("\
 958 @noindent\n\
 959 Intrinsic groups: ");
 960   switch (family)
 961     {
 962     case FFEINTRIN_familyF77:
 963       printf ("(standard FORTRAN 77).");
 964       break;
 965
 966     case FFEINTRIN_familyGNU:
 967       printf ("@code{gnu}.");
 968       break;
 969
 970     case FFEINTRIN_familyASC:
 971       printf ("@code{f2c}, @code{f90}.");
 972       break;
 973
 974     case FFEINTRIN_familyMIL:
 975       printf ("@code{mil}, @code{f90}, @code{vxt}.");
 976       break;
 977
 978     case FFEINTRIN_familyF90:
 979       printf ("@code{f90}.");
 980       break;
 981
 982     case FFEINTRIN_familyVXT:
 983       printf ("@code{vxt}.");
 984       break;
 985
 986     case FFEINTRIN_familyFVZ:
 987       printf ("@code{f2c}, @code{vxt}.");
 988       break;
 989
 990     case FFEINTRIN_familyF2C:
 991       printf ("@code{f2c}.");
 992       break;
 993
 994     case FFEINTRIN_familyF2U:
 995       printf ("@code{unix}.");
 996       break;
 997
 998     case FFEINTRIN_familyBADU77:
 999       printf ("@code{badu77}.");
1000       break;
1001
1002     default:
1003       assert ("bad family" == NULL);
1004       printf ("@code{???}.");
1005       break;
1006     }
1007   printf ("\n\n");
1008
1009   if (descriptions[imp] != NULL)
1010     {
1011       const char *c = descriptions[imp];
1012
1013       printf ("\
1014 @noindent\n\
1015 Description:\n\
1016 \n");
1017
1018       while (c[0] != '\0')
1019         {
1020           if (c[0] == '@' && ISDIGIT (c[1]))
1021             {
1022               int argno = c[1] - '0';
1023
1024               c += 2;
1025               while (ISDIGIT (c[0]))
1026                 {
1027                   argno = 10 * argno + (c[0] - '0');
1028                   ++c;
1029                 }
1030               assert (c[0] == '@');
1031               if (argno == 0)
1032                 printf ("%s", name_uc);
1033               else
1034                 printf ("%s", argument_name_string (imp, argno - 1));
1035             }
1036           else
1037             fputc (c[0], stdout);
1038           ++c;
1039         }
1040
1041       printf ("\n");
1042     }
1043 }
1044
1045 static const char *
1046 argument_info_ptr (ffeintrinImp imp, int argno)
1047 {
1048   const char *c = imps[imp].control;
1049   static char arginfos[8][32];
1050   static int argx = 0;
1051   int i;
1052
1053   if (c[2] == ':')
1054     c += 5;
1055   else
1056     c += 6;
1057
1058   while (argno--)
1059     {
1060       while ((c[0] != ',') && (c[0] != '\0'))
1061         ++c;
1062       if (c[0] != ',')
1063         break;
1064       ++c;
1065     }
1066
1067   if (c[0] == '\0')
1068     return NULL;
1069
1070   for (; (c[0] != '=') && (c[0] != '\0'); ++c)
1071     ;
1072
1073   assert (c[0] == '=');
1074
1075   for (i = 0, ++c; (c[0] != ',') && (c[0] != '\0'); ++c, ++i)
1076     arginfos[argx][i] = c[0];
1077
1078   arginfos[argx][i] = '\0';
1079
1080   c = &arginfos[argx][0];
1081   ++argx;
1082   if (((size_t) argx) >= ARRAY_SIZE (arginfos))
1083     argx = 0;
1084
1085   return c;
1086 }
1087
1088 static const char *
1089 argument_info_string (ffeintrinImp imp, int argno)
1090 {
1091   const char *p;
1092
1093   p = argument_info_ptr (imp, argno);
1094   assert (p != NULL);
1095   return p;
1096 }
1097
1098 static const char *
1099 argument_name_ptr (ffeintrinImp imp, int argno)
1100 {
1101   const char *c = imps[imp].control;
1102   static char argnames[8][32];
1103   static int argx = 0;
1104   int i;
1105
1106   if (c[2] == ':')
1107     c += 5;
1108   else
1109     c += 6;
1110
1111   while (argno--)
1112     {
1113       while ((c[0] != ',') && (c[0] != '\0'))
1114         ++c;
1115       if (c[0] != ',')
1116         break;
1117       ++c;
1118     }
1119
1120   if (c[0] == '\0')
1121     return NULL;
1122
1123   for (i = 0; (c[0] != '=') && (c[0] != '\0'); ++c, ++i)
1124     argnames[argx][i] = c[0];
1125
1126   assert (c[0] == '=');
1127   argnames[argx][i] = '\0';
1128
1129   c = &argnames[argx][0];
1130   ++argx;
1131   if (((size_t) argx) >= ARRAY_SIZE (argnames))
1132     argx = 0;
1133
1134   return c;
1135 }
1136
1137 static const char *
1138 argument_name_string (ffeintrinImp imp, int argno)
1139 {
1140   const char *p;
1141
1142   p = argument_name_ptr (imp, argno);
1143   assert (p != NULL);
1144   return p;
1145 }
1146
1147 static void
1148 print_type_string (const char *c)
1149 {
1150   char basic = c[0];
1151   char kind = c[1];
1152
1153   switch (basic)
1154     {
1155     case 'A':
1156       assert ((kind == '1') || (kind == '='));
1157       if (c[2] == ':')
1158         printf ("@code{CHARACTER*1}");
1159       else
1160         {
1161           assert (c[2] == '*');
1162           printf ("@code{CHARACTER*(*)}");
1163         }
1164       break;
1165
1166     case 'C':
1167       switch (kind)
1168         {
1169         case '=':
1170           printf ("@code{COMPLEX}");
1171           break;
1172
1173         case '1': case '2': case '3': case '4': case '5':
1174         case '6': case '7': case '8': case '9':
1175           printf ("@code{COMPLEX(KIND=%d)}", (kind - '0'));
1176           break;
1177
1178         default:
1179           assert ("Ca" == NULL);
1180           break;
1181         }
1182       break;
1183
1184     case 'I':
1185       switch (kind)
1186         {
1187         case '=':
1188           printf ("@code{INTEGER}");
1189           break;
1190
1191         case '1': case '2': case '3': case '4': case '5':
1192         case '6': case '7': case '8': case '9':
1193           printf ("@code{INTEGER(KIND=%d)}", (kind - '0'));
1194           break;
1195
1196         default:
1197           assert ("Ia" == NULL);
1198           break;
1199         }
1200       break;
1201
1202     case 'L':
1203       switch (kind)
1204         {
1205         case '=':
1206           printf ("@code{LOGICAL}");
1207           break;
1208
1209         case '1': case '2': case '3': case '4': case '5':
1210         case '6': case '7': case '8': case '9':
1211           printf ("@code{LOGICAL(KIND=%d)}", (kind - '0'));
1212           break;
1213
1214         default:
1215           assert ("La" == NULL);
1216           break;
1217         }
1218       break;
1219
1220     case 'R':
1221       switch (kind)
1222         {
1223         case '=':
1224           printf ("@code{REAL}");
1225           break;
1226
1227         case '1': case '2': case '3': case '4': case '5':
1228         case '6': case '7': case '8': case '9':
1229           printf ("@code{REAL(KIND=%d)}", (kind - '0'));
1230           break;
1231
1232         case 'C':
1233           printf ("@code{REAL}");
1234           break;
1235
1236         default:
1237           assert ("Ra" == NULL);
1238           break;
1239         }
1240       break;
1241
1242     case 'B':
1243       switch (kind)
1244         {
1245         case '=':
1246           printf ("@code{INTEGER} or @code{LOGICAL}");
1247           break;
1248
1249         case '1': case '2': case '3': case '4': case '5':
1250         case '6': case '7': case '8': case '9':
1251           printf ("@code{INTEGER(KIND=%d)} or @code{LOGICAL(KIND=%d)}",
1252                   (kind - '0'), (kind - '0'));
1253           break;
1254
1255         default:
1256           assert ("Ba" == NULL);
1257           break;
1258         }
1259       break;
1260
1261     case 'F':
1262       switch (kind)
1263         {
1264         case '=':
1265           printf ("@code{REAL} or @code{COMPLEX}");
1266           break;
1267
1268         case '1': case '2': case '3': case '4': case '5':
1269         case '6': case '7': case '8': case '9':
1270           printf ("@code{REAL(KIND=%d)} or @code{COMPLEX(KIND=%d)}",
1271                   (kind - '0'), (kind - '0'));
1272           break;
1273
1274         default:
1275           assert ("Fa" == NULL);
1276           break;
1277         }
1278       break;
1279
1280     case 'N':
1281       switch (kind)
1282         {
1283         case '=':
1284           printf ("@code{INTEGER}, @code{REAL}, or @code{COMPLEX}");
1285           break;
1286
1287         case '1': case '2': case '3': case '4': case '5':
1288         case '6': case '7': case '8': case '9':
1289           printf ("@code{INTEGER(KIND=%d)}, @code{REAL(KIND=%d)}, or @code{COMPLEX(KIND=%d)}",
1290                   (kind - '0'), (kind - '0'), (kind - '0'));
1291           break;
1292
1293         default:
1294           assert ("N1" == NULL);
1295           break;
1296         }
1297       break;
1298
1299     case 'S':
1300       switch (kind)
1301         {
1302         case '=':
1303           printf ("@code{INTEGER} or @code{REAL}");
1304           break;
1305
1306         case '1': case '2': case '3': case '4': case '5':
1307         case '6': case '7': case '8': case '9':
1308           printf ("@code{INTEGER(KIND=%d)} or @code{REAL(KIND=%d)}",
1309                   (kind - '0'), (kind - '0'));
1310           break;
1311
1312         default:
1313           assert ("Sa" == NULL);
1314           break;
1315         }
1316       break;
1317
1318     default:
1319       assert ("type?" == NULL);
1320       break;
1321     }
1322 }