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