]>
Commit | Line | Data |
---|---|---|
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 | } |