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