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