2 Copyright (C) 1997, 2000, 2001 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
5 This file is part of GNU Fortran.
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)
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.
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
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. */
29 /* Pull in the intrinsics info, but only the doc parts. */
30 #define FFEINTRIN_DOC 1
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
,
40 static void dumpspec (int menu
, const char *name
, const char *name_uc
,
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
);
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
);
53 static void print_type_string (const char *c
);
56 main (int argc
, char **argv ATTRIBUTE_UNUSED
)
61 Usage: intdoc > intdoc.texi\n\
62 Collects and dumps documentation on g77 intrinsics\n\
63 to the file named intdoc.texi.\n");
71 struct _ffeintrin_name_
77 ffeintrinSpec specific
;
80 struct _ffeintrin_gen_
82 const char *name
; /* Name as seen in program. */
83 ffeintrinSpec specs
[2];
86 struct _ffeintrin_spec_
88 const char *name
; /* Uppercase name as seen in source code,
89 lowercase if no source name, "none" if no
90 name at all (NONE case). */
91 bool is_actualarg
; /* Ok to pass as actual arg if -pedantic. */
92 ffeintrinFamily family
;
93 ffeintrinImp implementation
;
96 struct _ffeintrin_imp_
98 const char *name
; /* Name of implementation. */
99 #if 0 /* FFECOM_targetCURRENT == FFECOM_targetGCC */
100 ffecomGfrt gfrt
; /* gfrt index in library. */
101 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
105 static 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"
120 static 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"
135 static 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 #if 0 /* FFECOM_targetCURRENT == FFECOM_targetGCC */
140 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
141 { NAME, FFECOM_gfrt ## GFRT, CONTROL },
142 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
143 { NAME, FFECOM_gfrt ## GFRT, CONTROL },
144 #elif 1 /* FFECOM_targetCURRENT == FFECOM_targetFFE */
145 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
147 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
152 #include "intrin.def"
160 static struct _ffeintrin_spec_ specs
[] = {
161 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
162 #define DEFGEN(CODE,NAME,SPEC1,SPEC2)
163 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) \
164 { NAME, CALLABLE, FAMILY, IMP, },
165 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
166 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
167 #include "intrin.def"
174 struct cc_pair
{ ffeintrinImp imp
; const char *text
; };
176 static const char *descriptions
[FFEINTRIN_imp
] = { 0 };
177 static struct cc_pair cc_descriptions
[] = {
178 #define DEFDOC(IMP,SUMMARY,DESCRIPTION) { FFEINTRIN_imp ## IMP, DESCRIPTION },
183 static const char *summaries
[FFEINTRIN_imp
] = { 0 };
184 static struct cc_pair cc_summaries
[] = {
185 #define DEFDOC(IMP,SUMMARY,DESCRIPTION) { FFEINTRIN_imp ## IMP, SUMMARY },
191 family_name (ffeintrinFamily family
)
195 case FFEINTRIN_familyF77
:
198 case FFEINTRIN_familyASC
:
201 case FFEINTRIN_familyMIL
:
204 case FFEINTRIN_familyGNU
:
207 case FFEINTRIN_familyF90
:
210 case FFEINTRIN_familyVXT
:
213 case FFEINTRIN_familyFVZ
:
216 case FFEINTRIN_familyF2C
:
219 case FFEINTRIN_familyF2U
:
222 case FFEINTRIN_familyBADU77
:
223 return "familyBADU77";
226 assert ("bad family" == NULL
);
231 static int in_ifset
= 0;
232 static ffeintrinFamily latest_family
= FFEINTRIN_familyNONE
;
235 dumpif (ffeintrinFamily fam
)
237 assert (fam
!= FFEINTRIN_familyNONE
);
239 || (fam
!= latest_family
))
242 printf ("@end ifset\n");
244 printf ("@ifset %s\n", family_name (fam
));
259 || (latest_family
!= FFEINTRIN_familyNONE
))
260 printf ("@end ifset\n");
261 latest_family
= FFEINTRIN_familyNONE
;
270 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (cc_descriptions
); ++i
)
272 assert (descriptions
[cc_descriptions
[i
].imp
] == NULL
);
273 descriptions
[cc_descriptions
[i
].imp
] = cc_descriptions
[i
].text
;
276 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (cc_summaries
); ++i
)
278 assert (summaries
[cc_summaries
[i
].imp
] == NULL
);
279 summaries
[cc_summaries
[i
].imp
] = cc_summaries
[i
].text
;
282 printf ("@c This file is automatically derived from intdoc.c, intdoc.in,\n");
283 printf ("@c ansify.c, intrin.def, and intrin.h. Edit those files instead.\n");
285 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (names
); ++i
)
287 if (names
[i
].generic
!= FFEINTRIN_genNONE
)
288 dumpgen (1, names
[i
].name_ic
, names
[i
].name_uc
,
290 if (names
[i
].specific
!= FFEINTRIN_specNONE
)
291 dumpspec (1, names
[i
].name_ic
, names
[i
].name_uc
,
296 printf ("@end menu\n\n");
298 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (names
); ++i
)
300 if (names
[i
].generic
!= FFEINTRIN_genNONE
)
301 dumpgen (0, names
[i
].name_ic
, names
[i
].name_uc
,
303 if (names
[i
].specific
!= FFEINTRIN_specNONE
)
304 dumpspec (0, names
[i
].name_ic
, names
[i
].name_uc
,
311 dumpgen (int menu
, const char *name
, const char *name_uc
, ffeintrinGen gen
)
318 for (i
= 0; i
< ARRAY_SIZE (gens
[gen
].specs
); ++i
)
320 if (gens
[gen
].specs
[i
] != FFEINTRIN_specNONE
)
325 for (i
= 0; i
< ARRAY_SIZE (gens
[gen
].specs
); ++i
)
330 if ((spec
= gens
[gen
].specs
[i
]) == FFEINTRIN_specNONE
)
333 dumpif (specs
[spec
].family
);
334 dumpimp (menu
, name
, name_uc
, i
, specs
[spec
].family
, specs
[spec
].implementation
,
336 if (!menu
&& (total
> 0))
341 For information on another intrinsic with the same name:\n");
346 For information on other intrinsics with the same name:\n");
348 for (j
= 0; j
< ARRAY_SIZE (gens
[gen
].specs
); ++j
)
352 if ((spec
= gens
[gen
].specs
[j
]) == FFEINTRIN_specNONE
)
354 printf ("@xref{%s Intrinsic (%s)}.\n",
355 name
, specs
[spec
].name
);
364 dumpspec (int menu
, const char *name
, const char *name_uc
, ffeintrinSpec spec
)
366 dumpif (specs
[spec
].family
);
367 dumpimp (menu
, name
, name_uc
, 0, specs
[spec
].family
, specs
[spec
].implementation
,
373 dumpimp (int menu
, const char *name
, const char *name_uc
, size_t genno
,
374 ffeintrinFamily family
, ffeintrinImp imp
, ffeintrinSpec spec
)
383 assert ((imp
!= FFEINTRIN_impNONE
) || !genno
);
387 printf ("* %s Intrinsic",
389 if (spec
!= FFEINTRIN_specNONE
)
390 printf (" (%s)", specs
[spec
].name
); /* See XYZZY1 below */
392 #define INDENT_SUMMARY 24
393 if ((imp
== FFEINTRIN_impNONE
)
394 || (summaries
[imp
] != NULL
))
396 int spaces
= INDENT_SUMMARY
- 14 - strlen (name
);
399 if (spec
!= FFEINTRIN_specNONE
)
400 spaces
-= (3 + strlen (specs
[spec
].name
)); /* See XYZZY1 above */
406 if (imp
== FFEINTRIN_impNONE
)
408 printf ("(Reserved for future use.)\n");
412 for (c
= summaries
[imp
]; c
[0] != '\0'; ++c
)
418 int argno
= c
[1] - '0';
424 argno
= 10 * argno
+ (c
[0] - '0');
427 assert (c
[0] == '@');
430 else if (argno
== 99)
431 { /* Yeah, this is a major kludge. */
433 spaces
= INDENT_SUMMARY
+ 1;
438 printf ("%s", argument_name_string (imp
, argno
- 1));
441 fputc (c
[0], stdout
);
448 printf ("@node %s Intrinsic", name
);
449 if (spec
!= FFEINTRIN_specNONE
)
450 printf (" (%s)", specs
[spec
].name
);
451 printf ("\n@subsubsection %s Intrinsic", name
);
452 if (spec
!= FFEINTRIN_specNONE
)
453 printf (" (%s)", specs
[spec
].name
);
454 printf ("\n@cindex %s intrinsic\n@cindex intrinsics, %s\n",
457 if (imp
== FFEINTRIN_impNONE
)
460 This intrinsic is not yet implemented.\n\
461 The name is, however, reserved as an intrinsic.\n\
462 Use @samp{EXTERNAL %s} to use this name for an\n\
463 external procedure.\n\
470 c
= imps
[imp
].control
;
471 subr
= (c
[0] == '-');
472 colon
= (c
[2] == ':') ? 2 : 3;
478 (subr
? "CALL " : ""), name
);
482 for (argno
= 0; ; ++argno
)
484 argc
= argument_name_ptr (imp
, argno
);
489 printf ("@var{%s}", argc
);
490 argi
= argument_info_string (imp
, argno
);
495 printf ("-1, @var{%s}-2, @dots{}, @var{%s}-n",
507 const char *arg_string
;
508 const char *arg_info
;
510 if ((c
[colon
+ 1] >= '0')
511 && (c
[colon
+ 1] <= '9'))
513 other_arg
= c
[colon
+ 1] - '0';
514 arg_string
= argument_name_string (imp
, other_arg
);
515 arg_info
= argument_info_string (imp
, other_arg
);
527 print_type_string (c
);
528 printf (" function");
533 assert (other_arg
>= 0);
535 if ((arg_info
[0] == '?') || (arg_info
[0] == '!') || (arg_info
[0] == '+')
536 || (arg_info
[0] == '*') || (arg_info
[0] == 'n') || (arg_info
[0] == 'p'))
538 if ((arg_info
[0] == 'F') || (arg_info
[0] == 'N'))
540 The exact type is @samp{REAL(KIND=1)} when argument @var{%s} is\n\
541 any type other than @code{COMPLEX}, or when it is @code{COMPLEX(KIND=1)}.\n\
542 When @var{%s} is any @code{COMPLEX} type other than @code{COMPLEX(KIND=1)},\n\
543 this intrinsic is valid only when used as the argument to\n\
544 @code{REAL()}, as explained below.\n\n",
549 This intrinsic is valid when argument @var{%s} is\n\
550 @code{COMPLEX(KIND=1)}.\n\
551 When @var{%s} is any other @code{COMPLEX} type,\n\
552 this intrinsic is valid only when used as the argument to\n\
553 @code{REAL()}, as explained below.\n\n",
558 else if ((c
[0] == 'I')
560 printf (", the exact type being wide enough to hold a pointer\n\
561 on the target system (typically @code{INTEGER(KIND=1)} or @code{INTEGER(KIND=4)}).\n\n");
563 else if ((c
[1] == '=')
564 && (c
[colon
+ 1] >= '0')
565 && (c
[colon
+ 1] <= '9'))
567 assert (other_arg
>= 0);
569 if ((arg_info
[0] == '?') || (arg_info
[0] == '!') || (arg_info
[0] == '+')
570 || (arg_info
[0] == '*') || (arg_info
[0] == 'n') || (arg_info
[0] == 'p'))
573 if (((c
[0] == arg_info
[0])
574 && ((c
[0] == 'A') || (c
[0] == 'C') || (c
[0] == 'I')
575 || (c
[0] == 'L') || (c
[0] == 'R')))
577 && (arg_info
[0] == 'C'))
579 && (arg_info
[0] == 'R')))
580 printf (", the @samp{KIND=} value of the type being that of argument @var{%s}.\n\n",
582 else if ((c
[0] == 'S')
583 && ((arg_info
[0] == 'C')
584 || (arg_info
[0] == 'F')
585 || (arg_info
[0] == 'N')))
587 The exact type depends on that of argument @var{%s}---if @var{%s} is\n\
588 @code{COMPLEX}, this function's type is @code{REAL}\n\
589 with the same @samp{KIND=} value as the type of @var{%s}.\n\
590 Otherwise, this function's type is the same as that of @var{%s}.\n\n",
591 arg_string
, arg_string
, arg_string
, arg_string
);
593 printf (", the exact type being that of argument @var{%s}.\n\n",
596 else if ((c
[1] == '=')
597 && (c
[colon
+ 1] == '*'))
598 printf (", the exact type being the result of cross-promoting the\n\
599 types of all the arguments.\n\n");
600 else if (c
[1] == '=')
601 assert ("?0:?:" == NULL
);
606 for (argno
= 0, argc
= &c
[colon
+ 3]; *argc
!= '\0'; ++argno
)
608 char optionality
= '\0';
622 printf ("%c", *argc
);
633 optionality
= *(argc
++);
638 length
= *++argc
- '0';
640 length
= 10 * length
+ (*(argc
++) - '0');
647 elements
= *++argc
- '0';
649 elements
= 10 * elements
+ (*(argc
++) - '0');
652 else if (*argc
== '&')
677 assert ("kind arg" == NULL
);
683 assert ((kind
== '1') || (kind
== '*'));
684 printf ("@code{CHARACTER");
686 printf ("*%d", length
);
694 printf ("@code{COMPLEX}");
697 case '1': case '2': case '3': case '4': case '5':
698 case '6': case '7': case '8': case '9':
699 printf ("@code{COMPLEX(KIND=%d)}", (kind
- '0'));
703 printf ("Same @samp{KIND=} value as for @var{%s}",
704 argument_name_string (imp
, 0));
708 assert ("Ca" == NULL
);
717 printf ("@code{INTEGER}");
720 case '1': case '2': case '3': case '4': case '5':
721 case '6': case '7': case '8': case '9':
722 printf ("@code{INTEGER(KIND=%d)}", (kind
- '0'));
726 printf ("@code{INTEGER} with same @samp{KIND=} value as for @var{%s}",
727 argument_name_string (imp
, 0));
731 assert ("Ia" == NULL
);
740 printf ("@code{LOGICAL}");
743 case '1': case '2': case '3': case '4': case '5':
744 case '6': case '7': case '8': case '9':
745 printf ("@code{LOGICAL(KIND=%d)}", (kind
- '0'));
749 printf ("@code{LOGICAL} with same @samp{KIND=} value as for @var{%s}",
750 argument_name_string (imp
, 0));
754 assert ("La" == NULL
);
763 printf ("@code{REAL}");
766 case '1': case '2': case '3': case '4': case '5':
767 case '6': case '7': case '8': case '9':
768 printf ("@code{REAL(KIND=%d)}", (kind
- '0'));
772 printf ("@code{REAL} with same @samp{KIND=} value as for @var{%s}",
773 argument_name_string (imp
, 0));
777 assert ("Ra" == NULL
);
786 printf ("@code{INTEGER} or @code{LOGICAL}");
789 case '1': case '2': case '3': case '4': case '5':
790 case '6': case '7': case '8': case '9':
791 printf ("@code{INTEGER(KIND=%d)} or @code{LOGICAL(KIND=%d)}",
792 (kind
- '0'), (kind
- '0'));
796 printf ("Same type and @samp{KIND=} value as for @var{%s}",
797 argument_name_string (imp
, 0));
801 assert ("Ba" == NULL
);
810 printf ("@code{REAL} or @code{COMPLEX}");
813 case '1': case '2': case '3': case '4': case '5':
814 case '6': case '7': case '8': case '9':
815 printf ("@code{REAL(KIND=%d)} or @code{COMPLEX(KIND=%d)}",
816 (kind
- '0'), (kind
- '0'));
820 printf ("Same type as @var{%s}",
821 argument_name_string (imp
, 0));
825 assert ("Fa" == NULL
);
834 printf ("@code{INTEGER}, @code{REAL}, or @code{COMPLEX}");
837 case '1': case '2': case '3': case '4': case '5':
838 case '6': case '7': case '8': case '9':
839 printf ("@code{INTEGER(KIND=%d)}, @code{REAL(KIND=%d)}, or @code{COMPLEX(KIND=%d)}",
840 (kind
- '0'), (kind
- '0'), (kind
- '0'));
844 assert ("N1" == NULL
);
853 printf ("@code{INTEGER} or @code{REAL}");
856 case '1': case '2': case '3': case '4': case '5':
857 case '6': case '7': case '8': case '9':
858 printf ("@code{INTEGER(KIND=%d)} or @code{REAL(KIND=%d)}",
859 (kind
- '0'), (kind
- '0'));
863 printf ("@code{INTEGER} or @code{REAL} with same @samp{KIND=} value as for @var{%s}",
864 argument_name_string (imp
, 0));
868 assert ("Sa" == NULL
);
874 printf ("@samp{*@var{label}}, where @var{label} is the label\n\
875 of an executable statement");
879 printf ("Signal handler (@code{INTEGER FUNCTION} or @code{SUBROUTINE})\n\
880 or dummy/global @code{INTEGER(KIND=1)} scalar");
884 assert ("arg type?" == NULL
);
894 printf ("; OPTIONAL (must be omitted if @var{%s} is @code{COMPLEX})",
895 argument_name_string (imp
, argno
-1));
899 printf ("; OPTIONAL");
903 printf ("; OPTIONAL");
911 printf ("; at least two such arguments must be provided");
915 assert ("optionality!" == NULL
);
931 assert (extra
!= '\0');
932 printf ("; DIMENSION(%d)", elements
);
941 printf ("; INTENT(IN)");
948 printf ("; cannot be a constant or expression");
952 printf ("; INTENT(OUT)");
956 printf ("; INTENT(INOUT)");
965 Intrinsic groups: ");
968 case FFEINTRIN_familyF77
:
969 printf ("(standard FORTRAN 77).");
972 case FFEINTRIN_familyGNU
:
973 printf ("@code{gnu}.");
976 case FFEINTRIN_familyASC
:
977 printf ("@code{f2c}, @code{f90}.");
980 case FFEINTRIN_familyMIL
:
981 printf ("@code{mil}, @code{f90}, @code{vxt}.");
984 case FFEINTRIN_familyF90
:
985 printf ("@code{f90}.");
988 case FFEINTRIN_familyVXT
:
989 printf ("@code{vxt}.");
992 case FFEINTRIN_familyFVZ
:
993 printf ("@code{f2c}, @code{vxt}.");
996 case FFEINTRIN_familyF2C
:
997 printf ("@code{f2c}.");
1000 case FFEINTRIN_familyF2U
:
1001 printf ("@code{unix}.");
1004 case FFEINTRIN_familyBADU77
:
1005 printf ("@code{badu77}.");
1009 assert ("bad family" == NULL
);
1010 printf ("@code{???}.");
1015 if (descriptions
[imp
] != NULL
)
1017 const char *c
= descriptions
[imp
];
1024 while (c
[0] != '\0')
1030 int argno
= c
[1] - '0';
1033 while ((c
[0] >= '0')
1036 argno
= 10 * argno
+ (c
[0] - '0');
1039 assert (c
[0] == '@');
1041 printf ("%s", name_uc
);
1043 printf ("%s", argument_name_string (imp
, argno
- 1));
1046 fputc (c
[0], stdout
);
1055 argument_info_ptr (ffeintrinImp imp
, int argno
)
1057 const char *c
= imps
[imp
].control
;
1058 static char arginfos
[8][32];
1059 static int argx
= 0;
1069 while ((c
[0] != ',') && (c
[0] != '\0'))
1079 for (; (c
[0] != '=') && (c
[0] != '\0'); ++c
)
1082 assert (c
[0] == '=');
1084 for (i
= 0, ++c
; (c
[0] != ',') && (c
[0] != '\0'); ++c
, ++i
)
1085 arginfos
[argx
][i
] = c
[0];
1087 arginfos
[argx
][i
] = '\0';
1089 c
= &arginfos
[argx
][0];
1091 if (((size_t) argx
) >= ARRAY_SIZE (arginfos
))
1098 argument_info_string (ffeintrinImp imp
, int argno
)
1102 p
= argument_info_ptr (imp
, argno
);
1108 argument_name_ptr (ffeintrinImp imp
, int argno
)
1110 const char *c
= imps
[imp
].control
;
1111 static char argnames
[8][32];
1112 static int argx
= 0;
1122 while ((c
[0] != ',') && (c
[0] != '\0'))
1132 for (i
= 0; (c
[0] != '=') && (c
[0] != '\0'); ++c
, ++i
)
1133 argnames
[argx
][i
] = c
[0];
1135 assert (c
[0] == '=');
1136 argnames
[argx
][i
] = '\0';
1138 c
= &argnames
[argx
][0];
1140 if (((size_t) argx
) >= ARRAY_SIZE (argnames
))
1147 argument_name_string (ffeintrinImp imp
, int argno
)
1151 p
= argument_name_ptr (imp
, argno
);
1157 print_type_string (const char *c
)
1165 assert ((kind
== '1') || (kind
== '='));
1167 printf ("@code{CHARACTER*1}");
1170 assert (c
[2] == '*');
1171 printf ("@code{CHARACTER*(*)}");
1179 printf ("@code{COMPLEX}");
1182 case '1': case '2': case '3': case '4': case '5':
1183 case '6': case '7': case '8': case '9':
1184 printf ("@code{COMPLEX(KIND=%d)}", (kind
- '0'));
1188 assert ("Ca" == NULL
);
1197 printf ("@code{INTEGER}");
1200 case '1': case '2': case '3': case '4': case '5':
1201 case '6': case '7': case '8': case '9':
1202 printf ("@code{INTEGER(KIND=%d)}", (kind
- '0'));
1206 assert ("Ia" == NULL
);
1215 printf ("@code{LOGICAL}");
1218 case '1': case '2': case '3': case '4': case '5':
1219 case '6': case '7': case '8': case '9':
1220 printf ("@code{LOGICAL(KIND=%d)}", (kind
- '0'));
1224 assert ("La" == NULL
);
1233 printf ("@code{REAL}");
1236 case '1': case '2': case '3': case '4': case '5':
1237 case '6': case '7': case '8': case '9':
1238 printf ("@code{REAL(KIND=%d)}", (kind
- '0'));
1242 printf ("@code{REAL}");
1246 assert ("Ra" == NULL
);
1255 printf ("@code{INTEGER} or @code{LOGICAL}");
1258 case '1': case '2': case '3': case '4': case '5':
1259 case '6': case '7': case '8': case '9':
1260 printf ("@code{INTEGER(KIND=%d)} or @code{LOGICAL(KIND=%d)}",
1261 (kind
- '0'), (kind
- '0'));
1265 assert ("Ba" == NULL
);
1274 printf ("@code{REAL} or @code{COMPLEX}");
1277 case '1': case '2': case '3': case '4': case '5':
1278 case '6': case '7': case '8': case '9':
1279 printf ("@code{REAL(KIND=%d)} or @code{COMPLEX(KIND=%d)}",
1280 (kind
- '0'), (kind
- '0'));
1284 assert ("Fa" == NULL
);
1293 printf ("@code{INTEGER}, @code{REAL}, or @code{COMPLEX}");
1296 case '1': case '2': case '3': case '4': case '5':
1297 case '6': case '7': case '8': case '9':
1298 printf ("@code{INTEGER(KIND=%d)}, @code{REAL(KIND=%d)}, or @code{COMPLEX(KIND=%d)}",
1299 (kind
- '0'), (kind
- '0'), (kind
- '0'));
1303 assert ("N1" == NULL
);
1312 printf ("@code{INTEGER} or @code{REAL}");
1315 case '1': case '2': case '3': case '4': case '5':
1316 case '6': case '7': case '8': case '9':
1317 printf ("@code{INTEGER(KIND=%d)} or @code{REAL(KIND=%d)}",
1318 (kind
- '0'), (kind
- '0'));
1322 assert ("Sa" == NULL
);
1328 assert ("type?" == NULL
);