| blob | 2fb8caa150e4ea06f28d9a7fdde5c74e5f258c07 |
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. */
98 /* VMS-specific definitions */
99 #ifdef VMS
100 #include <descrip.h>
103 #define read(fd,buf,size) VMS_read (fd,buf,size)
104 #define write(fd,buf,size) VMS_write (fd,buf,size)
105 #define open(fname,mode,prot) VMS_open (fname,mode,prot)
106 #define fopen(fname,mode) VMS_fopen (fname,mode)
107 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
108 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
109 #define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
119 #define ino_t vms_ino_t
140 /* Externals defined here. */
142 /* Stream for reading from the input file. */
145 /* These definitions parallel those in c-decl.c so that code from that
146 module can be used pretty much as is. Much of these defs aren't
147 otherwise used, i.e. by g77 code per se, except some of them are used
148 to build some of them that are. The ones that are global (i.e. not
149 "static") are those that ste.c and such might use (directly
150 or by using com macros that reference them in their definitions). */
152 tree string_type_node;
154 /* The rest of these are inventions for g77, though there might be
155 similar things in the C front end. As they are found, these
156 inventions should be renamed to be canonical. Note that only
157 the ones currently required to be global are so. */
166 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
167 just use build_function_type and build_pointer_type on the
168 appropriate _tree_type array element. */
179 ffecomSymbol ffecom_symbol_null_
180 =
181 {
182 NULL_TREE,
183 NULL_TREE,
184 NULL_TREE,
185 NULL_TREE,
186 false
187 };
192 tree ffecom_f2c_integer_type_node;
194 tree ffecom_f2c_address_type_node;
195 tree ffecom_f2c_real_type_node;
197 tree ffecom_f2c_doublereal_type_node;
198 tree ffecom_f2c_complex_type_node;
199 tree ffecom_f2c_doublecomplex_type_node;
200 tree ffecom_f2c_longint_type_node;
201 tree ffecom_f2c_logical_type_node;
202 tree ffecom_f2c_flag_type_node;
203 tree ffecom_f2c_ftnlen_type_node;
204 tree ffecom_f2c_ftnlen_zero_node;
205 tree ffecom_f2c_ftnlen_one_node;
206 tree ffecom_f2c_ftnlen_two_node;
207 tree ffecom_f2c_ptr_to_ftnlen_type_node;
208 tree ffecom_f2c_ftnint_type_node;
209 tree ffecom_f2c_ptr_to_ftnint_type_node;
211 /* Simple definitions and enumerations. */
213 #ifndef FFECOM_sizeMAXSTACKITEM
215 larger than this # bytes
216 off stack if possible. */
217 #endif
219 /* For systems that have large enough stacks, they should define
220 this to 0, and here, for ease of use later on, we just undefine
221 it if it is 0. */
223 #if FFECOM_sizeMAXSTACKITEM == 0
224 #undef FFECOM_sizeMAXSTACKITEM
225 #endif
228 {
229 FFECOM_rttypeVOID_,
244 FFECOM_rttype_
247 /* Internal typedefs. */
251 /* Private include files. */
254 /* Internal structure definitions. */
256 struct _ffecom_concat_list_
257 {
261 ffetargetCharacterSize minlen;
262 ffetargetCharacterSize maxlen;
263 };
265 /* Static functions (internal). */
299 static ffecomConcatList_
301 ffebld expr,
302 ffetargetCharacterSize max);
305 ffetargetCharacterSize max);
308 ffetargetOffset offset);
325 ffeinfoBasictype bt,
326 ffeinfoKindtype kt);
334 tree dest_length,
335 ffetargetCharacterSize dest_size,
336 ffebld source);
341 ffebld source);
351 tree t);
358 ffeinfoBasictype bt,
359 ffeinfoKindtype kt);
368 /* These are static functions that parallel those found in the C front
369 end and thus have the same names. */
394 ffewhereColumn c);
396 /* Static objects accessed by functions in this module. */
430 /* Holds pointer-to-function expressions. */
434 /* Holds the external names of the functions. */
437 =
438 {
439 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
441 #undef DEFGFRT
442 };
444 /* Whether the function returns. */
447 =
448 {
449 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
451 #undef DEFGFRT
452 };
454 /* Whether the function returns type complex. */
457 =
458 {
459 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
461 #undef DEFGFRT
462 };
464 /* Whether the function is const
465 (i.e., has no side effects and only depends on its arguments). */
468 =
469 {
470 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
472 #undef DEFGFRT
473 };
475 /* Type code for the function return value. */
478 =
479 {
480 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
482 #undef DEFGFRT
483 };
485 /* String of codes for the function's arguments. */
488 =
489 {
490 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
492 #undef DEFGFRT
493 };
495 /* Internal macros. */
497 /* We let tm.h override the types used here, to handle trivial differences
498 such as the choice of unsigned int or long unsigned int for size_t.
499 When machines start needing nontrivial differences in the size type,
500 it would be best to do something here to figure out automatically
501 from other information what type to use. */
503 #ifndef SIZE_TYPE
505 #endif
507 #define ffecom_concat_list_count_(catlist) ((catlist).count)
508 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
509 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
510 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
512 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
513 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
515 /* For each binding contour we allocate a binding_level structure
516 * which records the names defined in that contour.
517 * Contours include:
518 * 0) the global one
519 * 1) one for each function definition,
520 * where internal declarations of the parameters appear.
521 *
522 * The current meaning of a name can be found by searching the levels from
523 * the current one out to the global one.
524 */
526 /* Note that the information in the `names' component of the global contour
527 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
530 {
531 /* A chain of _DECL nodes for all variables, constants, functions,
532 and typedef types. These are in the reverse of the order supplied.
533 */
534 tree names;
536 /* For each level (except not the global one),
537 a chain of BLOCK nodes for all the levels
538 that were entered and exited one level down. */
539 tree blocks;
541 /* The BLOCK node for this level, if one has been preallocated.
542 If 0, the BLOCK is allocated (if needed) when the level is popped. */
543 tree this_block;
545 /* The binding level which this one is contained in (inherits from). */
548 /* 0: no ffecom_prepare_* functions called at this level yet;
549 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
550 2: ffecom_prepare_end called. */
552 };
554 #define NULL_BINDING_LEVEL (struct f_binding_level *) NULL
556 /* The binding level currently in effect. */
560 /* A chain of binding_level structures awaiting reuse. */
564 /* The outermost binding level, for names of file scope.
565 This is created when the compiler is started and exists
566 through the entire run. */
570 /* Binding level structures are initialized by copying this one. */
572 static const struct f_binding_level clear_binding_level
573 =
576 /* Language-dependent contents of an identifier. */
579 {
581 tree global_value;
582 tree local_value;
583 tree label_value;
585 };
587 /* Macros for access to language-specific slots in an identifier. */
588 /* Each of these slots contains a DECL node or null. */
590 /* This represents the value which the identifier has in the
591 file-scope namespace. */
592 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
593 (((struct lang_identifier *)(NODE))->global_value)
594 /* This represents the value which the identifier has in the current
595 scope. */
596 #define IDENTIFIER_LOCAL_VALUE(NODE) \
597 (((struct lang_identifier *)(NODE))->local_value)
598 /* This represents the value which the identifier has as a label in
599 the current label scope. */
600 #define IDENTIFIER_LABEL_VALUE(NODE) \
601 (((struct lang_identifier *)(NODE))->label_value)
602 /* This is nonzero if the identifier was "made up" by g77 code. */
603 #define IDENTIFIER_INVENTED(NODE) \
604 (((struct lang_identifier *)(NODE))->invented)
606 /* The resulting tree type. */
607 union lang_tree_node
609 {
612 generic;
614 };
616 /* Fortran doesn't use either of these. */
618 {
619 };
621 {
622 };
624 /* In identifiers, C uses the following fields in a special way:
625 TREE_PUBLIC to record that there was a previous local extern decl.
626 TREE_USED to record that such a decl was used.
627 TREE_ADDRESSABLE to record that the address of such a decl was used. */
629 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
630 that have names. Here so we can clear out their names' definitions
631 at the end of the function. */
635 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
638 \f
639 /* Return the subscript expression, modified to do range-checking.
641 `array' is the array to be checked against.
642 `element' is the subscript expression to check.
643 `dim' is the dimension number (starting at 0).
644 `total_dims' is the total number of dimensions (0 for CHARACTER substring).
645 */
647 static tree
650 {
653 tree cond;
654 tree die;
655 tree args;
661 {
665 else
666 {
670 }
671 }
675 {
676 /* Special handling for substring range checks. Fortran allows the
677 end subscript < begin subscript, which means that expressions like
678 string(1:0) are valid (and yield a null string). In view of this,
679 enforce two simpler conditions:
680 1) element<=high for end-substring;
681 2) element>=low for start-substring.
682 Run-time character movement will enforce remaining conditions.
684 More complicated checks would be better, but present structure only
685 provides one index element at a time, so it is not possible to
686 enforce a check of both i and j in string(i:j). If it were, the
687 complete set of rules would read,
688 if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
689 ((low<=i<=high) && (low<=j<=high)) )
690 ok ;
691 else
692 range error ;
693 */
696 else
698 }
699 else
700 {
701 /* Array reference substring range checking. */
704 low,
705 element);
707 {
709 cond,
711 element,
712 high));
713 }
714 }
716 {
720 tree arg3;
721 tree arg2;
722 tree arg1;
723 tree arg4;
726 {
743 array_name,
749 }
753 build_range_type
755 integer_one_node,
761 arg1);
763 /* s_rnge adds one to the element to print it, so bias against
764 that -- want to print a faithful *subscript* value. */
768 element,
770 integer_one_node)));
774 NULL);
782 build_range_type
784 integer_one_node,
790 arg3);
804 }
811 cond,
812 element,
813 die);
816 }
818 /* Return the computed element of an array reference.
820 `item' is NULL_TREE, or the transformed pointer to the array.
821 `expr' is the original opARRAYREF expression, which is transformed
822 if `item' is NULL_TREE.
823 `want_ptr' is non-zero if a pointer to the element, instead of
824 the element itself, is to be returned. */
826 static tree
828 {
834 tree array;
835 tree element;
836 tree tree_type;
837 tree tree_type_x;
839 ffetype type;
840 ffebld list;
844 else
847 /* Build up ARRAY_REFs in reverse order (since we're column major
848 here in Fortran land). */
853 {
860 /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
861 pointers and 32-bit integers. Do the full 64-bit pointer
862 arithmetic, for codes using arrays for nonstandard heap-like
863 work. */
865 }
872 {
875 else
884 }
890 {
891 tree min;
896 {
901 array_name);
905 /* Widen integral arithmetic as desired while preserving
906 signedness. */
921 item,
926 tree_type_x,
928 }
930 {
933 item);
934 }
935 }
936 else
937 {
941 {
947 array_name);
951 /* Widen integral arithmetic as desired while preserving
952 signedness. */
964 item,
965 element);
966 }
967 }
970 }
972 /* This is like gcc's stabilize_reference -- in fact, most of the code
973 comes from that -- but it handles the situation where the reference
974 is going to have its subparts picked at, and it shouldn't change
975 (or trigger extra invocations of functions in the subtrees) due to
976 this. save_expr is a bit overzealous, because we don't need the
977 entire thing calculated and saved like a temp. So, for DECLs, no
978 change is needed, because these are stable aggregates, and ARRAY_REF
979 and such might well be stable too, but for things like calculations,
980 we do need to calculate a snapshot of a value before picking at it. */
982 static tree
984 {
985 tree result;
989 {
993 /* No action is needed in this case. */
1045 }
1053 }
1055 /* A rip-off of gcc's convert.c convert_to_complex function,
1056 reworked to handle complex implemented as C structures
1057 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
1059 static tree
1061 {
1063 tree subtype;
1070 {
1074 }
1077 {
1081 else
1082 {
1085 type,
1089 expr)),
1093 expr)));
1094 }
1095 }
1099 else
1105 }
1107 /* Like gcc's convert(), but crashes if widening might happen. */
1109 static tree
1112 {
1125 {
1128 }
1135 {
1142 }
1144 {
1147 }
1149 {
1153 }
1155 {
1159 }
1161 {
1163 /* Check that at least the first field name agrees. */
1172 }
1176 }
1178 /* Like gcc's convert(), but crashes if narrowing might happen. */
1180 static tree
1183 {
1196 {
1199 }
1206 {
1213 }
1215 {
1218 }
1220 {
1224 }
1226 {
1230 }
1232 {
1234 /* Check that at least the first field name agrees. */
1243 }
1247 }
1249 /* Handles making a COMPLEX type, either the standard
1250 (but buggy?) gbe way, or the safer (but less elegant?)
1251 f2c way. */
1253 static tree
1255 {
1256 tree type;
1257 tree realfield;
1258 tree imagfield;
1261 {
1267 }
1268 else
1269 {
1273 }
1276 }
1278 /* Chooses either the gbe or the f2c way to build a
1279 complex constant. */
1281 static tree
1283 {
1284 tree bothparts;
1287 {
1291 }
1292 else
1293 {
1295 }
1298 }
1300 static tree
1302 {
1303 tree list;
1307 tree length;
1308 ffebld exprh;
1309 tree item;
1318 {
1320 {
1323 {
1326 }
1328 {
1367 }
1368 }
1375 || (ptr
1376 && (TYPE_MODE
1380 *plist
1384 else
1385 {
1389 {
1392 item);
1393 }
1394 *plist
1396 item);
1397 }
1402 {
1405 }
1406 }
1408 /* We've run out of args in the call; if the implementation expects
1409 more, supply null pointers for them, which the implementation can
1410 check to see if an arg was omitted. */
1413 {
1416 else
1420 {
1434 }
1435 *plist
1437 null_pointer_node);
1439 }
1444 }
1446 static tree
1448 {
1449 ffebld item;
1451 ffetype type;
1453 tree t;
1456 {
1469 {
1472 }
1473 }
1480 }
1482 /* Check whether a partial overlap between two expressions is possible.
1484 Can *starting* to write a portion of expr1 change the value
1485 computed (perhaps already, *partially*) by expr2?
1487 Currently, this is a concern only for a COMPLEX expr1. But if it
1488 isn't in COMMON or local EQUIVALENCE, since we don't support
1489 aliasing of arguments, it isn't a concern. */
1491 static bool
1493 {
1494 ffesymbol sym;
1495 ffestorag st;
1498 {
1511 }
1519 /* It's in COMMON or local EQUIVALENCE. */
1522 }
1524 /* Check whether dest and source might overlap. ffebld versions of these
1525 might or might not be passed, will be NULL if not.
1527 The test is really whether source_tree is modifiable and, if modified,
1528 might overlap destination such that the value(s) in the destination might
1529 change before it is finally modified. dest_* are the canonized
1530 destination itself. */
1532 static bool
1536 {
1537 tree source_decl;
1538 tree source_offset;
1539 tree source_size;
1540 tree t;
1546 {
1611 scalar_arg);
1616 scalar_arg);
1626 source_tree);
1631 return
1634 scalar_arg)
1637 scalar_arg);
1666 }
1668 /* Come here when source_decl, source_offset, and source_size filled
1669 in appropriately. */
1679 array? Shouldn't happen.... */
1683 dest_offset,
1685 dest_size)),
1687 source_offset));
1700 source_offset,
1702 source_size)),
1704 dest_offset));
1710 }
1712 /* Check whether dest might overlap any of a list of arguments or is
1713 in a COMMON area the callee might know about (and thus modify). */
1715 static bool
1719 {
1720 tree arg;
1721 tree dest_decl;
1722 tree dest_offset;
1723 tree dest_size;
1726 dest_tree);
1731 /* If the decl cannot be determined reliably, or if its in COMMON
1732 and the callee isn't known to not futz with COMMON via other
1733 means, overlap might happen. */
1741 {
1746 }
1749 }
1751 /* Build a string for a variable name as used by NAMELIST. This means that
1752 if we're using the f2c library, we build an uppercase string, since
1753 f2c does this. */
1755 static tree
1757 {
1761 {
1766 tree t;
1770 else
1783 }
1784 }
1786 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1787 type to just get whatever the function returns), handling the
1788 f2c value-returning convention, if required, by prepending
1789 to the arglist a pointer to a temporary to receive the return value. */
1791 static tree
1796 {
1797 tree item;
1798 tree tempvar;
1804 {
1812 callee_commons,
1813 scalar_args))
1814 {
1817 }
1818 else
1819 {
1823 }
1825 item
1829 tempvar));
1837 }
1838 else
1846 }
1848 /* Given two arguments, transform them and make a call to the given
1849 function via ffecom_call_. */
1851 static tree
1856 {
1857 tree left_tree;
1858 tree right_tree;
1859 tree left_length;
1860 tree right_length;
1863 {
1864 /* Pass arguments by reference. */
1867 }
1868 else
1869 {
1870 /* Pass arguments by value. */
1873 }
1881 {
1884 }
1887 {
1891 else
1893 }
1898 }
1900 /* Return ptr/length args for char subexpression
1902 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1903 subexpressions by constructing the appropriate trees for the ptr-to-
1904 character-text and length-of-character-text arguments in a calling
1905 sequence.
1907 Note that if with_null is TRUE, and the expression is an opCONTER,
1908 a null byte is appended to the string. */
1910 static void
1912 {
1913 tree item;
1914 tree high;
1915 ffetargetCharacter1 val;
1916 ffetargetCharacterSize newlen;
1919 {
1924 {
1925 /* Begin FFETARGET-NULL-KLUDGE. */
1928 }
1935 /* End FFETARGET-NULL-KLUDGE. */
1937 = build_type_variant
1938 (build_array_type
1940 build_range_type
1942 ffecom_f2c_ftnlen_one_node,
1943 high)),
1948 item);
1952 {
1957 {
1960 }
1962 {
1965 else
1966 {
1969 }
1970 }
1973 else
1974 /* FFEINFO_kindFUNCTION. */
1980 item);
1981 }
1985 {
1989 {
1992 }
1995 }
1999 {
2000 ffebld start;
2001 ffebld end;
2003 tree start_tree;
2004 tree end_tree;
2006 ffebld left_symter;
2007 tree array;
2015 /* Determine name for pretty-printing range-check errors. */
2019 ;
2022 else
2028 {
2031 }
2035 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2038 {
2040 ;
2041 else
2042 {
2046 char_name);
2048 end_tree);
2051 {
2054 }
2057 }
2058 }
2059 else
2060 {
2064 char_name);
2066 start_tree);
2069 {
2072 }
2077 item,
2080 start_tree,
2081 ffecom_f2c_ftnlen_one_node));
2084 {
2086 ffecom_f2c_ftnlen_one_node,
2088 ffecom_f2c_ftnlen_type_node,
2090 start_tree));
2091 }
2092 else
2093 {
2097 char_name);
2099 end_tree);
2102 {
2105 }
2108 ffecom_f2c_ftnlen_one_node,
2110 ffecom_f2c_ftnlen_type_node,
2112 }
2113 }
2114 }
2118 {
2120 tree tempvar;
2121 tree args;
2123 ffecomGfrt ix;
2126 /* ~~Kludge alert! This should someday be fixed. */
2134 {
2136 {
2137 /* Invocation of an intrinsic returning CHARACTER*1. */
2141 }
2145 }
2146 else
2147 {
2151 {
2154 }
2156 {
2159 }
2163 }
2168 tempvar);
2174 else
2175 {
2178 {
2182 }
2183 else
2184 {
2187 }
2188 }
2194 tempvar);
2195 }
2203 {
2206 }
2212 temporary. */
2213 tree tempvar;
2214 tree args;
2215 tree newlen;
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
4034 {
4039 integer_one_node),
4041 }
4043 expr_tree,
4044 tempvar);
4047 expr_tree);
4053 return
4057 return
4064 return
4071 {
4072 tree arg1_tree;
4076 return
4081 }
4088 {
4093 }
4122 return
4124 ffecom_truth_value
4126 saved_expr1,
4127 saved_expr2)),
4129 saved_expr1,
4130 saved_expr2),
4134 return
4144 {
4149 }
4156 expr_tree
4159 expr_tree);
4160 expr_tree
4163 expr_tree,
4164 integer_one_node);
4169 saved_expr1,
4170 expr_tree,
4173 #endif
4179 #if 0
4181 #else
4183 #endif
4197 {
4202 }
4212 /* We used to call FFECOM_gfrtALOG10 here. */
4215 /* We used to call FFECOM_gfrtDLOG10 here. */
4227 else
4233 {
4238 expr_tree,
4241 }
4252 else
4258 {
4263 expr_tree,
4266 }
4278 /* We used to call FFECOM_gfrtAMOD here. */
4281 /* We used to call FFECOM_gfrtDMOD here. */
4287 #if 0
4288 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4290 #else
4291 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4293 return
4296 ffecom_truth_value
4298 saved_expr1,
4300 ffecom_float_zero_))),
4302 saved_expr1,
4304 ffecom_float_half_)),
4306 saved_expr1,
4308 ffecom_float_half_))));
4309 #endif
4314 {
4317 saved_expr1
4318 = ffecom_save_tree
4322 expr_tree
4324 ffecom_truth_value
4326 arg2_tree,
4328 integer_zero_node))),
4329 saved_expr1,
4331 /* Make sure SAVE_EXPRs get referenced early enough. */
4332 expr_tree
4335 expr_tree);
4336 }
4344 {
4349 }
4361 {
4366 }
4378 else
4381 return
4429 {
4430 ffetargetLogical1 target_true;
4431 ffetargetLogical1 target_false;
4432 tree true_tree;
4433 tree false_tree;
4439 else
4443 else
4446 return
4448 ffecom_truth_value
4454 integer_one_node),
4458 integer_zero_node))),
4459 false_tree,
4460 true_tree);
4461 }
4464 return
4470 integer_one_node),
4475 {
4478 tree uns_type
4481 expr_tree
4490 uns_type,
4492 integer_zero_node)),
4494 integer_type_node,
4496 arg3_tree))));
4497 /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE. */
4498 expr_tree
4500 ffecom_truth_value
4502 arg3_tree,
4503 integer_zero_node)),
4504 expr_tree,
4506 }
4510 return
4519 {
4523 tree uns_type
4526 expr_tree
4528 ffecom_truth_value
4530 arg2_tree,
4531 integer_zero_node)),
4533 arg1_tree,
4534 arg2_tree),
4539 integer_type_node,
4540 arg2_tree))));
4541 /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds. */
4542 expr_tree
4544 ffecom_truth_value
4547 integer_type_node,
4548 arg2_tree),
4550 expr_tree,
4552 /* Make sure SAVE_EXPRs get referenced early enough. */
4553 expr_tree
4558 expr_tree));
4559 }
4563 {
4569 tree shift_neg;
4570 tree shift_pos;
4571 tree mask_arg1;
4572 tree masked_arg1;
4573 tree uns_type
4576 mask_arg1
4580 arg3_tree);
4581 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4582 mask_arg1
4584 ffecom_truth_value
4586 arg3_tree,
4588 mask_arg1,
4591 masked_arg1
4593 arg1_tree,
4595 mask_arg1));
4597 shift_neg
4603 integer_type_node,
4604 arg2_tree))),
4606 arg1_tree,
4608 arg2_tree,
4609 arg3_tree)));
4610 shift_pos
4613 arg1_tree,
4614 arg2_tree),
4619 integer_type_node,
4620 arg3_tree,
4621 arg2_tree))));
4622 expr_tree
4624 ffecom_truth_value
4626 arg2_tree,
4627 integer_zero_node)),
4628 shift_neg,
4629 shift_pos);
4630 expr_tree
4633 mask_arg1,
4634 arg1_tree),
4637 mask_arg1),
4638 expr_tree));
4639 expr_tree
4641 ffecom_truth_value
4645 integer_type_node,
4646 arg2_tree),
4647 arg3_tree),
4649 arg2_tree,
4650 integer_zero_node))),
4651 arg1_tree,
4652 expr_tree);
4653 /* Make sure SAVE_EXPRs get referenced early enough. */
4654 expr_tree
4661 mask_arg1),
4664 masked_arg1),
4665 expr_tree))));
4666 expr_tree
4669 arg3_tree),
4670 expr_tree);
4671 }
4675 {
4678 expr_tree
4682 arg1_tree));
4683 }
4687 {
4688 tree arg1_tree;
4689 tree arg2_tree;
4690 tree arg3_tree;
4692 tree arg4_tree;
4693 tree arg4_type;
4695 tree arg5_tree;
4696 tree prep_arg1;
4697 tree prep_arg4;
4698 tree arg5_plus_arg3;
4713 prep_arg1
4717 arg1_tree,
4718 arg2_tree),
4722 arg4_type,
4723 convert
4725 integer_zero_node)),
4726 arg3_tree))),
4727 arg5_tree);
4728 arg5_plus_arg3
4730 arg5_tree,
4731 arg3_tree));
4732 prep_arg4
4736 integer_zero_node)),
4737 arg5_plus_arg3);
4738 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4739 prep_arg4
4741 ffecom_truth_value
4743 arg5_plus_arg3,
4746 prep_arg4,
4748 prep_arg4
4750 arg4_tree,
4752 prep_arg4,
4756 arg4_type,
4757 convert
4759 integer_zero_node)),
4760 arg5_tree))));
4761 prep_arg1
4763 prep_arg1,
4764 prep_arg4);
4765 /* Fix up (twice), because LSHIFT_EXPR above
4766 can't shift over TYPE_SIZE. */
4767 prep_arg1
4769 ffecom_truth_value
4771 arg3_tree,
4773 integer_zero_node))),
4774 prep_arg1,
4775 arg4_tree);
4776 prep_arg1
4778 ffecom_truth_value
4780 arg3_tree,
4783 prep_arg1,
4784 arg1_tree);
4785 expr_tree
4787 arg4_tree,
4788 prep_arg1);
4789 /* Make sure SAVE_EXPRs get referenced early enough. */
4790 expr_tree
4792 arg1_tree,
4794 arg3_tree,
4796 arg5_tree,
4798 arg5_plus_arg3,
4799 expr_tree))));
4800 expr_tree
4802 arg4_tree,
4803 expr_tree);
4805 }
4815 /* extern int xargc; i__1 = xargc - 1; */
4817 ffecom_tree_xargc_,
4819 integer_one_node));
4824 {
4825 tree arg1_tree;
4826 tree arg2_tree;
4827 tree arg3_tree;
4833 arg1_tree);
4835 /* Pass procedure as a pointer to it, anything else by value. */
4838 else
4841 arg2_tree);
4845 else
4852 expr_tree
4855 FALSE,
4857 NULL_TREE :
4858 tree_type),
4859 arg1_tree,
4864 expr_tree
4867 expr_tree));
4868 }
4872 {
4873 tree arg1_tree;
4874 tree arg2_tree;
4875 tree arg3_tree;
4881 arg1_tree);
4883 /* Pass procedure as a pointer to it, anything else by value. */
4886 else
4889 arg2_tree);
4893 else
4900 expr_tree
4903 FALSE,
4904 NULL_TREE,
4905 arg1_tree,
4910 expr_tree
4913 expr_tree));
4914 }
4925 {
4927 tree arg1_tree;
4928 tree arg2_tree;
4934 else
4941 expr_tree
4944 FALSE,
4945 NULL_TREE,
4946 arg1_tree,
4951 expr_tree
4954 expr_tree));
4955 }
4964 build_pointer_type
4966 integer_zero_node));
4968 return
4971 FALSE,
4972 void_type_node,
4973 expr_tree,
4980 else
4988 {
4990 tree arg1_tree;
4992 tree arg2_tree;
4993 tree arg3_tree;
4999 else
5011 FALSE,
5012 NULL_TREE,
5013 arg1_tree,
5019 expr_tree));
5020 }
5025 {
5027 tree arg1_tree;
5028 tree arg2_tree;
5029 tree arg3_tree;
5037 else
5047 FALSE,
5048 NULL_TREE,
5049 arg1_tree,
5055 expr_tree));
5056 }
5061 {
5062 tree arg1_tree;
5063 tree arg2_tree;
5065 tree arg3_tree;
5071 arg1_tree);
5076 else
5087 FALSE,
5088 NULL_TREE,
5089 arg1_tree,
5095 expr_tree));
5096 }
5100 {
5101 tree arg1_tree;
5102 tree arg2_tree;
5103 tree arg3_tree;
5109 arg1_tree);
5116 else
5124 FALSE,
5125 NULL_TREE,
5126 arg1_tree,
5132 expr_tree));
5133 }
5134 }
5138 {
5139 tree arg1_tree;
5140 tree arg2_tree;
5141 tree arg3_tree;
5147 arg1_tree);
5153 arg2_tree);
5157 else
5165 FALSE,
5166 NULL_TREE,
5167 arg1_tree,
5173 expr_tree));
5174 }
5175 }
5180 {
5182 tree arg1_tree;
5183 tree arg2_tree;
5188 ffecom_f2c_longint_type_node :
5189 ffecom_f2c_integer_type_node),
5193 arg2_tree);
5201 expr_tree
5204 FALSE,
5205 NULL_TREE,
5206 arg1_tree,
5210 }
5215 /* Arg defaults to 0 (normal random case) */
5216 {
5217 tree arg1_tree;
5221 else
5224 arg1_tree);
5227 arg1_tree);
5232 FALSE,
5234 ffecom_f2c_integer_type_node :
5235 ffecom_f2c_real_type_node),
5236 arg1_tree,
5240 }
5245 {
5246 tree arg1_tree;
5247 tree arg2_tree;
5253 arg1_tree);
5257 else
5262 FALSE,
5263 NULL_TREE,
5266 TRUE,
5271 expr_tree));
5272 }
5273 }
5278 {
5279 tree arg1_tree;
5283 expr_tree
5286 FALSE,
5287 NULL_TREE,
5288 NULL_TREE,
5292 expr_tree
5295 expr_tree));
5296 }
5301 {
5302 tree arg1_tree;
5303 tree result_tree;
5311 FALSE,
5312 NULL_TREE,
5315 TRUE,
5319 expr_tree));
5320 }
5323 /* Straightforward calls of libf2c routines: */
5400 }
5409 tree_type,
5414 /* See bottom of this file for f2c transforms used to determine
5415 many of the above implementations. The info seems to confuse
5416 Emacs's C mode indentation, which is why it's been moved to
5417 the bottom of this source file. */
5418 }
5420 /* For power (exponentiation) where right-hand operand is type INTEGER,
5421 generate in-line code to do it the fast way (which, if the operand
5422 is a constant, might just mean a series of multiplies). */
5424 static tree
5426 {
5438 {
5446 {
5447 /* Reciprocal of integer is either 0, -1, or 1, so after
5448 calculating that (which we leave to the back end to do
5449 or not do optimally), don't bother with any multiplying. */
5453 l,
5456 rtype,
5457 r);
5460 result);
5461 }
5463 /* Generate appropriate series of multiplies, preceded
5464 by divide if the exponent is negative. */
5469 {
5472 l,
5482 r,
5483 integer_one_node));
5486 l,
5487 l);
5488 }
5489 }
5492 {
5494 {
5497 else
5499 result,
5500 l);
5501 }
5504 r,
5505 integer_one_node);
5512 l,
5513 l);
5514 }
5516 }
5518 /* Though rhs isn't a constant, in-line code cannot be expanded
5519 while transforming dummies
5520 because the back end cannot be easily convinced to generate
5521 stores (MODIFY_EXPR), handle temporaries, and so on before
5522 all the appropriate rtx's have been generated for things like
5523 dummy args referenced in rhs -- which doesn't happen until
5524 store_parm_decls() is called (expand_function_start, I believe,
5525 does the actual rtx-stuffing of PARM_DECLs).
5527 So, in this case, let the caller generate the call to the
5528 run-time-library function to evaluate the power for us. */
5533 /* Right-hand operand not a constant, expand in-line code to figure
5534 out how to do the multiplies, &c.
5536 The returned expression is expressed this way in GNU C, where l and
5537 r are the "inputs":
5539 ({ typeof (r) rtmp = r;
5540 typeof (l) ltmp = l;
5541 typeof (l) result;
5543 if (rtmp == 0)
5544 result = 1;
5545 else
5546 {
5547 if ((basetypeof (l) == basetypeof (int))
5548 && (rtmp < 0))
5549 {
5550 result = ((typeof (l)) 1) / ltmp;
5551 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5552 result = -result;
5553 }
5554 else
5555 {
5556 result = 1;
5557 if ((basetypeof (l) != basetypeof (int))
5558 && (rtmp < 0))
5559 {
5560 ltmp = ((typeof (l)) 1) / ltmp;
5561 rtmp = -rtmp;
5562 if (rtmp < 0)
5563 {
5564 rtmp = -(rtmp >> 1);
5565 ltmp *= ltmp;
5566 }
5567 }
5568 for (;;)
5569 {
5570 if (rtmp & 1)
5571 result *= ltmp;
5572 if ((rtmp >>= 1) == 0)
5573 break;
5574 ltmp *= ltmp;
5575 }
5576 }
5577 }
5578 result;
5579 })
5581 Note that some of the above is compile-time collapsable, such as
5582 the first part of the if statements that checks the base type of
5583 l against int. The if statements are phrased that way to suggest
5584 an easy way to generate the if/else constructs here, knowing that
5585 the back end should (and probably does) eliminate the resulting
5586 dead code (either the int case or the non-int case), something
5587 it couldn't do without the redundant phrasing, requiring explicit
5588 dead-code elimination here, which would be kind of difficult to
5589 read. */
5591 {
5592 tree rtmp;
5593 tree ltmp;
5594 tree divide;
5595 tree basetypeof_l_is_int;
5596 tree se;
5597 tree t;
5599 basetypeof_l_is_int
5616 else
5620 rtmp,
5621 r));
5623 ltmp,
5624 l));
5627 rtmp,
5631 result,
5635 {
5637 rtmp,
5639 integer_zero_node)),
5642 result,
5643 ffecom_tree_divide_
5646 ltmp,
5648 divide)));
5652 ltmp,
5654 integer_zero_node)),
5657 rtype,
5659 rtype,
5660 rtmp),
5662 integer_one_node)),
5664 integer_zero_node)))),
5667 result,
5669 ltype,
5670 result)));
5673 }
5675 result,
5679 ffecom_truth_value_invert
5682 rtmp,
5684 integer_zero_node)))),
5687 ltmp,
5688 ffecom_tree_divide_
5691 ltmp,
5693 divide)));
5695 rtmp,
5697 rtmp)));
5700 rtmp,
5704 rtmp,
5707 rtype,
5708 rtmp,
5709 integer_one_node))));
5711 ltmp,
5713 ltmp,
5714 ltmp)));
5720 rtmp,
5724 result,
5726 result,
5727 ltmp)));
5730 ffecom_truth_value
5732 rtmp,
5734 rtype,
5735 rtmp,
5736 integer_one_node))));
5738 ltmp,
5740 ltmp,
5741 ltmp)));
5752 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5755 {
5756 /* Make a BIND_EXPR for the BLOCK already made. */
5759 /* Remove the block from the tree at this point.
5760 It gets put back at the proper place
5761 when the BIND_EXPR is expanded. */
5763 }
5764 else
5766 }
5769 }
5771 /* ffecom_expr_transform_ -- Transform symbols in expr
5773 ffebld expr; // FFE expression.
5774 ffecom_expr_transform_ (expr);
5776 Recursive descent on expr while transforming any untransformed SYMTERs. */
5778 static void
5780 {
5781 tree t;
5782 ffesymbol s;
5784 tail_recurse:
5790 {
5798 {
5801 DIMENSION expr? */
5802 }
5812 }
5815 {
5827 }
5830 }
5832 /* Make a type based on info in live f2c.h file. */
5834 static void
5836 {
5838 {
5861 ? signed_char_type_node
5895 }
5900 }
5902 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5903 given size. */
5905 static void
5908 {
5910 tree t;
5915 {
5919 }
5920 }
5922 /* Finish up globals after doing all program units in file
5924 Need to handle only uninitialized COMMON areas. */
5926 static ffeglobal
5928 {
5929 tree cbtype;
5930 tree cbt;
5931 tree size;
5946 /* Give the array a size now. */
5954 integer_zero_node,
5955 size);
5966 }
5968 /* Finish up any untransformed symbols. */
5970 static ffesymbol
5972 {
5976 /* It's easy to know to transform an untransformed symbol, to make sure
5977 we put out debugging info for it. But COMMON variables, unlike
5978 EQUIVALENCE ones, aren't given declarations in addition to the
5979 tree expressions that specify offsets, because COMMON variables
5980 can be referenced in the outer scope where only dummy arguments
5981 (PARM_DECLs) should really be seen. To be safe, just don't do any
5982 VAR_DECLs for COMMON variables when we transform them for real
5983 use, and therefore we do all the VAR_DECL creating here. */
5986 {
5991 /* Not transformed, and not CHARACTER*(*), and not a dummy
5992 argument, which can happen only if the entry point names
5993 it "rides in on" are all invalidated for other reasons. */
5995 }
5999 {
6000 /* This isn't working, at least for dbxout. The .s file looks
6001 okay to me (burley), but in gdb 4.9 at least, the variables
6002 appear to reside somewhere outside of the common area, so
6003 it doesn't make sense to mislead anyone by generating the info
6004 on those variables until this is fixed. NOTE: Same problem
6005 with EQUIVALENCE, sadly...see similar #if later. */
6008 }
6011 }
6013 /* Append underscore(s) to name before calling get_identifier. "us"
6014 is nonzero if the name already contains an underscore and thus
6015 needs two underscores appended. */
6017 static tree
6019 {
6022 tree id;
6036 }
6038 /* Decide whether to append underscore to name before calling
6039 get_identifier. */
6041 static tree
6043 {
6047 /* If name is a built-in name, just return it as is. */
6051 #if FFETARGET_isENFORCED_MAIN_NAME
6053 #else
6055 #endif
6064 }
6066 /* Decide whether to append underscore to internal name before calling
6067 get_identifier.
6069 This is for non-external, top-function-context names only. Transform
6070 identifier so it doesn't conflict with the transformed result
6071 of using a _different_ external name. E.g. if "CALL FOO" is
6072 transformed into "FOO_();", then the variable in "FOO_ = 3"
6073 must be transformed into something that does not conflict, since
6074 these two things should be independent.
6076 The transformation is as follows. If the name does not contain
6077 an underscore, there is no possible conflict, so just return.
6078 If the name does contain an underscore, then transform it just
6079 like we transform an external identifier. */
6081 static tree
6083 {
6084 /* If name does not contain an underscore, just return it as is. */
6091 name);
6092 }
6094 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6096 tree t;
6097 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6098 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6099 ffesymbol_kindtype(s));
6101 Call after setting up containing function and getting trees for all
6102 other symbols. */
6104 static tree
6106 {
6108 tree type;
6109 tree func;
6110 tree result;
6118 /* For now, we don't have a handy pointer to where the sfunc is actually
6119 defined, though that should be easy to add to an ffesymbol. (The
6120 token/where info available might well point to the place where the type
6121 of the sfunc is declared, especially if that precedes the place where
6122 the sfunc itself is defined, which is typically the case.) We should
6123 put out a null pointer rather than point somewhere wrong, but I want to
6124 see how it works at this point. */
6129 /* Pretransform the expression so any newly discovered things belong to the
6130 outer program unit, not to the statement function. */
6134 /* Make sure no recursive invocation of this fn (a specific case of failing
6135 to pretransform an sfunc's expression, i.e. where its expression
6136 references another untransformed sfunc) happens. */
6145 else
6146 {
6150 error. */
6151 }
6158 /* We don't worry about COMPLEX return values here, because this is
6159 entirely internal to our code, and gcc has the ability to return COMPLEX
6160 directly as a value. */
6164 tree type;
6176 }
6177 else
6187 {
6189 {
6191 tree result_length;
6202 }
6203 else
6204 {
6212 }
6213 }
6230 }
6234 {
6236 }
6238 static tree
6240 {
6247 }
6249 /* Return initialize-to-zero expression for this VAR_DECL. */
6251 /* A somewhat evil way to prevent the garbage collector
6252 from collecting 'tree' structures. */
6253 #define NUM_TRACKED_CHUNK 63
6255 {
6258 };
6261 void
6263 {
6268 {
6271 }
6273 {
6274 /* Need to allocate a new block. */
6282 }
6283 }
6285 static tree
6287 {
6288 tree init;
6293 {
6296 }
6304 {
6308 }
6309 else
6310 {
6313 }
6316 }
6318 static tree
6321 {
6322 tree expr_tree;
6323 tree length_tree;
6326 {
6329 (ffebld_constant_character1
6331 {
6334 }
6338 (ffebld_constant_character1
6352 {
6355 }
6358 {
6361 }
6363 expr_tree
6366 expr_tree);
6367 expr_tree
6370 expr_tree,
6371 integer_one_node);
6377 *maybe_tree
6378 = ffecom_truth_value
6380 length_tree,
6381 ffecom_f2c_ftnlen_zero_node));
6387 {
6390 }
6392 maybe_tree);
6395 {
6396 tree maybe_left;
6397 tree maybe_right;
6398 tree expr_left;
6399 tree expr_right;
6406 maybe_left,
6407 maybe_right);
6409 maybe_left,
6410 expr_left,
6411 expr_right);
6413 }
6418 }
6419 }
6421 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6423 tree length_arg;
6424 ffebld expr;
6425 length_arg = ffecom_intrinsic_len_ (expr);
6427 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6428 subexpressions by constructing the appropriate tree for the
6429 length-of-character-text argument in a calling sequence. */
6431 static tree
6433 {
6434 ffetargetCharacter1 val;
6435 tree length;
6438 {
6446 {
6448 tree item;
6452 {
6455 }
6457 {
6460 else
6461 {
6464 }
6465 }
6470 }
6478 {
6479 ffebld start;
6480 ffebld end;
6482 tree start_tree;
6483 tree end_tree;
6497 {
6499 ;
6500 else
6501 {
6504 }
6505 }
6506 else
6507 {
6512 {
6515 }
6518 {
6520 ffecom_f2c_ftnlen_one_node,
6522 ffecom_f2c_ftnlen_type_node,
6523 length,
6524 start_tree));
6525 }
6526 else
6527 {
6532 {
6535 }
6538 ffecom_f2c_ftnlen_one_node,
6540 ffecom_f2c_ftnlen_type_node,
6542 }
6543 }
6544 }
6548 length
6564 }
6569 }
6571 /* Handle CHARACTER assignments.
6573 Generates code to do the assignment. Used by ordinary assignment
6574 statement handler ffecom_let_stmt and by statement-function
6575 handler to generate code for a statement function. */
6577 static void
6580 {
6581 ffecomConcatList_ catlist;
6582 tree source_length;
6583 tree source_tree;
6584 tree expr_tree;
6593 /* Source might be an opCONVERT, which just means it is a different size
6594 than the destination. Since the underlying implementation here handles
6595 that (directly or via the s_copy or s_cat run-time-library functions),
6596 we don't need the "convenience" of an opCONVERT that tells us to
6597 truncate or blank-pad, particularly since the resulting implementation
6598 would probably be slower than otherwise. */
6605 {
6636 {
6637 dest_tree
6641 dest_tree);
6642 dest_tree
6646 dest_tree,
6647 integer_one_node);
6648 source_tree
6652 source_tree);
6653 source_tree
6657 source_tree,
6658 integer_one_node);
6665 }
6683 }
6685 /* Heavy-duty concatenation. */
6687 {
6690 tree lengths;
6691 tree items;
6692 tree length_array;
6693 tree item_array;
6694 tree citem;
6695 tree clength;
6697 {
6698 tree hook;
6706 }
6709 {
6714 {
6717 }
6719 items
6724 item_array,
6726 citem),
6727 items);
6728 lengths
6733 length_array,
6735 clength),
6736 lengths);
6737 }
6744 items));
6749 lengths));
6751 = build_tree_list
6763 }
6766 }
6768 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6770 ffecomGfrt ix;
6771 ffecom_make_gfrt_(ix);
6773 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6774 for the indicated run-time routine (ix). */
6776 static void
6778 {
6779 tree t;
6780 tree ttype;
6783 {
6848 }
6853 ttype);
6859 /* Sanity check: A function that's const cannot be volatile. */
6863 /* Sanity check: A function that's const cannot return complex. */
6872 }
6874 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
6876 static void
6878 {
6883 }
6885 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
6886 the member so debugger will see it. Otherwise nobody should be
6887 referencing the member. */
6889 static void
6891 {
6892 ffesymbol s;
6893 tree t;
6894 tree mt;
6895 tree type;
6914 type);
6931 }
6933 /* Prepare source expression for assignment into a destination perhaps known
6934 to be of a specific size. */
6936 static void
6938 {
6939 ffecomConcatList_ catlist;
6942 tree ltmp;
6943 tree itmp;
6953 {
6954 ltmp
6957 itmp
6964 }
6972 {
6975 }
6976 }
6978 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
6980 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
6981 (which generates their trees) and then their trees get push_parm_decl'd.
6983 The second arg is TRUE if the dummies are for a statement function, in
6984 which case lengths are not pushed for character arguments (since they are
6985 always known by both the caller and the callee, though the code allows
6986 for someday permitting CHAR*(*) stmtfunc dummies). */
6988 static void
6990 {
6991 ffebld dummy;
6992 ffebld dumlist;
6993 ffesymbol s;
6994 tree parm;
6998 /* First push the parms corresponding to actual dummy "contents". */
7001 {
7004 {
7011 }
7016 {
7020 }
7023 }
7025 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7028 {
7031 {
7035 NOTHING! */
7039 }
7045 length param. */
7052 }
7055 }
7057 /* ffecom_start_progunit_ -- Beginning of program unit
7059 Does GNU back end stuff necessary to teach it about the start of its
7060 equivalent of a Fortran program unit. */
7062 static void
7064 {
7066 ffebld arglist;
7070 ffeinfoBasictype bt;
7071 ffeinfoKindtype kt;
7072 ffeglobal g;
7073 ffeglobalType gt;
7078 bool multi
7079 = altentries
7093 {
7119 {
7125 }
7135 else
7142 else
7157 else
7165 /* Fall through. */
7174 }
7177 {
7180 }
7181 #if FFETARGET_isENFORCED_MAIN
7184 #endif
7185 else
7189 type,
7199 {
7201 }
7203 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7204 exec-transitioning needs current_function_decl to be filled in. So we
7205 do these things in two phases. */
7209 ffecom_which_entrypoint_decl_
7213 integer_type_node);
7215 }
7218 || cmplxfunc
7221 tree type;
7222 tree length;
7228 else
7233 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7237 else
7246 else
7250 {
7253 }
7254 }
7257 {
7260 else
7263 }
7269 /* Disallow temp vars at this level. */
7275 /* This handles any symbols still untransformed, in case -g specified.
7276 This used to be done in ffecom_finish_progunit, but it turns out to
7277 be necessary to do it here so that statement functions are
7278 expanded before code. But don't bother for BLOCK DATA. */
7282 }
7284 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7286 ffesymbol s;
7287 ffecom_sym_transform_(s);
7289 The ffesymbol_hook info for s is updated with appropriate backend info
7290 on the symbol. */
7292 static ffesymbol
7294 {
7298 ffeinfoBasictype bt;
7299 ffeinfoKindtype kt;
7300 ffeglobal g;
7304 /* Must ensure special ASSIGN variables are declared at top of outermost
7305 block, else they'll end up in the innermost block when their first
7306 ASSIGN is seen, which leaves them out of scope when they're the
7307 subject of a GOTO or I/O statement.
7309 We make this variable even if -fugly-assign. Just let it go unused,
7310 in case it turns out there are cases where we really want to use this
7311 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7319 {
7322 }
7323 else
7324 {
7329 }
7339 {
7342 {
7346 /* Before 0.4, this could be ENTITY/DUMMY, but see
7347 ffestu_sym_end_transition -- no longer true (in particular, if
7348 it could be an ENTITY, it _will_ be made one, so that
7349 possibility won't come through here). So we never make length
7350 arg for CHARACTER type. */
7354 ffecom_tree_ptr_to_subr_type);
7368 {
7371 }
7394 /* Fall through. */
7397 }
7402 {
7405 /* ~~Debugging info needed? */
7413 {
7415 tree type;
7419 {
7422 }
7427 {
7430 }
7435 ffestorag est;
7436 tree et;
7437 ffetargetOffset offset;
7454 /* (t_type *) (((char *) &et) + offset) */
7459 et));
7461 t,
7464 t);
7468 }
7469 else
7470 {
7471 tree initexpr;
7476 type);
7480 #ifdef FFECOM_sizeMAXSTACKITEM
7483 #endif
7485 && (ffecom_primary_entry_kind_
7489 else
7495 /* Keep -Wunused from complaining about var if it
7496 is used as sfunc arg or DATA implied-DO. */
7503 {
7506 else
7508 }
7511 else
7517 {
7521 }
7522 }
7523 }
7531 it (& length). */
7536 }
7541 it. */
7545 }
7547 {
7550 }
7553 {
7556 ffecom_multi_retval_);
7561 }
7575 {
7576 tree type;
7577 ffebld dl;
7578 ffebld dim;
7579 tree low;
7580 tree high;
7581 tree old_sizes;
7586 {
7589 context; get it later. */
7591 }
7594 }
7595 else
7608 {
7616 else
7621 {
7622 /* Used to just do high=low. But for ffecom_tree_
7623 canonize_ref_, it probably is important to correctly
7624 assess the size. E.g. given COMPLEX C(*),CFUNC and
7625 C(2)=CFUNC(C), overlap can happen, while it can't
7626 for, say, C(1)=CFUNC(C(2)). */
7627 /* Even more recently used to set to INT_MAX, but that
7628 broke when some overflow checking went into the back
7629 end. Now we just leave the upper bound unspecified. */
7631 }
7632 else
7635 /* Determine whether array is conditionally adjustable,
7636 to decide whether back-end magic is needed.
7638 Normally the front end uses the back-end function
7639 variable_size to wrap SAVE_EXPR's around expressions
7640 affecting the size/shape of an array so that the
7641 size/shape info doesn't change during execution
7642 of the compiled code even though variables and
7643 functions referenced in those expressions might.
7645 variable_size also makes sure those saved expressions
7646 get evaluated immediately upon entry to the
7647 compiled procedure -- the front end normally doesn't
7648 have to worry about that.
7650 However, there is a problem with this that affects
7651 g77's implementation of entry points, and that is
7652 that it is _not_ true that each invocation of the
7653 compiled procedure is permitted to evaluate
7654 array size/shape info -- because it is possible
7655 that, for some invocations, that info is invalid (in
7656 which case it is "promised" -- i.e. a violation of
7657 the Fortran standard -- that the compiled code
7658 won't reference the array or its size/shape
7659 during that particular invocation).
7661 To phrase this in C terms, consider this gcc function:
7663 void foo (int *n, float (*a)[*n])
7664 {
7665 // a is "pointer to array ...", fyi.
7666 }
7668 Suppose that, for some invocations, it is permitted
7669 for a caller of foo to do this:
7671 foo (NULL, NULL);
7673 Now the _written_ code for foo can take such a call
7674 into account by either testing explicitly for whether
7675 (a == NULL) || (n == NULL) -- presumably it is
7676 not permitted to reference *a in various fashions
7677 if (n == NULL) I suppose -- or it can avoid it by
7678 looking at other info (other arguments, static/global
7679 data, etc.).
7681 However, this won't work in gcc 2.5.8 because it'll
7682 automatically emit the code to save the "*n"
7683 expression, which'll yield a NULL dereference for
7684 the "foo (NULL, NULL)" call, something the code
7685 for foo cannot prevent.
7687 g77 definitely needs to avoid executing such
7688 code anytime the pointer to the adjustable array
7689 is NULL, because even if its bounds expressions
7690 don't have any references to possible "absent"
7691 variables like "*n" -- say all variable references
7692 are to COMMON variables, i.e. global (though in C,
7693 local static could actually make sense) -- the
7694 expressions could yield other run-time problems
7695 for allowably "dead" values in those variables.
7697 For example, let's consider a more complicated
7698 version of foo:
7700 extern int i;
7701 extern int j;
7703 void foo (float (*a)[i/j])
7704 {
7705 ...
7706 }
7708 The above is (essentially) quite valid for Fortran
7709 but, again, for a call like "foo (NULL);", it is
7710 permitted for i and j to be undefined when the
7711 call is made. If j happened to be zero, for
7712 example, emitting the code to evaluate "i/j"
7713 could result in a run-time error.
7715 Offhand, though I don't have my F77 or F90
7716 standards handy, it might even be valid for a
7717 bounds expression to contain a function reference,
7718 in which case I doubt it is permitted for an
7719 implementation to invoke that function in the
7720 Fortran case involved here (invocation of an
7721 alternate ENTRY point that doesn't have the adjustable
7722 array as one of its arguments).
7724 So, the code that the compiler would normally emit
7725 to preevaluate the size/shape info for an
7726 adjustable array _must not_ be executed at run time
7727 in certain cases. Specifically, for Fortran,
7728 the case is when the pointer to the adjustable
7729 array == NULL. (For gnu-ish C, it might be nice
7730 for the source code itself to specify an expression
7731 that, if TRUE, inhibits execution of the code. Or
7732 reverse the sense for elegance.)
7734 (Note that g77 could use a different test than NULL,
7735 actually, since it happens to always pass an
7736 integer to the called function that specifies which
7737 entry point is being invoked. Hmm, this might
7738 solve the next problem.)
7740 One way a user could, I suppose, write "foo" so
7741 it works is to insert COND_EXPR's for the
7742 size/shape info so the dangerous stuff isn't
7743 actually done, as in:
7745 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7746 {
7747 ...
7748 }
7750 The next problem is that the front end needs to
7751 be able to tell the back end about the array's
7752 decl _before_ it tells it about the conditional
7753 expression to inhibit evaluation of size/shape info,
7754 as shown above.
7756 To solve this, the front end needs to be able
7757 to give the back end the expression to inhibit
7758 generation of the preevaluation code _after_
7759 it makes the decl for the adjustable array.
7761 Until then, the above example using the COND_EXPR
7762 doesn't pass muster with gcc because the "(a == NULL)"
7763 part has a reference to "a", which is still
7764 undefined at that point.
7766 g77 will therefore use a different mechanism in the
7767 meantime. */
7778 low,
7779 ffecom_integer_zero_node);
7784 high,
7785 ffecom_integer_zero_node);
7786 #endif
7788 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7789 probably. Fixes 950302-1.f. */
7794 /* ~~~Similarly, this fixes dumb0.f. The C front end
7795 does this, which is why dumb0.c would work. */
7800 type
7801 = build_array_type
7806 }
7809 {
7812 }
7816 {
7819 }
7824 /* If this arg is present in every entry point's list of
7825 dummy args, then we're done. */
7831 #if 1
7833 /* If variable_size in stor-layout has been called during
7834 the above, then get_pending_sizes should have the
7835 yet-to-be-evaluated saved expressions pending.
7836 Make the whole lot of them get emitted, conditionally
7837 on whether the array decl ("t" above) is not NULL. */
7839 {
7841 tree tem;
7846 {
7851 else
7852 sizes
7855 temv,
7856 sizes);
7857 }
7860 {
7861 sizes
7865 integer_type_node,
7866 t,
7867 null_pointer_node),
7868 sizes,
7870 integer_zero_node));
7873 sizes
7875 }
7879 }
7881 #else
7882 #if 0
7888 t,
7889 null_pointer_node);
7890 #else
7891 #if 0
7895 {
7901 }
7902 #endif
7903 #endif
7904 #endif
7905 }
7909 {
7910 ffesymbol cs;
7911 ffeglobal cg;
7912 tree ct;
7914 tree type;
7918 {
7921 }
7929 else
7936 else
7937 {
7938 ffetargetOffset offset;
7939 ffestorag cst;
7950 /* (t_type *) (((char *) &ct) + offset) */
7955 ct));
7957 t,
7960 t);
7964 }
7965 }
7977 /* Fall through. */
7981 }
7986 {
8000 {
8003 }
8008 else
8013 t);
8035 else
8036 t = build_pointer_type
8041 t);
8054 decls. */
8058 /* Fall through. */
8062 }
8067 {
8081 {
8084 }
8088 ffecom_tree_subr_type);
8109 ffecom_tree_ptr_to_subr_type);
8117 decls. */
8121 /* Fall through. */
8125 }
8130 {
8149 /* Fall through. */
8153 }
8158 {
8169 ffecom_tree_blockdata_type);
8192 /* Fall through. */
8196 }
8201 {
8221 /* Fall through. */
8225 }
8230 {
8249 /* Fall through. */
8253 }
8258 {
8278 /* Fall through. */
8282 }
8287 /* Fall through. */
8291 }
8301 }
8303 /* Transform into ASSIGNable symbol.
8305 Symbol has already been transformed, but for whatever reason, the
8306 resulting decl_tree has been deemed not usable for an ASSIGN target.
8307 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8308 another local symbol of type void * and stuff that in the assign_tree
8309 argument. The F77/F90 standards allow this implementation. */
8311 static ffesymbol
8313 {
8319 {
8322 }
8323 else
8324 {
8329 }
8339 {
8341 /* Unlike for regular vars, SAVE status is easy to determine for
8342 ASSIGNed vars, since there's no initialization, there's no
8343 effective storage association (so "SAVE J" does not apply to
8344 K even given "EQUIVALENCE (J,K)"), there's no size issue
8345 to worry about, etc. */
8350 else
8359 /* Note that twinning a DUMMY means the caller won't see
8360 the ASSIGNed value. But both F77 and F90 allow implementations
8361 to do this, i.e. disallow Fortran code that would try and
8362 take advantage of actually putting a label into a variable
8363 via a dummy argument (or any other storage association, for
8364 that matter). */
8371 }
8382 }
8384 /* Implement COMMON area in back end.
8386 Because COMMON-based variables can be referenced in the dimension
8387 expressions of dummy (adjustable) arrays, and because dummies
8388 (in the gcc back end) need to be put in the outer binding level
8389 of a function (which has two binding levels, the outer holding
8390 the dummies and the inner holding the other vars), special care
8391 must be taken to handle COMMON areas.
8393 The current strategy is basically to always tell the back end about
8394 the COMMON area as a top-level external reference to just a block
8395 of storage of the master type of that area (e.g. integer, real,
8396 character, whatever -- not a structure). As a distinct action,
8397 if initial values are provided, tell the back end about the area
8398 as a top-level non-external (initialized) area and remember not to
8399 allow further initialization or expansion of the area. Meanwhile,
8400 if no initialization happens at all, tell the back end about
8401 the largest size we've seen declared so the space does get reserved.
8402 (This function doesn't handle all that stuff, but it does some
8403 of the important things.)
8405 Meanwhile, for COMMON variables themselves, just keep creating
8406 references like *((float *) (&common_area + offset)) each time
8407 we reference the variable. In other words, don't make a VAR_DECL
8408 or any kind of component reference (like we used to do before 0.4),
8409 though we might do that as well just for debugging purposes (and
8410 stuff the rtl with the appropriate offset expression). */
8412 static void
8414 {
8417 tree cbt;
8418 tree cbtype;
8419 tree init;
8420 tree high;
8429 /* First update the size of the area in global terms. */
8438 /* If we already have declared this common block for a previous program
8439 unit, and either we already initialized it or we don't have new
8440 initialization for it, just return what we have without changing it. */
8443 && (!is_init
8445 {
8448 }
8450 /* Process inits. */
8453 {
8455 {
8456 ffebld sexp;
8458 /* Set the padding for the expression, so ffecom_expr
8459 knows to insert that many zeros. */
8461 {
8477 }
8485 }
8486 }
8487 else
8489 }
8490 else
8493 /* cbtype must be permanently allocated! */
8495 /* Allocate the MAX of the areas so far, seen filewide. */
8503 integer_zero_node,
8504 high));
8505 else
8509 {
8510 cbt
8513 cbtype);
8516 }
8517 else
8518 {
8521 }
8531 /* Make sure that any type can live in COMMON and be referenced
8532 without getting a bus error. We could pick the most restrictive
8533 alignment of all entities actually placed in the COMMON, but
8534 this seems easy enough. */
8548 {
8554 }
8561 }
8563 /* Make master area for local EQUIVALENCE. */
8565 static void
8567 {
8568 tree eqt;
8569 tree eqtype;
8570 tree init;
8571 tree high;
8581 /* Process inits. */
8584 {
8586 {
8587 ffebld sexp;
8589 /* Set the padding for the expression, so ffecom_expr
8590 knows to insert that many zeros. */
8592 {
8608 }
8613 }
8614 else
8616 }
8619 else
8625 eqst);
8633 ffecom_integer_zero_node,
8634 high));
8638 ffesymbol_text
8640 eqtype);
8643 || ffecom_member_namelisted_
8644 #ifdef FFECOM_sizeMAXSTACKITEM
8646 #endif
8651 else
8658 else
8663 /* Make sure that any type can live in EQUIVALENCE and be referenced
8664 without getting a bus error. We could pick the most restrictive
8665 alignment of all entities actually placed in the EQUIVALENCE, but
8666 this seems easy enough. */
8680 {
8685 }
8691 eqst);
8692 }
8694 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8696 static tree
8698 {
8699 tree nmlt;
8701 tree nmlinits;
8702 tree nameinit;
8703 tree varsinit;
8704 tree nvarsinit;
8705 tree field;
8706 tree high;
8712 mynumber++),
8713 nmltype);
8719 /* Process inits. */
8729 = build_type_variant
8730 (build_array_type
8733 ffecom_f2c_ftnlen_one_node,
8734 high)),
8739 nameinit);
8743 varsinit);
8747 {
8748 ffebld b;
8752 }
8760 varsinit);
8773 }
8775 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8776 analyzed on the assumption it is calculating a pointer to be
8777 indirected through. It must return the proper decl and offset,
8778 taking into account different units of measurements for offsets. */
8780 static void
8782 tree t)
8783 {
8785 {
8799 {
8800 /* An offset into COMMON. */
8803 /* Convert offset (presumably in bytes) into canonical units
8804 (presumably bits). */
8809 }
8810 /* Not a COMMON reference, so an unrecognized pattern. */
8821 {
8822 /* A reference to COMMON. */
8826 }
8827 /* Fall through. */
8829 /* Not a COMMON reference, so an unrecognized pattern. */
8832 }
8833 }
8835 /* Given a tree that is possibly intended for use as an lvalue, return
8836 information representing a canonical view of that tree as a decl, an
8837 offset into that decl, and a size for the lvalue.
8839 If there's no applicable decl, NULL_TREE is returned for the decl,
8840 and the other fields are left undefined.
8842 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8843 is returned for the decl, and the other fields are left undefined.
8845 Otherwise, the decl returned currently is either a VAR_DECL or a
8846 PARM_DECL.
8848 The offset returned is always valid, but of course not necessarily
8849 a constant, and not necessarily converted into the appropriate
8850 type, leaving that up to the caller (so as to avoid that overhead
8851 if the decls being looked at are different anyway).
8853 If the size cannot be determined (e.g. an adjustable array),
8854 an ERROR_MARK node is returned for the size. Otherwise, the
8855 size returned is valid, not necessarily a constant, and not
8856 necessarily converted into the appropriate type as with the
8857 offset.
8859 Note that the offset and size expressions are expressed in the
8860 base storage units (usually bits) rather than in the units of
8861 the type of the decl, because two decls with different types
8862 might overlap but with apparently non-overlapping array offsets,
8863 whereas converting the array offsets to consistant offsets will
8864 reveal the overlap. */
8866 static void
8869 {
8870 /* The default path is to report a nonexistant decl. */
8877 {
8947 {
8950 tree init_offset;
8954 {
8957 }
8960 array);
8965 /* Calculate ((element - base) * NBBY) + init_offset. */
8967 element,
8979 }
8983 /* Most of this code is to handle references to COMMON. And so
8984 far that is useful only for calling library functions, since
8985 external (user) functions might reference common areas. But
8986 even calling an external function, it's worthwhile to decode
8987 COMMON references because if not storing into COMMON, we don't
8988 want COMMON-based arguments to gratuitously force use of a
8989 temporary. */
9015 }
9016 }
9018 /* Do divide operation appropriate to type of operands. */
9020 static tree
9023 tree hook)
9024 {
9030 {
9033 left,
9034 right);
9039 left,
9040 right);
9041 {
9042 ffecomGfrt ix;
9047 else
9052 left);
9056 right);
9063 tree_type,
9064 left,
9067 }
9071 {
9072 ffecomGfrt ix;
9077 else
9082 left);
9086 right);
9093 tree_type,
9094 left,
9097 }
9102 left,
9103 right);
9104 }
9105 }
9107 /* Build type info for non-dummy variable. */
9109 static tree
9111 ffeinfoKindtype kt)
9112 {
9113 tree type;
9114 ffebld dl;
9115 ffebld dim;
9116 tree lowt;
9117 tree hight;
9121 {
9125 type
9126 = build_array_type
9129 ffecom_f2c_ftnlen_one_node,
9130 hight));
9132 }
9135 {
9144 else
9160 }
9163 }
9165 /* Build Namelist type. */
9168 static tree
9170 {
9172 {
9182 string_type_node);
9185 integer_type_node);
9191 }
9194 }
9196 /* Build Vardesc type. */
9199 static tree
9201 {
9203 {
9208 string_type_node);
9210 string_type_node);
9212 ffecom_f2c_ptr_to_ftnlen_type_node);
9214 integer_type_node);
9220 }
9223 }
9225 static tree
9227 {
9228 ffesymbol s;
9234 {
9237 tree var;
9238 tree nameinit;
9239 tree dimsinit;
9240 tree addrinit;
9241 tree typeinit;
9242 tree field;
9243 tree varinits;
9248 mynumber++),
9249 vardesctype);
9255 /* Process inits. */
9261 = build_type_variant
9262 (build_array_type
9265 integer_one_node,
9272 nameinit);
9279 {
9286 }
9287 else
9291 nameinit);
9293 addrinit);
9308 }
9311 }
9313 static tree
9315 {
9316 ffebld b;
9317 tree list;
9319 tree var;
9326 {
9327 tree t;
9333 else
9334 {
9337 }
9338 }
9342 integer_one_node,
9356 }
9358 static tree
9360 {
9363 integer_zero_node);
9365 {
9366 ffebld b;
9367 ffebld e;
9368 tree list;
9369 tree backlist;
9371 tree var;
9372 tree numdim;
9373 tree numelem;
9388 {
9389 tree t;
9390 tree low;
9391 tree back;
9395 else
9396 {
9402 else
9403 {
9406 }
9407 }
9411 else
9418 }
9421 {
9424 else
9428 ffecom_f2c_ftnlen_type_node,
9430 baseoff));
9431 }
9433 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9446 integer_zero_node,
9447 build_int_2
9464 }
9465 }
9467 /* Essentially does a "fold (build1 (code, type, node))" while checking
9468 for certain housekeeping things.
9470 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9471 ffecom_1_fn instead. */
9473 tree
9475 {
9476 tree item;
9483 {
9486 }
9489 {
9490 tree realtype;
9503 {
9506 }
9509 item =
9513 node)),
9516 node)));
9522 }
9531 }
9533 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9534 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9535 does not set TREE_ADDRESSABLE (because calling an inline
9536 function does not mean the function needs to be separately
9537 compiled). */
9539 tree
9541 {
9542 tree item;
9543 tree type;
9558 }
9560 /* Essentially does a "fold (build (code, type, node1, node2))" while
9561 checking for certain housekeeping things. */
9563 tree
9565 tree node2)
9566 {
9567 tree item;
9575 {
9590 {
9593 }
9597 item =
9601 node1),
9603 node2)),
9606 node1),
9608 node2)));
9613 {
9616 }
9620 item =
9624 node1),
9626 node2)),
9629 node1),
9631 node2)));
9636 {
9639 }
9644 node1));
9646 node1));
9648 node2));
9650 node2));
9651 item =
9655 a,
9656 c),
9658 b,
9659 d)),
9662 a,
9663 d),
9665 c,
9666 b)));
9672 {
9675 }
9681 item =
9685 node1),
9687 node2)),
9690 node1),
9692 node2)));
9698 {
9701 }
9707 item =
9711 node1),
9713 node2)),
9716 node1),
9718 node2)));
9724 }
9729 }
9731 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9733 ffesymbol s; // the ENTRY point itself
9734 if (ffecom_2pass_advise_entrypoint(s))
9735 // the ENTRY point has been accepted
9737 Does whatever compiler needs to do when it learns about the entrypoint,
9738 like determine the return type of the master function, count the
9739 number of entrypoints, etc. Returns FALSE if the return type is
9740 not compatible with the return type(s) of other entrypoint(s).
9742 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9743 later (after _finish_progunit) be called with the same entrypoint(s)
9744 as passed to this fn for which TRUE was returned.
9746 03-Jan-92 JCB 2.0
9747 Return FALSE if the return type conflicts with previous entrypoints. */
9749 bool
9751 {
9765 arglist's dummies. */
9775 {
9782 else
9785 }
9786 }
9788 /* If necessary, scan entry arglist for alternate returns. Do this scan
9789 apparently redundantly (it's done below to UNIONize the arglists) so
9790 that we don't complain about RETURN 1 if an offending ENTRY is the only
9791 one with an alternate return. */
9794 {
9798 {
9801 {
9804 }
9805 }
9806 }
9808 /* Now check type compatibility. */
9811 {
9817 ok
9828 {
9831 }
9834 {
9837 }
9839 }
9842 {
9847 }
9849 /* Entrypoint type compatible with previous types. */
9853 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9858 {
9867 appending of arg. */
9870 }
9874 /* Append this arg to the master list. */
9879 else
9881 }
9884 }
9886 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9888 ffesymbol s; // the ENTRY point itself
9889 ffecom_2pass_do_entrypoint(s);
9891 Does whatever compiler needs to do to make the entrypoint actually
9892 happen. Must be called for each entrypoint after
9893 ffecom_finish_progunit is called. */
9895 void
9897 {
9906 }
9907 else
9913 }
9915 /* Essentially does a "fold (build (code, type, node1, node2))" while
9916 checking for certain housekeeping things. Always sets
9917 TREE_SIDE_EFFECTS. */
9919 tree
9921 tree node2)
9922 {
9923 tree item;
9933 }
9935 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9936 checking for certain housekeeping things. */
9938 tree
9941 {
9942 tree item;
9955 }
9957 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9958 checking for certain housekeeping things. Always sets
9959 TREE_SIDE_EFFECTS. */
9961 tree
9964 {
9965 tree item;
9976 }
9978 /* ffecom_arg_expr -- Transform argument expr into gcc tree
9980 See use by ffecom_list_expr.
9982 If expression is NULL, returns an integer zero tree. If it is not
9983 a CHARACTER expression, returns whatever ffecom_expr
9984 returns and sets the length return value to NULL_TREE. Otherwise
9985 generates code to evaluate the character expression, returns the proper
9986 pointer to the result, but does NOT set the length return value to a tree
9987 that specifies the length of the result. (In other words, the length
9988 variable is always set to NULL_TREE, because a length is never passed.)
9990 21-Dec-91 JCB 1.1
9991 Don't set returned length, since nobody needs it (yet; someday if
9992 we allow CHARACTER*(*) dummies to statement functions, we'll need
9993 it). */
9995 tree
9997 {
9998 tree ign;
10009 }
10011 /* Transform expression into constant argument-pointer-to-expression tree.
10013 If the expression can be transformed into a argument-pointer-to-expression
10014 tree that is constant, that is done, and the tree returned. Else
10015 NULL_TREE is returned.
10017 That way, a caller can attempt to provide compile-time initialization
10018 of a variable and, if that fails, *then* choose to start a new block
10019 and resort to using temporaries, as appropriate. */
10021 tree
10023 {
10028 {
10032 }
10039 {
10040 tree t;
10046 }
10054 }
10056 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10058 See use by ffecom_list_ptr_to_expr.
10060 If expression is NULL, returns an integer zero tree. If it is not
10061 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10062 returns and sets the length return value to NULL_TREE. Otherwise
10063 generates code to evaluate the character expression, returns the proper
10064 pointer to the result, AND sets the length return value to a tree that
10065 specifies the length of the result.
10067 If the length argument is NULL, this is a slightly special
10068 case of building a FORMAT expression, that is, an expression that
10069 will be used at run time without regard to length. For the current
10070 implementation, which uses the libf2c library, this means it is nice
10071 to append a null byte to the end of the expression, where feasible,
10072 to make sure any diagnostic about the FORMAT string terminates at
10073 some useful point.
10075 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10076 length argument. This might even be seen as a feature, if a null
10077 byte can always be appended. */
10079 tree
10081 {
10082 tree item;
10083 tree ign_length;
10084 ffecomConcatList_ catlist;
10093 {
10097 {
10098 tree temp_exp;
10099 tree temp_length;
10106 temp_exp);
10107 }
10113 {
10116 }
10122 {
10123 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10125 #endif
10134 }
10139 }
10141 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10145 ffetargetHollerith h;
10150 *length
10153 }
10154 #endif
10167 {
10170 {
10173 }
10181 else
10190 }
10192 {
10195 tree lengths;
10196 tree items;
10197 tree length_array;
10198 tree item_array;
10199 tree citem;
10200 tree clength;
10201 tree temporary;
10202 tree num;
10203 tree known_length;
10204 ffetargetCharacterSize sz;
10207 /* ~~Kludge! */
10210 {
10211 tree hook;
10220 }
10225 {
10230 else
10235 {
10239 }
10241 items
10246 item_array,
10248 citem),
10249 items);
10252 known_length
10254 known_length,
10255 clength);
10256 lengths
10261 length_array,
10263 clength),
10264 lengths);
10265 }
10269 temporary);
10276 items));
10281 lengths));
10283 = build_tree_list
10296 item,
10297 temporary);
10301 }
10306 }
10308 /* Generate call to run-time function.
10310 The first arg is the GNU Fortran Run-Time function index, the second
10311 arg is the list of arguments to pass to it. Returned is the expression
10312 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10313 result (which may be void). */
10315 tree
10317 {
10323 }
10325 /* Transform constant-union to tree. */
10327 tree
10330 {
10331 tree item;
10334 {
10336 {
10340 {
10341 #if FFETARGET_okINTEGER1
10345 #endif
10347 #if FFETARGET_okINTEGER2
10351 #endif
10353 #if FFETARGET_okINTEGER3
10357 #endif
10359 #if FFETARGET_okINTEGER4
10363 #endif
10367 /* Fall through. */
10370 }
10373 }
10377 {
10381 {
10382 #if FFETARGET_okLOGICAL1
10386 #endif
10388 #if FFETARGET_okLOGICAL2
10392 #endif
10394 #if FFETARGET_okLOGICAL3
10398 #endif
10400 #if FFETARGET_okLOGICAL4
10404 #endif
10408 /* Fall through. */
10411 }
10414 }
10418 {
10419 REAL_VALUE_TYPE val;
10422 {
10423 #if FFETARGET_okREAL1
10427 #endif
10429 #if FFETARGET_okREAL2
10433 #endif
10435 #if FFETARGET_okREAL3
10439 #endif
10441 #if FFETARGET_okREAL4
10445 #endif
10449 /* Fall through. */
10452 }
10454 }
10458 {
10459 REAL_VALUE_TYPE real;
10460 REAL_VALUE_TYPE imag;
10464 {
10465 #if FFETARGET_okCOMPLEX1
10470 #endif
10472 #if FFETARGET_okCOMPLEX2
10477 #endif
10479 #if FFETARGET_okCOMPLEX3
10484 #endif
10486 #if FFETARGET_okCOMPLEX4
10491 #endif
10495 /* Fall through. */
10498 }
10502 }
10507 ffetargetCharacter1 val;
10510 {
10511 #if FFETARGET_okCHARACTER1
10515 #endif
10519 /* Fall through. */
10522 }
10527 build_range_type
10529 integer_one_node,
10530 build_int_2
10531 (ffetarget_length_character1
10534 }
10538 {
10539 ffetargetHollerith h;
10543 /* If not at least as wide as default INTEGER, widen it. */
10546 else
10547 {
10552 FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10555 str);
10556 }
10559 build_range_type
10561 integer_one_node,
10562 build_int_2
10565 }
10569 {
10570 ffetargetInteger1 ival;
10571 ffetargetTypeless tless;
10572 ffebad error;
10579 }
10584 /* Fall through. */
10587 }
10592 }
10594 /* Transform expression into constant tree.
10596 If the expression can be transformed into a tree that is constant,
10597 that is done, and the tree returned. Else NULL_TREE is returned.
10599 That way, a caller can attempt to provide compile-time initialization
10600 of a variable and, if that fails, *then* choose to start a new block
10601 and resort to using temporaries, as appropriate. */
10603 tree
10605 {
10614 #if NEWCOMMON
10615 /* ~~Enable once common/equivalence is handled properly? */
10617 #endif
10620 {
10621 tree t;
10626 }
10629 }
10631 /* Handy way to make a field in a struct/union. */
10633 tree
10636 {
10637 tree field;
10647 }
10649 void
10651 {
10653 }
10655 int
10657 {
10659 }
10661 /* End a compound statement (block). */
10663 tree
10665 {
10667 }
10669 /* ffecom_end_transition -- Perform end transition on all symbols
10671 ffecom_end_transition();
10673 Calls ffecom_sym_end_transition for each global and local symbol. */
10675 void
10677 {
10678 ffebld item;
10688 {
10690 }
10697 {
10698 ffebld callee;
10699 ffesymbol s;
10700 tree dt;
10701 tree t;
10702 tree var;
10709 {
10712 }
10718 number++),
10719 dt);
10731 }
10733 /* This handles any COMMON areas that weren't referenced but have, for
10734 example, important initial data. */
10742 }
10744 /* ffecom_exec_transition -- Perform exec transition on all symbols
10746 ffecom_exec_transition();
10748 Calls ffecom_sym_exec_transition for each global and local symbol.
10749 Make sure error updating not inhibited. */
10751 void
10753 {
10765 {
10767 }
10771 }
10773 /* Handle assignment statement.
10775 Convert dest and source using ffecom_expr, then join them
10776 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
10778 void
10780 {
10781 tree dest_tree;
10782 tree dest_length;
10783 tree source_tree;
10784 tree expr_tree;
10787 {
10789 tree assign_temp;
10791 /* This attempts to replicate the test below, but must not be
10792 true when the test below is false. (Always err on the side
10793 of creating unused temporaries, to avoid ICEs.) */
10798 {
10801 }
10802 else
10803 {
10806 }
10810 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10811 create a temporary through which the assignment is to take place,
10812 since MODIFY_EXPR doesn't handle partial overlap properly. */
10815 {
10817 ffecom_tree_type
10820 FFETARGET_charactersizeNONE,
10822 }
10823 else
10836 else
10837 {
10841 }
10848 {
10849 #ifdef MOVE_EXPR
10850 /* The back end understands a conceptual move (evaluate source;
10851 store into dest), so use that, in case it can determine
10852 that it is going to use, say, two registers as temporaries
10853 anyway. So don't use the temp (and someday avoid generating
10854 it, once this code starts triggering regularly). */
10856 dest_tree,
10857 source_tree);
10858 #else
10860 assign_temp,
10861 source_tree);
10864 dest_tree,
10865 assign_temp);
10866 #endif
10867 }
10868 else
10870 dest_tree,
10871 source_tree);
10875 }
10884 source);
10885 }
10887 /* ffecom_expr -- Transform expr into gcc tree
10889 tree t;
10890 ffebld expr; // FFE expression.
10891 tree = ffecom_expr(expr);
10893 Recursive descent on expr while making corresponding tree nodes and
10894 attaching type info and such. */
10896 tree
10898 {
10900 }
10902 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
10904 tree
10906 {
10908 }
10910 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
10912 tree
10914 {
10916 }
10918 /* Transform expr for use as into read/write tree and stabilize the
10919 reference. Not for use on CHARACTER expressions.
10921 Recursive descent on expr while making corresponding tree nodes and
10922 attaching type info and such. */
10924 tree
10926 {
10928 /* Different target types not yet supported. */
10932 }
10934 /* Transform expr for use as into write tree and stabilize the
10935 reference. Not for use on CHARACTER expressions.
10937 Recursive descent on expr while making corresponding tree nodes and
10938 attaching type info and such. */
10940 tree
10942 {
10944 /* Different target types not yet supported. */
10948 }
10950 /* Do global stuff. */
10952 void
10954 {
10959 }
10961 /* Public entry point for front end to access finish_decl. */
10963 void
10965 {
10968 }
10970 /* Finish a program unit. */
10972 void
10974 {
10981 }
10983 /* Wrapper for get_identifier. pattern is sprintf-like. */
10985 tree
10987 {
10988 tree decl;
11000 }
11002 ffeinfoBasictype
11004 {
11008 {
11046 }
11047 }
11049 ffeinfoKindtype
11051 {
11055 {
11093 }
11094 }
11096 void
11098 {
11099 tree endlink;
11102 tree t;
11103 tree field;
11104 ffetype type;
11105 ffetype base_type;
11106 tree double_ftype_double;
11107 tree float_ftype_float;
11108 tree ldouble_ftype_ldouble;
11109 tree ffecom_tree_ptr_to_fun_type_void;
11111 /* This block of code comes from the now-obsolete cktyps.c. It checks
11112 whether the compiler environment is buggy in known ways, some of which
11113 would, if not explicitly checked here, result in subtle bugs in g77. */
11116 {
11118 =
11127 {
11131 }
11135 {
11139 }
11143 {
11147 }
11148 }
11155 /* Make the binding_level structure for global names. */
11162 /* Define `int' and `char' first so that dbx will output them first. */
11164 integer_type_node));
11165 /* CHARACTER*1 is unsigned in ICHAR contexts. */
11168 char_type_node));
11170 long_integer_type_node));
11172 unsigned_type_node));
11174 long_unsigned_type_node));
11176 long_long_integer_type_node));
11178 long_long_unsigned_type_node));
11180 short_integer_type_node));
11182 short_unsigned_type_node));
11184 /* Set the sizetype before we make other types. This *should* be the
11185 first type we create. */
11187 set_sizetype
11189 ffecom_typesize_pointer_
11194 /* Define both `signed char' and `unsigned char'. */
11196 signed_char_type_node));
11199 unsigned_char_type_node));
11202 float_type_node));
11204 double_type_node));
11206 long_double_type_node));
11208 /* For now, override what build_common_tree_nodes has done. */
11212 complex_long_double_type_node
11216 complex_integer_type_node));
11218 complex_float_type_node));
11220 complex_double_type_node));
11222 complex_long_double_type_node));
11225 void_type_node));
11226 /* We are not going to have real types in C with less than byte alignment,
11227 so we might as well not have any types that claim to have it. */
11233 ffecom_tree_fun_type_void
11236 ffecom_tree_ptr_to_fun_type_void
11241 float_ftype_float
11245 double_ftype_double
11249 ldouble_ftype_ldouble
11252 endlink));
11256 {
11261 }
11263 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11264 to size FLOAT_TYPE_SIZE because they have to be the same size as
11265 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11266 Compiler options and other such stuff that change the ways these
11267 types are set should not affect this particular setup. */
11272 t));
11276 type);
11282 type);
11290 t));
11295 t));
11298 type);
11304 type);
11311 t));
11316 t));
11319 type);
11325 type);
11332 t));
11337 t));
11340 type);
11346 type);
11353 t));
11355 #if 0
11361 {
11363 LONG_TYPE_SIZE);
11364 }
11365 #endif
11370 t));
11374 type);
11380 type);
11387 t));
11390 type);
11396 type);
11403 t));
11406 type);
11412 type);
11419 t));
11422 type);
11428 type);
11436 t));
11441 type);
11447 type);
11457 t));
11461 type);
11467 type);
11474 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11476 t));
11480 type);
11486 type);
11493 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11495 t));
11498 type);
11504 type);
11506 type);
11511 /* Make function and ptr-to-function types for non-CHARACTER types. */
11515 {
11517 {
11519 {
11520 /* Figure out the smallest INTEGER type that can hold
11521 a pointer on this machine. */
11524 {
11529 }
11530 }
11533 /* For f2c compatibility, REAL functions are really
11534 implemented as DOUBLE PRECISION. */
11537 t = ffecom_tree_type
11541 NULL_TREE);
11543 }
11544 }
11546 /* Set up pointer types. */
11553 FFEINFO_kindtypeINTEGERDEFAULT),
11556 ffecom_pointer_kind_));
11560 else
11565 ffecom_integer_type_node
11568 integer_zero_node);
11570 integer_one_node);
11572 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11573 Turns out that by TYLONG, runtime/libI77/lio.h really means
11574 "whatever size an ftnint is". For consistency and sanity,
11575 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11576 all are INTEGER, which we also make out of whatever back-end
11577 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11578 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11579 accommodate machines like the Alpha. Note that this suggests
11580 f2c and libf2c are missing a distinction perhaps needed on
11581 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11584 FFETARGET_f2cTYLONG);
11586 FFETARGET_f2cTYSHORT);
11588 FFETARGET_f2cTYINT1);
11590 FFETARGET_f2cTYQUAD);
11592 FFETARGET_f2cTYLOGICAL);
11594 FFETARGET_f2cTYLOGICAL2);
11596 FFETARGET_f2cTYLOGICAL1);
11597 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11599 FFETARGET_f2cTYQUAD);
11601 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11602 loop. CHARACTER items are built as arrays of unsigned char. */
11609 FFEINFO_kindtypeCHARACTER1,
11610 type);
11629 /* Make multi-return-value type and fields. */
11637 {
11654 }
11659 /* Subroutines usually return integer because they might have alternate
11660 returns. */
11662 ffecom_tree_subr_type
11664 ffecom_tree_ptr_to_subr_type
11666 ffecom_tree_blockdata_type
11691 FFECOM_f2cINTEGER,
11694 FFECOM_f2cADDRESS,
11697 FFECOM_f2cREAL,
11700 FFECOM_f2cDOUBLEREAL,
11703 FFECOM_f2cCOMPLEX,
11706 FFECOM_f2cDOUBLECOMPLEX,
11709 FFECOM_f2cLONGINT,
11712 FFECOM_f2cLOGICAL,
11715 FFECOM_f2cFLAG,
11718 FFECOM_f2cFTNLEN,
11721 FFECOM_f2cFTNINT,
11724 ffecom_f2c_ftnlen_zero_node
11727 ffecom_f2c_ftnlen_one_node
11733 ffecom_f2c_ptr_to_ftnlen_type_node
11736 ffecom_f2c_ptr_to_ftnint_type_node
11739 ffecom_f2c_ptr_to_integer_type_node
11742 ffecom_f2c_ptr_to_real_type_node
11747 {
11748 REAL_VALUE_TYPE point_5;
11753 }
11755 /* Do "extern int xargc;". */
11759 integer_type_node);
11769 {
11776 }
11777 #endif
11782 /* I/O will probably crash. */
11786 #endif
11791 /* ASSIGN 10 TO I will crash. */
11796 #endif
11797 }
11799 /* ffecom_init_2 -- Initialize
11801 ffecom_init_2(); */
11803 void
11805 {
11816 }
11818 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11820 tree t;
11821 ffebld expr; // FFE opITEM list.
11822 tree = ffecom_list_expr(expr);
11824 List of actual args is transformed into corresponding gcc backend list. */
11826 tree
11828 {
11829 tree list;
11833 tree length;
11836 {
11846 {
11849 }
11850 }
11855 }
11857 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11859 tree t;
11860 ffebld expr; // FFE opITEM list.
11861 tree = ffecom_list_ptr_to_expr(expr);
11863 List of actual args is transformed into corresponding gcc backend list for
11864 use in calling an external procedure (vs. a statement function). */
11866 tree
11868 {
11869 tree list;
11873 tree length;
11876 {
11886 {
11889 }
11890 }
11895 }
11897 /* Obtain gcc's LABEL_DECL tree for label. */
11899 tree
11901 {
11902 tree glabel;
11905 {
11909 {
11915 void_type_node);
11922 ffecom_get_invented_identifier
11926 NULL_TREE),
11947 }
11949 }
11950 else
11951 {
11953 }
11956 }
11958 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
11959 a single source specification (as in the fourth argument of MVBITS).
11960 If the type is NULL_TREE, the type of lhs is used to make the type of
11961 the MODIFY_EXPR. */
11963 tree
11965 tree rhs)
11966 {
11977 }
11979 /* Register source file name. */
11981 void
11983 {
11985 }
11987 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
11989 ffestorag st;
11990 ffecom_notify_init_storage(st);
11992 Gets called when all possible units in an aggregate storage area (a LOCAL
11993 with equivalences or a COMMON) have been initialized. The initialization
11994 info either is in ffestorag_init or, if that is NULL,
11995 ffestorag_accretion:
11997 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
11998 even for an array if the array is one element in length!
12000 ffestorag_accretion will contain an opACCTER. It is much like an
12001 opARRTER except it has an ffebit object in it instead of just a size.
12002 The back end can use the info in the ffebit object, if it wants, to
12003 reduce the amount of actual initialization, but in any case it should
12004 kill the ffebit object when done. Also, set accretion to NULL but
12005 init to a non-NULL value.
12007 After performing initialization, DO NOT set init to NULL, because that'll
12008 tell the front end it is ok for more initialization to happen. Instead,
12009 set init to an opANY expression or some such thing that you can use to
12010 tell that you've already initialized the object.
12012 27-Oct-91 JCB 1.1
12013 Support two-pass FFE. */
12015 void
12017 {
12021 {
12027 }
12028 }
12030 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12032 ffesymbol s;
12033 ffecom_notify_init_symbol(s);
12035 Gets called when all possible units in a symbol (not placed in COMMON
12036 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12037 have been initialized. The initialization info either is in
12038 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12040 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12041 even for an array if the array is one element in length!
12043 ffesymbol_accretion will contain an opACCTER. It is much like an
12044 opARRTER except it has an ffebit object in it instead of just a size.
12045 The back end can use the info in the ffebit object, if it wants, to
12046 reduce the amount of actual initialization, but in any case it should
12047 kill the ffebit object when done. Also, set accretion to NULL but
12048 init to a non-NULL value.
12050 After performing initialization, DO NOT set init to NULL, because that'll
12051 tell the front end it is ok for more initialization to happen. Instead,
12052 set init to an opANY expression or some such thing that you can use to
12053 tell that you've already initialized the object.
12055 27-Oct-91 JCB 1.1
12056 Support two-pass FFE. */
12058 void
12060 {
12065 possibilities checked. */
12069 {
12073 }
12074 }
12076 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12078 ffesymbol s;
12079 ffecom_notify_primary_entry(s);
12081 Gets called when implicit or explicit PROGRAM statement seen or when
12082 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12083 global symbol that serves as the entry point. */
12085 void
12087 {
12094 else
12098 {
12101 else
12103 }
12106 {
12107 ffebld list;
12108 ffebld arg;
12113 {
12116 {
12119 }
12120 }
12121 }
12122 }
12126 {
12128 }
12130 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12132 tree t;
12133 ffebld expr; // FFE expression.
12134 tree = ffecom_ptr_to_expr(expr);
12136 Like ffecom_expr, but sticks address-of in front of most things. */
12138 tree
12140 {
12141 tree item;
12142 ffeinfoBasictype bt;
12143 ffeinfoKindtype kt;
12144 ffesymbol s;
12149 {
12153 {
12154 ffecomGfrt ix;
12159 {
12162 }
12163 }
12164 else
12165 {
12168 {
12171 }
12172 }
12178 item);
12195 item);
12209 /* The back end currently optimizes a bit too zealously for us, in that
12210 we fail JCB001 if the following block of code is omitted. It checks
12211 to see if the transformed expression is a symbol or array reference,
12212 and encloses it in a SAVE_EXPR if that is the case. */
12221 #ifdef OFFSET_REF
12223 #endif
12227 {
12229 }
12232 item);
12234 }
12238 }
12240 /* Obtain a temp var with given data type.
12242 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12243 or >= 0 for a CHARACTER type.
12245 elements is -1 for a scalar or > 0 for an array of type. */
12247 tree
12250 {
12251 tree t;
12262 ffecom_f2c_ftnlen_one_node,
12267 integer_zero_node,
12272 commentary,
12273 mynumber++),
12274 type);
12280 }
12282 /* Prepare argument pointer to expression.
12284 Like ffecom_prepare_expr, except for expressions to be evaluated
12285 via ffecom_arg_ptr_to_expr. */
12287 void
12289 {
12290 /* ~~For now, it seems to be the same thing. */
12293 }
12295 /* End of preparations. */
12297 bool
12299 {
12306 }
12308 /* Prepare expression.
12310 This is called before any code is generated for the current block.
12311 It scans the expression, declares any temporaries that might be needed
12312 during evaluation of the expression, and stores those temporaries in
12313 the appropriate "hook" fields of the expression. `dest', if not NULL,
12314 specifies the destination that ffecom_expr_ will see, in case that
12315 helps avoid generating unused temporaries.
12317 ~~Improve to avoid allocating unused temporaries by taking `dest'
12318 into account vis-a-vis aliasing requirements of complex/character
12319 functions. */
12321 void
12323 {
12324 ffeinfoBasictype bt;
12325 ffeinfoKindtype kt;
12326 ffetargetCharacterSize sz;
12338 /* Generate whatever temporaries are needed to represent the result
12339 of the expression. */
12342 {
12345 }
12348 {
12350 /* Don't make temps for SYMTER, CONTER, etc. */
12355 {
12358 {
12359 ffesymbol s;
12371 }
12373 {
12374 /* Requires special treatment. There's no POW_CC function
12375 in libg2c, so POW_ZZ is used, which means we always
12376 need a double-complex temp, not a single-complex. */
12378 }
12380 /* The other ops don't need temps for complex operands. */
12383 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12384 REAL(C). See 19990325-0.f, routine `check', for cases. */
12386 ffecom_tree_type
12388 FFETARGET_charactersizeNONE,
12397 /* ~~Kludge alert! This should someday be fixed. */
12405 }
12409 {
12410 /* This gets special handling, because only one set of temps
12411 is needed for a tree of these -- the tree is treated as
12412 a flattened list of concatenations when generating code. */
12414 ffecomConcatList_ catlist;
12423 {
12424 ltmp
12426 ffecom_f2c_ftnlen_type_node,
12428 itmp
12430 ffecom_f2c_address_type_node,
12432 result
12434 char_type_node,
12442 }
12446 i));
12451 {
12454 }
12455 }
12465 }
12468 {
12471 }
12473 /* Prepare subexpressions for this expr. */
12476 {
12491 {
12492 ffebld item;
12499 }
12503 /* Need to handle character conversion specially. */
12505 {
12517 }
12518 }
12521 }
12523 /* Prepare expression for reading and writing.
12525 Like ffecom_prepare_expr, except for expressions to be evaluated
12526 via ffecom_expr_rw. */
12528 void
12530 {
12531 /* This is all we support for now. */
12534 /* ~~For now, it seems to be the same thing. */
12537 }
12539 /* Prepare expression for writing.
12541 Like ffecom_prepare_expr, except for expressions to be evaluated
12542 via ffecom_expr_w. */
12544 void
12546 {
12547 /* This is all we support for now. */
12550 /* ~~For now, it seems to be the same thing. */
12553 }
12555 /* Prepare expression for returning.
12557 Like ffecom_prepare_expr, except for expressions to be evaluated
12558 via ffecom_return_expr. */
12560 void
12562 {
12566 && ffecom_is_altreturning_
12569 }
12571 /* Prepare pointer to expression.
12573 Like ffecom_prepare_expr, except for expressions to be evaluated
12574 via ffecom_ptr_to_expr. */
12576 void
12578 {
12579 /* ~~For now, it seems to be the same thing. */
12582 }
12584 /* Transform expression into constant pointer-to-expression tree.
12586 If the expression can be transformed into a pointer-to-expression tree
12587 that is constant, that is done, and the tree returned. Else NULL_TREE
12588 is returned.
12590 That way, a caller can attempt to provide compile-time initialization
12591 of a variable and, if that fails, *then* choose to start a new block
12592 and resort to using temporaries, as appropriate. */
12594 tree
12596 {
12608 {
12609 tree t;
12614 }
12617 }
12619 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12621 tree rtn; // NULL_TREE means use expand_null_return()
12622 ffebld expr; // NULL if no alt return expr to RETURN stmt
12623 rtn = ffecom_return_expr(expr);
12625 Based on the program unit type and other info (like return function
12626 type, return master function type when alternate ENTRY points,
12627 whether subroutine has any alternate RETURN points, etc), returns the
12628 appropriate expression to be returned to the caller, or NULL_TREE
12629 meaning no return value or the caller expects it to be returned somewhere
12630 else (which is handled by other parts of this module). */
12632 tree
12634 {
12635 tree rtn;
12638 {
12649 else
12662 into (implicit) dummy. */
12665 }
12667 #if 0
12668 /* Spurious error if RETURN happens before first reference! So elide
12669 this code. In particular, for debugging registry, rtn should always
12670 be non-null after all, but TREE_USED won't be set until we encounter
12671 a reference in the code. Perfectly okay (but weird) code that,
12672 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12673 this diagnostic for no reason. Have people use -O -Wuninitialized
12674 and leave it to the back end to find obviously weird cases. */
12676 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12677 situation; if the return value has never been referenced, it won't
12678 have a tree under 2pass mode. */
12681 {
12688 }
12689 #endif
12697 }
12700 }
12702 /* Do save_expr only if tree is not error_mark_node. */
12704 tree
12706 {
12708 }
12710 /* Start a compound statement (block). */
12712 void
12714 {
12716 }
12718 /* Public entry point for front end to access start_decl. */
12720 tree
12722 {
12725 }
12727 /* ffecom_sym_commit -- Symbol's state being committed to reality
12729 ffesymbol s;
12730 ffecom_sym_commit(s);
12732 Does whatever the backend needs when a symbol is committed after having
12733 been backtrackable for a period of time. */
12735 void
12737 {
12739 }
12741 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12743 ffecom_sym_end_transition();
12745 Does backend-specific stuff and also calls ffest_sym_end_transition
12746 to do the necessary FFE stuff.
12748 Backtracking is never enabled when this fn is called, so don't worry
12749 about it. */
12751 ffesymbol
12753 {
12754 ffestorag st;
12762 {
12763 ffecom_list_blockdata_
12765 FFEINTRIN_specNONE,
12766 FFEINTRIN_impNONE),
12767 ffecom_list_blockdata_);
12768 }
12770 /* This is where we finally notice that a symbol has partial initialization
12771 and finalize it. */
12774 {
12777 }
12781 {
12784 }
12789 {
12790 ffecom_list_common_
12792 FFEINTRIN_specNONE,
12793 FFEINTRIN_impNONE),
12794 ffecom_list_common_);
12795 }
12798 }
12800 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12802 ffecom_sym_exec_transition();
12804 Does backend-specific stuff and also calls ffest_sym_exec_transition
12805 to do the necessary FFE stuff.
12807 See the long-winded description in ffecom_sym_learned for info
12808 on handling the situation where backtracking is inhibited. */
12810 ffesymbol
12812 {
12816 }
12818 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12820 ffesymbol s;
12821 s = ffecom_sym_learned(s);
12823 Called when a new symbol is seen after the exec transition or when more
12824 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
12825 it arrives here is that all its latest info is updated already, so its
12826 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12827 field filled in if its gone through here or exec_transition first, and
12828 so on.
12830 The backend probably wants to check ffesymbol_retractable() to see if
12831 backtracking is in effect. If so, the FFE's changes to the symbol may
12832 be retracted (undone) or committed (ratified), at which time the
12833 appropriate ffecom_sym_retract or _commit function will be called
12834 for that function.
12836 If the backend has its own backtracking mechanism, great, use it so that
12837 committal is a simple operation. Though it doesn't make much difference,
12838 I suppose: the reason for tentative symbol evolution in the FFE is to
12839 enable error detection in weird incorrect statements early and to disable
12840 incorrect error detection on a correct statement. The backend is not
12841 likely to introduce any information that'll get involved in these
12842 considerations, so it is probably just fine that the implementation
12843 model for this fn and for _exec_transition is to not do anything
12844 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12845 and instead wait until ffecom_sym_commit is called (which it never
12846 will be as long as we're using ambiguity-detecting statement analysis in
12847 the FFE, which we are initially to shake out the code, but don't depend
12848 on this), otherwise go ahead and do whatever is needed.
12850 In essence, then, when this fn and _exec_transition get called while
12851 backtracking is enabled, a general mechanism would be to flag which (or
12852 both) of these were called (and in what order? neat question as to what
12853 might happen that I'm too lame to think through right now) and then when
12854 _commit is called reproduce the original calling sequence, if any, for
12855 the two fns (at which point backtracking will, of course, be disabled). */
12857 ffesymbol
12859 {
12863 }
12865 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12867 ffesymbol s;
12868 ffecom_sym_retract(s);
12870 Does whatever the backend needs when a symbol is retracted after having
12871 been backtrackable for a period of time. */
12873 void
12875 {
12879 so nothing needed here. */
12881 {
12900 }
12901 #endif
12902 }
12904 /* Create temporary gcc label. */
12906 tree
12908 {
12909 tree glabel;
12914 mynumber++),
12915 void_type_node);
12920 }
12922 /* Return an expression that is usable as an arg in a conditional context
12923 (IF, DO WHILE, .NOT., and so on).
12925 Use the one provided for the back end as of >2.6.0. */
12927 tree
12929 {
12931 }
12933 /* Return the inversion of a truth value (the inversion of what
12934 ffecom_truth_value builds).
12936 Apparently invert_truthvalue, which is properly in the back end, is
12937 enough for now, so just use it. */
12939 tree
12941 {
12943 }
12945 /* Return the tree that is the type of the expression, as would be
12946 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
12947 transforming the expression, generating temporaries, etc. */
12949 tree
12951 {
12952 ffeinfoBasictype bt;
12953 ffeinfoKindtype kt;
12954 tree tree_type;
12963 {
13006 /* Fall through. */
13009 }
13010 }
13012 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13014 If the PARM_DECL already exists, return it, else create it. It's an
13015 integer_type_node argument for the master function that implements a
13016 subroutine or function with more than one entrypoint and is bound at
13017 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13018 first ENTRY statement, and so on). */
13020 tree
13022 {
13026 }
13027 \f
13028 /* The following sections consists of private and public functions
13029 that have the same names and perform roughly the same functions
13030 as counterparts in the C front end. Changes in the C front end
13031 might affect how things should be done here. Only functions
13032 needed by the back end should be public here; the rest should
13033 be private (static in the C sense). Functions needed by other
13034 g77 front-end modules should be accessed by them via public
13035 ffecom_* names, which should themselves call private versions
13036 in this section so the private versions are easy to recognize
13037 when upgrading to a new gcc and finding interesting changes
13038 in the front end.
13040 Functions named after rule "foo:" in c-parse.y are named
13041 "bison_rule_foo_" so they are easy to find. */
13043 static void
13045 {
13050 }
13052 static tree
13054 {
13055 tree t;
13058 /* Make the temps go away. */
13067 }
13069 /* Return a definition for a builtin function named NAME and whose data type
13070 is TYPE. TYPE should be a function type with argument types.
13071 FUNCTION_CODE tells later passes how to compile calls to this function.
13072 See tree.h for its possible values.
13074 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13075 the name to be called if we can't opencode the function. */
13077 tree
13081 {
13093 }
13095 /* Handle when a new declaration NEWDECL
13096 has the same name as an old one OLDDECL
13097 in the same binding contour.
13098 Prints an error message if appropriate.
13100 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13101 Otherwise, return 0. */
13103 static int
13105 {
13119 /* New decl is completely inconsistent with the old one =>
13120 tell caller to replace the old one.
13121 This is always an error except in the case of shadowing a builtin. */
13125 /* For real parm decl following a forward decl,
13126 return 1 so old decl will be reused. */
13131 /* The new declaration is the same kind of object as the old one.
13132 The declarations may partially match. Print warnings if they don't
13133 match enough. Ultimately, copy most of the information from the new
13134 decl to the old one, and keep using the old one. */
13138 {
13139 /* A function declaration for a built-in function. */
13143 {
13144 /* Accept the return type of the new declaration if same modes. */
13149 {
13150 /* Function types may be shared, so we can't just modify
13151 the return type of olddecl's function type. */
13152 tree newtype
13159 }
13160 }
13163 }
13166 {
13167 /* A function declaration for a predeclared function
13168 that isn't actually built in. */
13172 {
13173 /* If the types don't match, preserve volatility indication.
13174 Later on, we will discard everything else about the
13175 default declaration. */
13177 }
13178 }
13180 /* Copy all the DECL_... slots specified in the new decl
13181 except for any that we copy here from the old type.
13183 Past this point, we don't change OLDTYPE and NEWTYPE
13184 even if we change the types of NEWDECL and OLDDECL. */
13187 {
13188 /* Merge the data types specified in the two decls. */
13194 /* Lay the type out, unless already done. */
13196 {
13203 }
13204 else
13205 {
13206 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13211 {
13214 }
13215 }
13217 /* Keep the old rtl since we can safely use it. */
13220 /* Merge the type qualifiers. */
13227 {
13231 }
13233 /* Keep source location of definition rather than declaration.
13234 Likewise, keep decl at outer scope. */
13237 {
13244 }
13246 /* Merge the unused-warning information. */
13252 /* Merge the initialization information. */
13256 /* Merge the section attribute.
13257 We want to issue an error if the sections conflict but that must be
13258 done later in decl_attributes since we are called before attributes
13259 are assigned. */
13264 {
13267 }
13268 }
13269 /* If cannot merge, then use the new type and qualifiers,
13270 and don't preserve the old rtl. */
13271 else
13272 {
13277 }
13279 /* Merge the storage class information. */
13280 /* For functions, static overrides non-static. */
13282 {
13284 /* This is since we don't automatically
13285 copy the attributes of NEWDECL into OLDDECL. */
13287 /* If this clears `static', clear it in the identifier too. */
13290 }
13292 {
13295 /* An extern decl does not override previous storage class. */
13297 }
13298 else
13299 {
13302 }
13304 /* If either decl says `inline', this fn is inline,
13305 unless its definition was passed already. */
13310 /* Get rid of any built-in function if new arg types don't match it
13311 or if we have a function definition. */
13315 {
13318 }
13320 /* If redeclaring a builtin function, and not a definition,
13321 it stays built in.
13322 Also preserve various other info from the definition. */
13324 {
13326 {
13329 }
13335 }
13337 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13338 But preserve olddecl's DECL_UID. */
13339 {
13346 }
13349 }
13351 /* Finish processing of a declaration;
13352 install its initial value.
13353 If the length of an array type is not known before,
13354 it must be determined now, from the initial value, or it is an error. */
13356 static void
13358 {
13364 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13365 level anyway. */
13370 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13371 overlaps DECL_ARG_TYPE. */
13374 else
13378 {
13381 else
13382 {
13383 /* typedef foo = bar; store the type of bar as the type of foo. */
13386 }
13387 }
13389 /* Deduce size of array from initialization, if not already known */
13394 {
13399 }
13402 {
13409 ?
13410 /* A static variable with an incomplete type is an error if it is
13411 initialized. Also if it is not file scope. Otherwise, let it
13412 through, but if it is not `extern' then it may cause an error
13413 message later. */
13415 :
13416 /* An automatic variable with an incomplete type is an error. */
13418 {
13421 }
13426 {
13429 }
13430 }
13432 /* Output the assembler code and/or RTL code for variables and functions,
13433 unless the type is an undefined structure or union. If not, it will get
13434 done when the type is completed. */
13437 {
13443 {
13444 /* Recompute the RTL of a local array now if it used to be an
13445 incomplete type. */
13448 {
13449 /* If we used it already as memory, it must stay in memory. */
13451 /* If it's still incomplete now, no init will save it. */
13455 }
13456 /* Compute and store the initial value. */
13459 }
13460 }
13462 {
13466 }
13468 /* At the end of a declaration, throw away any variable type sizes of types
13469 defined inside that declaration. There is no use computing them in the
13470 following function definition. */
13473 }
13475 /* Finish up a function declaration and compile that function
13476 all the way to assembler language output. The free the storage
13477 for the function definition.
13479 This is called after parsing the body of the function definition.
13481 NESTED is nonzero if the function being finished is nested in another. */
13483 static void
13485 {
13490 {
13493 else
13495 }
13497 /* TREE_READONLY (fndecl) = 1;
13498 This caused &foo to be of type ptr-to-const-function
13499 which then got a warning when stored in a ptr-to-function variable. */
13504 {
13507 /* Must mark the RESULT_DECL as being in this function. */
13511 /* Obey `register' declarations if `setjmp' is called in this fn. */
13512 /* Generate rtl for function exit. */
13515 /* If this is a nested function, protect the local variables in the stack
13516 above us from being collected while we're compiling this function. */
13520 /* Run the optimizers and output the assembler code for this function. */
13523 /* Undo the GC context switch. */
13526 }
13529 && !nested
13531 {
13532 /* Stop pointing to the local nodes about to be freed. */
13533 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13534 function definition. */
13535 /* For a nested function, this is done in pop_f_function_context. */
13536 /* If rest_of_compilation set this to 0, leave it 0. */
13540 }
13543 {
13544 /* Let the error reporting routines know that we're outside a function.
13545 For a nested function, this value is used in pop_c_function_context
13546 and then reset via pop_function_context. */
13548 }
13549 }
13551 /* Plug-in replacement for identifying the name of a decl and, for a
13552 function, what we call it in diagnostics. For now, "program unit"
13553 should suffice, since it's a bit of a hassle to figure out which
13554 of several kinds of things it is. Note that it could conceivably
13555 be a statement function, which probably isn't really a program unit
13556 per se, but if that comes up, it should be easy to check (being a
13557 nested function and all). */
13561 {
13562 /* Just to keep GCC quiet about the unused variable.
13563 In theory, differing values of V should produce different
13564 output. */
13566 {
13571 }
13572 }
13574 /* g77's function to print out name of current function that caused
13575 an error. */
13577 static void
13580 {
13583 ffeglobal g;
13584 ffesymbol s;
13589 {
13593 }
13594 else
13595 {
13598 {
13601 }
13602 else
13603 {
13606 }
13607 }
13610 {
13616 else
13617 {
13621 }
13625 }
13626 }
13628 /* Similar to `lookup_name' but look only at current binding level. */
13630 static tree
13632 {
13646 }
13648 /* Create a new `struct f_binding_level'. */
13652 {
13653 /* NOSTRICT */
13655 }
13657 /* Save and restore the variables in this file and elsewhere
13658 that keep track of the progress of compilation of the current function.
13659 Used for nested functions. */
13661 struct f_function
13662 {
13664 tree named_labels;
13665 tree shadowed_labels;
13667 };
13671 /* Restore the variables used during compilation of a C function. */
13673 static void
13675 {
13677 tree link;
13679 /* Bring back all the labels that were shadowed. */
13687 {
13688 /* Stop pointing to the local nodes about to be freed. */
13689 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13690 function definition. */
13693 }
13704 }
13706 /* Save and reinitialize the variables
13707 used during compilation of a C function. */
13709 static void
13711 {
13723 }
13725 static void
13727 {
13730 /* Don't try computing parm sizes now -- wait till fn is called. */
13734 /* Fill in arg stuff. */
13745 }
13747 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
13749 static tree
13751 tree x;
13752 {
13763 }
13765 /* Store the list of declarations of the current level.
13766 This is done for the parameter declarations of a function being defined,
13767 after they are modified in the light of any missing parameters. */
13769 static tree
13771 tree decls;
13772 {
13774 }
13776 /* Store the parameter declarations into the current function declaration.
13777 This is called after parsing the parameter declarations, before
13778 digesting the body of the function.
13780 For an old-style definition, modify the function's type
13781 to specify at least the number of arguments. */
13783 static void
13785 {
13791 /* This is a chain of PARM_DECLs from old-style parm declarations. */
13794 /* Initialize the RTL code for the function. */
13798 /* Set up parameters and prepare for return, for the function. */
13801 }
13803 static tree
13805 {
13810 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13811 level anyway. */
13815 {
13818 }
13822 /* For Fortran, we by default put things in .common when possible. */
13825 /* Add this decl to the current binding level. TEM may equal DECL or it may
13826 be a previous decl of the same name. */
13829 else
13832 /* For a local variable, define the RTL now. */
13834 /* But not if this is a duplicate decl and we preserved the rtl from the
13835 previous one (which may or may not happen). */
13837 {
13843 }
13846 }
13848 /* Create the FUNCTION_DECL for a function definition.
13849 DECLSPECS and DECLARATOR are the parts of the declaration;
13850 they describe the function's name and the type it returns,
13851 but twisted together in a fashion that parallels the syntax of C.
13853 This function creates a binding context for the function body
13854 as well as setting up the FUNCTION_DECL in current_function_decl.
13856 Returns 1 on success. If the DECLARATOR is not suitable for a function
13857 (it defines a datum instead), we return 0, which tells
13858 ffe_parse_file to report a parse error.
13860 NESTED is nonzero for a function nested within another function. */
13862 static void
13864 {
13865 tree decl1;
13866 tree restype;
13872 /* Don't expand any sizes in the return type of the function. */
13876 {
13880 }
13881 else
13882 {
13884 }
13888 else
13889 {
13891 name,
13892 type);
13901 /* Make the init_value nonzero so pushdecl knows this is not tentative.
13902 error_mark_node is replaced below (in poplevel) with the BLOCK. */
13905 /* Record the decl so that the function name is defined. If we already have
13906 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
13909 }
13918 {
13924 }
13930 }
13931 \f
13932 /* Here are the public functions the GNU back end needs. */
13934 tree
13937 {
13950 {
13953 }
13959 e);
13973 }
13975 /* Return the list of declarations of the current level.
13976 Note that this list is in reverse order unless/until
13977 you nreverse it; and when you do nreverse it, you must
13978 store the result back using `storedecls' or you will lose. */
13980 tree
13982 {
13984 }
13986 /* Nonzero if we are currently in the global binding level. */
13988 int
13990 {
13992 }
13994 static void
13996 {
14000 }
14002 /* Delete the node BLOCK from the current binding level.
14003 This is used for the block inside a stmt expr ({...})
14004 so that the block can be reinserted where appropriate. */
14006 static void
14008 tree block;
14009 {
14010 tree t;
14014 {
14017 else
14019 }
14021 /* Clear TREE_USED which is always set by poplevel.
14022 The flag is set again if insert_block is called. */
14024 }
14026 void
14028 tree block;
14029 {
14031 current_binding_level->blocks
14033 }
14035 /* Each front end provides its own. */
14042 {
14044 };
14046 #undef LANG_HOOKS_NAME
14048 #undef LANG_HOOKS_INIT
14049 #define LANG_HOOKS_INIT ffe_init
14050 #undef LANG_HOOKS_FINISH
14051 #define LANG_HOOKS_FINISH ffe_finish
14052 #undef LANG_HOOKS_INIT_OPTIONS
14053 #define LANG_HOOKS_INIT_OPTIONS ffe_init_options
14054 #undef LANG_HOOKS_DECODE_OPTION
14055 #define LANG_HOOKS_DECODE_OPTION ffe_decode_option
14056 #undef LANG_HOOKS_PARSE_FILE
14057 #define LANG_HOOKS_PARSE_FILE ffe_parse_file
14058 #undef LANG_HOOKS_MARK_ADDRESSABLE
14059 #define LANG_HOOKS_MARK_ADDRESSABLE ffe_mark_addressable
14060 #undef LANG_HOOKS_PRINT_IDENTIFIER
14061 #define LANG_HOOKS_PRINT_IDENTIFIER ffe_print_identifier
14062 #undef LANG_HOOKS_DECL_PRINTABLE_NAME
14063 #define LANG_HOOKS_DECL_PRINTABLE_NAME ffe_printable_name
14064 #undef LANG_HOOKS_PRINT_ERROR_FUNCTION
14065 #define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function
14066 #undef LANG_HOOKS_TRUTHVALUE_CONVERSION
14067 #define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion
14069 #undef LANG_HOOKS_TYPE_FOR_MODE
14070 #define LANG_HOOKS_TYPE_FOR_MODE ffe_type_for_mode
14071 #undef LANG_HOOKS_TYPE_FOR_SIZE
14072 #define LANG_HOOKS_TYPE_FOR_SIZE ffe_type_for_size
14073 #undef LANG_HOOKS_SIGNED_TYPE
14074 #define LANG_HOOKS_SIGNED_TYPE ffe_signed_type
14075 #undef LANG_HOOKS_UNSIGNED_TYPE
14076 #define LANG_HOOKS_UNSIGNED_TYPE ffe_unsigned_type
14077 #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
14078 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type
14080 /* We do not wish to use alias-set based aliasing at all. Used in the
14081 extreme (every object with its own set, with equivalences recorded) it
14082 might be helpful, but there are problems when it comes to inlining. We
14083 get on ok with flag_argument_noalias, and alias-set aliasing does
14084 currently limit how stack slots can be reused, which is a lose. */
14085 #undef LANG_HOOKS_GET_ALIAS_SET
14086 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14090 /* Table indexed by tree code giving a string containing a character
14091 classifying the tree code. Possibilities are
14092 t, d, s, c, r, <, 1, 2 and e. See tree.def for details. */
14094 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14098 };
14099 #undef DEFTREECODE
14101 /* Table indexed by tree code giving number of expression
14102 operands beyond the fixed part of the node structure.
14103 Not used for types or decls. */
14105 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14109 };
14110 #undef DEFTREECODE
14112 /* Names of tree components.
14113 Used for printing out the tree and error messages. */
14114 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14118 };
14119 #undef DEFTREECODE
14124 {
14125 /* Open input file. */
14127 {
14130 }
14131 else
14136 #ifdef IO_BUFFER_SIZE
14138 #endif
14142 /* If the file is output from cpp, it should contain a first line
14143 `# 1 "real-filename"', and the current design of gcc (toplev.c
14144 in particular and the way it sets up information relied on by
14145 INCLUDE) requires that we read this now, and store the
14146 "real-filename" info in master_input_filename. Ask the lexer
14147 to try doing this. */
14150 /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14151 return the new file name. */
14156 }
14158 static void
14160 {
14167 }
14169 static void
14171 {
14172 /* Set default options for Fortran. */
14179 }
14181 static bool
14183 tree exp;
14184 {
14188 {
14205 {
14207 {
14210 }
14212 }
14214 {
14216 {
14219 }
14221 }
14224 /* drops in */
14230 #endif
14234 }
14235 }
14237 /* Exit a binding level.
14238 Pop the level off, and restore the state of the identifier-decl mappings
14239 that were in effect when this level was entered.
14241 If KEEP is nonzero, this level had explicit declarations, so
14242 and create a "block" (a BLOCK node) for the level
14243 to record its declarations and subblocks for symbol table output.
14245 If FUNCTIONBODY is nonzero, this level is the body of a function,
14246 so create a block as if KEEP were set and also clear out all
14247 label names.
14249 If REVERSE is nonzero, reverse the order of decls before putting
14250 them into the BLOCK. */
14252 tree
14257 {
14259 /* The chain of decls was accumulated in reverse order.
14260 Put it into forward order, just for cleanliness. */
14261 tree decls;
14264 tree decl;
14267 /* Get the decls in the order they were written.
14268 Usually current_binding_level->names is in reverse order.
14269 But parameter decls were previously put in forward order. */
14272 current_binding_level->names
14274 else
14277 /* Output any nested inline functions within this block
14278 if they weren't already output. */
14285 {
14286 /* If this decl was copied from a file-scope decl
14287 on account of a block-scope extern decl,
14288 propagate TREE_ADDRESSABLE to the file-scope decl.
14290 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14291 true, since then the decl goes through save_for_inline_copying. */
14296 {
14300 }
14301 }
14303 /* If there were any declarations or structure tags in that level,
14304 or if this level is a function body,
14305 create a BLOCK to record them for the life of this function. */
14314 {
14317 }
14319 /* In each subblock, record that this is its superior. */
14324 /* Clear out the meanings of the local variables of this level. */
14327 {
14329 {
14330 /* If the ident. was used or addressed via a local extern decl,
14331 don't forget that fact. */
14333 {
14338 }
14340 }
14341 }
14343 /* If the level being exited is the top level of a function,
14344 check over all the labels, and clear out the current
14345 (function local) meanings of their names. */
14348 {
14349 /* If this is the top level block of a function,
14350 the vars are the function's parameters.
14351 Don't leave them in the BLOCK because they are
14352 found in the FUNCTION_DECL instead. */
14355 }
14357 /* Pop the current level, and free the structure for reuse. */
14359 {
14365 }
14367 /* Dispose of the block that we just made inside some higher level. */
14372 {
14374 current_binding_level->blocks
14376 }
14377 /* If we did not make a block for the level just exited,
14378 any blocks made for inner levels
14379 (since they cannot be recorded as subblocks in that level)
14380 must be carried forward so they will later become subblocks
14381 of something else. */
14383 current_binding_level->blocks
14389 }
14391 static void
14394 tree node;
14396 {
14399 }
14401 /* Record a decl-node X as belonging to the current lexical scope.
14402 Check for errors (such as an incompatible declaration for the same
14403 name already seen in the same scope).
14405 Returns either X or an old decl for the same name.
14406 If an old decl is returned, it may have been smashed
14407 to agree with what X says. */
14409 tree
14411 tree x;
14412 {
14421 else
14425 {
14427 {
14430 }
14436 /* Don't push non-parms onto list for parms until we understand
14437 why we're doing this and whether it works. */
14440 || !ffecom_transform_only_dummies_
14446 /* If we are processing a typedef statement, generate a whole new
14447 ..._TYPE node (which will be just an variant of the existing
14448 ..._TYPE node with identical properties) and then install the
14449 TYPE_DECL node generated to represent the typedef name as the
14450 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14452 The whole point here is to end up with a situation where each and every
14453 ..._TYPE node the compiler creates will be uniquely associated with
14454 AT MOST one node representing a typedef name. This way, even though
14455 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14456 (i.e. "typedef name") nodes very early on, later parts of the
14457 compiler can always do the reverse translation and get back the
14458 corresponding typedef name. For example, given:
14460 typedef struct S MY_TYPE; MY_TYPE object;
14462 Later parts of the compiler might only know that `object' was of type
14463 `struct S' if it were not for code just below. With this code
14464 however, later parts of the compiler see something like:
14466 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14468 And they can then deduce (from the node for type struct S') that the
14469 original object declaration was:
14471 MY_TYPE object;
14473 Being able to do this is important for proper support of protoize, and
14474 also for generating precise symbolic debugging information which
14475 takes full account of the programmer's (typedef) vocabulary.
14477 Obviously, we don't want to generate a duplicate ..._TYPE node if the
14478 TYPE_DECL node that we are now processing really represents a
14479 standard built-in type.
14481 Since all standard types are effectively declared at line zero in the
14482 source file, we can easily check to see if we are working on a
14483 standard type by checking the current value of lineno. */
14486 {
14488 {
14491 }
14493 {
14499 }
14500 }
14502 /* This name is new in its binding level. Install the new declaration
14503 and return it. */
14506 else
14508 }
14510 /* Put decls on list in reverse order. We will reverse them later if
14511 necessary. */
14516 }
14518 /* Nonzero if the current level needs to have a BLOCK made. */
14520 static int
14522 {
14523 tree decl;
14526 decl;
14528 {
14531 /* Currently, there aren't supposed to be non-artificial names
14532 at other than the top block for a function -- they're
14533 believed to always be temps. But it's wise to check anyway. */
14535 }
14537 }
14539 /* Enter a new binding level.
14540 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14541 not for that of tags. */
14543 void
14546 {
14552 {
14554 }
14556 /* Reuse or create a struct for this binding level. */
14559 {
14562 }
14563 else
14564 {
14566 }
14568 /* Add this level to the front of the chain (stack) of levels that
14569 are active. */
14574 }
14576 /* Set the BLOCK node for the innermost scope
14577 (the one we are currently in). */
14579 void
14582 {
14588 }
14590 static tree
14593 tree type;
14594 {
14595 tree type2;
14616 }
14618 static tree
14620 tree type;
14621 {
14623 ffeinfoKindtype kt;
14624 tree type2;
14645 #endif
14652 {
14657 }
14660 }
14662 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14663 or validate its data type for an `if' or `while' statement or ?..: exp.
14665 This preparation consists of taking the ordinary
14666 representation of an expression expr and producing a valid tree
14667 boolean expression describing whether expr is nonzero. We could
14668 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14669 but we optimize comparisons, &&, ||, and !.
14671 The resulting type should always be `integer_type_node'. */
14673 static tree
14675 tree expr;
14676 {
14681 /* These really should return error_mark_node after 2.4 is stable.
14682 But not all callers handle ERROR_MARK properly. */
14684 {
14699 }
14703 {
14704 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14705 or comparison expressions as truth values at this level. */
14706 #if 0
14708 /* A one-bit unsigned bit-field is already acceptable. */
14713 #endif
14716 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14717 or comparison expressions as truth values at this level. */
14718 #if 0
14721 #endif
14744 else
14750 integer_type_node,
14758 /* These don't change whether an object is non-zero or zero. */
14763 /* These don't change whether an object is zero or non-zero, but
14764 we can't ignore them if their second arg has side-effects. */
14768 else
14772 /* Distribute the conversion into the arms of a COND_EXPR. */
14778 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14779 since that affects how `default_conversion' will behave. */
14783 /* fall through... */
14785 /* If this is widening the argument, we can ignore it. */
14792 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14793 this case. */
14797 /* fall through... */
14799 /* This and MINUS_EXPR can be changed into a comparison of the
14800 two objects. */
14821 #endif
14826 }
14832 integer_type_node,
14835 expr)),
14838 expr))));
14841 expr,
14843 }
14845 static tree
14849 {
14852 tree t;
14869 #if HOST_BITS_PER_WIDE_INT >= 64
14872 #endif
14888 {
14891 {
14894 else
14896 }
14897 }
14900 }
14902 static tree
14906 {
14907 ffeinfoKindtype kt;
14908 tree type_node;
14927 {
14933 }
14936 }
14938 static tree
14940 tree type;
14941 {
14943 ffeinfoKindtype kt;
14944 tree type2;
14965 #endif
14972 {
14977 }
14980 }
14981 \f
14982 /* From gcc/cccp.c, the code to handle -I. */
14984 /* Skip leading "./" from a directory name.
14985 This may yield the empty string, which represents the current directory. */
14989 {
14994 dir++;
14996 }
14998 /* The file_name_map structure holds a mapping of file names for a
14999 particular directory. This mapping is read from the file named
15000 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15001 map filenames on a file system with severe filename restrictions,
15002 such as DOS. The format of the file name map file is just a series
15003 of lines with two tokens on each line. The first token is the name
15004 to map, and the second token is the actual name to use. */
15006 struct file_name_map
15007 {
15011 };
15015 /* Current maximum length of directory names in the search path
15016 for include files. (Altered as we get more of them.) */
15020 struct file_name_list
15021 {
15024 /* Mapping of file names for this directory. */
15026 /* Non-zero if name_map is valid. */
15028 };
15033 /* I/O buffer structure.
15034 The `fname' field is nonzero for source files and #include files
15035 and for the dummy text used for -D and -U.
15036 It is zero for rescanning results of macro expansion
15037 and for expanding macro arguments. */
15038 #define INPUT_STACK_MAX 400
15041 /* Filename specified with #line command. */
15043 /* Record where in the search path this file was found.
15044 For #include_next. */
15046 ffewhereLine line;
15047 ffewhereColumn column;
15053 /* Current nesting level of input sources.
15054 `instack[indepth]' is the level currently being read. */
15059 /* Nonzero means -I- has been seen,
15060 so don't look for #include "foo" the source-file directory. */
15063 #ifndef INCLUDE_LEN_FUDGE
15064 #define INCLUDE_LEN_FUDGE 0
15065 #endif
15075 /* Append a chain of `struct file_name_list's
15076 to the end of the main include chain.
15077 FIRST is the beginning of the chain to append, and LAST is the end. */
15079 static void
15082 {
15090 else
15099 }
15103 }
15105 /* Try to open include file FILENAME. SEARCHPTR is the directory
15106 being tried from the include file search path. This function maps
15107 filenames on file systems based on information read by
15108 read_name_map. */
15114 {
15120 {
15124 }
15126 /* First check the mapping for the directory we are using. */
15128 {
15133 {
15135 {
15136 /* Found a match. */
15138 }
15139 }
15140 }
15142 /* Try to find a mapping file for the particular directory we are
15143 looking in. Thus #include <sys/types.h> will look up sys/types.h
15144 in /usr/include/header.gcc and look up types.h in
15145 /usr/include/sys/header.gcc. */
15147 #ifdef DIR_SEPARATOR
15152 }
15153 #endif
15160 {
15161 /* FILENAME is in SEARCHPTR, which we've already checked. */
15163 }
15166 {
15169 }
15170 else
15171 {
15178 }
15184 }
15186 /* Print the file names and line numbers of the #include
15187 commands which led to the current file. */
15189 static void
15191 {
15198 /* If stack of files hasn't changed since we last printed
15199 this info, don't repeat it. */
15207 }
15209 /* Give up if we don't find a source file. */
15213 /* Find the other, outer source files. */
15216 {
15219 {
15222 }
15223 else
15224 {
15226 }
15230 else
15233 /* xgettext:no-c-format */
15240 }
15242 /* Record we have printed the status as of this time. */
15244 }
15246 /* Read a space delimited string of unlimited length from a stdio
15247 file. */
15253 {
15260 {
15263 {
15265 {
15269 }
15271 }
15272 }
15276 }
15278 /* Read the file name map file for DIRNAME. */
15283 {
15284 /* This structure holds a linked list of file name maps, one per
15285 directory. */
15286 struct file_name_map_list
15287 {
15291 };
15321 else
15322 {
15326 {
15334 ;
15341 /* Make the real filename absolute. */
15344 else
15345 {
15351 }
15359 }
15361 }
15367 }
15369 static void
15371 {
15374 /* Do partial setup of input buffer for the sake of generating
15375 early #line directives (when -g is in effect). */
15382 }
15384 static void
15386 {
15389 indepth--;
15390 input_file_stack_tick++;
15394 }
15396 static int
15398 {
15403 else
15404 {
15412 else
15414 }
15416 }
15418 /* Open INCLUDEd file. */
15422 {
15437 /* If -I- was specified, don't search current dir, only spec'd ones. */
15439 {
15441 {
15447 {
15448 /* Found a named file. Figure out dir of the file,
15449 and put it in front of the search list. */
15452 #ifndef VMS
15454 #ifdef DIR_SEPARATOR
15459 }
15460 #endif
15468 {
15475 }
15476 else
15480 }
15481 }
15482 }
15484 /* Allocate this permanently, because it gets stored in the definitions
15485 of macros. */
15487 /* + 2 above for slash and terminating null. */
15488 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15489 for g77 yet). */
15491 /* If specified file name is absolute, just open it. */
15494 #ifdef DIR_SEPARATOR
15496 #endif
15497 )
15498 {
15502 }
15503 else
15504 {
15507 /* Search directory path, trying to open the file.
15508 Copy each filename tried into FNAME. */
15511 {
15513 {
15514 /* The empty string in a search path is ignored.
15515 This makes it possible to turn off entirely
15516 a standard piece of the list. */
15523 }
15524 else
15528 #ifdef VMS
15529 /* Change this 1/2 Unix 1/2 VMS file specification into a
15530 full VMS file specification */
15532 {
15533 /* Fix up the filename */
15535 }
15536 else
15537 {
15538 /* This is a normal VMS filespec, so use it unchanged. */
15542 /* if it's '#include filename', add the missing .h */
15545 #endif
15546 }
15549 #ifdef EACCES
15551 {
15553 /* xgettext:no-c-format */
15555 FFEBAD_severityWARNING);
15559 }
15560 #endif
15563 }
15564 }
15567 {
15568 /* A file that was not found. */
15577 }
15586 {
15588 /* xgettext:no-c-format */
15590 FFEBAD_severityFATAL);
15595 }
15605 indepth++;
15606 input_file_stack_tick++;
15609 }
15611 /**INDENT* (Do not reformat this comment even with -fca option.)
15612 Data-gathering files: Given the source file listed below, compiled with
15613 f2c I obtained the output file listed after that, and from the output
15614 file I derived the above code.
15616 -------- (begin input file to f2c)
15617 implicit none
15618 character*10 A1,A2
15619 complex C1,C2
15620 integer I1,I2
15621 real R1,R2
15622 double precision D1,D2
15623 C
15624 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15625 c /
15626 call fooI(I1/I2)
15627 call fooR(R1/I1)
15628 call fooD(D1/I1)
15629 call fooC(C1/I1)
15630 call fooR(R1/R2)
15631 call fooD(R1/D1)
15632 call fooD(D1/D2)
15633 call fooD(D1/R1)
15634 call fooC(C1/C2)
15635 call fooC(C1/R1)
15636 call fooZ(C1/D1)
15637 c **
15638 call fooI(I1**I2)
15639 call fooR(R1**I1)
15640 call fooD(D1**I1)
15641 call fooC(C1**I1)
15642 call fooR(R1**R2)
15643 call fooD(R1**D1)
15644 call fooD(D1**D2)
15645 call fooD(D1**R1)
15646 call fooC(C1**C2)
15647 call fooC(C1**R1)
15648 call fooZ(C1**D1)
15649 c FFEINTRIN_impABS
15650 call fooR(ABS(R1))
15651 c FFEINTRIN_impACOS
15652 call fooR(ACOS(R1))
15653 c FFEINTRIN_impAIMAG
15654 call fooR(AIMAG(C1))
15655 c FFEINTRIN_impAINT
15656 call fooR(AINT(R1))
15657 c FFEINTRIN_impALOG
15658 call fooR(ALOG(R1))
15659 c FFEINTRIN_impALOG10
15660 call fooR(ALOG10(R1))
15661 c FFEINTRIN_impAMAX0
15662 call fooR(AMAX0(I1,I2))
15663 c FFEINTRIN_impAMAX1
15664 call fooR(AMAX1(R1,R2))
15665 c FFEINTRIN_impAMIN0
15666 call fooR(AMIN0(I1,I2))
15667 c FFEINTRIN_impAMIN1
15668 call fooR(AMIN1(R1,R2))
15669 c FFEINTRIN_impAMOD
15670 call fooR(AMOD(R1,R2))
15671 c FFEINTRIN_impANINT
15672 call fooR(ANINT(R1))
15673 c FFEINTRIN_impASIN
15674 call fooR(ASIN(R1))
15675 c FFEINTRIN_impATAN
15676 call fooR(ATAN(R1))
15677 c FFEINTRIN_impATAN2
15678 call fooR(ATAN2(R1,R2))
15679 c FFEINTRIN_impCABS
15680 call fooR(CABS(C1))
15681 c FFEINTRIN_impCCOS
15682 call fooC(CCOS(C1))
15683 c FFEINTRIN_impCEXP
15684 call fooC(CEXP(C1))
15685 c FFEINTRIN_impCHAR
15686 call fooA(CHAR(I1))
15687 c FFEINTRIN_impCLOG
15688 call fooC(CLOG(C1))
15689 c FFEINTRIN_impCONJG
15690 call fooC(CONJG(C1))
15691 c FFEINTRIN_impCOS
15692 call fooR(COS(R1))
15693 c FFEINTRIN_impCOSH
15694 call fooR(COSH(R1))
15695 c FFEINTRIN_impCSIN
15696 call fooC(CSIN(C1))
15697 c FFEINTRIN_impCSQRT
15698 call fooC(CSQRT(C1))
15699 c FFEINTRIN_impDABS
15700 call fooD(DABS(D1))
15701 c FFEINTRIN_impDACOS
15702 call fooD(DACOS(D1))
15703 c FFEINTRIN_impDASIN
15704 call fooD(DASIN(D1))
15705 c FFEINTRIN_impDATAN
15706 call fooD(DATAN(D1))
15707 c FFEINTRIN_impDATAN2
15708 call fooD(DATAN2(D1,D2))
15709 c FFEINTRIN_impDCOS
15710 call fooD(DCOS(D1))
15711 c FFEINTRIN_impDCOSH
15712 call fooD(DCOSH(D1))
15713 c FFEINTRIN_impDDIM
15714 call fooD(DDIM(D1,D2))
15715 c FFEINTRIN_impDEXP
15716 call fooD(DEXP(D1))
15717 c FFEINTRIN_impDIM
15718 call fooR(DIM(R1,R2))
15719 c FFEINTRIN_impDINT
15720 call fooD(DINT(D1))
15721 c FFEINTRIN_impDLOG
15722 call fooD(DLOG(D1))
15723 c FFEINTRIN_impDLOG10
15724 call fooD(DLOG10(D1))
15725 c FFEINTRIN_impDMAX1
15726 call fooD(DMAX1(D1,D2))
15727 c FFEINTRIN_impDMIN1
15728 call fooD(DMIN1(D1,D2))
15729 c FFEINTRIN_impDMOD
15730 call fooD(DMOD(D1,D2))
15731 c FFEINTRIN_impDNINT
15732 call fooD(DNINT(D1))
15733 c FFEINTRIN_impDPROD
15734 call fooD(DPROD(R1,R2))
15735 c FFEINTRIN_impDSIGN
15736 call fooD(DSIGN(D1,D2))
15737 c FFEINTRIN_impDSIN
15738 call fooD(DSIN(D1))
15739 c FFEINTRIN_impDSINH
15740 call fooD(DSINH(D1))
15741 c FFEINTRIN_impDSQRT
15742 call fooD(DSQRT(D1))
15743 c FFEINTRIN_impDTAN
15744 call fooD(DTAN(D1))
15745 c FFEINTRIN_impDTANH
15746 call fooD(DTANH(D1))
15747 c FFEINTRIN_impEXP
15748 call fooR(EXP(R1))
15749 c FFEINTRIN_impIABS
15750 call fooI(IABS(I1))
15751 c FFEINTRIN_impICHAR
15752 call fooI(ICHAR(A1))
15753 c FFEINTRIN_impIDIM
15754 call fooI(IDIM(I1,I2))
15755 c FFEINTRIN_impIDNINT
15756 call fooI(IDNINT(D1))
15757 c FFEINTRIN_impINDEX
15758 call fooI(INDEX(A1,A2))
15759 c FFEINTRIN_impISIGN
15760 call fooI(ISIGN(I1,I2))
15761 c FFEINTRIN_impLEN
15762 call fooI(LEN(A1))
15763 c FFEINTRIN_impLGE
15764 call fooL(LGE(A1,A2))
15765 c FFEINTRIN_impLGT
15766 call fooL(LGT(A1,A2))
15767 c FFEINTRIN_impLLE
15768 call fooL(LLE(A1,A2))
15769 c FFEINTRIN_impLLT
15770 call fooL(LLT(A1,A2))
15771 c FFEINTRIN_impMAX0
15772 call fooI(MAX0(I1,I2))
15773 c FFEINTRIN_impMAX1
15774 call fooI(MAX1(R1,R2))
15775 c FFEINTRIN_impMIN0
15776 call fooI(MIN0(I1,I2))
15777 c FFEINTRIN_impMIN1
15778 call fooI(MIN1(R1,R2))
15779 c FFEINTRIN_impMOD
15780 call fooI(MOD(I1,I2))
15781 c FFEINTRIN_impNINT
15782 call fooI(NINT(R1))
15783 c FFEINTRIN_impSIGN
15784 call fooR(SIGN(R1,R2))
15785 c FFEINTRIN_impSIN
15786 call fooR(SIN(R1))
15787 c FFEINTRIN_impSINH
15788 call fooR(SINH(R1))
15789 c FFEINTRIN_impSQRT
15790 call fooR(SQRT(R1))
15791 c FFEINTRIN_impTAN
15792 call fooR(TAN(R1))
15793 c FFEINTRIN_impTANH
15794 call fooR(TANH(R1))
15795 c FFEINTRIN_imp_CMPLX_C
15796 call fooC(cmplx(C1,C2))
15797 c FFEINTRIN_imp_CMPLX_D
15798 call fooZ(cmplx(D1,D2))
15799 c FFEINTRIN_imp_CMPLX_I
15800 call fooC(cmplx(I1,I2))
15801 c FFEINTRIN_imp_CMPLX_R
15802 call fooC(cmplx(R1,R2))
15803 c FFEINTRIN_imp_DBLE_C
15804 call fooD(dble(C1))
15805 c FFEINTRIN_imp_DBLE_D
15806 call fooD(dble(D1))
15807 c FFEINTRIN_imp_DBLE_I
15808 call fooD(dble(I1))
15809 c FFEINTRIN_imp_DBLE_R
15810 call fooD(dble(R1))
15811 c FFEINTRIN_imp_INT_C
15812 call fooI(int(C1))
15813 c FFEINTRIN_imp_INT_D
15814 call fooI(int(D1))
15815 c FFEINTRIN_imp_INT_I
15816 call fooI(int(I1))
15817 c FFEINTRIN_imp_INT_R
15818 call fooI(int(R1))
15819 c FFEINTRIN_imp_REAL_C
15820 call fooR(real(C1))
15821 c FFEINTRIN_imp_REAL_D
15822 call fooR(real(D1))
15823 c FFEINTRIN_imp_REAL_I
15824 call fooR(real(I1))
15825 c FFEINTRIN_imp_REAL_R
15826 call fooR(real(R1))
15827 c
15828 c FFEINTRIN_imp_INT_D:
15829 c
15830 c FFEINTRIN_specIDINT
15831 call fooI(IDINT(D1))
15832 c
15833 c FFEINTRIN_imp_INT_R:
15834 c
15835 c FFEINTRIN_specIFIX
15836 call fooI(IFIX(R1))
15837 c FFEINTRIN_specINT
15838 call fooI(INT(R1))
15839 c
15840 c FFEINTRIN_imp_REAL_D:
15841 c
15842 c FFEINTRIN_specSNGL
15843 call fooR(SNGL(D1))
15844 c
15845 c FFEINTRIN_imp_REAL_I:
15846 c
15847 c FFEINTRIN_specFLOAT
15848 call fooR(FLOAT(I1))
15849 c FFEINTRIN_specREAL
15850 call fooR(REAL(I1))
15851 c
15852 end
15853 -------- (end input file to f2c)
15855 -------- (begin output from providing above input file as input to:
15856 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
15857 -------- -e "s:^#.*$::g"')
15859 // -- translated by f2c (version 19950223).
15860 You must link the resulting object file with the libraries:
15861 -lf2c -lm (in that order)
15862 //
15865 // f2c.h -- Standard Fortran to C header file //
15867 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
15869 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
15874 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
15875 // we assume short, float are OK //
15876 typedef long int // long int // integer;
15877 typedef char *address;
15878 typedef short int shortint;
15879 typedef float real;
15880 typedef double doublereal;
15881 typedef struct { real r, i; } complex;
15882 typedef struct { doublereal r, i; } doublecomplex;
15883 typedef long int // long int // logical;
15884 typedef short int shortlogical;
15885 typedef char logical1;
15886 typedef char integer1;
15887 // typedef long long longint; // // system-dependent //
15892 // Extern is for use with -E //
15897 // I/O stuff //
15906 typedef long int // int or long int // flag;
15907 typedef long int // int or long int // ftnlen;
15908 typedef long int // int or long int // ftnint;
15911 //external read, write//
15912 typedef struct
15913 { flag cierr;
15914 ftnint ciunit;
15915 flag ciend;
15916 char *cifmt;
15917 ftnint cirec;
15918 } cilist;
15920 //internal read, write//
15921 typedef struct
15922 { flag icierr;
15923 char *iciunit;
15924 flag iciend;
15925 char *icifmt;
15926 ftnint icirlen;
15927 ftnint icirnum;
15928 } icilist;
15930 //open//
15931 typedef struct
15932 { flag oerr;
15933 ftnint ounit;
15934 char *ofnm;
15935 ftnlen ofnmlen;
15936 char *osta;
15937 char *oacc;
15938 char *ofm;
15939 ftnint orl;
15940 char *oblnk;
15941 } olist;
15943 //close//
15944 typedef struct
15945 { flag cerr;
15946 ftnint cunit;
15947 char *csta;
15948 } cllist;
15950 //rewind, backspace, endfile//
15951 typedef struct
15952 { flag aerr;
15953 ftnint aunit;
15954 } alist;
15956 // inquire //
15957 typedef struct
15958 { flag inerr;
15959 ftnint inunit;
15960 char *infile;
15961 ftnlen infilen;
15962 ftnint *inex; //parameters in standard's order//
15963 ftnint *inopen;
15964 ftnint *innum;
15965 ftnint *innamed;
15966 char *inname;
15967 ftnlen innamlen;
15968 char *inacc;
15969 ftnlen inacclen;
15970 char *inseq;
15971 ftnlen inseqlen;
15972 char *indir;
15973 ftnlen indirlen;
15974 char *infmt;
15975 ftnlen infmtlen;
15976 char *inform;
15977 ftnint informlen;
15978 char *inunf;
15979 ftnlen inunflen;
15980 ftnint *inrecl;
15981 ftnint *innrec;
15982 char *inblank;
15983 ftnlen inblanklen;
15984 } inlist;
15988 union Multitype { // for multiple entry points //
15989 integer1 g;
15990 shortint h;
15991 integer i;
15992 // longint j; //
15993 real r;
15994 doublereal d;
15995 complex c;
15996 doublecomplex z;
15997 };
15999 typedef union Multitype Multitype;
16001 typedef long Long; // No longer used; formerly in Namelist //
16003 struct Vardesc { // for Namelist //
16004 char *name;
16005 char *addr;
16006 ftnlen *dims;
16007 int type;
16008 };
16009 typedef struct Vardesc Vardesc;
16011 struct Namelist {
16012 char *name;
16013 Vardesc **vars;
16014 int nvars;
16015 };
16016 typedef struct Namelist Namelist;
16025 // procedure parameter types for -A and -C++ //
16030 typedef int // Unknown procedure type // (*U_fp)();
16031 typedef shortint (*J_fp)();
16032 typedef integer (*I_fp)();
16033 typedef real (*R_fp)();
16034 typedef doublereal (*D_fp)(), (*E_fp)();
16035 typedef // Complex // void (*C_fp)();
16036 typedef // Double Complex // void (*Z_fp)();
16037 typedef logical (*L_fp)();
16038 typedef shortlogical (*K_fp)();
16039 typedef // Character // void (*H_fp)();
16040 typedef // Subroutine // int (*S_fp)();
16042 // E_fp is for real functions when -R is not specified //
16043 typedef void C_f; // complex function //
16044 typedef void H_f; // character function //
16045 typedef void Z_f; // double complex function //
16046 typedef doublereal E_f; // real function with -R not specified //
16048 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16051 // (No such symbols should be defined in a strict ANSI C compiler.
16052 We can avoid trouble with f2c-translated code by using
16053 gcc -ansi.) //
16077 // Main program // MAIN__()
16078 {
16079 // System generated locals //
16080 integer i__1;
16081 real r__1, r__2;
16082 doublereal d__1, d__2;
16083 complex q__1;
16084 doublecomplex z__1, z__2, z__3;
16085 logical L__1;
16086 char ch__1[1];
16088 // Builtin functions //
16089 void c_div();
16090 integer pow_ii();
16091 double pow_ri(), pow_di();
16092 void pow_ci();
16093 double pow_dd();
16094 void pow_zz();
16095 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16096 asin(), atan(), atan2(), c_abs();
16097 void c_cos(), c_exp(), c_log(), r_cnjg();
16098 double cos(), cosh();
16099 void c_sin(), c_sqrt();
16100 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16101 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16102 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16103 logical l_ge(), l_gt(), l_le(), l_lt();
16104 integer i_nint();
16105 double r_sign();
16107 // Local variables //
16108 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16109 fool_(), fooz_(), getem_();
16110 static char a1[10], a2[10];
16111 static complex c1, c2;
16112 static doublereal d1, d2;
16113 static integer i1, i2;
16114 static real r1, r2;
16117 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16118 // / //
16119 i__1 = i1 / i2;
16120 fooi_(&i__1);
16121 r__1 = r1 / i1;
16122 foor_(&r__1);
16123 d__1 = d1 / i1;
16124 food_(&d__1);
16125 d__1 = (doublereal) i1;
16126 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16127 fooc_(&q__1);
16128 r__1 = r1 / r2;
16129 foor_(&r__1);
16130 d__1 = r1 / d1;
16131 food_(&d__1);
16132 d__1 = d1 / d2;
16133 food_(&d__1);
16134 d__1 = d1 / r1;
16135 food_(&d__1);
16136 c_div(&q__1, &c1, &c2);
16137 fooc_(&q__1);
16138 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16139 fooc_(&q__1);
16140 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16141 fooz_(&z__1);
16142 // ** //
16143 i__1 = pow_ii(&i1, &i2);
16144 fooi_(&i__1);
16145 r__1 = pow_ri(&r1, &i1);
16146 foor_(&r__1);
16147 d__1 = pow_di(&d1, &i1);
16148 food_(&d__1);
16149 pow_ci(&q__1, &c1, &i1);
16150 fooc_(&q__1);
16151 d__1 = (doublereal) r1;
16152 d__2 = (doublereal) r2;
16153 r__1 = pow_dd(&d__1, &d__2);
16154 foor_(&r__1);
16155 d__2 = (doublereal) r1;
16156 d__1 = pow_dd(&d__2, &d1);
16157 food_(&d__1);
16158 d__1 = pow_dd(&d1, &d2);
16159 food_(&d__1);
16160 d__2 = (doublereal) r1;
16161 d__1 = pow_dd(&d1, &d__2);
16162 food_(&d__1);
16163 z__2.r = c1.r, z__2.i = c1.i;
16164 z__3.r = c2.r, z__3.i = c2.i;
16165 pow_zz(&z__1, &z__2, &z__3);
16166 q__1.r = z__1.r, q__1.i = z__1.i;
16167 fooc_(&q__1);
16168 z__2.r = c1.r, z__2.i = c1.i;
16169 z__3.r = r1, z__3.i = 0.;
16170 pow_zz(&z__1, &z__2, &z__3);
16171 q__1.r = z__1.r, q__1.i = z__1.i;
16172 fooc_(&q__1);
16173 z__2.r = c1.r, z__2.i = c1.i;
16174 z__3.r = d1, z__3.i = 0.;
16175 pow_zz(&z__1, &z__2, &z__3);
16176 fooz_(&z__1);
16177 // FFEINTRIN_impABS //
16178 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16179 foor_(&r__1);
16180 // FFEINTRIN_impACOS //
16181 r__1 = acos(r1);
16182 foor_(&r__1);
16183 // FFEINTRIN_impAIMAG //
16184 r__1 = r_imag(&c1);
16185 foor_(&r__1);
16186 // FFEINTRIN_impAINT //
16187 r__1 = r_int(&r1);
16188 foor_(&r__1);
16189 // FFEINTRIN_impALOG //
16190 r__1 = log(r1);
16191 foor_(&r__1);
16192 // FFEINTRIN_impALOG10 //
16193 r__1 = r_lg10(&r1);
16194 foor_(&r__1);
16195 // FFEINTRIN_impAMAX0 //
16196 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16197 foor_(&r__1);
16198 // FFEINTRIN_impAMAX1 //
16199 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16200 foor_(&r__1);
16201 // FFEINTRIN_impAMIN0 //
16202 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16203 foor_(&r__1);
16204 // FFEINTRIN_impAMIN1 //
16205 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16206 foor_(&r__1);
16207 // FFEINTRIN_impAMOD //
16208 r__1 = r_mod(&r1, &r2);
16209 foor_(&r__1);
16210 // FFEINTRIN_impANINT //
16211 r__1 = r_nint(&r1);
16212 foor_(&r__1);
16213 // FFEINTRIN_impASIN //
16214 r__1 = asin(r1);
16215 foor_(&r__1);
16216 // FFEINTRIN_impATAN //
16217 r__1 = atan(r1);
16218 foor_(&r__1);
16219 // FFEINTRIN_impATAN2 //
16220 r__1 = atan2(r1, r2);
16221 foor_(&r__1);
16222 // FFEINTRIN_impCABS //
16223 r__1 = c_abs(&c1);
16224 foor_(&r__1);
16225 // FFEINTRIN_impCCOS //
16226 c_cos(&q__1, &c1);
16227 fooc_(&q__1);
16228 // FFEINTRIN_impCEXP //
16229 c_exp(&q__1, &c1);
16230 fooc_(&q__1);
16231 // FFEINTRIN_impCHAR //
16232 *(unsigned char *)&ch__1[0] = i1;
16233 fooa_(ch__1, 1L);
16234 // FFEINTRIN_impCLOG //
16235 c_log(&q__1, &c1);
16236 fooc_(&q__1);
16237 // FFEINTRIN_impCONJG //
16238 r_cnjg(&q__1, &c1);
16239 fooc_(&q__1);
16240 // FFEINTRIN_impCOS //
16241 r__1 = cos(r1);
16242 foor_(&r__1);
16243 // FFEINTRIN_impCOSH //
16244 r__1 = cosh(r1);
16245 foor_(&r__1);
16246 // FFEINTRIN_impCSIN //
16247 c_sin(&q__1, &c1);
16248 fooc_(&q__1);
16249 // FFEINTRIN_impCSQRT //
16250 c_sqrt(&q__1, &c1);
16251 fooc_(&q__1);
16252 // FFEINTRIN_impDABS //
16253 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16254 food_(&d__1);
16255 // FFEINTRIN_impDACOS //
16256 d__1 = acos(d1);
16257 food_(&d__1);
16258 // FFEINTRIN_impDASIN //
16259 d__1 = asin(d1);
16260 food_(&d__1);
16261 // FFEINTRIN_impDATAN //
16262 d__1 = atan(d1);
16263 food_(&d__1);
16264 // FFEINTRIN_impDATAN2 //
16265 d__1 = atan2(d1, d2);
16266 food_(&d__1);
16267 // FFEINTRIN_impDCOS //
16268 d__1 = cos(d1);
16269 food_(&d__1);
16270 // FFEINTRIN_impDCOSH //
16271 d__1 = cosh(d1);
16272 food_(&d__1);
16273 // FFEINTRIN_impDDIM //
16274 d__1 = d_dim(&d1, &d2);
16275 food_(&d__1);
16276 // FFEINTRIN_impDEXP //
16277 d__1 = exp(d1);
16278 food_(&d__1);
16279 // FFEINTRIN_impDIM //
16280 r__1 = r_dim(&r1, &r2);
16281 foor_(&r__1);
16282 // FFEINTRIN_impDINT //
16283 d__1 = d_int(&d1);
16284 food_(&d__1);
16285 // FFEINTRIN_impDLOG //
16286 d__1 = log(d1);
16287 food_(&d__1);
16288 // FFEINTRIN_impDLOG10 //
16289 d__1 = d_lg10(&d1);
16290 food_(&d__1);
16291 // FFEINTRIN_impDMAX1 //
16292 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16293 food_(&d__1);
16294 // FFEINTRIN_impDMIN1 //
16295 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16296 food_(&d__1);
16297 // FFEINTRIN_impDMOD //
16298 d__1 = d_mod(&d1, &d2);
16299 food_(&d__1);
16300 // FFEINTRIN_impDNINT //
16301 d__1 = d_nint(&d1);
16302 food_(&d__1);
16303 // FFEINTRIN_impDPROD //
16304 d__1 = (doublereal) r1 * r2;
16305 food_(&d__1);
16306 // FFEINTRIN_impDSIGN //
16307 d__1 = d_sign(&d1, &d2);
16308 food_(&d__1);
16309 // FFEINTRIN_impDSIN //
16310 d__1 = sin(d1);
16311 food_(&d__1);
16312 // FFEINTRIN_impDSINH //
16313 d__1 = sinh(d1);
16314 food_(&d__1);
16315 // FFEINTRIN_impDSQRT //
16316 d__1 = sqrt(d1);
16317 food_(&d__1);
16318 // FFEINTRIN_impDTAN //
16319 d__1 = tan(d1);
16320 food_(&d__1);
16321 // FFEINTRIN_impDTANH //
16322 d__1 = tanh(d1);
16323 food_(&d__1);
16324 // FFEINTRIN_impEXP //
16325 r__1 = exp(r1);
16326 foor_(&r__1);
16327 // FFEINTRIN_impIABS //
16328 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16329 fooi_(&i__1);
16330 // FFEINTRIN_impICHAR //
16331 i__1 = *(unsigned char *)a1;
16332 fooi_(&i__1);
16333 // FFEINTRIN_impIDIM //
16334 i__1 = i_dim(&i1, &i2);
16335 fooi_(&i__1);
16336 // FFEINTRIN_impIDNINT //
16337 i__1 = i_dnnt(&d1);
16338 fooi_(&i__1);
16339 // FFEINTRIN_impINDEX //
16340 i__1 = i_indx(a1, a2, 10L, 10L);
16341 fooi_(&i__1);
16342 // FFEINTRIN_impISIGN //
16343 i__1 = i_sign(&i1, &i2);
16344 fooi_(&i__1);
16345 // FFEINTRIN_impLEN //
16346 i__1 = i_len(a1, 10L);
16347 fooi_(&i__1);
16348 // FFEINTRIN_impLGE //
16349 L__1 = l_ge(a1, a2, 10L, 10L);
16350 fool_(&L__1);
16351 // FFEINTRIN_impLGT //
16352 L__1 = l_gt(a1, a2, 10L, 10L);
16353 fool_(&L__1);
16354 // FFEINTRIN_impLLE //
16355 L__1 = l_le(a1, a2, 10L, 10L);
16356 fool_(&L__1);
16357 // FFEINTRIN_impLLT //
16358 L__1 = l_lt(a1, a2, 10L, 10L);
16359 fool_(&L__1);
16360 // FFEINTRIN_impMAX0 //
16361 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16362 fooi_(&i__1);
16363 // FFEINTRIN_impMAX1 //
16364 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16365 fooi_(&i__1);
16366 // FFEINTRIN_impMIN0 //
16367 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16368 fooi_(&i__1);
16369 // FFEINTRIN_impMIN1 //
16370 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16371 fooi_(&i__1);
16372 // FFEINTRIN_impMOD //
16373 i__1 = i1 % i2;
16374 fooi_(&i__1);
16375 // FFEINTRIN_impNINT //
16376 i__1 = i_nint(&r1);
16377 fooi_(&i__1);
16378 // FFEINTRIN_impSIGN //
16379 r__1 = r_sign(&r1, &r2);
16380 foor_(&r__1);
16381 // FFEINTRIN_impSIN //
16382 r__1 = sin(r1);
16383 foor_(&r__1);
16384 // FFEINTRIN_impSINH //
16385 r__1 = sinh(r1);
16386 foor_(&r__1);
16387 // FFEINTRIN_impSQRT //
16388 r__1 = sqrt(r1);
16389 foor_(&r__1);
16390 // FFEINTRIN_impTAN //
16391 r__1 = tan(r1);
16392 foor_(&r__1);
16393 // FFEINTRIN_impTANH //
16394 r__1 = tanh(r1);
16395 foor_(&r__1);
16396 // FFEINTRIN_imp_CMPLX_C //
16397 r__1 = c1.r;
16398 r__2 = c2.r;
16399 q__1.r = r__1, q__1.i = r__2;
16400 fooc_(&q__1);
16401 // FFEINTRIN_imp_CMPLX_D //
16402 z__1.r = d1, z__1.i = d2;
16403 fooz_(&z__1);
16404 // FFEINTRIN_imp_CMPLX_I //
16405 r__1 = (real) i1;
16406 r__2 = (real) i2;
16407 q__1.r = r__1, q__1.i = r__2;
16408 fooc_(&q__1);
16409 // FFEINTRIN_imp_CMPLX_R //
16410 q__1.r = r1, q__1.i = r2;
16411 fooc_(&q__1);
16412 // FFEINTRIN_imp_DBLE_C //
16413 d__1 = (doublereal) c1.r;
16414 food_(&d__1);
16415 // FFEINTRIN_imp_DBLE_D //
16416 d__1 = d1;
16417 food_(&d__1);
16418 // FFEINTRIN_imp_DBLE_I //
16419 d__1 = (doublereal) i1;
16420 food_(&d__1);
16421 // FFEINTRIN_imp_DBLE_R //
16422 d__1 = (doublereal) r1;
16423 food_(&d__1);
16424 // FFEINTRIN_imp_INT_C //
16425 i__1 = (integer) c1.r;
16426 fooi_(&i__1);
16427 // FFEINTRIN_imp_INT_D //
16428 i__1 = (integer) d1;
16429 fooi_(&i__1);
16430 // FFEINTRIN_imp_INT_I //
16431 i__1 = i1;
16432 fooi_(&i__1);
16433 // FFEINTRIN_imp_INT_R //
16434 i__1 = (integer) r1;
16435 fooi_(&i__1);
16436 // FFEINTRIN_imp_REAL_C //
16437 r__1 = c1.r;
16438 foor_(&r__1);
16439 // FFEINTRIN_imp_REAL_D //
16440 r__1 = (real) d1;
16441 foor_(&r__1);
16442 // FFEINTRIN_imp_REAL_I //
16443 r__1 = (real) i1;
16444 foor_(&r__1);
16445 // FFEINTRIN_imp_REAL_R //
16446 r__1 = r1;
16447 foor_(&r__1);
16449 // FFEINTRIN_imp_INT_D: //
16451 // FFEINTRIN_specIDINT //
16452 i__1 = (integer) d1;
16453 fooi_(&i__1);
16455 // FFEINTRIN_imp_INT_R: //
16457 // FFEINTRIN_specIFIX //
16458 i__1 = (integer) r1;
16459 fooi_(&i__1);
16460 // FFEINTRIN_specINT //
16461 i__1 = (integer) r1;
16462 fooi_(&i__1);
16464 // FFEINTRIN_imp_REAL_D: //
16466 // FFEINTRIN_specSNGL //
16467 r__1 = (real) d1;
16468 foor_(&r__1);
16470 // FFEINTRIN_imp_REAL_I: //
16472 // FFEINTRIN_specFLOAT //
16473 r__1 = (real) i1;
16474 foor_(&r__1);
16475 // FFEINTRIN_specREAL //
16476 r__1 = (real) i1;
16477 foor_(&r__1);
16479 } // MAIN__ //
16481 -------- (end output file from f2c)
16483 */