| blob | 9abab693235dcf5b5ee050d7b68a1cbd323c9a88 |
1 /* com.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
3 Free Software Foundation, Inc.
4 Contributed by James Craig Burley.
6 This file is part of GNU Fortran.
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.
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.
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.
23 Related Modules:
24 None
26 Description:
27 Contains compiler-specific functions.
29 Modifications:
30 */
32 /* Understanding this module means understanding the interface between
33 the g77 front end and the gcc back end (or, perhaps, some other
34 back end). In here are the functions called by the front end proper
35 to notify whatever back end is in place about certain things, and
36 also the back-end-specific functions. It's a bear to deal with, so
37 lately I've been trying to simplify things, especially with regard
38 to the gcc-back-end-specific stuff.
40 Building expressions generally seems quite easy, but building decls
41 has been challenging and is undergoing revision. gcc has several
42 kinds of decls:
44 TYPE_DECL -- a type (int, float, struct, function, etc.)
45 CONST_DECL -- a constant of some type other than function
46 LABEL_DECL -- a variable or a constant?
47 PARM_DECL -- an argument to a function (a variable that is a dummy)
48 RESULT_DECL -- the return value of a function (a variable)
49 VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
50 FUNCTION_DECL -- a function (either the actual function or an extern ref)
51 FIELD_DECL -- a field in a struct or union (goes into types)
53 g77 has a set of functions that somewhat parallels the gcc front end
54 when it comes to building decls:
56 Internal Function (one we define, not just declare as extern):
57 if (is_nested) push_f_function_context ();
58 start_function (get_identifier ("function_name"), function_type,
59 is_nested, is_public);
60 // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
61 store_parm_decls (is_main_program);
62 ffecom_start_compstmt ();
63 // for stmts and decls inside function, do appropriate things;
64 ffecom_end_compstmt ();
65 finish_function (is_nested);
66 if (is_nested) pop_f_function_context ();
68 Everything Else:
69 tree d;
70 tree init;
71 // fill in external, public, static, &c for decl, and
72 // set DECL_INITIAL to error_mark_node if going to initialize
73 // set is_top_level TRUE only if not at top level and decl
74 // must go in top level (i.e. not within current function decl context)
75 d = start_decl (decl, is_top_level);
76 init = ...; // if have initializer
77 finish_decl (d, init, is_top_level);
79 */
81 /* Include files. */
95 /* VMS-specific definitions */
96 #ifdef VMS
97 #include <descrip.h>
100 #define read(fd,buf,size) VMS_read (fd,buf,size)
101 #define write(fd,buf,size) VMS_write (fd,buf,size)
102 #define open(fname,mode,prot) VMS_open (fname,mode,prot)
103 #define fopen(fname,mode) VMS_fopen (fname,mode)
104 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
105 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
106 #define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
116 #define ino_t vms_ino_t
137 /* Externals defined here. */
139 /* Stream for reading from the input file. */
142 /* These definitions parallel those in c-decl.c so that code from that
143 module can be used pretty much as is. Much of these defs aren't
144 otherwise used, i.e. by g77 code per se, except some of them are used
145 to build some of them that are. The ones that are global (i.e. not
146 "static") are those that ste.c and such might use (directly
147 or by using com macros that reference them in their definitions). */
149 tree string_type_node;
151 /* The rest of these are inventions for g77, though there might be
152 similar things in the C front end. As they are found, these
153 inventions should be renamed to be canonical. Note that only
154 the ones currently required to be global are so. */
163 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
164 just use build_function_type and build_pointer_type on the
165 appropriate _tree_type array element. */
175 ffecomSymbol ffecom_symbol_null_
176 =
177 {
178 NULL_TREE,
179 NULL_TREE,
180 NULL_TREE,
181 NULL_TREE,
182 false
183 };
188 tree ffecom_f2c_integer_type_node;
189 tree ffecom_f2c_ptr_to_integer_type_node;
190 tree ffecom_f2c_address_type_node;
191 tree ffecom_f2c_real_type_node;
192 tree ffecom_f2c_ptr_to_real_type_node;
193 tree ffecom_f2c_doublereal_type_node;
194 tree ffecom_f2c_complex_type_node;
195 tree ffecom_f2c_doublecomplex_type_node;
196 tree ffecom_f2c_longint_type_node;
197 tree ffecom_f2c_logical_type_node;
198 tree ffecom_f2c_flag_type_node;
199 tree ffecom_f2c_ftnlen_type_node;
200 tree ffecom_f2c_ftnlen_zero_node;
201 tree ffecom_f2c_ftnlen_one_node;
202 tree ffecom_f2c_ftnlen_two_node;
203 tree ffecom_f2c_ptr_to_ftnlen_type_node;
204 tree ffecom_f2c_ftnint_type_node;
205 tree ffecom_f2c_ptr_to_ftnint_type_node;
207 /* Simple definitions and enumerations. */
209 #ifndef FFECOM_sizeMAXSTACKITEM
211 larger than this # bytes
212 off stack if possible. */
213 #endif
215 /* For systems that have large enough stacks, they should define
216 this to 0, and here, for ease of use later on, we just undefine
217 it if it is 0. */
219 #if FFECOM_sizeMAXSTACKITEM == 0
220 #undef FFECOM_sizeMAXSTACKITEM
221 #endif
224 {
225 FFECOM_rttypeVOID_,
240 FFECOM_rttype_
243 /* Internal typedefs. */
247 /* Private include files. */
250 /* Internal structure definitions. */
252 struct _ffecom_concat_list_
253 {
257 ffetargetCharacterSize minlen;
258 ffetargetCharacterSize maxlen;
259 };
261 /* Static functions (internal). */
288 static ffecomConcatList_
290 ffebld expr,
291 ffetargetCharacterSize max);
294 ffetargetCharacterSize max);
297 ffetargetOffset offset);
314 ffeinfoBasictype bt,
315 ffeinfoKindtype kt);
323 tree dest_length,
324 ffetargetCharacterSize dest_size,
325 ffebld source);
330 ffebld source);
340 tree t);
347 ffeinfoBasictype bt,
348 ffeinfoKindtype kt);
357 /* These are static functions that parallel those found in the C front
358 end and thus have the same names. */
382 ffewhereColumn c);
384 /* Static objects accessed by functions in this module. */
410 static tree
418 /* Holds pointer-to-function expressions. */
421 =
422 {
423 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
425 #undef DEFGFRT
426 };
428 /* Holds the external names of the functions. */
431 =
432 {
433 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
435 #undef DEFGFRT
436 };
438 /* Whether the function returns. */
441 =
442 {
443 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
445 #undef DEFGFRT
446 };
448 /* Whether the function returns type complex. */
451 =
452 {
453 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
455 #undef DEFGFRT
456 };
458 /* Whether the function is const
459 (i.e., has no side effects and only depends on its arguments). */
462 =
463 {
464 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
466 #undef DEFGFRT
467 };
469 /* Type code for the function return value. */
472 =
473 {
474 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
476 #undef DEFGFRT
477 };
479 /* String of codes for the function's arguments. */
482 =
483 {
484 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
486 #undef DEFGFRT
487 };
489 /* Internal macros. */
491 /* We let tm.h override the types used here, to handle trivial differences
492 such as the choice of unsigned int or long unsigned int for size_t.
493 When machines start needing nontrivial differences in the size type,
494 it would be best to do something here to figure out automatically
495 from other information what type to use. */
497 #ifndef SIZE_TYPE
499 #endif
501 #define ffecom_concat_list_count_(catlist) ((catlist).count)
502 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
503 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
504 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
506 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
507 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
509 /* For each binding contour we allocate a binding_level structure
510 * which records the names defined in that contour.
511 * Contours include:
512 * 0) the global one
513 * 1) one for each function definition,
514 * where internal declarations of the parameters appear.
515 *
516 * The current meaning of a name can be found by searching the levels from
517 * the current one out to the global one.
518 */
520 /* Note that the information in the `names' component of the global contour
521 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
523 struct binding_level
524 {
525 /* A chain of _DECL nodes for all variables, constants, functions,
526 and typedef types. These are in the reverse of the order supplied.
527 */
528 tree names;
530 /* For each level (except not the global one),
531 a chain of BLOCK nodes for all the levels
532 that were entered and exited one level down. */
533 tree blocks;
535 /* The BLOCK node for this level, if one has been preallocated.
536 If 0, the BLOCK is allocated (if needed) when the level is popped. */
537 tree this_block;
539 /* The binding level which this one is contained in (inherits from). */
542 /* 0: no ffecom_prepare_* functions called at this level yet;
543 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
544 2: ffecom_prepare_end called. */
546 };
548 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
550 /* The binding level currently in effect. */
554 /* A chain of binding_level structures awaiting reuse. */
558 /* The outermost binding level, for names of file scope.
559 This is created when the compiler is started and exists
560 through the entire run. */
564 /* Binding level structures are initialized by copying this one. */
566 static const struct binding_level clear_binding_level
567 =
570 /* Language-dependent contents of an identifier. */
572 struct lang_identifier
573 {
577 };
579 /* Macros for access to language-specific slots in an identifier. */
580 /* Each of these slots contains a DECL node or null. */
582 /* This represents the value which the identifier has in the
583 file-scope namespace. */
584 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
585 (((struct lang_identifier *)(NODE))->global_value)
586 /* This represents the value which the identifier has in the current
587 scope. */
588 #define IDENTIFIER_LOCAL_VALUE(NODE) \
589 (((struct lang_identifier *)(NODE))->local_value)
590 /* This represents the value which the identifier has as a label in
591 the current label scope. */
592 #define IDENTIFIER_LABEL_VALUE(NODE) \
593 (((struct lang_identifier *)(NODE))->label_value)
594 /* This is nonzero if the identifier was "made up" by g77 code. */
595 #define IDENTIFIER_INVENTED(NODE) \
596 (((struct lang_identifier *)(NODE))->invented)
598 /* In identifiers, C uses the following fields in a special way:
599 TREE_PUBLIC to record that there was a previous local extern decl.
600 TREE_USED to record that such a decl was used.
601 TREE_ADDRESSABLE to record that the address of such a decl was used. */
603 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
604 that have names. Here so we can clear out their names' definitions
605 at the end of the function. */
609 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
612 \f
613 /* Return the subscript expression, modified to do range-checking.
615 `array' is the array to be checked against.
616 `element' is the subscript expression to check.
617 `dim' is the dimension number (starting at 0).
618 `total_dims' is the total number of dimensions (0 for CHARACTER substring).
619 */
621 static tree
624 {
627 tree cond;
628 tree die;
629 tree args;
635 {
639 else
640 {
644 }
645 }
649 {
650 /* Special handling for substring range checks. Fortran allows the
651 end subscript < begin subscript, which means that expressions like
652 string(1:0) are valid (and yield a null string). In view of this,
653 enforce two simpler conditions:
654 1) element<=high for end-substring;
655 2) element>=low for start-substring.
656 Run-time character movement will enforce remaining conditions.
658 More complicated checks would be better, but present structure only
659 provides one index element at a time, so it is not possible to
660 enforce a check of both i and j in string(i:j). If it were, the
661 complete set of rules would read,
662 if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
663 ((low<=i<=high) && (low<=j<=high)) )
664 ok ;
665 else
666 range error ;
667 */
670 else
672 }
673 else
674 {
675 /* Array reference substring range checking. */
678 low,
679 element);
681 {
683 cond,
685 element,
686 high));
687 }
688 }
690 {
694 tree arg3;
695 tree arg2;
696 tree arg1;
697 tree arg4;
700 {
717 array_name,
723 }
727 build_range_type
729 integer_one_node,
735 arg1);
737 /* s_rnge adds one to the element to print it, so bias against
738 that -- want to print a faithful *subscript* value. */
742 element,
744 integer_one_node)));
748 NULL);
756 build_range_type
758 integer_one_node,
764 arg3);
778 }
785 cond,
786 element,
787 die);
790 }
792 /* Return the computed element of an array reference.
794 `item' is NULL_TREE, or the transformed pointer to the array.
795 `expr' is the original opARRAYREF expression, which is transformed
796 if `item' is NULL_TREE.
797 `want_ptr' is non-zero if a pointer to the element, instead of
798 the element itself, is to be returned. */
800 static tree
802 {
808 tree array;
809 tree element;
810 tree tree_type;
811 tree tree_type_x;
813 ffetype type;
814 ffebld list;
818 else
821 /* Build up ARRAY_REFs in reverse order (since we're column major
822 here in Fortran land). */
827 {
834 /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
835 pointers and 32-bit integers. Do the full 64-bit pointer
836 arithmetic, for codes using arrays for nonstandard heap-like
837 work. */
839 }
846 {
849 else
858 }
864 {
865 tree min;
870 {
875 array_name);
879 /* Widen integral arithmetic as desired while preserving
880 signedness. */
895 item,
900 tree_type_x,
902 }
904 {
907 item);
908 }
909 }
910 else
911 {
915 {
921 array_name);
925 /* Widen integral arithmetic as desired while preserving
926 signedness. */
938 item,
939 element);
940 }
941 }
944 }
946 /* This is like gcc's stabilize_reference -- in fact, most of the code
947 comes from that -- but it handles the situation where the reference
948 is going to have its subparts picked at, and it shouldn't change
949 (or trigger extra invocations of functions in the subtrees) due to
950 this. save_expr is a bit overzealous, because we don't need the
951 entire thing calculated and saved like a temp. So, for DECLs, no
952 change is needed, because these are stable aggregates, and ARRAY_REF
953 and such might well be stable too, but for things like calculations,
954 we do need to calculate a snapshot of a value before picking at it. */
956 static tree
958 {
959 tree result;
963 {
967 /* No action is needed in this case. */
1019 }
1027 }
1029 /* A rip-off of gcc's convert.c convert_to_complex function,
1030 reworked to handle complex implemented as C structures
1031 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
1033 static tree
1035 {
1037 tree subtype;
1044 {
1048 }
1051 {
1055 else
1056 {
1059 type,
1063 expr)),
1067 expr)));
1068 }
1069 }
1073 else
1079 }
1081 /* Like gcc's convert(), but crashes if widening might happen. */
1083 static tree
1086 {
1099 {
1102 }
1109 {
1116 }
1118 {
1121 }
1123 {
1127 }
1129 {
1133 }
1135 {
1137 /* Check that at least the first field name agrees. */
1146 }
1150 }
1152 /* Like gcc's convert(), but crashes if narrowing might happen. */
1154 static tree
1157 {
1170 {
1173 }
1180 {
1187 }
1189 {
1192 }
1194 {
1198 }
1200 {
1204 }
1206 {
1208 /* Check that at least the first field name agrees. */
1217 }
1221 }
1223 /* Handles making a COMPLEX type, either the standard
1224 (but buggy?) gbe way, or the safer (but less elegant?)
1225 f2c way. */
1227 static tree
1229 {
1230 tree type;
1231 tree realfield;
1232 tree imagfield;
1235 {
1241 }
1242 else
1243 {
1247 }
1250 }
1252 /* Chooses either the gbe or the f2c way to build a
1253 complex constant. */
1255 static tree
1257 {
1258 tree bothparts;
1261 {
1265 }
1266 else
1267 {
1269 }
1272 }
1274 static tree
1276 {
1277 tree list;
1281 tree length;
1282 ffebld exprh;
1283 tree item;
1292 {
1294 {
1297 {
1300 }
1302 {
1341 }
1342 }
1349 || (ptr
1350 && (TYPE_MODE
1354 *plist
1358 else
1359 {
1363 {
1366 item);
1367 }
1368 *plist
1370 item);
1371 }
1376 {
1379 }
1380 }
1382 /* We've run out of args in the call; if the implementation expects
1383 more, supply null pointers for them, which the implementation can
1384 check to see if an arg was omitted. */
1387 {
1390 else
1394 {
1408 }
1409 *plist
1411 null_pointer_node);
1413 }
1418 }
1420 static tree
1422 {
1423 ffebld item;
1425 ffetype type;
1427 tree t;
1430 {
1443 {
1446 }
1447 }
1454 }
1456 /* Check whether a partial overlap between two expressions is possible.
1458 Can *starting* to write a portion of expr1 change the value
1459 computed (perhaps already, *partially*) by expr2?
1461 Currently, this is a concern only for a COMPLEX expr1. But if it
1462 isn't in COMMON or local EQUIVALENCE, since we don't support
1463 aliasing of arguments, it isn't a concern. */
1465 static bool
1467 {
1468 ffesymbol sym;
1469 ffestorag st;
1472 {
1485 }
1493 /* It's in COMMON or local EQUIVALENCE. */
1496 }
1498 /* Check whether dest and source might overlap. ffebld versions of these
1499 might or might not be passed, will be NULL if not.
1501 The test is really whether source_tree is modifiable and, if modified,
1502 might overlap destination such that the value(s) in the destination might
1503 change before it is finally modified. dest_* are the canonized
1504 destination itself. */
1506 static bool
1510 {
1511 tree source_decl;
1512 tree source_offset;
1513 tree source_size;
1514 tree t;
1520 {
1585 scalar_arg);
1590 scalar_arg);
1600 source_tree);
1605 return
1608 scalar_arg)
1611 scalar_arg);
1640 }
1642 /* Come here when source_decl, source_offset, and source_size filled
1643 in appropriately. */
1653 array? Shouldn't happen.... */
1657 dest_offset,
1659 dest_size)),
1661 source_offset));
1674 source_offset,
1676 source_size)),
1678 dest_offset));
1684 }
1686 /* Check whether dest might overlap any of a list of arguments or is
1687 in a COMMON area the callee might know about (and thus modify). */
1689 static bool
1693 {
1694 tree arg;
1695 tree dest_decl;
1696 tree dest_offset;
1697 tree dest_size;
1700 dest_tree);
1705 /* If the decl cannot be determined reliably, or if its in COMMON
1706 and the callee isn't known to not futz with COMMON via other
1707 means, overlap might happen. */
1715 {
1720 }
1723 }
1725 /* Build a string for a variable name as used by NAMELIST. This means that
1726 if we're using the f2c library, we build an uppercase string, since
1727 f2c does this. */
1729 static tree
1731 {
1735 {
1740 tree t;
1744 else
1757 }
1758 }
1760 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1761 type to just get whatever the function returns), handling the
1762 f2c value-returning convention, if required, by prepending
1763 to the arglist a pointer to a temporary to receive the return value. */
1765 static tree
1770 {
1771 tree item;
1772 tree tempvar;
1778 {
1786 callee_commons,
1787 scalar_args))
1788 {
1789 #ifdef HOHO
1792 FFETARGET_charactersizeNONE,
1794 #else
1797 #endif
1798 }
1799 else
1800 {
1804 }
1806 item
1810 tempvar));
1818 }
1819 else
1827 }
1829 /* Given two arguments, transform them and make a call to the given
1830 function via ffecom_call_. */
1832 static tree
1837 {
1838 tree left_tree;
1839 tree right_tree;
1840 tree left_length;
1841 tree right_length;
1844 {
1845 /* Pass arguments by reference. */
1848 }
1849 else
1850 {
1851 /* Pass arguments by value. */
1854 }
1862 {
1865 }
1868 {
1872 else
1874 }
1879 }
1881 /* Return ptr/length args for char subexpression
1883 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1884 subexpressions by constructing the appropriate trees for the ptr-to-
1885 character-text and length-of-character-text arguments in a calling
1886 sequence.
1888 Note that if with_null is TRUE, and the expression is an opCONTER,
1889 a null byte is appended to the string. */
1891 static void
1893 {
1894 tree item;
1895 tree high;
1896 ffetargetCharacter1 val;
1897 ffetargetCharacterSize newlen;
1900 {
1905 {
1906 /* Begin FFETARGET-NULL-KLUDGE. */
1909 }
1916 /* End FFETARGET-NULL-KLUDGE. */
1918 = build_type_variant
1919 (build_array_type
1921 build_range_type
1923 ffecom_f2c_ftnlen_one_node,
1924 high)),
1929 item);
1933 {
1938 {
1941 }
1943 {
1946 else
1947 {
1950 }
1951 }
1954 else
1955 /* FFEINFO_kindFUNCTION. */
1961 item);
1962 }
1966 {
1970 {
1973 }
1976 }
1980 {
1981 ffebld start;
1982 ffebld end;
1984 tree start_tree;
1985 tree end_tree;
1987 ffebld left_symter;
1988 tree array;
1996 /* Determine name for pretty-printing range-check errors. */
2000 ;
2003 else
2009 {
2012 }
2016 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2019 {
2021 ;
2022 else
2023 {
2027 char_name);
2029 end_tree);
2032 {
2035 }
2038 }
2039 }
2040 else
2041 {
2045 char_name);
2047 start_tree);
2050 {
2053 }
2058 item,
2061 start_tree,
2062 ffecom_f2c_ftnlen_one_node));
2065 {
2067 ffecom_f2c_ftnlen_one_node,
2069 ffecom_f2c_ftnlen_type_node,
2071 start_tree));
2072 }
2073 else
2074 {
2078 char_name);
2080 end_tree);
2083 {
2086 }
2089 ffecom_f2c_ftnlen_one_node,
2091 ffecom_f2c_ftnlen_type_node,
2093 }
2094 }
2095 }
2099 {
2101 tree tempvar;
2102 tree args;
2104 ffecomGfrt ix;
2107 /* ~~Kludge alert! This should someday be fixed. */
2115 {
2117 {
2118 /* Invocation of an intrinsic returning CHARACTER*1. */
2122 }
2126 }
2127 else
2128 {
2132 {
2135 }
2137 {
2140 }
2144 }
2146 #ifdef HOHO
2148 #else
2151 #endif
2154 tempvar);
2160 else
2161 {
2164 {
2168 }
2169 else
2170 {
2173 }
2174 }
2180 tempvar);
2181 }
2189 {
2192 }
2198 temporary. */
2199 tree tempvar;
2200 tree args;
2201 tree newlen;
2203 #ifdef HOHO
2206 #else
2209 #endif
2212 tempvar);
2226 tempvar);
2228 }
2229 else
2233 }
2240 }
2243 }
2245 /* Check the size of the type to be sure it doesn't overflow the
2246 "portable" capacities of the compiler back end. `dummy' types
2247 can generally overflow the normal sizes as long as the computations
2248 themselves don't overflow. A particular target of the back end
2249 must still enforce its size requirements, though, and the back
2250 end takes care of this in stor-layout.c. */
2252 static tree
2254 {
2266 {
2273 }
2276 }
2278 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2279 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2280 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2282 static tree
2284 {
2286 tree highval;
2287 tree tlen;
2292 else
2293 {
2297 else
2301 }
2304 {
2307 }
2308 else
2309 {
2312 }
2316 ffecom_f2c_ftnlen_one_node,
2317 highval));
2321 }
2323 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2325 ffecomConcatList_ catlist;
2326 ffebld expr; // expr of CHARACTER basictype.
2327 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2328 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2330 Scans expr for character subexpressions, updates and returns catlist
2331 accordingly. */
2333 static ffecomConcatList_
2335 ffetargetCharacterSize max)
2336 {
2337 ffetargetCharacterSize sz;
2339 recurse:
2348 {
2355 if they don't need to preserve it. */
2365 {
2369 }
2372 }
2375 else
2379 else
2383 of the destination. */
2385 {
2391 /* ~~Do useful truncations here. */
2397 }
2398 }
2412 dummy arg of sfunc */
2415 {
2416 ffetargetCharacterSize cmax;
2422 }
2424 #endif
2432 }
2433 }
2435 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2437 ffecomConcatList_ catlist;
2438 ffecom_concat_list_kill_(catlist);
2440 Anything allocated within the list info is deallocated. */
2442 static void
2444 {
2448 }
2450 /* Make list of concatenated string exprs.
2452 Returns a flattened list of concatenated subexpressions given a
2453 tree of such expressions. */
2455 static ffecomConcatList_
2457 {
2458 ffecomConcatList_ catlist;
2462 }
2464 /* Provide some kind of useful info on member of aggregate area,
2465 since current g77/gcc technology does not provide debug info
2466 on these members. */
2468 static void
2471 {
2472 tree value;
2473 tree decl;
2477 #if 0
2478 tree type_id;
2482 )
2483 {
2485 {
2500 }
2501 }
2502 #endif
2511 #if 0
2513 #endif
2517 else
2521 aggr_type,
2528 build_range_type
2530 integer_one_node,
2545 }
2547 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2549 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2550 int i; // entry# for this entrypoint (used by master fn)
2551 ffecom_do_entrypoint_(s,i);
2553 Makes a public entry point that calls our private master fn (already
2554 compiled). */
2556 static void
2558 {
2559 ffebld item;
2563 ffeinfoBasictype bt;
2564 ffeinfoKindtype kt;
2565 ffeglobal g;
2566 ffeglobalType gt;
2568 CHARACTER. */
2581 {
2584 /* Determine actual return type for function. */
2590 {
2596 }
2603 else
2610 else
2629 {
2631 {
2634 }
2635 }
2638 else
2640 }
2641 else
2650 /* Fall through. */
2660 }
2662 /* build_decl uses the current lineno and input_filename to set the decl
2663 source info. So, I've putzed with ffestd and ffeste code to update that
2664 source info to point to the appropriate statement just before calling
2665 ffecom_do_entrypoint (which calls this fn). */
2668 type,
2675 {
2677 }
2679 /* Reset args in master arg list so they get retransitioned. */
2684 {
2685 ffebld arg;
2686 ffesymbol s;
2694 }
2696 /* Build dummy arg list for this entry point. */
2700 tree type;
2701 tree length;
2705 else
2710 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2714 else
2724 {
2727 }
2728 }
2729 else
2737 /* Disallow temp vars at this level. */
2740 /* Make local var to hold return type for multi-type master fn. */
2743 {
2747 ffecom_multi_type_node_);
2750 }
2751 else
2754 /* Here we emit the actual code for the entry point. */
2756 {
2757 ffebld list;
2758 ffebld arg;
2759 ffesymbol s;
2762 tree prepend;
2763 tree call;
2764 tree actarg;
2765 tree master_fn;
2767 /* Prepare actual arg list based on master arg list. */
2772 {
2780 else
2784 }
2786 /* This code appends the length arguments for character
2787 variables/arrays. */
2792 {
2804 else
2808 }
2810 /* Prepend character-value return info to actual arg list. */
2813 {
2819 }
2821 /* Prepend multi-type return value to actual arg list. */
2824 {
2825 prepend
2829 multi_retval));
2832 }
2834 /* Prepend my entry-point number to the actual arg list. */
2840 /* Build the call to the master function. */
2847 /* Decide whether the master function is a function or subroutine, and
2848 handle the return value for my entry point. */
2852 {
2855 }
2857 {
2859 result
2862 result);
2865 multi_retval,
2869 }
2871 {
2873 result
2878 multi_retval,
2881 }
2883 {
2884 result
2887 result);
2891 }
2892 else
2893 {
2895 result,
2897 call));
2899 }
2900 }
2910 }
2912 /* Transform expr into gcc tree with possible destination
2914 Recursive descent on expr while making corresponding tree nodes and
2915 attaching type info and such. If destination supplied and compatible
2916 with temporary that would be made in certain cases, temporary isn't
2917 made, destination used instead, and dest_used flag set TRUE. */
2919 static tree
2922 {
2923 tree item;
2924 tree list;
2925 tree args;
2926 ffeinfoBasictype bt;
2927 ffeinfoKindtype kt;
2928 tree t;
2932 ffesymbol s;
2944 /* Widen integral arithmetic as desired while preserving signedness. */
2952 {
2954 {
2955 ffebitCount i;
2959 tree purpose;
2967 {
2968 ffebldConstantUnion cu;
2969 ffebitCount length;
2978 {
2980 {
2989 else
2994 else
2995 {
2998 }
2999 }
3000 }
3003 }
3004 }
3010 item
3011 = build_array_type
3014 ffecom_integer_zero_node,
3015 item));
3022 {
3023 ffetargetOffset i;
3028 else
3029 {
3033 /* Becomes PURPOSE first time through loop. */
3035 }
3038 {
3039 ffebldConstantUnion cu
3045 /* Assume item is PURPOSE first time through loop. */
3047 else
3048 {
3051 }
3052 }
3053 }
3058 item
3059 = build_array_type
3062 ffecom_integer_zero_node,
3063 item));
3071 item
3086 {
3087 /* User explicitly wants ASSIGN'ed variables to be at the same
3088 memory address as the variables when used in non-ASSIGN
3089 contexts. That can make old, arcane, non-standard code
3090 work, but don't try to do it when a pointer wouldn't fit
3091 in the normal variable (take other approach, and warn,
3092 instead). */
3095 {
3099 }
3106 {
3111 }
3114 {
3116 FFEBAD_severityWARNING);
3121 }
3122 }
3124 /* Don't use the normal variable's tree for ASSIGN, though mark
3125 it as in the system header (housekeeping). Use an explicit,
3126 specially created sibling that is known to be wide enough
3127 to hold pointers to labels. */
3135 {
3139 }
3140 }
3141 else
3142 {
3144 {
3148 }
3152 }
3163 /* ~~~Make sure Fortran rules respected here */
3170 {
3173 }
3180 {
3184 }
3191 {
3195 }
3202 {
3206 }
3213 {
3217 }
3223 {
3226 ffecomGfrt code;
3227 ffeinfoKindtype rtkt;
3228 ffeinfoKindtype ltkt;
3232 {
3236 {
3240 }
3244 {
3250 {
3254 }
3255 else
3256 {
3259 }
3265 {
3268 }
3269 else
3270 {
3273 }
3279 {
3282 }
3283 else
3284 {
3287 }
3295 }
3300 FFETARGET_charactersizeNONE,
3301 FFEEXPR_contextLET);
3304 FFEINFO_basictypeINTEGER,
3306 FFETARGET_charactersizeNONE,
3307 FFEEXPR_contextLET);
3314 FFETARGET_charactersizeNONE,
3315 FFEEXPR_contextLET);
3319 FFEINFO_basictypeREAL,
3321 FFETARGET_charactersizeNONE,
3322 FFEEXPR_contextLET);
3323 /* We used to call FFECOM_gfrtPOW_DD here,
3324 which passes arguments by reference. */
3326 /* Pass arguments by value. */
3333 FFEINFO_basictypeCOMPLEX,
3335 FFETARGET_charactersizeNONE,
3336 FFEEXPR_contextLET);
3340 FFEINFO_basictypeCOMPLEX,
3342 FFETARGET_charactersizeNONE,
3343 FFEEXPR_contextLET);
3352 }
3361 }
3365 {
3376 /* Fall through. */
3379 }
3385 /* Fall through. */
3391 dest_used);
3393 }
3397 {
3400 }
3406 else
3411 else
3422 tree_type,
3423 args,
3432 {
3434 item
3447 /* Fall through. */
3450 }
3455 {
3457 item
3470 /* Fall through. */
3473 }
3479 {
3481 item
3494 /* Fall through. */
3497 }
3502 {
3504 item
3511 return
3519 /* Fall through. */
3522 }
3530 {
3538 {
3545 /* convert() takes care of converting to the subtype first,
3546 at least in gcc-2.7.2. */
3555 /* Fall through. */
3558 }
3563 /* Fall through. */
3566 }
3594 {
3605 {
3606 tree real_type;
3617 {
3620 }
3621 else
3622 {
3625 }
3627 item
3635 arg2)));
3638 else
3641 }
3644 {
3647 tree left_tree;
3648 tree right_tree;
3649 tree left_length;
3650 tree right_length;
3652 /* f2c run-time functions do the implicit blank-padding for us,
3653 so we don't usually have to implement blank-padding ourselves.
3654 (The exception is when we pass an argument to a separately
3655 compiled statement function -- if we know the arg is not the
3656 same length as the dummy, we must truncate or extend it. If
3657 we "inline" statement functions, that necessity goes away as
3658 well.)
3660 Strip off the CONVERT operators that blank-pad. (Truncation by
3661 CONVERT shouldn't happen here, but it can happen in
3662 assignments.) */
3679 {
3680 left_tree
3683 left_tree);
3684 right_tree
3687 right_tree);
3689 item
3693 left_tree,
3694 integer_one_node),
3697 right_tree,
3698 integer_one_node));
3699 }
3700 else
3701 {
3705 left_length);
3710 item,
3712 integer_zero_node));
3713 }
3715 }
3721 /* Fall through. */
3724 }
3742 /* Fall through. */
3745 }
3747 #if 1
3749 #else
3751 {
3768 }
3771 #endif
3772 }
3774 /* Returns the tree that does the intrinsic invocation.
3776 Note: this function applies only to intrinsics returning
3777 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3778 subroutines. */
3780 static tree
3783 {
3784 tree expr_tree;
3787 ffeinfoBasictype bt;
3788 ffeinfoKindtype kt;
3789 tree tree_type;
3790 tree arg1_type;
3792 tree tempvar;
3795 ffebld arg2;
3796 ffebld arg3;
3797 ffeintrinImp codegen_imp;
3798 ffecomGfrt gfrt;
3810 {
3815 {
3820 {
3824 }
3825 else
3827 }
3828 else
3830 }
3831 else
3834 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3835 args. This is used by the MAX/MIN expansions. */
3838 arg1_type = ffecom_tree_type
3841 else
3843 here. */
3845 /* There are several ways for each of the cases in the following switch
3846 statements to exit (from simplest to use to most complicated):
3848 break; (when expr_tree == NULL)
3850 A standard call is made to the specific intrinsic just as if it had been
3851 passed in as a dummy procedure and called as any old procedure. This
3852 method can produce slower code but in some cases it's the easiest way for
3853 now. However, if a (presumably faster) direct call is available,
3854 that is used, so this is the easiest way in many more cases now.
3856 gfrt = FFECOM_gfrtWHATEVER;
3857 break;
3859 gfrt contains the gfrt index of a library function to call, passing the
3860 argument(s) by value rather than by reference. Used when a more
3861 careful choice of library function is needed than that provided
3862 by the vanilla `break;'.
3864 return expr_tree;
3866 The expr_tree has been completely set up and is ready to be returned
3867 as is. No further actions are taken. Use this when the tree is not
3868 in the simple form for one of the arity_n labels. */
3870 /* For info on how the switch statement cases were written, see the files
3871 enclosed in comments below the switch statement. */
3879 {
3887 {
3893 }
3906 else
3909 return
3916 #if 0
3917 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
3920 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3922 return
3925 ffecom_truth_value
3927 saved_expr1,
3929 ffecom_float_zero_))),
3933 saved_expr1)),
3934 NULL_TREE),
3940 arg1_type,
3941 saved_expr1))),
3942 NULL_TREE)
3943 ))
3944 );
3945 #endif
3950 numbers of large magnitudes. */
3955 ffecom_truth_value
3957 integer_type_node,
3958 saved_expr1,
3959 ffecom_float_zero_)),
3961 tree_type,
3962 saved_expr1,
3963 ffecom_float_half_),
3965 tree_type,
3966 saved_expr1,
3967 ffecom_float_half_))));
3970 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3972 return
3975 ffecom_truth_value
3977 saved_expr1,
3979 ffecom_float_zero_))),
3984 arg1_type,
3985 saved_expr1,
3987 ffecom_float_half_)))),
3988 NULL_TREE),
3994 arg1_type,
3996 ffecom_float_half_),
3997 saved_expr1))),
3998 NULL_TREE))
3999 )
4000 );
4001 #endif
4013 #ifdef HOHO
4015 #else
4018 #endif
4019 {
4024 integer_one_node),
4026 }
4028 expr_tree,
4029 tempvar);
4032 expr_tree);
4038 return
4042 return
4049 return
4056 {
4057 tree arg1_tree;
4061 return
4066 }
4073 {
4078 }
4107 return
4109 ffecom_truth_value
4111 saved_expr1,
4112 saved_expr2)),
4114 saved_expr1,
4115 saved_expr2),
4119 return
4129 {
4134 }
4141 expr_tree
4144 expr_tree);
4145 expr_tree
4148 expr_tree,
4149 integer_one_node);
4154 saved_expr1,
4155 expr_tree,
4158 #endif
4164 #if 0
4166 #else
4168 #endif
4182 {
4187 }
4197 /* We used to call FFECOM_gfrtALOG10 here. */
4200 /* We used to call FFECOM_gfrtDLOG10 here. */
4212 else
4218 {
4223 expr_tree,
4226 }
4237 else
4243 {
4248 expr_tree,
4251 }
4263 /* We used to call FFECOM_gfrtAMOD here. */
4266 /* We used to call FFECOM_gfrtDMOD here. */
4272 #if 0
4273 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4275 #else
4276 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4278 return
4281 ffecom_truth_value
4283 saved_expr1,
4285 ffecom_float_zero_))),
4287 saved_expr1,
4289 ffecom_float_half_)),
4291 saved_expr1,
4293 ffecom_float_half_))));
4294 #endif
4299 {
4302 saved_expr1
4303 = ffecom_save_tree
4307 expr_tree
4309 ffecom_truth_value
4311 arg2_tree,
4313 integer_zero_node))),
4314 saved_expr1,
4316 /* Make sure SAVE_EXPRs get referenced early enough. */
4317 expr_tree
4320 expr_tree);
4321 }
4329 {
4334 }
4346 {
4351 }
4363 else
4366 return
4414 {
4415 ffetargetLogical1 target_true;
4416 ffetargetLogical1 target_false;
4417 tree true_tree;
4418 tree false_tree;
4424 else
4428 else
4431 return
4433 ffecom_truth_value
4439 integer_one_node),
4443 integer_zero_node))),
4444 false_tree,
4445 true_tree);
4446 }
4449 return
4455 integer_one_node),
4460 {
4463 tree uns_type
4466 expr_tree
4475 uns_type,
4477 integer_zero_node)),
4479 integer_type_node,
4481 arg3_tree))));
4482 /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE. */
4483 expr_tree
4485 ffecom_truth_value
4487 arg3_tree,
4488 integer_zero_node)),
4489 expr_tree,
4491 }
4495 return
4504 {
4508 tree uns_type
4511 expr_tree
4513 ffecom_truth_value
4515 arg2_tree,
4516 integer_zero_node)),
4518 arg1_tree,
4519 arg2_tree),
4524 integer_type_node,
4525 arg2_tree))));
4526 /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds. */
4527 expr_tree
4529 ffecom_truth_value
4532 integer_type_node,
4533 arg2_tree),
4535 expr_tree,
4537 /* Make sure SAVE_EXPRs get referenced early enough. */
4538 expr_tree
4543 expr_tree));
4544 }
4548 {
4554 tree shift_neg;
4555 tree shift_pos;
4556 tree mask_arg1;
4557 tree masked_arg1;
4558 tree uns_type
4561 mask_arg1
4565 arg3_tree);
4566 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4567 mask_arg1
4569 ffecom_truth_value
4571 arg3_tree,
4573 mask_arg1,
4576 masked_arg1
4578 arg1_tree,
4580 mask_arg1));
4582 shift_neg
4588 integer_type_node,
4589 arg2_tree))),
4591 arg1_tree,
4593 arg2_tree,
4594 arg3_tree)));
4595 shift_pos
4598 arg1_tree,
4599 arg2_tree),
4604 integer_type_node,
4605 arg3_tree,
4606 arg2_tree))));
4607 expr_tree
4609 ffecom_truth_value
4611 arg2_tree,
4612 integer_zero_node)),
4613 shift_neg,
4614 shift_pos);
4615 expr_tree
4618 mask_arg1,
4619 arg1_tree),
4622 mask_arg1),
4623 expr_tree));
4624 expr_tree
4626 ffecom_truth_value
4630 integer_type_node,
4631 arg2_tree),
4632 arg3_tree),
4634 arg2_tree,
4635 integer_zero_node))),
4636 arg1_tree,
4637 expr_tree);
4638 /* Make sure SAVE_EXPRs get referenced early enough. */
4639 expr_tree
4646 mask_arg1),
4649 masked_arg1),
4650 expr_tree))));
4651 expr_tree
4654 arg3_tree),
4655 expr_tree);
4656 }
4660 {
4663 expr_tree
4667 arg1_tree));
4668 }
4672 {
4673 tree arg1_tree;
4674 tree arg2_tree;
4675 tree arg3_tree;
4677 tree arg4_tree;
4678 tree arg4_type;
4680 tree arg5_tree;
4681 tree prep_arg1;
4682 tree prep_arg4;
4683 tree arg5_plus_arg3;
4698 prep_arg1
4702 arg1_tree,
4703 arg2_tree),
4707 arg4_type,
4708 convert
4710 integer_zero_node)),
4711 arg3_tree))),
4712 arg5_tree);
4713 arg5_plus_arg3
4715 arg5_tree,
4716 arg3_tree));
4717 prep_arg4
4721 integer_zero_node)),
4722 arg5_plus_arg3);
4723 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4724 prep_arg4
4726 ffecom_truth_value
4728 arg5_plus_arg3,
4731 prep_arg4,
4733 prep_arg4
4735 arg4_tree,
4737 prep_arg4,
4741 arg4_type,
4742 convert
4744 integer_zero_node)),
4745 arg5_tree))));
4746 prep_arg1
4748 prep_arg1,
4749 prep_arg4);
4750 /* Fix up (twice), because LSHIFT_EXPR above
4751 can't shift over TYPE_SIZE. */
4752 prep_arg1
4754 ffecom_truth_value
4756 arg3_tree,
4758 integer_zero_node))),
4759 prep_arg1,
4760 arg4_tree);
4761 prep_arg1
4763 ffecom_truth_value
4765 arg3_tree,
4768 prep_arg1,
4769 arg1_tree);
4770 expr_tree
4772 arg4_tree,
4773 prep_arg1);
4774 /* Make sure SAVE_EXPRs get referenced early enough. */
4775 expr_tree
4777 arg1_tree,
4779 arg3_tree,
4781 arg5_tree,
4783 arg5_plus_arg3,
4784 expr_tree))));
4785 expr_tree
4787 arg4_tree,
4788 expr_tree);
4790 }
4800 /* extern int xargc; i__1 = xargc - 1; */
4802 ffecom_tree_xargc_,
4804 integer_one_node));
4809 {
4810 tree arg1_tree;
4811 tree arg2_tree;
4812 tree arg3_tree;
4818 arg1_tree);
4820 /* Pass procedure as a pointer to it, anything else by value. */
4823 else
4826 arg2_tree);
4830 else
4837 expr_tree
4840 FALSE,
4842 NULL_TREE :
4843 tree_type),
4844 arg1_tree,
4849 expr_tree
4852 expr_tree));
4853 }
4857 {
4858 tree arg1_tree;
4859 tree arg2_tree;
4860 tree arg3_tree;
4866 arg1_tree);
4868 /* Pass procedure as a pointer to it, anything else by value. */
4871 else
4874 arg2_tree);
4878 else
4885 expr_tree
4888 FALSE,
4889 NULL_TREE,
4890 arg1_tree,
4895 expr_tree
4898 expr_tree));
4899 }
4910 {
4912 tree arg1_tree;
4913 tree arg2_tree;
4919 else
4926 expr_tree
4929 FALSE,
4930 NULL_TREE,
4931 arg1_tree,
4936 expr_tree
4939 expr_tree));
4940 }
4949 build_pointer_type
4951 integer_zero_node));
4953 return
4956 FALSE,
4957 void_type_node,
4958 expr_tree,
4965 else
4973 {
4975 tree arg1_tree;
4977 tree arg2_tree;
4978 tree arg3_tree;
4984 else
4996 FALSE,
4997 NULL_TREE,
4998 arg1_tree,
5004 expr_tree));
5005 }
5010 {
5012 tree arg1_tree;
5013 tree arg2_tree;
5014 tree arg3_tree;
5022 else
5032 FALSE,
5033 NULL_TREE,
5034 arg1_tree,
5040 expr_tree));
5041 }
5046 {
5047 tree arg1_tree;
5048 tree arg2_tree;
5050 tree arg3_tree;
5056 arg1_tree);
5061 else
5072 FALSE,
5073 NULL_TREE,
5074 arg1_tree,
5080 expr_tree));
5081 }
5085 {
5086 tree arg1_tree;
5087 tree arg2_tree;
5088 tree arg3_tree;
5094 arg1_tree);
5101 else
5109 FALSE,
5110 NULL_TREE,
5111 arg1_tree,
5117 expr_tree));
5118 }
5119 }
5123 {
5124 tree arg1_tree;
5125 tree arg2_tree;
5126 tree arg3_tree;
5132 arg1_tree);
5138 arg2_tree);
5142 else
5150 FALSE,
5151 NULL_TREE,
5152 arg1_tree,
5158 expr_tree));
5159 }
5160 }
5165 {
5167 tree arg1_tree;
5168 tree arg2_tree;
5173 ffecom_f2c_longint_type_node :
5174 ffecom_f2c_integer_type_node),
5178 arg2_tree);
5186 expr_tree
5189 FALSE,
5190 NULL_TREE,
5191 arg1_tree,
5195 }
5200 /* Arg defaults to 0 (normal random case) */
5201 {
5202 tree arg1_tree;
5206 else
5209 arg1_tree);
5212 arg1_tree);
5217 FALSE,
5219 ffecom_f2c_integer_type_node :
5220 ffecom_f2c_real_type_node),
5221 arg1_tree,
5225 }
5230 {
5231 tree arg1_tree;
5232 tree arg2_tree;
5238 arg1_tree);
5242 else
5247 FALSE,
5248 NULL_TREE,
5251 TRUE,
5256 expr_tree));
5257 }
5258 }
5263 {
5264 tree arg1_tree;
5268 expr_tree
5271 FALSE,
5272 NULL_TREE,
5273 NULL_TREE,
5277 expr_tree
5280 expr_tree));
5281 }
5286 {
5287 tree arg1_tree;
5288 tree result_tree;
5296 FALSE,
5297 NULL_TREE,
5300 TRUE,
5304 expr_tree));
5305 }
5308 /* Straightforward calls of libf2c routines: */
5385 }
5394 tree_type,
5399 /* See bottom of this file for f2c transforms used to determine
5400 many of the above implementations. The info seems to confuse
5401 Emacs's C mode indentation, which is why it's been moved to
5402 the bottom of this source file. */
5403 }
5405 /* For power (exponentiation) where right-hand operand is type INTEGER,
5406 generate in-line code to do it the fast way (which, if the operand
5407 is a constant, might just mean a series of multiplies). */
5409 static tree
5411 {
5423 {
5431 {
5432 /* Reciprocal of integer is either 0, -1, or 1, so after
5433 calculating that (which we leave to the back end to do
5434 or not do optimally), don't bother with any multiplying. */
5438 l,
5441 rtype,
5442 r);
5445 result);
5446 }
5448 /* Generate appropriate series of multiplies, preceded
5449 by divide if the exponent is negative. */
5454 {
5457 l,
5467 r,
5468 integer_one_node));
5471 l,
5472 l);
5473 }
5474 }
5477 {
5479 {
5482 else
5484 result,
5485 l);
5486 }
5489 r,
5490 integer_one_node);
5497 l,
5498 l);
5499 }
5501 }
5503 /* Though rhs isn't a constant, in-line code cannot be expanded
5504 while transforming dummies
5505 because the back end cannot be easily convinced to generate
5506 stores (MODIFY_EXPR), handle temporaries, and so on before
5507 all the appropriate rtx's have been generated for things like
5508 dummy args referenced in rhs -- which doesn't happen until
5509 store_parm_decls() is called (expand_function_start, I believe,
5510 does the actual rtx-stuffing of PARM_DECLs).
5512 So, in this case, let the caller generate the call to the
5513 run-time-library function to evaluate the power for us. */
5518 /* Right-hand operand not a constant, expand in-line code to figure
5519 out how to do the multiplies, &c.
5521 The returned expression is expressed this way in GNU C, where l and
5522 r are the "inputs":
5524 ({ typeof (r) rtmp = r;
5525 typeof (l) ltmp = l;
5526 typeof (l) result;
5528 if (rtmp == 0)
5529 result = 1;
5530 else
5531 {
5532 if ((basetypeof (l) == basetypeof (int))
5533 && (rtmp < 0))
5534 {
5535 result = ((typeof (l)) 1) / ltmp;
5536 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5537 result = -result;
5538 }
5539 else
5540 {
5541 result = 1;
5542 if ((basetypeof (l) != basetypeof (int))
5543 && (rtmp < 0))
5544 {
5545 ltmp = ((typeof (l)) 1) / ltmp;
5546 rtmp = -rtmp;
5547 if (rtmp < 0)
5548 {
5549 rtmp = -(rtmp >> 1);
5550 ltmp *= ltmp;
5551 }
5552 }
5553 for (;;)
5554 {
5555 if (rtmp & 1)
5556 result *= ltmp;
5557 if ((rtmp >>= 1) == 0)
5558 break;
5559 ltmp *= ltmp;
5560 }
5561 }
5562 }
5563 result;
5564 })
5566 Note that some of the above is compile-time collapsable, such as
5567 the first part of the if statements that checks the base type of
5568 l against int. The if statements are phrased that way to suggest
5569 an easy way to generate the if/else constructs here, knowing that
5570 the back end should (and probably does) eliminate the resulting
5571 dead code (either the int case or the non-int case), something
5572 it couldn't do without the redundant phrasing, requiring explicit
5573 dead-code elimination here, which would be kind of difficult to
5574 read. */
5576 {
5577 tree rtmp;
5578 tree ltmp;
5579 tree divide;
5580 tree basetypeof_l_is_int;
5581 tree se;
5582 tree t;
5584 basetypeof_l_is_int
5591 #ifndef HAHA
5602 else
5605 {
5606 tree hook;
5619 else
5621 }
5625 rtmp,
5626 r));
5628 ltmp,
5629 l));
5632 rtmp,
5636 result,
5640 {
5642 rtmp,
5644 integer_zero_node)),
5647 result,
5648 ffecom_tree_divide_
5651 ltmp,
5653 divide)));
5657 ltmp,
5659 integer_zero_node)),
5662 rtype,
5664 rtype,
5665 rtmp),
5667 integer_one_node)),
5669 integer_zero_node)))),
5672 result,
5674 ltype,
5675 result)));
5678 }
5680 result,
5684 ffecom_truth_value_invert
5687 rtmp,
5689 integer_zero_node)))),
5692 ltmp,
5693 ffecom_tree_divide_
5696 ltmp,
5698 divide)));
5700 rtmp,
5702 rtmp)));
5705 rtmp,
5709 rtmp,
5712 rtype,
5713 rtmp,
5714 integer_one_node))));
5716 ltmp,
5718 ltmp,
5719 ltmp)));
5725 rtmp,
5729 result,
5731 result,
5732 ltmp)));
5735 ffecom_truth_value
5737 rtmp,
5739 rtype,
5740 rtmp,
5741 integer_one_node))));
5743 ltmp,
5745 ltmp,
5746 ltmp)));
5757 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5760 {
5761 /* Make a BIND_EXPR for the BLOCK already made. */
5764 /* Remove the block from the tree at this point.
5765 It gets put back at the proper place
5766 when the BIND_EXPR is expanded. */
5768 }
5769 else
5771 }
5774 }
5776 /* ffecom_expr_transform_ -- Transform symbols in expr
5778 ffebld expr; // FFE expression.
5779 ffecom_expr_transform_ (expr);
5781 Recursive descent on expr while transforming any untransformed SYMTERs. */
5783 static void
5785 {
5786 tree t;
5787 ffesymbol s;
5789 tail_recurse:
5795 {
5803 {
5806 DIMENSION expr? */
5807 }
5817 }
5820 {
5832 }
5835 }
5837 /* Make a type based on info in live f2c.h file. */
5839 static void
5841 {
5843 {
5866 ? signed_char_type_node
5900 }
5905 }
5907 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5908 given size. */
5910 static void
5913 {
5915 tree t;
5920 {
5924 }
5925 }
5927 /* Finish up globals after doing all program units in file
5929 Need to handle only uninitialized COMMON areas. */
5931 static ffeglobal
5933 {
5934 tree cbtype;
5935 tree cbt;
5936 tree size;
5951 /* Give the array a size now. */
5959 integer_zero_node,
5960 size);
5971 }
5973 /* Finish up any untransformed symbols. */
5975 static ffesymbol
5977 {
5981 /* It's easy to know to transform an untransformed symbol, to make sure
5982 we put out debugging info for it. But COMMON variables, unlike
5983 EQUIVALENCE ones, aren't given declarations in addition to the
5984 tree expressions that specify offsets, because COMMON variables
5985 can be referenced in the outer scope where only dummy arguments
5986 (PARM_DECLs) should really be seen. To be safe, just don't do any
5987 VAR_DECLs for COMMON variables when we transform them for real
5988 use, and therefore we do all the VAR_DECL creating here. */
5991 {
5996 /* Not transformed, and not CHARACTER*(*), and not a dummy
5997 argument, which can happen only if the entry point names
5998 it "rides in on" are all invalidated for other reasons. */
6000 }
6004 {
6005 /* This isn't working, at least for dbxout. The .s file looks
6006 okay to me (burley), but in gdb 4.9 at least, the variables
6007 appear to reside somewhere outside of the common area, so
6008 it doesn't make sense to mislead anyone by generating the info
6009 on those variables until this is fixed. NOTE: Same problem
6010 with EQUIVALENCE, sadly...see similar #if later. */
6013 }
6016 }
6018 /* Append underscore(s) to name before calling get_identifier. "us"
6019 is nonzero if the name already contains an underscore and thus
6020 needs two underscores appended. */
6022 static tree
6024 {
6027 tree id;
6041 }
6043 /* Decide whether to append underscore to name before calling
6044 get_identifier. */
6046 static tree
6048 {
6052 /* If name is a built-in name, just return it as is. */
6056 #if FFETARGET_isENFORCED_MAIN_NAME
6058 #else
6060 #endif
6069 }
6071 /* Decide whether to append underscore to internal name before calling
6072 get_identifier.
6074 This is for non-external, top-function-context names only. Transform
6075 identifier so it doesn't conflict with the transformed result
6076 of using a _different_ external name. E.g. if "CALL FOO" is
6077 transformed into "FOO_();", then the variable in "FOO_ = 3"
6078 must be transformed into something that does not conflict, since
6079 these two things should be independent.
6081 The transformation is as follows. If the name does not contain
6082 an underscore, there is no possible conflict, so just return.
6083 If the name does contain an underscore, then transform it just
6084 like we transform an external identifier. */
6086 static tree
6088 {
6089 /* If name does not contain an underscore, just return it as is. */
6096 name);
6097 }
6099 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6101 tree t;
6102 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6103 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6104 ffesymbol_kindtype(s));
6106 Call after setting up containing function and getting trees for all
6107 other symbols. */
6109 static tree
6111 {
6113 tree type;
6114 tree func;
6115 tree result;
6123 /* For now, we don't have a handy pointer to where the sfunc is actually
6124 defined, though that should be easy to add to an ffesymbol. (The
6125 token/where info available might well point to the place where the type
6126 of the sfunc is declared, especially if that precedes the place where
6127 the sfunc itself is defined, which is typically the case.) We should
6128 put out a null pointer rather than point somewhere wrong, but I want to
6129 see how it works at this point. */
6134 /* Pretransform the expression so any newly discovered things belong to the
6135 outer program unit, not to the statement function. */
6139 /* Make sure no recursive invocation of this fn (a specific case of failing
6140 to pretransform an sfunc's expression, i.e. where its expression
6141 references another untransformed sfunc) happens. */
6150 else
6151 {
6155 error. */
6156 }
6163 /* We don't worry about COMPLEX return values here, because this is
6164 entirely internal to our code, and gcc has the ability to return COMPLEX
6165 directly as a value. */
6169 tree type;
6181 }
6182 else
6192 {
6194 {
6196 tree result_length;
6207 }
6208 else
6209 {
6217 }
6218 }
6235 }
6239 {
6241 }
6243 static tree
6245 {
6252 }
6254 /* Return initialize-to-zero expression for this VAR_DECL. */
6256 /* A somewhat evil way to prevent the garbage collector
6257 from collecting 'tree' structures. */
6258 #define NUM_TRACKED_CHUNK 63
6259 static struct tree_ggc_tracker
6260 {
6265 static void
6267 {
6274 {
6278 }
6279 }
6281 void
6283 {
6288 {
6291 }
6293 {
6294 /* Need to allocate a new block. */
6302 }
6303 }
6305 static tree
6307 {
6308 tree init;
6313 {
6316 }
6324 {
6328 }
6329 else
6330 {
6333 }
6336 }
6338 static tree
6341 {
6342 tree expr_tree;
6343 tree length_tree;
6346 {
6349 (ffebld_constant_character1
6351 {
6354 }
6358 (ffebld_constant_character1
6372 {
6375 }
6378 {
6381 }
6383 expr_tree
6386 expr_tree);
6387 expr_tree
6390 expr_tree,
6391 integer_one_node);
6397 *maybe_tree
6398 = ffecom_truth_value
6400 length_tree,
6401 ffecom_f2c_ftnlen_zero_node));
6407 {
6410 }
6412 maybe_tree);
6415 {
6416 tree maybe_left;
6417 tree maybe_right;
6418 tree expr_left;
6419 tree expr_right;
6426 maybe_left,
6427 maybe_right);
6429 maybe_left,
6430 expr_left,
6431 expr_right);
6433 }
6438 }
6439 }
6441 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6443 tree length_arg;
6444 ffebld expr;
6445 length_arg = ffecom_intrinsic_len_ (expr);
6447 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6448 subexpressions by constructing the appropriate tree for the
6449 length-of-character-text argument in a calling sequence. */
6451 static tree
6453 {
6454 ffetargetCharacter1 val;
6455 tree length;
6458 {
6466 {
6468 tree item;
6472 {
6475 }
6477 {
6480 else
6481 {
6484 }
6485 }
6490 }
6498 {
6499 ffebld start;
6500 ffebld end;
6502 tree start_tree;
6503 tree end_tree;
6517 {
6519 ;
6520 else
6521 {
6524 }
6525 }
6526 else
6527 {
6532 {
6535 }
6538 {
6540 ffecom_f2c_ftnlen_one_node,
6542 ffecom_f2c_ftnlen_type_node,
6543 length,
6544 start_tree));
6545 }
6546 else
6547 {
6552 {
6555 }
6558 ffecom_f2c_ftnlen_one_node,
6560 ffecom_f2c_ftnlen_type_node,
6562 }
6563 }
6564 }
6568 length
6584 }
6589 }
6591 /* Handle CHARACTER assignments.
6593 Generates code to do the assignment. Used by ordinary assignment
6594 statement handler ffecom_let_stmt and by statement-function
6595 handler to generate code for a statement function. */
6597 static void
6600 {
6601 ffecomConcatList_ catlist;
6602 tree source_length;
6603 tree source_tree;
6604 tree expr_tree;
6613 /* Source might be an opCONVERT, which just means it is a different size
6614 than the destination. Since the underlying implementation here handles
6615 that (directly or via the s_copy or s_cat run-time-library functions),
6616 we don't need the "convenience" of an opCONVERT that tells us to
6617 truncate or blank-pad, particularly since the resulting implementation
6618 would probably be slower than otherwise. */
6625 {
6656 {
6657 dest_tree
6661 dest_tree);
6662 dest_tree
6666 dest_tree,
6667 integer_one_node);
6668 source_tree
6672 source_tree);
6673 source_tree
6677 source_tree,
6678 integer_one_node);
6685 }
6703 }
6705 /* Heavy-duty concatenation. */
6707 {
6710 tree lengths;
6711 tree items;
6712 tree length_array;
6713 tree item_array;
6714 tree citem;
6715 tree clength;
6717 #ifdef HOHO
6718 length_array
6719 = lengths
6723 FFETARGET_charactersizeNONE,
6725 #else
6726 {
6727 tree hook;
6735 }
6736 #endif
6739 {
6744 {
6747 }
6749 items
6754 item_array,
6756 citem),
6757 items);
6758 lengths
6763 length_array,
6765 clength),
6766 lengths);
6767 }
6774 items));
6779 lengths));
6781 = build_tree_list
6793 }
6796 }
6798 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6800 ffecomGfrt ix;
6801 ffecom_make_gfrt_(ix);
6803 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6804 for the indicated run-time routine (ix). */
6806 static void
6808 {
6809 tree t;
6810 tree ttype;
6813 {
6878 }
6883 ttype);
6889 /* Sanity check: A function that's const cannot be volatile. */
6893 /* Sanity check: A function that's const cannot return complex. */
6902 }
6904 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
6906 static void
6908 {
6913 }
6915 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
6916 the member so debugger will see it. Otherwise nobody should be
6917 referencing the member. */
6919 static void
6921 {
6922 ffesymbol s;
6923 tree t;
6924 tree mt;
6925 tree type;
6944 type);
6961 }
6963 /* Prepare source expression for assignment into a destination perhaps known
6964 to be of a specific size. */
6966 static void
6968 {
6969 ffecomConcatList_ catlist;
6972 tree ltmp;
6973 tree itmp;
6983 {
6984 ltmp
6987 itmp
6994 }
7002 {
7005 }
7006 }
7008 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7010 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
7011 (which generates their trees) and then their trees get push_parm_decl'd.
7013 The second arg is TRUE if the dummies are for a statement function, in
7014 which case lengths are not pushed for character arguments (since they are
7015 always known by both the caller and the callee, though the code allows
7016 for someday permitting CHAR*(*) stmtfunc dummies). */
7018 static void
7020 {
7021 ffebld dummy;
7022 ffebld dumlist;
7023 ffesymbol s;
7024 tree parm;
7028 /* First push the parms corresponding to actual dummy "contents". */
7031 {
7034 {
7041 }
7046 {
7050 }
7053 }
7055 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7058 {
7061 {
7065 NOTHING! */
7069 }
7075 length param. */
7082 }
7085 }
7087 /* ffecom_start_progunit_ -- Beginning of program unit
7089 Does GNU back end stuff necessary to teach it about the start of its
7090 equivalent of a Fortran program unit. */
7092 static void
7094 {
7096 ffebld arglist;
7100 ffeinfoBasictype bt;
7101 ffeinfoKindtype kt;
7102 ffeglobal g;
7103 ffeglobalType gt;
7108 bool multi
7109 = altentries
7123 {
7149 {
7155 }
7165 else
7172 else
7187 else
7195 /* Fall through. */
7204 }
7207 {
7210 }
7211 #if FFETARGET_isENFORCED_MAIN
7214 #endif
7215 else
7219 type,
7229 {
7231 }
7233 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7234 exec-transitioning needs current_function_decl to be filled in. So we
7235 do these things in two phases. */
7239 ffecom_which_entrypoint_decl_
7243 integer_type_node);
7245 }
7248 || cmplxfunc
7251 tree type;
7252 tree length;
7258 else
7263 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7267 else
7276 else
7280 {
7283 }
7284 }
7287 {
7290 else
7293 }
7299 /* Disallow temp vars at this level. */
7305 /* This handles any symbols still untransformed, in case -g specified.
7306 This used to be done in ffecom_finish_progunit, but it turns out to
7307 be necessary to do it here so that statement functions are
7308 expanded before code. But don't bother for BLOCK DATA. */
7312 }
7314 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7316 ffesymbol s;
7317 ffecom_sym_transform_(s);
7319 The ffesymbol_hook info for s is updated with appropriate backend info
7320 on the symbol. */
7322 static ffesymbol
7324 {
7328 ffeinfoBasictype bt;
7329 ffeinfoKindtype kt;
7330 ffeglobal g;
7334 /* Must ensure special ASSIGN variables are declared at top of outermost
7335 block, else they'll end up in the innermost block when their first
7336 ASSIGN is seen, which leaves them out of scope when they're the
7337 subject of a GOTO or I/O statement.
7339 We make this variable even if -fugly-assign. Just let it go unused,
7340 in case it turns out there are cases where we really want to use this
7341 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7349 {
7352 }
7353 else
7354 {
7359 }
7369 {
7372 {
7376 /* Before 0.4, this could be ENTITY/DUMMY, but see
7377 ffestu_sym_end_transition -- no longer true (in particular, if
7378 it could be an ENTITY, it _will_ be made one, so that
7379 possibility won't come through here). So we never make length
7380 arg for CHARACTER type. */
7384 ffecom_tree_ptr_to_subr_type);
7398 {
7401 }
7424 /* Fall through. */
7427 }
7432 {
7435 /* ~~Debugging info needed? */
7443 {
7445 tree type;
7449 {
7452 }
7457 {
7460 }
7465 ffestorag est;
7466 tree et;
7467 ffetargetOffset offset;
7484 /* (t_type *) (((char *) &et) + offset) */
7489 et));
7491 t,
7494 t);
7498 }
7499 else
7500 {
7501 tree initexpr;
7506 type);
7510 #ifdef FFECOM_sizeMAXSTACKITEM
7513 #endif
7515 && (ffecom_primary_entry_kind_
7519 else
7525 /* Keep -Wunused from complaining about var if it
7526 is used as sfunc arg or DATA implied-DO. */
7533 {
7536 else
7538 }
7541 else
7547 {
7551 }
7552 }
7553 }
7561 it (& length). */
7566 }
7571 it. */
7575 }
7577 {
7580 }
7583 {
7586 ffecom_multi_retval_);
7591 }
7605 {
7606 tree type;
7607 ffebld dl;
7608 ffebld dim;
7609 tree low;
7610 tree high;
7611 tree old_sizes;
7616 {
7619 context; get it later. */
7621 }
7624 }
7625 else
7638 {
7646 else
7651 {
7652 /* Used to just do high=low. But for ffecom_tree_
7653 canonize_ref_, it probably is important to correctly
7654 assess the size. E.g. given COMPLEX C(*),CFUNC and
7655 C(2)=CFUNC(C), overlap can happen, while it can't
7656 for, say, C(1)=CFUNC(C(2)). */
7657 /* Even more recently used to set to INT_MAX, but that
7658 broke when some overflow checking went into the back
7659 end. Now we just leave the upper bound unspecified. */
7661 }
7662 else
7665 /* Determine whether array is conditionally adjustable,
7666 to decide whether back-end magic is needed.
7668 Normally the front end uses the back-end function
7669 variable_size to wrap SAVE_EXPR's around expressions
7670 affecting the size/shape of an array so that the
7671 size/shape info doesn't change during execution
7672 of the compiled code even though variables and
7673 functions referenced in those expressions might.
7675 variable_size also makes sure those saved expressions
7676 get evaluated immediately upon entry to the
7677 compiled procedure -- the front end normally doesn't
7678 have to worry about that.
7680 However, there is a problem with this that affects
7681 g77's implementation of entry points, and that is
7682 that it is _not_ true that each invocation of the
7683 compiled procedure is permitted to evaluate
7684 array size/shape info -- because it is possible
7685 that, for some invocations, that info is invalid (in
7686 which case it is "promised" -- i.e. a violation of
7687 the Fortran standard -- that the compiled code
7688 won't reference the array or its size/shape
7689 during that particular invocation).
7691 To phrase this in C terms, consider this gcc function:
7693 void foo (int *n, float (*a)[*n])
7694 {
7695 // a is "pointer to array ...", fyi.
7696 }
7698 Suppose that, for some invocations, it is permitted
7699 for a caller of foo to do this:
7701 foo (NULL, NULL);
7703 Now the _written_ code for foo can take such a call
7704 into account by either testing explicitly for whether
7705 (a == NULL) || (n == NULL) -- presumably it is
7706 not permitted to reference *a in various fashions
7707 if (n == NULL) I suppose -- or it can avoid it by
7708 looking at other info (other arguments, static/global
7709 data, etc.).
7711 However, this won't work in gcc 2.5.8 because it'll
7712 automatically emit the code to save the "*n"
7713 expression, which'll yield a NULL dereference for
7714 the "foo (NULL, NULL)" call, something the code
7715 for foo cannot prevent.
7717 g77 definitely needs to avoid executing such
7718 code anytime the pointer to the adjustable array
7719 is NULL, because even if its bounds expressions
7720 don't have any references to possible "absent"
7721 variables like "*n" -- say all variable references
7722 are to COMMON variables, i.e. global (though in C,
7723 local static could actually make sense) -- the
7724 expressions could yield other run-time problems
7725 for allowably "dead" values in those variables.
7727 For example, let's consider a more complicated
7728 version of foo:
7730 extern int i;
7731 extern int j;
7733 void foo (float (*a)[i/j])
7734 {
7735 ...
7736 }
7738 The above is (essentially) quite valid for Fortran
7739 but, again, for a call like "foo (NULL);", it is
7740 permitted for i and j to be undefined when the
7741 call is made. If j happened to be zero, for
7742 example, emitting the code to evaluate "i/j"
7743 could result in a run-time error.
7745 Offhand, though I don't have my F77 or F90
7746 standards handy, it might even be valid for a
7747 bounds expression to contain a function reference,
7748 in which case I doubt it is permitted for an
7749 implementation to invoke that function in the
7750 Fortran case involved here (invocation of an
7751 alternate ENTRY point that doesn't have the adjustable
7752 array as one of its arguments).
7754 So, the code that the compiler would normally emit
7755 to preevaluate the size/shape info for an
7756 adjustable array _must not_ be executed at run time
7757 in certain cases. Specifically, for Fortran,
7758 the case is when the pointer to the adjustable
7759 array == NULL. (For gnu-ish C, it might be nice
7760 for the source code itself to specify an expression
7761 that, if TRUE, inhibits execution of the code. Or
7762 reverse the sense for elegance.)
7764 (Note that g77 could use a different test than NULL,
7765 actually, since it happens to always pass an
7766 integer to the called function that specifies which
7767 entry point is being invoked. Hmm, this might
7768 solve the next problem.)
7770 One way a user could, I suppose, write "foo" so
7771 it works is to insert COND_EXPR's for the
7772 size/shape info so the dangerous stuff isn't
7773 actually done, as in:
7775 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7776 {
7777 ...
7778 }
7780 The next problem is that the front end needs to
7781 be able to tell the back end about the array's
7782 decl _before_ it tells it about the conditional
7783 expression to inhibit evaluation of size/shape info,
7784 as shown above.
7786 To solve this, the front end needs to be able
7787 to give the back end the expression to inhibit
7788 generation of the preevaluation code _after_
7789 it makes the decl for the adjustable array.
7791 Until then, the above example using the COND_EXPR
7792 doesn't pass muster with gcc because the "(a == NULL)"
7793 part has a reference to "a", which is still
7794 undefined at that point.
7796 g77 will therefore use a different mechanism in the
7797 meantime. */
7808 low,
7809 ffecom_integer_zero_node);
7814 high,
7815 ffecom_integer_zero_node);
7816 #endif
7818 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7819 probably. Fixes 950302-1.f. */
7824 /* ~~~Similarly, this fixes dumb0.f. The C front end
7825 does this, which is why dumb0.c would work. */
7830 type
7831 = build_array_type
7836 }
7839 {
7842 }
7846 {
7849 }
7854 /* If this arg is present in every entry point's list of
7855 dummy args, then we're done. */
7861 #if 1
7863 /* If variable_size in stor-layout has been called during
7864 the above, then get_pending_sizes should have the
7865 yet-to-be-evaluated saved expressions pending.
7866 Make the whole lot of them get emitted, conditionally
7867 on whether the array decl ("t" above) is not NULL. */
7869 {
7871 tree tem;
7876 {
7881 else
7882 sizes
7885 temv,
7886 sizes);
7887 }
7890 {
7891 sizes
7895 integer_type_node,
7896 t,
7897 null_pointer_node),
7898 sizes,
7900 integer_zero_node));
7903 sizes
7905 }
7909 }
7911 #else
7912 #if 0
7918 t,
7919 null_pointer_node);
7920 #else
7921 #if 0
7925 {
7931 }
7932 #endif
7933 #endif
7934 #endif
7935 }
7939 {
7940 ffesymbol cs;
7941 ffeglobal cg;
7942 tree ct;
7944 tree type;
7948 {
7951 }
7959 else
7966 else
7967 {
7968 ffetargetOffset offset;
7969 ffestorag cst;
7980 /* (t_type *) (((char *) &ct) + offset) */
7985 ct));
7987 t,
7990 t);
7994 }
7995 }
8007 /* Fall through. */
8011 }
8016 {
8030 {
8033 }
8038 else
8043 t);
8065 else
8066 t = build_pointer_type
8071 t);
8084 decls. */
8088 /* Fall through. */
8092 }
8097 {
8111 {
8114 }
8118 ffecom_tree_subr_type);
8139 ffecom_tree_ptr_to_subr_type);
8147 decls. */
8151 /* Fall through. */
8155 }
8160 {
8179 /* Fall through. */
8183 }
8188 {
8199 ffecom_tree_blockdata_type);
8222 /* Fall through. */
8226 }
8231 {
8251 /* Fall through. */
8255 }
8260 {
8279 /* Fall through. */
8283 }
8288 {
8308 /* Fall through. */
8312 }
8317 /* Fall through. */
8321 }
8331 }
8333 /* Transform into ASSIGNable symbol.
8335 Symbol has already been transformed, but for whatever reason, the
8336 resulting decl_tree has been deemed not usable for an ASSIGN target.
8337 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8338 another local symbol of type void * and stuff that in the assign_tree
8339 argument. The F77/F90 standards allow this implementation. */
8341 static ffesymbol
8343 {
8349 {
8352 }
8353 else
8354 {
8359 }
8369 {
8371 /* Unlike for regular vars, SAVE status is easy to determine for
8372 ASSIGNed vars, since there's no initialization, there's no
8373 effective storage association (so "SAVE J" does not apply to
8374 K even given "EQUIVALENCE (J,K)"), there's no size issue
8375 to worry about, etc. */
8380 else
8389 /* Note that twinning a DUMMY means the caller won't see
8390 the ASSIGNed value. But both F77 and F90 allow implementations
8391 to do this, i.e. disallow Fortran code that would try and
8392 take advantage of actually putting a label into a variable
8393 via a dummy argument (or any other storage association, for
8394 that matter). */
8401 }
8412 }
8414 /* Implement COMMON area in back end.
8416 Because COMMON-based variables can be referenced in the dimension
8417 expressions of dummy (adjustable) arrays, and because dummies
8418 (in the gcc back end) need to be put in the outer binding level
8419 of a function (which has two binding levels, the outer holding
8420 the dummies and the inner holding the other vars), special care
8421 must be taken to handle COMMON areas.
8423 The current strategy is basically to always tell the back end about
8424 the COMMON area as a top-level external reference to just a block
8425 of storage of the master type of that area (e.g. integer, real,
8426 character, whatever -- not a structure). As a distinct action,
8427 if initial values are provided, tell the back end about the area
8428 as a top-level non-external (initialized) area and remember not to
8429 allow further initialization or expansion of the area. Meanwhile,
8430 if no initialization happens at all, tell the back end about
8431 the largest size we've seen declared so the space does get reserved.
8432 (This function doesn't handle all that stuff, but it does some
8433 of the important things.)
8435 Meanwhile, for COMMON variables themselves, just keep creating
8436 references like *((float *) (&common_area + offset)) each time
8437 we reference the variable. In other words, don't make a VAR_DECL
8438 or any kind of component reference (like we used to do before 0.4),
8439 though we might do that as well just for debugging purposes (and
8440 stuff the rtl with the appropriate offset expression). */
8442 static void
8444 {
8447 tree cbt;
8448 tree cbtype;
8449 tree init;
8450 tree high;
8459 /* First update the size of the area in global terms. */
8468 /* If we already have declared this common block for a previous program
8469 unit, and either we already initialized it or we don't have new
8470 initialization for it, just return what we have without changing it. */
8473 && (!is_init
8475 {
8478 }
8480 /* Process inits. */
8483 {
8485 {
8486 ffebld sexp;
8488 /* Set the padding for the expression, so ffecom_expr
8489 knows to insert that many zeros. */
8491 {
8507 }
8515 }
8516 }
8517 else
8519 }
8520 else
8523 /* cbtype must be permanently allocated! */
8525 /* Allocate the MAX of the areas so far, seen filewide. */
8533 integer_zero_node,
8534 high));
8535 else
8539 {
8540 cbt
8543 cbtype);
8546 }
8547 else
8548 {
8551 }
8561 /* Make sure that any type can live in COMMON and be referenced
8562 without getting a bus error. We could pick the most restrictive
8563 alignment of all entities actually placed in the COMMON, but
8564 this seems easy enough. */
8578 {
8584 }
8591 }
8593 /* Make master area for local EQUIVALENCE. */
8595 static void
8597 {
8598 tree eqt;
8599 tree eqtype;
8600 tree init;
8601 tree high;
8611 /* Process inits. */
8614 {
8616 {
8617 ffebld sexp;
8619 /* Set the padding for the expression, so ffecom_expr
8620 knows to insert that many zeros. */
8622 {
8638 }
8643 }
8644 else
8646 }
8649 else
8655 eqst);
8663 ffecom_integer_zero_node,
8664 high));
8668 ffesymbol_text
8670 eqtype);
8673 || ffecom_member_namelisted_
8674 #ifdef FFECOM_sizeMAXSTACKITEM
8676 #endif
8681 else
8688 else
8693 /* Make sure that any type can live in EQUIVALENCE and be referenced
8694 without getting a bus error. We could pick the most restrictive
8695 alignment of all entities actually placed in the EQUIVALENCE, but
8696 this seems easy enough. */
8710 {
8715 }
8721 eqst);
8722 }
8724 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8726 static tree
8728 {
8729 tree nmlt;
8731 tree nmlinits;
8732 tree nameinit;
8733 tree varsinit;
8734 tree nvarsinit;
8735 tree field;
8736 tree high;
8742 mynumber++),
8743 nmltype);
8749 /* Process inits. */
8759 = build_type_variant
8760 (build_array_type
8763 ffecom_f2c_ftnlen_one_node,
8764 high)),
8769 nameinit);
8773 varsinit);
8777 {
8778 ffebld b;
8782 }
8790 varsinit);
8803 }
8805 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8806 analyzed on the assumption it is calculating a pointer to be
8807 indirected through. It must return the proper decl and offset,
8808 taking into account different units of measurements for offsets. */
8810 static void
8812 tree t)
8813 {
8815 {
8829 {
8830 /* An offset into COMMON. */
8833 /* Convert offset (presumably in bytes) into canonical units
8834 (presumably bits). */
8839 }
8840 /* Not a COMMON reference, so an unrecognized pattern. */
8851 {
8852 /* A reference to COMMON. */
8856 }
8857 /* Fall through. */
8859 /* Not a COMMON reference, so an unrecognized pattern. */
8862 }
8863 }
8865 /* Given a tree that is possibly intended for use as an lvalue, return
8866 information representing a canonical view of that tree as a decl, an
8867 offset into that decl, and a size for the lvalue.
8869 If there's no applicable decl, NULL_TREE is returned for the decl,
8870 and the other fields are left undefined.
8872 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8873 is returned for the decl, and the other fields are left undefined.
8875 Otherwise, the decl returned currently is either a VAR_DECL or a
8876 PARM_DECL.
8878 The offset returned is always valid, but of course not necessarily
8879 a constant, and not necessarily converted into the appropriate
8880 type, leaving that up to the caller (so as to avoid that overhead
8881 if the decls being looked at are different anyway).
8883 If the size cannot be determined (e.g. an adjustable array),
8884 an ERROR_MARK node is returned for the size. Otherwise, the
8885 size returned is valid, not necessarily a constant, and not
8886 necessarily converted into the appropriate type as with the
8887 offset.
8889 Note that the offset and size expressions are expressed in the
8890 base storage units (usually bits) rather than in the units of
8891 the type of the decl, because two decls with different types
8892 might overlap but with apparently non-overlapping array offsets,
8893 whereas converting the array offsets to consistant offsets will
8894 reveal the overlap. */
8896 static void
8899 {
8900 /* The default path is to report a nonexistant decl. */
8907 {
8977 {
8980 tree init_offset;
8984 {
8987 }
8990 array);
8995 /* Calculate ((element - base) * NBBY) + init_offset. */
8997 element,
9009 }
9013 /* Most of this code is to handle references to COMMON. And so
9014 far that is useful only for calling library functions, since
9015 external (user) functions might reference common areas. But
9016 even calling an external function, it's worthwhile to decode
9017 COMMON references because if not storing into COMMON, we don't
9018 want COMMON-based arguments to gratuitously force use of a
9019 temporary. */
9045 }
9046 }
9048 /* Do divide operation appropriate to type of operands. */
9050 static tree
9053 tree hook)
9054 {
9060 {
9063 left,
9064 right);
9069 left,
9070 right);
9071 {
9072 ffecomGfrt ix;
9077 else
9082 left);
9086 right);
9093 tree_type,
9094 left,
9097 }
9101 {
9102 ffecomGfrt ix;
9107 else
9112 left);
9116 right);
9123 tree_type,
9124 left,
9127 }
9132 left,
9133 right);
9134 }
9135 }
9137 /* Build type info for non-dummy variable. */
9139 static tree
9141 ffeinfoKindtype kt)
9142 {
9143 tree type;
9144 ffebld dl;
9145 ffebld dim;
9146 tree lowt;
9147 tree hight;
9151 {
9155 type
9156 = build_array_type
9159 ffecom_f2c_ftnlen_one_node,
9160 hight));
9162 }
9165 {
9174 else
9190 }
9193 }
9195 /* Build Namelist type. */
9197 static tree
9199 {
9203 {
9205 tree vardesctype;
9214 string_type_node);
9217 integer_type_node);
9223 }
9226 }
9228 /* Build Vardesc type. */
9230 static tree
9232 {
9237 {
9241 string_type_node);
9243 string_type_node);
9245 ffecom_f2c_ptr_to_ftnlen_type_node);
9247 integer_type_node);
9253 }
9256 }
9258 static tree
9260 {
9261 ffesymbol s;
9267 {
9270 tree var;
9271 tree nameinit;
9272 tree dimsinit;
9273 tree addrinit;
9274 tree typeinit;
9275 tree field;
9276 tree varinits;
9281 mynumber++),
9282 vardesctype);
9288 /* Process inits. */
9294 = build_type_variant
9295 (build_array_type
9298 integer_one_node,
9305 nameinit);
9312 {
9319 }
9320 else
9324 nameinit);
9326 addrinit);
9341 }
9344 }
9346 static tree
9348 {
9349 ffebld b;
9350 tree list;
9352 tree var;
9359 {
9360 tree t;
9366 else
9367 {
9370 }
9371 }
9375 integer_one_node,
9389 }
9391 static tree
9393 {
9396 integer_zero_node);
9398 {
9399 ffebld b;
9400 ffebld e;
9401 tree list;
9402 tree backlist;
9404 tree var;
9405 tree numdim;
9406 tree numelem;
9421 {
9422 tree t;
9423 tree low;
9424 tree back;
9428 else
9429 {
9435 else
9436 {
9439 }
9440 }
9444 else
9451 }
9454 {
9457 else
9461 ffecom_f2c_ftnlen_type_node,
9463 baseoff));
9464 }
9466 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9479 integer_zero_node,
9480 build_int_2
9497 }
9498 }
9500 /* Essentially does a "fold (build1 (code, type, node))" while checking
9501 for certain housekeeping things.
9503 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9504 ffecom_1_fn instead. */
9506 tree
9508 {
9509 tree item;
9516 {
9519 }
9522 {
9523 tree realtype;
9536 {
9539 }
9542 item =
9546 node)),
9549 node)));
9555 }
9564 }
9566 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9567 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9568 does not set TREE_ADDRESSABLE (because calling an inline
9569 function does not mean the function needs to be separately
9570 compiled). */
9572 tree
9574 {
9575 tree item;
9576 tree type;
9591 }
9593 /* Essentially does a "fold (build (code, type, node1, node2))" while
9594 checking for certain housekeeping things. */
9596 tree
9598 tree node2)
9599 {
9600 tree item;
9608 {
9623 {
9626 }
9630 item =
9634 node1),
9636 node2)),
9639 node1),
9641 node2)));
9646 {
9649 }
9653 item =
9657 node1),
9659 node2)),
9662 node1),
9664 node2)));
9669 {
9672 }
9677 node1));
9679 node1));
9681 node2));
9683 node2));
9684 item =
9688 a,
9689 c),
9691 b,
9692 d)),
9695 a,
9696 d),
9698 c,
9699 b)));
9705 {
9708 }
9714 item =
9718 node1),
9720 node2)),
9723 node1),
9725 node2)));
9731 {
9734 }
9740 item =
9744 node1),
9746 node2)),
9749 node1),
9751 node2)));
9757 }
9762 }
9764 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9766 ffesymbol s; // the ENTRY point itself
9767 if (ffecom_2pass_advise_entrypoint(s))
9768 // the ENTRY point has been accepted
9770 Does whatever compiler needs to do when it learns about the entrypoint,
9771 like determine the return type of the master function, count the
9772 number of entrypoints, etc. Returns FALSE if the return type is
9773 not compatible with the return type(s) of other entrypoint(s).
9775 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9776 later (after _finish_progunit) be called with the same entrypoint(s)
9777 as passed to this fn for which TRUE was returned.
9779 03-Jan-92 JCB 2.0
9780 Return FALSE if the return type conflicts with previous entrypoints. */
9782 bool
9784 {
9798 arglist's dummies. */
9808 {
9815 else
9818 }
9819 }
9821 /* If necessary, scan entry arglist for alternate returns. Do this scan
9822 apparently redundantly (it's done below to UNIONize the arglists) so
9823 that we don't complain about RETURN 1 if an offending ENTRY is the only
9824 one with an alternate return. */
9827 {
9831 {
9834 {
9837 }
9838 }
9839 }
9841 /* Now check type compatibility. */
9844 {
9850 ok
9861 {
9864 }
9867 {
9870 }
9872 }
9875 {
9880 }
9882 /* Entrypoint type compatible with previous types. */
9886 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9891 {
9900 appending of arg. */
9903 }
9907 /* Append this arg to the master list. */
9912 else
9914 }
9917 }
9919 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9921 ffesymbol s; // the ENTRY point itself
9922 ffecom_2pass_do_entrypoint(s);
9924 Does whatever compiler needs to do to make the entrypoint actually
9925 happen. Must be called for each entrypoint after
9926 ffecom_finish_progunit is called. */
9928 void
9930 {
9939 }
9940 else
9946 }
9948 /* Essentially does a "fold (build (code, type, node1, node2))" while
9949 checking for certain housekeeping things. Always sets
9950 TREE_SIDE_EFFECTS. */
9952 tree
9954 tree node2)
9955 {
9956 tree item;
9966 }
9968 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9969 checking for certain housekeeping things. */
9971 tree
9974 {
9975 tree item;
9988 }
9990 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9991 checking for certain housekeeping things. Always sets
9992 TREE_SIDE_EFFECTS. */
9994 tree
9997 {
9998 tree item;
10009 }
10011 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10013 See use by ffecom_list_expr.
10015 If expression is NULL, returns an integer zero tree. If it is not
10016 a CHARACTER expression, returns whatever ffecom_expr
10017 returns and sets the length return value to NULL_TREE. Otherwise
10018 generates code to evaluate the character expression, returns the proper
10019 pointer to the result, but does NOT set the length return value to a tree
10020 that specifies the length of the result. (In other words, the length
10021 variable is always set to NULL_TREE, because a length is never passed.)
10023 21-Dec-91 JCB 1.1
10024 Don't set returned length, since nobody needs it (yet; someday if
10025 we allow CHARACTER*(*) dummies to statement functions, we'll need
10026 it). */
10028 tree
10030 {
10031 tree ign;
10042 }
10044 /* Transform expression into constant argument-pointer-to-expression tree.
10046 If the expression can be transformed into a argument-pointer-to-expression
10047 tree that is constant, that is done, and the tree returned. Else
10048 NULL_TREE is returned.
10050 That way, a caller can attempt to provide compile-time initialization
10051 of a variable and, if that fails, *then* choose to start a new block
10052 and resort to using temporaries, as appropriate. */
10054 tree
10056 {
10061 {
10065 }
10072 {
10073 tree t;
10079 }
10087 }
10089 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10091 See use by ffecom_list_ptr_to_expr.
10093 If expression is NULL, returns an integer zero tree. If it is not
10094 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10095 returns and sets the length return value to NULL_TREE. Otherwise
10096 generates code to evaluate the character expression, returns the proper
10097 pointer to the result, AND sets the length return value to a tree that
10098 specifies the length of the result.
10100 If the length argument is NULL, this is a slightly special
10101 case of building a FORMAT expression, that is, an expression that
10102 will be used at run time without regard to length. For the current
10103 implementation, which uses the libf2c library, this means it is nice
10104 to append a null byte to the end of the expression, where feasible,
10105 to make sure any diagnostic about the FORMAT string terminates at
10106 some useful point.
10108 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10109 length argument. This might even be seen as a feature, if a null
10110 byte can always be appended. */
10112 tree
10114 {
10115 tree item;
10116 tree ign_length;
10117 ffecomConcatList_ catlist;
10126 {
10130 {
10131 tree temp_exp;
10132 tree temp_length;
10139 temp_exp);
10140 }
10146 {
10149 }
10155 {
10156 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10158 #endif
10167 }
10172 }
10174 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10178 ffetargetHollerith h;
10183 *length
10186 }
10187 #endif
10200 {
10203 {
10206 }
10214 else
10223 }
10225 {
10228 tree lengths;
10229 tree items;
10230 tree length_array;
10231 tree item_array;
10232 tree citem;
10233 tree clength;
10234 tree temporary;
10235 tree num;
10236 tree known_length;
10237 ffetargetCharacterSize sz;
10240 /* ~~Kludge! */
10243 #ifdef HOHO
10244 length_array
10245 = lengths
10248 item_array
10249 = items
10254 #else
10255 {
10256 tree hook;
10265 }
10266 #endif
10271 {
10276 else
10281 {
10285 }
10287 items
10292 item_array,
10294 citem),
10295 items);
10298 known_length
10300 known_length,
10301 clength);
10302 lengths
10307 length_array,
10309 clength),
10310 lengths);
10311 }
10315 temporary);
10322 items));
10327 lengths));
10329 = build_tree_list
10342 item,
10343 temporary);
10347 }
10352 }
10354 /* Generate call to run-time function.
10356 The first arg is the GNU Fortran Run-Time function index, the second
10357 arg is the list of arguments to pass to it. Returned is the expression
10358 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10359 result (which may be void). */
10361 tree
10363 {
10369 }
10371 /* Transform constant-union to tree. */
10373 tree
10376 {
10377 tree item;
10380 {
10382 {
10386 {
10387 #if FFETARGET_okINTEGER1
10391 #endif
10393 #if FFETARGET_okINTEGER2
10397 #endif
10399 #if FFETARGET_okINTEGER3
10403 #endif
10405 #if FFETARGET_okINTEGER4
10409 #endif
10413 /* Fall through. */
10416 }
10419 }
10423 {
10427 {
10428 #if FFETARGET_okLOGICAL1
10432 #endif
10434 #if FFETARGET_okLOGICAL2
10438 #endif
10440 #if FFETARGET_okLOGICAL3
10444 #endif
10446 #if FFETARGET_okLOGICAL4
10450 #endif
10454 /* Fall through. */
10457 }
10460 }
10464 {
10465 REAL_VALUE_TYPE val;
10468 {
10469 #if FFETARGET_okREAL1
10473 #endif
10475 #if FFETARGET_okREAL2
10479 #endif
10481 #if FFETARGET_okREAL3
10485 #endif
10487 #if FFETARGET_okREAL4
10491 #endif
10495 /* Fall through. */
10498 }
10500 }
10504 {
10505 REAL_VALUE_TYPE real;
10506 REAL_VALUE_TYPE imag;
10510 {
10511 #if FFETARGET_okCOMPLEX1
10516 #endif
10518 #if FFETARGET_okCOMPLEX2
10523 #endif
10525 #if FFETARGET_okCOMPLEX3
10530 #endif
10532 #if FFETARGET_okCOMPLEX4
10537 #endif
10541 /* Fall through. */
10544 }
10548 }
10553 ffetargetCharacter1 val;
10556 {
10557 #if FFETARGET_okCHARACTER1
10561 #endif
10565 /* Fall through. */
10568 }
10573 build_range_type
10575 integer_one_node,
10576 build_int_2
10577 (ffetarget_length_character1
10580 }
10584 {
10585 ffetargetHollerith h;
10589 /* If not at least as wide as default INTEGER, widen it. */
10592 else
10593 {
10598 FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10601 str);
10602 }
10605 build_range_type
10607 integer_one_node,
10608 build_int_2
10611 }
10615 {
10616 ffetargetInteger1 ival;
10617 ffetargetTypeless tless;
10618 ffebad error;
10625 }
10630 /* Fall through. */
10633 }
10638 }
10640 /* Transform expression into constant tree.
10642 If the expression can be transformed into a tree that is constant,
10643 that is done, and the tree returned. Else NULL_TREE is returned.
10645 That way, a caller can attempt to provide compile-time initialization
10646 of a variable and, if that fails, *then* choose to start a new block
10647 and resort to using temporaries, as appropriate. */
10649 tree
10651 {
10660 #if NEWCOMMON
10661 /* ~~Enable once common/equivalence is handled properly? */
10663 #endif
10666 {
10667 tree t;
10672 }
10675 }
10677 /* Handy way to make a field in a struct/union. */
10679 tree
10682 {
10683 tree field;
10693 }
10695 void
10697 {
10699 }
10701 int
10703 {
10705 }
10707 /* End a compound statement (block). */
10709 tree
10711 {
10713 }
10715 /* ffecom_end_transition -- Perform end transition on all symbols
10717 ffecom_end_transition();
10719 Calls ffecom_sym_end_transition for each global and local symbol. */
10721 void
10723 {
10724 ffebld item;
10734 {
10736 }
10743 {
10744 ffebld callee;
10745 ffesymbol s;
10746 tree dt;
10747 tree t;
10748 tree var;
10755 {
10758 }
10764 number++),
10765 dt);
10777 }
10779 /* This handles any COMMON areas that weren't referenced but have, for
10780 example, important initial data. */
10788 }
10790 /* ffecom_exec_transition -- Perform exec transition on all symbols
10792 ffecom_exec_transition();
10794 Calls ffecom_sym_exec_transition for each global and local symbol.
10795 Make sure error updating not inhibited. */
10797 void
10799 {
10811 {
10813 }
10817 }
10819 /* Handle assignment statement.
10821 Convert dest and source using ffecom_expr, then join them
10822 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
10824 void
10826 {
10827 tree dest_tree;
10828 tree dest_length;
10829 tree source_tree;
10830 tree expr_tree;
10833 {
10835 tree assign_temp;
10837 /* This attempts to replicate the test below, but must not be
10838 true when the test below is false. (Always err on the side
10839 of creating unused temporaries, to avoid ICEs.) */
10844 {
10847 }
10848 else
10849 {
10852 }
10856 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10857 create a temporary through which the assignment is to take place,
10858 since MODIFY_EXPR doesn't handle partial overlap properly. */
10861 {
10863 ffecom_tree_type
10866 FFETARGET_charactersizeNONE,
10868 }
10869 else
10882 else
10883 {
10887 }
10894 {
10895 #ifdef MOVE_EXPR
10896 /* The back end understands a conceptual move (evaluate source;
10897 store into dest), so use that, in case it can determine
10898 that it is going to use, say, two registers as temporaries
10899 anyway. So don't use the temp (and someday avoid generating
10900 it, once this code starts triggering regularly). */
10902 dest_tree,
10903 source_tree);
10904 #else
10906 assign_temp,
10907 source_tree);
10910 dest_tree,
10911 assign_temp);
10912 #endif
10913 }
10914 else
10916 dest_tree,
10917 source_tree);
10921 }
10930 source);
10931 }
10933 /* ffecom_expr -- Transform expr into gcc tree
10935 tree t;
10936 ffebld expr; // FFE expression.
10937 tree = ffecom_expr(expr);
10939 Recursive descent on expr while making corresponding tree nodes and
10940 attaching type info and such. */
10942 tree
10944 {
10946 }
10948 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
10950 tree
10952 {
10954 }
10956 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
10958 tree
10960 {
10962 }
10964 /* Transform expr for use as into read/write tree and stabilize the
10965 reference. Not for use on CHARACTER expressions.
10967 Recursive descent on expr while making corresponding tree nodes and
10968 attaching type info and such. */
10970 tree
10972 {
10974 /* Different target types not yet supported. */
10978 }
10980 /* Transform expr for use as into write tree and stabilize the
10981 reference. Not for use on CHARACTER expressions.
10983 Recursive descent on expr while making corresponding tree nodes and
10984 attaching type info and such. */
10986 tree
10988 {
10990 /* Different target types not yet supported. */
10994 }
10996 /* Do global stuff. */
10998 void
11000 {
11005 }
11007 /* Public entry point for front end to access finish_decl. */
11009 void
11011 {
11014 }
11016 /* Finish a program unit. */
11018 void
11020 {
11027 }
11029 /* Wrapper for get_identifier. pattern is sprintf-like. */
11031 tree
11033 {
11034 tree decl;
11046 }
11048 ffeinfoBasictype
11050 {
11054 {
11092 }
11093 }
11095 ffeinfoKindtype
11097 {
11101 {
11139 }
11140 }
11142 void
11144 {
11145 tree endlink;
11148 tree t;
11149 tree field;
11150 ffetype type;
11151 ffetype base_type;
11152 tree double_ftype_double;
11153 tree float_ftype_float;
11154 tree ldouble_ftype_ldouble;
11155 tree ffecom_tree_ptr_to_fun_type_void;
11157 /* This block of code comes from the now-obsolete cktyps.c. It checks
11158 whether the compiler environment is buggy in known ways, some of which
11159 would, if not explicitly checked here, result in subtle bugs in g77. */
11162 {
11164 =
11173 {
11177 }
11181 {
11185 }
11189 {
11193 }
11194 }
11201 /* Make the binding_level structure for global names. */
11208 /* Define `int' and `char' first so that dbx will output them first. */
11210 integer_type_node));
11211 /* CHARACTER*1 is unsigned in ICHAR contexts. */
11214 char_type_node));
11216 long_integer_type_node));
11218 unsigned_type_node));
11220 long_unsigned_type_node));
11222 long_long_integer_type_node));
11224 long_long_unsigned_type_node));
11226 short_integer_type_node));
11228 short_unsigned_type_node));
11230 /* Set the sizetype before we make other types. This *should* be the
11231 first type we create. */
11233 set_sizetype
11235 ffecom_typesize_pointer_
11240 /* Define both `signed char' and `unsigned char'. */
11242 signed_char_type_node));
11245 unsigned_char_type_node));
11248 float_type_node));
11250 double_type_node));
11252 long_double_type_node));
11254 /* For now, override what build_common_tree_nodes has done. */
11258 complex_long_double_type_node
11262 complex_integer_type_node));
11264 complex_float_type_node));
11266 complex_double_type_node));
11268 complex_long_double_type_node));
11271 void_type_node));
11272 /* We are not going to have real types in C with less than byte alignment,
11273 so we might as well not have any types that claim to have it. */
11279 ffecom_tree_fun_type_void
11282 ffecom_tree_ptr_to_fun_type_void
11287 float_ftype_float
11291 double_ftype_double
11295 ldouble_ftype_ldouble
11298 endlink));
11302 {
11307 }
11309 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11310 to size FLOAT_TYPE_SIZE because they have to be the same size as
11311 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11312 Compiler options and other such stuff that change the ways these
11313 types are set should not affect this particular setup. */
11318 t));
11322 type);
11328 type);
11336 t));
11341 t));
11344 type);
11350 type);
11357 t));
11362 t));
11365 type);
11371 type);
11378 t));
11383 t));
11386 type);
11392 type);
11399 t));
11401 #if 0
11407 {
11409 LONG_TYPE_SIZE);
11410 }
11411 #endif
11416 t));
11420 type);
11426 type);
11433 t));
11436 type);
11442 type);
11449 t));
11452 type);
11458 type);
11465 t));
11468 type);
11474 type);
11482 t));
11487 type);
11493 type);
11503 t));
11507 type);
11513 type);
11520 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11522 t));
11526 type);
11532 type);
11539 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11541 t));
11544 type);
11550 type);
11552 type);
11557 /* Make function and ptr-to-function types for non-CHARACTER types. */
11561 {
11563 {
11565 {
11566 /* Figure out the smallest INTEGER type that can hold
11567 a pointer on this machine. */
11570 {
11575 }
11576 }
11579 /* For f2c compatibility, REAL functions are really
11580 implemented as DOUBLE PRECISION. */
11583 t = ffecom_tree_type
11587 NULL_TREE);
11589 }
11590 }
11592 /* Set up pointer types. */
11599 FFEINFO_kindtypeINTEGERDEFAULT),
11602 ffecom_pointer_kind_));
11606 else
11611 ffecom_integer_type_node
11614 integer_zero_node);
11616 integer_one_node);
11618 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11619 Turns out that by TYLONG, runtime/libI77/lio.h really means
11620 "whatever size an ftnint is". For consistency and sanity,
11621 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11622 all are INTEGER, which we also make out of whatever back-end
11623 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11624 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11625 accommodate machines like the Alpha. Note that this suggests
11626 f2c and libf2c are missing a distinction perhaps needed on
11627 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11630 FFETARGET_f2cTYLONG);
11632 FFETARGET_f2cTYSHORT);
11634 FFETARGET_f2cTYINT1);
11636 FFETARGET_f2cTYQUAD);
11638 FFETARGET_f2cTYLOGICAL);
11640 FFETARGET_f2cTYLOGICAL2);
11642 FFETARGET_f2cTYLOGICAL1);
11643 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11645 FFETARGET_f2cTYQUAD);
11647 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11648 loop. CHARACTER items are built as arrays of unsigned char. */
11655 FFEINFO_kindtypeCHARACTER1,
11656 type);
11675 /* Make multi-return-value type and fields. */
11683 {
11700 }
11705 /* Subroutines usually return integer because they might have alternate
11706 returns. */
11708 ffecom_tree_subr_type
11710 ffecom_tree_ptr_to_subr_type
11712 ffecom_tree_blockdata_type
11737 FFECOM_f2cINTEGER,
11740 FFECOM_f2cADDRESS,
11743 FFECOM_f2cREAL,
11746 FFECOM_f2cDOUBLEREAL,
11749 FFECOM_f2cCOMPLEX,
11752 FFECOM_f2cDOUBLECOMPLEX,
11755 FFECOM_f2cLONGINT,
11758 FFECOM_f2cLOGICAL,
11761 FFECOM_f2cFLAG,
11764 FFECOM_f2cFTNLEN,
11767 FFECOM_f2cFTNINT,
11770 ffecom_f2c_ftnlen_zero_node
11773 ffecom_f2c_ftnlen_one_node
11779 ffecom_f2c_ptr_to_ftnlen_type_node
11782 ffecom_f2c_ptr_to_ftnint_type_node
11785 ffecom_f2c_ptr_to_integer_type_node
11788 ffecom_f2c_ptr_to_real_type_node
11793 {
11794 REAL_VALUE_TYPE point_5;
11796 #ifdef REAL_ARITHMETIC
11798 #else
11800 #endif
11803 }
11805 /* Do "extern int xargc;". */
11809 integer_type_node);
11819 {
11827 }
11828 #endif
11833 /* I/O will probably crash. */
11837 #endif
11842 /* ASSIGN 10 TO I will crash. */
11847 #endif
11848 }
11850 /* ffecom_init_2 -- Initialize
11852 ffecom_init_2(); */
11854 void
11856 {
11867 }
11869 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11871 tree t;
11872 ffebld expr; // FFE opITEM list.
11873 tree = ffecom_list_expr(expr);
11875 List of actual args is transformed into corresponding gcc backend list. */
11877 tree
11879 {
11880 tree list;
11884 tree length;
11887 {
11897 {
11900 }
11901 }
11906 }
11908 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11910 tree t;
11911 ffebld expr; // FFE opITEM list.
11912 tree = ffecom_list_ptr_to_expr(expr);
11914 List of actual args is transformed into corresponding gcc backend list for
11915 use in calling an external procedure (vs. a statement function). */
11917 tree
11919 {
11920 tree list;
11924 tree length;
11927 {
11937 {
11940 }
11941 }
11946 }
11948 /* Obtain gcc's LABEL_DECL tree for label. */
11950 tree
11952 {
11953 tree glabel;
11956 {
11960 {
11966 void_type_node);
11973 ffecom_get_invented_identifier
11977 NULL_TREE),
11998 }
12000 }
12001 else
12002 {
12004 }
12007 }
12009 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12010 a single source specification (as in the fourth argument of MVBITS).
12011 If the type is NULL_TREE, the type of lhs is used to make the type of
12012 the MODIFY_EXPR. */
12014 tree
12016 tree rhs)
12017 {
12028 }
12030 /* Register source file name. */
12032 void
12034 {
12036 }
12038 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12040 ffestorag st;
12041 ffecom_notify_init_storage(st);
12043 Gets called when all possible units in an aggregate storage area (a LOCAL
12044 with equivalences or a COMMON) have been initialized. The initialization
12045 info either is in ffestorag_init or, if that is NULL,
12046 ffestorag_accretion:
12048 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12049 even for an array if the array is one element in length!
12051 ffestorag_accretion will contain an opACCTER. It is much like an
12052 opARRTER except it has an ffebit object in it instead of just a size.
12053 The back end can use the info in the ffebit object, if it wants, to
12054 reduce the amount of actual initialization, but in any case it should
12055 kill the ffebit object when done. Also, set accretion to NULL but
12056 init to a non-NULL value.
12058 After performing initialization, DO NOT set init to NULL, because that'll
12059 tell the front end it is ok for more initialization to happen. Instead,
12060 set init to an opANY expression or some such thing that you can use to
12061 tell that you've already initialized the object.
12063 27-Oct-91 JCB 1.1
12064 Support two-pass FFE. */
12066 void
12068 {
12072 {
12078 }
12079 }
12081 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12083 ffesymbol s;
12084 ffecom_notify_init_symbol(s);
12086 Gets called when all possible units in a symbol (not placed in COMMON
12087 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12088 have been initialized. The initialization info either is in
12089 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12091 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12092 even for an array if the array is one element in length!
12094 ffesymbol_accretion will contain an opACCTER. It is much like an
12095 opARRTER except it has an ffebit object in it instead of just a size.
12096 The back end can use the info in the ffebit object, if it wants, to
12097 reduce the amount of actual initialization, but in any case it should
12098 kill the ffebit object when done. Also, set accretion to NULL but
12099 init to a non-NULL value.
12101 After performing initialization, DO NOT set init to NULL, because that'll
12102 tell the front end it is ok for more initialization to happen. Instead,
12103 set init to an opANY expression or some such thing that you can use to
12104 tell that you've already initialized the object.
12106 27-Oct-91 JCB 1.1
12107 Support two-pass FFE. */
12109 void
12111 {
12116 possibilities checked. */
12120 {
12124 }
12125 }
12127 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12129 ffesymbol s;
12130 ffecom_notify_primary_entry(s);
12132 Gets called when implicit or explicit PROGRAM statement seen or when
12133 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12134 global symbol that serves as the entry point. */
12136 void
12138 {
12145 else
12149 {
12152 else
12154 }
12157 {
12158 ffebld list;
12159 ffebld arg;
12164 {
12167 {
12170 }
12171 }
12172 }
12173 }
12177 {
12179 }
12181 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12183 tree t;
12184 ffebld expr; // FFE expression.
12185 tree = ffecom_ptr_to_expr(expr);
12187 Like ffecom_expr, but sticks address-of in front of most things. */
12189 tree
12191 {
12192 tree item;
12193 ffeinfoBasictype bt;
12194 ffeinfoKindtype kt;
12195 ffesymbol s;
12200 {
12204 {
12205 ffecomGfrt ix;
12210 {
12213 }
12214 }
12215 else
12216 {
12219 {
12222 }
12223 }
12229 item);
12246 item);
12260 /* The back end currently optimizes a bit too zealously for us, in that
12261 we fail JCB001 if the following block of code is omitted. It checks
12262 to see if the transformed expression is a symbol or array reference,
12263 and encloses it in a SAVE_EXPR if that is the case. */
12272 #ifdef OFFSET_REF
12274 #endif
12278 {
12280 }
12283 item);
12285 }
12289 }
12291 /* Obtain a temp var with given data type.
12293 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12294 or >= 0 for a CHARACTER type.
12296 elements is -1 for a scalar or > 0 for an array of type. */
12298 tree
12301 {
12302 tree t;
12313 ffecom_f2c_ftnlen_one_node,
12318 integer_zero_node,
12323 commentary,
12324 mynumber++),
12325 type);
12331 }
12333 /* Prepare argument pointer to expression.
12335 Like ffecom_prepare_expr, except for expressions to be evaluated
12336 via ffecom_arg_ptr_to_expr. */
12338 void
12340 {
12341 /* ~~For now, it seems to be the same thing. */
12344 }
12346 /* End of preparations. */
12348 bool
12350 {
12357 }
12359 /* Prepare expression.
12361 This is called before any code is generated for the current block.
12362 It scans the expression, declares any temporaries that might be needed
12363 during evaluation of the expression, and stores those temporaries in
12364 the appropriate "hook" fields of the expression. `dest', if not NULL,
12365 specifies the destination that ffecom_expr_ will see, in case that
12366 helps avoid generating unused temporaries.
12368 ~~Improve to avoid allocating unused temporaries by taking `dest'
12369 into account vis-a-vis aliasing requirements of complex/character
12370 functions. */
12372 void
12374 {
12375 ffeinfoBasictype bt;
12376 ffeinfoKindtype kt;
12377 ffetargetCharacterSize sz;
12389 /* Generate whatever temporaries are needed to represent the result
12390 of the expression. */
12393 {
12396 }
12399 {
12401 /* Don't make temps for SYMTER, CONTER, etc. */
12406 {
12409 {
12410 ffesymbol s;
12422 }
12424 {
12425 /* Requires special treatment. There's no POW_CC function
12426 in libg2c, so POW_ZZ is used, which means we always
12427 need a double-complex temp, not a single-complex. */
12429 }
12431 /* The other ops don't need temps for complex operands. */
12434 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12435 REAL(C). See 19990325-0.f, routine `check', for cases. */
12437 ffecom_tree_type
12439 FFETARGET_charactersizeNONE,
12448 /* ~~Kludge alert! This should someday be fixed. */
12456 }
12459 #ifdef HAHA
12461 {
12476 }
12481 {
12482 /* This gets special handling, because only one set of temps
12483 is needed for a tree of these -- the tree is treated as
12484 a flattened list of concatenations when generating code. */
12486 ffecomConcatList_ catlist;
12495 {
12496 ltmp
12498 ffecom_f2c_ftnlen_type_node,
12500 itmp
12502 ffecom_f2c_address_type_node,
12504 result
12506 char_type_node,
12514 }
12518 i));
12523 {
12526 }
12527 }
12537 }
12540 {
12543 }
12545 /* Prepare subexpressions for this expr. */
12548 {
12563 {
12564 ffebld item;
12571 }
12575 /* Need to handle character conversion specially. */
12577 {
12589 }
12590 }
12593 }
12595 /* Prepare expression for reading and writing.
12597 Like ffecom_prepare_expr, except for expressions to be evaluated
12598 via ffecom_expr_rw. */
12600 void
12602 {
12603 /* This is all we support for now. */
12606 /* ~~For now, it seems to be the same thing. */
12609 }
12611 /* Prepare expression for writing.
12613 Like ffecom_prepare_expr, except for expressions to be evaluated
12614 via ffecom_expr_w. */
12616 void
12618 {
12619 /* This is all we support for now. */
12622 /* ~~For now, it seems to be the same thing. */
12625 }
12627 /* Prepare expression for returning.
12629 Like ffecom_prepare_expr, except for expressions to be evaluated
12630 via ffecom_return_expr. */
12632 void
12634 {
12638 && ffecom_is_altreturning_
12641 }
12643 /* Prepare pointer to expression.
12645 Like ffecom_prepare_expr, except for expressions to be evaluated
12646 via ffecom_ptr_to_expr. */
12648 void
12650 {
12651 /* ~~For now, it seems to be the same thing. */
12654 }
12656 /* Transform expression into constant pointer-to-expression tree.
12658 If the expression can be transformed into a pointer-to-expression tree
12659 that is constant, that is done, and the tree returned. Else NULL_TREE
12660 is returned.
12662 That way, a caller can attempt to provide compile-time initialization
12663 of a variable and, if that fails, *then* choose to start a new block
12664 and resort to using temporaries, as appropriate. */
12666 tree
12668 {
12680 {
12681 tree t;
12686 }
12689 }
12691 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12693 tree rtn; // NULL_TREE means use expand_null_return()
12694 ffebld expr; // NULL if no alt return expr to RETURN stmt
12695 rtn = ffecom_return_expr(expr);
12697 Based on the program unit type and other info (like return function
12698 type, return master function type when alternate ENTRY points,
12699 whether subroutine has any alternate RETURN points, etc), returns the
12700 appropriate expression to be returned to the caller, or NULL_TREE
12701 meaning no return value or the caller expects it to be returned somewhere
12702 else (which is handled by other parts of this module). */
12704 tree
12706 {
12707 tree rtn;
12710 {
12721 else
12734 into (implicit) dummy. */
12737 }
12739 #if 0
12740 /* Spurious error if RETURN happens before first reference! So elide
12741 this code. In particular, for debugging registry, rtn should always
12742 be non-null after all, but TREE_USED won't be set until we encounter
12743 a reference in the code. Perfectly okay (but weird) code that,
12744 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12745 this diagnostic for no reason. Have people use -O -Wuninitialized
12746 and leave it to the back end to find obviously weird cases. */
12748 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12749 situation; if the return value has never been referenced, it won't
12750 have a tree under 2pass mode. */
12753 {
12760 }
12761 #endif
12769 }
12772 }
12774 /* Do save_expr only if tree is not error_mark_node. */
12776 tree
12778 {
12780 }
12782 /* Start a compound statement (block). */
12784 void
12786 {
12788 }
12790 /* Public entry point for front end to access start_decl. */
12792 tree
12794 {
12797 }
12799 /* ffecom_sym_commit -- Symbol's state being committed to reality
12801 ffesymbol s;
12802 ffecom_sym_commit(s);
12804 Does whatever the backend needs when a symbol is committed after having
12805 been backtrackable for a period of time. */
12807 void
12809 {
12811 }
12813 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12815 ffecom_sym_end_transition();
12817 Does backend-specific stuff and also calls ffest_sym_end_transition
12818 to do the necessary FFE stuff.
12820 Backtracking is never enabled when this fn is called, so don't worry
12821 about it. */
12823 ffesymbol
12825 {
12826 ffestorag st;
12834 {
12835 ffecom_list_blockdata_
12837 FFEINTRIN_specNONE,
12838 FFEINTRIN_impNONE),
12839 ffecom_list_blockdata_);
12840 }
12842 /* This is where we finally notice that a symbol has partial initialization
12843 and finalize it. */
12846 {
12849 }
12853 {
12856 }
12861 {
12862 ffecom_list_common_
12864 FFEINTRIN_specNONE,
12865 FFEINTRIN_impNONE),
12866 ffecom_list_common_);
12867 }
12870 }
12872 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12874 ffecom_sym_exec_transition();
12876 Does backend-specific stuff and also calls ffest_sym_exec_transition
12877 to do the necessary FFE stuff.
12879 See the long-winded description in ffecom_sym_learned for info
12880 on handling the situation where backtracking is inhibited. */
12882 ffesymbol
12884 {
12888 }
12890 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12892 ffesymbol s;
12893 s = ffecom_sym_learned(s);
12895 Called when a new symbol is seen after the exec transition or when more
12896 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
12897 it arrives here is that all its latest info is updated already, so its
12898 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12899 field filled in if its gone through here or exec_transition first, and
12900 so on.
12902 The backend probably wants to check ffesymbol_retractable() to see if
12903 backtracking is in effect. If so, the FFE's changes to the symbol may
12904 be retracted (undone) or committed (ratified), at which time the
12905 appropriate ffecom_sym_retract or _commit function will be called
12906 for that function.
12908 If the backend has its own backtracking mechanism, great, use it so that
12909 committal is a simple operation. Though it doesn't make much difference,
12910 I suppose: the reason for tentative symbol evolution in the FFE is to
12911 enable error detection in weird incorrect statements early and to disable
12912 incorrect error detection on a correct statement. The backend is not
12913 likely to introduce any information that'll get involved in these
12914 considerations, so it is probably just fine that the implementation
12915 model for this fn and for _exec_transition is to not do anything
12916 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12917 and instead wait until ffecom_sym_commit is called (which it never
12918 will be as long as we're using ambiguity-detecting statement analysis in
12919 the FFE, which we are initially to shake out the code, but don't depend
12920 on this), otherwise go ahead and do whatever is needed.
12922 In essence, then, when this fn and _exec_transition get called while
12923 backtracking is enabled, a general mechanism would be to flag which (or
12924 both) of these were called (and in what order? neat question as to what
12925 might happen that I'm too lame to think through right now) and then when
12926 _commit is called reproduce the original calling sequence, if any, for
12927 the two fns (at which point backtracking will, of course, be disabled). */
12929 ffesymbol
12931 {
12935 }
12937 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12939 ffesymbol s;
12940 ffecom_sym_retract(s);
12942 Does whatever the backend needs when a symbol is retracted after having
12943 been backtrackable for a period of time. */
12945 void
12947 {
12951 so nothing needed here. */
12953 {
12972 }
12973 #endif
12974 }
12976 /* Create temporary gcc label. */
12978 tree
12980 {
12981 tree glabel;
12986 mynumber++),
12987 void_type_node);
12992 }
12994 /* Return an expression that is usable as an arg in a conditional context
12995 (IF, DO WHILE, .NOT., and so on).
12997 Use the one provided for the back end as of >2.6.0. */
12999 tree
13001 {
13003 }
13005 /* Return the inversion of a truth value (the inversion of what
13006 ffecom_truth_value builds).
13008 Apparently invert_truthvalue, which is properly in the back end, is
13009 enough for now, so just use it. */
13011 tree
13013 {
13015 }
13017 /* Return the tree that is the type of the expression, as would be
13018 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13019 transforming the expression, generating temporaries, etc. */
13021 tree
13023 {
13024 ffeinfoBasictype bt;
13025 ffeinfoKindtype kt;
13026 tree tree_type;
13035 {
13078 /* Fall through. */
13081 }
13082 }
13084 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13086 If the PARM_DECL already exists, return it, else create it. It's an
13087 integer_type_node argument for the master function that implements a
13088 subroutine or function with more than one entrypoint and is bound at
13089 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13090 first ENTRY statement, and so on). */
13092 tree
13094 {
13098 }
13099 \f
13100 /* The following sections consists of private and public functions
13101 that have the same names and perform roughly the same functions
13102 as counterparts in the C front end. Changes in the C front end
13103 might affect how things should be done here. Only functions
13104 needed by the back end should be public here; the rest should
13105 be private (static in the C sense). Functions needed by other
13106 g77 front-end modules should be accessed by them via public
13107 ffecom_* names, which should themselves call private versions
13108 in this section so the private versions are easy to recognize
13109 when upgrading to a new gcc and finding interesting changes
13110 in the front end.
13112 Functions named after rule "foo:" in c-parse.y are named
13113 "bison_rule_foo_" so they are easy to find. */
13115 static void
13117 {
13122 }
13124 static tree
13126 {
13127 tree t;
13130 /* Make the temps go away. */
13139 }
13141 /* Return a definition for a builtin function named NAME and whose data type
13142 is TYPE. TYPE should be a function type with argument types.
13143 FUNCTION_CODE tells later passes how to compile calls to this function.
13144 See tree.h for its possible values.
13146 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13147 the name to be called if we can't opencode the function. */
13149 tree
13153 {
13165 }
13167 /* Handle when a new declaration NEWDECL
13168 has the same name as an old one OLDDECL
13169 in the same binding contour.
13170 Prints an error message if appropriate.
13172 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13173 Otherwise, return 0. */
13175 static int
13177 {
13191 /* New decl is completely inconsistent with the old one =>
13192 tell caller to replace the old one.
13193 This is always an error except in the case of shadowing a builtin. */
13197 /* For real parm decl following a forward decl,
13198 return 1 so old decl will be reused. */
13203 /* The new declaration is the same kind of object as the old one.
13204 The declarations may partially match. Print warnings if they don't
13205 match enough. Ultimately, copy most of the information from the new
13206 decl to the old one, and keep using the old one. */
13210 {
13211 /* A function declaration for a built-in function. */
13215 {
13216 /* Accept the return type of the new declaration if same modes. */
13221 {
13222 /* Function types may be shared, so we can't just modify
13223 the return type of olddecl's function type. */
13224 tree newtype
13231 }
13232 }
13235 }
13238 {
13239 /* A function declaration for a predeclared function
13240 that isn't actually built in. */
13244 {
13245 /* If the types don't match, preserve volatility indication.
13246 Later on, we will discard everything else about the
13247 default declaration. */
13249 }
13250 }
13252 /* Copy all the DECL_... slots specified in the new decl
13253 except for any that we copy here from the old type.
13255 Past this point, we don't change OLDTYPE and NEWTYPE
13256 even if we change the types of NEWDECL and OLDDECL. */
13259 {
13260 /* Merge the data types specified in the two decls. */
13266 /* Lay the type out, unless already done. */
13268 {
13275 }
13276 else
13277 {
13278 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13283 {
13286 }
13287 }
13289 /* Keep the old rtl since we can safely use it. */
13292 /* Merge the type qualifiers. */
13299 {
13303 }
13305 /* Keep source location of definition rather than declaration.
13306 Likewise, keep decl at outer scope. */
13309 {
13316 }
13318 /* Merge the unused-warning information. */
13324 /* Merge the initialization information. */
13328 /* Merge the section attribute.
13329 We want to issue an error if the sections conflict but that must be
13330 done later in decl_attributes since we are called before attributes
13331 are assigned. */
13336 {
13339 }
13340 }
13341 /* If cannot merge, then use the new type and qualifiers,
13342 and don't preserve the old rtl. */
13343 else
13344 {
13349 }
13351 /* Merge the storage class information. */
13352 /* For functions, static overrides non-static. */
13354 {
13356 /* This is since we don't automatically
13357 copy the attributes of NEWDECL into OLDDECL. */
13359 /* If this clears `static', clear it in the identifier too. */
13362 }
13364 {
13367 /* An extern decl does not override previous storage class. */
13369 }
13370 else
13371 {
13374 }
13376 /* If either decl says `inline', this fn is inline,
13377 unless its definition was passed already. */
13382 /* Get rid of any built-in function if new arg types don't match it
13383 or if we have a function definition. */
13387 {
13390 }
13392 /* If redeclaring a builtin function, and not a definition,
13393 it stays built in.
13394 Also preserve various other info from the definition. */
13396 {
13398 {
13401 }
13407 }
13409 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13410 But preserve olddecl's DECL_UID. */
13411 {
13418 }
13421 }
13423 /* Finish processing of a declaration;
13424 install its initial value.
13425 If the length of an array type is not known before,
13426 it must be determined now, from the initial value, or it is an error. */
13428 static void
13430 {
13436 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13437 level anyway. */
13442 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13443 overlaps DECL_ARG_TYPE. */
13446 else
13450 {
13453 else
13454 {
13455 /* typedef foo = bar; store the type of bar as the type of foo. */
13458 }
13459 }
13461 /* Deduce size of array from initialization, if not already known */
13466 {
13471 }
13474 {
13481 ?
13482 /* A static variable with an incomplete type is an error if it is
13483 initialized. Also if it is not file scope. Otherwise, let it
13484 through, but if it is not `extern' then it may cause an error
13485 message later. */
13487 :
13488 /* An automatic variable with an incomplete type is an error. */
13490 {
13493 }
13498 {
13501 }
13502 }
13504 /* Output the assembler code and/or RTL code for variables and functions,
13505 unless the type is an undefined structure or union. If not, it will get
13506 done when the type is completed. */
13509 {
13515 {
13516 /* Recompute the RTL of a local array now if it used to be an
13517 incomplete type. */
13520 {
13521 /* If we used it already as memory, it must stay in memory. */
13523 /* If it's still incomplete now, no init will save it. */
13527 }
13528 /* Compute and store the initial value. */
13531 }
13532 }
13534 {
13538 }
13540 /* At the end of a declaration, throw away any variable type sizes of types
13541 defined inside that declaration. There is no use computing them in the
13542 following function definition. */
13545 }
13547 /* Finish up a function declaration and compile that function
13548 all the way to assembler language output. The free the storage
13549 for the function definition.
13551 This is called after parsing the body of the function definition.
13553 NESTED is nonzero if the function being finished is nested in another. */
13555 static void
13557 {
13562 {
13565 else
13567 }
13569 /* TREE_READONLY (fndecl) = 1;
13570 This caused &foo to be of type ptr-to-const-function
13571 which then got a warning when stored in a ptr-to-function variable. */
13576 {
13579 /* Must mark the RESULT_DECL as being in this function. */
13583 /* Obey `register' declarations if `setjmp' is called in this fn. */
13584 /* Generate rtl for function exit. */
13587 /* If this is a nested function, protect the local variables in the stack
13588 above us from being collected while we're compiling this function. */
13592 /* Run the optimizers and output the assembler code for this function. */
13595 /* Undo the GC context switch. */
13598 }
13601 && !nested
13603 {
13604 /* Stop pointing to the local nodes about to be freed. */
13605 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13606 function definition. */
13607 /* For a nested function, this is done in pop_f_function_context. */
13608 /* If rest_of_compilation set this to 0, leave it 0. */
13612 }
13615 {
13616 /* Let the error reporting routines know that we're outside a function.
13617 For a nested function, this value is used in pop_c_function_context
13618 and then reset via pop_function_context. */
13620 }
13621 }
13623 /* Plug-in replacement for identifying the name of a decl and, for a
13624 function, what we call it in diagnostics. For now, "program unit"
13625 should suffice, since it's a bit of a hassle to figure out which
13626 of several kinds of things it is. Note that it could conceivably
13627 be a statement function, which probably isn't really a program unit
13628 per se, but if that comes up, it should be easy to check (being a
13629 nested function and all). */
13633 {
13634 /* Just to keep GCC quiet about the unused variable.
13635 In theory, differing values of V should produce different
13636 output. */
13638 {
13643 }
13644 }
13646 /* g77's function to print out name of current function that caused
13647 an error. */
13649 static void
13652 {
13655 ffeglobal g;
13656 ffesymbol s;
13661 {
13665 }
13666 else
13667 {
13670 {
13673 {
13693 }
13694 }
13695 else
13696 {
13699 }
13700 }
13703 {
13709 else
13710 {
13714 }
13718 }
13719 }
13721 /* Similar to `lookup_name' but look only at current binding level. */
13723 static tree
13725 {
13739 }
13741 /* Create a new `struct binding_level'. */
13745 {
13746 /* NOSTRICT */
13748 }
13750 /* Save and restore the variables in this file and elsewhere
13751 that keep track of the progress of compilation of the current function.
13752 Used for nested functions. */
13754 struct f_function
13755 {
13757 tree named_labels;
13758 tree shadowed_labels;
13760 };
13764 /* Restore the variables used during compilation of a C function. */
13766 static void
13768 {
13770 tree link;
13772 /* Bring back all the labels that were shadowed. */
13780 {
13781 /* Stop pointing to the local nodes about to be freed. */
13782 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13783 function definition. */
13786 }
13797 }
13799 /* Save and reinitialize the variables
13800 used during compilation of a C function. */
13802 static void
13804 {
13816 }
13818 static void
13820 {
13823 /* Don't try computing parm sizes now -- wait till fn is called. */
13827 /* Fill in arg stuff. */
13838 }
13840 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
13842 static tree
13844 tree x;
13845 {
13856 }
13858 /* Store the list of declarations of the current level.
13859 This is done for the parameter declarations of a function being defined,
13860 after they are modified in the light of any missing parameters. */
13862 static tree
13864 tree decls;
13865 {
13867 }
13869 /* Store the parameter declarations into the current function declaration.
13870 This is called after parsing the parameter declarations, before
13871 digesting the body of the function.
13873 For an old-style definition, modify the function's type
13874 to specify at least the number of arguments. */
13876 static void
13878 {
13884 /* This is a chain of PARM_DECLs from old-style parm declarations. */
13887 /* Initialize the RTL code for the function. */
13891 /* Set up parameters and prepare for return, for the function. */
13894 }
13896 static tree
13898 {
13903 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13904 level anyway. */
13908 {
13911 }
13915 /* For Fortran, we by default put things in .common when possible. */
13918 /* Add this decl to the current binding level. TEM may equal DECL or it may
13919 be a previous decl of the same name. */
13922 else
13925 /* For a local variable, define the RTL now. */
13927 /* But not if this is a duplicate decl and we preserved the rtl from the
13928 previous one (which may or may not happen). */
13930 {
13936 }
13939 }
13941 /* Create the FUNCTION_DECL for a function definition.
13942 DECLSPECS and DECLARATOR are the parts of the declaration;
13943 they describe the function's name and the type it returns,
13944 but twisted together in a fashion that parallels the syntax of C.
13946 This function creates a binding context for the function body
13947 as well as setting up the FUNCTION_DECL in current_function_decl.
13949 Returns 1 on success. If the DECLARATOR is not suitable for a function
13950 (it defines a datum instead), we return 0, which tells
13951 yyparse to report a parse error.
13953 NESTED is nonzero for a function nested within another function. */
13955 static void
13957 {
13958 tree decl1;
13959 tree restype;
13965 /* Don't expand any sizes in the return type of the function. */
13969 {
13973 }
13974 else
13975 {
13977 }
13981 else
13982 {
13984 name,
13985 type);
13994 /* Make the init_value nonzero so pushdecl knows this is not tentative.
13995 error_mark_node is replaced below (in poplevel) with the BLOCK. */
13998 /* Record the decl so that the function name is defined. If we already have
13999 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
14002 }
14011 {
14017 }
14023 }
14024 \f
14025 /* Here are the public functions the GNU back end needs. */
14027 tree
14030 {
14043 {
14046 }
14052 e);
14066 }
14068 /* integrate_decl_tree calls this function, but since we don't use the
14069 DECL_LANG_SPECIFIC field, this is a no-op. */
14071 void
14073 tree node UNUSED;
14074 {
14075 }
14077 /* Return the list of declarations of the current level.
14078 Note that this list is in reverse order unless/until
14079 you nreverse it; and when you do nreverse it, you must
14080 store the result back using `storedecls' or you will lose. */
14082 tree
14084 {
14086 }
14088 /* Nonzero if we are currently in the global binding level. */
14090 int
14092 {
14094 }
14096 /* Print an error message for invalid use of an incomplete type.
14097 VALUE is the expression that was used (or 0 if that isn't known)
14098 and TYPE is the type that was invalid. */
14100 void
14102 tree value UNUSED;
14103 tree type;
14104 {
14109 }
14111 /* Mark ARG for GC. */
14112 static void
14114 {
14118 {
14123 }
14124 }
14126 static void
14128 {
14169 &shadowed_labels
14170 };
14175 /* Record our roots. */
14186 mark_binding_level);
14188 mark_binding_level);
14192 }
14194 /* Delete the node BLOCK from the current binding level.
14195 This is used for the block inside a stmt expr ({...})
14196 so that the block can be reinserted where appropriate. */
14198 static void
14200 tree block;
14201 {
14202 tree t;
14206 {
14209 else
14211 }
14213 /* Clear TREE_USED which is always set by poplevel.
14214 The flag is set again if insert_block is called. */
14216 }
14218 void
14220 tree block;
14221 {
14223 current_binding_level->blocks
14225 }
14227 /* Each front end provides its own. */
14233 #undef LANG_HOOKS_NAME
14235 #undef LANG_HOOKS_INIT
14236 #define LANG_HOOKS_INIT ffe_init
14237 #undef LANG_HOOKS_FINISH
14238 #define LANG_HOOKS_FINISH ffe_finish
14239 #undef LANG_HOOKS_INIT_OPTIONS
14240 #define LANG_HOOKS_INIT_OPTIONS ffe_init_options
14241 #undef LANG_HOOKS_DECODE_OPTION
14242 #define LANG_HOOKS_DECODE_OPTION ffe_decode_option
14243 #undef LANG_HOOKS_PRINT_IDENTIFIER
14244 #define LANG_HOOKS_PRINT_IDENTIFIER ffe_print_identifier
14246 /* We do not wish to use alias-set based aliasing at all. Used in the
14247 extreme (every object with its own set, with equivalences recorded) it
14248 might be helpful, but there are problems when it comes to inlining. We
14249 get on ok with flag_argument_noalias, and alias-set aliasing does
14250 currently limit how stack slots can be reused, which is a lose. */
14251 #undef LANG_HOOKS_GET_ALIAS_SET
14252 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14259 {
14260 /* Open input file. */
14262 {
14265 }
14266 else
14271 #ifdef IO_BUFFER_SIZE
14273 #endif
14279 /* If the file is output from cpp, it should contain a first line
14280 `# 1 "real-filename"', and the current design of gcc (toplev.c
14281 in particular and the way it sets up information relied on by
14282 INCLUDE) requires that we read this now, and store the
14283 "real-filename" info in master_input_filename. Ask the lexer
14284 to try doing this. */
14287 /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14288 return the new file name. */
14293 }
14295 static void
14297 {
14304 }
14306 static void
14308 {
14309 /* Set default options for Fortran. */
14316 }
14318 int
14320 tree exp;
14321 {
14325 {
14342 {
14344 {
14347 }
14349 }
14351 {
14353 {
14356 }
14358 }
14361 /* drops in */
14367 #endif
14371 }
14372 }
14374 /* If DECL has a cleanup, build and return that cleanup here.
14375 This is a callback called by expand_expr. */
14377 tree
14379 tree decl UNUSED;
14380 {
14381 /* There are no cleanups in Fortran. */
14383 }
14385 /* Exit a binding level.
14386 Pop the level off, and restore the state of the identifier-decl mappings
14387 that were in effect when this level was entered.
14389 If KEEP is nonzero, this level had explicit declarations, so
14390 and create a "block" (a BLOCK node) for the level
14391 to record its declarations and subblocks for symbol table output.
14393 If FUNCTIONBODY is nonzero, this level is the body of a function,
14394 so create a block as if KEEP were set and also clear out all
14395 label names.
14397 If REVERSE is nonzero, reverse the order of decls before putting
14398 them into the BLOCK. */
14400 tree
14405 {
14407 /* The chain of decls was accumulated in reverse order.
14408 Put it into forward order, just for cleanliness. */
14409 tree decls;
14412 tree decl;
14415 /* Get the decls in the order they were written.
14416 Usually current_binding_level->names is in reverse order.
14417 But parameter decls were previously put in forward order. */
14420 current_binding_level->names
14422 else
14425 /* Output any nested inline functions within this block
14426 if they weren't already output. */
14433 {
14434 /* If this decl was copied from a file-scope decl
14435 on account of a block-scope extern decl,
14436 propagate TREE_ADDRESSABLE to the file-scope decl.
14438 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14439 true, since then the decl goes through save_for_inline_copying. */
14444 {
14448 }
14449 }
14451 /* If there were any declarations or structure tags in that level,
14452 or if this level is a function body,
14453 create a BLOCK to record them for the life of this function. */
14462 {
14465 }
14467 /* In each subblock, record that this is its superior. */
14472 /* Clear out the meanings of the local variables of this level. */
14475 {
14477 {
14478 /* If the ident. was used or addressed via a local extern decl,
14479 don't forget that fact. */
14481 {
14486 }
14488 }
14489 }
14491 /* If the level being exited is the top level of a function,
14492 check over all the labels, and clear out the current
14493 (function local) meanings of their names. */
14496 {
14497 /* If this is the top level block of a function,
14498 the vars are the function's parameters.
14499 Don't leave them in the BLOCK because they are
14500 found in the FUNCTION_DECL instead. */
14503 }
14505 /* Pop the current level, and free the structure for reuse. */
14507 {
14513 }
14515 /* Dispose of the block that we just made inside some higher level. */
14520 {
14522 current_binding_level->blocks
14524 }
14525 /* If we did not make a block for the level just exited,
14526 any blocks made for inner levels
14527 (since they cannot be recorded as subblocks in that level)
14528 must be carried forward so they will later become subblocks
14529 of something else. */
14531 current_binding_level->blocks
14537 }
14539 static void
14542 tree node;
14544 {
14547 }
14549 /* Record a decl-node X as belonging to the current lexical scope.
14550 Check for errors (such as an incompatible declaration for the same
14551 name already seen in the same scope).
14553 Returns either X or an old decl for the same name.
14554 If an old decl is returned, it may have been smashed
14555 to agree with what X says. */
14557 tree
14559 tree x;
14560 {
14569 else
14573 {
14575 {
14578 }
14584 /* Don't push non-parms onto list for parms until we understand
14585 why we're doing this and whether it works. */
14588 || !ffecom_transform_only_dummies_
14594 /* If we are processing a typedef statement, generate a whole new
14595 ..._TYPE node (which will be just an variant of the existing
14596 ..._TYPE node with identical properties) and then install the
14597 TYPE_DECL node generated to represent the typedef name as the
14598 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14600 The whole point here is to end up with a situation where each and every
14601 ..._TYPE node the compiler creates will be uniquely associated with
14602 AT MOST one node representing a typedef name. This way, even though
14603 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14604 (i.e. "typedef name") nodes very early on, later parts of the
14605 compiler can always do the reverse translation and get back the
14606 corresponding typedef name. For example, given:
14608 typedef struct S MY_TYPE; MY_TYPE object;
14610 Later parts of the compiler might only know that `object' was of type
14611 `struct S' if it were not for code just below. With this code
14612 however, later parts of the compiler see something like:
14614 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14616 And they can then deduce (from the node for type struct S') that the
14617 original object declaration was:
14619 MY_TYPE object;
14621 Being able to do this is important for proper support of protoize, and
14622 also for generating precise symbolic debugging information which
14623 takes full account of the programmer's (typedef) vocabulary.
14625 Obviously, we don't want to generate a duplicate ..._TYPE node if the
14626 TYPE_DECL node that we are now processing really represents a
14627 standard built-in type.
14629 Since all standard types are effectively declared at line zero in the
14630 source file, we can easily check to see if we are working on a
14631 standard type by checking the current value of lineno. */
14634 {
14636 {
14639 }
14641 {
14647 }
14648 }
14650 /* This name is new in its binding level. Install the new declaration
14651 and return it. */
14654 else
14656 }
14658 /* Put decls on list in reverse order. We will reverse them later if
14659 necessary. */
14664 }
14666 /* Nonzero if the current level needs to have a BLOCK made. */
14668 static int
14670 {
14671 tree decl;
14674 decl;
14676 {
14679 /* Currently, there aren't supposed to be non-artificial names
14680 at other than the top block for a function -- they're
14681 believed to always be temps. But it's wise to check anyway. */
14683 }
14685 }
14687 /* Enter a new binding level.
14688 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14689 not for that of tags. */
14691 void
14694 {
14700 {
14702 }
14704 /* Reuse or create a struct for this binding level. */
14707 {
14710 }
14711 else
14712 {
14714 }
14716 /* Add this level to the front of the chain (stack) of levels that
14717 are active. */
14722 }
14724 /* Set the BLOCK node for the innermost scope
14725 (the one we are currently in). */
14727 void
14730 {
14736 }
14738 tree
14741 tree type;
14742 {
14743 tree type2;
14764 }
14766 tree
14768 tree type;
14769 {
14771 ffeinfoKindtype kt;
14772 tree type2;
14793 #endif
14800 {
14805 }
14808 }
14810 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14811 or validate its data type for an `if' or `while' statement or ?..: exp.
14813 This preparation consists of taking the ordinary
14814 representation of an expression expr and producing a valid tree
14815 boolean expression describing whether expr is nonzero. We could
14816 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14817 but we optimize comparisons, &&, ||, and !.
14819 The resulting type should always be `integer_type_node'. */
14821 tree
14823 tree expr;
14824 {
14829 /* These really should return error_mark_node after 2.4 is stable.
14830 But not all callers handle ERROR_MARK properly. */
14832 {
14847 }
14851 {
14852 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14853 or comparison expressions as truth values at this level. */
14854 #if 0
14856 /* A one-bit unsigned bit-field is already acceptable. */
14861 #endif
14864 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14865 or comparison expressions as truth values at this level. */
14866 #if 0
14869 #endif
14892 else
14898 integer_type_node,
14906 /* These don't change whether an object is non-zero or zero. */
14911 /* These don't change whether an object is zero or non-zero, but
14912 we can't ignore them if their second arg has side-effects. */
14916 else
14920 /* Distribute the conversion into the arms of a COND_EXPR. */
14926 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14927 since that affects how `default_conversion' will behave. */
14931 /* fall through... */
14933 /* If this is widening the argument, we can ignore it. */
14940 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14941 this case. */
14945 /* fall through... */
14947 /* This and MINUS_EXPR can be changed into a comparison of the
14948 two objects. */
14969 #endif
14974 }
14980 integer_type_node,
14983 expr)),
14986 expr))));
14989 expr,
14991 }
14993 tree
14997 {
15000 tree t;
15017 #if HOST_BITS_PER_WIDE_INT >= 64
15020 #endif
15036 {
15039 {
15042 else
15044 }
15045 }
15048 }
15050 tree
15054 {
15055 ffeinfoKindtype kt;
15056 tree type_node;
15075 {
15081 }
15084 }
15086 tree
15088 tree type;
15089 {
15091 ffeinfoKindtype kt;
15092 tree type2;
15113 #endif
15120 {
15125 }
15128 }
15130 void
15133 {
15135 {
15140 }
15143 }
15144 \f
15145 /* From gcc/cccp.c, the code to handle -I. */
15147 /* Skip leading "./" from a directory name.
15148 This may yield the empty string, which represents the current directory. */
15152 {
15157 dir++;
15159 }
15161 /* The file_name_map structure holds a mapping of file names for a
15162 particular directory. This mapping is read from the file named
15163 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15164 map filenames on a file system with severe filename restrictions,
15165 such as DOS. The format of the file name map file is just a series
15166 of lines with two tokens on each line. The first token is the name
15167 to map, and the second token is the actual name to use. */
15169 struct file_name_map
15170 {
15174 };
15178 /* Current maximum length of directory names in the search path
15179 for include files. (Altered as we get more of them.) */
15183 struct file_name_list
15184 {
15187 /* Mapping of file names for this directory. */
15189 /* Non-zero if name_map is valid. */
15191 };
15196 /* I/O buffer structure.
15197 The `fname' field is nonzero for source files and #include files
15198 and for the dummy text used for -D and -U.
15199 It is zero for rescanning results of macro expansion
15200 and for expanding macro arguments. */
15201 #define INPUT_STACK_MAX 400
15204 /* Filename specified with #line command. */
15206 /* Record where in the search path this file was found.
15207 For #include_next. */
15209 ffewhereLine line;
15210 ffewhereColumn column;
15216 /* Current nesting level of input sources.
15217 `instack[indepth]' is the level currently being read. */
15222 /* Nonzero means -I- has been seen,
15223 so don't look for #include "foo" the source-file directory. */
15226 #ifndef INCLUDE_LEN_FUDGE
15227 #define INCLUDE_LEN_FUDGE 0
15228 #endif
15238 /* Append a chain of `struct file_name_list's
15239 to the end of the main include chain.
15240 FIRST is the beginning of the chain to append, and LAST is the end. */
15242 static void
15245 {
15253 else
15262 }
15266 }
15268 /* Try to open include file FILENAME. SEARCHPTR is the directory
15269 being tried from the include file search path. This function maps
15270 filenames on file systems based on information read by
15271 read_name_map. */
15277 {
15283 {
15287 }
15289 /* First check the mapping for the directory we are using. */
15291 {
15296 {
15298 {
15299 /* Found a match. */
15301 }
15302 }
15303 }
15305 /* Try to find a mapping file for the particular directory we are
15306 looking in. Thus #include <sys/types.h> will look up sys/types.h
15307 in /usr/include/header.gcc and look up types.h in
15308 /usr/include/sys/header.gcc. */
15310 #ifdef DIR_SEPARATOR
15315 }
15316 #endif
15323 {
15324 /* FILENAME is in SEARCHPTR, which we've already checked. */
15326 }
15329 {
15332 }
15333 else
15334 {
15341 }
15347 }
15349 /* Print the file names and line numbers of the #include
15350 commands which led to the current file. */
15352 static void
15354 {
15361 /* If stack of files hasn't changed since we last printed
15362 this info, don't repeat it. */
15370 }
15372 /* Give up if we don't find a source file. */
15376 /* Find the other, outer source files. */
15379 {
15382 {
15385 }
15386 else
15387 {
15389 }
15393 else
15402 }
15404 /* Record we have printed the status as of this time. */
15406 }
15408 /* Read a space delimited string of unlimited length from a stdio
15409 file. */
15415 {
15422 {
15425 {
15427 {
15431 }
15433 }
15434 }
15438 }
15440 /* Read the file name map file for DIRNAME. */
15445 {
15446 /* This structure holds a linked list of file name maps, one per
15447 directory. */
15448 struct file_name_map_list
15449 {
15453 };
15483 else
15484 {
15488 {
15496 ;
15503 /* Make the real filename absolute. */
15506 else
15507 {
15513 }
15521 }
15523 }
15529 }
15531 static void
15533 {
15536 /* Do partial setup of input buffer for the sake of generating
15537 early #line directives (when -g is in effect). */
15544 }
15546 static void
15548 {
15551 indepth--;
15552 input_file_stack_tick++;
15556 }
15558 static int
15560 {
15565 else
15566 {
15574 else
15576 }
15578 }
15580 /* Open INCLUDEd file. */
15584 {
15599 /* If -I- was specified, don't search current dir, only spec'd ones. */
15601 {
15603 {
15609 {
15610 /* Found a named file. Figure out dir of the file,
15611 and put it in front of the search list. */
15614 #ifndef VMS
15616 #ifdef DIR_SEPARATOR
15621 }
15622 #endif
15630 {
15637 }
15638 else
15642 }
15643 }
15644 }
15646 /* Allocate this permanently, because it gets stored in the definitions
15647 of macros. */
15649 /* + 2 above for slash and terminating null. */
15650 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15651 for g77 yet). */
15653 /* If specified file name is absolute, just open it. */
15656 #ifdef DIR_SEPARATOR
15658 #endif
15659 )
15660 {
15664 }
15665 else
15666 {
15669 /* Search directory path, trying to open the file.
15670 Copy each filename tried into FNAME. */
15673 {
15675 {
15676 /* The empty string in a search path is ignored.
15677 This makes it possible to turn off entirely
15678 a standard piece of the list. */
15685 }
15686 else
15690 #ifdef VMS
15691 /* Change this 1/2 Unix 1/2 VMS file specification into a
15692 full VMS file specification */
15694 {
15695 /* Fix up the filename */
15697 }
15698 else
15699 {
15700 /* This is a normal VMS filespec, so use it unchanged. */
15704 /* if it's '#include filename', add the missing .h */
15707 #endif
15708 }
15711 #ifdef EACCES
15713 {
15716 FFEBAD_severityWARNING);
15720 }
15721 #endif
15724 }
15725 }
15728 {
15729 /* A file that was not found. */
15738 }
15747 {
15750 FFEBAD_severityFATAL);
15755 }
15765 indepth++;
15766 input_file_stack_tick++;
15769 }
15771 /**INDENT* (Do not reformat this comment even with -fca option.)
15772 Data-gathering files: Given the source file listed below, compiled with
15773 f2c I obtained the output file listed after that, and from the output
15774 file I derived the above code.
15776 -------- (begin input file to f2c)
15777 implicit none
15778 character*10 A1,A2
15779 complex C1,C2
15780 integer I1,I2
15781 real R1,R2
15782 double precision D1,D2
15783 C
15784 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15785 c /
15786 call fooI(I1/I2)
15787 call fooR(R1/I1)
15788 call fooD(D1/I1)
15789 call fooC(C1/I1)
15790 call fooR(R1/R2)
15791 call fooD(R1/D1)
15792 call fooD(D1/D2)
15793 call fooD(D1/R1)
15794 call fooC(C1/C2)
15795 call fooC(C1/R1)
15796 call fooZ(C1/D1)
15797 c **
15798 call fooI(I1**I2)
15799 call fooR(R1**I1)
15800 call fooD(D1**I1)
15801 call fooC(C1**I1)
15802 call fooR(R1**R2)
15803 call fooD(R1**D1)
15804 call fooD(D1**D2)
15805 call fooD(D1**R1)
15806 call fooC(C1**C2)
15807 call fooC(C1**R1)
15808 call fooZ(C1**D1)
15809 c FFEINTRIN_impABS
15810 call fooR(ABS(R1))
15811 c FFEINTRIN_impACOS
15812 call fooR(ACOS(R1))
15813 c FFEINTRIN_impAIMAG
15814 call fooR(AIMAG(C1))
15815 c FFEINTRIN_impAINT
15816 call fooR(AINT(R1))
15817 c FFEINTRIN_impALOG
15818 call fooR(ALOG(R1))
15819 c FFEINTRIN_impALOG10
15820 call fooR(ALOG10(R1))
15821 c FFEINTRIN_impAMAX0
15822 call fooR(AMAX0(I1,I2))
15823 c FFEINTRIN_impAMAX1
15824 call fooR(AMAX1(R1,R2))
15825 c FFEINTRIN_impAMIN0
15826 call fooR(AMIN0(I1,I2))
15827 c FFEINTRIN_impAMIN1
15828 call fooR(AMIN1(R1,R2))
15829 c FFEINTRIN_impAMOD
15830 call fooR(AMOD(R1,R2))
15831 c FFEINTRIN_impANINT
15832 call fooR(ANINT(R1))
15833 c FFEINTRIN_impASIN
15834 call fooR(ASIN(R1))
15835 c FFEINTRIN_impATAN
15836 call fooR(ATAN(R1))
15837 c FFEINTRIN_impATAN2
15838 call fooR(ATAN2(R1,R2))
15839 c FFEINTRIN_impCABS
15840 call fooR(CABS(C1))
15841 c FFEINTRIN_impCCOS
15842 call fooC(CCOS(C1))
15843 c FFEINTRIN_impCEXP
15844 call fooC(CEXP(C1))
15845 c FFEINTRIN_impCHAR
15846 call fooA(CHAR(I1))
15847 c FFEINTRIN_impCLOG
15848 call fooC(CLOG(C1))
15849 c FFEINTRIN_impCONJG
15850 call fooC(CONJG(C1))
15851 c FFEINTRIN_impCOS
15852 call fooR(COS(R1))
15853 c FFEINTRIN_impCOSH
15854 call fooR(COSH(R1))
15855 c FFEINTRIN_impCSIN
15856 call fooC(CSIN(C1))
15857 c FFEINTRIN_impCSQRT
15858 call fooC(CSQRT(C1))
15859 c FFEINTRIN_impDABS
15860 call fooD(DABS(D1))
15861 c FFEINTRIN_impDACOS
15862 call fooD(DACOS(D1))
15863 c FFEINTRIN_impDASIN
15864 call fooD(DASIN(D1))
15865 c FFEINTRIN_impDATAN
15866 call fooD(DATAN(D1))
15867 c FFEINTRIN_impDATAN2
15868 call fooD(DATAN2(D1,D2))
15869 c FFEINTRIN_impDCOS
15870 call fooD(DCOS(D1))
15871 c FFEINTRIN_impDCOSH
15872 call fooD(DCOSH(D1))
15873 c FFEINTRIN_impDDIM
15874 call fooD(DDIM(D1,D2))
15875 c FFEINTRIN_impDEXP
15876 call fooD(DEXP(D1))
15877 c FFEINTRIN_impDIM
15878 call fooR(DIM(R1,R2))
15879 c FFEINTRIN_impDINT
15880 call fooD(DINT(D1))
15881 c FFEINTRIN_impDLOG
15882 call fooD(DLOG(D1))
15883 c FFEINTRIN_impDLOG10
15884 call fooD(DLOG10(D1))
15885 c FFEINTRIN_impDMAX1
15886 call fooD(DMAX1(D1,D2))
15887 c FFEINTRIN_impDMIN1
15888 call fooD(DMIN1(D1,D2))
15889 c FFEINTRIN_impDMOD
15890 call fooD(DMOD(D1,D2))
15891 c FFEINTRIN_impDNINT
15892 call fooD(DNINT(D1))
15893 c FFEINTRIN_impDPROD
15894 call fooD(DPROD(R1,R2))
15895 c FFEINTRIN_impDSIGN
15896 call fooD(DSIGN(D1,D2))
15897 c FFEINTRIN_impDSIN
15898 call fooD(DSIN(D1))
15899 c FFEINTRIN_impDSINH
15900 call fooD(DSINH(D1))
15901 c FFEINTRIN_impDSQRT
15902 call fooD(DSQRT(D1))
15903 c FFEINTRIN_impDTAN
15904 call fooD(DTAN(D1))
15905 c FFEINTRIN_impDTANH
15906 call fooD(DTANH(D1))
15907 c FFEINTRIN_impEXP
15908 call fooR(EXP(R1))
15909 c FFEINTRIN_impIABS
15910 call fooI(IABS(I1))
15911 c FFEINTRIN_impICHAR
15912 call fooI(ICHAR(A1))
15913 c FFEINTRIN_impIDIM
15914 call fooI(IDIM(I1,I2))
15915 c FFEINTRIN_impIDNINT
15916 call fooI(IDNINT(D1))
15917 c FFEINTRIN_impINDEX
15918 call fooI(INDEX(A1,A2))
15919 c FFEINTRIN_impISIGN
15920 call fooI(ISIGN(I1,I2))
15921 c FFEINTRIN_impLEN
15922 call fooI(LEN(A1))
15923 c FFEINTRIN_impLGE
15924 call fooL(LGE(A1,A2))
15925 c FFEINTRIN_impLGT
15926 call fooL(LGT(A1,A2))
15927 c FFEINTRIN_impLLE
15928 call fooL(LLE(A1,A2))
15929 c FFEINTRIN_impLLT
15930 call fooL(LLT(A1,A2))
15931 c FFEINTRIN_impMAX0
15932 call fooI(MAX0(I1,I2))
15933 c FFEINTRIN_impMAX1
15934 call fooI(MAX1(R1,R2))
15935 c FFEINTRIN_impMIN0
15936 call fooI(MIN0(I1,I2))
15937 c FFEINTRIN_impMIN1
15938 call fooI(MIN1(R1,R2))
15939 c FFEINTRIN_impMOD
15940 call fooI(MOD(I1,I2))
15941 c FFEINTRIN_impNINT
15942 call fooI(NINT(R1))
15943 c FFEINTRIN_impSIGN
15944 call fooR(SIGN(R1,R2))
15945 c FFEINTRIN_impSIN
15946 call fooR(SIN(R1))
15947 c FFEINTRIN_impSINH
15948 call fooR(SINH(R1))
15949 c FFEINTRIN_impSQRT
15950 call fooR(SQRT(R1))
15951 c FFEINTRIN_impTAN
15952 call fooR(TAN(R1))
15953 c FFEINTRIN_impTANH
15954 call fooR(TANH(R1))
15955 c FFEINTRIN_imp_CMPLX_C
15956 call fooC(cmplx(C1,C2))
15957 c FFEINTRIN_imp_CMPLX_D
15958 call fooZ(cmplx(D1,D2))
15959 c FFEINTRIN_imp_CMPLX_I
15960 call fooC(cmplx(I1,I2))
15961 c FFEINTRIN_imp_CMPLX_R
15962 call fooC(cmplx(R1,R2))
15963 c FFEINTRIN_imp_DBLE_C
15964 call fooD(dble(C1))
15965 c FFEINTRIN_imp_DBLE_D
15966 call fooD(dble(D1))
15967 c FFEINTRIN_imp_DBLE_I
15968 call fooD(dble(I1))
15969 c FFEINTRIN_imp_DBLE_R
15970 call fooD(dble(R1))
15971 c FFEINTRIN_imp_INT_C
15972 call fooI(int(C1))
15973 c FFEINTRIN_imp_INT_D
15974 call fooI(int(D1))
15975 c FFEINTRIN_imp_INT_I
15976 call fooI(int(I1))
15977 c FFEINTRIN_imp_INT_R
15978 call fooI(int(R1))
15979 c FFEINTRIN_imp_REAL_C
15980 call fooR(real(C1))
15981 c FFEINTRIN_imp_REAL_D
15982 call fooR(real(D1))
15983 c FFEINTRIN_imp_REAL_I
15984 call fooR(real(I1))
15985 c FFEINTRIN_imp_REAL_R
15986 call fooR(real(R1))
15987 c
15988 c FFEINTRIN_imp_INT_D:
15989 c
15990 c FFEINTRIN_specIDINT
15991 call fooI(IDINT(D1))
15992 c
15993 c FFEINTRIN_imp_INT_R:
15994 c
15995 c FFEINTRIN_specIFIX
15996 call fooI(IFIX(R1))
15997 c FFEINTRIN_specINT
15998 call fooI(INT(R1))
15999 c
16000 c FFEINTRIN_imp_REAL_D:
16001 c
16002 c FFEINTRIN_specSNGL
16003 call fooR(SNGL(D1))
16004 c
16005 c FFEINTRIN_imp_REAL_I:
16006 c
16007 c FFEINTRIN_specFLOAT
16008 call fooR(FLOAT(I1))
16009 c FFEINTRIN_specREAL
16010 call fooR(REAL(I1))
16011 c
16012 end
16013 -------- (end input file to f2c)
16015 -------- (begin output from providing above input file as input to:
16016 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16017 -------- -e "s:^#.*$::g"')
16019 // -- translated by f2c (version 19950223).
16020 You must link the resulting object file with the libraries:
16021 -lf2c -lm (in that order)
16022 //
16025 // f2c.h -- Standard Fortran to C header file //
16027 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
16029 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16034 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16035 // we assume short, float are OK //
16036 typedef long int // long int // integer;
16037 typedef char *address;
16038 typedef short int shortint;
16039 typedef float real;
16040 typedef double doublereal;
16041 typedef struct { real r, i; } complex;
16042 typedef struct { doublereal r, i; } doublecomplex;
16043 typedef long int // long int // logical;
16044 typedef short int shortlogical;
16045 typedef char logical1;
16046 typedef char integer1;
16047 // typedef long long longint; // // system-dependent //
16052 // Extern is for use with -E //
16057 // I/O stuff //
16066 typedef long int // int or long int // flag;
16067 typedef long int // int or long int // ftnlen;
16068 typedef long int // int or long int // ftnint;
16071 //external read, write//
16072 typedef struct
16073 { flag cierr;
16074 ftnint ciunit;
16075 flag ciend;
16076 char *cifmt;
16077 ftnint cirec;
16078 } cilist;
16080 //internal read, write//
16081 typedef struct
16082 { flag icierr;
16083 char *iciunit;
16084 flag iciend;
16085 char *icifmt;
16086 ftnint icirlen;
16087 ftnint icirnum;
16088 } icilist;
16090 //open//
16091 typedef struct
16092 { flag oerr;
16093 ftnint ounit;
16094 char *ofnm;
16095 ftnlen ofnmlen;
16096 char *osta;
16097 char *oacc;
16098 char *ofm;
16099 ftnint orl;
16100 char *oblnk;
16101 } olist;
16103 //close//
16104 typedef struct
16105 { flag cerr;
16106 ftnint cunit;
16107 char *csta;
16108 } cllist;
16110 //rewind, backspace, endfile//
16111 typedef struct
16112 { flag aerr;
16113 ftnint aunit;
16114 } alist;
16116 // inquire //
16117 typedef struct
16118 { flag inerr;
16119 ftnint inunit;
16120 char *infile;
16121 ftnlen infilen;
16122 ftnint *inex; //parameters in standard's order//
16123 ftnint *inopen;
16124 ftnint *innum;
16125 ftnint *innamed;
16126 char *inname;
16127 ftnlen innamlen;
16128 char *inacc;
16129 ftnlen inacclen;
16130 char *inseq;
16131 ftnlen inseqlen;
16132 char *indir;
16133 ftnlen indirlen;
16134 char *infmt;
16135 ftnlen infmtlen;
16136 char *inform;
16137 ftnint informlen;
16138 char *inunf;
16139 ftnlen inunflen;
16140 ftnint *inrecl;
16141 ftnint *innrec;
16142 char *inblank;
16143 ftnlen inblanklen;
16144 } inlist;
16148 union Multitype { // for multiple entry points //
16149 integer1 g;
16150 shortint h;
16151 integer i;
16152 // longint j; //
16153 real r;
16154 doublereal d;
16155 complex c;
16156 doublecomplex z;
16157 };
16159 typedef union Multitype Multitype;
16161 typedef long Long; // No longer used; formerly in Namelist //
16163 struct Vardesc { // for Namelist //
16164 char *name;
16165 char *addr;
16166 ftnlen *dims;
16167 int type;
16168 };
16169 typedef struct Vardesc Vardesc;
16171 struct Namelist {
16172 char *name;
16173 Vardesc **vars;
16174 int nvars;
16175 };
16176 typedef struct Namelist Namelist;
16185 // procedure parameter types for -A and -C++ //
16190 typedef int // Unknown procedure type // (*U_fp)();
16191 typedef shortint (*J_fp)();
16192 typedef integer (*I_fp)();
16193 typedef real (*R_fp)();
16194 typedef doublereal (*D_fp)(), (*E_fp)();
16195 typedef // Complex // void (*C_fp)();
16196 typedef // Double Complex // void (*Z_fp)();
16197 typedef logical (*L_fp)();
16198 typedef shortlogical (*K_fp)();
16199 typedef // Character // void (*H_fp)();
16200 typedef // Subroutine // int (*S_fp)();
16202 // E_fp is for real functions when -R is not specified //
16203 typedef void C_f; // complex function //
16204 typedef void H_f; // character function //
16205 typedef void Z_f; // double complex function //
16206 typedef doublereal E_f; // real function with -R not specified //
16208 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16211 // (No such symbols should be defined in a strict ANSI C compiler.
16212 We can avoid trouble with f2c-translated code by using
16213 gcc -ansi [-traditional].) //
16237 // Main program // MAIN__()
16238 {
16239 // System generated locals //
16240 integer i__1;
16241 real r__1, r__2;
16242 doublereal d__1, d__2;
16243 complex q__1;
16244 doublecomplex z__1, z__2, z__3;
16245 logical L__1;
16246 char ch__1[1];
16248 // Builtin functions //
16249 void c_div();
16250 integer pow_ii();
16251 double pow_ri(), pow_di();
16252 void pow_ci();
16253 double pow_dd();
16254 void pow_zz();
16255 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16256 asin(), atan(), atan2(), c_abs();
16257 void c_cos(), c_exp(), c_log(), r_cnjg();
16258 double cos(), cosh();
16259 void c_sin(), c_sqrt();
16260 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16261 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16262 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16263 logical l_ge(), l_gt(), l_le(), l_lt();
16264 integer i_nint();
16265 double r_sign();
16267 // Local variables //
16268 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16269 fool_(), fooz_(), getem_();
16270 static char a1[10], a2[10];
16271 static complex c1, c2;
16272 static doublereal d1, d2;
16273 static integer i1, i2;
16274 static real r1, r2;
16277 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16278 // / //
16279 i__1 = i1 / i2;
16280 fooi_(&i__1);
16281 r__1 = r1 / i1;
16282 foor_(&r__1);
16283 d__1 = d1 / i1;
16284 food_(&d__1);
16285 d__1 = (doublereal) i1;
16286 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16287 fooc_(&q__1);
16288 r__1 = r1 / r2;
16289 foor_(&r__1);
16290 d__1 = r1 / d1;
16291 food_(&d__1);
16292 d__1 = d1 / d2;
16293 food_(&d__1);
16294 d__1 = d1 / r1;
16295 food_(&d__1);
16296 c_div(&q__1, &c1, &c2);
16297 fooc_(&q__1);
16298 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16299 fooc_(&q__1);
16300 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16301 fooz_(&z__1);
16302 // ** //
16303 i__1 = pow_ii(&i1, &i2);
16304 fooi_(&i__1);
16305 r__1 = pow_ri(&r1, &i1);
16306 foor_(&r__1);
16307 d__1 = pow_di(&d1, &i1);
16308 food_(&d__1);
16309 pow_ci(&q__1, &c1, &i1);
16310 fooc_(&q__1);
16311 d__1 = (doublereal) r1;
16312 d__2 = (doublereal) r2;
16313 r__1 = pow_dd(&d__1, &d__2);
16314 foor_(&r__1);
16315 d__2 = (doublereal) r1;
16316 d__1 = pow_dd(&d__2, &d1);
16317 food_(&d__1);
16318 d__1 = pow_dd(&d1, &d2);
16319 food_(&d__1);
16320 d__2 = (doublereal) r1;
16321 d__1 = pow_dd(&d1, &d__2);
16322 food_(&d__1);
16323 z__2.r = c1.r, z__2.i = c1.i;
16324 z__3.r = c2.r, z__3.i = c2.i;
16325 pow_zz(&z__1, &z__2, &z__3);
16326 q__1.r = z__1.r, q__1.i = z__1.i;
16327 fooc_(&q__1);
16328 z__2.r = c1.r, z__2.i = c1.i;
16329 z__3.r = r1, z__3.i = 0.;
16330 pow_zz(&z__1, &z__2, &z__3);
16331 q__1.r = z__1.r, q__1.i = z__1.i;
16332 fooc_(&q__1);
16333 z__2.r = c1.r, z__2.i = c1.i;
16334 z__3.r = d1, z__3.i = 0.;
16335 pow_zz(&z__1, &z__2, &z__3);
16336 fooz_(&z__1);
16337 // FFEINTRIN_impABS //
16338 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16339 foor_(&r__1);
16340 // FFEINTRIN_impACOS //
16341 r__1 = acos(r1);
16342 foor_(&r__1);
16343 // FFEINTRIN_impAIMAG //
16344 r__1 = r_imag(&c1);
16345 foor_(&r__1);
16346 // FFEINTRIN_impAINT //
16347 r__1 = r_int(&r1);
16348 foor_(&r__1);
16349 // FFEINTRIN_impALOG //
16350 r__1 = log(r1);
16351 foor_(&r__1);
16352 // FFEINTRIN_impALOG10 //
16353 r__1 = r_lg10(&r1);
16354 foor_(&r__1);
16355 // FFEINTRIN_impAMAX0 //
16356 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16357 foor_(&r__1);
16358 // FFEINTRIN_impAMAX1 //
16359 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16360 foor_(&r__1);
16361 // FFEINTRIN_impAMIN0 //
16362 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16363 foor_(&r__1);
16364 // FFEINTRIN_impAMIN1 //
16365 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16366 foor_(&r__1);
16367 // FFEINTRIN_impAMOD //
16368 r__1 = r_mod(&r1, &r2);
16369 foor_(&r__1);
16370 // FFEINTRIN_impANINT //
16371 r__1 = r_nint(&r1);
16372 foor_(&r__1);
16373 // FFEINTRIN_impASIN //
16374 r__1 = asin(r1);
16375 foor_(&r__1);
16376 // FFEINTRIN_impATAN //
16377 r__1 = atan(r1);
16378 foor_(&r__1);
16379 // FFEINTRIN_impATAN2 //
16380 r__1 = atan2(r1, r2);
16381 foor_(&r__1);
16382 // FFEINTRIN_impCABS //
16383 r__1 = c_abs(&c1);
16384 foor_(&r__1);
16385 // FFEINTRIN_impCCOS //
16386 c_cos(&q__1, &c1);
16387 fooc_(&q__1);
16388 // FFEINTRIN_impCEXP //
16389 c_exp(&q__1, &c1);
16390 fooc_(&q__1);
16391 // FFEINTRIN_impCHAR //
16392 *(unsigned char *)&ch__1[0] = i1;
16393 fooa_(ch__1, 1L);
16394 // FFEINTRIN_impCLOG //
16395 c_log(&q__1, &c1);
16396 fooc_(&q__1);
16397 // FFEINTRIN_impCONJG //
16398 r_cnjg(&q__1, &c1);
16399 fooc_(&q__1);
16400 // FFEINTRIN_impCOS //
16401 r__1 = cos(r1);
16402 foor_(&r__1);
16403 // FFEINTRIN_impCOSH //
16404 r__1 = cosh(r1);
16405 foor_(&r__1);
16406 // FFEINTRIN_impCSIN //
16407 c_sin(&q__1, &c1);
16408 fooc_(&q__1);
16409 // FFEINTRIN_impCSQRT //
16410 c_sqrt(&q__1, &c1);
16411 fooc_(&q__1);
16412 // FFEINTRIN_impDABS //
16413 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16414 food_(&d__1);
16415 // FFEINTRIN_impDACOS //
16416 d__1 = acos(d1);
16417 food_(&d__1);
16418 // FFEINTRIN_impDASIN //
16419 d__1 = asin(d1);
16420 food_(&d__1);
16421 // FFEINTRIN_impDATAN //
16422 d__1 = atan(d1);
16423 food_(&d__1);
16424 // FFEINTRIN_impDATAN2 //
16425 d__1 = atan2(d1, d2);
16426 food_(&d__1);
16427 // FFEINTRIN_impDCOS //
16428 d__1 = cos(d1);
16429 food_(&d__1);
16430 // FFEINTRIN_impDCOSH //
16431 d__1 = cosh(d1);
16432 food_(&d__1);
16433 // FFEINTRIN_impDDIM //
16434 d__1 = d_dim(&d1, &d2);
16435 food_(&d__1);
16436 // FFEINTRIN_impDEXP //
16437 d__1 = exp(d1);
16438 food_(&d__1);
16439 // FFEINTRIN_impDIM //
16440 r__1 = r_dim(&r1, &r2);
16441 foor_(&r__1);
16442 // FFEINTRIN_impDINT //
16443 d__1 = d_int(&d1);
16444 food_(&d__1);
16445 // FFEINTRIN_impDLOG //
16446 d__1 = log(d1);
16447 food_(&d__1);
16448 // FFEINTRIN_impDLOG10 //
16449 d__1 = d_lg10(&d1);
16450 food_(&d__1);
16451 // FFEINTRIN_impDMAX1 //
16452 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16453 food_(&d__1);
16454 // FFEINTRIN_impDMIN1 //
16455 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16456 food_(&d__1);
16457 // FFEINTRIN_impDMOD //
16458 d__1 = d_mod(&d1, &d2);
16459 food_(&d__1);
16460 // FFEINTRIN_impDNINT //
16461 d__1 = d_nint(&d1);
16462 food_(&d__1);
16463 // FFEINTRIN_impDPROD //
16464 d__1 = (doublereal) r1 * r2;
16465 food_(&d__1);
16466 // FFEINTRIN_impDSIGN //
16467 d__1 = d_sign(&d1, &d2);
16468 food_(&d__1);
16469 // FFEINTRIN_impDSIN //
16470 d__1 = sin(d1);
16471 food_(&d__1);
16472 // FFEINTRIN_impDSINH //
16473 d__1 = sinh(d1);
16474 food_(&d__1);
16475 // FFEINTRIN_impDSQRT //
16476 d__1 = sqrt(d1);
16477 food_(&d__1);
16478 // FFEINTRIN_impDTAN //
16479 d__1 = tan(d1);
16480 food_(&d__1);
16481 // FFEINTRIN_impDTANH //
16482 d__1 = tanh(d1);
16483 food_(&d__1);
16484 // FFEINTRIN_impEXP //
16485 r__1 = exp(r1);
16486 foor_(&r__1);
16487 // FFEINTRIN_impIABS //
16488 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16489 fooi_(&i__1);
16490 // FFEINTRIN_impICHAR //
16491 i__1 = *(unsigned char *)a1;
16492 fooi_(&i__1);
16493 // FFEINTRIN_impIDIM //
16494 i__1 = i_dim(&i1, &i2);
16495 fooi_(&i__1);
16496 // FFEINTRIN_impIDNINT //
16497 i__1 = i_dnnt(&d1);
16498 fooi_(&i__1);
16499 // FFEINTRIN_impINDEX //
16500 i__1 = i_indx(a1, a2, 10L, 10L);
16501 fooi_(&i__1);
16502 // FFEINTRIN_impISIGN //
16503 i__1 = i_sign(&i1, &i2);
16504 fooi_(&i__1);
16505 // FFEINTRIN_impLEN //
16506 i__1 = i_len(a1, 10L);
16507 fooi_(&i__1);
16508 // FFEINTRIN_impLGE //
16509 L__1 = l_ge(a1, a2, 10L, 10L);
16510 fool_(&L__1);
16511 // FFEINTRIN_impLGT //
16512 L__1 = l_gt(a1, a2, 10L, 10L);
16513 fool_(&L__1);
16514 // FFEINTRIN_impLLE //
16515 L__1 = l_le(a1, a2, 10L, 10L);
16516 fool_(&L__1);
16517 // FFEINTRIN_impLLT //
16518 L__1 = l_lt(a1, a2, 10L, 10L);
16519 fool_(&L__1);
16520 // FFEINTRIN_impMAX0 //
16521 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16522 fooi_(&i__1);
16523 // FFEINTRIN_impMAX1 //
16524 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16525 fooi_(&i__1);
16526 // FFEINTRIN_impMIN0 //
16527 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16528 fooi_(&i__1);
16529 // FFEINTRIN_impMIN1 //
16530 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16531 fooi_(&i__1);
16532 // FFEINTRIN_impMOD //
16533 i__1 = i1 % i2;
16534 fooi_(&i__1);
16535 // FFEINTRIN_impNINT //
16536 i__1 = i_nint(&r1);
16537 fooi_(&i__1);
16538 // FFEINTRIN_impSIGN //
16539 r__1 = r_sign(&r1, &r2);
16540 foor_(&r__1);
16541 // FFEINTRIN_impSIN //
16542 r__1 = sin(r1);
16543 foor_(&r__1);
16544 // FFEINTRIN_impSINH //
16545 r__1 = sinh(r1);
16546 foor_(&r__1);
16547 // FFEINTRIN_impSQRT //
16548 r__1 = sqrt(r1);
16549 foor_(&r__1);
16550 // FFEINTRIN_impTAN //
16551 r__1 = tan(r1);
16552 foor_(&r__1);
16553 // FFEINTRIN_impTANH //
16554 r__1 = tanh(r1);
16555 foor_(&r__1);
16556 // FFEINTRIN_imp_CMPLX_C //
16557 r__1 = c1.r;
16558 r__2 = c2.r;
16559 q__1.r = r__1, q__1.i = r__2;
16560 fooc_(&q__1);
16561 // FFEINTRIN_imp_CMPLX_D //
16562 z__1.r = d1, z__1.i = d2;
16563 fooz_(&z__1);
16564 // FFEINTRIN_imp_CMPLX_I //
16565 r__1 = (real) i1;
16566 r__2 = (real) i2;
16567 q__1.r = r__1, q__1.i = r__2;
16568 fooc_(&q__1);
16569 // FFEINTRIN_imp_CMPLX_R //
16570 q__1.r = r1, q__1.i = r2;
16571 fooc_(&q__1);
16572 // FFEINTRIN_imp_DBLE_C //
16573 d__1 = (doublereal) c1.r;
16574 food_(&d__1);
16575 // FFEINTRIN_imp_DBLE_D //
16576 d__1 = d1;
16577 food_(&d__1);
16578 // FFEINTRIN_imp_DBLE_I //
16579 d__1 = (doublereal) i1;
16580 food_(&d__1);
16581 // FFEINTRIN_imp_DBLE_R //
16582 d__1 = (doublereal) r1;
16583 food_(&d__1);
16584 // FFEINTRIN_imp_INT_C //
16585 i__1 = (integer) c1.r;
16586 fooi_(&i__1);
16587 // FFEINTRIN_imp_INT_D //
16588 i__1 = (integer) d1;
16589 fooi_(&i__1);
16590 // FFEINTRIN_imp_INT_I //
16591 i__1 = i1;
16592 fooi_(&i__1);
16593 // FFEINTRIN_imp_INT_R //
16594 i__1 = (integer) r1;
16595 fooi_(&i__1);
16596 // FFEINTRIN_imp_REAL_C //
16597 r__1 = c1.r;
16598 foor_(&r__1);
16599 // FFEINTRIN_imp_REAL_D //
16600 r__1 = (real) d1;
16601 foor_(&r__1);
16602 // FFEINTRIN_imp_REAL_I //
16603 r__1 = (real) i1;
16604 foor_(&r__1);
16605 // FFEINTRIN_imp_REAL_R //
16606 r__1 = r1;
16607 foor_(&r__1);
16609 // FFEINTRIN_imp_INT_D: //
16611 // FFEINTRIN_specIDINT //
16612 i__1 = (integer) d1;
16613 fooi_(&i__1);
16615 // FFEINTRIN_imp_INT_R: //
16617 // FFEINTRIN_specIFIX //
16618 i__1 = (integer) r1;
16619 fooi_(&i__1);
16620 // FFEINTRIN_specINT //
16621 i__1 = (integer) r1;
16622 fooi_(&i__1);
16624 // FFEINTRIN_imp_REAL_D: //
16626 // FFEINTRIN_specSNGL //
16627 r__1 = (real) d1;
16628 foor_(&r__1);
16630 // FFEINTRIN_imp_REAL_I: //
16632 // FFEINTRIN_specFLOAT //
16633 r__1 = (real) i1;
16634 foor_(&r__1);
16635 // FFEINTRIN_specREAL //
16636 r__1 = (real) i1;
16637 foor_(&r__1);
16639 } // MAIN__ //
16641 -------- (end output file from f2c)
16643 */