| blob | 1e066f5431d9fa634b64206963435fdba99bb31f |
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
610 {
613 generic;
615 };
617 /* Fortran doesn't use either of these. */
619 {
620 };
622 {
623 };
625 /* In identifiers, C uses the following fields in a special way:
626 TREE_PUBLIC to record that there was a previous local extern decl.
627 TREE_USED to record that such a decl was used.
628 TREE_ADDRESSABLE to record that the address of such a decl was used. */
630 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
631 that have names. Here so we can clear out their names' definitions
632 at the end of the function. */
636 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
639 \f
640 /* Return the subscript expression, modified to do range-checking.
642 `array' is the array to be checked against.
643 `element' is the subscript expression to check.
644 `dim' is the dimension number (starting at 0).
645 `total_dims' is the total number of dimensions (0 for CHARACTER substring).
646 */
648 static tree
651 {
654 tree cond;
655 tree die;
656 tree args;
662 {
666 else
667 {
671 }
672 }
676 {
677 /* Special handling for substring range checks. Fortran allows the
678 end subscript < begin subscript, which means that expressions like
679 string(1:0) are valid (and yield a null string). In view of this,
680 enforce two simpler conditions:
681 1) element<=high for end-substring;
682 2) element>=low for start-substring.
683 Run-time character movement will enforce remaining conditions.
685 More complicated checks would be better, but present structure only
686 provides one index element at a time, so it is not possible to
687 enforce a check of both i and j in string(i:j). If it were, the
688 complete set of rules would read,
689 if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
690 ((low<=i<=high) && (low<=j<=high)) )
691 ok ;
692 else
693 range error ;
694 */
697 else
699 }
700 else
701 {
702 /* Array reference substring range checking. */
705 low,
706 element);
708 {
710 cond,
712 element,
713 high));
714 }
715 }
717 {
721 tree arg3;
722 tree arg2;
723 tree arg1;
724 tree arg4;
727 {
744 array_name,
750 }
754 build_range_type
756 integer_one_node,
762 arg1);
764 /* s_rnge adds one to the element to print it, so bias against
765 that -- want to print a faithful *subscript* value. */
769 element,
771 integer_one_node)));
775 NULL);
783 build_range_type
785 integer_one_node,
791 arg3);
805 }
813 cond,
814 element,
815 die);
818 }
820 /* Return the computed element of an array reference.
822 `item' is NULL_TREE, or the transformed pointer to the array.
823 `expr' is the original opARRAYREF expression, which is transformed
824 if `item' is NULL_TREE.
825 `want_ptr' is nonzero if a pointer to the element, instead of
826 the element itself, is to be returned. */
828 static tree
830 {
836 tree array;
837 tree element;
838 tree tree_type;
839 tree tree_type_x;
841 ffetype type;
842 ffebld list;
846 else
849 /* Build up ARRAY_REFs in reverse order (since we're column major
850 here in Fortran land). */
855 {
862 /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
863 pointers and 32-bit integers. Do the full 64-bit pointer
864 arithmetic, for codes using arrays for nonstandard heap-like
865 work. */
867 }
874 {
877 else
886 }
892 {
893 tree min;
898 {
903 array_name);
907 /* Widen integral arithmetic as desired while preserving
908 signedness. */
923 item,
928 tree_type_x,
930 }
932 {
935 item);
936 }
937 }
938 else
939 {
943 {
949 array_name);
953 /* Widen integral arithmetic as desired while preserving
954 signedness. */
966 item,
967 element);
968 }
969 }
972 }
974 /* This is like gcc's stabilize_reference -- in fact, most of the code
975 comes from that -- but it handles the situation where the reference
976 is going to have its subparts picked at, and it shouldn't change
977 (or trigger extra invocations of functions in the subtrees) due to
978 this. save_expr is a bit overzealous, because we don't need the
979 entire thing calculated and saved like a temp. So, for DECLs, no
980 change is needed, because these are stable aggregates, and ARRAY_REF
981 and such might well be stable too, but for things like calculations,
982 we do need to calculate a snapshot of a value before picking at it. */
984 static tree
986 {
987 tree result;
991 {
995 /* No action is needed in this case. */
1047 }
1055 }
1057 /* A rip-off of gcc's convert.c convert_to_complex function,
1058 reworked to handle complex implemented as C structures
1059 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
1061 static tree
1063 {
1065 tree subtype;
1072 {
1076 }
1079 {
1083 else
1084 {
1087 type,
1091 expr)),
1095 expr)));
1096 }
1097 }
1101 else
1107 }
1109 /* Like gcc's convert(), but crashes if widening might happen. */
1111 static tree
1114 {
1127 {
1130 }
1137 {
1144 }
1146 {
1149 }
1151 {
1155 }
1157 {
1161 }
1163 {
1165 /* Check that at least the first field name agrees. */
1174 }
1178 }
1180 /* Like gcc's convert(), but crashes if narrowing might happen. */
1182 static tree
1185 {
1198 {
1201 }
1208 {
1215 }
1217 {
1220 }
1222 {
1226 }
1228 {
1232 }
1234 {
1236 /* Check that at least the first field name agrees. */
1245 }
1249 }
1251 /* Handles making a COMPLEX type, either the standard
1252 (but buggy?) gbe way, or the safer (but less elegant?)
1253 f2c way. */
1255 static tree
1257 {
1258 tree type;
1259 tree realfield;
1260 tree imagfield;
1263 {
1269 }
1270 else
1271 {
1275 }
1278 }
1280 /* Chooses either the gbe or the f2c way to build a
1281 complex constant. */
1283 static tree
1285 {
1286 tree bothparts;
1289 {
1293 }
1294 else
1295 {
1297 }
1300 }
1302 static tree
1304 {
1305 tree list;
1309 tree length;
1310 ffebld exprh;
1311 tree item;
1320 {
1322 {
1325 {
1328 }
1330 {
1369 }
1370 }
1377 || (ptr
1378 && (TYPE_MODE
1382 *plist
1386 else
1387 {
1391 {
1394 item);
1395 }
1396 *plist
1398 item);
1399 }
1404 {
1407 }
1408 }
1410 /* We've run out of args in the call; if the implementation expects
1411 more, supply null pointers for them, which the implementation can
1412 check to see if an arg was omitted. */
1415 {
1418 else
1422 {
1436 }
1437 *plist
1439 null_pointer_node);
1441 }
1446 }
1448 static tree
1450 {
1451 ffebld item;
1453 ffetype type;
1455 tree t;
1458 {
1471 {
1474 }
1475 }
1482 }
1484 /* Check whether a partial overlap between two expressions is possible.
1486 Can *starting* to write a portion of expr1 change the value
1487 computed (perhaps already, *partially*) by expr2?
1489 Currently, this is a concern only for a COMPLEX expr1. But if it
1490 isn't in COMMON or local EQUIVALENCE, since we don't support
1491 aliasing of arguments, it isn't a concern. */
1493 static bool
1495 {
1496 ffesymbol sym;
1497 ffestorag st;
1500 {
1513 }
1521 /* It's in COMMON or local EQUIVALENCE. */
1524 }
1526 /* Check whether dest and source might overlap. ffebld versions of these
1527 might or might not be passed, will be NULL if not.
1529 The test is really whether source_tree is modifiable and, if modified,
1530 might overlap destination such that the value(s) in the destination might
1531 change before it is finally modified. dest_* are the canonized
1532 destination itself. */
1534 static bool
1538 {
1539 tree source_decl;
1540 tree source_offset;
1541 tree source_size;
1542 tree t;
1548 {
1613 scalar_arg);
1618 scalar_arg);
1628 source_tree);
1633 return
1636 scalar_arg)
1639 scalar_arg);
1668 }
1670 /* Come here when source_decl, source_offset, and source_size filled
1671 in appropriately. */
1681 array? Shouldn't happen.... */
1685 dest_offset,
1687 dest_size)),
1689 source_offset));
1702 source_offset,
1704 source_size)),
1706 dest_offset));
1712 }
1714 /* Check whether dest might overlap any of a list of arguments or is
1715 in a COMMON area the callee might know about (and thus modify). */
1717 static bool
1721 {
1722 tree arg;
1723 tree dest_decl;
1724 tree dest_offset;
1725 tree dest_size;
1728 dest_tree);
1733 /* If the decl cannot be determined reliably, or if its in COMMON
1734 and the callee isn't known to not futz with COMMON via other
1735 means, overlap might happen. */
1743 {
1748 }
1751 }
1753 /* Build a string for a variable name as used by NAMELIST. This means that
1754 if we're using the f2c library, we build an uppercase string, since
1755 f2c does this. */
1757 static tree
1759 {
1763 {
1768 tree t;
1772 else
1785 }
1786 }
1788 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1789 type to just get whatever the function returns), handling the
1790 f2c value-returning convention, if required, by prepending
1791 to the arglist a pointer to a temporary to receive the return value. */
1793 static tree
1798 {
1799 tree item;
1800 tree tempvar;
1806 {
1814 callee_commons,
1815 scalar_args))
1816 {
1819 }
1820 else
1821 {
1825 }
1827 item
1831 tempvar));
1839 }
1840 else
1848 }
1850 /* Given two arguments, transform them and make a call to the given
1851 function via ffecom_call_. */
1853 static tree
1858 {
1859 tree left_tree;
1860 tree right_tree;
1861 tree left_length;
1862 tree right_length;
1865 {
1866 /* Pass arguments by reference. */
1869 }
1870 else
1871 {
1872 /* Pass arguments by value. */
1875 }
1883 {
1886 }
1889 {
1893 else
1895 }
1900 }
1902 /* Return ptr/length args for char subexpression
1904 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1905 subexpressions by constructing the appropriate trees for the ptr-to-
1906 character-text and length-of-character-text arguments in a calling
1907 sequence.
1909 Note that if with_null is TRUE, and the expression is an opCONTER,
1910 a null byte is appended to the string. */
1912 static void
1914 {
1915 tree item;
1916 tree high;
1917 ffetargetCharacter1 val;
1918 ffetargetCharacterSize newlen;
1921 {
1926 {
1927 /* Begin FFETARGET-NULL-KLUDGE. */
1930 }
1937 /* End FFETARGET-NULL-KLUDGE. */
1939 = build_type_variant
1940 (build_array_type
1942 build_range_type
1944 ffecom_f2c_ftnlen_one_node,
1945 high)),
1950 item);
1954 {
1959 {
1962 }
1964 {
1967 else
1968 {
1971 }
1972 }
1975 else
1976 /* FFEINFO_kindFUNCTION. */
1982 item);
1983 }
1987 {
1991 {
1994 }
1997 }
2001 {
2002 ffebld start;
2003 ffebld end;
2005 tree start_tree;
2006 tree end_tree;
2008 ffebld left_symter;
2009 tree array;
2017 /* Determine name for pretty-printing range-check errors. */
2021 ;
2024 else
2030 {
2033 }
2037 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2040 {
2042 ;
2043 else
2044 {
2048 char_name);
2050 end_tree);
2053 {
2056 }
2059 }
2060 }
2061 else
2062 {
2066 char_name);
2068 start_tree);
2071 {
2074 }
2079 item,
2082 start_tree,
2083 ffecom_f2c_ftnlen_one_node));
2086 {
2088 ffecom_f2c_ftnlen_one_node,
2090 ffecom_f2c_ftnlen_type_node,
2092 start_tree));
2093 }
2094 else
2095 {
2099 char_name);
2101 end_tree);
2104 {
2107 }
2110 ffecom_f2c_ftnlen_one_node,
2112 ffecom_f2c_ftnlen_type_node,
2114 }
2115 }
2116 }
2120 {
2122 tree tempvar;
2123 tree args;
2125 ffecomGfrt ix;
2128 /* ~~Kludge alert! This should someday be fixed. */
2136 {
2138 {
2139 /* Invocation of an intrinsic returning CHARACTER*1. */
2143 }
2147 }
2148 else
2149 {
2153 {
2156 }
2158 {
2161 }
2165 }
2170 tempvar);
2176 else
2177 {
2180 {
2184 }
2185 else
2186 {
2189 }
2190 }
2196 tempvar);
2197 }
2205 {
2208 }
2214 temporary. */
2215 tree tempvar;
2216 tree args;
2217 tree newlen;
2223 tempvar);
2237 tempvar);
2239 }
2240 else
2244 }
2251 }
2254 }
2256 /* Check the size of the type to be sure it doesn't overflow the
2257 "portable" capacities of the compiler back end. `dummy' types
2258 can generally overflow the normal sizes as long as the computations
2259 themselves don't overflow. A particular target of the back end
2260 must still enforce its size requirements, though, and the back
2261 end takes care of this in stor-layout.c. */
2263 static tree
2265 {
2275 /* An array is too large if size is negative or the type_size overflows
2276 or its "upper half" is larger than 3 (which would make the signed
2277 byte size and offset computations overflow). */
2282 {
2289 }
2292 }
2294 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2295 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2296 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2298 static tree
2300 {
2302 tree highval;
2303 tree tlen;
2308 else
2309 {
2313 else
2317 }
2320 {
2323 }
2324 else
2325 {
2328 }
2332 ffecom_f2c_ftnlen_one_node,
2333 highval));
2337 }
2339 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2341 ffecomConcatList_ catlist;
2342 ffebld expr; // expr of CHARACTER basictype.
2343 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2344 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2346 Scans expr for character subexpressions, updates and returns catlist
2347 accordingly. */
2349 static ffecomConcatList_
2351 ffetargetCharacterSize max)
2352 {
2353 ffetargetCharacterSize sz;
2355 recurse:
2364 {
2371 if they don't need to preserve it. */
2381 {
2385 }
2388 }
2391 else
2395 else
2399 of the destination. */
2401 {
2407 /* ~~Do useful truncations here. */
2413 }
2414 }
2428 dummy arg of sfunc */
2431 {
2432 ffetargetCharacterSize cmax;
2438 }
2440 #endif
2448 }
2449 }
2451 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2453 ffecomConcatList_ catlist;
2454 ffecom_concat_list_kill_(catlist);
2456 Anything allocated within the list info is deallocated. */
2458 static void
2460 {
2464 }
2466 /* Make list of concatenated string exprs.
2468 Returns a flattened list of concatenated subexpressions given a
2469 tree of such expressions. */
2471 static ffecomConcatList_
2473 {
2474 ffecomConcatList_ catlist;
2478 }
2480 /* Provide some kind of useful info on member of aggregate area,
2481 since current g77/gcc technology does not provide debug info
2482 on these members. */
2484 static void
2487 {
2488 tree value;
2489 tree decl;
2493 #if 0
2494 tree type_id;
2498 )
2499 {
2501 {
2516 }
2517 }
2518 #endif
2527 #if 0
2529 #endif
2533 else
2537 aggr_type,
2544 build_range_type
2546 integer_one_node,
2561 }
2563 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2565 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2566 int i; // entry# for this entrypoint (used by master fn)
2567 ffecom_do_entrypoint_(s,i);
2569 Makes a public entry point that calls our private master fn (already
2570 compiled). */
2572 static void
2574 {
2575 ffebld item;
2579 ffeinfoBasictype bt;
2580 ffeinfoKindtype kt;
2581 ffeglobal g;
2582 ffeglobalType gt;
2584 CHARACTER. */
2597 {
2600 /* Determine actual return type for function. */
2606 {
2612 }
2619 else
2626 else
2645 {
2647 {
2650 }
2651 }
2654 else
2656 }
2657 else
2666 /* Fall through. */
2676 }
2678 /* build_decl uses the current lineno and input_filename to set the decl
2679 source info. So, I've putzed with ffestd and ffeste code to update that
2680 source info to point to the appropriate statement just before calling
2681 ffecom_do_entrypoint (which calls this fn). */
2684 type,
2691 {
2693 }
2695 /* Reset args in master arg list so they get retransitioned. */
2700 {
2701 ffebld arg;
2702 ffesymbol s;
2710 }
2712 /* Build dummy arg list for this entry point. */
2716 tree type;
2717 tree length;
2721 else
2726 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2730 else
2740 {
2743 }
2744 }
2745 else
2753 /* Disallow temp vars at this level. */
2756 /* Make local var to hold return type for multi-type master fn. */
2759 {
2763 ffecom_multi_type_node_);
2766 }
2767 else
2770 /* Here we emit the actual code for the entry point. */
2772 {
2773 ffebld list;
2774 ffebld arg;
2775 ffesymbol s;
2778 tree prepend;
2779 tree call;
2780 tree actarg;
2781 tree master_fn;
2783 /* Prepare actual arg list based on master arg list. */
2788 {
2796 else
2800 }
2802 /* This code appends the length arguments for character
2803 variables/arrays. */
2808 {
2820 else
2824 }
2826 /* Prepend character-value return info to actual arg list. */
2829 {
2835 }
2837 /* Prepend multi-type return value to actual arg list. */
2840 {
2841 prepend
2845 multi_retval));
2848 }
2850 /* Prepend my entry-point number to the actual arg list. */
2856 /* Build the call to the master function. */
2863 /* Decide whether the master function is a function or subroutine, and
2864 handle the return value for my entry point. */
2868 {
2871 }
2873 {
2875 result
2878 result);
2881 multi_retval,
2885 }
2887 {
2889 result
2894 multi_retval,
2897 }
2899 {
2900 result
2903 result);
2907 }
2908 else
2909 {
2911 result,
2913 call));
2915 }
2916 }
2926 }
2928 /* Transform expr into gcc tree with possible destination
2930 Recursive descent on expr while making corresponding tree nodes and
2931 attaching type info and such. If destination supplied and compatible
2932 with temporary that would be made in certain cases, temporary isn't
2933 made, destination used instead, and dest_used flag set TRUE. */
2935 static tree
2938 {
2939 tree item;
2940 tree list;
2941 tree args;
2942 ffeinfoBasictype bt;
2943 ffeinfoKindtype kt;
2944 tree t;
2948 ffesymbol s;
2960 /* Widen integral arithmetic as desired while preserving signedness. */
2968 {
2970 {
2971 ffebitCount i;
2975 tree purpose;
2983 {
2984 ffebldConstantUnion cu;
2985 ffebitCount length;
2994 {
2996 {
3005 else
3010 else
3011 {
3014 }
3015 }
3016 }
3019 }
3020 }
3026 item
3027 = build_array_type
3030 ffecom_integer_zero_node,
3031 item));
3038 {
3039 ffetargetOffset i;
3044 else
3045 {
3049 /* Becomes PURPOSE first time through loop. */
3051 }
3054 {
3055 ffebldConstantUnion cu
3061 /* Assume item is PURPOSE first time through loop. */
3063 else
3064 {
3067 }
3068 }
3069 }
3074 item
3075 = build_array_type
3078 ffecom_integer_zero_node,
3079 item));
3087 item
3102 {
3103 /* User explicitly wants ASSIGN'ed variables to be at the same
3104 memory address as the variables when used in non-ASSIGN
3105 contexts. That can make old, arcane, non-standard code
3106 work, but don't try to do it when a pointer wouldn't fit
3107 in the normal variable (take other approach, and warn,
3108 instead). */
3111 {
3115 }
3122 {
3127 }
3130 {
3131 /* xgettext:no-c-format */
3133 FFEBAD_severityWARNING);
3138 }
3139 }
3141 /* Don't use the normal variable's tree for ASSIGN, though mark
3142 it as in the system header (housekeeping). Use an explicit,
3143 specially created sibling that is known to be wide enough
3144 to hold pointers to labels. */
3152 {
3156 }
3157 }
3158 else
3159 {
3161 {
3165 }
3169 }
3180 /* ~~~Make sure Fortran rules respected here */
3187 {
3190 }
3197 {
3201 }
3208 {
3212 }
3219 {
3223 }
3230 {
3234 }
3240 {
3243 ffecomGfrt code;
3244 ffeinfoKindtype rtkt;
3245 ffeinfoKindtype ltkt;
3249 {
3253 {
3257 }
3261 {
3267 {
3271 }
3272 else
3273 {
3276 }
3282 {
3285 }
3286 else
3287 {
3290 }
3296 {
3299 }
3300 else
3301 {
3304 }
3312 }
3317 FFETARGET_charactersizeNONE,
3318 FFEEXPR_contextLET);
3321 FFEINFO_basictypeINTEGER,
3323 FFETARGET_charactersizeNONE,
3324 FFEEXPR_contextLET);
3331 FFETARGET_charactersizeNONE,
3332 FFEEXPR_contextLET);
3336 FFEINFO_basictypeREAL,
3338 FFETARGET_charactersizeNONE,
3339 FFEEXPR_contextLET);
3340 /* We used to call FFECOM_gfrtPOW_DD here,
3341 which passes arguments by reference. */
3343 /* Pass arguments by value. */
3350 FFEINFO_basictypeCOMPLEX,
3352 FFETARGET_charactersizeNONE,
3353 FFEEXPR_contextLET);
3357 FFEINFO_basictypeCOMPLEX,
3359 FFETARGET_charactersizeNONE,
3360 FFEEXPR_contextLET);
3369 }
3378 }
3382 {
3393 /* Fall through. */
3396 }
3402 /* Fall through. */
3408 dest_used);
3410 }
3414 {
3417 }
3423 else
3428 else
3439 tree_type,
3440 args,
3449 {
3451 item
3464 /* Fall through. */
3467 }
3472 {
3474 item
3487 /* Fall through. */
3490 }
3496 {
3498 item
3511 /* Fall through. */
3514 }
3519 {
3521 item
3528 return
3536 /* Fall through. */
3539 }
3547 {
3555 {
3562 /* convert() takes care of converting to the subtype first,
3563 at least in gcc-2.7.2. */
3572 /* Fall through. */
3575 }
3580 /* Fall through. */
3583 }
3611 {
3622 {
3623 tree real_type;
3634 {
3637 }
3638 else
3639 {
3642 }
3644 item
3652 arg2)));
3655 else
3658 }
3661 {
3664 tree left_tree;
3665 tree right_tree;
3666 tree left_length;
3667 tree right_length;
3669 /* f2c run-time functions do the implicit blank-padding for us,
3670 so we don't usually have to implement blank-padding ourselves.
3671 (The exception is when we pass an argument to a separately
3672 compiled statement function -- if we know the arg is not the
3673 same length as the dummy, we must truncate or extend it. If
3674 we "inline" statement functions, that necessity goes away as
3675 well.)
3677 Strip off the CONVERT operators that blank-pad. (Truncation by
3678 CONVERT shouldn't happen here, but it can happen in
3679 assignments.) */
3696 {
3697 left_tree
3700 left_tree);
3701 right_tree
3704 right_tree);
3706 item
3710 left_tree,
3711 integer_one_node),
3714 right_tree,
3715 integer_one_node));
3716 }
3717 else
3718 {
3722 left_length);
3727 item,
3729 integer_zero_node));
3730 }
3732 }
3738 /* Fall through. */
3741 }
3763 /* Fall through. */
3766 }
3768 #if 1
3770 #else
3772 {
3789 }
3792 #endif
3793 }
3795 /* Returns the tree that does the intrinsic invocation.
3797 Note: this function applies only to intrinsics returning
3798 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3799 subroutines. */
3801 static tree
3804 {
3805 tree expr_tree;
3808 ffeinfoBasictype bt;
3809 ffeinfoKindtype kt;
3810 tree tree_type;
3811 tree arg1_type;
3813 tree tempvar;
3816 ffebld arg2;
3817 ffebld arg3;
3818 ffeintrinImp codegen_imp;
3819 ffecomGfrt gfrt;
3831 {
3836 {
3841 {
3845 }
3846 else
3848 }
3849 else
3851 }
3852 else
3855 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3856 args. This is used by the MAX/MIN expansions. */
3859 arg1_type = ffecom_tree_type
3862 else
3864 here. */
3866 /* There are several ways for each of the cases in the following switch
3867 statements to exit (from simplest to use to most complicated):
3869 break; (when expr_tree == NULL)
3871 A standard call is made to the specific intrinsic just as if it had been
3872 passed in as a dummy procedure and called as any old procedure. This
3873 method can produce slower code but in some cases it's the easiest way for
3874 now. However, if a (presumably faster) direct call is available,
3875 that is used, so this is the easiest way in many more cases now.
3877 gfrt = FFECOM_gfrtWHATEVER;
3878 break;
3880 gfrt contains the gfrt index of a library function to call, passing the
3881 argument(s) by value rather than by reference. Used when a more
3882 careful choice of library function is needed than that provided
3883 by the vanilla `break;'.
3885 return expr_tree;
3887 The expr_tree has been completely set up and is ready to be returned
3888 as is. No further actions are taken. Use this when the tree is not
3889 in the simple form for one of the arity_n labels. */
3891 /* For info on how the switch statement cases were written, see the files
3892 enclosed in comments below the switch statement. */
3900 {
3908 {
3914 }
3927 else
3930 return
3937 #if 0
3938 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
3941 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3943 return
3946 ffecom_truth_value
3948 saved_expr1,
3950 ffecom_float_zero_))),
3954 saved_expr1)),
3955 NULL_TREE),
3961 arg1_type,
3962 saved_expr1))),
3963 NULL_TREE)
3964 ))
3965 );
3966 #endif
3971 numbers of large magnitudes. */
3976 ffecom_truth_value
3978 integer_type_node,
3979 saved_expr1,
3980 ffecom_float_zero_)),
3982 tree_type,
3983 saved_expr1,
3984 ffecom_float_half_),
3986 tree_type,
3987 saved_expr1,
3988 ffecom_float_half_))));
3991 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3993 return
3996 ffecom_truth_value
3998 saved_expr1,
4000 ffecom_float_zero_))),
4005 arg1_type,
4006 saved_expr1,
4008 ffecom_float_half_)))),
4009 NULL_TREE),
4015 arg1_type,
4017 ffecom_float_half_),
4018 saved_expr1))),
4019 NULL_TREE))
4020 )
4021 );
4022 #endif
4036 {
4041 integer_one_node),
4043 }
4045 expr_tree,
4046 tempvar);
4049 expr_tree);
4055 return
4059 return
4066 return
4073 {
4074 tree arg1_tree;
4078 return
4083 }
4090 {
4095 }
4124 return
4126 ffecom_truth_value
4128 saved_expr1,
4129 saved_expr2)),
4131 saved_expr1,
4132 saved_expr2),
4136 return
4146 {
4151 }
4158 expr_tree
4161 expr_tree);
4162 expr_tree
4165 expr_tree,
4166 integer_one_node);
4171 saved_expr1,
4172 expr_tree,
4175 #endif
4181 #if 0
4183 #else
4185 #endif
4199 {
4204 }
4214 /* We used to call FFECOM_gfrtALOG10 here. */
4217 /* We used to call FFECOM_gfrtDLOG10 here. */
4229 else
4235 {
4240 expr_tree,
4243 }
4254 else
4260 {
4265 expr_tree,
4268 }
4280 /* We used to call FFECOM_gfrtAMOD here. */
4283 /* We used to call FFECOM_gfrtDMOD here. */
4289 #if 0
4290 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4292 #else
4293 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4295 return
4298 ffecom_truth_value
4300 saved_expr1,
4302 ffecom_float_zero_))),
4304 saved_expr1,
4306 ffecom_float_half_)),
4308 saved_expr1,
4310 ffecom_float_half_))));
4311 #endif
4316 {
4319 saved_expr1
4320 = ffecom_save_tree
4324 expr_tree
4326 ffecom_truth_value
4328 arg2_tree,
4330 integer_zero_node))),
4331 saved_expr1,
4333 /* Make sure SAVE_EXPRs get referenced early enough. */
4334 expr_tree
4337 expr_tree);
4338 }
4346 {
4351 }
4363 {
4368 }
4380 else
4383 return
4431 {
4432 ffetargetLogical1 target_true;
4433 ffetargetLogical1 target_false;
4434 tree true_tree;
4435 tree false_tree;
4441 else
4445 else
4448 return
4450 ffecom_truth_value
4456 integer_one_node),
4460 integer_zero_node))),
4461 false_tree,
4462 true_tree);
4463 }
4466 return
4472 integer_one_node),
4477 {
4480 tree uns_type
4483 expr_tree
4492 uns_type,
4494 integer_zero_node)),
4496 integer_type_node,
4498 arg3_tree))));
4499 /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE. */
4500 expr_tree
4502 ffecom_truth_value
4504 arg3_tree,
4505 integer_zero_node)),
4506 expr_tree,
4508 }
4512 return
4521 {
4525 tree uns_type
4528 expr_tree
4530 ffecom_truth_value
4532 arg2_tree,
4533 integer_zero_node)),
4535 arg1_tree,
4536 arg2_tree),
4541 integer_type_node,
4542 arg2_tree))));
4543 /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds. */
4544 expr_tree
4546 ffecom_truth_value
4549 integer_type_node,
4550 arg2_tree),
4552 expr_tree,
4554 /* Make sure SAVE_EXPRs get referenced early enough. */
4555 expr_tree
4560 expr_tree));
4561 }
4565 {
4571 tree shift_neg;
4572 tree shift_pos;
4573 tree mask_arg1;
4574 tree masked_arg1;
4575 tree uns_type
4578 mask_arg1
4582 arg3_tree);
4583 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4584 mask_arg1
4586 ffecom_truth_value
4588 arg3_tree,
4590 mask_arg1,
4593 masked_arg1
4595 arg1_tree,
4597 mask_arg1));
4599 shift_neg
4605 integer_type_node,
4606 arg2_tree))),
4608 arg1_tree,
4610 arg2_tree,
4611 arg3_tree)));
4612 shift_pos
4615 arg1_tree,
4616 arg2_tree),
4621 integer_type_node,
4622 arg3_tree,
4623 arg2_tree))));
4624 expr_tree
4626 ffecom_truth_value
4628 arg2_tree,
4629 integer_zero_node)),
4630 shift_neg,
4631 shift_pos);
4632 expr_tree
4635 mask_arg1,
4636 arg1_tree),
4639 mask_arg1),
4640 expr_tree));
4641 expr_tree
4643 ffecom_truth_value
4647 integer_type_node,
4648 arg2_tree),
4649 arg3_tree),
4651 arg2_tree,
4652 integer_zero_node))),
4653 arg1_tree,
4654 expr_tree);
4655 /* Make sure SAVE_EXPRs get referenced early enough. */
4656 expr_tree
4663 mask_arg1),
4666 masked_arg1),
4667 expr_tree))));
4668 expr_tree
4671 arg3_tree),
4672 expr_tree);
4673 }
4677 {
4680 expr_tree
4684 arg1_tree));
4685 }
4689 {
4690 tree arg1_tree;
4691 tree arg2_tree;
4692 tree arg3_tree;
4694 tree arg4_tree;
4695 tree arg4_type;
4697 tree arg5_tree;
4698 tree prep_arg1;
4699 tree prep_arg4;
4700 tree arg5_plus_arg3;
4715 prep_arg1
4719 arg1_tree,
4720 arg2_tree),
4724 arg4_type,
4725 convert
4727 integer_zero_node)),
4728 arg3_tree))),
4729 arg5_tree);
4730 arg5_plus_arg3
4732 arg5_tree,
4733 arg3_tree));
4734 prep_arg4
4738 integer_zero_node)),
4739 arg5_plus_arg3);
4740 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4741 prep_arg4
4743 ffecom_truth_value
4745 arg5_plus_arg3,
4748 prep_arg4,
4750 prep_arg4
4752 arg4_tree,
4754 prep_arg4,
4758 arg4_type,
4759 convert
4761 integer_zero_node)),
4762 arg5_tree))));
4763 prep_arg1
4765 prep_arg1,
4766 prep_arg4);
4767 /* Fix up (twice), because LSHIFT_EXPR above
4768 can't shift over TYPE_SIZE. */
4769 prep_arg1
4771 ffecom_truth_value
4773 arg3_tree,
4775 integer_zero_node))),
4776 prep_arg1,
4777 arg4_tree);
4778 prep_arg1
4780 ffecom_truth_value
4782 arg3_tree,
4785 prep_arg1,
4786 arg1_tree);
4787 expr_tree
4789 arg4_tree,
4790 prep_arg1);
4791 /* Make sure SAVE_EXPRs get referenced early enough. */
4792 expr_tree
4794 arg1_tree,
4796 arg3_tree,
4798 arg5_tree,
4800 arg5_plus_arg3,
4801 expr_tree))));
4802 expr_tree
4804 arg4_tree,
4805 expr_tree);
4807 }
4817 /* extern int xargc; i__1 = xargc - 1; */
4819 ffecom_tree_xargc_,
4821 integer_one_node));
4826 {
4827 tree arg1_tree;
4828 tree arg2_tree;
4829 tree arg3_tree;
4835 arg1_tree);
4837 /* Pass procedure as a pointer to it, anything else by value. */
4840 else
4843 arg2_tree);
4847 else
4854 expr_tree
4857 FALSE,
4859 NULL_TREE :
4860 tree_type),
4861 arg1_tree,
4866 expr_tree
4869 expr_tree));
4870 }
4874 {
4875 tree arg1_tree;
4876 tree arg2_tree;
4877 tree arg3_tree;
4883 arg1_tree);
4885 /* Pass procedure as a pointer to it, anything else by value. */
4888 else
4891 arg2_tree);
4895 else
4902 expr_tree
4905 FALSE,
4906 NULL_TREE,
4907 arg1_tree,
4912 expr_tree
4915 expr_tree));
4916 }
4927 {
4929 tree arg1_tree;
4930 tree arg2_tree;
4936 else
4943 expr_tree
4946 FALSE,
4947 NULL_TREE,
4948 arg1_tree,
4953 expr_tree
4956 expr_tree));
4957 }
4966 build_pointer_type
4968 integer_zero_node));
4970 return
4973 FALSE,
4974 void_type_node,
4975 expr_tree,
4982 else
4990 {
4992 tree arg1_tree;
4994 tree arg2_tree;
4995 tree arg3_tree;
5001 else
5013 FALSE,
5014 NULL_TREE,
5015 arg1_tree,
5021 expr_tree));
5022 }
5027 {
5029 tree arg1_tree;
5030 tree arg2_tree;
5031 tree arg3_tree;
5039 else
5049 FALSE,
5050 NULL_TREE,
5051 arg1_tree,
5057 expr_tree));
5058 }
5063 {
5064 tree arg1_tree;
5065 tree arg2_tree;
5067 tree arg3_tree;
5073 arg1_tree);
5078 else
5089 FALSE,
5090 NULL_TREE,
5091 arg1_tree,
5097 expr_tree));
5098 }
5102 {
5103 tree arg1_tree;
5104 tree arg2_tree;
5105 tree arg3_tree;
5111 arg1_tree);
5118 else
5126 FALSE,
5127 NULL_TREE,
5128 arg1_tree,
5134 expr_tree));
5135 }
5136 }
5140 {
5141 tree arg1_tree;
5142 tree arg2_tree;
5143 tree arg3_tree;
5149 arg1_tree);
5155 arg2_tree);
5159 else
5167 FALSE,
5168 NULL_TREE,
5169 arg1_tree,
5175 expr_tree));
5176 }
5177 }
5182 {
5184 tree arg1_tree;
5185 tree arg2_tree;
5190 ffecom_f2c_longint_type_node :
5191 ffecom_f2c_integer_type_node),
5195 arg2_tree);
5203 expr_tree
5206 FALSE,
5207 NULL_TREE,
5208 arg1_tree,
5212 }
5217 /* Arg defaults to 0 (normal random case) */
5218 {
5219 tree arg1_tree;
5223 else
5226 arg1_tree);
5229 arg1_tree);
5234 FALSE,
5236 ffecom_f2c_integer_type_node :
5237 ffecom_f2c_real_type_node),
5238 arg1_tree,
5242 }
5247 {
5248 tree arg1_tree;
5249 tree arg2_tree;
5255 arg1_tree);
5259 else
5264 FALSE,
5265 NULL_TREE,
5268 TRUE,
5273 expr_tree));
5274 }
5275 }
5280 {
5281 tree arg1_tree;
5285 expr_tree
5288 FALSE,
5289 NULL_TREE,
5290 NULL_TREE,
5294 expr_tree
5297 expr_tree));
5298 }
5303 {
5304 tree arg1_tree;
5305 tree result_tree;
5313 FALSE,
5314 NULL_TREE,
5317 TRUE,
5321 expr_tree));
5322 }
5325 /* Straightforward calls of libf2c routines: */
5402 }
5411 tree_type,
5416 /* See bottom of this file for f2c transforms used to determine
5417 many of the above implementations. The info seems to confuse
5418 Emacs's C mode indentation, which is why it's been moved to
5419 the bottom of this source file. */
5420 }
5422 /* For power (exponentiation) where right-hand operand is type INTEGER,
5423 generate in-line code to do it the fast way (which, if the operand
5424 is a constant, might just mean a series of multiplies). */
5426 static tree
5428 {
5440 {
5448 {
5449 /* Reciprocal of integer is either 0, -1, or 1, so after
5450 calculating that (which we leave to the back end to do
5451 or not do optimally), don't bother with any multiplying. */
5455 l,
5458 rtype,
5459 r);
5462 result);
5463 }
5465 /* Generate appropriate series of multiplies, preceded
5466 by divide if the exponent is negative. */
5471 {
5474 l,
5484 r,
5485 integer_one_node));
5488 l,
5489 l);
5490 }
5491 }
5494 {
5496 {
5499 else
5501 result,
5502 l);
5503 }
5506 r,
5507 integer_one_node);
5514 l,
5515 l);
5516 }
5518 }
5520 /* Though rhs isn't a constant, in-line code cannot be expanded
5521 while transforming dummies
5522 because the back end cannot be easily convinced to generate
5523 stores (MODIFY_EXPR), handle temporaries, and so on before
5524 all the appropriate rtx's have been generated for things like
5525 dummy args referenced in rhs -- which doesn't happen until
5526 store_parm_decls() is called (expand_function_start, I believe,
5527 does the actual rtx-stuffing of PARM_DECLs).
5529 So, in this case, let the caller generate the call to the
5530 run-time-library function to evaluate the power for us. */
5535 /* Right-hand operand not a constant, expand in-line code to figure
5536 out how to do the multiplies, &c.
5538 The returned expression is expressed this way in GNU C, where l and
5539 r are the "inputs":
5541 ({ typeof (r) rtmp = r;
5542 typeof (l) ltmp = l;
5543 typeof (l) result;
5545 if (rtmp == 0)
5546 result = 1;
5547 else
5548 {
5549 if ((basetypeof (l) == basetypeof (int))
5550 && (rtmp < 0))
5551 {
5552 result = ((typeof (l)) 1) / ltmp;
5553 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5554 result = -result;
5555 }
5556 else
5557 {
5558 result = 1;
5559 if ((basetypeof (l) != basetypeof (int))
5560 && (rtmp < 0))
5561 {
5562 ltmp = ((typeof (l)) 1) / ltmp;
5563 rtmp = -rtmp;
5564 if (rtmp < 0)
5565 {
5566 rtmp = -(rtmp >> 1);
5567 ltmp *= ltmp;
5568 }
5569 }
5570 for (;;)
5571 {
5572 if (rtmp & 1)
5573 result *= ltmp;
5574 if ((rtmp >>= 1) == 0)
5575 break;
5576 ltmp *= ltmp;
5577 }
5578 }
5579 }
5580 result;
5581 })
5583 Note that some of the above is compile-time collapsable, such as
5584 the first part of the if statements that checks the base type of
5585 l against int. The if statements are phrased that way to suggest
5586 an easy way to generate the if/else constructs here, knowing that
5587 the back end should (and probably does) eliminate the resulting
5588 dead code (either the int case or the non-int case), something
5589 it couldn't do without the redundant phrasing, requiring explicit
5590 dead-code elimination here, which would be kind of difficult to
5591 read. */
5593 {
5594 tree rtmp;
5595 tree ltmp;
5596 tree divide;
5597 tree basetypeof_l_is_int;
5598 tree se;
5599 tree t;
5601 basetypeof_l_is_int
5618 else
5622 rtmp,
5623 r));
5625 ltmp,
5626 l));
5629 rtmp,
5633 result,
5637 {
5639 rtmp,
5641 integer_zero_node)),
5644 result,
5645 ffecom_tree_divide_
5648 ltmp,
5650 divide)));
5654 ltmp,
5656 integer_zero_node)),
5659 rtype,
5661 rtype,
5662 rtmp),
5664 integer_one_node)),
5666 integer_zero_node)))),
5669 result,
5671 ltype,
5672 result)));
5675 }
5677 result,
5681 ffecom_truth_value_invert
5684 rtmp,
5686 integer_zero_node)))),
5689 ltmp,
5690 ffecom_tree_divide_
5693 ltmp,
5695 divide)));
5697 rtmp,
5699 rtmp)));
5702 rtmp,
5706 rtmp,
5709 rtype,
5710 rtmp,
5711 integer_one_node))));
5713 ltmp,
5715 ltmp,
5716 ltmp)));
5722 rtmp,
5726 result,
5728 result,
5729 ltmp)));
5732 ffecom_truth_value
5734 rtmp,
5736 rtype,
5737 rtmp,
5738 integer_one_node))));
5740 ltmp,
5742 ltmp,
5743 ltmp)));
5754 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5757 {
5758 /* Make a BIND_EXPR for the BLOCK already made. */
5761 /* Remove the block from the tree at this point.
5762 It gets put back at the proper place
5763 when the BIND_EXPR is expanded. */
5765 }
5766 else
5768 }
5771 }
5773 /* ffecom_expr_transform_ -- Transform symbols in expr
5775 ffebld expr; // FFE expression.
5776 ffecom_expr_transform_ (expr);
5778 Recursive descent on expr while transforming any untransformed SYMTERs. */
5780 static void
5782 {
5783 tree t;
5784 ffesymbol s;
5786 tail_recurse:
5792 {
5800 {
5803 DIMENSION expr? */
5804 }
5814 }
5817 {
5829 }
5832 }
5834 /* Make a type based on info in live f2c.h file. */
5836 static void
5838 {
5840 {
5863 ? signed_char_type_node
5897 }
5902 }
5904 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5905 given size. */
5907 static void
5910 {
5912 tree t;
5917 {
5921 }
5922 }
5924 /* Finish up globals after doing all program units in file
5926 Need to handle only uninitialized COMMON areas. */
5928 static ffeglobal
5930 {
5931 tree cbtype;
5932 tree cbt;
5933 tree size;
5948 /* Give the array a size now. */
5956 integer_zero_node,
5957 size);
5968 }
5970 /* Finish up any untransformed symbols. */
5972 static ffesymbol
5974 {
5978 /* It's easy to know to transform an untransformed symbol, to make sure
5979 we put out debugging info for it. But COMMON variables, unlike
5980 EQUIVALENCE ones, aren't given declarations in addition to the
5981 tree expressions that specify offsets, because COMMON variables
5982 can be referenced in the outer scope where only dummy arguments
5983 (PARM_DECLs) should really be seen. To be safe, just don't do any
5984 VAR_DECLs for COMMON variables when we transform them for real
5985 use, and therefore we do all the VAR_DECL creating here. */
5988 {
5993 /* Not transformed, and not CHARACTER*(*), and not a dummy
5994 argument, which can happen only if the entry point names
5995 it "rides in on" are all invalidated for other reasons. */
5997 }
6001 {
6002 /* This isn't working, at least for dbxout. The .s file looks
6003 okay to me (burley), but in gdb 4.9 at least, the variables
6004 appear to reside somewhere outside of the common area, so
6005 it doesn't make sense to mislead anyone by generating the info
6006 on those variables until this is fixed. NOTE: Same problem
6007 with EQUIVALENCE, sadly...see similar #if later. */
6010 }
6013 }
6015 /* Append underscore(s) to name before calling get_identifier. "us"
6016 is nonzero if the name already contains an underscore and thus
6017 needs two underscores appended. */
6019 static tree
6021 {
6024 tree id;
6038 }
6040 /* Decide whether to append underscore to name before calling
6041 get_identifier. */
6043 static tree
6045 {
6049 /* If name is a built-in name, just return it as is. */
6053 #if FFETARGET_isENFORCED_MAIN_NAME
6055 #else
6057 #endif
6066 }
6068 /* Decide whether to append underscore to internal name before calling
6069 get_identifier.
6071 This is for non-external, top-function-context names only. Transform
6072 identifier so it doesn't conflict with the transformed result
6073 of using a _different_ external name. E.g. if "CALL FOO" is
6074 transformed into "FOO_();", then the variable in "FOO_ = 3"
6075 must be transformed into something that does not conflict, since
6076 these two things should be independent.
6078 The transformation is as follows. If the name does not contain
6079 an underscore, there is no possible conflict, so just return.
6080 If the name does contain an underscore, then transform it just
6081 like we transform an external identifier. */
6083 static tree
6085 {
6086 /* If name does not contain an underscore, just return it as is. */
6093 name);
6094 }
6096 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6098 tree t;
6099 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6100 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6101 ffesymbol_kindtype(s));
6103 Call after setting up containing function and getting trees for all
6104 other symbols. */
6106 static tree
6108 {
6110 tree type;
6111 tree func;
6112 tree result;
6120 /* For now, we don't have a handy pointer to where the sfunc is actually
6121 defined, though that should be easy to add to an ffesymbol. (The
6122 token/where info available might well point to the place where the type
6123 of the sfunc is declared, especially if that precedes the place where
6124 the sfunc itself is defined, which is typically the case.) We should
6125 put out a null pointer rather than point somewhere wrong, but I want to
6126 see how it works at this point. */
6131 /* Pretransform the expression so any newly discovered things belong to the
6132 outer program unit, not to the statement function. */
6136 /* Make sure no recursive invocation of this fn (a specific case of failing
6137 to pretransform an sfunc's expression, i.e. where its expression
6138 references another untransformed sfunc) happens. */
6147 else
6148 {
6152 error. */
6153 }
6160 /* We don't worry about COMPLEX return values here, because this is
6161 entirely internal to our code, and gcc has the ability to return COMPLEX
6162 directly as a value. */
6166 tree type;
6178 }
6179 else
6189 {
6191 {
6193 tree result_length;
6204 }
6205 else
6206 {
6214 }
6215 }
6232 }
6236 {
6238 }
6240 static tree
6242 {
6249 }
6251 /* Return initialize-to-zero expression for this VAR_DECL. */
6253 /* A somewhat evil way to prevent the garbage collector
6254 from collecting 'tree' structures. */
6255 #define NUM_TRACKED_CHUNK 63
6257 {
6260 };
6263 void
6265 {
6270 {
6273 }
6275 {
6276 /* Need to allocate a new block. */
6284 }
6285 }
6287 static tree
6289 {
6290 tree init;
6295 {
6298 }
6306 {
6310 }
6311 else
6312 {
6315 }
6318 }
6320 static tree
6323 {
6324 tree expr_tree;
6325 tree length_tree;
6328 {
6331 (ffebld_constant_character1
6333 {
6336 }
6340 (ffebld_constant_character1
6354 {
6357 }
6360 {
6363 }
6365 expr_tree
6368 expr_tree);
6369 expr_tree
6372 expr_tree,
6373 integer_one_node);
6379 *maybe_tree
6380 = ffecom_truth_value
6382 length_tree,
6383 ffecom_f2c_ftnlen_zero_node));
6389 {
6392 }
6394 maybe_tree);
6397 {
6398 tree maybe_left;
6399 tree maybe_right;
6400 tree expr_left;
6401 tree expr_right;
6408 maybe_left,
6409 maybe_right);
6411 maybe_left,
6412 expr_left,
6413 expr_right);
6415 }
6420 }
6421 }
6423 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6425 tree length_arg;
6426 ffebld expr;
6427 length_arg = ffecom_intrinsic_len_ (expr);
6429 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6430 subexpressions by constructing the appropriate tree for the
6431 length-of-character-text argument in a calling sequence. */
6433 static tree
6435 {
6436 ffetargetCharacter1 val;
6437 tree length;
6440 {
6448 {
6450 tree item;
6454 {
6457 }
6459 {
6462 else
6463 {
6466 }
6467 }
6472 }
6480 {
6481 ffebld start;
6482 ffebld end;
6484 tree start_tree;
6485 tree end_tree;
6499 {
6501 ;
6502 else
6503 {
6506 }
6507 }
6508 else
6509 {
6514 {
6517 }
6520 {
6522 ffecom_f2c_ftnlen_one_node,
6524 ffecom_f2c_ftnlen_type_node,
6525 length,
6526 start_tree));
6527 }
6528 else
6529 {
6534 {
6537 }
6540 ffecom_f2c_ftnlen_one_node,
6542 ffecom_f2c_ftnlen_type_node,
6544 }
6545 }
6546 }
6550 length
6566 }
6571 }
6573 /* Handle CHARACTER assignments.
6575 Generates code to do the assignment. Used by ordinary assignment
6576 statement handler ffecom_let_stmt and by statement-function
6577 handler to generate code for a statement function. */
6579 static void
6582 {
6583 ffecomConcatList_ catlist;
6584 tree source_length;
6585 tree source_tree;
6586 tree expr_tree;
6595 /* Source might be an opCONVERT, which just means it is a different size
6596 than the destination. Since the underlying implementation here handles
6597 that (directly or via the s_copy or s_cat run-time-library functions),
6598 we don't need the "convenience" of an opCONVERT that tells us to
6599 truncate or blank-pad, particularly since the resulting implementation
6600 would probably be slower than otherwise. */
6607 {
6638 {
6639 dest_tree
6643 dest_tree);
6644 dest_tree
6648 dest_tree,
6649 integer_one_node);
6650 source_tree
6654 source_tree);
6655 source_tree
6659 source_tree,
6660 integer_one_node);
6667 }
6685 }
6687 /* Heavy-duty concatenation. */
6689 {
6692 tree lengths;
6693 tree items;
6694 tree length_array;
6695 tree item_array;
6696 tree citem;
6697 tree clength;
6699 {
6700 tree hook;
6708 }
6711 {
6716 {
6719 }
6721 items
6726 item_array,
6728 citem),
6729 items);
6730 lengths
6735 length_array,
6737 clength),
6738 lengths);
6739 }
6746 items));
6751 lengths));
6753 = build_tree_list
6765 }
6768 }
6770 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6772 ffecomGfrt ix;
6773 ffecom_make_gfrt_(ix);
6775 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6776 for the indicated run-time routine (ix). */
6778 static void
6780 {
6781 tree t;
6782 tree ttype;
6785 {
6850 }
6855 ttype);
6861 /* Sanity check: A function that's const cannot be volatile. */
6865 /* Sanity check: A function that's const cannot return complex. */
6874 }
6876 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
6878 static void
6880 {
6885 }
6887 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
6888 the member so debugger will see it. Otherwise nobody should be
6889 referencing the member. */
6891 static void
6893 {
6894 ffesymbol s;
6895 tree t;
6896 tree mt;
6897 tree type;
6916 type);
6933 }
6935 /* Prepare source expression for assignment into a destination perhaps known
6936 to be of a specific size. */
6938 static void
6940 {
6941 ffecomConcatList_ catlist;
6944 tree ltmp;
6945 tree itmp;
6955 {
6956 ltmp
6959 itmp
6966 }
6974 {
6977 }
6978 }
6980 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
6982 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
6983 (which generates their trees) and then their trees get push_parm_decl'd.
6985 The second arg is TRUE if the dummies are for a statement function, in
6986 which case lengths are not pushed for character arguments (since they are
6987 always known by both the caller and the callee, though the code allows
6988 for someday permitting CHAR*(*) stmtfunc dummies). */
6990 static void
6992 {
6993 ffebld dummy;
6994 ffebld dumlist;
6995 ffesymbol s;
6996 tree parm;
7000 /* First push the parms corresponding to actual dummy "contents". */
7003 {
7006 {
7013 }
7018 {
7022 }
7025 }
7027 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7030 {
7033 {
7037 NOTHING! */
7041 }
7047 length param. */
7054 }
7057 }
7059 /* ffecom_start_progunit_ -- Beginning of program unit
7061 Does GNU back end stuff necessary to teach it about the start of its
7062 equivalent of a Fortran program unit. */
7064 static void
7066 {
7068 ffebld arglist;
7072 ffeinfoBasictype bt;
7073 ffeinfoKindtype kt;
7074 ffeglobal g;
7075 ffeglobalType gt;
7080 bool multi
7081 = altentries
7095 {
7121 {
7127 }
7137 else
7144 else
7159 else
7167 /* Fall through. */
7176 }
7179 {
7182 }
7183 #if FFETARGET_isENFORCED_MAIN
7186 #endif
7187 else
7191 type,
7201 {
7203 }
7205 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7206 exec-transitioning needs current_function_decl to be filled in. So we
7207 do these things in two phases. */
7211 ffecom_which_entrypoint_decl_
7215 integer_type_node);
7217 }
7220 || cmplxfunc
7223 tree type;
7224 tree length;
7230 else
7235 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7239 else
7248 else
7252 {
7255 }
7256 }
7259 {
7262 else
7265 }
7271 /* Disallow temp vars at this level. */
7277 /* This handles any symbols still untransformed, in case -g specified.
7278 This used to be done in ffecom_finish_progunit, but it turns out to
7279 be necessary to do it here so that statement functions are
7280 expanded before code. But don't bother for BLOCK DATA. */
7284 }
7286 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7288 ffesymbol s;
7289 ffecom_sym_transform_(s);
7291 The ffesymbol_hook info for s is updated with appropriate backend info
7292 on the symbol. */
7294 static ffesymbol
7296 {
7300 ffeinfoBasictype bt;
7301 ffeinfoKindtype kt;
7302 ffeglobal g;
7306 /* Must ensure special ASSIGN variables are declared at top of outermost
7307 block, else they'll end up in the innermost block when their first
7308 ASSIGN is seen, which leaves them out of scope when they're the
7309 subject of a GOTO or I/O statement.
7311 We make this variable even if -fugly-assign. Just let it go unused,
7312 in case it turns out there are cases where we really want to use this
7313 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7321 {
7324 }
7325 else
7326 {
7331 }
7341 {
7344 {
7348 /* Before 0.4, this could be ENTITY/DUMMY, but see
7349 ffestu_sym_end_transition -- no longer true (in particular, if
7350 it could be an ENTITY, it _will_ be made one, so that
7351 possibility won't come through here). So we never make length
7352 arg for CHARACTER type. */
7356 ffecom_tree_ptr_to_subr_type);
7370 {
7373 }
7396 /* Fall through. */
7399 }
7404 {
7407 /* ~~Debugging info needed? */
7415 {
7417 tree type;
7421 {
7424 }
7429 {
7432 }
7437 ffestorag est;
7438 tree et;
7439 ffetargetOffset offset;
7456 /* (t_type *) (((char *) &et) + offset) */
7461 et));
7463 t,
7466 t);
7470 }
7471 else
7472 {
7473 tree initexpr;
7478 type);
7482 #ifdef FFECOM_sizeMAXSTACKITEM
7485 #endif
7487 && (ffecom_primary_entry_kind_
7491 else
7497 /* Keep -Wunused from complaining about var if it
7498 is used as sfunc arg or DATA implied-DO. */
7505 {
7508 else
7510 }
7513 else
7519 {
7523 }
7524 }
7525 }
7533 it (& length). */
7538 }
7543 it. */
7547 }
7549 {
7552 }
7555 {
7558 ffecom_multi_retval_);
7563 }
7577 {
7578 tree type;
7579 ffebld dl;
7580 ffebld dim;
7581 tree low;
7582 tree high;
7583 tree old_sizes;
7588 {
7591 context; get it later. */
7593 }
7596 }
7597 else
7610 {
7618 else
7623 {
7624 /* Used to just do high=low. But for ffecom_tree_
7625 canonize_ref_, it probably is important to correctly
7626 assess the size. E.g. given COMPLEX C(*),CFUNC and
7627 C(2)=CFUNC(C), overlap can happen, while it can't
7628 for, say, C(1)=CFUNC(C(2)). */
7629 /* Even more recently used to set to INT_MAX, but that
7630 broke when some overflow checking went into the back
7631 end. Now we just leave the upper bound unspecified. */
7633 }
7634 else
7637 /* Determine whether array is conditionally adjustable,
7638 to decide whether back-end magic is needed.
7640 Normally the front end uses the back-end function
7641 variable_size to wrap SAVE_EXPR's around expressions
7642 affecting the size/shape of an array so that the
7643 size/shape info doesn't change during execution
7644 of the compiled code even though variables and
7645 functions referenced in those expressions might.
7647 variable_size also makes sure those saved expressions
7648 get evaluated immediately upon entry to the
7649 compiled procedure -- the front end normally doesn't
7650 have to worry about that.
7652 However, there is a problem with this that affects
7653 g77's implementation of entry points, and that is
7654 that it is _not_ true that each invocation of the
7655 compiled procedure is permitted to evaluate
7656 array size/shape info -- because it is possible
7657 that, for some invocations, that info is invalid (in
7658 which case it is "promised" -- i.e. a violation of
7659 the Fortran standard -- that the compiled code
7660 won't reference the array or its size/shape
7661 during that particular invocation).
7663 To phrase this in C terms, consider this gcc function:
7665 void foo (int *n, float (*a)[*n])
7666 {
7667 // a is "pointer to array ...", fyi.
7668 }
7670 Suppose that, for some invocations, it is permitted
7671 for a caller of foo to do this:
7673 foo (NULL, NULL);
7675 Now the _written_ code for foo can take such a call
7676 into account by either testing explicitly for whether
7677 (a == NULL) || (n == NULL) -- presumably it is
7678 not permitted to reference *a in various fashions
7679 if (n == NULL) I suppose -- or it can avoid it by
7680 looking at other info (other arguments, static/global
7681 data, etc.).
7683 However, this won't work in gcc 2.5.8 because it'll
7684 automatically emit the code to save the "*n"
7685 expression, which'll yield a NULL dereference for
7686 the "foo (NULL, NULL)" call, something the code
7687 for foo cannot prevent.
7689 g77 definitely needs to avoid executing such
7690 code anytime the pointer to the adjustable array
7691 is NULL, because even if its bounds expressions
7692 don't have any references to possible "absent"
7693 variables like "*n" -- say all variable references
7694 are to COMMON variables, i.e. global (though in C,
7695 local static could actually make sense) -- the
7696 expressions could yield other run-time problems
7697 for allowably "dead" values in those variables.
7699 For example, let's consider a more complicated
7700 version of foo:
7702 extern int i;
7703 extern int j;
7705 void foo (float (*a)[i/j])
7706 {
7707 ...
7708 }
7710 The above is (essentially) quite valid for Fortran
7711 but, again, for a call like "foo (NULL);", it is
7712 permitted for i and j to be undefined when the
7713 call is made. If j happened to be zero, for
7714 example, emitting the code to evaluate "i/j"
7715 could result in a run-time error.
7717 Offhand, though I don't have my F77 or F90
7718 standards handy, it might even be valid for a
7719 bounds expression to contain a function reference,
7720 in which case I doubt it is permitted for an
7721 implementation to invoke that function in the
7722 Fortran case involved here (invocation of an
7723 alternate ENTRY point that doesn't have the adjustable
7724 array as one of its arguments).
7726 So, the code that the compiler would normally emit
7727 to preevaluate the size/shape info for an
7728 adjustable array _must not_ be executed at run time
7729 in certain cases. Specifically, for Fortran,
7730 the case is when the pointer to the adjustable
7731 array == NULL. (For gnu-ish C, it might be nice
7732 for the source code itself to specify an expression
7733 that, if TRUE, inhibits execution of the code. Or
7734 reverse the sense for elegance.)
7736 (Note that g77 could use a different test than NULL,
7737 actually, since it happens to always pass an
7738 integer to the called function that specifies which
7739 entry point is being invoked. Hmm, this might
7740 solve the next problem.)
7742 One way a user could, I suppose, write "foo" so
7743 it works is to insert COND_EXPR's for the
7744 size/shape info so the dangerous stuff isn't
7745 actually done, as in:
7747 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7748 {
7749 ...
7750 }
7752 The next problem is that the front end needs to
7753 be able to tell the back end about the array's
7754 decl _before_ it tells it about the conditional
7755 expression to inhibit evaluation of size/shape info,
7756 as shown above.
7758 To solve this, the front end needs to be able
7759 to give the back end the expression to inhibit
7760 generation of the preevaluation code _after_
7761 it makes the decl for the adjustable array.
7763 Until then, the above example using the COND_EXPR
7764 doesn't pass muster with gcc because the "(a == NULL)"
7765 part has a reference to "a", which is still
7766 undefined at that point.
7768 g77 will therefore use a different mechanism in the
7769 meantime. */
7780 low,
7781 ffecom_integer_zero_node);
7786 high,
7787 ffecom_integer_zero_node);
7788 #endif
7790 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7791 probably. Fixes 950302-1.f. */
7796 /* ~~~Similarly, this fixes dumb0.f. The C front end
7797 does this, which is why dumb0.c would work. */
7802 type
7803 = build_array_type
7808 }
7811 {
7814 }
7818 {
7821 }
7826 /* If this arg is present in every entry point's list of
7827 dummy args, then we're done. */
7833 #if 1
7835 /* If variable_size in stor-layout has been called during
7836 the above, then get_pending_sizes should have the
7837 yet-to-be-evaluated saved expressions pending.
7838 Make the whole lot of them get emitted, conditionally
7839 on whether the array decl ("t" above) is not NULL. */
7841 {
7843 tree tem;
7848 {
7853 else
7854 sizes
7857 temv,
7858 sizes);
7859 }
7862 {
7863 sizes
7867 integer_type_node,
7868 t,
7869 null_pointer_node),
7870 sizes,
7872 integer_zero_node));
7875 sizes
7877 }
7881 }
7883 #else
7884 #if 0
7890 t,
7891 null_pointer_node);
7892 #else
7893 #if 0
7897 {
7903 }
7904 #endif
7905 #endif
7906 #endif
7907 }
7911 {
7912 ffesymbol cs;
7913 ffeglobal cg;
7914 tree ct;
7916 tree type;
7920 {
7923 }
7931 else
7938 else
7939 {
7940 ffetargetOffset offset;
7941 ffestorag cst;
7952 /* (t_type *) (((char *) &ct) + offset) */
7957 ct));
7959 t,
7962 t);
7966 }
7967 }
7979 /* Fall through. */
7983 }
7988 {
8002 {
8005 }
8010 else
8015 t);
8037 else
8038 t = build_pointer_type
8043 t);
8056 decls. */
8060 /* Fall through. */
8064 }
8069 {
8083 {
8086 }
8090 ffecom_tree_subr_type);
8111 ffecom_tree_ptr_to_subr_type);
8119 decls. */
8123 /* Fall through. */
8127 }
8132 {
8151 /* Fall through. */
8155 }
8160 {
8171 ffecom_tree_blockdata_type);
8194 /* Fall through. */
8198 }
8203 {
8223 /* Fall through. */
8227 }
8232 {
8251 /* Fall through. */
8255 }
8260 {
8280 /* Fall through. */
8284 }
8289 /* Fall through. */
8293 }
8303 }
8305 /* Transform into ASSIGNable symbol.
8307 Symbol has already been transformed, but for whatever reason, the
8308 resulting decl_tree has been deemed not usable for an ASSIGN target.
8309 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8310 another local symbol of type void * and stuff that in the assign_tree
8311 argument. The F77/F90 standards allow this implementation. */
8313 static ffesymbol
8315 {
8321 {
8324 }
8325 else
8326 {
8331 }
8341 {
8343 /* Unlike for regular vars, SAVE status is easy to determine for
8344 ASSIGNed vars, since there's no initialization, there's no
8345 effective storage association (so "SAVE J" does not apply to
8346 K even given "EQUIVALENCE (J,K)"), there's no size issue
8347 to worry about, etc. */
8352 else
8361 /* Note that twinning a DUMMY means the caller won't see
8362 the ASSIGNed value. But both F77 and F90 allow implementations
8363 to do this, i.e. disallow Fortran code that would try and
8364 take advantage of actually putting a label into a variable
8365 via a dummy argument (or any other storage association, for
8366 that matter). */
8373 }
8384 }
8386 /* Implement COMMON area in back end.
8388 Because COMMON-based variables can be referenced in the dimension
8389 expressions of dummy (adjustable) arrays, and because dummies
8390 (in the gcc back end) need to be put in the outer binding level
8391 of a function (which has two binding levels, the outer holding
8392 the dummies and the inner holding the other vars), special care
8393 must be taken to handle COMMON areas.
8395 The current strategy is basically to always tell the back end about
8396 the COMMON area as a top-level external reference to just a block
8397 of storage of the master type of that area (e.g. integer, real,
8398 character, whatever -- not a structure). As a distinct action,
8399 if initial values are provided, tell the back end about the area
8400 as a top-level non-external (initialized) area and remember not to
8401 allow further initialization or expansion of the area. Meanwhile,
8402 if no initialization happens at all, tell the back end about
8403 the largest size we've seen declared so the space does get reserved.
8404 (This function doesn't handle all that stuff, but it does some
8405 of the important things.)
8407 Meanwhile, for COMMON variables themselves, just keep creating
8408 references like *((float *) (&common_area + offset)) each time
8409 we reference the variable. In other words, don't make a VAR_DECL
8410 or any kind of component reference (like we used to do before 0.4),
8411 though we might do that as well just for debugging purposes (and
8412 stuff the rtl with the appropriate offset expression). */
8414 static void
8416 {
8419 tree cbt;
8420 tree cbtype;
8421 tree init;
8422 tree high;
8431 /* First update the size of the area in global terms. */
8440 /* If we already have declared this common block for a previous program
8441 unit, and either we already initialized it or we don't have new
8442 initialization for it, just return what we have without changing it. */
8445 && (!is_init
8447 {
8450 }
8452 /* Process inits. */
8455 {
8457 {
8458 ffebld sexp;
8460 /* Set the padding for the expression, so ffecom_expr
8461 knows to insert that many zeros. */
8463 {
8479 }
8487 }
8488 }
8489 else
8491 }
8492 else
8495 /* cbtype must be permanently allocated! */
8497 /* Allocate the MAX of the areas so far, seen filewide. */
8505 integer_zero_node,
8506 high));
8507 else
8511 {
8512 cbt
8515 cbtype);
8518 }
8519 else
8520 {
8523 }
8533 /* Make sure that any type can live in COMMON and be referenced
8534 without getting a bus error. We could pick the most restrictive
8535 alignment of all entities actually placed in the COMMON, but
8536 this seems easy enough. */
8550 {
8556 }
8563 }
8565 /* Make master area for local EQUIVALENCE. */
8567 static void
8569 {
8570 tree eqt;
8571 tree eqtype;
8572 tree init;
8573 tree high;
8583 /* Process inits. */
8586 {
8588 {
8589 ffebld sexp;
8591 /* Set the padding for the expression, so ffecom_expr
8592 knows to insert that many zeros. */
8594 {
8610 }
8615 }
8616 else
8618 }
8621 else
8627 eqst);
8635 ffecom_integer_zero_node,
8636 high));
8640 ffesymbol_text
8642 eqtype);
8645 || ffecom_member_namelisted_
8646 #ifdef FFECOM_sizeMAXSTACKITEM
8648 #endif
8653 else
8660 else
8665 /* Make sure that any type can live in EQUIVALENCE and be referenced
8666 without getting a bus error. We could pick the most restrictive
8667 alignment of all entities actually placed in the EQUIVALENCE, but
8668 this seems easy enough. */
8682 {
8687 }
8693 eqst);
8694 }
8696 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8698 static tree
8700 {
8701 tree nmlt;
8703 tree nmlinits;
8704 tree nameinit;
8705 tree varsinit;
8706 tree nvarsinit;
8707 tree field;
8708 tree high;
8714 mynumber++),
8715 nmltype);
8721 /* Process inits. */
8731 = build_type_variant
8732 (build_array_type
8735 ffecom_f2c_ftnlen_one_node,
8736 high)),
8741 nameinit);
8745 varsinit);
8749 {
8750 ffebld b;
8754 }
8762 varsinit);
8775 }
8777 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8778 analyzed on the assumption it is calculating a pointer to be
8779 indirected through. It must return the proper decl and offset,
8780 taking into account different units of measurements for offsets. */
8782 static void
8784 tree t)
8785 {
8787 {
8801 {
8802 /* An offset into COMMON. */
8805 /* Convert offset (presumably in bytes) into canonical units
8806 (presumably bits). */
8811 }
8812 /* Not a COMMON reference, so an unrecognized pattern. */
8823 {
8824 /* A reference to COMMON. */
8828 }
8829 /* Fall through. */
8831 /* Not a COMMON reference, so an unrecognized pattern. */
8834 }
8835 }
8837 /* Given a tree that is possibly intended for use as an lvalue, return
8838 information representing a canonical view of that tree as a decl, an
8839 offset into that decl, and a size for the lvalue.
8841 If there's no applicable decl, NULL_TREE is returned for the decl,
8842 and the other fields are left undefined.
8844 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8845 is returned for the decl, and the other fields are left undefined.
8847 Otherwise, the decl returned currently is either a VAR_DECL or a
8848 PARM_DECL.
8850 The offset returned is always valid, but of course not necessarily
8851 a constant, and not necessarily converted into the appropriate
8852 type, leaving that up to the caller (so as to avoid that overhead
8853 if the decls being looked at are different anyway).
8855 If the size cannot be determined (e.g. an adjustable array),
8856 an ERROR_MARK node is returned for the size. Otherwise, the
8857 size returned is valid, not necessarily a constant, and not
8858 necessarily converted into the appropriate type as with the
8859 offset.
8861 Note that the offset and size expressions are expressed in the
8862 base storage units (usually bits) rather than in the units of
8863 the type of the decl, because two decls with different types
8864 might overlap but with apparently non-overlapping array offsets,
8865 whereas converting the array offsets to consistant offsets will
8866 reveal the overlap. */
8868 static void
8871 {
8872 /* The default path is to report a nonexistant decl. */
8879 {
8949 {
8952 tree init_offset;
8956 {
8959 }
8962 array);
8967 /* Calculate ((element - base) * NBBY) + init_offset. */
8969 element,
8981 }
8985 /* Most of this code is to handle references to COMMON. And so
8986 far that is useful only for calling library functions, since
8987 external (user) functions might reference common areas. But
8988 even calling an external function, it's worthwhile to decode
8989 COMMON references because if not storing into COMMON, we don't
8990 want COMMON-based arguments to gratuitously force use of a
8991 temporary. */
9017 }
9018 }
9020 /* Do divide operation appropriate to type of operands. */
9022 static tree
9025 tree hook)
9026 {
9032 {
9035 left,
9036 right);
9041 left,
9042 right);
9043 {
9044 ffecomGfrt ix;
9049 else
9054 left);
9058 right);
9065 tree_type,
9066 left,
9069 }
9073 {
9074 ffecomGfrt ix;
9079 else
9084 left);
9088 right);
9095 tree_type,
9096 left,
9099 }
9104 left,
9105 right);
9106 }
9107 }
9109 /* Build type info for non-dummy variable. */
9111 static tree
9113 ffeinfoKindtype kt)
9114 {
9115 tree type;
9116 ffebld dl;
9117 ffebld dim;
9118 tree lowt;
9119 tree hight;
9123 {
9127 type
9128 = build_array_type
9131 ffecom_f2c_ftnlen_one_node,
9132 hight));
9134 }
9137 {
9146 else
9162 }
9165 }
9167 /* Build Namelist type. */
9170 static tree
9172 {
9174 {
9184 string_type_node);
9187 integer_type_node);
9193 }
9196 }
9198 /* Build Vardesc type. */
9201 static tree
9203 {
9205 {
9210 string_type_node);
9212 string_type_node);
9214 ffecom_f2c_ptr_to_ftnlen_type_node);
9216 integer_type_node);
9222 }
9225 }
9227 static tree
9229 {
9230 ffesymbol s;
9236 {
9239 tree var;
9240 tree nameinit;
9241 tree dimsinit;
9242 tree addrinit;
9243 tree typeinit;
9244 tree field;
9245 tree varinits;
9250 mynumber++),
9251 vardesctype);
9257 /* Process inits. */
9263 = build_type_variant
9264 (build_array_type
9267 integer_one_node,
9274 nameinit);
9281 {
9288 }
9289 else
9293 nameinit);
9295 addrinit);
9310 }
9313 }
9315 static tree
9317 {
9318 ffebld b;
9319 tree list;
9321 tree var;
9328 {
9329 tree t;
9335 else
9336 {
9339 }
9340 }
9344 integer_one_node,
9358 }
9360 static tree
9362 {
9365 integer_zero_node);
9367 {
9368 ffebld b;
9369 ffebld e;
9370 tree list;
9371 tree backlist;
9373 tree var;
9374 tree numdim;
9375 tree numelem;
9390 {
9391 tree t;
9392 tree low;
9393 tree back;
9397 else
9398 {
9404 else
9405 {
9408 }
9409 }
9413 else
9420 }
9423 {
9426 else
9430 ffecom_f2c_ftnlen_type_node,
9432 baseoff));
9433 }
9435 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9448 integer_zero_node,
9449 build_int_2
9466 }
9467 }
9469 /* Essentially does a "fold (build1 (code, type, node))" while checking
9470 for certain housekeeping things.
9472 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9473 ffecom_1_fn instead. */
9475 tree
9477 {
9478 tree item;
9485 {
9488 }
9491 {
9492 tree realtype;
9505 {
9508 }
9511 item =
9515 node)),
9518 node)));
9524 }
9533 }
9535 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9536 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9537 does not set TREE_ADDRESSABLE (because calling an inline
9538 function does not mean the function needs to be separately
9539 compiled). */
9541 tree
9543 {
9544 tree item;
9545 tree type;
9560 }
9562 /* Essentially does a "fold (build (code, type, node1, node2))" while
9563 checking for certain housekeeping things. */
9565 tree
9567 tree node2)
9568 {
9569 tree item;
9577 {
9592 {
9595 }
9599 item =
9603 node1),
9605 node2)),
9608 node1),
9610 node2)));
9615 {
9618 }
9622 item =
9626 node1),
9628 node2)),
9631 node1),
9633 node2)));
9638 {
9641 }
9646 node1));
9648 node1));
9650 node2));
9652 node2));
9653 item =
9657 a,
9658 c),
9660 b,
9661 d)),
9664 a,
9665 d),
9667 c,
9668 b)));
9674 {
9677 }
9683 item =
9687 node1),
9689 node2)),
9692 node1),
9694 node2)));
9700 {
9703 }
9709 item =
9713 node1),
9715 node2)),
9718 node1),
9720 node2)));
9726 }
9731 }
9733 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9735 ffesymbol s; // the ENTRY point itself
9736 if (ffecom_2pass_advise_entrypoint(s))
9737 // the ENTRY point has been accepted
9739 Does whatever compiler needs to do when it learns about the entrypoint,
9740 like determine the return type of the master function, count the
9741 number of entrypoints, etc. Returns FALSE if the return type is
9742 not compatible with the return type(s) of other entrypoint(s).
9744 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9745 later (after _finish_progunit) be called with the same entrypoint(s)
9746 as passed to this fn for which TRUE was returned.
9748 03-Jan-92 JCB 2.0
9749 Return FALSE if the return type conflicts with previous entrypoints. */
9751 bool
9753 {
9767 arglist's dummies. */
9777 {
9784 else
9787 }
9788 }
9790 /* If necessary, scan entry arglist for alternate returns. Do this scan
9791 apparently redundantly (it's done below to UNIONize the arglists) so
9792 that we don't complain about RETURN 1 if an offending ENTRY is the only
9793 one with an alternate return. */
9796 {
9800 {
9803 {
9806 }
9807 }
9808 }
9810 /* Now check type compatibility. */
9813 {
9819 ok
9830 {
9833 }
9836 {
9839 }
9841 }
9844 {
9849 }
9851 /* Entrypoint type compatible with previous types. */
9855 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9860 {
9869 appending of arg. */
9872 }
9876 /* Append this arg to the master list. */
9881 else
9883 }
9886 }
9888 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9890 ffesymbol s; // the ENTRY point itself
9891 ffecom_2pass_do_entrypoint(s);
9893 Does whatever compiler needs to do to make the entrypoint actually
9894 happen. Must be called for each entrypoint after
9895 ffecom_finish_progunit is called. */
9897 void
9899 {
9908 }
9909 else
9915 }
9917 /* Essentially does a "fold (build (code, type, node1, node2))" while
9918 checking for certain housekeeping things. Always sets
9919 TREE_SIDE_EFFECTS. */
9921 tree
9923 tree node2)
9924 {
9925 tree item;
9935 }
9937 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9938 checking for certain housekeeping things. */
9940 tree
9943 {
9944 tree item;
9957 }
9959 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9960 checking for certain housekeeping things. Always sets
9961 TREE_SIDE_EFFECTS. */
9963 tree
9966 {
9967 tree item;
9978 }
9980 /* ffecom_arg_expr -- Transform argument expr into gcc tree
9982 See use by ffecom_list_expr.
9984 If expression is NULL, returns an integer zero tree. If it is not
9985 a CHARACTER expression, returns whatever ffecom_expr
9986 returns and sets the length return value to NULL_TREE. Otherwise
9987 generates code to evaluate the character expression, returns the proper
9988 pointer to the result, but does NOT set the length return value to a tree
9989 that specifies the length of the result. (In other words, the length
9990 variable is always set to NULL_TREE, because a length is never passed.)
9992 21-Dec-91 JCB 1.1
9993 Don't set returned length, since nobody needs it (yet; someday if
9994 we allow CHARACTER*(*) dummies to statement functions, we'll need
9995 it). */
9997 tree
9999 {
10000 tree ign;
10011 }
10013 /* Transform expression into constant argument-pointer-to-expression tree.
10015 If the expression can be transformed into a argument-pointer-to-expression
10016 tree that is constant, that is done, and the tree returned. Else
10017 NULL_TREE is returned.
10019 That way, a caller can attempt to provide compile-time initialization
10020 of a variable and, if that fails, *then* choose to start a new block
10021 and resort to using temporaries, as appropriate. */
10023 tree
10025 {
10030 {
10034 }
10041 {
10042 tree t;
10048 }
10056 }
10058 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10060 See use by ffecom_list_ptr_to_expr.
10062 If expression is NULL, returns an integer zero tree. If it is not
10063 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10064 returns and sets the length return value to NULL_TREE. Otherwise
10065 generates code to evaluate the character expression, returns the proper
10066 pointer to the result, AND sets the length return value to a tree that
10067 specifies the length of the result.
10069 If the length argument is NULL, this is a slightly special
10070 case of building a FORMAT expression, that is, an expression that
10071 will be used at run time without regard to length. For the current
10072 implementation, which uses the libf2c library, this means it is nice
10073 to append a null byte to the end of the expression, where feasible,
10074 to make sure any diagnostic about the FORMAT string terminates at
10075 some useful point.
10077 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10078 length argument. This might even be seen as a feature, if a null
10079 byte can always be appended. */
10081 tree
10083 {
10084 tree item;
10085 tree ign_length;
10086 ffecomConcatList_ catlist;
10095 {
10099 {
10100 tree temp_exp;
10101 tree temp_length;
10108 temp_exp);
10109 }
10115 {
10118 }
10124 {
10125 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10127 #endif
10136 }
10141 }
10143 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10147 ffetargetHollerith h;
10152 *length
10155 }
10156 #endif
10169 {
10172 {
10175 }
10183 else
10192 }
10194 {
10197 tree lengths;
10198 tree items;
10199 tree length_array;
10200 tree item_array;
10201 tree citem;
10202 tree clength;
10203 tree temporary;
10204 tree num;
10205 tree known_length;
10206 ffetargetCharacterSize sz;
10209 /* ~~Kludge! */
10212 {
10213 tree hook;
10222 }
10227 {
10232 else
10237 {
10241 }
10243 items
10248 item_array,
10250 citem),
10251 items);
10254 known_length
10256 known_length,
10257 clength);
10258 lengths
10263 length_array,
10265 clength),
10266 lengths);
10267 }
10271 temporary);
10278 items));
10283 lengths));
10285 = build_tree_list
10298 item,
10299 temporary);
10303 }
10308 }
10310 /* Generate call to run-time function.
10312 The first arg is the GNU Fortran Run-Time function index, the second
10313 arg is the list of arguments to pass to it. Returned is the expression
10314 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10315 result (which may be void). */
10317 tree
10319 {
10325 }
10327 /* Transform constant-union to tree. */
10329 tree
10332 {
10333 tree item;
10336 {
10338 {
10342 {
10343 #if FFETARGET_okINTEGER1
10347 #endif
10349 #if FFETARGET_okINTEGER2
10353 #endif
10355 #if FFETARGET_okINTEGER3
10359 #endif
10361 #if FFETARGET_okINTEGER4
10365 #endif
10369 /* Fall through. */
10372 }
10375 }
10379 {
10383 {
10384 #if FFETARGET_okLOGICAL1
10388 #endif
10390 #if FFETARGET_okLOGICAL2
10394 #endif
10396 #if FFETARGET_okLOGICAL3
10400 #endif
10402 #if FFETARGET_okLOGICAL4
10406 #endif
10410 /* Fall through. */
10413 }
10416 }
10420 {
10421 REAL_VALUE_TYPE val;
10424 {
10425 #if FFETARGET_okREAL1
10429 #endif
10431 #if FFETARGET_okREAL2
10435 #endif
10437 #if FFETARGET_okREAL3
10441 #endif
10443 #if FFETARGET_okREAL4
10447 #endif
10451 /* Fall through. */
10454 }
10456 }
10460 {
10461 REAL_VALUE_TYPE real;
10462 REAL_VALUE_TYPE imag;
10466 {
10467 #if FFETARGET_okCOMPLEX1
10472 #endif
10474 #if FFETARGET_okCOMPLEX2
10479 #endif
10481 #if FFETARGET_okCOMPLEX3
10486 #endif
10488 #if FFETARGET_okCOMPLEX4
10493 #endif
10497 /* Fall through. */
10500 }
10504 }
10509 ffetargetCharacter1 val;
10512 {
10513 #if FFETARGET_okCHARACTER1
10517 #endif
10521 /* Fall through. */
10524 }
10529 build_range_type
10531 integer_one_node,
10532 build_int_2
10533 (ffetarget_length_character1
10536 }
10540 {
10541 ffetargetHollerith h;
10545 /* If not at least as wide as default INTEGER, widen it. */
10548 else
10549 {
10554 FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10557 str);
10558 }
10561 build_range_type
10563 integer_one_node,
10564 build_int_2
10567 }
10571 {
10572 ffetargetInteger1 ival;
10573 ffetargetTypeless tless;
10574 ffebad error;
10581 }
10586 /* Fall through. */
10589 }
10594 }
10596 /* Transform expression into constant tree.
10598 If the expression can be transformed into a tree that is constant,
10599 that is done, and the tree returned. Else NULL_TREE is returned.
10601 That way, a caller can attempt to provide compile-time initialization
10602 of a variable and, if that fails, *then* choose to start a new block
10603 and resort to using temporaries, as appropriate. */
10605 tree
10607 {
10616 #if NEWCOMMON
10617 /* ~~Enable once common/equivalence is handled properly? */
10619 #endif
10622 {
10623 tree t;
10628 }
10631 }
10633 /* Handy way to make a field in a struct/union. */
10635 tree
10638 {
10639 tree field;
10649 }
10651 void
10653 {
10655 }
10657 int
10659 {
10661 }
10663 /* End a compound statement (block). */
10665 tree
10667 {
10669 }
10671 /* ffecom_end_transition -- Perform end transition on all symbols
10673 ffecom_end_transition();
10675 Calls ffecom_sym_end_transition for each global and local symbol. */
10677 void
10679 {
10680 ffebld item;
10690 {
10692 }
10699 {
10700 ffebld callee;
10701 ffesymbol s;
10702 tree dt;
10703 tree t;
10704 tree var;
10711 {
10714 }
10720 number++),
10721 dt);
10733 }
10735 /* This handles any COMMON areas that weren't referenced but have, for
10736 example, important initial data. */
10744 }
10746 /* ffecom_exec_transition -- Perform exec transition on all symbols
10748 ffecom_exec_transition();
10750 Calls ffecom_sym_exec_transition for each global and local symbol.
10751 Make sure error updating not inhibited. */
10753 void
10755 {
10767 {
10769 }
10773 }
10775 /* Handle assignment statement.
10777 Convert dest and source using ffecom_expr, then join them
10778 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
10780 void
10782 {
10783 tree dest_tree;
10784 tree dest_length;
10785 tree source_tree;
10786 tree expr_tree;
10789 {
10791 tree assign_temp;
10793 /* This attempts to replicate the test below, but must not be
10794 true when the test below is false. (Always err on the side
10795 of creating unused temporaries, to avoid ICEs.) */
10800 {
10803 }
10804 else
10805 {
10808 }
10812 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10813 create a temporary through which the assignment is to take place,
10814 since MODIFY_EXPR doesn't handle partial overlap properly. */
10817 {
10819 ffecom_tree_type
10822 FFETARGET_charactersizeNONE,
10824 }
10825 else
10838 else
10839 {
10843 }
10850 {
10851 #ifdef MOVE_EXPR
10852 /* The back end understands a conceptual move (evaluate source;
10853 store into dest), so use that, in case it can determine
10854 that it is going to use, say, two registers as temporaries
10855 anyway. So don't use the temp (and someday avoid generating
10856 it, once this code starts triggering regularly). */
10858 dest_tree,
10859 source_tree);
10860 #else
10862 assign_temp,
10863 source_tree);
10866 dest_tree,
10867 assign_temp);
10868 #endif
10869 }
10870 else
10872 dest_tree,
10873 source_tree);
10877 }
10886 source);
10887 }
10889 /* ffecom_expr -- Transform expr into gcc tree
10891 tree t;
10892 ffebld expr; // FFE expression.
10893 tree = ffecom_expr(expr);
10895 Recursive descent on expr while making corresponding tree nodes and
10896 attaching type info and such. */
10898 tree
10900 {
10902 }
10904 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
10906 tree
10908 {
10910 }
10912 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
10914 tree
10916 {
10918 }
10920 /* Transform expr for use as into read/write tree and stabilize the
10921 reference. Not for use on CHARACTER expressions.
10923 Recursive descent on expr while making corresponding tree nodes and
10924 attaching type info and such. */
10926 tree
10928 {
10930 /* Different target types not yet supported. */
10934 }
10936 /* Transform expr for use as into write tree and stabilize the
10937 reference. Not for use on CHARACTER expressions.
10939 Recursive descent on expr while making corresponding tree nodes and
10940 attaching type info and such. */
10942 tree
10944 {
10946 /* Different target types not yet supported. */
10950 }
10952 /* Do global stuff. */
10954 void
10956 {
10961 }
10963 /* Public entry point for front end to access finish_decl. */
10965 void
10967 {
10970 }
10972 /* Finish a program unit. */
10974 void
10976 {
10983 }
10985 /* Wrapper for get_identifier. pattern is sprintf-like. */
10987 tree
10989 {
10990 tree decl;
11002 }
11004 ffeinfoBasictype
11006 {
11010 {
11048 }
11049 }
11051 ffeinfoKindtype
11053 {
11057 {
11095 }
11096 }
11098 void
11100 {
11101 tree endlink;
11104 tree t;
11105 tree field;
11106 ffetype type;
11107 ffetype base_type;
11108 tree double_ftype_double;
11109 tree float_ftype_float;
11110 tree ldouble_ftype_ldouble;
11111 tree ffecom_tree_ptr_to_fun_type_void;
11113 /* This block of code comes from the now-obsolete cktyps.c. It checks
11114 whether the compiler environment is buggy in known ways, some of which
11115 would, if not explicitly checked here, result in subtle bugs in g77. */
11118 {
11120 =
11129 {
11133 }
11137 {
11141 }
11145 {
11149 }
11150 }
11157 /* Make the binding_level structure for global names. */
11164 /* Define `int' and `char' first so that dbx will output them first. */
11166 integer_type_node));
11167 /* CHARACTER*1 is unsigned in ICHAR contexts. */
11170 char_type_node));
11172 long_integer_type_node));
11174 unsigned_type_node));
11176 long_unsigned_type_node));
11178 long_long_integer_type_node));
11180 long_long_unsigned_type_node));
11182 short_integer_type_node));
11184 short_unsigned_type_node));
11186 /* Set the sizetype before we make other types. This *should* be the
11187 first type we create. */
11189 set_sizetype
11191 ffecom_typesize_pointer_
11196 /* Define both `signed char' and `unsigned char'. */
11198 signed_char_type_node));
11201 unsigned_char_type_node));
11204 float_type_node));
11206 double_type_node));
11208 long_double_type_node));
11210 /* For now, override what build_common_tree_nodes has done. */
11214 complex_long_double_type_node
11218 complex_integer_type_node));
11220 complex_float_type_node));
11222 complex_double_type_node));
11224 complex_long_double_type_node));
11227 void_type_node));
11228 /* We are not going to have real types in C with less than byte alignment,
11229 so we might as well not have any types that claim to have it. */
11235 ffecom_tree_fun_type_void
11238 ffecom_tree_ptr_to_fun_type_void
11243 float_ftype_float
11247 double_ftype_double
11251 ldouble_ftype_ldouble
11254 endlink));
11258 {
11263 }
11265 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11266 to size FLOAT_TYPE_SIZE because they have to be the same size as
11267 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11268 Compiler options and other such stuff that change the ways these
11269 types are set should not affect this particular setup. */
11274 t));
11278 type);
11284 type);
11292 t));
11297 t));
11300 type);
11306 type);
11313 t));
11318 t));
11321 type);
11327 type);
11334 t));
11339 t));
11342 type);
11348 type);
11355 t));
11357 #if 0
11363 {
11365 LONG_TYPE_SIZE);
11366 }
11367 #endif
11372 t));
11376 type);
11382 type);
11389 t));
11392 type);
11398 type);
11405 t));
11408 type);
11414 type);
11421 t));
11424 type);
11430 type);
11438 t));
11443 type);
11449 type);
11459 t));
11463 type);
11469 type);
11476 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11478 t));
11482 type);
11488 type);
11495 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11497 t));
11500 type);
11506 type);
11508 type);
11513 /* Make function and ptr-to-function types for non-CHARACTER types. */
11517 {
11519 {
11521 {
11522 /* Figure out the smallest INTEGER type that can hold
11523 a pointer on this machine. */
11526 {
11531 }
11532 }
11535 /* For f2c compatibility, REAL functions are really
11536 implemented as DOUBLE PRECISION. */
11539 t = ffecom_tree_type
11543 NULL_TREE);
11545 }
11546 }
11548 /* Set up pointer types. */
11555 FFEINFO_kindtypeINTEGERDEFAULT),
11558 ffecom_pointer_kind_));
11562 else
11567 ffecom_integer_type_node
11570 integer_zero_node);
11572 integer_one_node);
11574 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11575 Turns out that by TYLONG, runtime/libI77/lio.h really means
11576 "whatever size an ftnint is". For consistency and sanity,
11577 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11578 all are INTEGER, which we also make out of whatever back-end
11579 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11580 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11581 accommodate machines like the Alpha. Note that this suggests
11582 f2c and libf2c are missing a distinction perhaps needed on
11583 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11586 FFETARGET_f2cTYLONG);
11588 FFETARGET_f2cTYSHORT);
11590 FFETARGET_f2cTYINT1);
11592 FFETARGET_f2cTYQUAD);
11594 FFETARGET_f2cTYLOGICAL);
11596 FFETARGET_f2cTYLOGICAL2);
11598 FFETARGET_f2cTYLOGICAL1);
11599 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11601 FFETARGET_f2cTYQUAD);
11603 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11604 loop. CHARACTER items are built as arrays of unsigned char. */
11611 FFEINFO_kindtypeCHARACTER1,
11612 type);
11631 /* Make multi-return-value type and fields. */
11639 {
11656 }
11661 /* Subroutines usually return integer because they might have alternate
11662 returns. */
11664 ffecom_tree_subr_type
11666 ffecom_tree_ptr_to_subr_type
11668 ffecom_tree_blockdata_type
11693 FFECOM_f2cINTEGER,
11696 FFECOM_f2cADDRESS,
11699 FFECOM_f2cREAL,
11702 FFECOM_f2cDOUBLEREAL,
11705 FFECOM_f2cCOMPLEX,
11708 FFECOM_f2cDOUBLECOMPLEX,
11711 FFECOM_f2cLONGINT,
11714 FFECOM_f2cLOGICAL,
11717 FFECOM_f2cFLAG,
11720 FFECOM_f2cFTNLEN,
11723 FFECOM_f2cFTNINT,
11726 ffecom_f2c_ftnlen_zero_node
11729 ffecom_f2c_ftnlen_one_node
11735 ffecom_f2c_ptr_to_ftnlen_type_node
11738 ffecom_f2c_ptr_to_ftnint_type_node
11741 ffecom_f2c_ptr_to_integer_type_node
11744 ffecom_f2c_ptr_to_real_type_node
11749 {
11750 REAL_VALUE_TYPE point_5;
11755 }
11757 /* Do "extern int xargc;". */
11761 integer_type_node);
11771 {
11778 }
11779 #endif
11784 /* I/O will probably crash. */
11788 #endif
11793 /* ASSIGN 10 TO I will crash. */
11798 #endif
11799 }
11801 /* ffecom_init_2 -- Initialize
11803 ffecom_init_2(); */
11805 void
11807 {
11818 }
11820 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11822 tree t;
11823 ffebld expr; // FFE opITEM list.
11824 tree = ffecom_list_expr(expr);
11826 List of actual args is transformed into corresponding gcc backend list. */
11828 tree
11830 {
11831 tree list;
11835 tree length;
11838 {
11848 {
11851 }
11852 }
11857 }
11859 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11861 tree t;
11862 ffebld expr; // FFE opITEM list.
11863 tree = ffecom_list_ptr_to_expr(expr);
11865 List of actual args is transformed into corresponding gcc backend list for
11866 use in calling an external procedure (vs. a statement function). */
11868 tree
11870 {
11871 tree list;
11875 tree length;
11878 {
11888 {
11891 }
11892 }
11897 }
11899 /* Obtain gcc's LABEL_DECL tree for label. */
11901 tree
11903 {
11904 tree glabel;
11907 {
11911 {
11917 void_type_node);
11924 ffecom_get_invented_identifier
11928 NULL_TREE),
11949 }
11951 }
11952 else
11953 {
11955 }
11958 }
11960 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
11961 a single source specification (as in the fourth argument of MVBITS).
11962 If the type is NULL_TREE, the type of lhs is used to make the type of
11963 the MODIFY_EXPR. */
11965 tree
11967 tree rhs)
11968 {
11979 }
11981 /* Register source file name. */
11983 void
11985 {
11987 }
11989 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
11991 ffestorag st;
11992 ffecom_notify_init_storage(st);
11994 Gets called when all possible units in an aggregate storage area (a LOCAL
11995 with equivalences or a COMMON) have been initialized. The initialization
11996 info either is in ffestorag_init or, if that is NULL,
11997 ffestorag_accretion:
11999 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12000 even for an array if the array is one element in length!
12002 ffestorag_accretion will contain an opACCTER. It is much like an
12003 opARRTER except it has an ffebit object in it instead of just a size.
12004 The back end can use the info in the ffebit object, if it wants, to
12005 reduce the amount of actual initialization, but in any case it should
12006 kill the ffebit object when done. Also, set accretion to NULL but
12007 init to a non-NULL value.
12009 After performing initialization, DO NOT set init to NULL, because that'll
12010 tell the front end it is ok for more initialization to happen. Instead,
12011 set init to an opANY expression or some such thing that you can use to
12012 tell that you've already initialized the object.
12014 27-Oct-91 JCB 1.1
12015 Support two-pass FFE. */
12017 void
12019 {
12023 {
12029 }
12030 }
12032 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12034 ffesymbol s;
12035 ffecom_notify_init_symbol(s);
12037 Gets called when all possible units in a symbol (not placed in COMMON
12038 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12039 have been initialized. The initialization info either is in
12040 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12042 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12043 even for an array if the array is one element in length!
12045 ffesymbol_accretion will contain an opACCTER. It is much like an
12046 opARRTER except it has an ffebit object in it instead of just a size.
12047 The back end can use the info in the ffebit object, if it wants, to
12048 reduce the amount of actual initialization, but in any case it should
12049 kill the ffebit object when done. Also, set accretion to NULL but
12050 init to a non-NULL value.
12052 After performing initialization, DO NOT set init to NULL, because that'll
12053 tell the front end it is ok for more initialization to happen. Instead,
12054 set init to an opANY expression or some such thing that you can use to
12055 tell that you've already initialized the object.
12057 27-Oct-91 JCB 1.1
12058 Support two-pass FFE. */
12060 void
12062 {
12067 possibilities checked. */
12071 {
12075 }
12076 }
12078 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12080 ffesymbol s;
12081 ffecom_notify_primary_entry(s);
12083 Gets called when implicit or explicit PROGRAM statement seen or when
12084 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12085 global symbol that serves as the entry point. */
12087 void
12089 {
12096 else
12100 {
12103 else
12105 }
12108 {
12109 ffebld list;
12110 ffebld arg;
12115 {
12118 {
12121 }
12122 }
12123 }
12124 }
12128 {
12130 }
12132 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12134 tree t;
12135 ffebld expr; // FFE expression.
12136 tree = ffecom_ptr_to_expr(expr);
12138 Like ffecom_expr, but sticks address-of in front of most things. */
12140 tree
12142 {
12143 tree item;
12144 ffeinfoBasictype bt;
12145 ffeinfoKindtype kt;
12146 ffesymbol s;
12151 {
12155 {
12156 ffecomGfrt ix;
12161 {
12164 }
12165 }
12166 else
12167 {
12170 {
12173 }
12174 }
12180 item);
12197 item);
12211 /* The back end currently optimizes a bit too zealously for us, in that
12212 we fail JCB001 if the following block of code is omitted. It checks
12213 to see if the transformed expression is a symbol or array reference,
12214 and encloses it in a SAVE_EXPR if that is the case. */
12223 #ifdef OFFSET_REF
12225 #endif
12229 {
12231 }
12234 item);
12236 }
12240 }
12242 /* Obtain a temp var with given data type.
12244 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12245 or >= 0 for a CHARACTER type.
12247 elements is -1 for a scalar or > 0 for an array of type. */
12249 tree
12252 {
12253 tree t;
12264 ffecom_f2c_ftnlen_one_node,
12269 integer_zero_node,
12274 commentary,
12275 mynumber++),
12276 type);
12282 }
12284 /* Prepare argument pointer to expression.
12286 Like ffecom_prepare_expr, except for expressions to be evaluated
12287 via ffecom_arg_ptr_to_expr. */
12289 void
12291 {
12292 /* ~~For now, it seems to be the same thing. */
12295 }
12297 /* End of preparations. */
12299 bool
12301 {
12308 }
12310 /* Prepare expression.
12312 This is called before any code is generated for the current block.
12313 It scans the expression, declares any temporaries that might be needed
12314 during evaluation of the expression, and stores those temporaries in
12315 the appropriate "hook" fields of the expression. `dest', if not NULL,
12316 specifies the destination that ffecom_expr_ will see, in case that
12317 helps avoid generating unused temporaries.
12319 ~~Improve to avoid allocating unused temporaries by taking `dest'
12320 into account vis-a-vis aliasing requirements of complex/character
12321 functions. */
12323 void
12325 {
12326 ffeinfoBasictype bt;
12327 ffeinfoKindtype kt;
12328 ffetargetCharacterSize sz;
12340 /* Generate whatever temporaries are needed to represent the result
12341 of the expression. */
12344 {
12347 }
12350 {
12352 /* Don't make temps for SYMTER, CONTER, etc. */
12357 {
12360 {
12361 ffesymbol s;
12373 }
12375 {
12376 /* Requires special treatment. There's no POW_CC function
12377 in libg2c, so POW_ZZ is used, which means we always
12378 need a double-complex temp, not a single-complex. */
12380 }
12382 /* The other ops don't need temps for complex operands. */
12385 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12386 REAL(C). See 19990325-0.f, routine `check', for cases. */
12388 ffecom_tree_type
12390 FFETARGET_charactersizeNONE,
12399 /* ~~Kludge alert! This should someday be fixed. */
12407 }
12411 {
12412 /* This gets special handling, because only one set of temps
12413 is needed for a tree of these -- the tree is treated as
12414 a flattened list of concatenations when generating code. */
12416 ffecomConcatList_ catlist;
12425 {
12426 ltmp
12428 ffecom_f2c_ftnlen_type_node,
12430 itmp
12432 ffecom_f2c_address_type_node,
12434 result
12436 char_type_node,
12444 }
12448 i));
12453 {
12456 }
12457 }
12467 }
12470 {
12473 }
12475 /* Prepare subexpressions for this expr. */
12478 {
12493 {
12494 ffebld item;
12501 }
12505 /* Need to handle character conversion specially. */
12507 {
12519 }
12520 }
12523 }
12525 /* Prepare expression for reading and writing.
12527 Like ffecom_prepare_expr, except for expressions to be evaluated
12528 via ffecom_expr_rw. */
12530 void
12532 {
12533 /* This is all we support for now. */
12536 /* ~~For now, it seems to be the same thing. */
12539 }
12541 /* Prepare expression for writing.
12543 Like ffecom_prepare_expr, except for expressions to be evaluated
12544 via ffecom_expr_w. */
12546 void
12548 {
12549 /* This is all we support for now. */
12552 /* ~~For now, it seems to be the same thing. */
12555 }
12557 /* Prepare expression for returning.
12559 Like ffecom_prepare_expr, except for expressions to be evaluated
12560 via ffecom_return_expr. */
12562 void
12564 {
12568 && ffecom_is_altreturning_
12571 }
12573 /* Prepare pointer to expression.
12575 Like ffecom_prepare_expr, except for expressions to be evaluated
12576 via ffecom_ptr_to_expr. */
12578 void
12580 {
12581 /* ~~For now, it seems to be the same thing. */
12584 }
12586 /* Transform expression into constant pointer-to-expression tree.
12588 If the expression can be transformed into a pointer-to-expression tree
12589 that is constant, that is done, and the tree returned. Else NULL_TREE
12590 is returned.
12592 That way, a caller can attempt to provide compile-time initialization
12593 of a variable and, if that fails, *then* choose to start a new block
12594 and resort to using temporaries, as appropriate. */
12596 tree
12598 {
12610 {
12611 tree t;
12616 }
12619 }
12621 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12623 tree rtn; // NULL_TREE means use expand_null_return()
12624 ffebld expr; // NULL if no alt return expr to RETURN stmt
12625 rtn = ffecom_return_expr(expr);
12627 Based on the program unit type and other info (like return function
12628 type, return master function type when alternate ENTRY points,
12629 whether subroutine has any alternate RETURN points, etc), returns the
12630 appropriate expression to be returned to the caller, or NULL_TREE
12631 meaning no return value or the caller expects it to be returned somewhere
12632 else (which is handled by other parts of this module). */
12634 tree
12636 {
12637 tree rtn;
12640 {
12651 else
12664 into (implicit) dummy. */
12667 }
12669 #if 0
12670 /* Spurious error if RETURN happens before first reference! So elide
12671 this code. In particular, for debugging registry, rtn should always
12672 be non-null after all, but TREE_USED won't be set until we encounter
12673 a reference in the code. Perfectly okay (but weird) code that,
12674 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12675 this diagnostic for no reason. Have people use -O -Wuninitialized
12676 and leave it to the back end to find obviously weird cases. */
12678 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12679 situation; if the return value has never been referenced, it won't
12680 have a tree under 2pass mode. */
12683 {
12690 }
12691 #endif
12699 }
12702 }
12704 /* Do save_expr only if tree is not error_mark_node. */
12706 tree
12708 {
12710 }
12712 /* Start a compound statement (block). */
12714 void
12716 {
12718 }
12720 /* Public entry point for front end to access start_decl. */
12722 tree
12724 {
12727 }
12729 /* ffecom_sym_commit -- Symbol's state being committed to reality
12731 ffesymbol s;
12732 ffecom_sym_commit(s);
12734 Does whatever the backend needs when a symbol is committed after having
12735 been backtrackable for a period of time. */
12737 void
12739 {
12741 }
12743 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12745 ffecom_sym_end_transition();
12747 Does backend-specific stuff and also calls ffest_sym_end_transition
12748 to do the necessary FFE stuff.
12750 Backtracking is never enabled when this fn is called, so don't worry
12751 about it. */
12753 ffesymbol
12755 {
12756 ffestorag st;
12764 {
12765 ffecom_list_blockdata_
12767 FFEINTRIN_specNONE,
12768 FFEINTRIN_impNONE),
12769 ffecom_list_blockdata_);
12770 }
12772 /* This is where we finally notice that a symbol has partial initialization
12773 and finalize it. */
12776 {
12779 }
12783 {
12786 }
12791 {
12792 ffecom_list_common_
12794 FFEINTRIN_specNONE,
12795 FFEINTRIN_impNONE),
12796 ffecom_list_common_);
12797 }
12800 }
12802 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12804 ffecom_sym_exec_transition();
12806 Does backend-specific stuff and also calls ffest_sym_exec_transition
12807 to do the necessary FFE stuff.
12809 See the long-winded description in ffecom_sym_learned for info
12810 on handling the situation where backtracking is inhibited. */
12812 ffesymbol
12814 {
12818 }
12820 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12822 ffesymbol s;
12823 s = ffecom_sym_learned(s);
12825 Called when a new symbol is seen after the exec transition or when more
12826 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
12827 it arrives here is that all its latest info is updated already, so its
12828 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12829 field filled in if its gone through here or exec_transition first, and
12830 so on.
12832 The backend probably wants to check ffesymbol_retractable() to see if
12833 backtracking is in effect. If so, the FFE's changes to the symbol may
12834 be retracted (undone) or committed (ratified), at which time the
12835 appropriate ffecom_sym_retract or _commit function will be called
12836 for that function.
12838 If the backend has its own backtracking mechanism, great, use it so that
12839 committal is a simple operation. Though it doesn't make much difference,
12840 I suppose: the reason for tentative symbol evolution in the FFE is to
12841 enable error detection in weird incorrect statements early and to disable
12842 incorrect error detection on a correct statement. The backend is not
12843 likely to introduce any information that'll get involved in these
12844 considerations, so it is probably just fine that the implementation
12845 model for this fn and for _exec_transition is to not do anything
12846 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12847 and instead wait until ffecom_sym_commit is called (which it never
12848 will be as long as we're using ambiguity-detecting statement analysis in
12849 the FFE, which we are initially to shake out the code, but don't depend
12850 on this), otherwise go ahead and do whatever is needed.
12852 In essence, then, when this fn and _exec_transition get called while
12853 backtracking is enabled, a general mechanism would be to flag which (or
12854 both) of these were called (and in what order? neat question as to what
12855 might happen that I'm too lame to think through right now) and then when
12856 _commit is called reproduce the original calling sequence, if any, for
12857 the two fns (at which point backtracking will, of course, be disabled). */
12859 ffesymbol
12861 {
12865 }
12867 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12869 ffesymbol s;
12870 ffecom_sym_retract(s);
12872 Does whatever the backend needs when a symbol is retracted after having
12873 been backtrackable for a period of time. */
12875 void
12877 {
12881 so nothing needed here. */
12883 {
12902 }
12903 #endif
12904 }
12906 /* Create temporary gcc label. */
12908 tree
12910 {
12911 tree glabel;
12916 mynumber++),
12917 void_type_node);
12922 }
12924 /* Return an expression that is usable as an arg in a conditional context
12925 (IF, DO WHILE, .NOT., and so on).
12927 Use the one provided for the back end as of >2.6.0. */
12929 tree
12931 {
12933 }
12935 /* Return the inversion of a truth value (the inversion of what
12936 ffecom_truth_value builds).
12938 Apparently invert_truthvalue, which is properly in the back end, is
12939 enough for now, so just use it. */
12941 tree
12943 {
12945 }
12947 /* Return the tree that is the type of the expression, as would be
12948 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
12949 transforming the expression, generating temporaries, etc. */
12951 tree
12953 {
12954 ffeinfoBasictype bt;
12955 ffeinfoKindtype kt;
12956 tree tree_type;
12965 {
13008 /* Fall through. */
13011 }
13012 }
13014 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13016 If the PARM_DECL already exists, return it, else create it. It's an
13017 integer_type_node argument for the master function that implements a
13018 subroutine or function with more than one entrypoint and is bound at
13019 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13020 first ENTRY statement, and so on). */
13022 tree
13024 {
13028 }
13029 \f
13030 /* The following sections consists of private and public functions
13031 that have the same names and perform roughly the same functions
13032 as counterparts in the C front end. Changes in the C front end
13033 might affect how things should be done here. Only functions
13034 needed by the back end should be public here; the rest should
13035 be private (static in the C sense). Functions needed by other
13036 g77 front-end modules should be accessed by them via public
13037 ffecom_* names, which should themselves call private versions
13038 in this section so the private versions are easy to recognize
13039 when upgrading to a new gcc and finding interesting changes
13040 in the front end.
13042 Functions named after rule "foo:" in c-parse.y are named
13043 "bison_rule_foo_" so they are easy to find. */
13045 static void
13047 {
13052 }
13054 static tree
13056 {
13057 tree t;
13060 /* Make the temps go away. */
13069 }
13071 /* Return a definition for a builtin function named NAME and whose data type
13072 is TYPE. TYPE should be a function type with argument types.
13073 FUNCTION_CODE tells later passes how to compile calls to this function.
13074 See tree.h for its possible values.
13076 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13077 the name to be called if we can't opencode the function. If
13078 ATTRS is nonzero, use that for the function's attribute list. */
13080 tree
13084 tree attrs ATTRIBUTE_UNUSED)
13085 {
13097 }
13099 /* Handle when a new declaration NEWDECL
13100 has the same name as an old one OLDDECL
13101 in the same binding contour.
13102 Prints an error message if appropriate.
13104 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13105 Otherwise, return 0. */
13107 static int
13109 {
13123 /* New decl is completely inconsistent with the old one =>
13124 tell caller to replace the old one.
13125 This is always an error except in the case of shadowing a builtin. */
13129 /* For real parm decl following a forward decl,
13130 return 1 so old decl will be reused. */
13135 /* The new declaration is the same kind of object as the old one.
13136 The declarations may partially match. Print warnings if they don't
13137 match enough. Ultimately, copy most of the information from the new
13138 decl to the old one, and keep using the old one. */
13142 {
13143 /* A function declaration for a built-in function. */
13147 {
13148 /* Accept the return type of the new declaration if same modes. */
13153 {
13154 /* Function types may be shared, so we can't just modify
13155 the return type of olddecl's function type. */
13156 tree newtype
13163 }
13164 }
13167 }
13170 {
13171 /* A function declaration for a predeclared function
13172 that isn't actually built in. */
13176 {
13177 /* If the types don't match, preserve volatility indication.
13178 Later on, we will discard everything else about the
13179 default declaration. */
13181 }
13182 }
13184 /* Copy all the DECL_... slots specified in the new decl
13185 except for any that we copy here from the old type.
13187 Past this point, we don't change OLDTYPE and NEWTYPE
13188 even if we change the types of NEWDECL and OLDDECL. */
13191 {
13192 /* Merge the data types specified in the two decls. */
13198 /* Lay the type out, unless already done. */
13200 {
13207 }
13208 else
13209 {
13210 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13215 {
13218 }
13219 }
13221 /* Keep the old rtl since we can safely use it. */
13224 /* Merge the type qualifiers. */
13231 {
13235 }
13237 /* Keep source location of definition rather than declaration.
13238 Likewise, keep decl at outer scope. */
13241 {
13248 }
13250 /* Merge the unused-warning information. */
13256 /* Merge the initialization information. */
13260 /* Merge the section attribute.
13261 We want to issue an error if the sections conflict but that must be
13262 done later in decl_attributes since we are called before attributes
13263 are assigned. */
13268 {
13271 }
13272 }
13273 /* If cannot merge, then use the new type and qualifiers,
13274 and don't preserve the old rtl. */
13275 else
13276 {
13281 }
13283 /* Merge the storage class information. */
13284 /* For functions, static overrides non-static. */
13286 {
13288 /* This is since we don't automatically
13289 copy the attributes of NEWDECL into OLDDECL. */
13291 /* If this clears `static', clear it in the identifier too. */
13294 }
13296 {
13299 /* An extern decl does not override previous storage class. */
13301 }
13302 else
13303 {
13306 }
13308 /* If either decl says `inline', this fn is inline,
13309 unless its definition was passed already. */
13314 /* Get rid of any built-in function if new arg types don't match it
13315 or if we have a function definition. */
13319 {
13322 }
13324 /* If redeclaring a builtin function, and not a definition,
13325 it stays built in.
13326 Also preserve various other info from the definition. */
13328 {
13330 {
13333 }
13339 }
13341 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13342 But preserve olddecl's DECL_UID. */
13343 {
13350 }
13353 }
13355 /* Finish processing of a declaration;
13356 install its initial value.
13357 If the length of an array type is not known before,
13358 it must be determined now, from the initial value, or it is an error. */
13360 static void
13362 {
13368 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13369 level anyway. */
13374 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13375 overlaps DECL_ARG_TYPE. */
13378 else
13382 {
13385 else
13386 {
13387 /* typedef foo = bar; store the type of bar as the type of foo. */
13390 }
13391 }
13393 /* Deduce size of array from initialization, if not already known */
13398 {
13403 }
13406 {
13413 ?
13414 /* A static variable with an incomplete type is an error if it is
13415 initialized. Also if it is not file scope. Otherwise, let it
13416 through, but if it is not `extern' then it may cause an error
13417 message later. */
13419 :
13420 /* An automatic variable with an incomplete type is an error. */
13422 {
13425 }
13430 {
13433 }
13434 }
13436 /* Output the assembler code and/or RTL code for variables and functions,
13437 unless the type is an undefined structure or union. If not, it will get
13438 done when the type is completed. */
13441 {
13447 {
13448 /* Recompute the RTL of a local array now if it used to be an
13449 incomplete type. */
13452 {
13453 /* If we used it already as memory, it must stay in memory. */
13455 /* If it's still incomplete now, no init will save it. */
13459 }
13460 /* Compute and store the initial value. */
13463 }
13464 }
13466 {
13470 }
13472 /* At the end of a declaration, throw away any variable type sizes of types
13473 defined inside that declaration. There is no use computing them in the
13474 following function definition. */
13477 }
13479 /* Finish up a function declaration and compile that function
13480 all the way to assembler language output. The free the storage
13481 for the function definition.
13483 This is called after parsing the body of the function definition.
13485 NESTED is nonzero if the function being finished is nested in another. */
13487 static void
13489 {
13494 {
13497 else
13499 }
13501 /* TREE_READONLY (fndecl) = 1;
13502 This caused &foo to be of type ptr-to-const-function
13503 which then got a warning when stored in a ptr-to-function variable. */
13508 {
13511 /* Must mark the RESULT_DECL as being in this function. */
13515 /* Obey `register' declarations if `setjmp' is called in this fn. */
13516 /* Generate rtl for function exit. */
13519 /* If this is a nested function, protect the local variables in the stack
13520 above us from being collected while we're compiling this function. */
13524 /* Run the optimizers and output the assembler code for this function. */
13527 /* Undo the GC context switch. */
13530 }
13533 && !nested
13535 {
13536 /* Stop pointing to the local nodes about to be freed. */
13537 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13538 function definition. */
13539 /* For a nested function, this is done in pop_f_function_context. */
13540 /* If rest_of_compilation set this to 0, leave it 0. */
13544 }
13547 {
13548 /* Let the error reporting routines know that we're outside a function.
13549 For a nested function, this value is used in pop_c_function_context
13550 and then reset via pop_function_context. */
13552 }
13553 }
13555 /* Plug-in replacement for identifying the name of a decl and, for a
13556 function, what we call it in diagnostics. For now, "program unit"
13557 should suffice, since it's a bit of a hassle to figure out which
13558 of several kinds of things it is. Note that it could conceivably
13559 be a statement function, which probably isn't really a program unit
13560 per se, but if that comes up, it should be easy to check (being a
13561 nested function and all). */
13565 {
13566 /* Just to keep GCC quiet about the unused variable.
13567 In theory, differing values of V should produce different
13568 output. */
13570 {
13575 }
13576 }
13578 /* g77's function to print out name of current function that caused
13579 an error. */
13581 static void
13584 {
13587 ffeglobal g;
13588 ffesymbol s;
13593 {
13597 }
13598 else
13599 {
13602 {
13605 }
13606 else
13607 {
13610 }
13611 }
13614 {
13620 else
13621 {
13625 }
13629 }
13630 }
13632 /* Similar to `lookup_name' but look only at current binding level. */
13634 static tree
13636 {
13650 }
13652 /* Create a new `struct f_binding_level'. */
13656 {
13657 /* NOSTRICT */
13659 }
13661 /* Save and restore the variables in this file and elsewhere
13662 that keep track of the progress of compilation of the current function.
13663 Used for nested functions. */
13665 struct f_function
13666 {
13668 tree named_labels;
13669 tree shadowed_labels;
13671 };
13675 /* Restore the variables used during compilation of a C function. */
13677 static void
13679 {
13681 tree link;
13683 /* Bring back all the labels that were shadowed. */
13691 {
13692 /* Stop pointing to the local nodes about to be freed. */
13693 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13694 function definition. */
13697 }
13708 }
13710 /* Save and reinitialize the variables
13711 used during compilation of a C function. */
13713 static void
13715 {
13727 }
13729 static void
13731 {
13734 /* Don't try computing parm sizes now -- wait till fn is called. */
13738 /* Fill in arg stuff. */
13749 }
13751 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
13753 static tree
13755 tree x;
13756 {
13767 }
13769 /* Store the list of declarations of the current level.
13770 This is done for the parameter declarations of a function being defined,
13771 after they are modified in the light of any missing parameters. */
13773 static tree
13775 tree decls;
13776 {
13778 }
13780 /* Store the parameter declarations into the current function declaration.
13781 This is called after parsing the parameter declarations, before
13782 digesting the body of the function.
13784 For an old-style definition, modify the function's type
13785 to specify at least the number of arguments. */
13787 static void
13789 {
13795 /* This is a chain of PARM_DECLs from old-style parm declarations. */
13798 /* Initialize the RTL code for the function. */
13802 /* Set up parameters and prepare for return, for the function. */
13805 }
13807 static tree
13809 {
13814 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13815 level anyway. */
13819 {
13822 }
13826 /* For Fortran, we by default put things in .common when possible. */
13829 /* Add this decl to the current binding level. TEM may equal DECL or it may
13830 be a previous decl of the same name. */
13833 else
13836 /* For a local variable, define the RTL now. */
13838 /* But not if this is a duplicate decl and we preserved the rtl from the
13839 previous one (which may or may not happen). */
13841 {
13847 }
13850 }
13852 /* Create the FUNCTION_DECL for a function definition.
13853 DECLSPECS and DECLARATOR are the parts of the declaration;
13854 they describe the function's name and the type it returns,
13855 but twisted together in a fashion that parallels the syntax of C.
13857 This function creates a binding context for the function body
13858 as well as setting up the FUNCTION_DECL in current_function_decl.
13860 Returns 1 on success. If the DECLARATOR is not suitable for a function
13861 (it defines a datum instead), we return 0, which tells
13862 ffe_parse_file to report a parse error.
13864 NESTED is nonzero for a function nested within another function. */
13866 static void
13868 {
13869 tree decl1;
13870 tree restype;
13876 /* Don't expand any sizes in the return type of the function. */
13880 {
13884 }
13885 else
13886 {
13888 }
13892 else
13893 {
13895 name,
13896 type);
13905 /* Make the init_value nonzero so pushdecl knows this is not tentative.
13906 error_mark_node is replaced below (in poplevel) with the BLOCK. */
13909 /* Record the decl so that the function name is defined. If we already have
13910 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
13913 }
13922 {
13928 }
13934 }
13935 \f
13936 /* Here are the public functions the GNU back end needs. */
13938 tree
13941 {
13954 {
13957 }
13963 e);
13977 }
13979 /* Return the list of declarations of the current level.
13980 Note that this list is in reverse order unless/until
13981 you nreverse it; and when you do nreverse it, you must
13982 store the result back using `storedecls' or you will lose. */
13984 tree
13986 {
13988 }
13990 /* Nonzero if we are currently in the global binding level. */
13992 int
13994 {
13996 }
13998 static void
14000 {
14004 }
14006 /* Delete the node BLOCK from the current binding level.
14007 This is used for the block inside a stmt expr ({...})
14008 so that the block can be reinserted where appropriate. */
14010 static void
14012 tree block;
14013 {
14014 tree t;
14018 {
14021 else
14023 }
14025 /* Clear TREE_USED which is always set by poplevel.
14026 The flag is set again if insert_block is called. */
14028 }
14030 void
14032 tree block;
14033 {
14035 current_binding_level->blocks
14037 }
14039 /* Each front end provides its own. */
14046 {
14048 };
14050 #undef LANG_HOOKS_NAME
14052 #undef LANG_HOOKS_INIT
14053 #define LANG_HOOKS_INIT ffe_init
14054 #undef LANG_HOOKS_FINISH
14055 #define LANG_HOOKS_FINISH ffe_finish
14056 #undef LANG_HOOKS_INIT_OPTIONS
14057 #define LANG_HOOKS_INIT_OPTIONS ffe_init_options
14058 #undef LANG_HOOKS_DECODE_OPTION
14059 #define LANG_HOOKS_DECODE_OPTION ffe_decode_option
14060 #undef LANG_HOOKS_PARSE_FILE
14061 #define LANG_HOOKS_PARSE_FILE ffe_parse_file
14062 #undef LANG_HOOKS_MARK_ADDRESSABLE
14063 #define LANG_HOOKS_MARK_ADDRESSABLE ffe_mark_addressable
14064 #undef LANG_HOOKS_PRINT_IDENTIFIER
14065 #define LANG_HOOKS_PRINT_IDENTIFIER ffe_print_identifier
14066 #undef LANG_HOOKS_DECL_PRINTABLE_NAME
14067 #define LANG_HOOKS_DECL_PRINTABLE_NAME ffe_printable_name
14068 #undef LANG_HOOKS_PRINT_ERROR_FUNCTION
14069 #define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function
14070 #undef LANG_HOOKS_TRUTHVALUE_CONVERSION
14071 #define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion
14073 #undef LANG_HOOKS_TYPE_FOR_MODE
14074 #define LANG_HOOKS_TYPE_FOR_MODE ffe_type_for_mode
14075 #undef LANG_HOOKS_TYPE_FOR_SIZE
14076 #define LANG_HOOKS_TYPE_FOR_SIZE ffe_type_for_size
14077 #undef LANG_HOOKS_SIGNED_TYPE
14078 #define LANG_HOOKS_SIGNED_TYPE ffe_signed_type
14079 #undef LANG_HOOKS_UNSIGNED_TYPE
14080 #define LANG_HOOKS_UNSIGNED_TYPE ffe_unsigned_type
14081 #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
14082 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type
14084 /* We do not wish to use alias-set based aliasing at all. Used in the
14085 extreme (every object with its own set, with equivalences recorded) it
14086 might be helpful, but there are problems when it comes to inlining. We
14087 get on ok with flag_argument_noalias, and alias-set aliasing does
14088 currently limit how stack slots can be reused, which is a lose. */
14089 #undef LANG_HOOKS_GET_ALIAS_SET
14090 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14094 /* Table indexed by tree code giving a string containing a character
14095 classifying the tree code. Possibilities are
14096 t, d, s, c, r, <, 1, 2 and e. See tree.def for details. */
14098 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14102 };
14103 #undef DEFTREECODE
14105 /* Table indexed by tree code giving number of expression
14106 operands beyond the fixed part of the node structure.
14107 Not used for types or decls. */
14109 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14113 };
14114 #undef DEFTREECODE
14116 /* Names of tree components.
14117 Used for printing out the tree and error messages. */
14118 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14122 };
14123 #undef DEFTREECODE
14128 {
14129 /* Open input file. */
14131 {
14134 }
14135 else
14140 #ifdef IO_BUFFER_SIZE
14142 #endif
14146 /* If the file is output from cpp, it should contain a first line
14147 `# 1 "real-filename"', and the current design of gcc (toplev.c
14148 in particular and the way it sets up information relied on by
14149 INCLUDE) requires that we read this now, and store the
14150 "real-filename" info in master_input_filename. Ask the lexer
14151 to try doing this. */
14154 /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14155 return the new file name. */
14160 }
14162 static void
14164 {
14171 }
14173 static void
14175 {
14176 /* Set default options for Fortran. */
14183 }
14185 static bool
14187 tree exp;
14188 {
14192 {
14209 {
14211 {
14214 }
14216 }
14218 {
14220 {
14223 }
14225 }
14228 /* drops in */
14234 #endif
14238 }
14239 }
14241 /* Exit a binding level.
14242 Pop the level off, and restore the state of the identifier-decl mappings
14243 that were in effect when this level was entered.
14245 If KEEP is nonzero, this level had explicit declarations, so
14246 and create a "block" (a BLOCK node) for the level
14247 to record its declarations and subblocks for symbol table output.
14249 If FUNCTIONBODY is nonzero, this level is the body of a function,
14250 so create a block as if KEEP were set and also clear out all
14251 label names.
14253 If REVERSE is nonzero, reverse the order of decls before putting
14254 them into the BLOCK. */
14256 tree
14261 {
14263 /* The chain of decls was accumulated in reverse order.
14264 Put it into forward order, just for cleanliness. */
14265 tree decls;
14268 tree decl;
14271 /* Get the decls in the order they were written.
14272 Usually current_binding_level->names is in reverse order.
14273 But parameter decls were previously put in forward order. */
14276 current_binding_level->names
14278 else
14281 /* Output any nested inline functions within this block
14282 if they weren't already output. */
14289 {
14290 /* If this decl was copied from a file-scope decl
14291 on account of a block-scope extern decl,
14292 propagate TREE_ADDRESSABLE to the file-scope decl.
14294 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14295 true, since then the decl goes through save_for_inline_copying. */
14300 {
14304 }
14305 }
14307 /* If there were any declarations or structure tags in that level,
14308 or if this level is a function body,
14309 create a BLOCK to record them for the life of this function. */
14318 {
14321 }
14323 /* In each subblock, record that this is its superior. */
14328 /* Clear out the meanings of the local variables of this level. */
14331 {
14333 {
14334 /* If the ident. was used or addressed via a local extern decl,
14335 don't forget that fact. */
14337 {
14342 }
14344 }
14345 }
14347 /* If the level being exited is the top level of a function,
14348 check over all the labels, and clear out the current
14349 (function local) meanings of their names. */
14352 {
14353 /* If this is the top level block of a function,
14354 the vars are the function's parameters.
14355 Don't leave them in the BLOCK because they are
14356 found in the FUNCTION_DECL instead. */
14359 }
14361 /* Pop the current level, and free the structure for reuse. */
14363 {
14369 }
14371 /* Dispose of the block that we just made inside some higher level. */
14376 {
14378 current_binding_level->blocks
14380 }
14381 /* If we did not make a block for the level just exited,
14382 any blocks made for inner levels
14383 (since they cannot be recorded as subblocks in that level)
14384 must be carried forward so they will later become subblocks
14385 of something else. */
14387 current_binding_level->blocks
14393 }
14395 static void
14398 tree node;
14400 {
14403 }
14405 /* Record a decl-node X as belonging to the current lexical scope.
14406 Check for errors (such as an incompatible declaration for the same
14407 name already seen in the same scope).
14409 Returns either X or an old decl for the same name.
14410 If an old decl is returned, it may have been smashed
14411 to agree with what X says. */
14413 tree
14415 tree x;
14416 {
14425 else
14429 {
14431 {
14434 }
14440 /* Don't push non-parms onto list for parms until we understand
14441 why we're doing this and whether it works. */
14444 || !ffecom_transform_only_dummies_
14450 /* If we are processing a typedef statement, generate a whole new
14451 ..._TYPE node (which will be just an variant of the existing
14452 ..._TYPE node with identical properties) and then install the
14453 TYPE_DECL node generated to represent the typedef name as the
14454 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14456 The whole point here is to end up with a situation where each and every
14457 ..._TYPE node the compiler creates will be uniquely associated with
14458 AT MOST one node representing a typedef name. This way, even though
14459 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14460 (i.e. "typedef name") nodes very early on, later parts of the
14461 compiler can always do the reverse translation and get back the
14462 corresponding typedef name. For example, given:
14464 typedef struct S MY_TYPE; MY_TYPE object;
14466 Later parts of the compiler might only know that `object' was of type
14467 `struct S' if it were not for code just below. With this code
14468 however, later parts of the compiler see something like:
14470 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14472 And they can then deduce (from the node for type struct S') that the
14473 original object declaration was:
14475 MY_TYPE object;
14477 Being able to do this is important for proper support of protoize, and
14478 also for generating precise symbolic debugging information which
14479 takes full account of the programmer's (typedef) vocabulary.
14481 Obviously, we don't want to generate a duplicate ..._TYPE node if the
14482 TYPE_DECL node that we are now processing really represents a
14483 standard built-in type.
14485 Since all standard types are effectively declared at line zero in the
14486 source file, we can easily check to see if we are working on a
14487 standard type by checking the current value of lineno. */
14490 {
14492 {
14495 }
14497 {
14503 }
14504 }
14506 /* This name is new in its binding level. Install the new declaration
14507 and return it. */
14510 else
14512 }
14514 /* Put decls on list in reverse order. We will reverse them later if
14515 necessary. */
14520 }
14522 /* Nonzero if the current level needs to have a BLOCK made. */
14524 static int
14526 {
14527 tree decl;
14530 decl;
14532 {
14535 /* Currently, there aren't supposed to be non-artificial names
14536 at other than the top block for a function -- they're
14537 believed to always be temps. But it's wise to check anyway. */
14539 }
14541 }
14543 /* Enter a new binding level.
14544 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14545 not for that of tags. */
14547 void
14550 {
14556 {
14558 }
14560 /* Reuse or create a struct for this binding level. */
14563 {
14566 }
14567 else
14568 {
14570 }
14572 /* Add this level to the front of the chain (stack) of levels that
14573 are active. */
14578 }
14580 /* Set the BLOCK node for the innermost scope
14581 (the one we are currently in). */
14583 void
14586 {
14592 }
14594 static tree
14597 tree type;
14598 {
14599 tree type2;
14620 }
14622 static tree
14624 tree type;
14625 {
14627 ffeinfoKindtype kt;
14628 tree type2;
14649 #endif
14656 {
14661 }
14664 }
14666 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14667 or validate its data type for an `if' or `while' statement or ?..: exp.
14669 This preparation consists of taking the ordinary
14670 representation of an expression expr and producing a valid tree
14671 boolean expression describing whether expr is nonzero. We could
14672 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14673 but we optimize comparisons, &&, ||, and !.
14675 The resulting type should always be `integer_type_node'. */
14677 static tree
14679 tree expr;
14680 {
14685 /* These really should return error_mark_node after 2.4 is stable.
14686 But not all callers handle ERROR_MARK properly. */
14688 {
14703 }
14707 {
14708 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14709 or comparison expressions as truth values at this level. */
14710 #if 0
14712 /* A one-bit unsigned bit-field is already acceptable. */
14717 #endif
14720 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14721 or comparison expressions as truth values at this level. */
14722 #if 0
14725 #endif
14748 else
14754 integer_type_node,
14762 /* These don't change whether an object is nonzero or zero. */
14767 /* These don't change whether an object is zero or nonzero, but
14768 we can't ignore them if their second arg has side-effects. */
14772 else
14776 {
14777 /* Distribute the conversion into the arms of a COND_EXPR. */
14786 }
14789 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14790 since that affects how `default_conversion' will behave. */
14794 /* fall through... */
14796 /* If this is widening the argument, we can ignore it. */
14803 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14804 this case. */
14808 /* fall through... */
14810 /* This and MINUS_EXPR can be changed into a comparison of the
14811 two objects. */
14832 #endif
14837 }
14843 integer_type_node,
14846 expr)),
14849 expr))));
14852 expr,
14854 }
14856 static tree
14860 {
14863 tree t;
14880 #if HOST_BITS_PER_WIDE_INT >= 64
14883 #endif
14902 {
14905 {
14908 else
14910 }
14911 }
14914 }
14916 static tree
14920 {
14921 ffeinfoKindtype kt;
14922 tree type_node;
14941 {
14947 }
14950 }
14952 static tree
14954 tree type;
14955 {
14957 ffeinfoKindtype kt;
14958 tree type2;
14979 #endif
14986 {
14991 }
14994 }
14995 \f
14996 /* From gcc/cccp.c, the code to handle -I. */
14998 /* Skip leading "./" from a directory name.
14999 This may yield the empty string, which represents the current directory. */
15003 {
15008 dir++;
15010 }
15012 /* The file_name_map structure holds a mapping of file names for a
15013 particular directory. This mapping is read from the file named
15014 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15015 map filenames on a file system with severe filename restrictions,
15016 such as DOS. The format of the file name map file is just a series
15017 of lines with two tokens on each line. The first token is the name
15018 to map, and the second token is the actual name to use. */
15020 struct file_name_map
15021 {
15025 };
15029 /* Current maximum length of directory names in the search path
15030 for include files. (Altered as we get more of them.) */
15034 struct file_name_list
15035 {
15038 /* Mapping of file names for this directory. */
15040 /* Nonzero if name_map is valid. */
15042 };
15047 /* I/O buffer structure.
15048 The `fname' field is nonzero for source files and #include files
15049 and for the dummy text used for -D and -U.
15050 It is zero for rescanning results of macro expansion
15051 and for expanding macro arguments. */
15052 #define INPUT_STACK_MAX 400
15055 /* Filename specified with #line command. */
15057 /* Record where in the search path this file was found.
15058 For #include_next. */
15060 ffewhereLine line;
15061 ffewhereColumn column;
15067 /* Current nesting level of input sources.
15068 `instack[indepth]' is the level currently being read. */
15073 /* Nonzero means -I- has been seen,
15074 so don't look for #include "foo" the source-file directory. */
15077 #ifndef INCLUDE_LEN_FUDGE
15078 #define INCLUDE_LEN_FUDGE 0
15079 #endif
15089 /* Append a chain of `struct file_name_list's
15090 to the end of the main include chain.
15091 FIRST is the beginning of the chain to append, and LAST is the end. */
15093 static void
15096 {
15104 else
15113 }
15117 }
15119 /* Try to open include file FILENAME. SEARCHPTR is the directory
15120 being tried from the include file search path. This function maps
15121 filenames on file systems based on information read by
15122 read_name_map. */
15128 {
15134 {
15138 }
15140 /* First check the mapping for the directory we are using. */
15142 {
15147 {
15149 {
15150 /* Found a match. */
15152 }
15153 }
15154 }
15156 /* Try to find a mapping file for the particular directory we are
15157 looking in. Thus #include <sys/types.h> will look up sys/types.h
15158 in /usr/include/header.gcc and look up types.h in
15159 /usr/include/sys/header.gcc. */
15161 #ifdef DIR_SEPARATOR
15166 }
15167 #endif
15174 {
15175 /* FILENAME is in SEARCHPTR, which we've already checked. */
15177 }
15180 {
15183 }
15184 else
15185 {
15192 }
15198 }
15200 /* Print the file names and line numbers of the #include
15201 commands which led to the current file. */
15203 static void
15205 {
15212 /* If stack of files hasn't changed since we last printed
15213 this info, don't repeat it. */
15221 }
15223 /* Give up if we don't find a source file. */
15227 /* Find the other, outer source files. */
15230 {
15233 {
15236 }
15237 else
15238 {
15240 }
15244 else
15247 /* xgettext:no-c-format */
15254 }
15256 /* Record we have printed the status as of this time. */
15258 }
15260 /* Read a space delimited string of unlimited length from a stdio
15261 file. */
15267 {
15274 {
15277 {
15279 {
15283 }
15285 }
15286 }
15290 }
15292 /* Read the file name map file for DIRNAME. */
15297 {
15298 /* This structure holds a linked list of file name maps, one per
15299 directory. */
15300 struct file_name_map_list
15301 {
15305 };
15329 else
15335 else
15336 {
15340 {
15348 ;
15355 /* Make the real filename absolute. */
15358 else
15359 {
15362 else
15365 }
15373 }
15375 }
15381 }
15383 static void
15385 {
15388 /* Do partial setup of input buffer for the sake of generating
15389 early #line directives (when -g is in effect). */
15396 }
15398 static void
15400 {
15403 indepth--;
15404 input_file_stack_tick++;
15408 }
15410 static int
15412 {
15417 else
15418 {
15426 else
15428 }
15430 }
15432 /* Open INCLUDEd file. */
15436 {
15451 /* If -I- was specified, don't search current dir, only spec'd ones. */
15453 {
15455 {
15461 {
15462 /* Found a named file. Figure out dir of the file,
15463 and put it in front of the search list. */
15466 #ifndef VMS
15468 #ifdef DIR_SEPARATOR
15473 }
15474 #endif
15482 {
15489 }
15490 else
15494 }
15495 }
15496 }
15498 /* Allocate this permanently, because it gets stored in the definitions
15499 of macros. */
15501 /* + 2 above for slash and terminating null. */
15502 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15503 for g77 yet). */
15505 /* If specified file name is absolute, just open it. */
15508 #ifdef DIR_SEPARATOR
15510 #endif
15511 )
15512 {
15516 }
15517 else
15518 {
15521 /* Search directory path, trying to open the file.
15522 Copy each filename tried into FNAME. */
15525 {
15527 {
15528 /* The empty string in a search path is ignored.
15529 This makes it possible to turn off entirely
15530 a standard piece of the list. */
15537 }
15538 else
15542 #ifdef VMS
15543 /* Change this 1/2 Unix 1/2 VMS file specification into a
15544 full VMS file specification */
15546 {
15547 /* Fix up the filename */
15549 }
15550 else
15551 {
15552 /* This is a normal VMS filespec, so use it unchanged. */
15556 /* if it's '#include filename', add the missing .h */
15559 #endif
15560 }
15563 #ifdef EACCES
15565 {
15567 /* xgettext:no-c-format */
15569 FFEBAD_severityWARNING);
15573 }
15574 #endif
15577 }
15578 }
15581 {
15582 /* A file that was not found. */
15591 }
15600 {
15602 /* xgettext:no-c-format */
15604 FFEBAD_severityFATAL);
15609 }
15619 indepth++;
15620 input_file_stack_tick++;
15623 }
15625 /**INDENT* (Do not reformat this comment even with -fca option.)
15626 Data-gathering files: Given the source file listed below, compiled with
15627 f2c I obtained the output file listed after that, and from the output
15628 file I derived the above code.
15630 -------- (begin input file to f2c)
15631 implicit none
15632 character*10 A1,A2
15633 complex C1,C2
15634 integer I1,I2
15635 real R1,R2
15636 double precision D1,D2
15637 C
15638 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15639 c /
15640 call fooI(I1/I2)
15641 call fooR(R1/I1)
15642 call fooD(D1/I1)
15643 call fooC(C1/I1)
15644 call fooR(R1/R2)
15645 call fooD(R1/D1)
15646 call fooD(D1/D2)
15647 call fooD(D1/R1)
15648 call fooC(C1/C2)
15649 call fooC(C1/R1)
15650 call fooZ(C1/D1)
15651 c **
15652 call fooI(I1**I2)
15653 call fooR(R1**I1)
15654 call fooD(D1**I1)
15655 call fooC(C1**I1)
15656 call fooR(R1**R2)
15657 call fooD(R1**D1)
15658 call fooD(D1**D2)
15659 call fooD(D1**R1)
15660 call fooC(C1**C2)
15661 call fooC(C1**R1)
15662 call fooZ(C1**D1)
15663 c FFEINTRIN_impABS
15664 call fooR(ABS(R1))
15665 c FFEINTRIN_impACOS
15666 call fooR(ACOS(R1))
15667 c FFEINTRIN_impAIMAG
15668 call fooR(AIMAG(C1))
15669 c FFEINTRIN_impAINT
15670 call fooR(AINT(R1))
15671 c FFEINTRIN_impALOG
15672 call fooR(ALOG(R1))
15673 c FFEINTRIN_impALOG10
15674 call fooR(ALOG10(R1))
15675 c FFEINTRIN_impAMAX0
15676 call fooR(AMAX0(I1,I2))
15677 c FFEINTRIN_impAMAX1
15678 call fooR(AMAX1(R1,R2))
15679 c FFEINTRIN_impAMIN0
15680 call fooR(AMIN0(I1,I2))
15681 c FFEINTRIN_impAMIN1
15682 call fooR(AMIN1(R1,R2))
15683 c FFEINTRIN_impAMOD
15684 call fooR(AMOD(R1,R2))
15685 c FFEINTRIN_impANINT
15686 call fooR(ANINT(R1))
15687 c FFEINTRIN_impASIN
15688 call fooR(ASIN(R1))
15689 c FFEINTRIN_impATAN
15690 call fooR(ATAN(R1))
15691 c FFEINTRIN_impATAN2
15692 call fooR(ATAN2(R1,R2))
15693 c FFEINTRIN_impCABS
15694 call fooR(CABS(C1))
15695 c FFEINTRIN_impCCOS
15696 call fooC(CCOS(C1))
15697 c FFEINTRIN_impCEXP
15698 call fooC(CEXP(C1))
15699 c FFEINTRIN_impCHAR
15700 call fooA(CHAR(I1))
15701 c FFEINTRIN_impCLOG
15702 call fooC(CLOG(C1))
15703 c FFEINTRIN_impCONJG
15704 call fooC(CONJG(C1))
15705 c FFEINTRIN_impCOS
15706 call fooR(COS(R1))
15707 c FFEINTRIN_impCOSH
15708 call fooR(COSH(R1))
15709 c FFEINTRIN_impCSIN
15710 call fooC(CSIN(C1))
15711 c FFEINTRIN_impCSQRT
15712 call fooC(CSQRT(C1))
15713 c FFEINTRIN_impDABS
15714 call fooD(DABS(D1))
15715 c FFEINTRIN_impDACOS
15716 call fooD(DACOS(D1))
15717 c FFEINTRIN_impDASIN
15718 call fooD(DASIN(D1))
15719 c FFEINTRIN_impDATAN
15720 call fooD(DATAN(D1))
15721 c FFEINTRIN_impDATAN2
15722 call fooD(DATAN2(D1,D2))
15723 c FFEINTRIN_impDCOS
15724 call fooD(DCOS(D1))
15725 c FFEINTRIN_impDCOSH
15726 call fooD(DCOSH(D1))
15727 c FFEINTRIN_impDDIM
15728 call fooD(DDIM(D1,D2))
15729 c FFEINTRIN_impDEXP
15730 call fooD(DEXP(D1))
15731 c FFEINTRIN_impDIM
15732 call fooR(DIM(R1,R2))
15733 c FFEINTRIN_impDINT
15734 call fooD(DINT(D1))
15735 c FFEINTRIN_impDLOG
15736 call fooD(DLOG(D1))
15737 c FFEINTRIN_impDLOG10
15738 call fooD(DLOG10(D1))
15739 c FFEINTRIN_impDMAX1
15740 call fooD(DMAX1(D1,D2))
15741 c FFEINTRIN_impDMIN1
15742 call fooD(DMIN1(D1,D2))
15743 c FFEINTRIN_impDMOD
15744 call fooD(DMOD(D1,D2))
15745 c FFEINTRIN_impDNINT
15746 call fooD(DNINT(D1))
15747 c FFEINTRIN_impDPROD
15748 call fooD(DPROD(R1,R2))
15749 c FFEINTRIN_impDSIGN
15750 call fooD(DSIGN(D1,D2))
15751 c FFEINTRIN_impDSIN
15752 call fooD(DSIN(D1))
15753 c FFEINTRIN_impDSINH
15754 call fooD(DSINH(D1))
15755 c FFEINTRIN_impDSQRT
15756 call fooD(DSQRT(D1))
15757 c FFEINTRIN_impDTAN
15758 call fooD(DTAN(D1))
15759 c FFEINTRIN_impDTANH
15760 call fooD(DTANH(D1))
15761 c FFEINTRIN_impEXP
15762 call fooR(EXP(R1))
15763 c FFEINTRIN_impIABS
15764 call fooI(IABS(I1))
15765 c FFEINTRIN_impICHAR
15766 call fooI(ICHAR(A1))
15767 c FFEINTRIN_impIDIM
15768 call fooI(IDIM(I1,I2))
15769 c FFEINTRIN_impIDNINT
15770 call fooI(IDNINT(D1))
15771 c FFEINTRIN_impINDEX
15772 call fooI(INDEX(A1,A2))
15773 c FFEINTRIN_impISIGN
15774 call fooI(ISIGN(I1,I2))
15775 c FFEINTRIN_impLEN
15776 call fooI(LEN(A1))
15777 c FFEINTRIN_impLGE
15778 call fooL(LGE(A1,A2))
15779 c FFEINTRIN_impLGT
15780 call fooL(LGT(A1,A2))
15781 c FFEINTRIN_impLLE
15782 call fooL(LLE(A1,A2))
15783 c FFEINTRIN_impLLT
15784 call fooL(LLT(A1,A2))
15785 c FFEINTRIN_impMAX0
15786 call fooI(MAX0(I1,I2))
15787 c FFEINTRIN_impMAX1
15788 call fooI(MAX1(R1,R2))
15789 c FFEINTRIN_impMIN0
15790 call fooI(MIN0(I1,I2))
15791 c FFEINTRIN_impMIN1
15792 call fooI(MIN1(R1,R2))
15793 c FFEINTRIN_impMOD
15794 call fooI(MOD(I1,I2))
15795 c FFEINTRIN_impNINT
15796 call fooI(NINT(R1))
15797 c FFEINTRIN_impSIGN
15798 call fooR(SIGN(R1,R2))
15799 c FFEINTRIN_impSIN
15800 call fooR(SIN(R1))
15801 c FFEINTRIN_impSINH
15802 call fooR(SINH(R1))
15803 c FFEINTRIN_impSQRT
15804 call fooR(SQRT(R1))
15805 c FFEINTRIN_impTAN
15806 call fooR(TAN(R1))
15807 c FFEINTRIN_impTANH
15808 call fooR(TANH(R1))
15809 c FFEINTRIN_imp_CMPLX_C
15810 call fooC(cmplx(C1,C2))
15811 c FFEINTRIN_imp_CMPLX_D
15812 call fooZ(cmplx(D1,D2))
15813 c FFEINTRIN_imp_CMPLX_I
15814 call fooC(cmplx(I1,I2))
15815 c FFEINTRIN_imp_CMPLX_R
15816 call fooC(cmplx(R1,R2))
15817 c FFEINTRIN_imp_DBLE_C
15818 call fooD(dble(C1))
15819 c FFEINTRIN_imp_DBLE_D
15820 call fooD(dble(D1))
15821 c FFEINTRIN_imp_DBLE_I
15822 call fooD(dble(I1))
15823 c FFEINTRIN_imp_DBLE_R
15824 call fooD(dble(R1))
15825 c FFEINTRIN_imp_INT_C
15826 call fooI(int(C1))
15827 c FFEINTRIN_imp_INT_D
15828 call fooI(int(D1))
15829 c FFEINTRIN_imp_INT_I
15830 call fooI(int(I1))
15831 c FFEINTRIN_imp_INT_R
15832 call fooI(int(R1))
15833 c FFEINTRIN_imp_REAL_C
15834 call fooR(real(C1))
15835 c FFEINTRIN_imp_REAL_D
15836 call fooR(real(D1))
15837 c FFEINTRIN_imp_REAL_I
15838 call fooR(real(I1))
15839 c FFEINTRIN_imp_REAL_R
15840 call fooR(real(R1))
15841 c
15842 c FFEINTRIN_imp_INT_D:
15843 c
15844 c FFEINTRIN_specIDINT
15845 call fooI(IDINT(D1))
15846 c
15847 c FFEINTRIN_imp_INT_R:
15848 c
15849 c FFEINTRIN_specIFIX
15850 call fooI(IFIX(R1))
15851 c FFEINTRIN_specINT
15852 call fooI(INT(R1))
15853 c
15854 c FFEINTRIN_imp_REAL_D:
15855 c
15856 c FFEINTRIN_specSNGL
15857 call fooR(SNGL(D1))
15858 c
15859 c FFEINTRIN_imp_REAL_I:
15860 c
15861 c FFEINTRIN_specFLOAT
15862 call fooR(FLOAT(I1))
15863 c FFEINTRIN_specREAL
15864 call fooR(REAL(I1))
15865 c
15866 end
15867 -------- (end input file to f2c)
15869 -------- (begin output from providing above input file as input to:
15870 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
15871 -------- -e "s:^#.*$::g"')
15873 // -- translated by f2c (version 19950223).
15874 You must link the resulting object file with the libraries:
15875 -lf2c -lm (in that order)
15876 //
15879 // f2c.h -- Standard Fortran to C header file //
15881 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
15883 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
15888 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
15889 // we assume short, float are OK //
15890 typedef long int // long int // integer;
15891 typedef char *address;
15892 typedef short int shortint;
15893 typedef float real;
15894 typedef double doublereal;
15895 typedef struct { real r, i; } complex;
15896 typedef struct { doublereal r, i; } doublecomplex;
15897 typedef long int // long int // logical;
15898 typedef short int shortlogical;
15899 typedef char logical1;
15900 typedef char integer1;
15901 // typedef long long longint; // // system-dependent //
15906 // Extern is for use with -E //
15911 // I/O stuff //
15920 typedef long int // int or long int // flag;
15921 typedef long int // int or long int // ftnlen;
15922 typedef long int // int or long int // ftnint;
15925 //external read, write//
15926 typedef struct
15927 { flag cierr;
15928 ftnint ciunit;
15929 flag ciend;
15930 char *cifmt;
15931 ftnint cirec;
15932 } cilist;
15934 //internal read, write//
15935 typedef struct
15936 { flag icierr;
15937 char *iciunit;
15938 flag iciend;
15939 char *icifmt;
15940 ftnint icirlen;
15941 ftnint icirnum;
15942 } icilist;
15944 //open//
15945 typedef struct
15946 { flag oerr;
15947 ftnint ounit;
15948 char *ofnm;
15949 ftnlen ofnmlen;
15950 char *osta;
15951 char *oacc;
15952 char *ofm;
15953 ftnint orl;
15954 char *oblnk;
15955 } olist;
15957 //close//
15958 typedef struct
15959 { flag cerr;
15960 ftnint cunit;
15961 char *csta;
15962 } cllist;
15964 //rewind, backspace, endfile//
15965 typedef struct
15966 { flag aerr;
15967 ftnint aunit;
15968 } alist;
15970 // inquire //
15971 typedef struct
15972 { flag inerr;
15973 ftnint inunit;
15974 char *infile;
15975 ftnlen infilen;
15976 ftnint *inex; //parameters in standard's order//
15977 ftnint *inopen;
15978 ftnint *innum;
15979 ftnint *innamed;
15980 char *inname;
15981 ftnlen innamlen;
15982 char *inacc;
15983 ftnlen inacclen;
15984 char *inseq;
15985 ftnlen inseqlen;
15986 char *indir;
15987 ftnlen indirlen;
15988 char *infmt;
15989 ftnlen infmtlen;
15990 char *inform;
15991 ftnint informlen;
15992 char *inunf;
15993 ftnlen inunflen;
15994 ftnint *inrecl;
15995 ftnint *innrec;
15996 char *inblank;
15997 ftnlen inblanklen;
15998 } inlist;
16002 union Multitype { // for multiple entry points //
16003 integer1 g;
16004 shortint h;
16005 integer i;
16006 // longint j; //
16007 real r;
16008 doublereal d;
16009 complex c;
16010 doublecomplex z;
16011 };
16013 typedef union Multitype Multitype;
16015 typedef long Long; // No longer used; formerly in Namelist //
16017 struct Vardesc { // for Namelist //
16018 char *name;
16019 char *addr;
16020 ftnlen *dims;
16021 int type;
16022 };
16023 typedef struct Vardesc Vardesc;
16025 struct Namelist {
16026 char *name;
16027 Vardesc **vars;
16028 int nvars;
16029 };
16030 typedef struct Namelist Namelist;
16039 // procedure parameter types for -A and -C++ //
16044 typedef int // Unknown procedure type // (*U_fp)();
16045 typedef shortint (*J_fp)();
16046 typedef integer (*I_fp)();
16047 typedef real (*R_fp)();
16048 typedef doublereal (*D_fp)(), (*E_fp)();
16049 typedef // Complex // void (*C_fp)();
16050 typedef // Double Complex // void (*Z_fp)();
16051 typedef logical (*L_fp)();
16052 typedef shortlogical (*K_fp)();
16053 typedef // Character // void (*H_fp)();
16054 typedef // Subroutine // int (*S_fp)();
16056 // E_fp is for real functions when -R is not specified //
16057 typedef void C_f; // complex function //
16058 typedef void H_f; // character function //
16059 typedef void Z_f; // double complex function //
16060 typedef doublereal E_f; // real function with -R not specified //
16062 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16065 // (No such symbols should be defined in a strict ANSI C compiler.
16066 We can avoid trouble with f2c-translated code by using
16067 gcc -ansi.) //
16091 // Main program // MAIN__()
16092 {
16093 // System generated locals //
16094 integer i__1;
16095 real r__1, r__2;
16096 doublereal d__1, d__2;
16097 complex q__1;
16098 doublecomplex z__1, z__2, z__3;
16099 logical L__1;
16100 char ch__1[1];
16102 // Builtin functions //
16103 void c_div();
16104 integer pow_ii();
16105 double pow_ri(), pow_di();
16106 void pow_ci();
16107 double pow_dd();
16108 void pow_zz();
16109 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16110 asin(), atan(), atan2(), c_abs();
16111 void c_cos(), c_exp(), c_log(), r_cnjg();
16112 double cos(), cosh();
16113 void c_sin(), c_sqrt();
16114 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16115 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16116 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16117 logical l_ge(), l_gt(), l_le(), l_lt();
16118 integer i_nint();
16119 double r_sign();
16121 // Local variables //
16122 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16123 fool_(), fooz_(), getem_();
16124 static char a1[10], a2[10];
16125 static complex c1, c2;
16126 static doublereal d1, d2;
16127 static integer i1, i2;
16128 static real r1, r2;
16131 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16132 // / //
16133 i__1 = i1 / i2;
16134 fooi_(&i__1);
16135 r__1 = r1 / i1;
16136 foor_(&r__1);
16137 d__1 = d1 / i1;
16138 food_(&d__1);
16139 d__1 = (doublereal) i1;
16140 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16141 fooc_(&q__1);
16142 r__1 = r1 / r2;
16143 foor_(&r__1);
16144 d__1 = r1 / d1;
16145 food_(&d__1);
16146 d__1 = d1 / d2;
16147 food_(&d__1);
16148 d__1 = d1 / r1;
16149 food_(&d__1);
16150 c_div(&q__1, &c1, &c2);
16151 fooc_(&q__1);
16152 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16153 fooc_(&q__1);
16154 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16155 fooz_(&z__1);
16156 // ** //
16157 i__1 = pow_ii(&i1, &i2);
16158 fooi_(&i__1);
16159 r__1 = pow_ri(&r1, &i1);
16160 foor_(&r__1);
16161 d__1 = pow_di(&d1, &i1);
16162 food_(&d__1);
16163 pow_ci(&q__1, &c1, &i1);
16164 fooc_(&q__1);
16165 d__1 = (doublereal) r1;
16166 d__2 = (doublereal) r2;
16167 r__1 = pow_dd(&d__1, &d__2);
16168 foor_(&r__1);
16169 d__2 = (doublereal) r1;
16170 d__1 = pow_dd(&d__2, &d1);
16171 food_(&d__1);
16172 d__1 = pow_dd(&d1, &d2);
16173 food_(&d__1);
16174 d__2 = (doublereal) r1;
16175 d__1 = pow_dd(&d1, &d__2);
16176 food_(&d__1);
16177 z__2.r = c1.r, z__2.i = c1.i;
16178 z__3.r = c2.r, z__3.i = c2.i;
16179 pow_zz(&z__1, &z__2, &z__3);
16180 q__1.r = z__1.r, q__1.i = z__1.i;
16181 fooc_(&q__1);
16182 z__2.r = c1.r, z__2.i = c1.i;
16183 z__3.r = r1, z__3.i = 0.;
16184 pow_zz(&z__1, &z__2, &z__3);
16185 q__1.r = z__1.r, q__1.i = z__1.i;
16186 fooc_(&q__1);
16187 z__2.r = c1.r, z__2.i = c1.i;
16188 z__3.r = d1, z__3.i = 0.;
16189 pow_zz(&z__1, &z__2, &z__3);
16190 fooz_(&z__1);
16191 // FFEINTRIN_impABS //
16192 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16193 foor_(&r__1);
16194 // FFEINTRIN_impACOS //
16195 r__1 = acos(r1);
16196 foor_(&r__1);
16197 // FFEINTRIN_impAIMAG //
16198 r__1 = r_imag(&c1);
16199 foor_(&r__1);
16200 // FFEINTRIN_impAINT //
16201 r__1 = r_int(&r1);
16202 foor_(&r__1);
16203 // FFEINTRIN_impALOG //
16204 r__1 = log(r1);
16205 foor_(&r__1);
16206 // FFEINTRIN_impALOG10 //
16207 r__1 = r_lg10(&r1);
16208 foor_(&r__1);
16209 // FFEINTRIN_impAMAX0 //
16210 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16211 foor_(&r__1);
16212 // FFEINTRIN_impAMAX1 //
16213 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16214 foor_(&r__1);
16215 // FFEINTRIN_impAMIN0 //
16216 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16217 foor_(&r__1);
16218 // FFEINTRIN_impAMIN1 //
16219 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16220 foor_(&r__1);
16221 // FFEINTRIN_impAMOD //
16222 r__1 = r_mod(&r1, &r2);
16223 foor_(&r__1);
16224 // FFEINTRIN_impANINT //
16225 r__1 = r_nint(&r1);
16226 foor_(&r__1);
16227 // FFEINTRIN_impASIN //
16228 r__1 = asin(r1);
16229 foor_(&r__1);
16230 // FFEINTRIN_impATAN //
16231 r__1 = atan(r1);
16232 foor_(&r__1);
16233 // FFEINTRIN_impATAN2 //
16234 r__1 = atan2(r1, r2);
16235 foor_(&r__1);
16236 // FFEINTRIN_impCABS //
16237 r__1 = c_abs(&c1);
16238 foor_(&r__1);
16239 // FFEINTRIN_impCCOS //
16240 c_cos(&q__1, &c1);
16241 fooc_(&q__1);
16242 // FFEINTRIN_impCEXP //
16243 c_exp(&q__1, &c1);
16244 fooc_(&q__1);
16245 // FFEINTRIN_impCHAR //
16246 *(unsigned char *)&ch__1[0] = i1;
16247 fooa_(ch__1, 1L);
16248 // FFEINTRIN_impCLOG //
16249 c_log(&q__1, &c1);
16250 fooc_(&q__1);
16251 // FFEINTRIN_impCONJG //
16252 r_cnjg(&q__1, &c1);
16253 fooc_(&q__1);
16254 // FFEINTRIN_impCOS //
16255 r__1 = cos(r1);
16256 foor_(&r__1);
16257 // FFEINTRIN_impCOSH //
16258 r__1 = cosh(r1);
16259 foor_(&r__1);
16260 // FFEINTRIN_impCSIN //
16261 c_sin(&q__1, &c1);
16262 fooc_(&q__1);
16263 // FFEINTRIN_impCSQRT //
16264 c_sqrt(&q__1, &c1);
16265 fooc_(&q__1);
16266 // FFEINTRIN_impDABS //
16267 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16268 food_(&d__1);
16269 // FFEINTRIN_impDACOS //
16270 d__1 = acos(d1);
16271 food_(&d__1);
16272 // FFEINTRIN_impDASIN //
16273 d__1 = asin(d1);
16274 food_(&d__1);
16275 // FFEINTRIN_impDATAN //
16276 d__1 = atan(d1);
16277 food_(&d__1);
16278 // FFEINTRIN_impDATAN2 //
16279 d__1 = atan2(d1, d2);
16280 food_(&d__1);
16281 // FFEINTRIN_impDCOS //
16282 d__1 = cos(d1);
16283 food_(&d__1);
16284 // FFEINTRIN_impDCOSH //
16285 d__1 = cosh(d1);
16286 food_(&d__1);
16287 // FFEINTRIN_impDDIM //
16288 d__1 = d_dim(&d1, &d2);
16289 food_(&d__1);
16290 // FFEINTRIN_impDEXP //
16291 d__1 = exp(d1);
16292 food_(&d__1);
16293 // FFEINTRIN_impDIM //
16294 r__1 = r_dim(&r1, &r2);
16295 foor_(&r__1);
16296 // FFEINTRIN_impDINT //
16297 d__1 = d_int(&d1);
16298 food_(&d__1);
16299 // FFEINTRIN_impDLOG //
16300 d__1 = log(d1);
16301 food_(&d__1);
16302 // FFEINTRIN_impDLOG10 //
16303 d__1 = d_lg10(&d1);
16304 food_(&d__1);
16305 // FFEINTRIN_impDMAX1 //
16306 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16307 food_(&d__1);
16308 // FFEINTRIN_impDMIN1 //
16309 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16310 food_(&d__1);
16311 // FFEINTRIN_impDMOD //
16312 d__1 = d_mod(&d1, &d2);
16313 food_(&d__1);
16314 // FFEINTRIN_impDNINT //
16315 d__1 = d_nint(&d1);
16316 food_(&d__1);
16317 // FFEINTRIN_impDPROD //
16318 d__1 = (doublereal) r1 * r2;
16319 food_(&d__1);
16320 // FFEINTRIN_impDSIGN //
16321 d__1 = d_sign(&d1, &d2);
16322 food_(&d__1);
16323 // FFEINTRIN_impDSIN //
16324 d__1 = sin(d1);
16325 food_(&d__1);
16326 // FFEINTRIN_impDSINH //
16327 d__1 = sinh(d1);
16328 food_(&d__1);
16329 // FFEINTRIN_impDSQRT //
16330 d__1 = sqrt(d1);
16331 food_(&d__1);
16332 // FFEINTRIN_impDTAN //
16333 d__1 = tan(d1);
16334 food_(&d__1);
16335 // FFEINTRIN_impDTANH //
16336 d__1 = tanh(d1);
16337 food_(&d__1);
16338 // FFEINTRIN_impEXP //
16339 r__1 = exp(r1);
16340 foor_(&r__1);
16341 // FFEINTRIN_impIABS //
16342 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16343 fooi_(&i__1);
16344 // FFEINTRIN_impICHAR //
16345 i__1 = *(unsigned char *)a1;
16346 fooi_(&i__1);
16347 // FFEINTRIN_impIDIM //
16348 i__1 = i_dim(&i1, &i2);
16349 fooi_(&i__1);
16350 // FFEINTRIN_impIDNINT //
16351 i__1 = i_dnnt(&d1);
16352 fooi_(&i__1);
16353 // FFEINTRIN_impINDEX //
16354 i__1 = i_indx(a1, a2, 10L, 10L);
16355 fooi_(&i__1);
16356 // FFEINTRIN_impISIGN //
16357 i__1 = i_sign(&i1, &i2);
16358 fooi_(&i__1);
16359 // FFEINTRIN_impLEN //
16360 i__1 = i_len(a1, 10L);
16361 fooi_(&i__1);
16362 // FFEINTRIN_impLGE //
16363 L__1 = l_ge(a1, a2, 10L, 10L);
16364 fool_(&L__1);
16365 // FFEINTRIN_impLGT //
16366 L__1 = l_gt(a1, a2, 10L, 10L);
16367 fool_(&L__1);
16368 // FFEINTRIN_impLLE //
16369 L__1 = l_le(a1, a2, 10L, 10L);
16370 fool_(&L__1);
16371 // FFEINTRIN_impLLT //
16372 L__1 = l_lt(a1, a2, 10L, 10L);
16373 fool_(&L__1);
16374 // FFEINTRIN_impMAX0 //
16375 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16376 fooi_(&i__1);
16377 // FFEINTRIN_impMAX1 //
16378 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16379 fooi_(&i__1);
16380 // FFEINTRIN_impMIN0 //
16381 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16382 fooi_(&i__1);
16383 // FFEINTRIN_impMIN1 //
16384 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16385 fooi_(&i__1);
16386 // FFEINTRIN_impMOD //
16387 i__1 = i1 % i2;
16388 fooi_(&i__1);
16389 // FFEINTRIN_impNINT //
16390 i__1 = i_nint(&r1);
16391 fooi_(&i__1);
16392 // FFEINTRIN_impSIGN //
16393 r__1 = r_sign(&r1, &r2);
16394 foor_(&r__1);
16395 // FFEINTRIN_impSIN //
16396 r__1 = sin(r1);
16397 foor_(&r__1);
16398 // FFEINTRIN_impSINH //
16399 r__1 = sinh(r1);
16400 foor_(&r__1);
16401 // FFEINTRIN_impSQRT //
16402 r__1 = sqrt(r1);
16403 foor_(&r__1);
16404 // FFEINTRIN_impTAN //
16405 r__1 = tan(r1);
16406 foor_(&r__1);
16407 // FFEINTRIN_impTANH //
16408 r__1 = tanh(r1);
16409 foor_(&r__1);
16410 // FFEINTRIN_imp_CMPLX_C //
16411 r__1 = c1.r;
16412 r__2 = c2.r;
16413 q__1.r = r__1, q__1.i = r__2;
16414 fooc_(&q__1);
16415 // FFEINTRIN_imp_CMPLX_D //
16416 z__1.r = d1, z__1.i = d2;
16417 fooz_(&z__1);
16418 // FFEINTRIN_imp_CMPLX_I //
16419 r__1 = (real) i1;
16420 r__2 = (real) i2;
16421 q__1.r = r__1, q__1.i = r__2;
16422 fooc_(&q__1);
16423 // FFEINTRIN_imp_CMPLX_R //
16424 q__1.r = r1, q__1.i = r2;
16425 fooc_(&q__1);
16426 // FFEINTRIN_imp_DBLE_C //
16427 d__1 = (doublereal) c1.r;
16428 food_(&d__1);
16429 // FFEINTRIN_imp_DBLE_D //
16430 d__1 = d1;
16431 food_(&d__1);
16432 // FFEINTRIN_imp_DBLE_I //
16433 d__1 = (doublereal) i1;
16434 food_(&d__1);
16435 // FFEINTRIN_imp_DBLE_R //
16436 d__1 = (doublereal) r1;
16437 food_(&d__1);
16438 // FFEINTRIN_imp_INT_C //
16439 i__1 = (integer) c1.r;
16440 fooi_(&i__1);
16441 // FFEINTRIN_imp_INT_D //
16442 i__1 = (integer) d1;
16443 fooi_(&i__1);
16444 // FFEINTRIN_imp_INT_I //
16445 i__1 = i1;
16446 fooi_(&i__1);
16447 // FFEINTRIN_imp_INT_R //
16448 i__1 = (integer) r1;
16449 fooi_(&i__1);
16450 // FFEINTRIN_imp_REAL_C //
16451 r__1 = c1.r;
16452 foor_(&r__1);
16453 // FFEINTRIN_imp_REAL_D //
16454 r__1 = (real) d1;
16455 foor_(&r__1);
16456 // FFEINTRIN_imp_REAL_I //
16457 r__1 = (real) i1;
16458 foor_(&r__1);
16459 // FFEINTRIN_imp_REAL_R //
16460 r__1 = r1;
16461 foor_(&r__1);
16463 // FFEINTRIN_imp_INT_D: //
16465 // FFEINTRIN_specIDINT //
16466 i__1 = (integer) d1;
16467 fooi_(&i__1);
16469 // FFEINTRIN_imp_INT_R: //
16471 // FFEINTRIN_specIFIX //
16472 i__1 = (integer) r1;
16473 fooi_(&i__1);
16474 // FFEINTRIN_specINT //
16475 i__1 = (integer) r1;
16476 fooi_(&i__1);
16478 // FFEINTRIN_imp_REAL_D: //
16480 // FFEINTRIN_specSNGL //
16481 r__1 = (real) d1;
16482 foor_(&r__1);
16484 // FFEINTRIN_imp_REAL_I: //
16486 // FFEINTRIN_specFLOAT //
16487 r__1 = (real) i1;
16488 foor_(&r__1);
16489 // FFEINTRIN_specREAL //
16490 r__1 = (real) i1;
16491 foor_(&r__1);
16493 } // MAIN__ //
16495 -------- (end output file from f2c)
16497 */