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