gcc/f/intdoc.c

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