gcc/f/intdoc.c

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