| blob | c100c2a12acc0e7af96fe067d4237842fd3dc02b |
1 /* com.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
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. */
96 /* VMS-specific definitions */
97 #ifdef VMS
98 #include <descrip.h>
101 #define read(fd,buf,size) VMS_read (fd,buf,size)
102 #define write(fd,buf,size) VMS_write (fd,buf,size)
103 #define open(fname,mode,prot) VMS_open (fname,mode,prot)
104 #define fopen(fname,mode) VMS_fopen (fname,mode)
105 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
106 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
107 #define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
117 #define ino_t vms_ino_t
138 /* Externals defined here. */
140 /* Stream for reading from the input file. */
143 /* These definitions parallel those in c-decl.c so that code from that
144 module can be used pretty much as is. Much of these defs aren't
145 otherwise used, i.e. by g77 code per se, except some of them are used
146 to build some of them that are. The ones that are global (i.e. not
147 "static") are those that ste.c and such might use (directly
148 or by using com macros that reference them in their definitions). */
150 tree string_type_node;
152 /* The rest of these are inventions for g77, though there might be
153 similar things in the C front end. As they are found, these
154 inventions should be renamed to be canonical. Note that only
155 the ones currently required to be global are so. */
164 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
165 just use build_function_type and build_pointer_type on the
166 appropriate _tree_type array element. */
176 ffecomSymbol ffecom_symbol_null_
177 =
178 {
179 NULL_TREE,
180 NULL_TREE,
181 NULL_TREE,
182 NULL_TREE,
183 false
184 };
189 tree ffecom_f2c_integer_type_node;
190 tree ffecom_f2c_ptr_to_integer_type_node;
191 tree ffecom_f2c_address_type_node;
192 tree ffecom_f2c_real_type_node;
193 tree ffecom_f2c_ptr_to_real_type_node;
194 tree ffecom_f2c_doublereal_type_node;
195 tree ffecom_f2c_complex_type_node;
196 tree ffecom_f2c_doublecomplex_type_node;
197 tree ffecom_f2c_longint_type_node;
198 tree ffecom_f2c_logical_type_node;
199 tree ffecom_f2c_flag_type_node;
200 tree ffecom_f2c_ftnlen_type_node;
201 tree ffecom_f2c_ftnlen_zero_node;
202 tree ffecom_f2c_ftnlen_one_node;
203 tree ffecom_f2c_ftnlen_two_node;
204 tree ffecom_f2c_ptr_to_ftnlen_type_node;
205 tree ffecom_f2c_ftnint_type_node;
206 tree ffecom_f2c_ptr_to_ftnint_type_node;
208 /* Simple definitions and enumerations. */
210 #ifndef FFECOM_sizeMAXSTACKITEM
212 larger than this # bytes
213 off stack if possible. */
214 #endif
216 /* For systems that have large enough stacks, they should define
217 this to 0, and here, for ease of use later on, we just undefine
218 it if it is 0. */
220 #if FFECOM_sizeMAXSTACKITEM == 0
221 #undef FFECOM_sizeMAXSTACKITEM
222 #endif
225 {
226 FFECOM_rttypeVOID_,
241 FFECOM_rttype_
244 /* Internal typedefs. */
248 /* Private include files. */
251 /* Internal structure definitions. */
253 struct _ffecom_concat_list_
254 {
258 ffetargetCharacterSize minlen;
259 ffetargetCharacterSize maxlen;
260 };
262 /* Static functions (internal). */
296 static ffecomConcatList_
298 ffebld expr,
299 ffetargetCharacterSize max);
302 ffetargetCharacterSize max);
305 ffetargetOffset offset);
322 ffeinfoBasictype bt,
323 ffeinfoKindtype kt);
331 tree dest_length,
332 ffetargetCharacterSize dest_size,
333 ffebld source);
338 ffebld source);
348 tree t);
355 ffeinfoBasictype bt,
356 ffeinfoKindtype kt);
365 /* These are static functions that parallel those found in the C front
366 end and thus have the same names. */
391 ffewhereColumn c);
393 /* Static objects accessed by functions in this module. */
419 static tree
427 /* Holds pointer-to-function expressions. */
430 =
431 {
432 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
434 #undef DEFGFRT
435 };
437 /* Holds the external names of the functions. */
440 =
441 {
442 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
444 #undef DEFGFRT
445 };
447 /* Whether the function returns. */
450 =
451 {
452 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
454 #undef DEFGFRT
455 };
457 /* Whether the function returns type complex. */
460 =
461 {
462 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
464 #undef DEFGFRT
465 };
467 /* Whether the function is const
468 (i.e., has no side effects and only depends on its arguments). */
471 =
472 {
473 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
475 #undef DEFGFRT
476 };
478 /* Type code for the function return value. */
481 =
482 {
483 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
485 #undef DEFGFRT
486 };
488 /* String of codes for the function's arguments. */
491 =
492 {
493 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
495 #undef DEFGFRT
496 };
498 /* Internal macros. */
500 /* We let tm.h override the types used here, to handle trivial differences
501 such as the choice of unsigned int or long unsigned int for size_t.
502 When machines start needing nontrivial differences in the size type,
503 it would be best to do something here to figure out automatically
504 from other information what type to use. */
506 #ifndef SIZE_TYPE
508 #endif
510 #define ffecom_concat_list_count_(catlist) ((catlist).count)
511 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
512 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
513 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
515 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
516 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
518 /* For each binding contour we allocate a binding_level structure
519 * which records the names defined in that contour.
520 * Contours include:
521 * 0) the global one
522 * 1) one for each function definition,
523 * where internal declarations of the parameters appear.
524 *
525 * The current meaning of a name can be found by searching the levels from
526 * the current one out to the global one.
527 */
529 /* Note that the information in the `names' component of the global contour
530 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
532 struct binding_level
533 {
534 /* A chain of _DECL nodes for all variables, constants, functions,
535 and typedef types. These are in the reverse of the order supplied.
536 */
537 tree names;
539 /* For each level (except not the global one),
540 a chain of BLOCK nodes for all the levels
541 that were entered and exited one level down. */
542 tree blocks;
544 /* The BLOCK node for this level, if one has been preallocated.
545 If 0, the BLOCK is allocated (if needed) when the level is popped. */
546 tree this_block;
548 /* The binding level which this one is contained in (inherits from). */
551 /* 0: no ffecom_prepare_* functions called at this level yet;
552 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
553 2: ffecom_prepare_end called. */
555 };
557 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
559 /* The binding level currently in effect. */
563 /* A chain of binding_level structures awaiting reuse. */
567 /* The outermost binding level, for names of file scope.
568 This is created when the compiler is started and exists
569 through the entire run. */
573 /* Binding level structures are initialized by copying this one. */
575 static const struct binding_level clear_binding_level
576 =
579 /* Language-dependent contents of an identifier. */
581 struct lang_identifier
582 {
586 };
588 /* Macros for access to language-specific slots in an identifier. */
589 /* Each of these slots contains a DECL node or null. */
591 /* This represents the value which the identifier has in the
592 file-scope namespace. */
593 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
594 (((struct lang_identifier *)(NODE))->global_value)
595 /* This represents the value which the identifier has in the current
596 scope. */
597 #define IDENTIFIER_LOCAL_VALUE(NODE) \
598 (((struct lang_identifier *)(NODE))->local_value)
599 /* This represents the value which the identifier has as a label in
600 the current label scope. */
601 #define IDENTIFIER_LABEL_VALUE(NODE) \
602 (((struct lang_identifier *)(NODE))->label_value)
603 /* This is nonzero if the identifier was "made up" by g77 code. */
604 #define IDENTIFIER_INVENTED(NODE) \
605 (((struct lang_identifier *)(NODE))->invented)
607 /* In identifiers, C uses the following fields in a special way:
608 TREE_PUBLIC to record that there was a previous local extern decl.
609 TREE_USED to record that such a decl was used.
610 TREE_ADDRESSABLE to record that the address of such a decl was used. */
612 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
613 that have names. Here so we can clear out their names' definitions
614 at the end of the function. */
618 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
621 \f
622 /* Return the subscript expression, modified to do range-checking.
624 `array' is the array to be checked against.
625 `element' is the subscript expression to check.
626 `dim' is the dimension number (starting at 0).
627 `total_dims' is the total number of dimensions (0 for CHARACTER substring).
628 */
630 static tree
633 {
636 tree cond;
637 tree die;
638 tree args;
644 {
648 else
649 {
653 }
654 }
658 {
659 /* Special handling for substring range checks. Fortran allows the
660 end subscript < begin subscript, which means that expressions like
661 string(1:0) are valid (and yield a null string). In view of this,
662 enforce two simpler conditions:
663 1) element<=high for end-substring;
664 2) element>=low for start-substring.
665 Run-time character movement will enforce remaining conditions.
667 More complicated checks would be better, but present structure only
668 provides one index element at a time, so it is not possible to
669 enforce a check of both i and j in string(i:j). If it were, the
670 complete set of rules would read,
671 if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
672 ((low<=i<=high) && (low<=j<=high)) )
673 ok ;
674 else
675 range error ;
676 */
679 else
681 }
682 else
683 {
684 /* Array reference substring range checking. */
687 low,
688 element);
690 {
692 cond,
694 element,
695 high));
696 }
697 }
699 {
703 tree arg3;
704 tree arg2;
705 tree arg1;
706 tree arg4;
709 {
726 array_name,
732 }
736 build_range_type
738 integer_one_node,
744 arg1);
746 /* s_rnge adds one to the element to print it, so bias against
747 that -- want to print a faithful *subscript* value. */
751 element,
753 integer_one_node)));
757 NULL);
765 build_range_type
767 integer_one_node,
773 arg3);
787 }
794 cond,
795 element,
796 die);
799 }
801 /* Return the computed element of an array reference.
803 `item' is NULL_TREE, or the transformed pointer to the array.
804 `expr' is the original opARRAYREF expression, which is transformed
805 if `item' is NULL_TREE.
806 `want_ptr' is non-zero if a pointer to the element, instead of
807 the element itself, is to be returned. */
809 static tree
811 {
817 tree array;
818 tree element;
819 tree tree_type;
820 tree tree_type_x;
822 ffetype type;
823 ffebld list;
827 else
830 /* Build up ARRAY_REFs in reverse order (since we're column major
831 here in Fortran land). */
836 {
843 /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
844 pointers and 32-bit integers. Do the full 64-bit pointer
845 arithmetic, for codes using arrays for nonstandard heap-like
846 work. */
848 }
855 {
858 else
867 }
873 {
874 tree min;
879 {
884 array_name);
888 /* Widen integral arithmetic as desired while preserving
889 signedness. */
904 item,
909 tree_type_x,
911 }
913 {
916 item);
917 }
918 }
919 else
920 {
924 {
930 array_name);
934 /* Widen integral arithmetic as desired while preserving
935 signedness. */
947 item,
948 element);
949 }
950 }
953 }
955 /* This is like gcc's stabilize_reference -- in fact, most of the code
956 comes from that -- but it handles the situation where the reference
957 is going to have its subparts picked at, and it shouldn't change
958 (or trigger extra invocations of functions in the subtrees) due to
959 this. save_expr is a bit overzealous, because we don't need the
960 entire thing calculated and saved like a temp. So, for DECLs, no
961 change is needed, because these are stable aggregates, and ARRAY_REF
962 and such might well be stable too, but for things like calculations,
963 we do need to calculate a snapshot of a value before picking at it. */
965 static tree
967 {
968 tree result;
972 {
976 /* No action is needed in this case. */
1028 }
1036 }
1038 /* A rip-off of gcc's convert.c convert_to_complex function,
1039 reworked to handle complex implemented as C structures
1040 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
1042 static tree
1044 {
1046 tree subtype;
1053 {
1057 }
1060 {
1064 else
1065 {
1068 type,
1072 expr)),
1076 expr)));
1077 }
1078 }
1082 else
1088 }
1090 /* Like gcc's convert(), but crashes if widening might happen. */
1092 static tree
1095 {
1108 {
1111 }
1118 {
1125 }
1127 {
1130 }
1132 {
1136 }
1138 {
1142 }
1144 {
1146 /* Check that at least the first field name agrees. */
1155 }
1159 }
1161 /* Like gcc's convert(), but crashes if narrowing might happen. */
1163 static tree
1166 {
1179 {
1182 }
1189 {
1196 }
1198 {
1201 }
1203 {
1207 }
1209 {
1213 }
1215 {
1217 /* Check that at least the first field name agrees. */
1226 }
1230 }
1232 /* Handles making a COMPLEX type, either the standard
1233 (but buggy?) gbe way, or the safer (but less elegant?)
1234 f2c way. */
1236 static tree
1238 {
1239 tree type;
1240 tree realfield;
1241 tree imagfield;
1244 {
1250 }
1251 else
1252 {
1256 }
1259 }
1261 /* Chooses either the gbe or the f2c way to build a
1262 complex constant. */
1264 static tree
1266 {
1267 tree bothparts;
1270 {
1274 }
1275 else
1276 {
1278 }
1281 }
1283 static tree
1285 {
1286 tree list;
1290 tree length;
1291 ffebld exprh;
1292 tree item;
1301 {
1303 {
1306 {
1309 }
1311 {
1350 }
1351 }
1358 || (ptr
1359 && (TYPE_MODE
1363 *plist
1367 else
1368 {
1372 {
1375 item);
1376 }
1377 *plist
1379 item);
1380 }
1385 {
1388 }
1389 }
1391 /* We've run out of args in the call; if the implementation expects
1392 more, supply null pointers for them, which the implementation can
1393 check to see if an arg was omitted. */
1396 {
1399 else
1403 {
1417 }
1418 *plist
1420 null_pointer_node);
1422 }
1427 }
1429 static tree
1431 {
1432 ffebld item;
1434 ffetype type;
1436 tree t;
1439 {
1452 {
1455 }
1456 }
1463 }
1465 /* Check whether a partial overlap between two expressions is possible.
1467 Can *starting* to write a portion of expr1 change the value
1468 computed (perhaps already, *partially*) by expr2?
1470 Currently, this is a concern only for a COMPLEX expr1. But if it
1471 isn't in COMMON or local EQUIVALENCE, since we don't support
1472 aliasing of arguments, it isn't a concern. */
1474 static bool
1476 {
1477 ffesymbol sym;
1478 ffestorag st;
1481 {
1494 }
1502 /* It's in COMMON or local EQUIVALENCE. */
1505 }
1507 /* Check whether dest and source might overlap. ffebld versions of these
1508 might or might not be passed, will be NULL if not.
1510 The test is really whether source_tree is modifiable and, if modified,
1511 might overlap destination such that the value(s) in the destination might
1512 change before it is finally modified. dest_* are the canonized
1513 destination itself. */
1515 static bool
1519 {
1520 tree source_decl;
1521 tree source_offset;
1522 tree source_size;
1523 tree t;
1529 {
1594 scalar_arg);
1599 scalar_arg);
1609 source_tree);
1614 return
1617 scalar_arg)
1620 scalar_arg);
1649 }
1651 /* Come here when source_decl, source_offset, and source_size filled
1652 in appropriately. */
1662 array? Shouldn't happen.... */
1666 dest_offset,
1668 dest_size)),
1670 source_offset));
1683 source_offset,
1685 source_size)),
1687 dest_offset));
1693 }
1695 /* Check whether dest might overlap any of a list of arguments or is
1696 in a COMMON area the callee might know about (and thus modify). */
1698 static bool
1702 {
1703 tree arg;
1704 tree dest_decl;
1705 tree dest_offset;
1706 tree dest_size;
1709 dest_tree);
1714 /* If the decl cannot be determined reliably, or if its in COMMON
1715 and the callee isn't known to not futz with COMMON via other
1716 means, overlap might happen. */
1724 {
1729 }
1732 }
1734 /* Build a string for a variable name as used by NAMELIST. This means that
1735 if we're using the f2c library, we build an uppercase string, since
1736 f2c does this. */
1738 static tree
1740 {
1744 {
1749 tree t;
1753 else
1766 }
1767 }
1769 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1770 type to just get whatever the function returns), handling the
1771 f2c value-returning convention, if required, by prepending
1772 to the arglist a pointer to a temporary to receive the return value. */
1774 static tree
1779 {
1780 tree item;
1781 tree tempvar;
1787 {
1795 callee_commons,
1796 scalar_args))
1797 {
1798 #ifdef HOHO
1801 FFETARGET_charactersizeNONE,
1803 #else
1806 #endif
1807 }
1808 else
1809 {
1813 }
1815 item
1819 tempvar));
1827 }
1828 else
1836 }
1838 /* Given two arguments, transform them and make a call to the given
1839 function via ffecom_call_. */
1841 static tree
1846 {
1847 tree left_tree;
1848 tree right_tree;
1849 tree left_length;
1850 tree right_length;
1853 {
1854 /* Pass arguments by reference. */
1857 }
1858 else
1859 {
1860 /* Pass arguments by value. */
1863 }
1871 {
1874 }
1877 {
1881 else
1883 }
1888 }
1890 /* Return ptr/length args for char subexpression
1892 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1893 subexpressions by constructing the appropriate trees for the ptr-to-
1894 character-text and length-of-character-text arguments in a calling
1895 sequence.
1897 Note that if with_null is TRUE, and the expression is an opCONTER,
1898 a null byte is appended to the string. */
1900 static void
1902 {
1903 tree item;
1904 tree high;
1905 ffetargetCharacter1 val;
1906 ffetargetCharacterSize newlen;
1909 {
1914 {
1915 /* Begin FFETARGET-NULL-KLUDGE. */
1918 }
1925 /* End FFETARGET-NULL-KLUDGE. */
1927 = build_type_variant
1928 (build_array_type
1930 build_range_type
1932 ffecom_f2c_ftnlen_one_node,
1933 high)),
1938 item);
1942 {
1947 {
1950 }
1952 {
1955 else
1956 {
1959 }
1960 }
1963 else
1964 /* FFEINFO_kindFUNCTION. */
1970 item);
1971 }
1975 {
1979 {
1982 }
1985 }
1989 {
1990 ffebld start;
1991 ffebld end;
1993 tree start_tree;
1994 tree end_tree;
1996 ffebld left_symter;
1997 tree array;
2005 /* Determine name for pretty-printing range-check errors. */
2009 ;
2012 else
2018 {
2021 }
2025 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2028 {
2030 ;
2031 else
2032 {
2036 char_name);
2038 end_tree);
2041 {
2044 }
2047 }
2048 }
2049 else
2050 {
2054 char_name);
2056 start_tree);
2059 {
2062 }
2067 item,
2070 start_tree,
2071 ffecom_f2c_ftnlen_one_node));
2074 {
2076 ffecom_f2c_ftnlen_one_node,
2078 ffecom_f2c_ftnlen_type_node,
2080 start_tree));
2081 }
2082 else
2083 {
2087 char_name);
2089 end_tree);
2092 {
2095 }
2098 ffecom_f2c_ftnlen_one_node,
2100 ffecom_f2c_ftnlen_type_node,
2102 }
2103 }
2104 }
2108 {
2110 tree tempvar;
2111 tree args;
2113 ffecomGfrt ix;
2116 /* ~~Kludge alert! This should someday be fixed. */
2124 {
2126 {
2127 /* Invocation of an intrinsic returning CHARACTER*1. */
2131 }
2135 }
2136 else
2137 {
2141 {
2144 }
2146 {
2149 }
2153 }
2155 #ifdef HOHO
2157 #else
2160 #endif
2163 tempvar);
2169 else
2170 {
2173 {
2177 }
2178 else
2179 {
2182 }
2183 }
2189 tempvar);
2190 }
2198 {
2201 }
2207 temporary. */
2208 tree tempvar;
2209 tree args;
2210 tree newlen;
2212 #ifdef HOHO
2215 #else
2218 #endif
2221 tempvar);
2235 tempvar);
2237 }
2238 else
2242 }
2249 }
2252 }
2254 /* Check the size of the type to be sure it doesn't overflow the
2255 "portable" capacities of the compiler back end. `dummy' types
2256 can generally overflow the normal sizes as long as the computations
2257 themselves don't overflow. A particular target of the back end
2258 must still enforce its size requirements, though, and the back
2259 end takes care of this in stor-layout.c. */
2261 static tree
2263 {
2273 /* An array is too large if size is negative or the type_size overflows
2274 or its "upper half" is larger than 3 (which would make the signed
2275 byte size and offset computations overflow). */
2280 {
2287 }
2290 }
2292 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2293 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2294 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2296 static tree
2298 {
2300 tree highval;
2301 tree tlen;
2306 else
2307 {
2311 else
2315 }
2318 {
2321 }
2322 else
2323 {
2326 }
2330 ffecom_f2c_ftnlen_one_node,
2331 highval));
2335 }
2337 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2339 ffecomConcatList_ catlist;
2340 ffebld expr; // expr of CHARACTER basictype.
2341 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2342 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2344 Scans expr for character subexpressions, updates and returns catlist
2345 accordingly. */
2347 static ffecomConcatList_
2349 ffetargetCharacterSize max)
2350 {
2351 ffetargetCharacterSize sz;
2353 recurse:
2362 {
2369 if they don't need to preserve it. */
2379 {
2383 }
2386 }
2389 else
2393 else
2397 of the destination. */
2399 {
2405 /* ~~Do useful truncations here. */
2411 }
2412 }
2426 dummy arg of sfunc */
2429 {
2430 ffetargetCharacterSize cmax;
2436 }
2438 #endif
2446 }
2447 }
2449 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2451 ffecomConcatList_ catlist;
2452 ffecom_concat_list_kill_(catlist);
2454 Anything allocated within the list info is deallocated. */
2456 static void
2458 {
2462 }
2464 /* Make list of concatenated string exprs.
2466 Returns a flattened list of concatenated subexpressions given a
2467 tree of such expressions. */
2469 static ffecomConcatList_
2471 {
2472 ffecomConcatList_ catlist;
2476 }
2478 /* Provide some kind of useful info on member of aggregate area,
2479 since current g77/gcc technology does not provide debug info
2480 on these members. */
2482 static void
2485 {
2486 tree value;
2487 tree decl;
2491 #if 0
2492 tree type_id;
2496 )
2497 {
2499 {
2514 }
2515 }
2516 #endif
2525 #if 0
2527 #endif
2531 else
2535 aggr_type,
2542 build_range_type
2544 integer_one_node,
2559 }
2561 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2563 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2564 int i; // entry# for this entrypoint (used by master fn)
2565 ffecom_do_entrypoint_(s,i);
2567 Makes a public entry point that calls our private master fn (already
2568 compiled). */
2570 static void
2572 {
2573 ffebld item;
2577 ffeinfoBasictype bt;
2578 ffeinfoKindtype kt;
2579 ffeglobal g;
2580 ffeglobalType gt;
2582 CHARACTER. */
2595 {
2598 /* Determine actual return type for function. */
2604 {
2610 }
2617 else
2624 else
2643 {
2645 {
2648 }
2649 }
2652 else
2654 }
2655 else
2664 /* Fall through. */
2674 }
2676 /* build_decl uses the current lineno and input_filename to set the decl
2677 source info. So, I've putzed with ffestd and ffeste code to update that
2678 source info to point to the appropriate statement just before calling
2679 ffecom_do_entrypoint (which calls this fn). */
2682 type,
2689 {
2691 }
2693 /* Reset args in master arg list so they get retransitioned. */
2698 {
2699 ffebld arg;
2700 ffesymbol s;
2708 }
2710 /* Build dummy arg list for this entry point. */
2714 tree type;
2715 tree length;
2719 else
2724 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2728 else
2738 {
2741 }
2742 }
2743 else
2751 /* Disallow temp vars at this level. */
2754 /* Make local var to hold return type for multi-type master fn. */
2757 {
2761 ffecom_multi_type_node_);
2764 }
2765 else
2768 /* Here we emit the actual code for the entry point. */
2770 {
2771 ffebld list;
2772 ffebld arg;
2773 ffesymbol s;
2776 tree prepend;
2777 tree call;
2778 tree actarg;
2779 tree master_fn;
2781 /* Prepare actual arg list based on master arg list. */
2786 {
2794 else
2798 }
2800 /* This code appends the length arguments for character
2801 variables/arrays. */
2806 {
2818 else
2822 }
2824 /* Prepend character-value return info to actual arg list. */
2827 {
2833 }
2835 /* Prepend multi-type return value to actual arg list. */
2838 {
2839 prepend
2843 multi_retval));
2846 }
2848 /* Prepend my entry-point number to the actual arg list. */
2854 /* Build the call to the master function. */
2861 /* Decide whether the master function is a function or subroutine, and
2862 handle the return value for my entry point. */
2866 {
2869 }
2871 {
2873 result
2876 result);
2879 multi_retval,
2883 }
2885 {
2887 result
2892 multi_retval,
2895 }
2897 {
2898 result
2901 result);
2905 }
2906 else
2907 {
2909 result,
2911 call));
2913 }
2914 }
2924 }
2926 /* Transform expr into gcc tree with possible destination
2928 Recursive descent on expr while making corresponding tree nodes and
2929 attaching type info and such. If destination supplied and compatible
2930 with temporary that would be made in certain cases, temporary isn't
2931 made, destination used instead, and dest_used flag set TRUE. */
2933 static tree
2936 {
2937 tree item;
2938 tree list;
2939 tree args;
2940 ffeinfoBasictype bt;
2941 ffeinfoKindtype kt;
2942 tree t;
2946 ffesymbol s;
2958 /* Widen integral arithmetic as desired while preserving signedness. */
2966 {
2968 {
2969 ffebitCount i;
2973 tree purpose;
2981 {
2982 ffebldConstantUnion cu;
2983 ffebitCount length;
2992 {
2994 {
3003 else
3008 else
3009 {
3012 }
3013 }
3014 }
3017 }
3018 }
3024 item
3025 = build_array_type
3028 ffecom_integer_zero_node,
3029 item));
3036 {
3037 ffetargetOffset i;
3042 else
3043 {
3047 /* Becomes PURPOSE first time through loop. */
3049 }
3052 {
3053 ffebldConstantUnion cu
3059 /* Assume item is PURPOSE first time through loop. */
3061 else
3062 {
3065 }
3066 }
3067 }
3072 item
3073 = build_array_type
3076 ffecom_integer_zero_node,
3077 item));
3085 item
3100 {
3101 /* User explicitly wants ASSIGN'ed variables to be at the same
3102 memory address as the variables when used in non-ASSIGN
3103 contexts. That can make old, arcane, non-standard code
3104 work, but don't try to do it when a pointer wouldn't fit
3105 in the normal variable (take other approach, and warn,
3106 instead). */
3109 {
3113 }
3120 {
3125 }
3128 {
3129 /* xgettext:no-c-format */
3131 FFEBAD_severityWARNING);
3136 }
3137 }
3139 /* Don't use the normal variable's tree for ASSIGN, though mark
3140 it as in the system header (housekeeping). Use an explicit,
3141 specially created sibling that is known to be wide enough
3142 to hold pointers to labels. */
3150 {
3154 }
3155 }
3156 else
3157 {
3159 {
3163 }
3167 }
3178 /* ~~~Make sure Fortran rules respected here */
3185 {
3188 }
3195 {
3199 }
3206 {
3210 }
3217 {
3221 }
3228 {
3232 }
3238 {
3241 ffecomGfrt code;
3242 ffeinfoKindtype rtkt;
3243 ffeinfoKindtype ltkt;
3247 {
3251 {
3255 }
3259 {
3265 {
3269 }
3270 else
3271 {
3274 }
3280 {
3283 }
3284 else
3285 {
3288 }
3294 {
3297 }
3298 else
3299 {
3302 }
3310 }
3315 FFETARGET_charactersizeNONE,
3316 FFEEXPR_contextLET);
3319 FFEINFO_basictypeINTEGER,
3321 FFETARGET_charactersizeNONE,
3322 FFEEXPR_contextLET);
3329 FFETARGET_charactersizeNONE,
3330 FFEEXPR_contextLET);
3334 FFEINFO_basictypeREAL,
3336 FFETARGET_charactersizeNONE,
3337 FFEEXPR_contextLET);
3338 /* We used to call FFECOM_gfrtPOW_DD here,
3339 which passes arguments by reference. */
3341 /* Pass arguments by value. */
3348 FFEINFO_basictypeCOMPLEX,
3350 FFETARGET_charactersizeNONE,
3351 FFEEXPR_contextLET);
3355 FFEINFO_basictypeCOMPLEX,
3357 FFETARGET_charactersizeNONE,
3358 FFEEXPR_contextLET);
3367 }
3376 }
3380 {
3391 /* Fall through. */
3394 }
3400 /* Fall through. */
3406 dest_used);
3408 }
3412 {
3415 }
3421 else
3426 else
3437 tree_type,
3438 args,
3447 {
3449 item
3462 /* Fall through. */
3465 }
3470 {
3472 item
3485 /* Fall through. */
3488 }
3494 {
3496 item
3509 /* Fall through. */
3512 }
3517 {
3519 item
3526 return
3534 /* Fall through. */
3537 }
3545 {
3553 {
3560 /* convert() takes care of converting to the subtype first,
3561 at least in gcc-2.7.2. */
3570 /* Fall through. */
3573 }
3578 /* Fall through. */
3581 }
3609 {
3620 {
3621 tree real_type;
3632 {
3635 }
3636 else
3637 {
3640 }
3642 item
3650 arg2)));
3653 else
3656 }
3659 {
3662 tree left_tree;
3663 tree right_tree;
3664 tree left_length;
3665 tree right_length;
3667 /* f2c run-time functions do the implicit blank-padding for us,
3668 so we don't usually have to implement blank-padding ourselves.
3669 (The exception is when we pass an argument to a separately
3670 compiled statement function -- if we know the arg is not the
3671 same length as the dummy, we must truncate or extend it. If
3672 we "inline" statement functions, that necessity goes away as
3673 well.)
3675 Strip off the CONVERT operators that blank-pad. (Truncation by
3676 CONVERT shouldn't happen here, but it can happen in
3677 assignments.) */
3694 {
3695 left_tree
3698 left_tree);
3699 right_tree
3702 right_tree);
3704 item
3708 left_tree,
3709 integer_one_node),
3712 right_tree,
3713 integer_one_node));
3714 }
3715 else
3716 {
3720 left_length);
3725 item,
3727 integer_zero_node));
3728 }
3730 }
3736 /* Fall through. */
3739 }
3761 /* Fall through. */
3764 }
3766 #if 1
3768 #else
3770 {
3787 }
3790 #endif
3791 }
3793 /* Returns the tree that does the intrinsic invocation.
3795 Note: this function applies only to intrinsics returning
3796 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3797 subroutines. */
3799 static tree
3802 {
3803 tree expr_tree;
3806 ffeinfoBasictype bt;
3807 ffeinfoKindtype kt;
3808 tree tree_type;
3809 tree arg1_type;
3811 tree tempvar;
3814 ffebld arg2;
3815 ffebld arg3;
3816 ffeintrinImp codegen_imp;
3817 ffecomGfrt gfrt;
3829 {
3834 {
3839 {
3843 }
3844 else
3846 }
3847 else
3849 }
3850 else
3853 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3854 args. This is used by the MAX/MIN expansions. */
3857 arg1_type = ffecom_tree_type
3860 else
3862 here. */
3864 /* There are several ways for each of the cases in the following switch
3865 statements to exit (from simplest to use to most complicated):
3867 break; (when expr_tree == NULL)
3869 A standard call is made to the specific intrinsic just as if it had been
3870 passed in as a dummy procedure and called as any old procedure. This
3871 method can produce slower code but in some cases it's the easiest way for
3872 now. However, if a (presumably faster) direct call is available,
3873 that is used, so this is the easiest way in many more cases now.
3875 gfrt = FFECOM_gfrtWHATEVER;
3876 break;
3878 gfrt contains the gfrt index of a library function to call, passing the
3879 argument(s) by value rather than by reference. Used when a more
3880 careful choice of library function is needed than that provided
3881 by the vanilla `break;'.
3883 return expr_tree;
3885 The expr_tree has been completely set up and is ready to be returned
3886 as is. No further actions are taken. Use this when the tree is not
3887 in the simple form for one of the arity_n labels. */
3889 /* For info on how the switch statement cases were written, see the files
3890 enclosed in comments below the switch statement. */
3898 {
3906 {
3912 }
3925 else
3928 return
3935 #if 0
3936 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
3939 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3941 return
3944 ffecom_truth_value
3946 saved_expr1,
3948 ffecom_float_zero_))),
3952 saved_expr1)),
3953 NULL_TREE),
3959 arg1_type,
3960 saved_expr1))),
3961 NULL_TREE)
3962 ))
3963 );
3964 #endif
3969 numbers of large magnitudes. */
3974 ffecom_truth_value
3976 integer_type_node,
3977 saved_expr1,
3978 ffecom_float_zero_)),
3980 tree_type,
3981 saved_expr1,
3982 ffecom_float_half_),
3984 tree_type,
3985 saved_expr1,
3986 ffecom_float_half_))));
3989 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3991 return
3994 ffecom_truth_value
3996 saved_expr1,
3998 ffecom_float_zero_))),
4003 arg1_type,
4004 saved_expr1,
4006 ffecom_float_half_)))),
4007 NULL_TREE),
4013 arg1_type,
4015 ffecom_float_half_),
4016 saved_expr1))),
4017 NULL_TREE))
4018 )
4019 );
4020 #endif
4032 #ifdef HOHO
4034 #else
4037 #endif
4038 {
4043 integer_one_node),
4045 }
4047 expr_tree,
4048 tempvar);
4051 expr_tree);
4057 return
4061 return
4068 return
4075 {
4076 tree arg1_tree;
4080 return
4085 }
4092 {
4097 }
4126 return
4128 ffecom_truth_value
4130 saved_expr1,
4131 saved_expr2)),
4133 saved_expr1,
4134 saved_expr2),
4138 return
4148 {
4153 }
4160 expr_tree
4163 expr_tree);
4164 expr_tree
4167 expr_tree,
4168 integer_one_node);
4173 saved_expr1,
4174 expr_tree,
4177 #endif
4183 #if 0
4185 #else
4187 #endif
4201 {
4206 }
4216 /* We used to call FFECOM_gfrtALOG10 here. */
4219 /* We used to call FFECOM_gfrtDLOG10 here. */
4231 else
4237 {
4242 expr_tree,
4245 }
4256 else
4262 {
4267 expr_tree,
4270 }
4282 /* We used to call FFECOM_gfrtAMOD here. */
4285 /* We used to call FFECOM_gfrtDMOD here. */
4291 #if 0
4292 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4294 #else
4295 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4297 return
4300 ffecom_truth_value
4302 saved_expr1,
4304 ffecom_float_zero_))),
4306 saved_expr1,
4308 ffecom_float_half_)),
4310 saved_expr1,
4312 ffecom_float_half_))));
4313 #endif
4318 {
4321 saved_expr1
4322 = ffecom_save_tree
4326 expr_tree
4328 ffecom_truth_value
4330 arg2_tree,
4332 integer_zero_node))),
4333 saved_expr1,
4335 /* Make sure SAVE_EXPRs get referenced early enough. */
4336 expr_tree
4339 expr_tree);
4340 }
4348 {
4353 }
4365 {
4370 }
4382 else
4385 return
4433 {
4434 ffetargetLogical1 target_true;
4435 ffetargetLogical1 target_false;
4436 tree true_tree;
4437 tree false_tree;
4443 else
4447 else
4450 return
4452 ffecom_truth_value
4458 integer_one_node),
4462 integer_zero_node))),
4463 false_tree,
4464 true_tree);
4465 }
4468 return
4474 integer_one_node),
4479 {
4482 tree uns_type
4485 expr_tree
4494 uns_type,
4496 integer_zero_node)),
4498 integer_type_node,
4500 arg3_tree))));
4501 /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE. */
4502 expr_tree
4504 ffecom_truth_value
4506 arg3_tree,
4507 integer_zero_node)),
4508 expr_tree,
4510 }
4514 return
4523 {
4527 tree uns_type
4530 expr_tree
4532 ffecom_truth_value
4534 arg2_tree,
4535 integer_zero_node)),
4537 arg1_tree,
4538 arg2_tree),
4543 integer_type_node,
4544 arg2_tree))));
4545 /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds. */
4546 expr_tree
4548 ffecom_truth_value
4551 integer_type_node,
4552 arg2_tree),
4554 expr_tree,
4556 /* Make sure SAVE_EXPRs get referenced early enough. */
4557 expr_tree
4562 expr_tree));
4563 }
4567 {
4573 tree shift_neg;
4574 tree shift_pos;
4575 tree mask_arg1;
4576 tree masked_arg1;
4577 tree uns_type
4580 mask_arg1
4584 arg3_tree);
4585 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4586 mask_arg1
4588 ffecom_truth_value
4590 arg3_tree,
4592 mask_arg1,
4595 masked_arg1
4597 arg1_tree,
4599 mask_arg1));
4601 shift_neg
4607 integer_type_node,
4608 arg2_tree))),
4610 arg1_tree,
4612 arg2_tree,
4613 arg3_tree)));
4614 shift_pos
4617 arg1_tree,
4618 arg2_tree),
4623 integer_type_node,
4624 arg3_tree,
4625 arg2_tree))));
4626 expr_tree
4628 ffecom_truth_value
4630 arg2_tree,
4631 integer_zero_node)),
4632 shift_neg,
4633 shift_pos);
4634 expr_tree
4637 mask_arg1,
4638 arg1_tree),
4641 mask_arg1),
4642 expr_tree));
4643 expr_tree
4645 ffecom_truth_value
4649 integer_type_node,
4650 arg2_tree),
4651 arg3_tree),
4653 arg2_tree,
4654 integer_zero_node))),
4655 arg1_tree,
4656 expr_tree);
4657 /* Make sure SAVE_EXPRs get referenced early enough. */
4658 expr_tree
4665 mask_arg1),
4668 masked_arg1),
4669 expr_tree))));
4670 expr_tree
4673 arg3_tree),
4674 expr_tree);
4675 }
4679 {
4682 expr_tree
4686 arg1_tree));
4687 }
4691 {
4692 tree arg1_tree;
4693 tree arg2_tree;
4694 tree arg3_tree;
4696 tree arg4_tree;
4697 tree arg4_type;
4699 tree arg5_tree;
4700 tree prep_arg1;
4701 tree prep_arg4;
4702 tree arg5_plus_arg3;
4717 prep_arg1
4721 arg1_tree,
4722 arg2_tree),
4726 arg4_type,
4727 convert
4729 integer_zero_node)),
4730 arg3_tree))),
4731 arg5_tree);
4732 arg5_plus_arg3
4734 arg5_tree,
4735 arg3_tree));
4736 prep_arg4
4740 integer_zero_node)),
4741 arg5_plus_arg3);
4742 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4743 prep_arg4
4745 ffecom_truth_value
4747 arg5_plus_arg3,
4750 prep_arg4,
4752 prep_arg4
4754 arg4_tree,
4756 prep_arg4,
4760 arg4_type,
4761 convert
4763 integer_zero_node)),
4764 arg5_tree))));
4765 prep_arg1
4767 prep_arg1,
4768 prep_arg4);
4769 /* Fix up (twice), because LSHIFT_EXPR above
4770 can't shift over TYPE_SIZE. */
4771 prep_arg1
4773 ffecom_truth_value
4775 arg3_tree,
4777 integer_zero_node))),
4778 prep_arg1,
4779 arg4_tree);
4780 prep_arg1
4782 ffecom_truth_value
4784 arg3_tree,
4787 prep_arg1,
4788 arg1_tree);
4789 expr_tree
4791 arg4_tree,
4792 prep_arg1);
4793 /* Make sure SAVE_EXPRs get referenced early enough. */
4794 expr_tree
4796 arg1_tree,
4798 arg3_tree,
4800 arg5_tree,
4802 arg5_plus_arg3,
4803 expr_tree))));
4804 expr_tree
4806 arg4_tree,
4807 expr_tree);
4809 }
4819 /* extern int xargc; i__1 = xargc - 1; */
4821 ffecom_tree_xargc_,
4823 integer_one_node));
4828 {
4829 tree arg1_tree;
4830 tree arg2_tree;
4831 tree arg3_tree;
4837 arg1_tree);
4839 /* Pass procedure as a pointer to it, anything else by value. */
4842 else
4845 arg2_tree);
4849 else
4856 expr_tree
4859 FALSE,
4861 NULL_TREE :
4862 tree_type),
4863 arg1_tree,
4868 expr_tree
4871 expr_tree));
4872 }
4876 {
4877 tree arg1_tree;
4878 tree arg2_tree;
4879 tree arg3_tree;
4885 arg1_tree);
4887 /* Pass procedure as a pointer to it, anything else by value. */
4890 else
4893 arg2_tree);
4897 else
4904 expr_tree
4907 FALSE,
4908 NULL_TREE,
4909 arg1_tree,
4914 expr_tree
4917 expr_tree));
4918 }
4929 {
4931 tree arg1_tree;
4932 tree arg2_tree;
4938 else
4945 expr_tree
4948 FALSE,
4949 NULL_TREE,
4950 arg1_tree,
4955 expr_tree
4958 expr_tree));
4959 }
4968 build_pointer_type
4970 integer_zero_node));
4972 return
4975 FALSE,
4976 void_type_node,
4977 expr_tree,
4984 else
4992 {
4994 tree arg1_tree;
4996 tree arg2_tree;
4997 tree arg3_tree;
5003 else
5015 FALSE,
5016 NULL_TREE,
5017 arg1_tree,
5023 expr_tree));
5024 }
5029 {
5031 tree arg1_tree;
5032 tree arg2_tree;
5033 tree arg3_tree;
5041 else
5051 FALSE,
5052 NULL_TREE,
5053 arg1_tree,
5059 expr_tree));
5060 }
5065 {
5066 tree arg1_tree;
5067 tree arg2_tree;
5069 tree arg3_tree;
5075 arg1_tree);
5080 else
5091 FALSE,
5092 NULL_TREE,
5093 arg1_tree,
5099 expr_tree));
5100 }
5104 {
5105 tree arg1_tree;
5106 tree arg2_tree;
5107 tree arg3_tree;
5113 arg1_tree);
5120 else
5128 FALSE,
5129 NULL_TREE,
5130 arg1_tree,
5136 expr_tree));
5137 }
5138 }
5142 {
5143 tree arg1_tree;
5144 tree arg2_tree;
5145 tree arg3_tree;
5151 arg1_tree);
5157 arg2_tree);
5161 else
5169 FALSE,
5170 NULL_TREE,
5171 arg1_tree,
5177 expr_tree));
5178 }
5179 }
5184 {
5186 tree arg1_tree;
5187 tree arg2_tree;
5192 ffecom_f2c_longint_type_node :
5193 ffecom_f2c_integer_type_node),
5197 arg2_tree);
5205 expr_tree
5208 FALSE,
5209 NULL_TREE,
5210 arg1_tree,
5214 }
5219 /* Arg defaults to 0 (normal random case) */
5220 {
5221 tree arg1_tree;
5225 else
5228 arg1_tree);
5231 arg1_tree);
5236 FALSE,
5238 ffecom_f2c_integer_type_node :
5239 ffecom_f2c_real_type_node),
5240 arg1_tree,
5244 }
5249 {
5250 tree arg1_tree;
5251 tree arg2_tree;
5257 arg1_tree);
5261 else
5266 FALSE,
5267 NULL_TREE,
5270 TRUE,
5275 expr_tree));
5276 }
5277 }
5282 {
5283 tree arg1_tree;
5287 expr_tree
5290 FALSE,
5291 NULL_TREE,
5292 NULL_TREE,
5296 expr_tree
5299 expr_tree));
5300 }
5305 {
5306 tree arg1_tree;
5307 tree result_tree;
5315 FALSE,
5316 NULL_TREE,
5319 TRUE,
5323 expr_tree));
5324 }
5327 /* Straightforward calls of libf2c routines: */
5404 }
5413 tree_type,
5418 /* See bottom of this file for f2c transforms used to determine
5419 many of the above implementations. The info seems to confuse
5420 Emacs's C mode indentation, which is why it's been moved to
5421 the bottom of this source file. */
5422 }
5424 /* For power (exponentiation) where right-hand operand is type INTEGER,
5425 generate in-line code to do it the fast way (which, if the operand
5426 is a constant, might just mean a series of multiplies). */
5428 static tree
5430 {
5442 {
5450 {
5451 /* Reciprocal of integer is either 0, -1, or 1, so after
5452 calculating that (which we leave to the back end to do
5453 or not do optimally), don't bother with any multiplying. */
5457 l,
5460 rtype,
5461 r);
5464 result);
5465 }
5467 /* Generate appropriate series of multiplies, preceded
5468 by divide if the exponent is negative. */
5473 {
5476 l,
5486 r,
5487 integer_one_node));
5490 l,
5491 l);
5492 }
5493 }
5496 {
5498 {
5501 else
5503 result,
5504 l);
5505 }
5508 r,
5509 integer_one_node);
5516 l,
5517 l);
5518 }
5520 }
5522 /* Though rhs isn't a constant, in-line code cannot be expanded
5523 while transforming dummies
5524 because the back end cannot be easily convinced to generate
5525 stores (MODIFY_EXPR), handle temporaries, and so on before
5526 all the appropriate rtx's have been generated for things like
5527 dummy args referenced in rhs -- which doesn't happen until
5528 store_parm_decls() is called (expand_function_start, I believe,
5529 does the actual rtx-stuffing of PARM_DECLs).
5531 So, in this case, let the caller generate the call to the
5532 run-time-library function to evaluate the power for us. */
5537 /* Right-hand operand not a constant, expand in-line code to figure
5538 out how to do the multiplies, &c.
5540 The returned expression is expressed this way in GNU C, where l and
5541 r are the "inputs":
5543 ({ typeof (r) rtmp = r;
5544 typeof (l) ltmp = l;
5545 typeof (l) result;
5547 if (rtmp == 0)
5548 result = 1;
5549 else
5550 {
5551 if ((basetypeof (l) == basetypeof (int))
5552 && (rtmp < 0))
5553 {
5554 result = ((typeof (l)) 1) / ltmp;
5555 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5556 result = -result;
5557 }
5558 else
5559 {
5560 result = 1;
5561 if ((basetypeof (l) != basetypeof (int))
5562 && (rtmp < 0))
5563 {
5564 ltmp = ((typeof (l)) 1) / ltmp;
5565 rtmp = -rtmp;
5566 if (rtmp < 0)
5567 {
5568 rtmp = -(rtmp >> 1);
5569 ltmp *= ltmp;
5570 }
5571 }
5572 for (;;)
5573 {
5574 if (rtmp & 1)
5575 result *= ltmp;
5576 if ((rtmp >>= 1) == 0)
5577 break;
5578 ltmp *= ltmp;
5579 }
5580 }
5581 }
5582 result;
5583 })
5585 Note that some of the above is compile-time collapsable, such as
5586 the first part of the if statements that checks the base type of
5587 l against int. The if statements are phrased that way to suggest
5588 an easy way to generate the if/else constructs here, knowing that
5589 the back end should (and probably does) eliminate the resulting
5590 dead code (either the int case or the non-int case), something
5591 it couldn't do without the redundant phrasing, requiring explicit
5592 dead-code elimination here, which would be kind of difficult to
5593 read. */
5595 {
5596 tree rtmp;
5597 tree ltmp;
5598 tree divide;
5599 tree basetypeof_l_is_int;
5600 tree se;
5601 tree t;
5603 basetypeof_l_is_int
5610 #ifndef HAHA
5621 else
5624 {
5625 tree hook;
5638 else
5640 }
5644 rtmp,
5645 r));
5647 ltmp,
5648 l));
5651 rtmp,
5655 result,
5659 {
5661 rtmp,
5663 integer_zero_node)),
5666 result,
5667 ffecom_tree_divide_
5670 ltmp,
5672 divide)));
5676 ltmp,
5678 integer_zero_node)),
5681 rtype,
5683 rtype,
5684 rtmp),
5686 integer_one_node)),
5688 integer_zero_node)))),
5691 result,
5693 ltype,
5694 result)));
5697 }
5699 result,
5703 ffecom_truth_value_invert
5706 rtmp,
5708 integer_zero_node)))),
5711 ltmp,
5712 ffecom_tree_divide_
5715 ltmp,
5717 divide)));
5719 rtmp,
5721 rtmp)));
5724 rtmp,
5728 rtmp,
5731 rtype,
5732 rtmp,
5733 integer_one_node))));
5735 ltmp,
5737 ltmp,
5738 ltmp)));
5744 rtmp,
5748 result,
5750 result,
5751 ltmp)));
5754 ffecom_truth_value
5756 rtmp,
5758 rtype,
5759 rtmp,
5760 integer_one_node))));
5762 ltmp,
5764 ltmp,
5765 ltmp)));
5776 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5779 {
5780 /* Make a BIND_EXPR for the BLOCK already made. */
5783 /* Remove the block from the tree at this point.
5784 It gets put back at the proper place
5785 when the BIND_EXPR is expanded. */
5787 }
5788 else
5790 }
5793 }
5795 /* ffecom_expr_transform_ -- Transform symbols in expr
5797 ffebld expr; // FFE expression.
5798 ffecom_expr_transform_ (expr);
5800 Recursive descent on expr while transforming any untransformed SYMTERs. */
5802 static void
5804 {
5805 tree t;
5806 ffesymbol s;
5808 tail_recurse:
5814 {
5822 {
5825 DIMENSION expr? */
5826 }
5836 }
5839 {
5851 }
5854 }
5856 /* Make a type based on info in live f2c.h file. */
5858 static void
5860 {
5862 {
5885 ? signed_char_type_node
5919 }
5924 }
5926 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5927 given size. */
5929 static void
5932 {
5934 tree t;
5939 {
5943 }
5944 }
5946 /* Finish up globals after doing all program units in file
5948 Need to handle only uninitialized COMMON areas. */
5950 static ffeglobal
5952 {
5953 tree cbtype;
5954 tree cbt;
5955 tree size;
5970 /* Give the array a size now. */
5978 integer_zero_node,
5979 size);
5990 }
5992 /* Finish up any untransformed symbols. */
5994 static ffesymbol
5996 {
6000 /* It's easy to know to transform an untransformed symbol, to make sure
6001 we put out debugging info for it. But COMMON variables, unlike
6002 EQUIVALENCE ones, aren't given declarations in addition to the
6003 tree expressions that specify offsets, because COMMON variables
6004 can be referenced in the outer scope where only dummy arguments
6005 (PARM_DECLs) should really be seen. To be safe, just don't do any
6006 VAR_DECLs for COMMON variables when we transform them for real
6007 use, and therefore we do all the VAR_DECL creating here. */
6010 {
6015 /* Not transformed, and not CHARACTER*(*), and not a dummy
6016 argument, which can happen only if the entry point names
6017 it "rides in on" are all invalidated for other reasons. */
6019 }
6023 {
6024 /* This isn't working, at least for dbxout. The .s file looks
6025 okay to me (burley), but in gdb 4.9 at least, the variables
6026 appear to reside somewhere outside of the common area, so
6027 it doesn't make sense to mislead anyone by generating the info
6028 on those variables until this is fixed. NOTE: Same problem
6029 with EQUIVALENCE, sadly...see similar #if later. */
6032 }
6035 }
6037 /* Append underscore(s) to name before calling get_identifier. "us"
6038 is nonzero if the name already contains an underscore and thus
6039 needs two underscores appended. */
6041 static tree
6043 {
6046 tree id;
6060 }
6062 /* Decide whether to append underscore to name before calling
6063 get_identifier. */
6065 static tree
6067 {
6071 /* If name is a built-in name, just return it as is. */
6075 #if FFETARGET_isENFORCED_MAIN_NAME
6077 #else
6079 #endif
6088 }
6090 /* Decide whether to append underscore to internal name before calling
6091 get_identifier.
6093 This is for non-external, top-function-context names only. Transform
6094 identifier so it doesn't conflict with the transformed result
6095 of using a _different_ external name. E.g. if "CALL FOO" is
6096 transformed into "FOO_();", then the variable in "FOO_ = 3"
6097 must be transformed into something that does not conflict, since
6098 these two things should be independent.
6100 The transformation is as follows. If the name does not contain
6101 an underscore, there is no possible conflict, so just return.
6102 If the name does contain an underscore, then transform it just
6103 like we transform an external identifier. */
6105 static tree
6107 {
6108 /* If name does not contain an underscore, just return it as is. */
6115 name);
6116 }
6118 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6120 tree t;
6121 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6122 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6123 ffesymbol_kindtype(s));
6125 Call after setting up containing function and getting trees for all
6126 other symbols. */
6128 static tree
6130 {
6132 tree type;
6133 tree func;
6134 tree result;
6142 /* For now, we don't have a handy pointer to where the sfunc is actually
6143 defined, though that should be easy to add to an ffesymbol. (The
6144 token/where info available might well point to the place where the type
6145 of the sfunc is declared, especially if that precedes the place where
6146 the sfunc itself is defined, which is typically the case.) We should
6147 put out a null pointer rather than point somewhere wrong, but I want to
6148 see how it works at this point. */
6153 /* Pretransform the expression so any newly discovered things belong to the
6154 outer program unit, not to the statement function. */
6158 /* Make sure no recursive invocation of this fn (a specific case of failing
6159 to pretransform an sfunc's expression, i.e. where its expression
6160 references another untransformed sfunc) happens. */
6169 else
6170 {
6174 error. */
6175 }
6182 /* We don't worry about COMPLEX return values here, because this is
6183 entirely internal to our code, and gcc has the ability to return COMPLEX
6184 directly as a value. */
6188 tree type;
6200 }
6201 else
6211 {
6213 {
6215 tree result_length;
6226 }
6227 else
6228 {
6236 }
6237 }
6254 }
6258 {
6260 }
6262 static tree
6264 {
6271 }
6273 /* Return initialize-to-zero expression for this VAR_DECL. */
6275 /* A somewhat evil way to prevent the garbage collector
6276 from collecting 'tree' structures. */
6277 #define NUM_TRACKED_CHUNK 63
6278 static struct tree_ggc_tracker
6279 {
6284 static void
6286 {
6293 {
6297 }
6298 }
6300 void
6302 {
6307 {
6310 }
6312 {
6313 /* Need to allocate a new block. */
6321 }
6322 }
6324 static tree
6326 {
6327 tree init;
6332 {
6335 }
6343 {
6347 }
6348 else
6349 {
6352 }
6355 }
6357 static tree
6360 {
6361 tree expr_tree;
6362 tree length_tree;
6365 {
6368 (ffebld_constant_character1
6370 {
6373 }
6377 (ffebld_constant_character1
6391 {
6394 }
6397 {
6400 }
6402 expr_tree
6405 expr_tree);
6406 expr_tree
6409 expr_tree,
6410 integer_one_node);
6416 *maybe_tree
6417 = ffecom_truth_value
6419 length_tree,
6420 ffecom_f2c_ftnlen_zero_node));
6426 {
6429 }
6431 maybe_tree);
6434 {
6435 tree maybe_left;
6436 tree maybe_right;
6437 tree expr_left;
6438 tree expr_right;
6445 maybe_left,
6446 maybe_right);
6448 maybe_left,
6449 expr_left,
6450 expr_right);
6452 }
6457 }
6458 }
6460 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6462 tree length_arg;
6463 ffebld expr;
6464 length_arg = ffecom_intrinsic_len_ (expr);
6466 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6467 subexpressions by constructing the appropriate tree for the
6468 length-of-character-text argument in a calling sequence. */
6470 static tree
6472 {
6473 ffetargetCharacter1 val;
6474 tree length;
6477 {
6485 {
6487 tree item;
6491 {
6494 }
6496 {
6499 else
6500 {
6503 }
6504 }
6509 }
6517 {
6518 ffebld start;
6519 ffebld end;
6521 tree start_tree;
6522 tree end_tree;
6536 {
6538 ;
6539 else
6540 {
6543 }
6544 }
6545 else
6546 {
6551 {
6554 }
6557 {
6559 ffecom_f2c_ftnlen_one_node,
6561 ffecom_f2c_ftnlen_type_node,
6562 length,
6563 start_tree));
6564 }
6565 else
6566 {
6571 {
6574 }
6577 ffecom_f2c_ftnlen_one_node,
6579 ffecom_f2c_ftnlen_type_node,
6581 }
6582 }
6583 }
6587 length
6603 }
6608 }
6610 /* Handle CHARACTER assignments.
6612 Generates code to do the assignment. Used by ordinary assignment
6613 statement handler ffecom_let_stmt and by statement-function
6614 handler to generate code for a statement function. */
6616 static void
6619 {
6620 ffecomConcatList_ catlist;
6621 tree source_length;
6622 tree source_tree;
6623 tree expr_tree;
6632 /* Source might be an opCONVERT, which just means it is a different size
6633 than the destination. Since the underlying implementation here handles
6634 that (directly or via the s_copy or s_cat run-time-library functions),
6635 we don't need the "convenience" of an opCONVERT that tells us to
6636 truncate or blank-pad, particularly since the resulting implementation
6637 would probably be slower than otherwise. */
6644 {
6675 {
6676 dest_tree
6680 dest_tree);
6681 dest_tree
6685 dest_tree,
6686 integer_one_node);
6687 source_tree
6691 source_tree);
6692 source_tree
6696 source_tree,
6697 integer_one_node);
6704 }
6722 }
6724 /* Heavy-duty concatenation. */
6726 {
6729 tree lengths;
6730 tree items;
6731 tree length_array;
6732 tree item_array;
6733 tree citem;
6734 tree clength;
6736 #ifdef HOHO
6737 length_array
6738 = lengths
6742 FFETARGET_charactersizeNONE,
6744 #else
6745 {
6746 tree hook;
6754 }
6755 #endif
6758 {
6763 {
6766 }
6768 items
6773 item_array,
6775 citem),
6776 items);
6777 lengths
6782 length_array,
6784 clength),
6785 lengths);
6786 }
6793 items));
6798 lengths));
6800 = build_tree_list
6812 }
6815 }
6817 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6819 ffecomGfrt ix;
6820 ffecom_make_gfrt_(ix);
6822 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6823 for the indicated run-time routine (ix). */
6825 static void
6827 {
6828 tree t;
6829 tree ttype;
6832 {
6897 }
6902 ttype);
6908 /* Sanity check: A function that's const cannot be volatile. */
6912 /* Sanity check: A function that's const cannot return complex. */
6921 }
6923 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
6925 static void
6927 {
6932 }
6934 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
6935 the member so debugger will see it. Otherwise nobody should be
6936 referencing the member. */
6938 static void
6940 {
6941 ffesymbol s;
6942 tree t;
6943 tree mt;
6944 tree type;
6963 type);
6980 }
6982 /* Prepare source expression for assignment into a destination perhaps known
6983 to be of a specific size. */
6985 static void
6987 {
6988 ffecomConcatList_ catlist;
6991 tree ltmp;
6992 tree itmp;
7002 {
7003 ltmp
7006 itmp
7013 }
7021 {
7024 }
7025 }
7027 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7029 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
7030 (which generates their trees) and then their trees get push_parm_decl'd.
7032 The second arg is TRUE if the dummies are for a statement function, in
7033 which case lengths are not pushed for character arguments (since they are
7034 always known by both the caller and the callee, though the code allows
7035 for someday permitting CHAR*(*) stmtfunc dummies). */
7037 static void
7039 {
7040 ffebld dummy;
7041 ffebld dumlist;
7042 ffesymbol s;
7043 tree parm;
7047 /* First push the parms corresponding to actual dummy "contents". */
7050 {
7053 {
7060 }
7065 {
7069 }
7072 }
7074 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7077 {
7080 {
7084 NOTHING! */
7088 }
7094 length param. */
7101 }
7104 }
7106 /* ffecom_start_progunit_ -- Beginning of program unit
7108 Does GNU back end stuff necessary to teach it about the start of its
7109 equivalent of a Fortran program unit. */
7111 static void
7113 {
7115 ffebld arglist;
7119 ffeinfoBasictype bt;
7120 ffeinfoKindtype kt;
7121 ffeglobal g;
7122 ffeglobalType gt;
7127 bool multi
7128 = altentries
7142 {
7168 {
7174 }
7184 else
7191 else
7206 else
7214 /* Fall through. */
7223 }
7226 {
7229 }
7230 #if FFETARGET_isENFORCED_MAIN
7233 #endif
7234 else
7238 type,
7248 {
7250 }
7252 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7253 exec-transitioning needs current_function_decl to be filled in. So we
7254 do these things in two phases. */
7258 ffecom_which_entrypoint_decl_
7262 integer_type_node);
7264 }
7267 || cmplxfunc
7270 tree type;
7271 tree length;
7277 else
7282 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7286 else
7295 else
7299 {
7302 }
7303 }
7306 {
7309 else
7312 }
7318 /* Disallow temp vars at this level. */
7324 /* This handles any symbols still untransformed, in case -g specified.
7325 This used to be done in ffecom_finish_progunit, but it turns out to
7326 be necessary to do it here so that statement functions are
7327 expanded before code. But don't bother for BLOCK DATA. */
7331 }
7333 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7335 ffesymbol s;
7336 ffecom_sym_transform_(s);
7338 The ffesymbol_hook info for s is updated with appropriate backend info
7339 on the symbol. */
7341 static ffesymbol
7343 {
7347 ffeinfoBasictype bt;
7348 ffeinfoKindtype kt;
7349 ffeglobal g;
7353 /* Must ensure special ASSIGN variables are declared at top of outermost
7354 block, else they'll end up in the innermost block when their first
7355 ASSIGN is seen, which leaves them out of scope when they're the
7356 subject of a GOTO or I/O statement.
7358 We make this variable even if -fugly-assign. Just let it go unused,
7359 in case it turns out there are cases where we really want to use this
7360 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7368 {
7371 }
7372 else
7373 {
7378 }
7388 {
7391 {
7395 /* Before 0.4, this could be ENTITY/DUMMY, but see
7396 ffestu_sym_end_transition -- no longer true (in particular, if
7397 it could be an ENTITY, it _will_ be made one, so that
7398 possibility won't come through here). So we never make length
7399 arg for CHARACTER type. */
7403 ffecom_tree_ptr_to_subr_type);
7417 {
7420 }
7443 /* Fall through. */
7446 }
7451 {
7454 /* ~~Debugging info needed? */
7462 {
7464 tree type;
7468 {
7471 }
7476 {
7479 }
7484 ffestorag est;
7485 tree et;
7486 ffetargetOffset offset;
7503 /* (t_type *) (((char *) &et) + offset) */
7508 et));
7510 t,
7513 t);
7517 }
7518 else
7519 {
7520 tree initexpr;
7525 type);
7529 #ifdef FFECOM_sizeMAXSTACKITEM
7532 #endif
7534 && (ffecom_primary_entry_kind_
7538 else
7544 /* Keep -Wunused from complaining about var if it
7545 is used as sfunc arg or DATA implied-DO. */
7552 {
7555 else
7557 }
7560 else
7566 {
7570 }
7571 }
7572 }
7580 it (& length). */
7585 }
7590 it. */
7594 }
7596 {
7599 }
7602 {
7605 ffecom_multi_retval_);
7610 }
7624 {
7625 tree type;
7626 ffebld dl;
7627 ffebld dim;
7628 tree low;
7629 tree high;
7630 tree old_sizes;
7635 {
7638 context; get it later. */
7640 }
7643 }
7644 else
7657 {
7665 else
7670 {
7671 /* Used to just do high=low. But for ffecom_tree_
7672 canonize_ref_, it probably is important to correctly
7673 assess the size. E.g. given COMPLEX C(*),CFUNC and
7674 C(2)=CFUNC(C), overlap can happen, while it can't
7675 for, say, C(1)=CFUNC(C(2)). */
7676 /* Even more recently used to set to INT_MAX, but that
7677 broke when some overflow checking went into the back
7678 end. Now we just leave the upper bound unspecified. */
7680 }
7681 else
7684 /* Determine whether array is conditionally adjustable,
7685 to decide whether back-end magic is needed.
7687 Normally the front end uses the back-end function
7688 variable_size to wrap SAVE_EXPR's around expressions
7689 affecting the size/shape of an array so that the
7690 size/shape info doesn't change during execution
7691 of the compiled code even though variables and
7692 functions referenced in those expressions might.
7694 variable_size also makes sure those saved expressions
7695 get evaluated immediately upon entry to the
7696 compiled procedure -- the front end normally doesn't
7697 have to worry about that.
7699 However, there is a problem with this that affects
7700 g77's implementation of entry points, and that is
7701 that it is _not_ true that each invocation of the
7702 compiled procedure is permitted to evaluate
7703 array size/shape info -- because it is possible
7704 that, for some invocations, that info is invalid (in
7705 which case it is "promised" -- i.e. a violation of
7706 the Fortran standard -- that the compiled code
7707 won't reference the array or its size/shape
7708 during that particular invocation).
7710 To phrase this in C terms, consider this gcc function:
7712 void foo (int *n, float (*a)[*n])
7713 {
7714 // a is "pointer to array ...", fyi.
7715 }
7717 Suppose that, for some invocations, it is permitted
7718 for a caller of foo to do this:
7720 foo (NULL, NULL);
7722 Now the _written_ code for foo can take such a call
7723 into account by either testing explicitly for whether
7724 (a == NULL) || (n == NULL) -- presumably it is
7725 not permitted to reference *a in various fashions
7726 if (n == NULL) I suppose -- or it can avoid it by
7727 looking at other info (other arguments, static/global
7728 data, etc.).
7730 However, this won't work in gcc 2.5.8 because it'll
7731 automatically emit the code to save the "*n"
7732 expression, which'll yield a NULL dereference for
7733 the "foo (NULL, NULL)" call, something the code
7734 for foo cannot prevent.
7736 g77 definitely needs to avoid executing such
7737 code anytime the pointer to the adjustable array
7738 is NULL, because even if its bounds expressions
7739 don't have any references to possible "absent"
7740 variables like "*n" -- say all variable references
7741 are to COMMON variables, i.e. global (though in C,
7742 local static could actually make sense) -- the
7743 expressions could yield other run-time problems
7744 for allowably "dead" values in those variables.
7746 For example, let's consider a more complicated
7747 version of foo:
7749 extern int i;
7750 extern int j;
7752 void foo (float (*a)[i/j])
7753 {
7754 ...
7755 }
7757 The above is (essentially) quite valid for Fortran
7758 but, again, for a call like "foo (NULL);", it is
7759 permitted for i and j to be undefined when the
7760 call is made. If j happened to be zero, for
7761 example, emitting the code to evaluate "i/j"
7762 could result in a run-time error.
7764 Offhand, though I don't have my F77 or F90
7765 standards handy, it might even be valid for a
7766 bounds expression to contain a function reference,
7767 in which case I doubt it is permitted for an
7768 implementation to invoke that function in the
7769 Fortran case involved here (invocation of an
7770 alternate ENTRY point that doesn't have the adjustable
7771 array as one of its arguments).
7773 So, the code that the compiler would normally emit
7774 to preevaluate the size/shape info for an
7775 adjustable array _must not_ be executed at run time
7776 in certain cases. Specifically, for Fortran,
7777 the case is when the pointer to the adjustable
7778 array == NULL. (For gnu-ish C, it might be nice
7779 for the source code itself to specify an expression
7780 that, if TRUE, inhibits execution of the code. Or
7781 reverse the sense for elegance.)
7783 (Note that g77 could use a different test than NULL,
7784 actually, since it happens to always pass an
7785 integer to the called function that specifies which
7786 entry point is being invoked. Hmm, this might
7787 solve the next problem.)
7789 One way a user could, I suppose, write "foo" so
7790 it works is to insert COND_EXPR's for the
7791 size/shape info so the dangerous stuff isn't
7792 actually done, as in:
7794 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7795 {
7796 ...
7797 }
7799 The next problem is that the front end needs to
7800 be able to tell the back end about the array's
7801 decl _before_ it tells it about the conditional
7802 expression to inhibit evaluation of size/shape info,
7803 as shown above.
7805 To solve this, the front end needs to be able
7806 to give the back end the expression to inhibit
7807 generation of the preevaluation code _after_
7808 it makes the decl for the adjustable array.
7810 Until then, the above example using the COND_EXPR
7811 doesn't pass muster with gcc because the "(a == NULL)"
7812 part has a reference to "a", which is still
7813 undefined at that point.
7815 g77 will therefore use a different mechanism in the
7816 meantime. */
7827 low,
7828 ffecom_integer_zero_node);
7833 high,
7834 ffecom_integer_zero_node);
7835 #endif
7837 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7838 probably. Fixes 950302-1.f. */
7843 /* ~~~Similarly, this fixes dumb0.f. The C front end
7844 does this, which is why dumb0.c would work. */
7849 type
7850 = build_array_type
7855 }
7858 {
7861 }
7865 {
7868 }
7873 /* If this arg is present in every entry point's list of
7874 dummy args, then we're done. */
7880 #if 1
7882 /* If variable_size in stor-layout has been called during
7883 the above, then get_pending_sizes should have the
7884 yet-to-be-evaluated saved expressions pending.
7885 Make the whole lot of them get emitted, conditionally
7886 on whether the array decl ("t" above) is not NULL. */
7888 {
7890 tree tem;
7895 {
7900 else
7901 sizes
7904 temv,
7905 sizes);
7906 }
7909 {
7910 sizes
7914 integer_type_node,
7915 t,
7916 null_pointer_node),
7917 sizes,
7919 integer_zero_node));
7922 sizes
7924 }
7928 }
7930 #else
7931 #if 0
7937 t,
7938 null_pointer_node);
7939 #else
7940 #if 0
7944 {
7950 }
7951 #endif
7952 #endif
7953 #endif
7954 }
7958 {
7959 ffesymbol cs;
7960 ffeglobal cg;
7961 tree ct;
7963 tree type;
7967 {
7970 }
7978 else
7985 else
7986 {
7987 ffetargetOffset offset;
7988 ffestorag cst;
7999 /* (t_type *) (((char *) &ct) + offset) */
8004 ct));
8006 t,
8009 t);
8013 }
8014 }
8026 /* Fall through. */
8030 }
8035 {
8049 {
8052 }
8057 else
8062 t);
8084 else
8085 t = build_pointer_type
8090 t);
8103 decls. */
8107 /* Fall through. */
8111 }
8116 {
8130 {
8133 }
8137 ffecom_tree_subr_type);
8158 ffecom_tree_ptr_to_subr_type);
8166 decls. */
8170 /* Fall through. */
8174 }
8179 {
8198 /* Fall through. */
8202 }
8207 {
8218 ffecom_tree_blockdata_type);
8241 /* Fall through. */
8245 }
8250 {
8270 /* Fall through. */
8274 }
8279 {
8298 /* Fall through. */
8302 }
8307 {
8327 /* Fall through. */
8331 }
8336 /* Fall through. */
8340 }
8350 }
8352 /* Transform into ASSIGNable symbol.
8354 Symbol has already been transformed, but for whatever reason, the
8355 resulting decl_tree has been deemed not usable for an ASSIGN target.
8356 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8357 another local symbol of type void * and stuff that in the assign_tree
8358 argument. The F77/F90 standards allow this implementation. */
8360 static ffesymbol
8362 {
8368 {
8371 }
8372 else
8373 {
8378 }
8388 {
8390 /* Unlike for regular vars, SAVE status is easy to determine for
8391 ASSIGNed vars, since there's no initialization, there's no
8392 effective storage association (so "SAVE J" does not apply to
8393 K even given "EQUIVALENCE (J,K)"), there's no size issue
8394 to worry about, etc. */
8399 else
8408 /* Note that twinning a DUMMY means the caller won't see
8409 the ASSIGNed value. But both F77 and F90 allow implementations
8410 to do this, i.e. disallow Fortran code that would try and
8411 take advantage of actually putting a label into a variable
8412 via a dummy argument (or any other storage association, for
8413 that matter). */
8420 }
8431 }
8433 /* Implement COMMON area in back end.
8435 Because COMMON-based variables can be referenced in the dimension
8436 expressions of dummy (adjustable) arrays, and because dummies
8437 (in the gcc back end) need to be put in the outer binding level
8438 of a function (which has two binding levels, the outer holding
8439 the dummies and the inner holding the other vars), special care
8440 must be taken to handle COMMON areas.
8442 The current strategy is basically to always tell the back end about
8443 the COMMON area as a top-level external reference to just a block
8444 of storage of the master type of that area (e.g. integer, real,
8445 character, whatever -- not a structure). As a distinct action,
8446 if initial values are provided, tell the back end about the area
8447 as a top-level non-external (initialized) area and remember not to
8448 allow further initialization or expansion of the area. Meanwhile,
8449 if no initialization happens at all, tell the back end about
8450 the largest size we've seen declared so the space does get reserved.
8451 (This function doesn't handle all that stuff, but it does some
8452 of the important things.)
8454 Meanwhile, for COMMON variables themselves, just keep creating
8455 references like *((float *) (&common_area + offset)) each time
8456 we reference the variable. In other words, don't make a VAR_DECL
8457 or any kind of component reference (like we used to do before 0.4),
8458 though we might do that as well just for debugging purposes (and
8459 stuff the rtl with the appropriate offset expression). */
8461 static void
8463 {
8466 tree cbt;
8467 tree cbtype;
8468 tree init;
8469 tree high;
8478 /* First update the size of the area in global terms. */
8487 /* If we already have declared this common block for a previous program
8488 unit, and either we already initialized it or we don't have new
8489 initialization for it, just return what we have without changing it. */
8492 && (!is_init
8494 {
8497 }
8499 /* Process inits. */
8502 {
8504 {
8505 ffebld sexp;
8507 /* Set the padding for the expression, so ffecom_expr
8508 knows to insert that many zeros. */
8510 {
8526 }
8534 }
8535 }
8536 else
8538 }
8539 else
8542 /* cbtype must be permanently allocated! */
8544 /* Allocate the MAX of the areas so far, seen filewide. */
8552 integer_zero_node,
8553 high));
8554 else
8558 {
8559 cbt
8562 cbtype);
8565 }
8566 else
8567 {
8570 }
8580 /* Make sure that any type can live in COMMON and be referenced
8581 without getting a bus error. We could pick the most restrictive
8582 alignment of all entities actually placed in the COMMON, but
8583 this seems easy enough. */
8597 {
8603 }
8610 }
8612 /* Make master area for local EQUIVALENCE. */
8614 static void
8616 {
8617 tree eqt;
8618 tree eqtype;
8619 tree init;
8620 tree high;
8630 /* Process inits. */
8633 {
8635 {
8636 ffebld sexp;
8638 /* Set the padding for the expression, so ffecom_expr
8639 knows to insert that many zeros. */
8641 {
8657 }
8662 }
8663 else
8665 }
8668 else
8674 eqst);
8682 ffecom_integer_zero_node,
8683 high));
8687 ffesymbol_text
8689 eqtype);
8692 || ffecom_member_namelisted_
8693 #ifdef FFECOM_sizeMAXSTACKITEM
8695 #endif
8700 else
8707 else
8712 /* Make sure that any type can live in EQUIVALENCE and be referenced
8713 without getting a bus error. We could pick the most restrictive
8714 alignment of all entities actually placed in the EQUIVALENCE, but
8715 this seems easy enough. */
8729 {
8734 }
8740 eqst);
8741 }
8743 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8745 static tree
8747 {
8748 tree nmlt;
8750 tree nmlinits;
8751 tree nameinit;
8752 tree varsinit;
8753 tree nvarsinit;
8754 tree field;
8755 tree high;
8761 mynumber++),
8762 nmltype);
8768 /* Process inits. */
8778 = build_type_variant
8779 (build_array_type
8782 ffecom_f2c_ftnlen_one_node,
8783 high)),
8788 nameinit);
8792 varsinit);
8796 {
8797 ffebld b;
8801 }
8809 varsinit);
8822 }
8824 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8825 analyzed on the assumption it is calculating a pointer to be
8826 indirected through. It must return the proper decl and offset,
8827 taking into account different units of measurements for offsets. */
8829 static void
8831 tree t)
8832 {
8834 {
8848 {
8849 /* An offset into COMMON. */
8852 /* Convert offset (presumably in bytes) into canonical units
8853 (presumably bits). */
8858 }
8859 /* Not a COMMON reference, so an unrecognized pattern. */
8870 {
8871 /* A reference to COMMON. */
8875 }
8876 /* Fall through. */
8878 /* Not a COMMON reference, so an unrecognized pattern. */
8881 }
8882 }
8884 /* Given a tree that is possibly intended for use as an lvalue, return
8885 information representing a canonical view of that tree as a decl, an
8886 offset into that decl, and a size for the lvalue.
8888 If there's no applicable decl, NULL_TREE is returned for the decl,
8889 and the other fields are left undefined.
8891 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8892 is returned for the decl, and the other fields are left undefined.
8894 Otherwise, the decl returned currently is either a VAR_DECL or a
8895 PARM_DECL.
8897 The offset returned is always valid, but of course not necessarily
8898 a constant, and not necessarily converted into the appropriate
8899 type, leaving that up to the caller (so as to avoid that overhead
8900 if the decls being looked at are different anyway).
8902 If the size cannot be determined (e.g. an adjustable array),
8903 an ERROR_MARK node is returned for the size. Otherwise, the
8904 size returned is valid, not necessarily a constant, and not
8905 necessarily converted into the appropriate type as with the
8906 offset.
8908 Note that the offset and size expressions are expressed in the
8909 base storage units (usually bits) rather than in the units of
8910 the type of the decl, because two decls with different types
8911 might overlap but with apparently non-overlapping array offsets,
8912 whereas converting the array offsets to consistant offsets will
8913 reveal the overlap. */
8915 static void
8918 {
8919 /* The default path is to report a nonexistant decl. */
8926 {
8996 {
8999 tree init_offset;
9003 {
9006 }
9009 array);
9014 /* Calculate ((element - base) * NBBY) + init_offset. */
9016 element,
9028 }
9032 /* Most of this code is to handle references to COMMON. And so
9033 far that is useful only for calling library functions, since
9034 external (user) functions might reference common areas. But
9035 even calling an external function, it's worthwhile to decode
9036 COMMON references because if not storing into COMMON, we don't
9037 want COMMON-based arguments to gratuitously force use of a
9038 temporary. */
9064 }
9065 }
9067 /* Do divide operation appropriate to type of operands. */
9069 static tree
9072 tree hook)
9073 {
9079 {
9082 left,
9083 right);
9088 left,
9089 right);
9090 {
9091 ffecomGfrt ix;
9096 else
9101 left);
9105 right);
9112 tree_type,
9113 left,
9116 }
9120 {
9121 ffecomGfrt ix;
9126 else
9131 left);
9135 right);
9142 tree_type,
9143 left,
9146 }
9151 left,
9152 right);
9153 }
9154 }
9156 /* Build type info for non-dummy variable. */
9158 static tree
9160 ffeinfoKindtype kt)
9161 {
9162 tree type;
9163 ffebld dl;
9164 ffebld dim;
9165 tree lowt;
9166 tree hight;
9170 {
9174 type
9175 = build_array_type
9178 ffecom_f2c_ftnlen_one_node,
9179 hight));
9181 }
9184 {
9193 else
9209 }
9212 }
9214 /* Build Namelist type. */
9216 static tree
9218 {
9222 {
9224 tree vardesctype;
9233 string_type_node);
9236 integer_type_node);
9242 }
9245 }
9247 /* Build Vardesc type. */
9249 static tree
9251 {
9256 {
9260 string_type_node);
9262 string_type_node);
9264 ffecom_f2c_ptr_to_ftnlen_type_node);
9266 integer_type_node);
9272 }
9275 }
9277 static tree
9279 {
9280 ffesymbol s;
9286 {
9289 tree var;
9290 tree nameinit;
9291 tree dimsinit;
9292 tree addrinit;
9293 tree typeinit;
9294 tree field;
9295 tree varinits;
9300 mynumber++),
9301 vardesctype);
9307 /* Process inits. */
9313 = build_type_variant
9314 (build_array_type
9317 integer_one_node,
9324 nameinit);
9331 {
9338 }
9339 else
9343 nameinit);
9345 addrinit);
9360 }
9363 }
9365 static tree
9367 {
9368 ffebld b;
9369 tree list;
9371 tree var;
9378 {
9379 tree t;
9385 else
9386 {
9389 }
9390 }
9394 integer_one_node,
9408 }
9410 static tree
9412 {
9415 integer_zero_node);
9417 {
9418 ffebld b;
9419 ffebld e;
9420 tree list;
9421 tree backlist;
9423 tree var;
9424 tree numdim;
9425 tree numelem;
9440 {
9441 tree t;
9442 tree low;
9443 tree back;
9447 else
9448 {
9454 else
9455 {
9458 }
9459 }
9463 else
9470 }
9473 {
9476 else
9480 ffecom_f2c_ftnlen_type_node,
9482 baseoff));
9483 }
9485 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9498 integer_zero_node,
9499 build_int_2
9516 }
9517 }
9519 /* Essentially does a "fold (build1 (code, type, node))" while checking
9520 for certain housekeeping things.
9522 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9523 ffecom_1_fn instead. */
9525 tree
9527 {
9528 tree item;
9535 {
9538 }
9541 {
9542 tree realtype;
9555 {
9558 }
9561 item =
9565 node)),
9568 node)));
9574 }
9583 }
9585 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9586 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9587 does not set TREE_ADDRESSABLE (because calling an inline
9588 function does not mean the function needs to be separately
9589 compiled). */
9591 tree
9593 {
9594 tree item;
9595 tree type;
9610 }
9612 /* Essentially does a "fold (build (code, type, node1, node2))" while
9613 checking for certain housekeeping things. */
9615 tree
9617 tree node2)
9618 {
9619 tree item;
9627 {
9642 {
9645 }
9649 item =
9653 node1),
9655 node2)),
9658 node1),
9660 node2)));
9665 {
9668 }
9672 item =
9676 node1),
9678 node2)),
9681 node1),
9683 node2)));
9688 {
9691 }
9696 node1));
9698 node1));
9700 node2));
9702 node2));
9703 item =
9707 a,
9708 c),
9710 b,
9711 d)),
9714 a,
9715 d),
9717 c,
9718 b)));
9724 {
9727 }
9733 item =
9737 node1),
9739 node2)),
9742 node1),
9744 node2)));
9750 {
9753 }
9759 item =
9763 node1),
9765 node2)),
9768 node1),
9770 node2)));
9776 }
9781 }
9783 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9785 ffesymbol s; // the ENTRY point itself
9786 if (ffecom_2pass_advise_entrypoint(s))
9787 // the ENTRY point has been accepted
9789 Does whatever compiler needs to do when it learns about the entrypoint,
9790 like determine the return type of the master function, count the
9791 number of entrypoints, etc. Returns FALSE if the return type is
9792 not compatible with the return type(s) of other entrypoint(s).
9794 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9795 later (after _finish_progunit) be called with the same entrypoint(s)
9796 as passed to this fn for which TRUE was returned.
9798 03-Jan-92 JCB 2.0
9799 Return FALSE if the return type conflicts with previous entrypoints. */
9801 bool
9803 {
9817 arglist's dummies. */
9827 {
9834 else
9837 }
9838 }
9840 /* If necessary, scan entry arglist for alternate returns. Do this scan
9841 apparently redundantly (it's done below to UNIONize the arglists) so
9842 that we don't complain about RETURN 1 if an offending ENTRY is the only
9843 one with an alternate return. */
9846 {
9850 {
9853 {
9856 }
9857 }
9858 }
9860 /* Now check type compatibility. */
9863 {
9869 ok
9880 {
9883 }
9886 {
9889 }
9891 }
9894 {
9899 }
9901 /* Entrypoint type compatible with previous types. */
9905 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9910 {
9919 appending of arg. */
9922 }
9926 /* Append this arg to the master list. */
9931 else
9933 }
9936 }
9938 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9940 ffesymbol s; // the ENTRY point itself
9941 ffecom_2pass_do_entrypoint(s);
9943 Does whatever compiler needs to do to make the entrypoint actually
9944 happen. Must be called for each entrypoint after
9945 ffecom_finish_progunit is called. */
9947 void
9949 {
9958 }
9959 else
9965 }
9967 /* Essentially does a "fold (build (code, type, node1, node2))" while
9968 checking for certain housekeeping things. Always sets
9969 TREE_SIDE_EFFECTS. */
9971 tree
9973 tree node2)
9974 {
9975 tree item;
9985 }
9987 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9988 checking for certain housekeeping things. */
9990 tree
9993 {
9994 tree item;
10007 }
10009 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10010 checking for certain housekeeping things. Always sets
10011 TREE_SIDE_EFFECTS. */
10013 tree
10016 {
10017 tree item;
10028 }
10030 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10032 See use by ffecom_list_expr.
10034 If expression is NULL, returns an integer zero tree. If it is not
10035 a CHARACTER expression, returns whatever ffecom_expr
10036 returns and sets the length return value to NULL_TREE. Otherwise
10037 generates code to evaluate the character expression, returns the proper
10038 pointer to the result, but does NOT set the length return value to a tree
10039 that specifies the length of the result. (In other words, the length
10040 variable is always set to NULL_TREE, because a length is never passed.)
10042 21-Dec-91 JCB 1.1
10043 Don't set returned length, since nobody needs it (yet; someday if
10044 we allow CHARACTER*(*) dummies to statement functions, we'll need
10045 it). */
10047 tree
10049 {
10050 tree ign;
10061 }
10063 /* Transform expression into constant argument-pointer-to-expression tree.
10065 If the expression can be transformed into a argument-pointer-to-expression
10066 tree that is constant, that is done, and the tree returned. Else
10067 NULL_TREE is returned.
10069 That way, a caller can attempt to provide compile-time initialization
10070 of a variable and, if that fails, *then* choose to start a new block
10071 and resort to using temporaries, as appropriate. */
10073 tree
10075 {
10080 {
10084 }
10091 {
10092 tree t;
10098 }
10106 }
10108 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10110 See use by ffecom_list_ptr_to_expr.
10112 If expression is NULL, returns an integer zero tree. If it is not
10113 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10114 returns and sets the length return value to NULL_TREE. Otherwise
10115 generates code to evaluate the character expression, returns the proper
10116 pointer to the result, AND sets the length return value to a tree that
10117 specifies the length of the result.
10119 If the length argument is NULL, this is a slightly special
10120 case of building a FORMAT expression, that is, an expression that
10121 will be used at run time without regard to length. For the current
10122 implementation, which uses the libf2c library, this means it is nice
10123 to append a null byte to the end of the expression, where feasible,
10124 to make sure any diagnostic about the FORMAT string terminates at
10125 some useful point.
10127 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10128 length argument. This might even be seen as a feature, if a null
10129 byte can always be appended. */
10131 tree
10133 {
10134 tree item;
10135 tree ign_length;
10136 ffecomConcatList_ catlist;
10145 {
10149 {
10150 tree temp_exp;
10151 tree temp_length;
10158 temp_exp);
10159 }
10165 {
10168 }
10174 {
10175 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10177 #endif
10186 }
10191 }
10193 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10197 ffetargetHollerith h;
10202 *length
10205 }
10206 #endif
10219 {
10222 {
10225 }
10233 else
10242 }
10244 {
10247 tree lengths;
10248 tree items;
10249 tree length_array;
10250 tree item_array;
10251 tree citem;
10252 tree clength;
10253 tree temporary;
10254 tree num;
10255 tree known_length;
10256 ffetargetCharacterSize sz;
10259 /* ~~Kludge! */
10262 #ifdef HOHO
10263 length_array
10264 = lengths
10267 item_array
10268 = items
10273 #else
10274 {
10275 tree hook;
10284 }
10285 #endif
10290 {
10295 else
10300 {
10304 }
10306 items
10311 item_array,
10313 citem),
10314 items);
10317 known_length
10319 known_length,
10320 clength);
10321 lengths
10326 length_array,
10328 clength),
10329 lengths);
10330 }
10334 temporary);
10341 items));
10346 lengths));
10348 = build_tree_list
10361 item,
10362 temporary);
10366 }
10371 }
10373 /* Generate call to run-time function.
10375 The first arg is the GNU Fortran Run-Time function index, the second
10376 arg is the list of arguments to pass to it. Returned is the expression
10377 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10378 result (which may be void). */
10380 tree
10382 {
10388 }
10390 /* Transform constant-union to tree. */
10392 tree
10395 {
10396 tree item;
10399 {
10401 {
10405 {
10406 #if FFETARGET_okINTEGER1
10410 #endif
10412 #if FFETARGET_okINTEGER2
10416 #endif
10418 #if FFETARGET_okINTEGER3
10422 #endif
10424 #if FFETARGET_okINTEGER4
10428 #endif
10432 /* Fall through. */
10435 }
10438 }
10442 {
10446 {
10447 #if FFETARGET_okLOGICAL1
10451 #endif
10453 #if FFETARGET_okLOGICAL2
10457 #endif
10459 #if FFETARGET_okLOGICAL3
10463 #endif
10465 #if FFETARGET_okLOGICAL4
10469 #endif
10473 /* Fall through. */
10476 }
10479 }
10483 {
10484 REAL_VALUE_TYPE val;
10487 {
10488 #if FFETARGET_okREAL1
10492 #endif
10494 #if FFETARGET_okREAL2
10498 #endif
10500 #if FFETARGET_okREAL3
10504 #endif
10506 #if FFETARGET_okREAL4
10510 #endif
10514 /* Fall through. */
10517 }
10519 }
10523 {
10524 REAL_VALUE_TYPE real;
10525 REAL_VALUE_TYPE imag;
10529 {
10530 #if FFETARGET_okCOMPLEX1
10535 #endif
10537 #if FFETARGET_okCOMPLEX2
10542 #endif
10544 #if FFETARGET_okCOMPLEX3
10549 #endif
10551 #if FFETARGET_okCOMPLEX4
10556 #endif
10560 /* Fall through. */
10563 }
10567 }
10572 ffetargetCharacter1 val;
10575 {
10576 #if FFETARGET_okCHARACTER1
10580 #endif
10584 /* Fall through. */
10587 }
10592 build_range_type
10594 integer_one_node,
10595 build_int_2
10596 (ffetarget_length_character1
10599 }
10603 {
10604 ffetargetHollerith h;
10608 /* If not at least as wide as default INTEGER, widen it. */
10611 else
10612 {
10617 FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10620 str);
10621 }
10624 build_range_type
10626 integer_one_node,
10627 build_int_2
10630 }
10634 {
10635 ffetargetInteger1 ival;
10636 ffetargetTypeless tless;
10637 ffebad error;
10644 }
10649 /* Fall through. */
10652 }
10657 }
10659 /* Transform expression into constant tree.
10661 If the expression can be transformed into a tree that is constant,
10662 that is done, and the tree returned. Else NULL_TREE is returned.
10664 That way, a caller can attempt to provide compile-time initialization
10665 of a variable and, if that fails, *then* choose to start a new block
10666 and resort to using temporaries, as appropriate. */
10668 tree
10670 {
10679 #if NEWCOMMON
10680 /* ~~Enable once common/equivalence is handled properly? */
10682 #endif
10685 {
10686 tree t;
10691 }
10694 }
10696 /* Handy way to make a field in a struct/union. */
10698 tree
10701 {
10702 tree field;
10712 }
10714 void
10716 {
10718 }
10720 int
10722 {
10724 }
10726 /* End a compound statement (block). */
10728 tree
10730 {
10732 }
10734 /* ffecom_end_transition -- Perform end transition on all symbols
10736 ffecom_end_transition();
10738 Calls ffecom_sym_end_transition for each global and local symbol. */
10740 void
10742 {
10743 ffebld item;
10753 {
10755 }
10762 {
10763 ffebld callee;
10764 ffesymbol s;
10765 tree dt;
10766 tree t;
10767 tree var;
10774 {
10777 }
10783 number++),
10784 dt);
10796 }
10798 /* This handles any COMMON areas that weren't referenced but have, for
10799 example, important initial data. */
10807 }
10809 /* ffecom_exec_transition -- Perform exec transition on all symbols
10811 ffecom_exec_transition();
10813 Calls ffecom_sym_exec_transition for each global and local symbol.
10814 Make sure error updating not inhibited. */
10816 void
10818 {
10830 {
10832 }
10836 }
10838 /* Handle assignment statement.
10840 Convert dest and source using ffecom_expr, then join them
10841 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
10843 void
10845 {
10846 tree dest_tree;
10847 tree dest_length;
10848 tree source_tree;
10849 tree expr_tree;
10852 {
10854 tree assign_temp;
10856 /* This attempts to replicate the test below, but must not be
10857 true when the test below is false. (Always err on the side
10858 of creating unused temporaries, to avoid ICEs.) */
10863 {
10866 }
10867 else
10868 {
10871 }
10875 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10876 create a temporary through which the assignment is to take place,
10877 since MODIFY_EXPR doesn't handle partial overlap properly. */
10880 {
10882 ffecom_tree_type
10885 FFETARGET_charactersizeNONE,
10887 }
10888 else
10901 else
10902 {
10906 }
10913 {
10914 #ifdef MOVE_EXPR
10915 /* The back end understands a conceptual move (evaluate source;
10916 store into dest), so use that, in case it can determine
10917 that it is going to use, say, two registers as temporaries
10918 anyway. So don't use the temp (and someday avoid generating
10919 it, once this code starts triggering regularly). */
10921 dest_tree,
10922 source_tree);
10923 #else
10925 assign_temp,
10926 source_tree);
10929 dest_tree,
10930 assign_temp);
10931 #endif
10932 }
10933 else
10935 dest_tree,
10936 source_tree);
10940 }
10949 source);
10950 }
10952 /* ffecom_expr -- Transform expr into gcc tree
10954 tree t;
10955 ffebld expr; // FFE expression.
10956 tree = ffecom_expr(expr);
10958 Recursive descent on expr while making corresponding tree nodes and
10959 attaching type info and such. */
10961 tree
10963 {
10965 }
10967 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
10969 tree
10971 {
10973 }
10975 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
10977 tree
10979 {
10981 }
10983 /* Transform expr for use as into read/write tree and stabilize the
10984 reference. Not for use on CHARACTER expressions.
10986 Recursive descent on expr while making corresponding tree nodes and
10987 attaching type info and such. */
10989 tree
10991 {
10993 /* Different target types not yet supported. */
10997 }
10999 /* Transform expr for use as into write tree and stabilize the
11000 reference. Not for use on CHARACTER expressions.
11002 Recursive descent on expr while making corresponding tree nodes and
11003 attaching type info and such. */
11005 tree
11007 {
11009 /* Different target types not yet supported. */
11013 }
11015 /* Do global stuff. */
11017 void
11019 {
11024 }
11026 /* Public entry point for front end to access finish_decl. */
11028 void
11030 {
11033 }
11035 /* Finish a program unit. */
11037 void
11039 {
11046 }
11048 /* Wrapper for get_identifier. pattern is sprintf-like. */
11050 tree
11052 {
11053 tree decl;
11065 }
11067 ffeinfoBasictype
11069 {
11073 {
11111 }
11112 }
11114 ffeinfoKindtype
11116 {
11120 {
11158 }
11159 }
11161 void
11163 {
11164 tree endlink;
11167 tree t;
11168 tree field;
11169 ffetype type;
11170 ffetype base_type;
11171 tree double_ftype_double;
11172 tree float_ftype_float;
11173 tree ldouble_ftype_ldouble;
11174 tree ffecom_tree_ptr_to_fun_type_void;
11176 /* This block of code comes from the now-obsolete cktyps.c. It checks
11177 whether the compiler environment is buggy in known ways, some of which
11178 would, if not explicitly checked here, result in subtle bugs in g77. */
11181 {
11183 =
11192 {
11196 }
11200 {
11204 }
11208 {
11212 }
11213 }
11220 /* Make the binding_level structure for global names. */
11227 /* Define `int' and `char' first so that dbx will output them first. */
11229 integer_type_node));
11230 /* CHARACTER*1 is unsigned in ICHAR contexts. */
11233 char_type_node));
11235 long_integer_type_node));
11237 unsigned_type_node));
11239 long_unsigned_type_node));
11241 long_long_integer_type_node));
11243 long_long_unsigned_type_node));
11245 short_integer_type_node));
11247 short_unsigned_type_node));
11249 /* Set the sizetype before we make other types. This *should* be the
11250 first type we create. */
11252 set_sizetype
11254 ffecom_typesize_pointer_
11259 /* Define both `signed char' and `unsigned char'. */
11261 signed_char_type_node));
11264 unsigned_char_type_node));
11267 float_type_node));
11269 double_type_node));
11271 long_double_type_node));
11273 /* For now, override what build_common_tree_nodes has done. */
11277 complex_long_double_type_node
11281 complex_integer_type_node));
11283 complex_float_type_node));
11285 complex_double_type_node));
11287 complex_long_double_type_node));
11290 void_type_node));
11291 /* We are not going to have real types in C with less than byte alignment,
11292 so we might as well not have any types that claim to have it. */
11298 ffecom_tree_fun_type_void
11301 ffecom_tree_ptr_to_fun_type_void
11306 float_ftype_float
11310 double_ftype_double
11314 ldouble_ftype_ldouble
11317 endlink));
11321 {
11326 }
11328 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11329 to size FLOAT_TYPE_SIZE because they have to be the same size as
11330 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11331 Compiler options and other such stuff that change the ways these
11332 types are set should not affect this particular setup. */
11337 t));
11341 type);
11347 type);
11355 t));
11360 t));
11363 type);
11369 type);
11376 t));
11381 t));
11384 type);
11390 type);
11397 t));
11402 t));
11405 type);
11411 type);
11418 t));
11420 #if 0
11426 {
11428 LONG_TYPE_SIZE);
11429 }
11430 #endif
11435 t));
11439 type);
11445 type);
11452 t));
11455 type);
11461 type);
11468 t));
11471 type);
11477 type);
11484 t));
11487 type);
11493 type);
11501 t));
11506 type);
11512 type);
11522 t));
11526 type);
11532 type);
11539 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11541 t));
11545 type);
11551 type);
11558 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11560 t));
11563 type);
11569 type);
11571 type);
11576 /* Make function and ptr-to-function types for non-CHARACTER types. */
11580 {
11582 {
11584 {
11585 /* Figure out the smallest INTEGER type that can hold
11586 a pointer on this machine. */
11589 {
11594 }
11595 }
11598 /* For f2c compatibility, REAL functions are really
11599 implemented as DOUBLE PRECISION. */
11602 t = ffecom_tree_type
11606 NULL_TREE);
11608 }
11609 }
11611 /* Set up pointer types. */
11618 FFEINFO_kindtypeINTEGERDEFAULT),
11621 ffecom_pointer_kind_));
11625 else
11630 ffecom_integer_type_node
11633 integer_zero_node);
11635 integer_one_node);
11637 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11638 Turns out that by TYLONG, runtime/libI77/lio.h really means
11639 "whatever size an ftnint is". For consistency and sanity,
11640 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11641 all are INTEGER, which we also make out of whatever back-end
11642 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11643 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11644 accommodate machines like the Alpha. Note that this suggests
11645 f2c and libf2c are missing a distinction perhaps needed on
11646 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11649 FFETARGET_f2cTYLONG);
11651 FFETARGET_f2cTYSHORT);
11653 FFETARGET_f2cTYINT1);
11655 FFETARGET_f2cTYQUAD);
11657 FFETARGET_f2cTYLOGICAL);
11659 FFETARGET_f2cTYLOGICAL2);
11661 FFETARGET_f2cTYLOGICAL1);
11662 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11664 FFETARGET_f2cTYQUAD);
11666 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11667 loop. CHARACTER items are built as arrays of unsigned char. */
11674 FFEINFO_kindtypeCHARACTER1,
11675 type);
11694 /* Make multi-return-value type and fields. */
11702 {
11719 }
11724 /* Subroutines usually return integer because they might have alternate
11725 returns. */
11727 ffecom_tree_subr_type
11729 ffecom_tree_ptr_to_subr_type
11731 ffecom_tree_blockdata_type
11756 FFECOM_f2cINTEGER,
11759 FFECOM_f2cADDRESS,
11762 FFECOM_f2cREAL,
11765 FFECOM_f2cDOUBLEREAL,
11768 FFECOM_f2cCOMPLEX,
11771 FFECOM_f2cDOUBLECOMPLEX,
11774 FFECOM_f2cLONGINT,
11777 FFECOM_f2cLOGICAL,
11780 FFECOM_f2cFLAG,
11783 FFECOM_f2cFTNLEN,
11786 FFECOM_f2cFTNINT,
11789 ffecom_f2c_ftnlen_zero_node
11792 ffecom_f2c_ftnlen_one_node
11798 ffecom_f2c_ptr_to_ftnlen_type_node
11801 ffecom_f2c_ptr_to_ftnint_type_node
11804 ffecom_f2c_ptr_to_integer_type_node
11807 ffecom_f2c_ptr_to_real_type_node
11812 {
11813 REAL_VALUE_TYPE point_5;
11818 }
11820 /* Do "extern int xargc;". */
11824 integer_type_node);
11834 {
11841 }
11842 #endif
11847 /* I/O will probably crash. */
11851 #endif
11856 /* ASSIGN 10 TO I will crash. */
11861 #endif
11862 }
11864 /* ffecom_init_2 -- Initialize
11866 ffecom_init_2(); */
11868 void
11870 {
11881 }
11883 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11885 tree t;
11886 ffebld expr; // FFE opITEM list.
11887 tree = ffecom_list_expr(expr);
11889 List of actual args is transformed into corresponding gcc backend list. */
11891 tree
11893 {
11894 tree list;
11898 tree length;
11901 {
11911 {
11914 }
11915 }
11920 }
11922 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11924 tree t;
11925 ffebld expr; // FFE opITEM list.
11926 tree = ffecom_list_ptr_to_expr(expr);
11928 List of actual args is transformed into corresponding gcc backend list for
11929 use in calling an external procedure (vs. a statement function). */
11931 tree
11933 {
11934 tree list;
11938 tree length;
11941 {
11951 {
11954 }
11955 }
11960 }
11962 /* Obtain gcc's LABEL_DECL tree for label. */
11964 tree
11966 {
11967 tree glabel;
11970 {
11974 {
11980 void_type_node);
11987 ffecom_get_invented_identifier
11991 NULL_TREE),
12012 }
12014 }
12015 else
12016 {
12018 }
12021 }
12023 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12024 a single source specification (as in the fourth argument of MVBITS).
12025 If the type is NULL_TREE, the type of lhs is used to make the type of
12026 the MODIFY_EXPR. */
12028 tree
12030 tree rhs)
12031 {
12042 }
12044 /* Register source file name. */
12046 void
12048 {
12050 }
12052 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12054 ffestorag st;
12055 ffecom_notify_init_storage(st);
12057 Gets called when all possible units in an aggregate storage area (a LOCAL
12058 with equivalences or a COMMON) have been initialized. The initialization
12059 info either is in ffestorag_init or, if that is NULL,
12060 ffestorag_accretion:
12062 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12063 even for an array if the array is one element in length!
12065 ffestorag_accretion will contain an opACCTER. It is much like an
12066 opARRTER except it has an ffebit object in it instead of just a size.
12067 The back end can use the info in the ffebit object, if it wants, to
12068 reduce the amount of actual initialization, but in any case it should
12069 kill the ffebit object when done. Also, set accretion to NULL but
12070 init to a non-NULL value.
12072 After performing initialization, DO NOT set init to NULL, because that'll
12073 tell the front end it is ok for more initialization to happen. Instead,
12074 set init to an opANY expression or some such thing that you can use to
12075 tell that you've already initialized the object.
12077 27-Oct-91 JCB 1.1
12078 Support two-pass FFE. */
12080 void
12082 {
12086 {
12092 }
12093 }
12095 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12097 ffesymbol s;
12098 ffecom_notify_init_symbol(s);
12100 Gets called when all possible units in a symbol (not placed in COMMON
12101 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12102 have been initialized. The initialization info either is in
12103 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12105 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12106 even for an array if the array is one element in length!
12108 ffesymbol_accretion will contain an opACCTER. It is much like an
12109 opARRTER except it has an ffebit object in it instead of just a size.
12110 The back end can use the info in the ffebit object, if it wants, to
12111 reduce the amount of actual initialization, but in any case it should
12112 kill the ffebit object when done. Also, set accretion to NULL but
12113 init to a non-NULL value.
12115 After performing initialization, DO NOT set init to NULL, because that'll
12116 tell the front end it is ok for more initialization to happen. Instead,
12117 set init to an opANY expression or some such thing that you can use to
12118 tell that you've already initialized the object.
12120 27-Oct-91 JCB 1.1
12121 Support two-pass FFE. */
12123 void
12125 {
12130 possibilities checked. */
12134 {
12138 }
12139 }
12141 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12143 ffesymbol s;
12144 ffecom_notify_primary_entry(s);
12146 Gets called when implicit or explicit PROGRAM statement seen or when
12147 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12148 global symbol that serves as the entry point. */
12150 void
12152 {
12159 else
12163 {
12166 else
12168 }
12171 {
12172 ffebld list;
12173 ffebld arg;
12178 {
12181 {
12184 }
12185 }
12186 }
12187 }
12191 {
12193 }
12195 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12197 tree t;
12198 ffebld expr; // FFE expression.
12199 tree = ffecom_ptr_to_expr(expr);
12201 Like ffecom_expr, but sticks address-of in front of most things. */
12203 tree
12205 {
12206 tree item;
12207 ffeinfoBasictype bt;
12208 ffeinfoKindtype kt;
12209 ffesymbol s;
12214 {
12218 {
12219 ffecomGfrt ix;
12224 {
12227 }
12228 }
12229 else
12230 {
12233 {
12236 }
12237 }
12243 item);
12260 item);
12274 /* The back end currently optimizes a bit too zealously for us, in that
12275 we fail JCB001 if the following block of code is omitted. It checks
12276 to see if the transformed expression is a symbol or array reference,
12277 and encloses it in a SAVE_EXPR if that is the case. */
12286 #ifdef OFFSET_REF
12288 #endif
12292 {
12294 }
12297 item);
12299 }
12303 }
12305 /* Obtain a temp var with given data type.
12307 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12308 or >= 0 for a CHARACTER type.
12310 elements is -1 for a scalar or > 0 for an array of type. */
12312 tree
12315 {
12316 tree t;
12327 ffecom_f2c_ftnlen_one_node,
12332 integer_zero_node,
12337 commentary,
12338 mynumber++),
12339 type);
12345 }
12347 /* Prepare argument pointer to expression.
12349 Like ffecom_prepare_expr, except for expressions to be evaluated
12350 via ffecom_arg_ptr_to_expr. */
12352 void
12354 {
12355 /* ~~For now, it seems to be the same thing. */
12358 }
12360 /* End of preparations. */
12362 bool
12364 {
12371 }
12373 /* Prepare expression.
12375 This is called before any code is generated for the current block.
12376 It scans the expression, declares any temporaries that might be needed
12377 during evaluation of the expression, and stores those temporaries in
12378 the appropriate "hook" fields of the expression. `dest', if not NULL,
12379 specifies the destination that ffecom_expr_ will see, in case that
12380 helps avoid generating unused temporaries.
12382 ~~Improve to avoid allocating unused temporaries by taking `dest'
12383 into account vis-a-vis aliasing requirements of complex/character
12384 functions. */
12386 void
12388 {
12389 ffeinfoBasictype bt;
12390 ffeinfoKindtype kt;
12391 ffetargetCharacterSize sz;
12403 /* Generate whatever temporaries are needed to represent the result
12404 of the expression. */
12407 {
12410 }
12413 {
12415 /* Don't make temps for SYMTER, CONTER, etc. */
12420 {
12423 {
12424 ffesymbol s;
12436 }
12438 {
12439 /* Requires special treatment. There's no POW_CC function
12440 in libg2c, so POW_ZZ is used, which means we always
12441 need a double-complex temp, not a single-complex. */
12443 }
12445 /* The other ops don't need temps for complex operands. */
12448 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12449 REAL(C). See 19990325-0.f, routine `check', for cases. */
12451 ffecom_tree_type
12453 FFETARGET_charactersizeNONE,
12462 /* ~~Kludge alert! This should someday be fixed. */
12470 }
12473 #ifdef HAHA
12475 {
12490 }
12495 {
12496 /* This gets special handling, because only one set of temps
12497 is needed for a tree of these -- the tree is treated as
12498 a flattened list of concatenations when generating code. */
12500 ffecomConcatList_ catlist;
12509 {
12510 ltmp
12512 ffecom_f2c_ftnlen_type_node,
12514 itmp
12516 ffecom_f2c_address_type_node,
12518 result
12520 char_type_node,
12528 }
12532 i));
12537 {
12540 }
12541 }
12551 }
12554 {
12557 }
12559 /* Prepare subexpressions for this expr. */
12562 {
12577 {
12578 ffebld item;
12585 }
12589 /* Need to handle character conversion specially. */
12591 {
12603 }
12604 }
12607 }
12609 /* Prepare expression for reading and writing.
12611 Like ffecom_prepare_expr, except for expressions to be evaluated
12612 via ffecom_expr_rw. */
12614 void
12616 {
12617 /* This is all we support for now. */
12620 /* ~~For now, it seems to be the same thing. */
12623 }
12625 /* Prepare expression for writing.
12627 Like ffecom_prepare_expr, except for expressions to be evaluated
12628 via ffecom_expr_w. */
12630 void
12632 {
12633 /* This is all we support for now. */
12636 /* ~~For now, it seems to be the same thing. */
12639 }
12641 /* Prepare expression for returning.
12643 Like ffecom_prepare_expr, except for expressions to be evaluated
12644 via ffecom_return_expr. */
12646 void
12648 {
12652 && ffecom_is_altreturning_
12655 }
12657 /* Prepare pointer to expression.
12659 Like ffecom_prepare_expr, except for expressions to be evaluated
12660 via ffecom_ptr_to_expr. */
12662 void
12664 {
12665 /* ~~For now, it seems to be the same thing. */
12668 }
12670 /* Transform expression into constant pointer-to-expression tree.
12672 If the expression can be transformed into a pointer-to-expression tree
12673 that is constant, that is done, and the tree returned. Else NULL_TREE
12674 is returned.
12676 That way, a caller can attempt to provide compile-time initialization
12677 of a variable and, if that fails, *then* choose to start a new block
12678 and resort to using temporaries, as appropriate. */
12680 tree
12682 {
12694 {
12695 tree t;
12700 }
12703 }
12705 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12707 tree rtn; // NULL_TREE means use expand_null_return()
12708 ffebld expr; // NULL if no alt return expr to RETURN stmt
12709 rtn = ffecom_return_expr(expr);
12711 Based on the program unit type and other info (like return function
12712 type, return master function type when alternate ENTRY points,
12713 whether subroutine has any alternate RETURN points, etc), returns the
12714 appropriate expression to be returned to the caller, or NULL_TREE
12715 meaning no return value or the caller expects it to be returned somewhere
12716 else (which is handled by other parts of this module). */
12718 tree
12720 {
12721 tree rtn;
12724 {
12735 else
12748 into (implicit) dummy. */
12751 }
12753 #if 0
12754 /* Spurious error if RETURN happens before first reference! So elide
12755 this code. In particular, for debugging registry, rtn should always
12756 be non-null after all, but TREE_USED won't be set until we encounter
12757 a reference in the code. Perfectly okay (but weird) code that,
12758 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12759 this diagnostic for no reason. Have people use -O -Wuninitialized
12760 and leave it to the back end to find obviously weird cases. */
12762 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12763 situation; if the return value has never been referenced, it won't
12764 have a tree under 2pass mode. */
12767 {
12774 }
12775 #endif
12783 }
12786 }
12788 /* Do save_expr only if tree is not error_mark_node. */
12790 tree
12792 {
12794 }
12796 /* Start a compound statement (block). */
12798 void
12800 {
12802 }
12804 /* Public entry point for front end to access start_decl. */
12806 tree
12808 {
12811 }
12813 /* ffecom_sym_commit -- Symbol's state being committed to reality
12815 ffesymbol s;
12816 ffecom_sym_commit(s);
12818 Does whatever the backend needs when a symbol is committed after having
12819 been backtrackable for a period of time. */
12821 void
12823 {
12825 }
12827 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12829 ffecom_sym_end_transition();
12831 Does backend-specific stuff and also calls ffest_sym_end_transition
12832 to do the necessary FFE stuff.
12834 Backtracking is never enabled when this fn is called, so don't worry
12835 about it. */
12837 ffesymbol
12839 {
12840 ffestorag st;
12848 {
12849 ffecom_list_blockdata_
12851 FFEINTRIN_specNONE,
12852 FFEINTRIN_impNONE),
12853 ffecom_list_blockdata_);
12854 }
12856 /* This is where we finally notice that a symbol has partial initialization
12857 and finalize it. */
12860 {
12863 }
12867 {
12870 }
12875 {
12876 ffecom_list_common_
12878 FFEINTRIN_specNONE,
12879 FFEINTRIN_impNONE),
12880 ffecom_list_common_);
12881 }
12884 }
12886 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12888 ffecom_sym_exec_transition();
12890 Does backend-specific stuff and also calls ffest_sym_exec_transition
12891 to do the necessary FFE stuff.
12893 See the long-winded description in ffecom_sym_learned for info
12894 on handling the situation where backtracking is inhibited. */
12896 ffesymbol
12898 {
12902 }
12904 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12906 ffesymbol s;
12907 s = ffecom_sym_learned(s);
12909 Called when a new symbol is seen after the exec transition or when more
12910 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
12911 it arrives here is that all its latest info is updated already, so its
12912 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12913 field filled in if its gone through here or exec_transition first, and
12914 so on.
12916 The backend probably wants to check ffesymbol_retractable() to see if
12917 backtracking is in effect. If so, the FFE's changes to the symbol may
12918 be retracted (undone) or committed (ratified), at which time the
12919 appropriate ffecom_sym_retract or _commit function will be called
12920 for that function.
12922 If the backend has its own backtracking mechanism, great, use it so that
12923 committal is a simple operation. Though it doesn't make much difference,
12924 I suppose: the reason for tentative symbol evolution in the FFE is to
12925 enable error detection in weird incorrect statements early and to disable
12926 incorrect error detection on a correct statement. The backend is not
12927 likely to introduce any information that'll get involved in these
12928 considerations, so it is probably just fine that the implementation
12929 model for this fn and for _exec_transition is to not do anything
12930 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12931 and instead wait until ffecom_sym_commit is called (which it never
12932 will be as long as we're using ambiguity-detecting statement analysis in
12933 the FFE, which we are initially to shake out the code, but don't depend
12934 on this), otherwise go ahead and do whatever is needed.
12936 In essence, then, when this fn and _exec_transition get called while
12937 backtracking is enabled, a general mechanism would be to flag which (or
12938 both) of these were called (and in what order? neat question as to what
12939 might happen that I'm too lame to think through right now) and then when
12940 _commit is called reproduce the original calling sequence, if any, for
12941 the two fns (at which point backtracking will, of course, be disabled). */
12943 ffesymbol
12945 {
12949 }
12951 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12953 ffesymbol s;
12954 ffecom_sym_retract(s);
12956 Does whatever the backend needs when a symbol is retracted after having
12957 been backtrackable for a period of time. */
12959 void
12961 {
12965 so nothing needed here. */
12967 {
12986 }
12987 #endif
12988 }
12990 /* Create temporary gcc label. */
12992 tree
12994 {
12995 tree glabel;
13000 mynumber++),
13001 void_type_node);
13006 }
13008 /* Return an expression that is usable as an arg in a conditional context
13009 (IF, DO WHILE, .NOT., and so on).
13011 Use the one provided for the back end as of >2.6.0. */
13013 tree
13015 {
13017 }
13019 /* Return the inversion of a truth value (the inversion of what
13020 ffecom_truth_value builds).
13022 Apparently invert_truthvalue, which is properly in the back end, is
13023 enough for now, so just use it. */
13025 tree
13027 {
13029 }
13031 /* Return the tree that is the type of the expression, as would be
13032 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13033 transforming the expression, generating temporaries, etc. */
13035 tree
13037 {
13038 ffeinfoBasictype bt;
13039 ffeinfoKindtype kt;
13040 tree tree_type;
13049 {
13092 /* Fall through. */
13095 }
13096 }
13098 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13100 If the PARM_DECL already exists, return it, else create it. It's an
13101 integer_type_node argument for the master function that implements a
13102 subroutine or function with more than one entrypoint and is bound at
13103 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13104 first ENTRY statement, and so on). */
13106 tree
13108 {
13112 }
13113 \f
13114 /* The following sections consists of private and public functions
13115 that have the same names and perform roughly the same functions
13116 as counterparts in the C front end. Changes in the C front end
13117 might affect how things should be done here. Only functions
13118 needed by the back end should be public here; the rest should
13119 be private (static in the C sense). Functions needed by other
13120 g77 front-end modules should be accessed by them via public
13121 ffecom_* names, which should themselves call private versions
13122 in this section so the private versions are easy to recognize
13123 when upgrading to a new gcc and finding interesting changes
13124 in the front end.
13126 Functions named after rule "foo:" in c-parse.y are named
13127 "bison_rule_foo_" so they are easy to find. */
13129 static void
13131 {
13136 }
13138 static tree
13140 {
13141 tree t;
13144 /* Make the temps go away. */
13153 }
13155 /* Return a definition for a builtin function named NAME and whose data type
13156 is TYPE. TYPE should be a function type with argument types.
13157 FUNCTION_CODE tells later passes how to compile calls to this function.
13158 See tree.h for its possible values.
13160 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13161 the name to be called if we can't opencode the function. */
13163 tree
13167 {
13179 }
13181 /* Handle when a new declaration NEWDECL
13182 has the same name as an old one OLDDECL
13183 in the same binding contour.
13184 Prints an error message if appropriate.
13186 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13187 Otherwise, return 0. */
13189 static int
13191 {
13205 /* New decl is completely inconsistent with the old one =>
13206 tell caller to replace the old one.
13207 This is always an error except in the case of shadowing a builtin. */
13211 /* For real parm decl following a forward decl,
13212 return 1 so old decl will be reused. */
13217 /* The new declaration is the same kind of object as the old one.
13218 The declarations may partially match. Print warnings if they don't
13219 match enough. Ultimately, copy most of the information from the new
13220 decl to the old one, and keep using the old one. */
13224 {
13225 /* A function declaration for a built-in function. */
13229 {
13230 /* Accept the return type of the new declaration if same modes. */
13235 {
13236 /* Function types may be shared, so we can't just modify
13237 the return type of olddecl's function type. */
13238 tree newtype
13245 }
13246 }
13249 }
13252 {
13253 /* A function declaration for a predeclared function
13254 that isn't actually built in. */
13258 {
13259 /* If the types don't match, preserve volatility indication.
13260 Later on, we will discard everything else about the
13261 default declaration. */
13263 }
13264 }
13266 /* Copy all the DECL_... slots specified in the new decl
13267 except for any that we copy here from the old type.
13269 Past this point, we don't change OLDTYPE and NEWTYPE
13270 even if we change the types of NEWDECL and OLDDECL. */
13273 {
13274 /* Merge the data types specified in the two decls. */
13280 /* Lay the type out, unless already done. */
13282 {
13289 }
13290 else
13291 {
13292 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13297 {
13300 }
13301 }
13303 /* Keep the old rtl since we can safely use it. */
13306 /* Merge the type qualifiers. */
13313 {
13317 }
13319 /* Keep source location of definition rather than declaration.
13320 Likewise, keep decl at outer scope. */
13323 {
13330 }
13332 /* Merge the unused-warning information. */
13338 /* Merge the initialization information. */
13342 /* Merge the section attribute.
13343 We want to issue an error if the sections conflict but that must be
13344 done later in decl_attributes since we are called before attributes
13345 are assigned. */
13350 {
13353 }
13354 }
13355 /* If cannot merge, then use the new type and qualifiers,
13356 and don't preserve the old rtl. */
13357 else
13358 {
13363 }
13365 /* Merge the storage class information. */
13366 /* For functions, static overrides non-static. */
13368 {
13370 /* This is since we don't automatically
13371 copy the attributes of NEWDECL into OLDDECL. */
13373 /* If this clears `static', clear it in the identifier too. */
13376 }
13378 {
13381 /* An extern decl does not override previous storage class. */
13383 }
13384 else
13385 {
13388 }
13390 /* If either decl says `inline', this fn is inline,
13391 unless its definition was passed already. */
13396 /* Get rid of any built-in function if new arg types don't match it
13397 or if we have a function definition. */
13401 {
13404 }
13406 /* If redeclaring a builtin function, and not a definition,
13407 it stays built in.
13408 Also preserve various other info from the definition. */
13410 {
13412 {
13415 }
13421 }
13423 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13424 But preserve olddecl's DECL_UID. */
13425 {
13432 }
13435 }
13437 /* Finish processing of a declaration;
13438 install its initial value.
13439 If the length of an array type is not known before,
13440 it must be determined now, from the initial value, or it is an error. */
13442 static void
13444 {
13450 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13451 level anyway. */
13456 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13457 overlaps DECL_ARG_TYPE. */
13460 else
13464 {
13467 else
13468 {
13469 /* typedef foo = bar; store the type of bar as the type of foo. */
13472 }
13473 }
13475 /* Deduce size of array from initialization, if not already known */
13480 {
13485 }
13488 {
13495 ?
13496 /* A static variable with an incomplete type is an error if it is
13497 initialized. Also if it is not file scope. Otherwise, let it
13498 through, but if it is not `extern' then it may cause an error
13499 message later. */
13501 :
13502 /* An automatic variable with an incomplete type is an error. */
13504 {
13507 }
13512 {
13515 }
13516 }
13518 /* Output the assembler code and/or RTL code for variables and functions,
13519 unless the type is an undefined structure or union. If not, it will get
13520 done when the type is completed. */
13523 {
13529 {
13530 /* Recompute the RTL of a local array now if it used to be an
13531 incomplete type. */
13534 {
13535 /* If we used it already as memory, it must stay in memory. */
13537 /* If it's still incomplete now, no init will save it. */
13541 }
13542 /* Compute and store the initial value. */
13545 }
13546 }
13548 {
13552 }
13554 /* At the end of a declaration, throw away any variable type sizes of types
13555 defined inside that declaration. There is no use computing them in the
13556 following function definition. */
13559 }
13561 /* Finish up a function declaration and compile that function
13562 all the way to assembler language output. The free the storage
13563 for the function definition.
13565 This is called after parsing the body of the function definition.
13567 NESTED is nonzero if the function being finished is nested in another. */
13569 static void
13571 {
13576 {
13579 else
13581 }
13583 /* TREE_READONLY (fndecl) = 1;
13584 This caused &foo to be of type ptr-to-const-function
13585 which then got a warning when stored in a ptr-to-function variable. */
13590 {
13593 /* Must mark the RESULT_DECL as being in this function. */
13597 /* Obey `register' declarations if `setjmp' is called in this fn. */
13598 /* Generate rtl for function exit. */
13601 /* If this is a nested function, protect the local variables in the stack
13602 above us from being collected while we're compiling this function. */
13606 /* Run the optimizers and output the assembler code for this function. */
13609 /* Undo the GC context switch. */
13612 }
13615 && !nested
13617 {
13618 /* Stop pointing to the local nodes about to be freed. */
13619 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13620 function definition. */
13621 /* For a nested function, this is done in pop_f_function_context. */
13622 /* If rest_of_compilation set this to 0, leave it 0. */
13626 }
13629 {
13630 /* Let the error reporting routines know that we're outside a function.
13631 For a nested function, this value is used in pop_c_function_context
13632 and then reset via pop_function_context. */
13634 }
13635 }
13637 /* Plug-in replacement for identifying the name of a decl and, for a
13638 function, what we call it in diagnostics. For now, "program unit"
13639 should suffice, since it's a bit of a hassle to figure out which
13640 of several kinds of things it is. Note that it could conceivably
13641 be a statement function, which probably isn't really a program unit
13642 per se, but if that comes up, it should be easy to check (being a
13643 nested function and all). */
13647 {
13648 /* Just to keep GCC quiet about the unused variable.
13649 In theory, differing values of V should produce different
13650 output. */
13652 {
13657 }
13658 }
13660 /* g77's function to print out name of current function that caused
13661 an error. */
13663 static void
13666 {
13669 ffeglobal g;
13670 ffesymbol s;
13675 {
13679 }
13680 else
13681 {
13684 {
13687 }
13688 else
13689 {
13692 }
13693 }
13696 {
13702 else
13703 {
13707 }
13711 }
13712 }
13714 /* Similar to `lookup_name' but look only at current binding level. */
13716 static tree
13718 {
13732 }
13734 /* Create a new `struct binding_level'. */
13738 {
13739 /* NOSTRICT */
13741 }
13743 /* Save and restore the variables in this file and elsewhere
13744 that keep track of the progress of compilation of the current function.
13745 Used for nested functions. */
13747 struct f_function
13748 {
13750 tree named_labels;
13751 tree shadowed_labels;
13753 };
13757 /* Restore the variables used during compilation of a C function. */
13759 static void
13761 {
13763 tree link;
13765 /* Bring back all the labels that were shadowed. */
13773 {
13774 /* Stop pointing to the local nodes about to be freed. */
13775 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13776 function definition. */
13779 }
13790 }
13792 /* Save and reinitialize the variables
13793 used during compilation of a C function. */
13795 static void
13797 {
13809 }
13811 static void
13813 {
13816 /* Don't try computing parm sizes now -- wait till fn is called. */
13820 /* Fill in arg stuff. */
13831 }
13833 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
13835 static tree
13837 tree x;
13838 {
13849 }
13851 /* Store the list of declarations of the current level.
13852 This is done for the parameter declarations of a function being defined,
13853 after they are modified in the light of any missing parameters. */
13855 static tree
13857 tree decls;
13858 {
13860 }
13862 /* Store the parameter declarations into the current function declaration.
13863 This is called after parsing the parameter declarations, before
13864 digesting the body of the function.
13866 For an old-style definition, modify the function's type
13867 to specify at least the number of arguments. */
13869 static void
13871 {
13877 /* This is a chain of PARM_DECLs from old-style parm declarations. */
13880 /* Initialize the RTL code for the function. */
13884 /* Set up parameters and prepare for return, for the function. */
13887 }
13889 static tree
13891 {
13896 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13897 level anyway. */
13901 {
13904 }
13908 /* For Fortran, we by default put things in .common when possible. */
13911 /* Add this decl to the current binding level. TEM may equal DECL or it may
13912 be a previous decl of the same name. */
13915 else
13918 /* For a local variable, define the RTL now. */
13920 /* But not if this is a duplicate decl and we preserved the rtl from the
13921 previous one (which may or may not happen). */
13923 {
13929 }
13932 }
13934 /* Create the FUNCTION_DECL for a function definition.
13935 DECLSPECS and DECLARATOR are the parts of the declaration;
13936 they describe the function's name and the type it returns,
13937 but twisted together in a fashion that parallels the syntax of C.
13939 This function creates a binding context for the function body
13940 as well as setting up the FUNCTION_DECL in current_function_decl.
13942 Returns 1 on success. If the DECLARATOR is not suitable for a function
13943 (it defines a datum instead), we return 0, which tells
13944 ffe_parse_file to report a parse error.
13946 NESTED is nonzero for a function nested within another function. */
13948 static void
13950 {
13951 tree decl1;
13952 tree restype;
13958 /* Don't expand any sizes in the return type of the function. */
13962 {
13966 }
13967 else
13968 {
13970 }
13974 else
13975 {
13977 name,
13978 type);
13987 /* Make the init_value nonzero so pushdecl knows this is not tentative.
13988 error_mark_node is replaced below (in poplevel) with the BLOCK. */
13991 /* Record the decl so that the function name is defined. If we already have
13992 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
13995 }
14004 {
14010 }
14016 }
14017 \f
14018 /* Here are the public functions the GNU back end needs. */
14020 tree
14023 {
14036 {
14039 }
14045 e);
14059 }
14061 /* Return the list of declarations of the current level.
14062 Note that this list is in reverse order unless/until
14063 you nreverse it; and when you do nreverse it, you must
14064 store the result back using `storedecls' or you will lose. */
14066 tree
14068 {
14070 }
14072 /* Nonzero if we are currently in the global binding level. */
14074 int
14076 {
14078 }
14080 /* Mark ARG for GC. */
14081 static void
14083 {
14087 {
14092 }
14093 }
14095 static void
14097 {
14138 &shadowed_labels
14139 };
14144 /* Record our roots. */
14155 mark_binding_level);
14157 mark_binding_level);
14161 }
14163 /* Delete the node BLOCK from the current binding level.
14164 This is used for the block inside a stmt expr ({...})
14165 so that the block can be reinserted where appropriate. */
14167 static void
14169 tree block;
14170 {
14171 tree t;
14175 {
14178 else
14180 }
14182 /* Clear TREE_USED which is always set by poplevel.
14183 The flag is set again if insert_block is called. */
14185 }
14187 void
14189 tree block;
14190 {
14192 current_binding_level->blocks
14194 }
14196 /* Each front end provides its own. */
14203 #undef LANG_HOOKS_NAME
14205 #undef LANG_HOOKS_INIT
14206 #define LANG_HOOKS_INIT ffe_init
14207 #undef LANG_HOOKS_FINISH
14208 #define LANG_HOOKS_FINISH ffe_finish
14209 #undef LANG_HOOKS_INIT_OPTIONS
14210 #define LANG_HOOKS_INIT_OPTIONS ffe_init_options
14211 #undef LANG_HOOKS_DECODE_OPTION
14212 #define LANG_HOOKS_DECODE_OPTION ffe_decode_option
14213 #undef LANG_HOOKS_PARSE_FILE
14214 #define LANG_HOOKS_PARSE_FILE ffe_parse_file
14215 #undef LANG_HOOKS_MARK_TREE
14216 #define LANG_HOOKS_MARK_TREE ffe_mark_tree
14217 #undef LANG_HOOKS_MARK_ADDRESSABLE
14218 #define LANG_HOOKS_MARK_ADDRESSABLE ffe_mark_addressable
14219 #undef LANG_HOOKS_PRINT_IDENTIFIER
14220 #define LANG_HOOKS_PRINT_IDENTIFIER ffe_print_identifier
14221 #undef LANG_HOOKS_DECL_PRINTABLE_NAME
14222 #define LANG_HOOKS_DECL_PRINTABLE_NAME ffe_printable_name
14223 #undef LANG_HOOKS_PRINT_ERROR_FUNCTION
14224 #define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function
14225 #undef LANG_HOOKS_TRUTHVALUE_CONVERSION
14226 #define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion
14228 #undef LANG_HOOKS_TYPE_FOR_MODE
14229 #define LANG_HOOKS_TYPE_FOR_MODE ffe_type_for_mode
14230 #undef LANG_HOOKS_TYPE_FOR_SIZE
14231 #define LANG_HOOKS_TYPE_FOR_SIZE ffe_type_for_size
14232 #undef LANG_HOOKS_SIGNED_TYPE
14233 #define LANG_HOOKS_SIGNED_TYPE ffe_signed_type
14234 #undef LANG_HOOKS_UNSIGNED_TYPE
14235 #define LANG_HOOKS_UNSIGNED_TYPE ffe_unsigned_type
14236 #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
14237 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type
14239 /* We do not wish to use alias-set based aliasing at all. Used in the
14240 extreme (every object with its own set, with equivalences recorded) it
14241 might be helpful, but there are problems when it comes to inlining. We
14242 get on ok with flag_argument_noalias, and alias-set aliasing does
14243 currently limit how stack slots can be reused, which is a lose. */
14244 #undef LANG_HOOKS_GET_ALIAS_SET
14245 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14249 /* Table indexed by tree code giving a string containing a character
14250 classifying the tree code. Possibilities are
14251 t, d, s, c, r, <, 1, 2 and e. See tree.def for details. */
14253 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14257 };
14258 #undef DEFTREECODE
14260 /* Table indexed by tree code giving number of expression
14261 operands beyond the fixed part of the node structure.
14262 Not used for types or decls. */
14264 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14268 };
14269 #undef DEFTREECODE
14271 /* Names of tree components.
14272 Used for printing out the tree and error messages. */
14273 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14277 };
14278 #undef DEFTREECODE
14283 {
14284 /* Open input file. */
14286 {
14289 }
14290 else
14295 #ifdef IO_BUFFER_SIZE
14297 #endif
14301 /* If the file is output from cpp, it should contain a first line
14302 `# 1 "real-filename"', and the current design of gcc (toplev.c
14303 in particular and the way it sets up information relied on by
14304 INCLUDE) requires that we read this now, and store the
14305 "real-filename" info in master_input_filename. Ask the lexer
14306 to try doing this. */
14309 /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14310 return the new file name. */
14315 }
14317 static void
14319 {
14326 }
14328 static void
14330 {
14331 /* Set default options for Fortran. */
14338 }
14340 static bool
14342 tree exp;
14343 {
14347 {
14364 {
14366 {
14369 }
14371 }
14373 {
14375 {
14378 }
14380 }
14383 /* drops in */
14389 #endif
14393 }
14394 }
14396 /* Exit a binding level.
14397 Pop the level off, and restore the state of the identifier-decl mappings
14398 that were in effect when this level was entered.
14400 If KEEP is nonzero, this level had explicit declarations, so
14401 and create a "block" (a BLOCK node) for the level
14402 to record its declarations and subblocks for symbol table output.
14404 If FUNCTIONBODY is nonzero, this level is the body of a function,
14405 so create a block as if KEEP were set and also clear out all
14406 label names.
14408 If REVERSE is nonzero, reverse the order of decls before putting
14409 them into the BLOCK. */
14411 tree
14416 {
14418 /* The chain of decls was accumulated in reverse order.
14419 Put it into forward order, just for cleanliness. */
14420 tree decls;
14423 tree decl;
14426 /* Get the decls in the order they were written.
14427 Usually current_binding_level->names is in reverse order.
14428 But parameter decls were previously put in forward order. */
14431 current_binding_level->names
14433 else
14436 /* Output any nested inline functions within this block
14437 if they weren't already output. */
14444 {
14445 /* If this decl was copied from a file-scope decl
14446 on account of a block-scope extern decl,
14447 propagate TREE_ADDRESSABLE to the file-scope decl.
14449 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14450 true, since then the decl goes through save_for_inline_copying. */
14455 {
14459 }
14460 }
14462 /* If there were any declarations or structure tags in that level,
14463 or if this level is a function body,
14464 create a BLOCK to record them for the life of this function. */
14473 {
14476 }
14478 /* In each subblock, record that this is its superior. */
14483 /* Clear out the meanings of the local variables of this level. */
14486 {
14488 {
14489 /* If the ident. was used or addressed via a local extern decl,
14490 don't forget that fact. */
14492 {
14497 }
14499 }
14500 }
14502 /* If the level being exited is the top level of a function,
14503 check over all the labels, and clear out the current
14504 (function local) meanings of their names. */
14507 {
14508 /* If this is the top level block of a function,
14509 the vars are the function's parameters.
14510 Don't leave them in the BLOCK because they are
14511 found in the FUNCTION_DECL instead. */
14514 }
14516 /* Pop the current level, and free the structure for reuse. */
14518 {
14524 }
14526 /* Dispose of the block that we just made inside some higher level. */
14531 {
14533 current_binding_level->blocks
14535 }
14536 /* If we did not make a block for the level just exited,
14537 any blocks made for inner levels
14538 (since they cannot be recorded as subblocks in that level)
14539 must be carried forward so they will later become subblocks
14540 of something else. */
14542 current_binding_level->blocks
14548 }
14550 static void
14553 tree node;
14555 {
14558 }
14560 /* Record a decl-node X as belonging to the current lexical scope.
14561 Check for errors (such as an incompatible declaration for the same
14562 name already seen in the same scope).
14564 Returns either X or an old decl for the same name.
14565 If an old decl is returned, it may have been smashed
14566 to agree with what X says. */
14568 tree
14570 tree x;
14571 {
14580 else
14584 {
14586 {
14589 }
14595 /* Don't push non-parms onto list for parms until we understand
14596 why we're doing this and whether it works. */
14599 || !ffecom_transform_only_dummies_
14605 /* If we are processing a typedef statement, generate a whole new
14606 ..._TYPE node (which will be just an variant of the existing
14607 ..._TYPE node with identical properties) and then install the
14608 TYPE_DECL node generated to represent the typedef name as the
14609 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14611 The whole point here is to end up with a situation where each and every
14612 ..._TYPE node the compiler creates will be uniquely associated with
14613 AT MOST one node representing a typedef name. This way, even though
14614 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14615 (i.e. "typedef name") nodes very early on, later parts of the
14616 compiler can always do the reverse translation and get back the
14617 corresponding typedef name. For example, given:
14619 typedef struct S MY_TYPE; MY_TYPE object;
14621 Later parts of the compiler might only know that `object' was of type
14622 `struct S' if it were not for code just below. With this code
14623 however, later parts of the compiler see something like:
14625 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14627 And they can then deduce (from the node for type struct S') that the
14628 original object declaration was:
14630 MY_TYPE object;
14632 Being able to do this is important for proper support of protoize, and
14633 also for generating precise symbolic debugging information which
14634 takes full account of the programmer's (typedef) vocabulary.
14636 Obviously, we don't want to generate a duplicate ..._TYPE node if the
14637 TYPE_DECL node that we are now processing really represents a
14638 standard built-in type.
14640 Since all standard types are effectively declared at line zero in the
14641 source file, we can easily check to see if we are working on a
14642 standard type by checking the current value of lineno. */
14645 {
14647 {
14650 }
14652 {
14658 }
14659 }
14661 /* This name is new in its binding level. Install the new declaration
14662 and return it. */
14665 else
14667 }
14669 /* Put decls on list in reverse order. We will reverse them later if
14670 necessary. */
14675 }
14677 /* Nonzero if the current level needs to have a BLOCK made. */
14679 static int
14681 {
14682 tree decl;
14685 decl;
14687 {
14690 /* Currently, there aren't supposed to be non-artificial names
14691 at other than the top block for a function -- they're
14692 believed to always be temps. But it's wise to check anyway. */
14694 }
14696 }
14698 /* Enter a new binding level.
14699 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14700 not for that of tags. */
14702 void
14705 {
14711 {
14713 }
14715 /* Reuse or create a struct for this binding level. */
14718 {
14721 }
14722 else
14723 {
14725 }
14727 /* Add this level to the front of the chain (stack) of levels that
14728 are active. */
14733 }
14735 /* Set the BLOCK node for the innermost scope
14736 (the one we are currently in). */
14738 void
14741 {
14747 }
14749 static tree
14752 tree type;
14753 {
14754 tree type2;
14775 }
14777 static tree
14779 tree type;
14780 {
14782 ffeinfoKindtype kt;
14783 tree type2;
14804 #endif
14811 {
14816 }
14819 }
14821 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14822 or validate its data type for an `if' or `while' statement or ?..: exp.
14824 This preparation consists of taking the ordinary
14825 representation of an expression expr and producing a valid tree
14826 boolean expression describing whether expr is nonzero. We could
14827 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14828 but we optimize comparisons, &&, ||, and !.
14830 The resulting type should always be `integer_type_node'. */
14832 static tree
14834 tree expr;
14835 {
14840 /* These really should return error_mark_node after 2.4 is stable.
14841 But not all callers handle ERROR_MARK properly. */
14843 {
14858 }
14862 {
14863 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14864 or comparison expressions as truth values at this level. */
14865 #if 0
14867 /* A one-bit unsigned bit-field is already acceptable. */
14872 #endif
14875 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14876 or comparison expressions as truth values at this level. */
14877 #if 0
14880 #endif
14903 else
14909 integer_type_node,
14917 /* These don't change whether an object is non-zero or zero. */
14922 /* These don't change whether an object is zero or non-zero, but
14923 we can't ignore them if their second arg has side-effects. */
14927 else
14931 /* Distribute the conversion into the arms of a COND_EXPR. */
14937 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14938 since that affects how `default_conversion' will behave. */
14942 /* fall through... */
14944 /* If this is widening the argument, we can ignore it. */
14951 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14952 this case. */
14956 /* fall through... */
14958 /* This and MINUS_EXPR can be changed into a comparison of the
14959 two objects. */
14980 #endif
14985 }
14991 integer_type_node,
14994 expr)),
14997 expr))));
15000 expr,
15002 }
15004 static tree
15008 {
15011 tree t;
15028 #if HOST_BITS_PER_WIDE_INT >= 64
15031 #endif
15047 {
15050 {
15053 else
15055 }
15056 }
15059 }
15061 static tree
15065 {
15066 ffeinfoKindtype kt;
15067 tree type_node;
15086 {
15092 }
15095 }
15097 static tree
15099 tree type;
15100 {
15102 ffeinfoKindtype kt;
15103 tree type2;
15124 #endif
15131 {
15136 }
15139 }
15141 static void
15143 tree t;
15144 {
15146 {
15151 }
15154 }
15155 \f
15156 /* From gcc/cccp.c, the code to handle -I. */
15158 /* Skip leading "./" from a directory name.
15159 This may yield the empty string, which represents the current directory. */
15163 {
15168 dir++;
15170 }
15172 /* The file_name_map structure holds a mapping of file names for a
15173 particular directory. This mapping is read from the file named
15174 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15175 map filenames on a file system with severe filename restrictions,
15176 such as DOS. The format of the file name map file is just a series
15177 of lines with two tokens on each line. The first token is the name
15178 to map, and the second token is the actual name to use. */
15180 struct file_name_map
15181 {
15185 };
15189 /* Current maximum length of directory names in the search path
15190 for include files. (Altered as we get more of them.) */
15194 struct file_name_list
15195 {
15198 /* Mapping of file names for this directory. */
15200 /* Non-zero if name_map is valid. */
15202 };
15207 /* I/O buffer structure.
15208 The `fname' field is nonzero for source files and #include files
15209 and for the dummy text used for -D and -U.
15210 It is zero for rescanning results of macro expansion
15211 and for expanding macro arguments. */
15212 #define INPUT_STACK_MAX 400
15215 /* Filename specified with #line command. */
15217 /* Record where in the search path this file was found.
15218 For #include_next. */
15220 ffewhereLine line;
15221 ffewhereColumn column;
15227 /* Current nesting level of input sources.
15228 `instack[indepth]' is the level currently being read. */
15233 /* Nonzero means -I- has been seen,
15234 so don't look for #include "foo" the source-file directory. */
15237 #ifndef INCLUDE_LEN_FUDGE
15238 #define INCLUDE_LEN_FUDGE 0
15239 #endif
15249 /* Append a chain of `struct file_name_list's
15250 to the end of the main include chain.
15251 FIRST is the beginning of the chain to append, and LAST is the end. */
15253 static void
15256 {
15264 else
15273 }
15277 }
15279 /* Try to open include file FILENAME. SEARCHPTR is the directory
15280 being tried from the include file search path. This function maps
15281 filenames on file systems based on information read by
15282 read_name_map. */
15288 {
15294 {
15298 }
15300 /* First check the mapping for the directory we are using. */
15302 {
15307 {
15309 {
15310 /* Found a match. */
15312 }
15313 }
15314 }
15316 /* Try to find a mapping file for the particular directory we are
15317 looking in. Thus #include <sys/types.h> will look up sys/types.h
15318 in /usr/include/header.gcc and look up types.h in
15319 /usr/include/sys/header.gcc. */
15321 #ifdef DIR_SEPARATOR
15326 }
15327 #endif
15334 {
15335 /* FILENAME is in SEARCHPTR, which we've already checked. */
15337 }
15340 {
15343 }
15344 else
15345 {
15352 }
15358 }
15360 /* Print the file names and line numbers of the #include
15361 commands which led to the current file. */
15363 static void
15365 {
15372 /* If stack of files hasn't changed since we last printed
15373 this info, don't repeat it. */
15381 }
15383 /* Give up if we don't find a source file. */
15387 /* Find the other, outer source files. */
15390 {
15393 {
15396 }
15397 else
15398 {
15400 }
15404 else
15407 /* xgettext:no-c-format */
15414 }
15416 /* Record we have printed the status as of this time. */
15418 }
15420 /* Read a space delimited string of unlimited length from a stdio
15421 file. */
15427 {
15434 {
15437 {
15439 {
15443 }
15445 }
15446 }
15450 }
15452 /* Read the file name map file for DIRNAME. */
15457 {
15458 /* This structure holds a linked list of file name maps, one per
15459 directory. */
15460 struct file_name_map_list
15461 {
15465 };
15495 else
15496 {
15500 {
15508 ;
15515 /* Make the real filename absolute. */
15518 else
15519 {
15525 }
15533 }
15535 }
15541 }
15543 static void
15545 {
15548 /* Do partial setup of input buffer for the sake of generating
15549 early #line directives (when -g is in effect). */
15556 }
15558 static void
15560 {
15563 indepth--;
15564 input_file_stack_tick++;
15568 }
15570 static int
15572 {
15577 else
15578 {
15586 else
15588 }
15590 }
15592 /* Open INCLUDEd file. */
15596 {
15611 /* If -I- was specified, don't search current dir, only spec'd ones. */
15613 {
15615 {
15621 {
15622 /* Found a named file. Figure out dir of the file,
15623 and put it in front of the search list. */
15626 #ifndef VMS
15628 #ifdef DIR_SEPARATOR
15633 }
15634 #endif
15642 {
15649 }
15650 else
15654 }
15655 }
15656 }
15658 /* Allocate this permanently, because it gets stored in the definitions
15659 of macros. */
15661 /* + 2 above for slash and terminating null. */
15662 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15663 for g77 yet). */
15665 /* If specified file name is absolute, just open it. */
15668 #ifdef DIR_SEPARATOR
15670 #endif
15671 )
15672 {
15676 }
15677 else
15678 {
15681 /* Search directory path, trying to open the file.
15682 Copy each filename tried into FNAME. */
15685 {
15687 {
15688 /* The empty string in a search path is ignored.
15689 This makes it possible to turn off entirely
15690 a standard piece of the list. */
15697 }
15698 else
15702 #ifdef VMS
15703 /* Change this 1/2 Unix 1/2 VMS file specification into a
15704 full VMS file specification */
15706 {
15707 /* Fix up the filename */
15709 }
15710 else
15711 {
15712 /* This is a normal VMS filespec, so use it unchanged. */
15716 /* if it's '#include filename', add the missing .h */
15719 #endif
15720 }
15723 #ifdef EACCES
15725 {
15727 /* xgettext:no-c-format */
15729 FFEBAD_severityWARNING);
15733 }
15734 #endif
15737 }
15738 }
15741 {
15742 /* A file that was not found. */
15751 }
15760 {
15762 /* xgettext:no-c-format */
15764 FFEBAD_severityFATAL);
15769 }
15779 indepth++;
15780 input_file_stack_tick++;
15783 }
15785 /**INDENT* (Do not reformat this comment even with -fca option.)
15786 Data-gathering files: Given the source file listed below, compiled with
15787 f2c I obtained the output file listed after that, and from the output
15788 file I derived the above code.
15790 -------- (begin input file to f2c)
15791 implicit none
15792 character*10 A1,A2
15793 complex C1,C2
15794 integer I1,I2
15795 real R1,R2
15796 double precision D1,D2
15797 C
15798 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15799 c /
15800 call fooI(I1/I2)
15801 call fooR(R1/I1)
15802 call fooD(D1/I1)
15803 call fooC(C1/I1)
15804 call fooR(R1/R2)
15805 call fooD(R1/D1)
15806 call fooD(D1/D2)
15807 call fooD(D1/R1)
15808 call fooC(C1/C2)
15809 call fooC(C1/R1)
15810 call fooZ(C1/D1)
15811 c **
15812 call fooI(I1**I2)
15813 call fooR(R1**I1)
15814 call fooD(D1**I1)
15815 call fooC(C1**I1)
15816 call fooR(R1**R2)
15817 call fooD(R1**D1)
15818 call fooD(D1**D2)
15819 call fooD(D1**R1)
15820 call fooC(C1**C2)
15821 call fooC(C1**R1)
15822 call fooZ(C1**D1)
15823 c FFEINTRIN_impABS
15824 call fooR(ABS(R1))
15825 c FFEINTRIN_impACOS
15826 call fooR(ACOS(R1))
15827 c FFEINTRIN_impAIMAG
15828 call fooR(AIMAG(C1))
15829 c FFEINTRIN_impAINT
15830 call fooR(AINT(R1))
15831 c FFEINTRIN_impALOG
15832 call fooR(ALOG(R1))
15833 c FFEINTRIN_impALOG10
15834 call fooR(ALOG10(R1))
15835 c FFEINTRIN_impAMAX0
15836 call fooR(AMAX0(I1,I2))
15837 c FFEINTRIN_impAMAX1
15838 call fooR(AMAX1(R1,R2))
15839 c FFEINTRIN_impAMIN0
15840 call fooR(AMIN0(I1,I2))
15841 c FFEINTRIN_impAMIN1
15842 call fooR(AMIN1(R1,R2))
15843 c FFEINTRIN_impAMOD
15844 call fooR(AMOD(R1,R2))
15845 c FFEINTRIN_impANINT
15846 call fooR(ANINT(R1))
15847 c FFEINTRIN_impASIN
15848 call fooR(ASIN(R1))
15849 c FFEINTRIN_impATAN
15850 call fooR(ATAN(R1))
15851 c FFEINTRIN_impATAN2
15852 call fooR(ATAN2(R1,R2))
15853 c FFEINTRIN_impCABS
15854 call fooR(CABS(C1))
15855 c FFEINTRIN_impCCOS
15856 call fooC(CCOS(C1))
15857 c FFEINTRIN_impCEXP
15858 call fooC(CEXP(C1))
15859 c FFEINTRIN_impCHAR
15860 call fooA(CHAR(I1))
15861 c FFEINTRIN_impCLOG
15862 call fooC(CLOG(C1))
15863 c FFEINTRIN_impCONJG
15864 call fooC(CONJG(C1))
15865 c FFEINTRIN_impCOS
15866 call fooR(COS(R1))
15867 c FFEINTRIN_impCOSH
15868 call fooR(COSH(R1))
15869 c FFEINTRIN_impCSIN
15870 call fooC(CSIN(C1))
15871 c FFEINTRIN_impCSQRT
15872 call fooC(CSQRT(C1))
15873 c FFEINTRIN_impDABS
15874 call fooD(DABS(D1))
15875 c FFEINTRIN_impDACOS
15876 call fooD(DACOS(D1))
15877 c FFEINTRIN_impDASIN
15878 call fooD(DASIN(D1))
15879 c FFEINTRIN_impDATAN
15880 call fooD(DATAN(D1))
15881 c FFEINTRIN_impDATAN2
15882 call fooD(DATAN2(D1,D2))
15883 c FFEINTRIN_impDCOS
15884 call fooD(DCOS(D1))
15885 c FFEINTRIN_impDCOSH
15886 call fooD(DCOSH(D1))
15887 c FFEINTRIN_impDDIM
15888 call fooD(DDIM(D1,D2))
15889 c FFEINTRIN_impDEXP
15890 call fooD(DEXP(D1))
15891 c FFEINTRIN_impDIM
15892 call fooR(DIM(R1,R2))
15893 c FFEINTRIN_impDINT
15894 call fooD(DINT(D1))
15895 c FFEINTRIN_impDLOG
15896 call fooD(DLOG(D1))
15897 c FFEINTRIN_impDLOG10
15898 call fooD(DLOG10(D1))
15899 c FFEINTRIN_impDMAX1
15900 call fooD(DMAX1(D1,D2))
15901 c FFEINTRIN_impDMIN1
15902 call fooD(DMIN1(D1,D2))
15903 c FFEINTRIN_impDMOD
15904 call fooD(DMOD(D1,D2))
15905 c FFEINTRIN_impDNINT
15906 call fooD(DNINT(D1))
15907 c FFEINTRIN_impDPROD
15908 call fooD(DPROD(R1,R2))
15909 c FFEINTRIN_impDSIGN
15910 call fooD(DSIGN(D1,D2))
15911 c FFEINTRIN_impDSIN
15912 call fooD(DSIN(D1))
15913 c FFEINTRIN_impDSINH
15914 call fooD(DSINH(D1))
15915 c FFEINTRIN_impDSQRT
15916 call fooD(DSQRT(D1))
15917 c FFEINTRIN_impDTAN
15918 call fooD(DTAN(D1))
15919 c FFEINTRIN_impDTANH
15920 call fooD(DTANH(D1))
15921 c FFEINTRIN_impEXP
15922 call fooR(EXP(R1))
15923 c FFEINTRIN_impIABS
15924 call fooI(IABS(I1))
15925 c FFEINTRIN_impICHAR
15926 call fooI(ICHAR(A1))
15927 c FFEINTRIN_impIDIM
15928 call fooI(IDIM(I1,I2))
15929 c FFEINTRIN_impIDNINT
15930 call fooI(IDNINT(D1))
15931 c FFEINTRIN_impINDEX
15932 call fooI(INDEX(A1,A2))
15933 c FFEINTRIN_impISIGN
15934 call fooI(ISIGN(I1,I2))
15935 c FFEINTRIN_impLEN
15936 call fooI(LEN(A1))
15937 c FFEINTRIN_impLGE
15938 call fooL(LGE(A1,A2))
15939 c FFEINTRIN_impLGT
15940 call fooL(LGT(A1,A2))
15941 c FFEINTRIN_impLLE
15942 call fooL(LLE(A1,A2))
15943 c FFEINTRIN_impLLT
15944 call fooL(LLT(A1,A2))
15945 c FFEINTRIN_impMAX0
15946 call fooI(MAX0(I1,I2))
15947 c FFEINTRIN_impMAX1
15948 call fooI(MAX1(R1,R2))
15949 c FFEINTRIN_impMIN0
15950 call fooI(MIN0(I1,I2))
15951 c FFEINTRIN_impMIN1
15952 call fooI(MIN1(R1,R2))
15953 c FFEINTRIN_impMOD
15954 call fooI(MOD(I1,I2))
15955 c FFEINTRIN_impNINT
15956 call fooI(NINT(R1))
15957 c FFEINTRIN_impSIGN
15958 call fooR(SIGN(R1,R2))
15959 c FFEINTRIN_impSIN
15960 call fooR(SIN(R1))
15961 c FFEINTRIN_impSINH
15962 call fooR(SINH(R1))
15963 c FFEINTRIN_impSQRT
15964 call fooR(SQRT(R1))
15965 c FFEINTRIN_impTAN
15966 call fooR(TAN(R1))
15967 c FFEINTRIN_impTANH
15968 call fooR(TANH(R1))
15969 c FFEINTRIN_imp_CMPLX_C
15970 call fooC(cmplx(C1,C2))
15971 c FFEINTRIN_imp_CMPLX_D
15972 call fooZ(cmplx(D1,D2))
15973 c FFEINTRIN_imp_CMPLX_I
15974 call fooC(cmplx(I1,I2))
15975 c FFEINTRIN_imp_CMPLX_R
15976 call fooC(cmplx(R1,R2))
15977 c FFEINTRIN_imp_DBLE_C
15978 call fooD(dble(C1))
15979 c FFEINTRIN_imp_DBLE_D
15980 call fooD(dble(D1))
15981 c FFEINTRIN_imp_DBLE_I
15982 call fooD(dble(I1))
15983 c FFEINTRIN_imp_DBLE_R
15984 call fooD(dble(R1))
15985 c FFEINTRIN_imp_INT_C
15986 call fooI(int(C1))
15987 c FFEINTRIN_imp_INT_D
15988 call fooI(int(D1))
15989 c FFEINTRIN_imp_INT_I
15990 call fooI(int(I1))
15991 c FFEINTRIN_imp_INT_R
15992 call fooI(int(R1))
15993 c FFEINTRIN_imp_REAL_C
15994 call fooR(real(C1))
15995 c FFEINTRIN_imp_REAL_D
15996 call fooR(real(D1))
15997 c FFEINTRIN_imp_REAL_I
15998 call fooR(real(I1))
15999 c FFEINTRIN_imp_REAL_R
16000 call fooR(real(R1))
16001 c
16002 c FFEINTRIN_imp_INT_D:
16003 c
16004 c FFEINTRIN_specIDINT
16005 call fooI(IDINT(D1))
16006 c
16007 c FFEINTRIN_imp_INT_R:
16008 c
16009 c FFEINTRIN_specIFIX
16010 call fooI(IFIX(R1))
16011 c FFEINTRIN_specINT
16012 call fooI(INT(R1))
16013 c
16014 c FFEINTRIN_imp_REAL_D:
16015 c
16016 c FFEINTRIN_specSNGL
16017 call fooR(SNGL(D1))
16018 c
16019 c FFEINTRIN_imp_REAL_I:
16020 c
16021 c FFEINTRIN_specFLOAT
16022 call fooR(FLOAT(I1))
16023 c FFEINTRIN_specREAL
16024 call fooR(REAL(I1))
16025 c
16026 end
16027 -------- (end input file to f2c)
16029 -------- (begin output from providing above input file as input to:
16030 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16031 -------- -e "s:^#.*$::g"')
16033 // -- translated by f2c (version 19950223).
16034 You must link the resulting object file with the libraries:
16035 -lf2c -lm (in that order)
16036 //
16039 // f2c.h -- Standard Fortran to C header file //
16041 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
16043 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16048 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16049 // we assume short, float are OK //
16050 typedef long int // long int // integer;
16051 typedef char *address;
16052 typedef short int shortint;
16053 typedef float real;
16054 typedef double doublereal;
16055 typedef struct { real r, i; } complex;
16056 typedef struct { doublereal r, i; } doublecomplex;
16057 typedef long int // long int // logical;
16058 typedef short int shortlogical;
16059 typedef char logical1;
16060 typedef char integer1;
16061 // typedef long long longint; // // system-dependent //
16066 // Extern is for use with -E //
16071 // I/O stuff //
16080 typedef long int // int or long int // flag;
16081 typedef long int // int or long int // ftnlen;
16082 typedef long int // int or long int // ftnint;
16085 //external read, write//
16086 typedef struct
16087 { flag cierr;
16088 ftnint ciunit;
16089 flag ciend;
16090 char *cifmt;
16091 ftnint cirec;
16092 } cilist;
16094 //internal read, write//
16095 typedef struct
16096 { flag icierr;
16097 char *iciunit;
16098 flag iciend;
16099 char *icifmt;
16100 ftnint icirlen;
16101 ftnint icirnum;
16102 } icilist;
16104 //open//
16105 typedef struct
16106 { flag oerr;
16107 ftnint ounit;
16108 char *ofnm;
16109 ftnlen ofnmlen;
16110 char *osta;
16111 char *oacc;
16112 char *ofm;
16113 ftnint orl;
16114 char *oblnk;
16115 } olist;
16117 //close//
16118 typedef struct
16119 { flag cerr;
16120 ftnint cunit;
16121 char *csta;
16122 } cllist;
16124 //rewind, backspace, endfile//
16125 typedef struct
16126 { flag aerr;
16127 ftnint aunit;
16128 } alist;
16130 // inquire //
16131 typedef struct
16132 { flag inerr;
16133 ftnint inunit;
16134 char *infile;
16135 ftnlen infilen;
16136 ftnint *inex; //parameters in standard's order//
16137 ftnint *inopen;
16138 ftnint *innum;
16139 ftnint *innamed;
16140 char *inname;
16141 ftnlen innamlen;
16142 char *inacc;
16143 ftnlen inacclen;
16144 char *inseq;
16145 ftnlen inseqlen;
16146 char *indir;
16147 ftnlen indirlen;
16148 char *infmt;
16149 ftnlen infmtlen;
16150 char *inform;
16151 ftnint informlen;
16152 char *inunf;
16153 ftnlen inunflen;
16154 ftnint *inrecl;
16155 ftnint *innrec;
16156 char *inblank;
16157 ftnlen inblanklen;
16158 } inlist;
16162 union Multitype { // for multiple entry points //
16163 integer1 g;
16164 shortint h;
16165 integer i;
16166 // longint j; //
16167 real r;
16168 doublereal d;
16169 complex c;
16170 doublecomplex z;
16171 };
16173 typedef union Multitype Multitype;
16175 typedef long Long; // No longer used; formerly in Namelist //
16177 struct Vardesc { // for Namelist //
16178 char *name;
16179 char *addr;
16180 ftnlen *dims;
16181 int type;
16182 };
16183 typedef struct Vardesc Vardesc;
16185 struct Namelist {
16186 char *name;
16187 Vardesc **vars;
16188 int nvars;
16189 };
16190 typedef struct Namelist Namelist;
16199 // procedure parameter types for -A and -C++ //
16204 typedef int // Unknown procedure type // (*U_fp)();
16205 typedef shortint (*J_fp)();
16206 typedef integer (*I_fp)();
16207 typedef real (*R_fp)();
16208 typedef doublereal (*D_fp)(), (*E_fp)();
16209 typedef // Complex // void (*C_fp)();
16210 typedef // Double Complex // void (*Z_fp)();
16211 typedef logical (*L_fp)();
16212 typedef shortlogical (*K_fp)();
16213 typedef // Character // void (*H_fp)();
16214 typedef // Subroutine // int (*S_fp)();
16216 // E_fp is for real functions when -R is not specified //
16217 typedef void C_f; // complex function //
16218 typedef void H_f; // character function //
16219 typedef void Z_f; // double complex function //
16220 typedef doublereal E_f; // real function with -R not specified //
16222 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16225 // (No such symbols should be defined in a strict ANSI C compiler.
16226 We can avoid trouble with f2c-translated code by using
16227 gcc -ansi.) //
16251 // Main program // MAIN__()
16252 {
16253 // System generated locals //
16254 integer i__1;
16255 real r__1, r__2;
16256 doublereal d__1, d__2;
16257 complex q__1;
16258 doublecomplex z__1, z__2, z__3;
16259 logical L__1;
16260 char ch__1[1];
16262 // Builtin functions //
16263 void c_div();
16264 integer pow_ii();
16265 double pow_ri(), pow_di();
16266 void pow_ci();
16267 double pow_dd();
16268 void pow_zz();
16269 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16270 asin(), atan(), atan2(), c_abs();
16271 void c_cos(), c_exp(), c_log(), r_cnjg();
16272 double cos(), cosh();
16273 void c_sin(), c_sqrt();
16274 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16275 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16276 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16277 logical l_ge(), l_gt(), l_le(), l_lt();
16278 integer i_nint();
16279 double r_sign();
16281 // Local variables //
16282 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16283 fool_(), fooz_(), getem_();
16284 static char a1[10], a2[10];
16285 static complex c1, c2;
16286 static doublereal d1, d2;
16287 static integer i1, i2;
16288 static real r1, r2;
16291 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16292 // / //
16293 i__1 = i1 / i2;
16294 fooi_(&i__1);
16295 r__1 = r1 / i1;
16296 foor_(&r__1);
16297 d__1 = d1 / i1;
16298 food_(&d__1);
16299 d__1 = (doublereal) i1;
16300 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16301 fooc_(&q__1);
16302 r__1 = r1 / r2;
16303 foor_(&r__1);
16304 d__1 = r1 / d1;
16305 food_(&d__1);
16306 d__1 = d1 / d2;
16307 food_(&d__1);
16308 d__1 = d1 / r1;
16309 food_(&d__1);
16310 c_div(&q__1, &c1, &c2);
16311 fooc_(&q__1);
16312 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16313 fooc_(&q__1);
16314 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16315 fooz_(&z__1);
16316 // ** //
16317 i__1 = pow_ii(&i1, &i2);
16318 fooi_(&i__1);
16319 r__1 = pow_ri(&r1, &i1);
16320 foor_(&r__1);
16321 d__1 = pow_di(&d1, &i1);
16322 food_(&d__1);
16323 pow_ci(&q__1, &c1, &i1);
16324 fooc_(&q__1);
16325 d__1 = (doublereal) r1;
16326 d__2 = (doublereal) r2;
16327 r__1 = pow_dd(&d__1, &d__2);
16328 foor_(&r__1);
16329 d__2 = (doublereal) r1;
16330 d__1 = pow_dd(&d__2, &d1);
16331 food_(&d__1);
16332 d__1 = pow_dd(&d1, &d2);
16333 food_(&d__1);
16334 d__2 = (doublereal) r1;
16335 d__1 = pow_dd(&d1, &d__2);
16336 food_(&d__1);
16337 z__2.r = c1.r, z__2.i = c1.i;
16338 z__3.r = c2.r, z__3.i = c2.i;
16339 pow_zz(&z__1, &z__2, &z__3);
16340 q__1.r = z__1.r, q__1.i = z__1.i;
16341 fooc_(&q__1);
16342 z__2.r = c1.r, z__2.i = c1.i;
16343 z__3.r = r1, z__3.i = 0.;
16344 pow_zz(&z__1, &z__2, &z__3);
16345 q__1.r = z__1.r, q__1.i = z__1.i;
16346 fooc_(&q__1);
16347 z__2.r = c1.r, z__2.i = c1.i;
16348 z__3.r = d1, z__3.i = 0.;
16349 pow_zz(&z__1, &z__2, &z__3);
16350 fooz_(&z__1);
16351 // FFEINTRIN_impABS //
16352 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16353 foor_(&r__1);
16354 // FFEINTRIN_impACOS //
16355 r__1 = acos(r1);
16356 foor_(&r__1);
16357 // FFEINTRIN_impAIMAG //
16358 r__1 = r_imag(&c1);
16359 foor_(&r__1);
16360 // FFEINTRIN_impAINT //
16361 r__1 = r_int(&r1);
16362 foor_(&r__1);
16363 // FFEINTRIN_impALOG //
16364 r__1 = log(r1);
16365 foor_(&r__1);
16366 // FFEINTRIN_impALOG10 //
16367 r__1 = r_lg10(&r1);
16368 foor_(&r__1);
16369 // FFEINTRIN_impAMAX0 //
16370 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16371 foor_(&r__1);
16372 // FFEINTRIN_impAMAX1 //
16373 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16374 foor_(&r__1);
16375 // FFEINTRIN_impAMIN0 //
16376 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16377 foor_(&r__1);
16378 // FFEINTRIN_impAMIN1 //
16379 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16380 foor_(&r__1);
16381 // FFEINTRIN_impAMOD //
16382 r__1 = r_mod(&r1, &r2);
16383 foor_(&r__1);
16384 // FFEINTRIN_impANINT //
16385 r__1 = r_nint(&r1);
16386 foor_(&r__1);
16387 // FFEINTRIN_impASIN //
16388 r__1 = asin(r1);
16389 foor_(&r__1);
16390 // FFEINTRIN_impATAN //
16391 r__1 = atan(r1);
16392 foor_(&r__1);
16393 // FFEINTRIN_impATAN2 //
16394 r__1 = atan2(r1, r2);
16395 foor_(&r__1);
16396 // FFEINTRIN_impCABS //
16397 r__1 = c_abs(&c1);
16398 foor_(&r__1);
16399 // FFEINTRIN_impCCOS //
16400 c_cos(&q__1, &c1);
16401 fooc_(&q__1);
16402 // FFEINTRIN_impCEXP //
16403 c_exp(&q__1, &c1);
16404 fooc_(&q__1);
16405 // FFEINTRIN_impCHAR //
16406 *(unsigned char *)&ch__1[0] = i1;
16407 fooa_(ch__1, 1L);
16408 // FFEINTRIN_impCLOG //
16409 c_log(&q__1, &c1);
16410 fooc_(&q__1);
16411 // FFEINTRIN_impCONJG //
16412 r_cnjg(&q__1, &c1);
16413 fooc_(&q__1);
16414 // FFEINTRIN_impCOS //
16415 r__1 = cos(r1);
16416 foor_(&r__1);
16417 // FFEINTRIN_impCOSH //
16418 r__1 = cosh(r1);
16419 foor_(&r__1);
16420 // FFEINTRIN_impCSIN //
16421 c_sin(&q__1, &c1);
16422 fooc_(&q__1);
16423 // FFEINTRIN_impCSQRT //
16424 c_sqrt(&q__1, &c1);
16425 fooc_(&q__1);
16426 // FFEINTRIN_impDABS //
16427 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16428 food_(&d__1);
16429 // FFEINTRIN_impDACOS //
16430 d__1 = acos(d1);
16431 food_(&d__1);
16432 // FFEINTRIN_impDASIN //
16433 d__1 = asin(d1);
16434 food_(&d__1);
16435 // FFEINTRIN_impDATAN //
16436 d__1 = atan(d1);
16437 food_(&d__1);
16438 // FFEINTRIN_impDATAN2 //
16439 d__1 = atan2(d1, d2);
16440 food_(&d__1);
16441 // FFEINTRIN_impDCOS //
16442 d__1 = cos(d1);
16443 food_(&d__1);
16444 // FFEINTRIN_impDCOSH //
16445 d__1 = cosh(d1);
16446 food_(&d__1);
16447 // FFEINTRIN_impDDIM //
16448 d__1 = d_dim(&d1, &d2);
16449 food_(&d__1);
16450 // FFEINTRIN_impDEXP //
16451 d__1 = exp(d1);
16452 food_(&d__1);
16453 // FFEINTRIN_impDIM //
16454 r__1 = r_dim(&r1, &r2);
16455 foor_(&r__1);
16456 // FFEINTRIN_impDINT //
16457 d__1 = d_int(&d1);
16458 food_(&d__1);
16459 // FFEINTRIN_impDLOG //
16460 d__1 = log(d1);
16461 food_(&d__1);
16462 // FFEINTRIN_impDLOG10 //
16463 d__1 = d_lg10(&d1);
16464 food_(&d__1);
16465 // FFEINTRIN_impDMAX1 //
16466 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16467 food_(&d__1);
16468 // FFEINTRIN_impDMIN1 //
16469 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16470 food_(&d__1);
16471 // FFEINTRIN_impDMOD //
16472 d__1 = d_mod(&d1, &d2);
16473 food_(&d__1);
16474 // FFEINTRIN_impDNINT //
16475 d__1 = d_nint(&d1);
16476 food_(&d__1);
16477 // FFEINTRIN_impDPROD //
16478 d__1 = (doublereal) r1 * r2;
16479 food_(&d__1);
16480 // FFEINTRIN_impDSIGN //
16481 d__1 = d_sign(&d1, &d2);
16482 food_(&d__1);
16483 // FFEINTRIN_impDSIN //
16484 d__1 = sin(d1);
16485 food_(&d__1);
16486 // FFEINTRIN_impDSINH //
16487 d__1 = sinh(d1);
16488 food_(&d__1);
16489 // FFEINTRIN_impDSQRT //
16490 d__1 = sqrt(d1);
16491 food_(&d__1);
16492 // FFEINTRIN_impDTAN //
16493 d__1 = tan(d1);
16494 food_(&d__1);
16495 // FFEINTRIN_impDTANH //
16496 d__1 = tanh(d1);
16497 food_(&d__1);
16498 // FFEINTRIN_impEXP //
16499 r__1 = exp(r1);
16500 foor_(&r__1);
16501 // FFEINTRIN_impIABS //
16502 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16503 fooi_(&i__1);
16504 // FFEINTRIN_impICHAR //
16505 i__1 = *(unsigned char *)a1;
16506 fooi_(&i__1);
16507 // FFEINTRIN_impIDIM //
16508 i__1 = i_dim(&i1, &i2);
16509 fooi_(&i__1);
16510 // FFEINTRIN_impIDNINT //
16511 i__1 = i_dnnt(&d1);
16512 fooi_(&i__1);
16513 // FFEINTRIN_impINDEX //
16514 i__1 = i_indx(a1, a2, 10L, 10L);
16515 fooi_(&i__1);
16516 // FFEINTRIN_impISIGN //
16517 i__1 = i_sign(&i1, &i2);
16518 fooi_(&i__1);
16519 // FFEINTRIN_impLEN //
16520 i__1 = i_len(a1, 10L);
16521 fooi_(&i__1);
16522 // FFEINTRIN_impLGE //
16523 L__1 = l_ge(a1, a2, 10L, 10L);
16524 fool_(&L__1);
16525 // FFEINTRIN_impLGT //
16526 L__1 = l_gt(a1, a2, 10L, 10L);
16527 fool_(&L__1);
16528 // FFEINTRIN_impLLE //
16529 L__1 = l_le(a1, a2, 10L, 10L);
16530 fool_(&L__1);
16531 // FFEINTRIN_impLLT //
16532 L__1 = l_lt(a1, a2, 10L, 10L);
16533 fool_(&L__1);
16534 // FFEINTRIN_impMAX0 //
16535 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16536 fooi_(&i__1);
16537 // FFEINTRIN_impMAX1 //
16538 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16539 fooi_(&i__1);
16540 // FFEINTRIN_impMIN0 //
16541 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16542 fooi_(&i__1);
16543 // FFEINTRIN_impMIN1 //
16544 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16545 fooi_(&i__1);
16546 // FFEINTRIN_impMOD //
16547 i__1 = i1 % i2;
16548 fooi_(&i__1);
16549 // FFEINTRIN_impNINT //
16550 i__1 = i_nint(&r1);
16551 fooi_(&i__1);
16552 // FFEINTRIN_impSIGN //
16553 r__1 = r_sign(&r1, &r2);
16554 foor_(&r__1);
16555 // FFEINTRIN_impSIN //
16556 r__1 = sin(r1);
16557 foor_(&r__1);
16558 // FFEINTRIN_impSINH //
16559 r__1 = sinh(r1);
16560 foor_(&r__1);
16561 // FFEINTRIN_impSQRT //
16562 r__1 = sqrt(r1);
16563 foor_(&r__1);
16564 // FFEINTRIN_impTAN //
16565 r__1 = tan(r1);
16566 foor_(&r__1);
16567 // FFEINTRIN_impTANH //
16568 r__1 = tanh(r1);
16569 foor_(&r__1);
16570 // FFEINTRIN_imp_CMPLX_C //
16571 r__1 = c1.r;
16572 r__2 = c2.r;
16573 q__1.r = r__1, q__1.i = r__2;
16574 fooc_(&q__1);
16575 // FFEINTRIN_imp_CMPLX_D //
16576 z__1.r = d1, z__1.i = d2;
16577 fooz_(&z__1);
16578 // FFEINTRIN_imp_CMPLX_I //
16579 r__1 = (real) i1;
16580 r__2 = (real) i2;
16581 q__1.r = r__1, q__1.i = r__2;
16582 fooc_(&q__1);
16583 // FFEINTRIN_imp_CMPLX_R //
16584 q__1.r = r1, q__1.i = r2;
16585 fooc_(&q__1);
16586 // FFEINTRIN_imp_DBLE_C //
16587 d__1 = (doublereal) c1.r;
16588 food_(&d__1);
16589 // FFEINTRIN_imp_DBLE_D //
16590 d__1 = d1;
16591 food_(&d__1);
16592 // FFEINTRIN_imp_DBLE_I //
16593 d__1 = (doublereal) i1;
16594 food_(&d__1);
16595 // FFEINTRIN_imp_DBLE_R //
16596 d__1 = (doublereal) r1;
16597 food_(&d__1);
16598 // FFEINTRIN_imp_INT_C //
16599 i__1 = (integer) c1.r;
16600 fooi_(&i__1);
16601 // FFEINTRIN_imp_INT_D //
16602 i__1 = (integer) d1;
16603 fooi_(&i__1);
16604 // FFEINTRIN_imp_INT_I //
16605 i__1 = i1;
16606 fooi_(&i__1);
16607 // FFEINTRIN_imp_INT_R //
16608 i__1 = (integer) r1;
16609 fooi_(&i__1);
16610 // FFEINTRIN_imp_REAL_C //
16611 r__1 = c1.r;
16612 foor_(&r__1);
16613 // FFEINTRIN_imp_REAL_D //
16614 r__1 = (real) d1;
16615 foor_(&r__1);
16616 // FFEINTRIN_imp_REAL_I //
16617 r__1 = (real) i1;
16618 foor_(&r__1);
16619 // FFEINTRIN_imp_REAL_R //
16620 r__1 = r1;
16621 foor_(&r__1);
16623 // FFEINTRIN_imp_INT_D: //
16625 // FFEINTRIN_specIDINT //
16626 i__1 = (integer) d1;
16627 fooi_(&i__1);
16629 // FFEINTRIN_imp_INT_R: //
16631 // FFEINTRIN_specIFIX //
16632 i__1 = (integer) r1;
16633 fooi_(&i__1);
16634 // FFEINTRIN_specINT //
16635 i__1 = (integer) r1;
16636 fooi_(&i__1);
16638 // FFEINTRIN_imp_REAL_D: //
16640 // FFEINTRIN_specSNGL //
16641 r__1 = (real) d1;
16642 foor_(&r__1);
16644 // FFEINTRIN_imp_REAL_I: //
16646 // FFEINTRIN_specFLOAT //
16647 r__1 = (real) i1;
16648 foor_(&r__1);
16649 // FFEINTRIN_specREAL //
16650 r__1 = (real) i1;
16651 foor_(&r__1);
16653 } // MAIN__ //
16655 -------- (end output file from f2c)
16657 */