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