gcc/f/intdoc.c

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