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