| blob | 951e01891ba584d753f4804e930ad48a683da802 |
1 /* com.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
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
141 /* Externals defined here. */
143 /* Stream for reading from the input file. */
146 /* These definitions parallel those in c-decl.c so that code from that
147 module can be used pretty much as is. Much of these defs aren't
148 otherwise used, i.e. by g77 code per se, except some of them are used
149 to build some of them that are. The ones that are global (i.e. not
150 "static") are those that ste.c and such might use (directly
151 or by using com macros that reference them in their definitions). */
153 tree string_type_node;
155 /* The rest of these are inventions for g77, though there might be
156 similar things in the C front end. As they are found, these
157 inventions should be renamed to be canonical. Note that only
158 the ones currently required to be global are so. */
167 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
168 just use build_function_type and build_pointer_type on the
169 appropriate _tree_type array element. */
180 ffecomSymbol ffecom_symbol_null_
181 =
182 {
183 NULL_TREE,
184 NULL_TREE,
185 NULL_TREE,
186 NULL_TREE,
187 false
188 };
193 tree ffecom_f2c_integer_type_node;
195 tree ffecom_f2c_address_type_node;
196 tree ffecom_f2c_real_type_node;
198 tree ffecom_f2c_doublereal_type_node;
199 tree ffecom_f2c_complex_type_node;
200 tree ffecom_f2c_doublecomplex_type_node;
201 tree ffecom_f2c_longint_type_node;
202 tree ffecom_f2c_logical_type_node;
203 tree ffecom_f2c_flag_type_node;
204 tree ffecom_f2c_ftnlen_type_node;
205 tree ffecom_f2c_ftnlen_zero_node;
206 tree ffecom_f2c_ftnlen_one_node;
207 tree ffecom_f2c_ftnlen_two_node;
208 tree ffecom_f2c_ptr_to_ftnlen_type_node;
209 tree ffecom_f2c_ftnint_type_node;
210 tree ffecom_f2c_ptr_to_ftnint_type_node;
212 /* Simple definitions and enumerations. */
214 #ifndef FFECOM_sizeMAXSTACKITEM
216 larger than this # bytes
217 off stack if possible. */
218 #endif
220 /* For systems that have large enough stacks, they should define
221 this to 0, and here, for ease of use later on, we just undefine
222 it if it is 0. */
224 #if FFECOM_sizeMAXSTACKITEM == 0
225 #undef FFECOM_sizeMAXSTACKITEM
226 #endif
229 {
230 FFECOM_rttypeVOID_,
245 FFECOM_rttype_
248 /* Internal typedefs. */
252 /* Private include files. */
255 /* Internal structure definitions. */
257 struct _ffecom_concat_list_
258 {
262 ffetargetCharacterSize minlen;
263 ffetargetCharacterSize maxlen;
264 };
266 /* Static functions (internal). */
300 static ffecomConcatList_
302 ffebld expr,
303 ffetargetCharacterSize max);
306 ffetargetCharacterSize max);
309 ffetargetOffset offset);
326 ffeinfoBasictype bt,
327 ffeinfoKindtype kt);
335 tree dest_length,
336 ffetargetCharacterSize dest_size,
337 ffebld source);
342 ffebld source);
352 tree t);
359 ffeinfoBasictype bt,
360 ffeinfoKindtype kt);
369 /* These are static functions that parallel those found in the C front
370 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 type 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 `item' is the array decl or NULL_TREE.
647 */
649 static tree
652 {
655 tree cond;
656 tree die;
657 tree args;
663 {
667 else
668 {
672 }
673 }
677 {
678 /* Special handling for substring range checks. Fortran allows the
679 end subscript < begin subscript, which means that expressions like
680 string(1:0) are valid (and yield a null string). In view of this,
681 enforce two simpler conditions:
682 1) element<=high for end-substring;
683 2) element>=low for start-substring.
684 Run-time character movement will enforce remaining conditions.
686 More complicated checks would be better, but present structure only
687 provides one index element at a time, so it is not possible to
688 enforce a check of both i and j in string(i:j). If it were, the
689 complete set of rules would read,
690 if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
691 ((low<=i<=high) && (low<=j<=high)) )
692 ok ;
693 else
694 range error ;
695 */
698 else
700 }
701 else
702 {
703 /* Array reference substring range checking. */
706 low,
707 element);
709 {
711 cond,
713 element,
714 high));
715 }
716 }
718 /* If the array index is safe at compile-time, return element. */
722 {
726 tree arg3;
727 tree arg2;
728 tree arg1;
729 tree arg4;
732 {
749 array_name,
755 }
759 build_range_type
761 integer_one_node,
767 arg1);
769 /* s_rnge adds one to the element to print it, so bias against
770 that -- want to print a faithful *subscript* value. */
774 element,
776 integer_one_node)));
780 NULL);
788 build_range_type
790 integer_one_node,
796 arg3);
810 }
820 }
822 /* Return the computed element of an array reference.
824 `item' is NULL_TREE, or the transformed pointer to the array.
825 `expr' is the original opARRAYREF expression, which is transformed
826 if `item' is NULL_TREE.
827 `want_ptr' is nonzero if a pointer to the element, instead of
828 the element itself, is to be returned. */
830 static tree
832 {
838 tree array;
839 tree element;
840 tree tree_type;
841 tree tree_type_x;
843 ffetype type;
844 ffebld list;
848 else
851 /* Build up ARRAY_REFs in reverse order (since we're column major
852 here in Fortran land). */
857 {
864 /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
865 pointers and 32-bit integers. Do the full 64-bit pointer
866 arithmetic, for codes using arrays for nonstandard heap-like
867 work. */
869 }
876 {
879 else
888 }
894 {
895 tree min;
900 {
909 /* Widen integral arithmetic as desired while preserving
910 signedness. */
925 item,
930 tree_type_x,
932 }
934 {
937 item);
938 }
939 }
940 else
941 {
945 {
955 /* Widen integral arithmetic as desired while preserving
956 signedness. */
968 item,
969 element);
970 }
971 }
974 }
976 /* This is like gcc's stabilize_reference -- in fact, most of the code
977 comes from that -- but it handles the situation where the reference
978 is going to have its subparts picked at, and it shouldn't change
979 (or trigger extra invocations of functions in the subtrees) due to
980 this. save_expr is a bit overzealous, because we don't need the
981 entire thing calculated and saved like a temp. So, for DECLs, no
982 change is needed, because these are stable aggregates, and ARRAY_REF
983 and such might well be stable too, but for things like calculations,
984 we do need to calculate a snapshot of a value before picking at it. */
986 static tree
988 {
989 tree result;
993 {
997 /* No action is needed in this case. */
1049 }
1057 }
1059 /* A rip-off of gcc's convert.c convert_to_complex function,
1060 reworked to handle complex implemented as C structures
1061 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
1063 static tree
1065 {
1067 tree subtype;
1074 {
1078 }
1081 {
1085 else
1086 {
1089 type,
1093 expr)),
1097 expr)));
1098 }
1099 }
1103 else
1109 }
1111 /* Like gcc's convert(), but crashes if widening might happen. */
1113 static tree
1115 {
1128 {
1131 }
1138 {
1145 }
1147 {
1150 }
1152 {
1156 }
1158 {
1162 }
1164 {
1166 /* Check that at least the first field name agrees. */
1175 }
1179 }
1181 /* Like gcc's convert(), but crashes if narrowing might happen. */
1183 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
1537 {
1538 tree source_decl;
1539 tree source_offset;
1540 tree source_size;
1541 tree t;
1547 {
1610 scalar_arg);
1615 scalar_arg);
1625 source_tree);
1630 return
1633 scalar_arg)
1636 scalar_arg);
1665 }
1667 /* Come here when source_decl, source_offset, and source_size filled
1668 in appropriately. */
1678 array? Shouldn't happen.... */
1682 dest_offset,
1684 dest_size)),
1686 source_offset));
1699 source_offset,
1701 source_size)),
1703 dest_offset));
1709 }
1711 /* Check whether dest might overlap any of a list of arguments or is
1712 in a COMMON area the callee might know about (and thus modify). */
1714 static bool
1717 {
1718 tree arg;
1719 tree dest_decl;
1720 tree dest_offset;
1721 tree dest_size;
1724 dest_tree);
1729 /* If the decl cannot be determined reliably, or if its in COMMON
1730 and the callee isn't known to not futz with COMMON via other
1731 means, overlap might happen. */
1739 {
1744 }
1747 }
1749 /* Build a string for a variable name as used by NAMELIST. This means that
1750 if we're using the f2c library, we build an uppercase string, since
1751 f2c does this. */
1753 static tree
1755 {
1759 {
1764 tree t;
1768 else
1781 }
1782 }
1784 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1785 type to just get whatever the function returns), handling the
1786 f2c value-returning convention, if required, by prepending
1787 to the arglist a pointer to a temporary to receive the return value. */
1789 static tree
1793 {
1794 tree item;
1795 tree tempvar;
1801 {
1809 callee_commons,
1810 scalar_args))
1811 {
1814 }
1815 else
1816 {
1820 }
1822 item
1826 tempvar));
1834 }
1835 else
1843 }
1845 /* Given two arguments, transform them and make a call to the given
1846 function via ffecom_call_. */
1848 static tree
1853 {
1854 tree left_tree;
1855 tree right_tree;
1856 tree left_length;
1857 tree right_length;
1860 {
1861 /* Pass arguments by reference. */
1864 }
1865 else
1866 {
1867 /* Pass arguments by value. */
1870 }
1878 {
1881 }
1884 {
1888 else
1890 }
1895 }
1897 /* Return ptr/length args for char subexpression
1899 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1900 subexpressions by constructing the appropriate trees for the ptr-to-
1901 character-text and length-of-character-text arguments in a calling
1902 sequence.
1904 Note that if with_null is TRUE, and the expression is an opCONTER,
1905 a null byte is appended to the string. */
1907 static void
1909 {
1910 tree item;
1911 tree high;
1912 ffetargetCharacter1 val;
1913 ffetargetCharacterSize newlen;
1916 {
1921 {
1922 /* Begin FFETARGET-NULL-KLUDGE. */
1925 }
1932 /* End FFETARGET-NULL-KLUDGE. */
1934 = build_type_variant
1935 (build_array_type
1937 build_range_type
1939 ffecom_f2c_ftnlen_one_node,
1940 high)),
1945 item);
1949 {
1954 {
1957 }
1959 {
1962 else
1963 {
1966 }
1967 }
1970 else
1971 /* FFEINFO_kindFUNCTION. */
1977 item);
1978 }
1982 {
1986 {
1989 }
1992 }
1996 {
1997 ffebld start;
1998 ffebld end;
2000 tree start_tree;
2001 tree end_tree;
2003 ffebld left_symter;
2004 tree array;
2012 /* Determine name for pretty-printing range-check errors. */
2016 ;
2019 else
2025 {
2028 }
2032 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2035 {
2037 ;
2038 else
2039 {
2045 end_tree);
2048 {
2051 }
2054 }
2055 }
2056 else
2057 {
2063 start_tree);
2066 {
2069 }
2074 item,
2077 start_tree,
2078 ffecom_f2c_ftnlen_one_node));
2081 {
2083 ffecom_f2c_ftnlen_one_node,
2085 ffecom_f2c_ftnlen_type_node,
2087 start_tree));
2088 }
2089 else
2090 {
2096 end_tree);
2099 {
2102 }
2105 ffecom_f2c_ftnlen_one_node,
2107 ffecom_f2c_ftnlen_type_node,
2109 }
2110 }
2111 }
2115 {
2117 tree tempvar;
2118 tree args;
2120 ffecomGfrt ix;
2123 /* ~~Kludge alert! This should someday be fixed. */
2131 {
2133 {
2134 /* Invocation of an intrinsic returning CHARACTER*1. */
2138 }
2142 }
2143 else
2144 {
2148 {
2151 }
2153 {
2156 }
2160 }
2165 tempvar);
2171 else
2172 {
2175 {
2179 }
2180 else
2181 {
2184 }
2185 }
2191 tempvar);
2192 }
2200 {
2203 }
2209 temporary. */
2210 tree tempvar;
2211 tree args;
2212 tree newlen;
2218 tempvar);
2232 tempvar);
2234 }
2235 else
2239 }
2246 }
2249 }
2251 /* Check the size of the type to be sure it doesn't overflow the
2252 "portable" capacities of the compiler back end. `dummy' types
2253 can generally overflow the normal sizes as long as the computations
2254 themselves don't overflow. A particular target of the back end
2255 must still enforce its size requirements, though, and the back
2256 end takes care of this in stor-layout.c. */
2258 static tree
2260 {
2270 /* An array is too large if size is negative or the type_size overflows
2271 or its "upper half" is larger than 3 (which would make the signed
2272 byte size and offset computations overflow). */
2277 {
2284 }
2287 }
2289 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2290 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2291 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2293 static tree
2295 {
2297 tree highval;
2298 tree tlen;
2303 else
2304 {
2308 else
2312 }
2315 {
2318 }
2319 else
2320 {
2323 }
2327 ffecom_f2c_ftnlen_one_node,
2328 highval));
2332 }
2334 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2336 ffecomConcatList_ catlist;
2337 ffebld expr; // expr of CHARACTER basictype.
2338 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2339 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2341 Scans expr for character subexpressions, updates and returns catlist
2342 accordingly. */
2344 static ffecomConcatList_
2346 ffetargetCharacterSize max)
2347 {
2348 ffetargetCharacterSize sz;
2350 recurse:
2359 {
2366 if they don't need to preserve it. */
2376 {
2380 }
2383 }
2386 else
2390 else
2394 of the destination. */
2396 {
2402 /* ~~Do useful truncations here. */
2408 }
2409 }
2423 dummy arg of sfunc */
2426 {
2427 ffetargetCharacterSize cmax;
2433 }
2435 #endif
2443 }
2444 }
2446 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2448 ffecomConcatList_ catlist;
2449 ffecom_concat_list_kill_(catlist);
2451 Anything allocated within the list info is deallocated. */
2453 static void
2455 {
2459 }
2461 /* Make list of concatenated string exprs.
2463 Returns a flattened list of concatenated subexpressions given a
2464 tree of such expressions. */
2466 static ffecomConcatList_
2468 {
2469 ffecomConcatList_ catlist;
2473 }
2475 /* Provide some kind of useful info on member of aggregate area,
2476 since current g77/gcc technology does not provide debug info
2477 on these members. */
2479 static void
2482 {
2483 tree value;
2484 tree decl;
2488 #if 0
2489 tree type_id;
2493 )
2494 {
2496 {
2511 }
2512 }
2513 #endif
2522 #if 0
2524 #endif
2528 else
2532 aggr_type,
2539 build_range_type
2541 integer_one_node,
2556 }
2558 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2560 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2561 int i; // entry# for this entrypoint (used by master fn)
2562 ffecom_do_entrypoint_(s,i);
2564 Makes a public entry point that calls our private master fn (already
2565 compiled). */
2567 static void
2569 {
2570 ffebld item;
2574 ffeinfoBasictype bt;
2575 ffeinfoKindtype kt;
2576 ffeglobal g;
2577 ffeglobalType gt;
2579 CHARACTER. */
2583 returns. */
2592 {
2595 /* Determine actual return type for function. */
2601 {
2607 }
2614 else
2621 else
2640 {
2642 {
2645 }
2646 }
2649 else
2651 }
2652 else
2661 /* Fall through. */
2671 }
2673 /* build_decl uses the current lineno and input_filename to set the decl
2674 source info. So, I've putzed with ffestd and ffeste code to update that
2675 source info to point to the appropriate statement just before calling
2676 ffecom_do_entrypoint (which calls this fn). */
2679 type,
2686 {
2688 }
2690 /* Reset args in master arg list so they get retransitioned. */
2695 {
2696 ffebld arg;
2697 ffesymbol s;
2705 }
2707 /* Build dummy arg list for this entry point. */
2711 tree type;
2712 tree length;
2716 else
2721 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2725 else
2735 {
2738 }
2739 }
2740 else
2748 /* Disallow temp vars at this level. */
2751 /* Make local var to hold return type for multi-type master fn. */
2754 {
2758 ffecom_multi_type_node_);
2761 }
2762 else
2765 /* Here we emit the actual code for the entry point. */
2767 {
2768 ffebld list;
2769 ffebld arg;
2770 ffesymbol s;
2773 tree prepend;
2774 tree call;
2775 tree actarg;
2776 tree master_fn;
2778 /* Prepare actual arg list based on master arg list. */
2783 {
2791 else
2795 }
2797 /* This code appends the length arguments for character
2798 variables/arrays. */
2803 {
2815 else
2819 }
2821 /* Prepend character-value return info to actual arg list. */
2824 {
2830 }
2832 /* Prepend multi-type return value to actual arg list. */
2835 {
2836 prepend
2840 multi_retval));
2843 }
2845 /* Prepend my entry-point number to the actual arg list. */
2851 /* Build the call to the master function. */
2858 /* Decide whether the master function is a function or subroutine, and
2859 handle the return value for my entry point. */
2863 {
2866 }
2868 {
2870 result
2873 result);
2876 multi_retval,
2880 }
2882 {
2884 result
2889 multi_retval,
2892 }
2894 {
2895 result
2898 result);
2902 }
2903 else
2904 {
2906 result,
2908 call));
2910 }
2911 }
2920 }
2922 /* Transform expr into gcc tree with possible destination
2924 Recursive descent on expr while making corresponding tree nodes and
2925 attaching type info and such. If destination supplied and compatible
2926 with temporary that would be made in certain cases, temporary isn't
2927 made, destination used instead, and dest_used flag set TRUE. */
2929 static tree
2932 {
2933 tree item;
2934 tree list;
2935 tree args;
2936 ffeinfoBasictype bt;
2937 ffeinfoKindtype kt;
2938 tree t;
2942 ffesymbol s;
2954 /* Widen integral arithmetic as desired while preserving signedness. */
2962 {
2964 {
2965 ffebitCount i;
2969 tree purpose;
2977 {
2978 ffebldConstantUnion cu;
2979 ffebitCount length;
2988 {
2990 {
2999 else
3004 else
3005 {
3008 }
3009 }
3010 }
3013 }
3014 }
3020 item
3021 = build_array_type
3024 ffecom_integer_zero_node,
3025 item));
3032 {
3033 ffetargetOffset i;
3038 else
3039 {
3043 /* Becomes PURPOSE first time through loop. */
3045 }
3048 {
3049 ffebldConstantUnion cu
3055 /* Assume item is PURPOSE first time through loop. */
3057 else
3058 {
3061 }
3062 }
3063 }
3068 item
3069 = build_array_type
3072 ffecom_integer_zero_node,
3073 item));
3081 item
3096 {
3097 /* User explicitly wants ASSIGN'ed variables to be at the same
3098 memory address as the variables when used in non-ASSIGN
3099 contexts. That can make old, arcane, non-standard code
3100 work, but don't try to do it when a pointer wouldn't fit
3101 in the normal variable (take other approach, and warn,
3102 instead). */
3105 {
3109 }
3116 {
3121 }
3124 {
3125 /* xgettext:no-c-format */
3127 FFEBAD_severityWARNING);
3132 }
3133 }
3135 /* Don't use the normal variable's tree for ASSIGN, though mark
3136 it as in the system header (housekeeping). Use an explicit,
3137 specially created sibling that is known to be wide enough
3138 to hold pointers to labels. */
3146 {
3150 }
3151 }
3152 else
3153 {
3155 {
3159 }
3163 }
3174 /* ~~~Make sure Fortran rules respected here */
3181 {
3184 }
3191 {
3195 }
3202 {
3206 }
3213 {
3217 }
3224 {
3228 }
3234 {
3237 ffecomGfrt code;
3238 ffeinfoKindtype rtkt;
3239 ffeinfoKindtype ltkt;
3243 {
3247 {
3251 }
3255 {
3261 {
3265 }
3266 else
3267 {
3270 }
3276 {
3279 }
3280 else
3281 {
3284 }
3290 {
3293 }
3294 else
3295 {
3298 }
3306 }
3311 FFETARGET_charactersizeNONE,
3312 FFEEXPR_contextLET);
3315 FFEINFO_basictypeINTEGER,
3317 FFETARGET_charactersizeNONE,
3318 FFEEXPR_contextLET);
3325 FFETARGET_charactersizeNONE,
3326 FFEEXPR_contextLET);
3330 FFEINFO_basictypeREAL,
3332 FFETARGET_charactersizeNONE,
3333 FFEEXPR_contextLET);
3334 /* We used to call FFECOM_gfrtPOW_DD here,
3335 which passes arguments by reference. */
3337 /* Pass arguments by value. */
3344 FFEINFO_basictypeCOMPLEX,
3346 FFETARGET_charactersizeNONE,
3347 FFEEXPR_contextLET);
3351 FFEINFO_basictypeCOMPLEX,
3353 FFETARGET_charactersizeNONE,
3354 FFEEXPR_contextLET);
3363 }
3372 }
3376 {
3387 /* Fall through. */
3390 }
3396 /* Fall through. */
3402 dest_used);
3404 }
3408 {
3411 }
3417 else
3422 else
3433 tree_type,
3434 args,
3443 {
3445 item
3458 /* Fall through. */
3461 }
3466 {
3468 item
3481 /* Fall through. */
3484 }
3490 {
3492 item
3505 /* Fall through. */
3508 }
3513 {
3515 item
3522 return
3530 /* Fall through. */
3533 }
3541 {
3549 {
3556 /* convert() takes care of converting to the subtype first,
3557 at least in gcc-2.7.2. */
3566 /* Fall through. */
3569 }
3574 /* Fall through. */
3577 }
3605 {
3616 {
3617 tree real_type;
3628 {
3631 }
3632 else
3633 {
3636 }
3638 item
3646 arg2)));
3649 else
3652 }
3655 {
3658 tree left_tree;
3659 tree right_tree;
3660 tree left_length;
3661 tree right_length;
3663 /* f2c run-time functions do the implicit blank-padding for us,
3664 so we don't usually have to implement blank-padding ourselves.
3665 (The exception is when we pass an argument to a separately
3666 compiled statement function -- if we know the arg is not the
3667 same length as the dummy, we must truncate or extend it. If
3668 we "inline" statement functions, that necessity goes away as
3669 well.)
3671 Strip off the CONVERT operators that blank-pad. (Truncation by
3672 CONVERT shouldn't happen here, but it can happen in
3673 assignments.) */
3690 {
3691 left_tree
3694 left_tree);
3695 right_tree
3698 right_tree);
3700 item
3704 left_tree,
3705 integer_one_node),
3708 right_tree,
3709 integer_one_node));
3710 }
3711 else
3712 {
3716 left_length);
3721 item,
3723 integer_zero_node));
3724 }
3726 }
3732 /* Fall through. */
3735 }
3757 /* Fall through. */
3760 }
3762 #if 1
3764 #else
3766 {
3783 }
3786 #endif
3787 }
3789 /* Returns the tree that does the intrinsic invocation.
3791 Note: this function applies only to intrinsics returning
3792 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3793 subroutines. */
3795 static tree
3798 {
3799 tree expr_tree;
3802 ffeinfoBasictype bt;
3803 ffeinfoKindtype kt;
3804 tree tree_type;
3805 tree arg1_type;
3807 tree tempvar;
3810 ffebld arg2;
3811 ffebld arg3;
3812 ffeintrinImp codegen_imp;
3813 ffecomGfrt gfrt;
3825 {
3830 {
3835 {
3839 }
3840 else
3842 }
3843 else
3845 }
3846 else
3849 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3850 args. This is used by the MAX/MIN expansions. */
3853 arg1_type = ffecom_tree_type
3856 else
3858 here. */
3860 /* There are several ways for each of the cases in the following switch
3861 statements to exit (from simplest to use to most complicated):
3863 break; (when expr_tree == NULL)
3865 A standard call is made to the specific intrinsic just as if it had been
3866 passed in as a dummy procedure and called as any old procedure. This
3867 method can produce slower code but in some cases it's the easiest way for
3868 now. However, if a (presumably faster) direct call is available,
3869 that is used, so this is the easiest way in many more cases now.
3871 gfrt = FFECOM_gfrtWHATEVER;
3872 break;
3874 gfrt contains the gfrt index of a library function to call, passing the
3875 argument(s) by value rather than by reference. Used when a more
3876 careful choice of library function is needed than that provided
3877 by the vanilla `break;'.
3879 return expr_tree;
3881 The expr_tree has been completely set up and is ready to be returned
3882 as is. No further actions are taken. Use this when the tree is not
3883 in the simple form for one of the arity_n labels. */
3885 /* For info on how the switch statement cases were written, see the files
3886 enclosed in comments below the switch statement. */
3894 {
3902 {
3908 }
3921 else
3924 return
3931 #if 0
3932 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
3935 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3937 return
3940 ffecom_truth_value
3942 saved_expr1,
3944 ffecom_float_zero_))),
3948 saved_expr1)),
3949 NULL_TREE),
3955 arg1_type,
3956 saved_expr1))),
3957 NULL_TREE)
3958 ))
3959 );
3960 #endif
3965 numbers of large magnitudes. */
3970 ffecom_truth_value
3972 integer_type_node,
3973 saved_expr1,
3974 ffecom_float_zero_)),
3976 tree_type,
3977 saved_expr1,
3978 ffecom_float_half_),
3980 tree_type,
3981 saved_expr1,
3982 ffecom_float_half_))));
3985 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3987 return
3990 ffecom_truth_value
3992 saved_expr1,
3994 ffecom_float_zero_))),
3999 arg1_type,
4000 saved_expr1,
4002 ffecom_float_half_)))),
4003 NULL_TREE),
4009 arg1_type,
4011 ffecom_float_half_),
4012 saved_expr1))),
4013 NULL_TREE))
4014 )
4015 );
4016 #endif
4030 {
4035 integer_one_node),
4037 }
4039 expr_tree,
4040 tempvar);
4043 expr_tree);
4049 return
4053 return
4060 return
4067 {
4068 tree arg1_tree;
4072 return
4077 }
4084 {
4089 }
4118 return
4120 ffecom_truth_value
4122 saved_expr1,
4123 saved_expr2)),
4125 saved_expr1,
4126 saved_expr2),
4130 return
4140 {
4145 }
4152 expr_tree
4155 expr_tree);
4156 expr_tree
4159 expr_tree,
4160 integer_one_node);
4165 saved_expr1,
4166 expr_tree,
4169 #endif
4175 #if 0
4177 #else
4179 #endif
4193 {
4198 }
4208 /* We used to call FFECOM_gfrtALOG10 here. */
4211 /* We used to call FFECOM_gfrtDLOG10 here. */
4223 else
4229 {
4234 expr_tree,
4237 }
4248 else
4254 {
4259 expr_tree,
4262 }
4274 /* We used to call FFECOM_gfrtAMOD here. */
4277 /* We used to call FFECOM_gfrtDMOD here. */
4283 #if 0
4284 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4286 #else
4287 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4289 return
4292 ffecom_truth_value
4294 saved_expr1,
4296 ffecom_float_zero_))),
4298 saved_expr1,
4300 ffecom_float_half_)),
4302 saved_expr1,
4304 ffecom_float_half_))));
4305 #endif
4310 {
4313 saved_expr1
4314 = ffecom_save_tree
4318 expr_tree
4320 ffecom_truth_value
4322 arg2_tree,
4324 integer_zero_node))),
4325 saved_expr1,
4327 /* Make sure SAVE_EXPRs get referenced early enough. */
4328 expr_tree
4331 expr_tree);
4332 }
4340 {
4345 }
4357 {
4362 }
4374 else
4377 return
4425 {
4426 ffetargetLogical1 target_true;
4427 ffetargetLogical1 target_false;
4428 tree true_tree;
4429 tree false_tree;
4435 else
4439 else
4442 return
4444 ffecom_truth_value
4450 integer_one_node),
4454 integer_zero_node))),
4455 false_tree,
4456 true_tree);
4457 }
4460 return
4466 integer_one_node),
4471 {
4474 tree uns_type
4477 expr_tree
4486 uns_type,
4488 integer_zero_node)),
4490 integer_type_node,
4492 arg3_tree))));
4493 /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE. */
4494 expr_tree
4496 ffecom_truth_value
4498 arg3_tree,
4499 integer_zero_node)),
4500 expr_tree,
4502 }
4506 return
4515 {
4519 tree uns_type
4522 expr_tree
4524 ffecom_truth_value
4526 arg2_tree,
4527 integer_zero_node)),
4529 arg1_tree,
4530 arg2_tree),
4535 integer_type_node,
4536 arg2_tree))));
4537 /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds. */
4538 expr_tree
4540 ffecom_truth_value
4543 integer_type_node,
4544 arg2_tree),
4546 expr_tree,
4548 /* Make sure SAVE_EXPRs get referenced early enough. */
4549 expr_tree
4554 expr_tree));
4555 }
4559 {
4565 tree shift_neg;
4566 tree shift_pos;
4567 tree mask_arg1;
4568 tree masked_arg1;
4569 tree uns_type
4572 mask_arg1
4576 arg3_tree);
4577 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4578 mask_arg1
4580 ffecom_truth_value
4582 arg3_tree,
4584 mask_arg1,
4587 masked_arg1
4589 arg1_tree,
4591 mask_arg1));
4593 shift_neg
4599 integer_type_node,
4600 arg2_tree))),
4602 arg1_tree,
4604 arg2_tree,
4605 arg3_tree)));
4606 shift_pos
4609 arg1_tree,
4610 arg2_tree),
4615 integer_type_node,
4616 arg3_tree,
4617 arg2_tree))));
4618 expr_tree
4620 ffecom_truth_value
4622 arg2_tree,
4623 integer_zero_node)),
4624 shift_neg,
4625 shift_pos);
4626 expr_tree
4629 mask_arg1,
4630 arg1_tree),
4633 mask_arg1),
4634 expr_tree));
4635 expr_tree
4637 ffecom_truth_value
4641 integer_type_node,
4642 arg2_tree),
4643 arg3_tree),
4645 arg2_tree,
4646 integer_zero_node))),
4647 arg1_tree,
4648 expr_tree);
4649 /* Make sure SAVE_EXPRs get referenced early enough. */
4650 expr_tree
4657 mask_arg1),
4660 masked_arg1),
4661 expr_tree))));
4662 expr_tree
4665 arg3_tree),
4666 expr_tree);
4667 }
4671 {
4674 expr_tree
4678 arg1_tree));
4679 }
4683 {
4684 tree arg1_tree;
4685 tree arg2_tree;
4686 tree arg3_tree;
4688 tree arg4_tree;
4689 tree arg4_type;
4691 tree arg5_tree;
4692 tree prep_arg1;
4693 tree prep_arg4;
4694 tree arg5_plus_arg3;
4709 prep_arg1
4713 arg1_tree,
4714 arg2_tree),
4718 arg4_type,
4719 convert
4721 integer_zero_node)),
4722 arg3_tree))),
4723 arg5_tree);
4724 arg5_plus_arg3
4726 arg5_tree,
4727 arg3_tree));
4728 prep_arg4
4732 integer_zero_node)),
4733 arg5_plus_arg3);
4734 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4735 prep_arg4
4737 ffecom_truth_value
4739 arg5_plus_arg3,
4742 prep_arg4,
4744 prep_arg4
4746 arg4_tree,
4748 prep_arg4,
4752 arg4_type,
4753 convert
4755 integer_zero_node)),
4756 arg5_tree))));
4757 prep_arg1
4759 prep_arg1,
4760 prep_arg4);
4761 /* Fix up (twice), because LSHIFT_EXPR above
4762 can't shift over TYPE_SIZE. */
4763 prep_arg1
4765 ffecom_truth_value
4767 arg3_tree,
4769 integer_zero_node))),
4770 prep_arg1,
4771 arg4_tree);
4772 prep_arg1
4774 ffecom_truth_value
4776 arg3_tree,
4779 prep_arg1,
4780 arg1_tree);
4781 expr_tree
4783 arg4_tree,
4784 prep_arg1);
4785 /* Make sure SAVE_EXPRs get referenced early enough. */
4786 expr_tree
4788 arg1_tree,
4790 arg3_tree,
4792 arg5_tree,
4794 arg5_plus_arg3,
4795 expr_tree))));
4796 expr_tree
4798 arg4_tree,
4799 expr_tree);
4801 }
4811 /* extern int xargc; i__1 = xargc - 1; */
4813 ffecom_tree_xargc_,
4815 integer_one_node));
4820 {
4821 tree arg1_tree;
4822 tree arg2_tree;
4823 tree arg3_tree;
4829 arg1_tree);
4831 /* Pass procedure as a pointer to it, anything else by value. */
4834 else
4837 arg2_tree);
4841 else
4848 expr_tree
4851 FALSE,
4853 NULL_TREE :
4854 tree_type),
4855 arg1_tree,
4860 expr_tree
4863 expr_tree));
4864 }
4868 {
4869 tree arg1_tree;
4870 tree arg2_tree;
4871 tree arg3_tree;
4877 arg1_tree);
4879 /* Pass procedure as a pointer to it, anything else by value. */
4882 else
4885 arg2_tree);
4889 else
4896 expr_tree
4899 FALSE,
4900 NULL_TREE,
4901 arg1_tree,
4906 expr_tree
4909 expr_tree));
4910 }
4921 {
4923 tree arg1_tree;
4924 tree arg2_tree;
4930 else
4937 expr_tree
4940 FALSE,
4941 NULL_TREE,
4942 arg1_tree,
4947 expr_tree
4950 expr_tree));
4951 }
4960 build_pointer_type
4962 integer_zero_node));
4964 return
4967 FALSE,
4968 void_type_node,
4969 expr_tree,
4976 else
4984 {
4986 tree arg1_tree;
4988 tree arg2_tree;
4989 tree arg3_tree;
4995 else
5007 FALSE,
5008 NULL_TREE,
5009 arg1_tree,
5015 expr_tree));
5016 }
5021 {
5023 tree arg1_tree;
5024 tree arg2_tree;
5025 tree arg3_tree;
5033 else
5043 FALSE,
5044 NULL_TREE,
5045 arg1_tree,
5051 expr_tree));
5052 }
5057 {
5058 tree arg1_tree;
5059 tree arg2_tree;
5061 tree arg3_tree;
5067 arg1_tree);
5072 else
5083 FALSE,
5084 NULL_TREE,
5085 arg1_tree,
5091 expr_tree));
5092 }
5096 {
5097 tree arg1_tree;
5098 tree arg2_tree;
5099 tree arg3_tree;
5105 arg1_tree);
5112 else
5120 FALSE,
5121 NULL_TREE,
5122 arg1_tree,
5128 expr_tree));
5129 }
5130 }
5134 {
5135 tree arg1_tree;
5136 tree arg2_tree;
5137 tree arg3_tree;
5143 arg1_tree);
5149 arg2_tree);
5153 else
5161 FALSE,
5162 NULL_TREE,
5163 arg1_tree,
5169 expr_tree));
5170 }
5171 }
5176 {
5178 tree arg1_tree;
5179 tree arg2_tree;
5184 ffecom_f2c_longint_type_node :
5185 ffecom_f2c_integer_type_node),
5189 arg2_tree);
5197 expr_tree
5200 FALSE,
5201 NULL_TREE,
5202 arg1_tree,
5206 }
5211 /* Arg defaults to 0 (normal random case) */
5212 {
5213 tree arg1_tree;
5217 else
5220 arg1_tree);
5223 arg1_tree);
5228 FALSE,
5230 ffecom_f2c_integer_type_node :
5231 ffecom_f2c_real_type_node),
5232 arg1_tree,
5236 }
5241 {
5242 tree arg1_tree;
5243 tree arg2_tree;
5249 arg1_tree);
5253 else
5258 FALSE,
5259 NULL_TREE,
5262 TRUE,
5267 expr_tree));
5268 }
5269 }
5274 {
5275 tree arg1_tree;
5279 expr_tree
5282 FALSE,
5283 NULL_TREE,
5284 NULL_TREE,
5288 expr_tree
5291 expr_tree));
5292 }
5297 {
5298 tree arg1_tree;
5299 tree result_tree;
5307 FALSE,
5308 NULL_TREE,
5311 TRUE,
5315 expr_tree));
5316 }
5319 /* Straightforward calls of libf2c routines: */
5396 }
5405 tree_type,
5410 /* See bottom of this file for f2c transforms used to determine
5411 many of the above implementations. The info seems to confuse
5412 Emacs's C mode indentation, which is why it's been moved to
5413 the bottom of this source file. */
5414 }
5416 /* For power (exponentiation) where right-hand operand is type INTEGER,
5417 generate in-line code to do it the fast way (which, if the operand
5418 is a constant, might just mean a series of multiplies). */
5420 static tree
5422 {
5434 {
5442 {
5443 /* Reciprocal of integer is either 0, -1, or 1, so after
5444 calculating that (which we leave to the back end to do
5445 or not do optimally), don't bother with any multiplying. */
5449 l,
5452 rtype,
5453 r);
5456 result);
5457 }
5459 /* Generate appropriate series of multiplies, preceded
5460 by divide if the exponent is negative. */
5465 {
5468 l,
5478 r,
5479 integer_one_node));
5482 l,
5483 l);
5484 }
5485 }
5488 {
5490 {
5493 else
5495 result,
5496 l);
5497 }
5500 r,
5501 integer_one_node);
5508 l,
5509 l);
5510 }
5512 }
5514 /* Though rhs isn't a constant, in-line code cannot be expanded
5515 while transforming dummies
5516 because the back end cannot be easily convinced to generate
5517 stores (MODIFY_EXPR), handle temporaries, and so on before
5518 all the appropriate rtx's have been generated for things like
5519 dummy args referenced in rhs -- which doesn't happen until
5520 store_parm_decls() is called (expand_function_start, I believe,
5521 does the actual rtx-stuffing of PARM_DECLs).
5523 So, in this case, let the caller generate the call to the
5524 run-time-library function to evaluate the power for us. */
5529 /* Right-hand operand not a constant, expand in-line code to figure
5530 out how to do the multiplies, &c.
5532 The returned expression is expressed this way in GNU C, where l and
5533 r are the "inputs":
5535 ({ typeof (r) rtmp = r;
5536 typeof (l) ltmp = l;
5537 typeof (l) result;
5539 if (rtmp == 0)
5540 result = 1;
5541 else
5542 {
5543 if ((basetypeof (l) == basetypeof (int))
5544 && (rtmp < 0))
5545 {
5546 result = ((typeof (l)) 1) / ltmp;
5547 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5548 result = -result;
5549 }
5550 else
5551 {
5552 result = 1;
5553 if ((basetypeof (l) != basetypeof (int))
5554 && (rtmp < 0))
5555 {
5556 ltmp = ((typeof (l)) 1) / ltmp;
5557 rtmp = -rtmp;
5558 if (rtmp < 0)
5559 {
5560 rtmp = -(rtmp >> 1);
5561 ltmp *= ltmp;
5562 }
5563 }
5564 for (;;)
5565 {
5566 if (rtmp & 1)
5567 result *= ltmp;
5568 if ((rtmp >>= 1) == 0)
5569 break;
5570 ltmp *= ltmp;
5571 }
5572 }
5573 }
5574 result;
5575 })
5577 Note that some of the above is compile-time collapsable, such as
5578 the first part of the if statements that checks the base type of
5579 l against int. The if statements are phrased that way to suggest
5580 an easy way to generate the if/else constructs here, knowing that
5581 the back end should (and probably does) eliminate the resulting
5582 dead code (either the int case or the non-int case), something
5583 it couldn't do without the redundant phrasing, requiring explicit
5584 dead-code elimination here, which would be kind of difficult to
5585 read. */
5587 {
5588 tree rtmp;
5589 tree ltmp;
5590 tree divide;
5591 tree basetypeof_l_is_int;
5592 tree se;
5593 tree t;
5595 basetypeof_l_is_int
5612 else
5616 rtmp,
5617 r));
5619 ltmp,
5620 l));
5623 rtmp,
5627 result,
5631 {
5633 rtmp,
5635 integer_zero_node)),
5638 result,
5639 ffecom_tree_divide_
5642 ltmp,
5644 divide)));
5648 ltmp,
5650 integer_zero_node)),
5653 rtype,
5655 rtype,
5656 rtmp),
5658 integer_one_node)),
5660 integer_zero_node)))),
5663 result,
5665 ltype,
5666 result)));
5669 }
5671 result,
5675 ffecom_truth_value_invert
5678 rtmp,
5680 integer_zero_node)))),
5683 ltmp,
5684 ffecom_tree_divide_
5687 ltmp,
5689 divide)));
5691 rtmp,
5693 rtmp)));
5696 rtmp,
5700 rtmp,
5703 rtype,
5704 rtmp,
5705 integer_one_node))));
5707 ltmp,
5709 ltmp,
5710 ltmp)));
5716 rtmp,
5720 result,
5722 result,
5723 ltmp)));
5726 ffecom_truth_value
5728 rtmp,
5730 rtype,
5731 rtmp,
5732 integer_one_node))));
5734 ltmp,
5736 ltmp,
5737 ltmp)));
5748 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5751 {
5752 /* Make a BIND_EXPR for the BLOCK already made. */
5755 /* Remove the block from the tree at this point.
5756 It gets put back at the proper place
5757 when the BIND_EXPR is expanded. */
5759 }
5760 else
5762 }
5765 }
5767 /* ffecom_expr_transform_ -- Transform symbols in expr
5769 ffebld expr; // FFE expression.
5770 ffecom_expr_transform_ (expr);
5772 Recursive descent on expr while transforming any untransformed SYMTERs. */
5774 static void
5776 {
5777 tree t;
5778 ffesymbol s;
5780 tail_recurse:
5786 {
5794 {
5797 DIMENSION expr? */
5798 }
5808 }
5811 {
5823 }
5826 }
5828 /* Make a type based on info in live f2c.h file. */
5830 static void
5832 {
5834 {
5857 ? signed_char_type_node
5891 }
5896 }
5898 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5899 given size. */
5901 static void
5903 {
5905 tree t;
5910 {
5914 }
5915 }
5917 /* Finish up globals after doing all program units in file
5919 Need to handle only uninitialized COMMON areas. */
5921 static ffeglobal
5923 {
5924 tree cbtype;
5925 tree cbt;
5926 tree size;
5941 /* Give the array a size now. */
5949 integer_zero_node,
5950 size);
5961 }
5963 /* Finish up any untransformed symbols. */
5965 static ffesymbol
5967 {
5971 /* It's easy to know to transform an untransformed symbol, to make sure
5972 we put out debugging info for it. But COMMON variables, unlike
5973 EQUIVALENCE ones, aren't given declarations in addition to the
5974 tree expressions that specify offsets, because COMMON variables
5975 can be referenced in the outer scope where only dummy arguments
5976 (PARM_DECLs) should really be seen. To be safe, just don't do any
5977 VAR_DECLs for COMMON variables when we transform them for real
5978 use, and therefore we do all the VAR_DECL creating here. */
5981 {
5986 /* Not transformed, and not CHARACTER*(*), and not a dummy
5987 argument, which can happen only if the entry point names
5988 it "rides in on" are all invalidated for other reasons. */
5990 }
5994 {
5995 /* This isn't working, at least for dbxout. The .s file looks
5996 okay to me (burley), but in gdb 4.9 at least, the variables
5997 appear to reside somewhere outside of the common area, so
5998 it doesn't make sense to mislead anyone by generating the info
5999 on those variables until this is fixed. NOTE: Same problem
6000 with EQUIVALENCE, sadly...see similar #if later. */
6003 }
6006 }
6008 /* Append underscore(s) to name before calling get_identifier. "us"
6009 is nonzero if the name already contains an underscore and thus
6010 needs two underscores appended. */
6012 static tree
6014 {
6017 tree id;
6031 }
6033 /* Decide whether to append underscore to name before calling
6034 get_identifier. */
6036 static tree
6038 {
6042 /* If name is a built-in name, just return it as is. */
6055 }
6057 /* Decide whether to append underscore to internal name before calling
6058 get_identifier.
6060 This is for non-external, top-function-context names only. Transform
6061 identifier so it doesn't conflict with the transformed result
6062 of using a _different_ external name. E.g. if "CALL FOO" is
6063 transformed into "FOO_();", then the variable in "FOO_ = 3"
6064 must be transformed into something that does not conflict, since
6065 these two things should be independent.
6067 The transformation is as follows. If the name does not contain
6068 an underscore, there is no possible conflict, so just return.
6069 If the name does contain an underscore, then transform it just
6070 like we transform an external identifier. */
6072 static tree
6074 {
6075 /* If name does not contain an underscore, just return it as is. */
6082 name);
6083 }
6085 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6087 tree t;
6088 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6089 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6090 ffesymbol_kindtype(s));
6092 Call after setting up containing function and getting trees for all
6093 other symbols. */
6095 static tree
6097 {
6099 tree type;
6100 tree func;
6101 tree result;
6108 /* For now, we don't have a handy pointer to where the sfunc is actually
6109 defined, though that should be easy to add to an ffesymbol. (The
6110 token/where info available might well point to the place where the type
6111 of the sfunc is declared, especially if that precedes the place where
6112 the sfunc itself is defined, which is typically the case.) We should
6113 put out a null pointer rather than point somewhere wrong, but I want to
6114 see how it works at this point. */
6119 /* Pretransform the expression so any newly discovered things belong to the
6120 outer program unit, not to the statement function. */
6124 /* Make sure no recursive invocation of this fn (a specific case of failing
6125 to pretransform an sfunc's expression, i.e. where its expression
6126 references another untransformed sfunc) happens. */
6135 else
6136 {
6140 error. */
6141 }
6148 /* We don't worry about COMPLEX return values here, because this is
6149 entirely internal to our code, and gcc has the ability to return COMPLEX
6150 directly as a value. */
6154 tree type;
6166 }
6167 else
6177 {
6179 {
6181 tree result_length;
6192 }
6193 else
6194 {
6202 }
6203 }
6219 }
6223 {
6225 }
6227 static tree
6229 {
6236 }
6238 /* Return initialize-to-zero expression for this VAR_DECL. */
6240 /* A somewhat evil way to prevent the garbage collector
6241 from collecting 'tree' structures. */
6242 #define NUM_TRACKED_CHUNK 63
6244 {
6247 };
6250 void
6252 {
6257 {
6260 }
6262 {
6263 /* Need to allocate a new block. */
6271 }
6272 }
6274 static tree
6276 {
6277 tree init;
6282 {
6285 }
6293 {
6297 }
6298 else
6299 {
6302 }
6305 }
6307 static tree
6309 {
6310 tree expr_tree;
6311 tree length_tree;
6314 {
6317 (ffebld_constant_character1
6319 {
6322 }
6326 (ffebld_constant_character1
6340 {
6343 }
6346 {
6349 }
6351 expr_tree
6354 expr_tree);
6355 expr_tree
6358 expr_tree,
6359 integer_one_node);
6365 *maybe_tree
6366 = ffecom_truth_value
6368 length_tree,
6369 ffecom_f2c_ftnlen_zero_node));
6375 {
6378 }
6380 maybe_tree);
6383 {
6384 tree maybe_left;
6385 tree maybe_right;
6386 tree expr_left;
6387 tree expr_right;
6394 maybe_left,
6395 maybe_right);
6397 maybe_left,
6398 expr_left,
6399 expr_right);
6401 }
6406 }
6407 }
6409 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6411 tree length_arg;
6412 ffebld expr;
6413 length_arg = ffecom_intrinsic_len_ (expr);
6415 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6416 subexpressions by constructing the appropriate tree for the
6417 length-of-character-text argument in a calling sequence. */
6419 static tree
6421 {
6422 ffetargetCharacter1 val;
6423 tree length;
6426 {
6434 {
6436 tree item;
6440 {
6443 }
6445 {
6448 else
6449 {
6452 }
6453 }
6458 }
6466 {
6467 ffebld start;
6468 ffebld end;
6470 tree start_tree;
6471 tree end_tree;
6485 {
6487 ;
6488 else
6489 {
6492 }
6493 }
6494 else
6495 {
6500 {
6503 }
6506 {
6508 ffecom_f2c_ftnlen_one_node,
6510 ffecom_f2c_ftnlen_type_node,
6511 length,
6512 start_tree));
6513 }
6514 else
6515 {
6520 {
6523 }
6526 ffecom_f2c_ftnlen_one_node,
6528 ffecom_f2c_ftnlen_type_node,
6530 }
6531 }
6532 }
6536 length
6552 }
6557 }
6559 /* Handle CHARACTER assignments.
6561 Generates code to do the assignment. Used by ordinary assignment
6562 statement handler ffecom_let_stmt and by statement-function
6563 handler to generate code for a statement function. */
6565 static void
6568 {
6569 ffecomConcatList_ catlist;
6570 tree source_length;
6571 tree source_tree;
6572 tree expr_tree;
6581 /* Source might be an opCONVERT, which just means it is a different size
6582 than the destination. Since the underlying implementation here handles
6583 that (directly or via the s_copy or s_cat run-time-library functions),
6584 we don't need the "convenience" of an opCONVERT that tells us to
6585 truncate or blank-pad, particularly since the resulting implementation
6586 would probably be slower than otherwise. */
6593 {
6624 {
6625 dest_tree
6629 dest_tree);
6630 dest_tree
6634 dest_tree,
6635 integer_one_node);
6636 source_tree
6640 source_tree);
6641 source_tree
6645 source_tree,
6646 integer_one_node);
6653 }
6671 }
6673 /* Heavy-duty concatenation. */
6675 {
6678 tree lengths;
6679 tree items;
6680 tree length_array;
6681 tree item_array;
6682 tree citem;
6683 tree clength;
6685 {
6686 tree hook;
6694 }
6697 {
6702 {
6705 }
6707 items
6712 item_array,
6714 citem),
6715 items);
6716 lengths
6721 length_array,
6723 clength),
6724 lengths);
6725 }
6732 items));
6737 lengths));
6739 = build_tree_list
6751 }
6754 }
6756 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6758 ffecomGfrt ix;
6759 ffecom_make_gfrt_(ix);
6761 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6762 for the indicated run-time routine (ix). */
6764 static void
6766 {
6767 tree t;
6768 tree ttype;
6771 {
6836 }
6841 ttype);
6847 /* Sanity check: A function that's const cannot be volatile. */
6851 /* Sanity check: A function that's const cannot return complex. */
6860 }
6862 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
6864 static void
6866 {
6871 }
6873 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
6874 the member so debugger will see it. Otherwise nobody should be
6875 referencing the member. */
6877 static void
6879 {
6880 ffesymbol s;
6881 tree t;
6882 tree mt;
6883 tree type;
6902 type);
6919 }
6921 /* Prepare source expression for assignment into a destination perhaps known
6922 to be of a specific size. */
6924 static void
6926 {
6927 ffecomConcatList_ catlist;
6930 tree ltmp;
6931 tree itmp;
6941 {
6942 ltmp
6945 itmp
6952 }
6960 {
6963 }
6964 }
6966 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
6968 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
6969 (which generates their trees) and then their trees get push_parm_decl'd.
6971 The second arg is TRUE if the dummies are for a statement function, in
6972 which case lengths are not pushed for character arguments (since they are
6973 always known by both the caller and the callee, though the code allows
6974 for someday permitting CHAR*(*) stmtfunc dummies). */
6976 static void
6978 {
6979 ffebld dummy;
6980 ffebld dumlist;
6981 ffesymbol s;
6982 tree parm;
6986 /* First push the parms corresponding to actual dummy "contents". */
6989 {
6992 {
6999 }
7004 {
7008 }
7011 }
7013 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7016 {
7019 {
7023 NOTHING! */
7027 }
7033 length param. */
7040 }
7043 }
7045 /* ffecom_start_progunit_ -- Beginning of program unit
7047 Does GNU back end stuff necessary to teach it about the start of its
7048 equivalent of a Fortran program unit. */
7050 static void
7052 {
7054 ffebld arglist;
7058 ffeinfoBasictype bt;
7059 ffeinfoKindtype kt;
7060 ffeglobal g;
7061 ffeglobalType gt;
7066 bool multi
7067 = altentries
7080 {
7106 {
7112 }
7122 else
7129 else
7144 else
7152 /* Fall through. */
7161 }
7164 {
7167 }
7168 #if FFETARGET_isENFORCED_MAIN
7171 #endif
7172 else
7176 type,
7186 {
7188 }
7190 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7191 exec-transitioning needs current_function_decl to be filled in. So we
7192 do these things in two phases. */
7196 ffecom_which_entrypoint_decl_
7200 integer_type_node);
7202 }
7205 || cmplxfunc
7208 tree type;
7209 tree length;
7215 else
7220 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7224 else
7233 else
7237 {
7240 }
7241 }
7244 {
7247 else
7250 }
7256 /* Disallow temp vars at this level. */
7261 /* This handles any symbols still untransformed, in case -g specified.
7262 This used to be done in ffecom_finish_progunit, but it turns out to
7263 be necessary to do it here so that statement functions are
7264 expanded before code. But don't bother for BLOCK DATA. */
7268 }
7270 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7272 ffesymbol s;
7273 ffecom_sym_transform_(s);
7275 The ffesymbol_hook info for s is updated with appropriate backend info
7276 on the symbol. */
7278 static ffesymbol
7280 {
7284 ffeinfoBasictype bt;
7285 ffeinfoKindtype kt;
7286 ffeglobal g;
7289 /* Must ensure special ASSIGN variables are declared at top of outermost
7290 block, else they'll end up in the innermost block when their first
7291 ASSIGN is seen, which leaves them out of scope when they're the
7292 subject of a GOTO or I/O statement.
7294 We make this variable even if -fugly-assign. Just let it go unused,
7295 in case it turns out there are cases where we really want to use this
7296 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7304 {
7307 }
7308 else
7309 {
7314 }
7324 {
7327 {
7331 /* Before 0.4, this could be ENTITY/DUMMY, but see
7332 ffestu_sym_end_transition -- no longer true (in particular, if
7333 it could be an ENTITY, it _will_ be made one, so that
7334 possibility won't come through here). So we never make length
7335 arg for CHARACTER type. */
7339 ffecom_tree_ptr_to_subr_type);
7353 {
7356 }
7379 /* Fall through. */
7382 }
7387 {
7390 /* ~~Debugging info needed? */
7398 {
7400 tree type;
7405 {
7408 }
7412 {
7415 }
7420 ffestorag est;
7421 tree et;
7422 ffetargetOffset offset;
7439 /* (t_type *) (((char *) &et) + offset) */
7444 et));
7446 t,
7449 t);
7453 }
7454 else
7455 {
7456 tree initexpr;
7461 type);
7465 #ifdef FFECOM_sizeMAXSTACKITEM
7468 #endif
7470 && (ffecom_primary_entry_kind_
7474 else
7480 /* Keep -Wunused from complaining about var if it
7481 is used as sfunc arg or DATA implied-DO. */
7488 {
7491 else
7493 }
7496 else
7502 {
7506 }
7507 }
7508 }
7516 it (& length). */
7521 }
7526 it. */
7530 }
7532 {
7535 }
7538 {
7541 ffecom_multi_retval_);
7546 }
7560 {
7561 tree type;
7562 ffebld dl;
7563 ffebld dim;
7564 tree low;
7565 tree high;
7566 tree old_sizes;
7571 {
7574 context; get it later. */
7576 }
7579 }
7580 else
7593 {
7601 else
7606 {
7607 /* Used to just do high=low. But for ffecom_tree_
7608 canonize_ref_, it probably is important to correctly
7609 assess the size. E.g. given COMPLEX C(*),CFUNC and
7610 C(2)=CFUNC(C), overlap can happen, while it can't
7611 for, say, C(1)=CFUNC(C(2)). */
7612 /* Even more recently used to set to INT_MAX, but that
7613 broke when some overflow checking went into the back
7614 end. Now we just leave the upper bound unspecified. */
7616 }
7617 else
7620 /* Determine whether array is conditionally adjustable,
7621 to decide whether back-end magic is needed.
7623 Normally the front end uses the back-end function
7624 variable_size to wrap SAVE_EXPR's around expressions
7625 affecting the size/shape of an array so that the
7626 size/shape info doesn't change during execution
7627 of the compiled code even though variables and
7628 functions referenced in those expressions might.
7630 variable_size also makes sure those saved expressions
7631 get evaluated immediately upon entry to the
7632 compiled procedure -- the front end normally doesn't
7633 have to worry about that.
7635 However, there is a problem with this that affects
7636 g77's implementation of entry points, and that is
7637 that it is _not_ true that each invocation of the
7638 compiled procedure is permitted to evaluate
7639 array size/shape info -- because it is possible
7640 that, for some invocations, that info is invalid (in
7641 which case it is "promised" -- i.e. a violation of
7642 the Fortran standard -- that the compiled code
7643 won't reference the array or its size/shape
7644 during that particular invocation).
7646 To phrase this in C terms, consider this gcc function:
7648 void foo (int *n, float (*a)[*n])
7649 {
7650 // a is "pointer to array ...", fyi.
7651 }
7653 Suppose that, for some invocations, it is permitted
7654 for a caller of foo to do this:
7656 foo (NULL, NULL);
7658 Now the _written_ code for foo can take such a call
7659 into account by either testing explicitly for whether
7660 (a == NULL) || (n == NULL) -- presumably it is
7661 not permitted to reference *a in various fashions
7662 if (n == NULL) I suppose -- or it can avoid it by
7663 looking at other info (other arguments, static/global
7664 data, etc.).
7666 However, this won't work in gcc 2.5.8 because it'll
7667 automatically emit the code to save the "*n"
7668 expression, which'll yield a NULL dereference for
7669 the "foo (NULL, NULL)" call, something the code
7670 for foo cannot prevent.
7672 g77 definitely needs to avoid executing such
7673 code anytime the pointer to the adjustable array
7674 is NULL, because even if its bounds expressions
7675 don't have any references to possible "absent"
7676 variables like "*n" -- say all variable references
7677 are to COMMON variables, i.e. global (though in C,
7678 local static could actually make sense) -- the
7679 expressions could yield other run-time problems
7680 for allowably "dead" values in those variables.
7682 For example, let's consider a more complicated
7683 version of foo:
7685 extern int i;
7686 extern int j;
7688 void foo (float (*a)[i/j])
7689 {
7690 ...
7691 }
7693 The above is (essentially) quite valid for Fortran
7694 but, again, for a call like "foo (NULL);", it is
7695 permitted for i and j to be undefined when the
7696 call is made. If j happened to be zero, for
7697 example, emitting the code to evaluate "i/j"
7698 could result in a run-time error.
7700 Offhand, though I don't have my F77 or F90
7701 standards handy, it might even be valid for a
7702 bounds expression to contain a function reference,
7703 in which case I doubt it is permitted for an
7704 implementation to invoke that function in the
7705 Fortran case involved here (invocation of an
7706 alternate ENTRY point that doesn't have the adjustable
7707 array as one of its arguments).
7709 So, the code that the compiler would normally emit
7710 to preevaluate the size/shape info for an
7711 adjustable array _must not_ be executed at run time
7712 in certain cases. Specifically, for Fortran,
7713 the case is when the pointer to the adjustable
7714 array == NULL. (For gnu-ish C, it might be nice
7715 for the source code itself to specify an expression
7716 that, if TRUE, inhibits execution of the code. Or
7717 reverse the sense for elegance.)
7719 (Note that g77 could use a different test than NULL,
7720 actually, since it happens to always pass an
7721 integer to the called function that specifies which
7722 entry point is being invoked. Hmm, this might
7723 solve the next problem.)
7725 One way a user could, I suppose, write "foo" so
7726 it works is to insert COND_EXPR's for the
7727 size/shape info so the dangerous stuff isn't
7728 actually done, as in:
7730 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7731 {
7732 ...
7733 }
7735 The next problem is that the front end needs to
7736 be able to tell the back end about the array's
7737 decl _before_ it tells it about the conditional
7738 expression to inhibit evaluation of size/shape info,
7739 as shown above.
7741 To solve this, the front end needs to be able
7742 to give the back end the expression to inhibit
7743 generation of the preevaluation code _after_
7744 it makes the decl for the adjustable array.
7746 Until then, the above example using the COND_EXPR
7747 doesn't pass muster with gcc because the "(a == NULL)"
7748 part has a reference to "a", which is still
7749 undefined at that point.
7751 g77 will therefore use a different mechanism in the
7752 meantime. */
7763 low,
7764 ffecom_integer_zero_node);
7769 high,
7770 ffecom_integer_zero_node);
7771 #endif
7773 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7774 probably. Fixes 950302-1.f. */
7779 /* ~~~Similarly, this fixes dumb0.f. The C front end
7780 does this, which is why dumb0.c would work. */
7785 type
7786 = build_array_type
7791 }
7794 {
7797 }
7801 {
7804 }
7809 /* If this arg is present in every entry point's list of
7810 dummy args, then we're done. */
7816 #if 1
7818 /* If variable_size in stor-layout has been called during
7819 the above, then get_pending_sizes should have the
7820 yet-to-be-evaluated saved expressions pending.
7821 Make the whole lot of them get emitted, conditionally
7822 on whether the array decl ("t" above) is not NULL. */
7824 {
7826 tree tem;
7831 {
7836 else
7837 sizes
7840 temv,
7841 sizes);
7842 }
7845 {
7846 sizes
7850 integer_type_node,
7851 t,
7852 null_pointer_node),
7853 sizes,
7855 integer_zero_node));
7858 sizes
7860 }
7864 }
7866 #else
7867 #if 0
7873 t,
7874 null_pointer_node);
7875 #else
7876 #if 0
7880 {
7886 }
7887 #endif
7888 #endif
7889 #endif
7890 }
7894 {
7895 ffesymbol cs;
7896 ffeglobal cg;
7897 tree ct;
7899 tree type;
7903 {
7906 }
7914 else
7921 else
7922 {
7923 ffetargetOffset offset;
7924 ffestorag cst;
7925 tree toffset;
7936 /* (t_type *) (((char *) &ct) + offset) */
7941 ct));
7947 t);
7951 }
7952 }
7964 /* Fall through. */
7968 }
7973 {
7987 {
7990 }
7995 else
8000 t);
8022 else
8023 t = build_pointer_type
8028 t);
8041 decls. */
8045 /* Fall through. */
8049 }
8054 {
8068 {
8071 }
8075 ffecom_tree_subr_type);
8096 ffecom_tree_ptr_to_subr_type);
8104 decls. */
8108 /* Fall through. */
8112 }
8117 {
8136 /* Fall through. */
8140 }
8145 {
8156 ffecom_tree_blockdata_type);
8179 /* Fall through. */
8183 }
8188 {
8208 /* Fall through. */
8212 }
8217 {
8236 /* Fall through. */
8240 }
8245 {
8265 /* Fall through. */
8269 }
8274 /* Fall through. */
8278 }
8287 }
8289 /* Transform into ASSIGNable symbol.
8291 Symbol has already been transformed, but for whatever reason, the
8292 resulting decl_tree has been deemed not usable for an ASSIGN target.
8293 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8294 another local symbol of type void * and stuff that in the assign_tree
8295 argument. The F77/F90 standards allow this implementation. */
8297 static ffesymbol
8299 {
8304 {
8307 }
8308 else
8309 {
8314 }
8324 {
8326 /* Unlike for regular vars, SAVE status is easy to determine for
8327 ASSIGNed vars, since there's no initialization, there's no
8328 effective storage association (so "SAVE J" does not apply to
8329 K even given "EQUIVALENCE (J,K)"), there's no size issue
8330 to worry about, etc. */
8335 else
8344 /* Note that twinning a DUMMY means the caller won't see
8345 the ASSIGNed value. But both F77 and F90 allow implementations
8346 to do this, i.e. disallow Fortran code that would try and
8347 take advantage of actually putting a label into a variable
8348 via a dummy argument (or any other storage association, for
8349 that matter). */
8356 }
8366 }
8368 /* Implement COMMON area in back end.
8370 Because COMMON-based variables can be referenced in the dimension
8371 expressions of dummy (adjustable) arrays, and because dummies
8372 (in the gcc back end) need to be put in the outer binding level
8373 of a function (which has two binding levels, the outer holding
8374 the dummies and the inner holding the other vars), special care
8375 must be taken to handle COMMON areas.
8377 The current strategy is basically to always tell the back end about
8378 the COMMON area as a top-level external reference to just a block
8379 of storage of the master type of that area (e.g. integer, real,
8380 character, whatever -- not a structure). As a distinct action,
8381 if initial values are provided, tell the back end about the area
8382 as a top-level non-external (initialized) area and remember not to
8383 allow further initialization or expansion of the area. Meanwhile,
8384 if no initialization happens at all, tell the back end about
8385 the largest size we've seen declared so the space does get reserved.
8386 (This function doesn't handle all that stuff, but it does some
8387 of the important things.)
8389 Meanwhile, for COMMON variables themselves, just keep creating
8390 references like *((float *) (&common_area + offset)) each time
8391 we reference the variable. In other words, don't make a VAR_DECL
8392 or any kind of component reference (like we used to do before 0.4),
8393 though we might do that as well just for debugging purposes (and
8394 stuff the rtl with the appropriate offset expression). */
8396 static void
8398 {
8401 tree cbt;
8402 tree cbtype;
8403 tree init;
8404 tree high;
8413 /* First update the size of the area in global terms. */
8422 /* If we already have declared this common block for a previous program
8423 unit, and either we already initialized it or we don't have new
8424 initialization for it, just return what we have without changing it. */
8427 && (!is_init
8429 {
8432 }
8434 /* Process inits. */
8437 {
8439 {
8440 ffebld sexp;
8442 /* Set the padding for the expression, so ffecom_expr
8443 knows to insert that many zeros. */
8445 {
8461 }
8469 }
8470 }
8471 else
8473 }
8474 else
8477 /* cbtype must be permanently allocated! */
8479 /* Allocate the MAX of the areas so far, seen filewide. */
8487 integer_zero_node,
8488 high));
8489 else
8493 {
8494 cbt
8497 cbtype);
8500 }
8501 else
8502 {
8505 }
8515 /* Make sure that any type can live in COMMON and be referenced
8516 without getting a bus error. We could pick the most restrictive
8517 alignment of all entities actually placed in the COMMON, but
8518 this seems easy enough. */
8532 {
8538 }
8545 }
8547 /* Make master area for local EQUIVALENCE. */
8549 static void
8551 {
8552 tree eqt;
8553 tree eqtype;
8554 tree init;
8555 tree high;
8565 /* Process inits. */
8568 {
8570 {
8571 ffebld sexp;
8573 /* Set the padding for the expression, so ffecom_expr
8574 knows to insert that many zeros. */
8576 {
8592 }
8597 }
8598 else
8600 }
8603 else
8609 eqst);
8617 ffecom_integer_zero_node,
8618 high));
8622 ffesymbol_text
8624 eqtype);
8627 || ffecom_member_namelisted_
8628 #ifdef FFECOM_sizeMAXSTACKITEM
8630 #endif
8635 else
8642 else
8647 /* Make sure that any type can live in EQUIVALENCE and be referenced
8648 without getting a bus error. We could pick the most restrictive
8649 alignment of all entities actually placed in the EQUIVALENCE, but
8650 this seems easy enough. */
8664 {
8669 }
8675 eqst);
8676 }
8678 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8680 static tree
8682 {
8683 tree nmlt;
8685 tree nmlinits;
8686 tree nameinit;
8687 tree varsinit;
8688 tree nvarsinit;
8689 tree field;
8690 tree high;
8696 mynumber++),
8697 nmltype);
8703 /* Process inits. */
8713 = build_type_variant
8714 (build_array_type
8717 ffecom_f2c_ftnlen_one_node,
8718 high)),
8723 nameinit);
8727 varsinit);
8731 {
8732 ffebld b;
8736 }
8744 varsinit);
8757 }
8759 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8760 analyzed on the assumption it is calculating a pointer to be
8761 indirected through. It must return the proper decl and offset,
8762 taking into account different units of measurements for offsets. */
8764 static void
8766 {
8768 {
8782 {
8783 /* An offset into COMMON. */
8786 /* Convert offset (presumably in bytes) into canonical units
8787 (presumably bits). */
8792 }
8793 /* Not a COMMON reference, so an unrecognized pattern. */
8804 {
8805 /* A reference to COMMON. */
8809 }
8810 /* Fall through. */
8812 /* Not a COMMON reference, so an unrecognized pattern. */
8815 }
8816 }
8818 /* Given a tree that is possibly intended for use as an lvalue, return
8819 information representing a canonical view of that tree as a decl, an
8820 offset into that decl, and a size for the lvalue.
8822 If there's no applicable decl, NULL_TREE is returned for the decl,
8823 and the other fields are left undefined.
8825 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8826 is returned for the decl, and the other fields are left undefined.
8828 Otherwise, the decl returned currently is either a VAR_DECL or a
8829 PARM_DECL.
8831 The offset returned is always valid, but of course not necessarily
8832 a constant, and not necessarily converted into the appropriate
8833 type, leaving that up to the caller (so as to avoid that overhead
8834 if the decls being looked at are different anyway).
8836 If the size cannot be determined (e.g. an adjustable array),
8837 an ERROR_MARK node is returned for the size. Otherwise, the
8838 size returned is valid, not necessarily a constant, and not
8839 necessarily converted into the appropriate type as with the
8840 offset.
8842 Note that the offset and size expressions are expressed in the
8843 base storage units (usually bits) rather than in the units of
8844 the type of the decl, because two decls with different types
8845 might overlap but with apparently non-overlapping array offsets,
8846 whereas converting the array offsets to consistant offsets will
8847 reveal the overlap. */
8849 static void
8851 {
8852 /* The default path is to report a nonexistant decl. */
8859 {
8927 {
8930 tree init_offset;
8934 {
8937 }
8940 array);
8945 /* Calculate ((element - base) * NBBY) + init_offset. */
8947 element,
8959 }
8963 /* Most of this code is to handle references to COMMON. And so
8964 far that is useful only for calling library functions, since
8965 external (user) functions might reference common areas. But
8966 even calling an external function, it's worthwhile to decode
8967 COMMON references because if not storing into COMMON, we don't
8968 want COMMON-based arguments to gratuitously force use of a
8969 temporary. */
8995 }
8996 }
8998 /* Do divide operation appropriate to type of operands. */
9000 static tree
9003 {
9009 {
9012 left,
9013 right);
9018 left,
9019 right);
9020 {
9021 ffecomGfrt ix;
9026 else
9031 left);
9035 right);
9042 tree_type,
9043 left,
9046 }
9050 {
9051 ffecomGfrt ix;
9056 else
9061 left);
9065 right);
9072 tree_type,
9073 left,
9076 }
9081 left,
9082 right);
9083 }
9084 }
9086 /* Build type info for non-dummy variable. */
9088 static tree
9090 {
9091 tree type;
9092 ffebld dl;
9093 ffebld dim;
9094 tree lowt;
9095 tree hight;
9099 {
9103 type
9104 = build_array_type
9107 ffecom_f2c_ftnlen_one_node,
9108 hight));
9110 }
9113 {
9122 else
9138 }
9141 }
9143 /* Build Namelist type. */
9146 static tree
9148 {
9150 {
9160 string_type_node);
9163 integer_type_node);
9169 }
9172 }
9174 /* Build Vardesc type. */
9177 static tree
9179 {
9181 {
9186 string_type_node);
9188 string_type_node);
9190 ffecom_f2c_ptr_to_ftnlen_type_node);
9192 integer_type_node);
9198 }
9201 }
9203 static tree
9205 {
9206 ffesymbol s;
9212 {
9215 tree var;
9216 tree nameinit;
9217 tree dimsinit;
9218 tree addrinit;
9219 tree typeinit;
9220 tree field;
9221 tree varinits;
9226 mynumber++),
9227 vardesctype);
9233 /* Process inits. */
9239 = build_type_variant
9240 (build_array_type
9243 integer_one_node,
9250 nameinit);
9257 {
9264 }
9265 else
9269 nameinit);
9271 addrinit);
9286 }
9289 }
9291 static tree
9293 {
9294 ffebld b;
9295 tree list;
9297 tree var;
9304 {
9305 tree t;
9311 else
9312 {
9315 }
9316 }
9320 integer_one_node,
9334 }
9336 static tree
9338 {
9341 integer_zero_node);
9343 {
9344 ffebld b;
9345 ffebld e;
9346 tree list;
9347 tree backlist;
9349 tree var;
9350 tree numdim;
9351 tree numelem;
9366 {
9367 tree t;
9368 tree low;
9369 tree back;
9373 else
9374 {
9380 else
9381 {
9384 }
9385 }
9389 else
9396 }
9399 {
9402 else
9406 ffecom_f2c_ftnlen_type_node,
9408 baseoff));
9409 }
9411 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9424 integer_zero_node,
9425 build_int_2
9442 }
9443 }
9445 /* Essentially does a "fold (build1 (code, type, node))" while checking
9446 for certain housekeeping things.
9448 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9449 ffecom_1_fn instead. */
9451 tree
9453 {
9454 tree item;
9461 {
9464 }
9467 {
9468 tree realtype;
9481 {
9484 }
9487 item =
9491 node)),
9494 node)));
9500 }
9509 }
9511 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9512 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9513 does not set TREE_ADDRESSABLE (because calling an inline
9514 function does not mean the function needs to be separately
9515 compiled). */
9517 tree
9519 {
9520 tree item;
9521 tree type;
9536 }
9538 /* Essentially does a "fold (build (code, type, node1, node2))" while
9539 checking for certain housekeeping things. */
9541 tree
9543 {
9544 tree item;
9552 {
9567 {
9570 }
9574 item =
9578 node1),
9580 node2)),
9583 node1),
9585 node2)));
9590 {
9593 }
9597 item =
9601 node1),
9603 node2)),
9606 node1),
9608 node2)));
9613 {
9616 }
9621 node1));
9623 node1));
9625 node2));
9627 node2));
9628 item =
9632 a,
9633 c),
9635 b,
9636 d)),
9639 a,
9640 d),
9642 c,
9643 b)));
9649 {
9652 }
9658 item =
9662 node1),
9664 node2)),
9667 node1),
9669 node2)));
9675 {
9678 }
9684 item =
9688 node1),
9690 node2)),
9693 node1),
9695 node2)));
9701 }
9706 }
9708 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9710 ffesymbol s; // the ENTRY point itself
9711 if (ffecom_2pass_advise_entrypoint(s))
9712 // the ENTRY point has been accepted
9714 Does whatever compiler needs to do when it learns about the entrypoint,
9715 like determine the return type of the master function, count the
9716 number of entrypoints, etc. Returns FALSE if the return type is
9717 not compatible with the return type(s) of other entrypoint(s).
9719 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9720 later (after _finish_progunit) be called with the same entrypoint(s)
9721 as passed to this fn for which TRUE was returned.
9723 03-Jan-92 JCB 2.0
9724 Return FALSE if the return type conflicts with previous entrypoints. */
9726 bool
9728 {
9742 arglist's dummies. */
9752 {
9759 else
9762 }
9763 }
9765 /* If necessary, scan entry arglist for alternate returns. Do this scan
9766 apparently redundantly (it's done below to UNIONize the arglists) so
9767 that we don't complain about RETURN 1 if an offending ENTRY is the only
9768 one with an alternate return. */
9771 {
9775 {
9778 {
9781 }
9782 }
9783 }
9785 /* Now check type compatibility. */
9788 {
9794 ok
9805 {
9808 }
9811 {
9814 }
9816 }
9819 {
9824 }
9826 /* Entrypoint type compatible with previous types. */
9830 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9835 {
9844 appending of arg. */
9847 }
9851 /* Append this arg to the master list. */
9856 else
9858 }
9861 }
9863 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9865 ffesymbol s; // the ENTRY point itself
9866 ffecom_2pass_do_entrypoint(s);
9868 Does whatever compiler needs to do to make the entrypoint actually
9869 happen. Must be called for each entrypoint after
9870 ffecom_finish_progunit is called. */
9872 void
9874 {
9883 }
9884 else
9890 }
9892 /* Essentially does a "fold (build (code, type, node1, node2))" while
9893 checking for certain housekeeping things. Always sets
9894 TREE_SIDE_EFFECTS. */
9896 tree
9898 {
9899 tree item;
9909 }
9911 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9912 checking for certain housekeeping things. */
9914 tree
9916 {
9917 tree item;
9930 }
9932 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9933 checking for certain housekeeping things. Always sets
9934 TREE_SIDE_EFFECTS. */
9936 tree
9938 {
9939 tree item;
9950 }
9952 /* ffecom_arg_expr -- Transform argument expr into gcc tree
9954 See use by ffecom_list_expr.
9956 If expression is NULL, returns an integer zero tree. If it is not
9957 a CHARACTER expression, returns whatever ffecom_expr
9958 returns and sets the length return value to NULL_TREE. Otherwise
9959 generates code to evaluate the character expression, returns the proper
9960 pointer to the result, but does NOT set the length return value to a tree
9961 that specifies the length of the result. (In other words, the length
9962 variable is always set to NULL_TREE, because a length is never passed.)
9964 21-Dec-91 JCB 1.1
9965 Don't set returned length, since nobody needs it (yet; someday if
9966 we allow CHARACTER*(*) dummies to statement functions, we'll need
9967 it). */
9969 tree
9971 {
9972 tree ign;
9983 }
9985 /* Transform expression into constant argument-pointer-to-expression tree.
9987 If the expression can be transformed into a argument-pointer-to-expression
9988 tree that is constant, that is done, and the tree returned. Else
9989 NULL_TREE is returned.
9991 That way, a caller can attempt to provide compile-time initialization
9992 of a variable and, if that fails, *then* choose to start a new block
9993 and resort to using temporaries, as appropriate. */
9995 tree
9997 {
10002 {
10006 }
10013 {
10014 tree t;
10020 }
10028 }
10030 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10032 See use by ffecom_list_ptr_to_expr.
10034 If expression is NULL, returns an integer zero tree. If it is not
10035 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10036 returns and sets the length return value to NULL_TREE. Otherwise
10037 generates code to evaluate the character expression, returns the proper
10038 pointer to the result, AND sets the length return value to a tree that
10039 specifies the length of the result.
10041 If the length argument is NULL, this is a slightly special
10042 case of building a FORMAT expression, that is, an expression that
10043 will be used at run time without regard to length. For the current
10044 implementation, which uses the libf2c library, this means it is nice
10045 to append a null byte to the end of the expression, where feasible,
10046 to make sure any diagnostic about the FORMAT string terminates at
10047 some useful point.
10049 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10050 length argument. This might even be seen as a feature, if a null
10051 byte can always be appended. */
10053 tree
10055 {
10056 tree item;
10057 tree ign_length;
10058 ffecomConcatList_ catlist;
10067 {
10071 {
10072 tree temp_exp;
10073 tree temp_length;
10080 temp_exp);
10081 }
10087 {
10090 }
10096 {
10105 }
10110 }
10123 {
10126 {
10129 }
10137 else
10146 }
10148 {
10151 tree lengths;
10152 tree items;
10153 tree length_array;
10154 tree item_array;
10155 tree citem;
10156 tree clength;
10157 tree temporary;
10158 tree num;
10159 tree known_length;
10160 ffetargetCharacterSize sz;
10163 /* ~~Kludge! */
10166 {
10167 tree hook;
10176 }
10181 {
10186 else
10191 {
10195 }
10197 items
10202 item_array,
10204 citem),
10205 items);
10208 known_length
10210 known_length,
10211 clength);
10212 lengths
10217 length_array,
10219 clength),
10220 lengths);
10221 }
10225 temporary);
10232 items));
10237 lengths));
10239 = build_tree_list
10252 item,
10253 temporary);
10257 }
10262 }
10264 /* Generate call to run-time function.
10266 The first arg is the GNU Fortran Run-Time function index, the second
10267 arg is the list of arguments to pass to it. Returned is the expression
10268 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10269 result (which may be void). */
10271 tree
10273 {
10279 }
10281 /* Transform constant-union to tree. */
10283 tree
10286 {
10287 tree item;
10290 {
10292 {
10296 {
10297 #if FFETARGET_okINTEGER1
10302 #endif
10304 #if FFETARGET_okINTEGER2
10309 #endif
10311 #if FFETARGET_okINTEGER3
10316 #endif
10318 #if FFETARGET_okINTEGER4
10320 #if HOST_BITS_PER_LONGLONG > HOST_BITS_PER_WIDE_INT
10321 {
10325 }
10326 #else
10329 #endif
10331 #endif
10335 /* Fall through. */
10338 }
10341 }
10345 {
10349 {
10350 #if FFETARGET_okLOGICAL1
10354 #endif
10356 #if FFETARGET_okLOGICAL2
10360 #endif
10362 #if FFETARGET_okLOGICAL3
10366 #endif
10368 #if FFETARGET_okLOGICAL4
10372 #endif
10376 /* Fall through. */
10379 }
10382 }
10386 {
10387 REAL_VALUE_TYPE val;
10390 {
10391 #if FFETARGET_okREAL1
10395 #endif
10397 #if FFETARGET_okREAL2
10401 #endif
10403 #if FFETARGET_okREAL3
10407 #endif
10411 /* Fall through. */
10414 }
10416 }
10420 {
10421 REAL_VALUE_TYPE real;
10422 REAL_VALUE_TYPE imag;
10426 {
10427 #if FFETARGET_okCOMPLEX1
10432 #endif
10434 #if FFETARGET_okCOMPLEX2
10439 #endif
10441 #if FFETARGET_okCOMPLEX3
10446 #endif
10450 /* Fall through. */
10453 }
10457 }
10462 ffetargetCharacter1 val;
10465 {
10466 #if FFETARGET_okCHARACTER1
10470 #endif
10474 /* Fall through. */
10477 }
10482 build_range_type
10484 integer_one_node,
10485 build_int_2
10486 (ffetarget_length_character1
10489 }
10493 {
10494 ffetargetHollerith h;
10498 /* If not at least as wide as default INTEGER, widen it. */
10501 else
10502 {
10507 FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10510 str);
10511 }
10514 build_range_type
10516 integer_one_node,
10517 build_int_2
10520 }
10524 {
10525 ffetargetInteger1 ival;
10526 ffetargetTypeless tless;
10527 ffebad error;
10534 }
10539 /* Fall through. */
10542 }
10547 }
10549 /* Transform constant-union to tree, with the type known. */
10551 tree
10553 ffebldConst ct)
10554 {
10555 tree item;
10560 {
10561 #if FFETARGET_okINTEGER1
10566 #endif
10567 #if FFETARGET_okINTEGER2
10572 #endif
10573 #if FFETARGET_okINTEGER3
10578 #endif
10579 #if FFETARGET_okINTEGER4
10581 #if HOST_BITS_PER_LONGLONG > HOST_BITS_PER_WIDE_INT
10582 {
10587 }
10588 #else
10591 #endif
10593 #endif
10594 #if FFETARGET_okLOGICAL1
10599 #endif
10600 #if FFETARGET_okLOGICAL2
10605 #endif
10606 #if FFETARGET_okLOGICAL3
10611 #endif
10612 #if FFETARGET_okLOGICAL4
10617 #endif
10622 }
10629 }
10630 /* Transform expression into constant tree.
10632 If the expression can be transformed into a tree that is constant,
10633 that is done, and the tree returned. Else NULL_TREE is returned.
10635 That way, a caller can attempt to provide compile-time initialization
10636 of a variable and, if that fails, *then* choose to start a new block
10637 and resort to using temporaries, as appropriate. */
10639 tree
10641 {
10652 {
10653 tree t;
10658 }
10661 }
10663 /* Handy way to make a field in a struct/union. */
10665 tree
10667 {
10668 tree field;
10678 }
10680 void
10682 {
10684 }
10686 /* End a compound statement (block). */
10688 tree
10690 {
10692 }
10694 /* ffecom_end_transition -- Perform end transition on all symbols
10696 ffecom_end_transition();
10698 Calls ffecom_sym_end_transition for each global and local symbol. */
10700 void
10702 {
10703 ffebld item;
10713 {
10715 }
10722 {
10723 ffebld callee;
10724 ffesymbol s;
10725 tree dt;
10726 tree t;
10727 tree var;
10734 {
10737 }
10743 number++),
10744 dt);
10756 }
10758 /* This handles any COMMON areas that weren't referenced but have, for
10759 example, important initial data. */
10767 }
10769 /* ffecom_exec_transition -- Perform exec transition on all symbols
10771 ffecom_exec_transition();
10773 Calls ffecom_sym_exec_transition for each global and local symbol.
10774 Make sure error updating not inhibited. */
10776 void
10778 {
10790 {
10792 }
10796 }
10798 /* Handle assignment statement.
10800 Convert dest and source using ffecom_expr, then join them
10801 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
10803 void
10805 {
10806 tree dest_tree;
10807 tree dest_length;
10808 tree source_tree;
10809 tree expr_tree;
10812 {
10814 tree assign_temp;
10816 /* This attempts to replicate the test below, but must not be
10817 true when the test below is false. (Always err on the side
10818 of creating unused temporaries, to avoid ICEs.) */
10823 {
10826 }
10827 else
10828 {
10831 }
10835 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10836 create a temporary through which the assignment is to take place,
10837 since MODIFY_EXPR doesn't handle partial overlap properly. */
10840 {
10842 ffecom_tree_type
10845 FFETARGET_charactersizeNONE,
10847 }
10848 else
10861 else
10862 {
10866 }
10873 {
10875 assign_temp,
10876 source_tree);
10879 dest_tree,
10880 assign_temp);
10881 }
10882 else
10884 dest_tree,
10885 source_tree);
10889 }
10898 source);
10899 }
10901 /* ffecom_expr -- Transform expr into gcc tree
10903 tree t;
10904 ffebld expr; // FFE expression.
10905 tree = ffecom_expr(expr);
10907 Recursive descent on expr while making corresponding tree nodes and
10908 attaching type info and such. */
10910 tree
10912 {
10914 }
10916 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
10918 tree
10920 {
10922 }
10924 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
10926 tree
10928 {
10930 }
10932 /* Transform expr for use as into read/write tree and stabilize the
10933 reference. Not for use on CHARACTER expressions.
10935 Recursive descent on expr while making corresponding tree nodes and
10936 attaching type info and such. */
10938 tree
10940 {
10942 /* Different target types not yet supported. */
10946 }
10948 /* Transform expr for use as into write tree and stabilize the
10949 reference. Not for use on CHARACTER expressions.
10951 Recursive descent on expr while making corresponding tree nodes and
10952 attaching type info and such. */
10954 tree
10956 {
10958 /* Different target types not yet supported. */
10962 }
10964 /* Do global stuff. */
10966 void
10968 {
10973 }
10975 /* Public entry point for front end to access finish_decl. */
10977 void
10979 {
10982 }
10984 /* Finish a program unit. */
10986 void
10988 {
10995 }
10997 /* Wrapper for get_identifier. pattern is sprintf-like. */
10999 tree
11001 {
11002 tree decl;
11014 }
11016 ffeinfoBasictype
11018 {
11022 {
11060 }
11061 }
11063 ffeinfoKindtype
11065 {
11069 {
11107 }
11108 }
11110 void
11112 {
11113 tree endlink;
11116 tree t;
11117 tree field;
11118 ffetype type;
11119 ffetype base_type;
11123 tree ffecom_tree_ptr_to_fun_type_void;
11125 /* This block of code comes from the now-obsolete cktyps.c. It checks
11126 whether the compiler environment is buggy in known ways, some of which
11127 would, if not explicitly checked here, result in subtle bugs in g77. */
11130 {
11132 =
11141 {
11145 }
11149 {
11153 }
11157 {
11161 }
11162 }
11169 /* Make the binding_level structure for global names. */
11176 /* Define `int' and `char' first so that dbx will output them first. */
11178 integer_type_node));
11179 /* CHARACTER*1 is unsigned in ICHAR contexts. */
11182 char_type_node));
11184 long_integer_type_node));
11186 unsigned_type_node));
11188 long_unsigned_type_node));
11190 long_long_integer_type_node));
11192 long_long_unsigned_type_node));
11194 short_integer_type_node));
11196 short_unsigned_type_node));
11198 /* Set the sizetype before we make other types. This *should* be the
11199 first type we create. */
11201 set_sizetype
11203 ffecom_typesize_pointer_
11208 /* Define both `signed char' and `unsigned char'. */
11210 signed_char_type_node));
11213 unsigned_char_type_node));
11216 float_type_node));
11218 double_type_node));
11220 long_double_type_node));
11222 /* For now, override what build_common_tree_nodes has done. */
11226 complex_long_double_type_node
11230 complex_integer_type_node));
11232 complex_float_type_node));
11234 complex_double_type_node));
11236 complex_long_double_type_node));
11239 void_type_node));
11240 /* We are not going to have real types in C with less than byte alignment,
11241 so we might as well not have any types that claim to have it. */
11247 ffecom_tree_fun_type_void
11250 ffecom_tree_ptr_to_fun_type_void
11269 t);
11273 {
11278 }
11280 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11281 to size FLOAT_TYPE_SIZE because they have to be the same size as
11282 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11283 Compiler options and other such stuff that change the ways these
11284 types are set should not affect this particular setup. */
11289 t));
11293 type);
11299 type);
11307 t));
11312 t));
11315 type);
11321 type);
11328 t));
11333 t));
11336 type);
11342 type);
11349 t));
11354 t));
11357 type);
11363 type);
11370 t));
11372 #if 0
11378 {
11380 LONG_TYPE_SIZE);
11381 }
11382 #endif
11387 t));
11391 type);
11397 type);
11404 t));
11407 type);
11413 type);
11420 t));
11423 type);
11429 type);
11436 t));
11439 type);
11445 type);
11453 t));
11458 type);
11464 type);
11474 t));
11478 type);
11484 type);
11491 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11493 t));
11497 type);
11503 type);
11510 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11512 t));
11515 type);
11521 type);
11523 type);
11528 /* Make function and ptr-to-function types for non-CHARACTER types. */
11532 {
11534 {
11536 {
11537 /* Figure out the smallest INTEGER type that can hold
11538 a pointer on this machine. */
11541 {
11546 }
11547 }
11550 /* For f2c compatibility, REAL functions are really
11551 implemented as DOUBLE PRECISION. */
11554 t = ffecom_tree_type
11558 NULL_TREE);
11560 }
11561 }
11563 /* Set up pointer types. */
11570 FFEINFO_kindtypeINTEGERDEFAULT),
11573 ffecom_pointer_kind_));
11577 else
11582 ffecom_integer_type_node
11585 integer_zero_node);
11587 integer_one_node);
11589 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11590 Turns out that by TYLONG, runtime/libI77/lio.h really means
11591 "whatever size an ftnint is". For consistency and sanity,
11592 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11593 all are INTEGER, which we also make out of whatever back-end
11594 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11595 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11596 accommodate machines like the Alpha. Note that this suggests
11597 f2c and libf2c are missing a distinction perhaps needed on
11598 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11601 FFETARGET_f2cTYLONG);
11603 FFETARGET_f2cTYSHORT);
11605 FFETARGET_f2cTYINT1);
11607 FFETARGET_f2cTYQUAD);
11609 FFETARGET_f2cTYLOGICAL);
11611 FFETARGET_f2cTYLOGICAL2);
11613 FFETARGET_f2cTYLOGICAL1);
11614 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11616 FFETARGET_f2cTYQUAD);
11618 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11619 loop. CHARACTER items are built as arrays of unsigned char. */
11626 FFEINFO_kindtypeCHARACTER1,
11627 type);
11646 /* Make multi-return-value type and fields. */
11654 {
11671 }
11676 /* Subroutines usually return integer because they might have alternate
11677 returns. */
11679 ffecom_tree_subr_type
11681 ffecom_tree_ptr_to_subr_type
11683 ffecom_tree_blockdata_type
11766 FFECOM_f2cINTEGER,
11769 FFECOM_f2cADDRESS,
11772 FFECOM_f2cREAL,
11775 FFECOM_f2cDOUBLEREAL,
11778 FFECOM_f2cCOMPLEX,
11781 FFECOM_f2cDOUBLECOMPLEX,
11784 FFECOM_f2cLONGINT,
11787 FFECOM_f2cLOGICAL,
11790 FFECOM_f2cFLAG,
11793 FFECOM_f2cFTNLEN,
11796 FFECOM_f2cFTNINT,
11799 ffecom_f2c_ftnlen_zero_node
11802 ffecom_f2c_ftnlen_one_node
11808 ffecom_f2c_ptr_to_ftnlen_type_node
11811 ffecom_f2c_ptr_to_ftnint_type_node
11814 ffecom_f2c_ptr_to_integer_type_node
11817 ffecom_f2c_ptr_to_real_type_node
11825 /* Do "extern int xargc;". */
11829 integer_type_node);
11839 {
11846 }
11847 #endif
11852 /* I/O will probably crash. */
11856 #endif
11861 /* ASSIGN 10 TO I will crash. */
11866 #endif
11867 }
11869 /* ffecom_init_2 -- Initialize
11871 ffecom_init_2(); */
11873 void
11875 {
11886 }
11888 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11890 tree t;
11891 ffebld expr; // FFE opITEM list.
11892 tree = ffecom_list_expr(expr);
11894 List of actual args is transformed into corresponding gcc backend list. */
11896 tree
11898 {
11899 tree list;
11903 tree length;
11906 {
11916 {
11919 }
11920 }
11925 }
11927 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11929 tree t;
11930 ffebld expr; // FFE opITEM list.
11931 tree = ffecom_list_ptr_to_expr(expr);
11933 List of actual args is transformed into corresponding gcc backend list for
11934 use in calling an external procedure (vs. a statement function). */
11936 tree
11938 {
11939 tree list;
11943 tree length;
11946 {
11956 {
11959 }
11960 }
11965 }
11967 /* Obtain gcc's LABEL_DECL tree for label. */
11969 tree
11971 {
11972 tree glabel;
11975 {
11979 {
11985 void_type_node);
11992 ffecom_get_invented_identifier
11996 NULL_TREE),
12017 }
12019 }
12020 else
12021 {
12023 }
12026 }
12028 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12029 a single source specification (as in the fourth argument of MVBITS).
12030 If the type is NULL_TREE, the type of lhs is used to make the type of
12031 the MODIFY_EXPR. */
12033 tree
12035 {
12046 }
12048 /* Register source file name. */
12050 void
12052 {
12054 }
12056 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12058 ffestorag st;
12059 ffecom_notify_init_storage(st);
12061 Gets called when all possible units in an aggregate storage area (a LOCAL
12062 with equivalences or a COMMON) have been initialized. The initialization
12063 info either is in ffestorag_init or, if that is NULL,
12064 ffestorag_accretion:
12066 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12067 even for an array if the array is one element in length!
12069 ffestorag_accretion will contain an opACCTER. It is much like an
12070 opARRTER except it has an ffebit object in it instead of just a size.
12071 The back end can use the info in the ffebit object, if it wants, to
12072 reduce the amount of actual initialization, but in any case it should
12073 kill the ffebit object when done. Also, set accretion to NULL but
12074 init to a non-NULL value.
12076 After performing initialization, DO NOT set init to NULL, because that'll
12077 tell the front end it is ok for more initialization to happen. Instead,
12078 set init to an opANY expression or some such thing that you can use to
12079 tell that you've already initialized the object.
12081 27-Oct-91 JCB 1.1
12082 Support two-pass FFE. */
12084 void
12086 {
12090 {
12096 }
12097 }
12099 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12101 ffesymbol s;
12102 ffecom_notify_init_symbol(s);
12104 Gets called when all possible units in a symbol (not placed in COMMON
12105 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12106 have been initialized. The initialization info either is in
12107 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12109 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12110 even for an array if the array is one element in length!
12112 ffesymbol_accretion will contain an opACCTER. It is much like an
12113 opARRTER except it has an ffebit object in it instead of just a size.
12114 The back end can use the info in the ffebit object, if it wants, to
12115 reduce the amount of actual initialization, but in any case it should
12116 kill the ffebit object when done. Also, set accretion to NULL but
12117 init to a non-NULL value.
12119 After performing initialization, DO NOT set init to NULL, because that'll
12120 tell the front end it is ok for more initialization to happen. Instead,
12121 set init to an opANY expression or some such thing that you can use to
12122 tell that you've already initialized the object.
12124 27-Oct-91 JCB 1.1
12125 Support two-pass FFE. */
12127 void
12129 {
12134 possibilities checked. */
12138 {
12142 }
12143 }
12145 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12147 ffesymbol s;
12148 ffecom_notify_primary_entry(s);
12150 Gets called when implicit or explicit PROGRAM statement seen or when
12151 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12152 global symbol that serves as the entry point. */
12154 void
12156 {
12163 else
12167 {
12170 else
12172 }
12175 {
12176 ffebld list;
12177 ffebld arg;
12182 {
12185 {
12188 }
12189 }
12190 }
12191 }
12195 {
12197 }
12199 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12201 tree t;
12202 ffebld expr; // FFE expression.
12203 tree = ffecom_ptr_to_expr(expr);
12205 Like ffecom_expr, but sticks address-of in front of most things. */
12207 tree
12209 {
12210 tree item;
12211 ffeinfoBasictype bt;
12212 ffeinfoKindtype kt;
12213 ffesymbol s;
12218 {
12222 {
12223 ffecomGfrt ix;
12228 {
12231 }
12232 }
12233 else
12234 {
12237 {
12240 }
12241 }
12247 item);
12264 item);
12278 /* The back end currently optimizes a bit too zealously for us, in that
12279 we fail JCB001 if the following block of code is omitted. It checks
12280 to see if the transformed expression is a symbol or array reference,
12281 and encloses it in a SAVE_EXPR if that is the case. */
12290 #ifdef OFFSET_REF
12292 #endif
12296 {
12298 }
12301 item);
12303 }
12307 }
12309 /* Obtain a temp var with given data type.
12311 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12312 or >= 0 for a CHARACTER type.
12314 elements is -1 for a scalar or > 0 for an array of type. */
12316 tree
12319 {
12320 tree t;
12331 ffecom_f2c_ftnlen_one_node,
12336 integer_zero_node,
12341 commentary,
12342 mynumber++),
12343 type);
12349 }
12351 /* Prepare argument pointer to expression.
12353 Like ffecom_prepare_expr, except for expressions to be evaluated
12354 via ffecom_arg_ptr_to_expr. */
12356 void
12358 {
12359 /* ~~For now, it seems to be the same thing. */
12362 }
12364 /* End of preparations. */
12366 bool
12368 {
12375 }
12377 /* Prepare expression.
12379 This is called before any code is generated for the current block.
12380 It scans the expression, declares any temporaries that might be needed
12381 during evaluation of the expression, and stores those temporaries in
12382 the appropriate "hook" fields of the expression. `dest', if not NULL,
12383 specifies the destination that ffecom_expr_ will see, in case that
12384 helps avoid generating unused temporaries.
12386 ~~Improve to avoid allocating unused temporaries by taking `dest'
12387 into account vis-a-vis aliasing requirements of complex/character
12388 functions. */
12390 void
12392 {
12393 ffeinfoBasictype bt;
12394 ffeinfoKindtype kt;
12395 ffetargetCharacterSize sz;
12407 /* Generate whatever temporaries are needed to represent the result
12408 of the expression. */
12411 {
12414 }
12417 {
12419 /* Don't make temps for SYMTER, CONTER, etc. */
12424 {
12427 {
12428 ffesymbol s;
12440 }
12442 {
12443 /* Requires special treatment. There's no POW_CC function
12444 in libg2c, so POW_ZZ is used, which means we always
12445 need a double-complex temp, not a single-complex. */
12447 }
12449 /* The other ops don't need temps for complex operands. */
12452 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12453 REAL(C). See 19990325-0.f, routine `check', for cases. */
12455 ffecom_tree_type
12457 FFETARGET_charactersizeNONE,
12466 /* ~~Kludge alert! This should someday be fixed. */
12474 }
12478 {
12479 /* This gets special handling, because only one set of temps
12480 is needed for a tree of these -- the tree is treated as
12481 a flattened list of concatenations when generating code. */
12483 ffecomConcatList_ catlist;
12492 {
12493 ltmp
12495 ffecom_f2c_ftnlen_type_node,
12497 itmp
12499 ffecom_f2c_address_type_node,
12501 result
12503 char_type_node,
12511 }
12515 i));
12520 {
12523 }
12524 }
12534 }
12537 {
12540 }
12542 /* Prepare subexpressions for this expr. */
12545 {
12560 {
12561 ffebld item;
12568 }
12572 /* Need to handle character conversion specially. */
12574 {
12586 }
12587 }
12590 }
12592 /* Prepare expression for reading and writing.
12594 Like ffecom_prepare_expr, except for expressions to be evaluated
12595 via ffecom_expr_rw. */
12597 void
12599 {
12600 /* This is all we support for now. */
12603 /* ~~For now, it seems to be the same thing. */
12606 }
12608 /* Prepare expression for writing.
12610 Like ffecom_prepare_expr, except for expressions to be evaluated
12611 via ffecom_expr_w. */
12613 void
12615 {
12616 /* This is all we support for now. */
12619 /* ~~For now, it seems to be the same thing. */
12622 }
12624 /* Prepare expression for returning.
12626 Like ffecom_prepare_expr, except for expressions to be evaluated
12627 via ffecom_return_expr. */
12629 void
12631 {
12635 && ffecom_is_altreturning_
12638 }
12640 /* Prepare pointer to expression.
12642 Like ffecom_prepare_expr, except for expressions to be evaluated
12643 via ffecom_ptr_to_expr. */
12645 void
12647 {
12648 /* ~~For now, it seems to be the same thing. */
12651 }
12653 /* Transform expression into constant pointer-to-expression tree.
12655 If the expression can be transformed into a pointer-to-expression tree
12656 that is constant, that is done, and the tree returned. Else NULL_TREE
12657 is returned.
12659 That way, a caller can attempt to provide compile-time initialization
12660 of a variable and, if that fails, *then* choose to start a new block
12661 and resort to using temporaries, as appropriate. */
12663 tree
12665 {
12677 {
12678 tree t;
12683 }
12686 }
12688 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12690 tree rtn; // NULL_TREE means use expand_null_return()
12691 ffebld expr; // NULL if no alt return expr to RETURN stmt
12692 rtn = ffecom_return_expr(expr);
12694 Based on the program unit type and other info (like return function
12695 type, return master function type when alternate ENTRY points,
12696 whether subroutine has any alternate RETURN points, etc), returns the
12697 appropriate expression to be returned to the caller, or NULL_TREE
12698 meaning no return value or the caller expects it to be returned somewhere
12699 else (which is handled by other parts of this module). */
12701 tree
12703 {
12704 tree rtn;
12707 {
12718 else
12731 into (implicit) dummy. */
12734 }
12736 #if 0
12737 /* Spurious error if RETURN happens before first reference! So elide
12738 this code. In particular, for debugging registry, rtn should always
12739 be non-null after all, but TREE_USED won't be set until we encounter
12740 a reference in the code. Perfectly okay (but weird) code that,
12741 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12742 this diagnostic for no reason. Have people use -O -Wuninitialized
12743 and leave it to the back end to find obviously weird cases. */
12745 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12746 situation; if the return value has never been referenced, it won't
12747 have a tree under 2pass mode. */
12750 {
12757 }
12758 #endif
12766 }
12769 }
12771 /* Do save_expr only if tree is not error_mark_node. */
12773 tree
12775 {
12777 }
12779 /* Start a compound statement (block). */
12781 void
12783 {
12785 }
12787 /* Public entry point for front end to access start_decl. */
12789 tree
12791 {
12794 }
12796 /* ffecom_sym_commit -- Symbol's state being committed to reality
12798 ffesymbol s;
12799 ffecom_sym_commit(s);
12801 Does whatever the backend needs when a symbol is committed after having
12802 been backtrackable for a period of time. */
12804 void
12806 {
12808 }
12810 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12812 ffecom_sym_end_transition();
12814 Does backend-specific stuff and also calls ffest_sym_end_transition
12815 to do the necessary FFE stuff.
12817 Backtracking is never enabled when this fn is called, so don't worry
12818 about it. */
12820 ffesymbol
12822 {
12823 ffestorag st;
12831 {
12832 ffecom_list_blockdata_
12834 FFEINTRIN_specNONE,
12835 FFEINTRIN_impNONE),
12836 ffecom_list_blockdata_);
12837 }
12839 /* This is where we finally notice that a symbol has partial initialization
12840 and finalize it. */
12843 {
12846 }
12850 {
12853 }
12858 {
12859 ffecom_list_common_
12861 FFEINTRIN_specNONE,
12862 FFEINTRIN_impNONE),
12863 ffecom_list_common_);
12864 }
12867 }
12869 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12871 ffecom_sym_exec_transition();
12873 Does backend-specific stuff and also calls ffest_sym_exec_transition
12874 to do the necessary FFE stuff.
12876 See the long-winded description in ffecom_sym_learned for info
12877 on handling the situation where backtracking is inhibited. */
12879 ffesymbol
12881 {
12885 }
12887 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12889 ffesymbol s;
12890 s = ffecom_sym_learned(s);
12892 Called when a new symbol is seen after the exec transition or when more
12893 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
12894 it arrives here is that all its latest info is updated already, so its
12895 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12896 field filled in if its gone through here or exec_transition first, and
12897 so on.
12899 The backend probably wants to check ffesymbol_retractable() to see if
12900 backtracking is in effect. If so, the FFE's changes to the symbol may
12901 be retracted (undone) or committed (ratified), at which time the
12902 appropriate ffecom_sym_retract or _commit function will be called
12903 for that function.
12905 If the backend has its own backtracking mechanism, great, use it so that
12906 committal is a simple operation. Though it doesn't make much difference,
12907 I suppose: the reason for tentative symbol evolution in the FFE is to
12908 enable error detection in weird incorrect statements early and to disable
12909 incorrect error detection on a correct statement. The backend is not
12910 likely to introduce any information that'll get involved in these
12911 considerations, so it is probably just fine that the implementation
12912 model for this fn and for _exec_transition is to not do anything
12913 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12914 and instead wait until ffecom_sym_commit is called (which it never
12915 will be as long as we're using ambiguity-detecting statement analysis in
12916 the FFE, which we are initially to shake out the code, but don't depend
12917 on this), otherwise go ahead and do whatever is needed.
12919 In essence, then, when this fn and _exec_transition get called while
12920 backtracking is enabled, a general mechanism would be to flag which (or
12921 both) of these were called (and in what order? neat question as to what
12922 might happen that I'm too lame to think through right now) and then when
12923 _commit is called reproduce the original calling sequence, if any, for
12924 the two fns (at which point backtracking will, of course, be disabled). */
12926 ffesymbol
12928 {
12932 }
12934 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12936 ffesymbol s;
12937 ffecom_sym_retract(s);
12939 Does whatever the backend needs when a symbol is retracted after having
12940 been backtrackable for a period of time. */
12942 void
12944 {
12948 so nothing needed here. */
12950 {
12969 }
12970 #endif
12971 }
12973 /* Create temporary gcc label. */
12975 tree
12977 {
12978 tree glabel;
12983 mynumber++),
12984 void_type_node);
12989 }
12991 /* Return an expression that is usable as an arg in a conditional context
12992 (IF, DO WHILE, .NOT., and so on).
12994 Use the one provided for the back end as of >2.6.0. */
12996 tree
12998 {
13000 }
13002 /* Return the inversion of a truth value (the inversion of what
13003 ffecom_truth_value builds).
13005 Apparently invert_truthvalue, which is properly in the back end, is
13006 enough for now, so just use it. */
13008 tree
13010 {
13012 }
13014 /* Return the tree that is the type of the expression, as would be
13015 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13016 transforming the expression, generating temporaries, etc. */
13018 tree
13020 {
13021 ffeinfoBasictype bt;
13022 ffeinfoKindtype kt;
13023 tree tree_type;
13032 {
13075 /* Fall through. */
13078 }
13079 }
13081 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13083 If the PARM_DECL already exists, return it, else create it. It's an
13084 integer_type_node argument for the master function that implements a
13085 subroutine or function with more than one entrypoint and is bound at
13086 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13087 first ENTRY statement, and so on). */
13089 tree
13091 {
13095 }
13096 \f
13097 /* The following sections consists of private and public functions
13098 that have the same names and perform roughly the same functions
13099 as counterparts in the C front end. Changes in the C front end
13100 might affect how things should be done here. Only functions
13101 needed by the back end should be public here; the rest should
13102 be private (static in the C sense). Functions needed by other
13103 g77 front-end modules should be accessed by them via public
13104 ffecom_* names, which should themselves call private versions
13105 in this section so the private versions are easy to recognize
13106 when upgrading to a new gcc and finding interesting changes
13107 in the front end.
13109 Functions named after rule "foo:" in c-parse.y are named
13110 "bison_rule_foo_" so they are easy to find. */
13112 static void
13114 {
13119 }
13121 static tree
13123 {
13124 tree t;
13127 /* Make the temps go away. */
13136 }
13138 /* Return a definition for a builtin function named NAME and whose data type
13139 is TYPE. TYPE should be a function type with argument types.
13140 FUNCTION_CODE tells later passes how to compile calls to this function.
13141 See tree.h for its possible values.
13143 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13144 the name to be called if we can't opencode the function. If
13145 ATTRS is nonzero, use that for the function's attribute list. */
13147 tree
13150 tree attrs ATTRIBUTE_UNUSED)
13151 {
13163 }
13165 /* Handle when a new declaration NEWDECL
13166 has the same name as an old one OLDDECL
13167 in the same binding contour.
13168 Prints an error message if appropriate.
13170 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13171 Otherwise, return 0. */
13173 static int
13175 {
13189 /* New decl is completely inconsistent with the old one =>
13190 tell caller to replace the old one.
13191 This is always an error except in the case of shadowing a builtin. */
13195 /* For real parm decl following a forward decl,
13196 return 1 so old decl will be reused. */
13201 /* The new declaration is the same kind of object as the old one.
13202 The declarations may partially match. Print warnings if they don't
13203 match enough. Ultimately, copy most of the information from the new
13204 decl to the old one, and keep using the old one. */
13208 {
13209 /* A function declaration for a built-in function. */
13213 {
13214 /* Accept the return type of the new declaration if same modes. */
13219 {
13220 /* Function types may be shared, so we can't just modify
13221 the return type of olddecl's function type. */
13222 tree newtype
13229 }
13230 }
13233 }
13236 {
13237 /* A function declaration for a predeclared function
13238 that isn't actually built in. */
13242 {
13243 /* If the types don't match, preserve volatility indication.
13244 Later on, we will discard everything else about the
13245 default declaration. */
13247 }
13248 }
13250 /* Copy all the DECL_... slots specified in the new decl
13251 except for any that we copy here from the old type.
13253 Past this point, we don't change OLDTYPE and NEWTYPE
13254 even if we change the types of NEWDECL and OLDDECL. */
13257 {
13258 /* Merge the data types specified in the two decls. */
13264 /* Lay the type out, unless already done. */
13266 {
13273 }
13274 else
13275 {
13276 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13281 {
13284 }
13285 }
13287 /* Keep the old rtl since we can safely use it. */
13290 /* Merge the type qualifiers. */
13294 {
13298 }
13300 /* Keep source location of definition rather than declaration.
13301 Likewise, keep decl at outer scope. */
13304 {
13310 }
13312 /* Merge the unused-warning information. */
13318 /* Merge the initialization information. */
13322 /* Merge the section attribute.
13323 We want to issue an error if the sections conflict but that must be
13324 done later in decl_attributes since we are called before attributes
13325 are assigned. */
13329 /* Copy the assembler name. */
13333 {
13340 }
13341 }
13342 /* If cannot merge, then use the new type and qualifiers,
13343 and don't preserve the old rtl. */
13344 else
13345 {
13350 }
13352 /* Merge the storage class information. */
13353 /* For functions, static overrides non-static. */
13355 {
13357 /* This is since we don't automatically
13358 copy the attributes of NEWDECL into OLDDECL. */
13360 /* If this clears `static', clear it in the identifier too. */
13363 }
13365 {
13368 /* An extern decl does not override previous storage class. */
13370 }
13371 else
13372 {
13375 }
13377 /* If either decl says `inline', this fn is inline,
13378 unless its definition was passed already. */
13383 /* Get rid of any built-in function if new arg types don't match it
13384 or if we have a function definition. */
13388 {
13391 }
13393 /* If redeclaring a builtin function, and not a definition,
13394 it stays built in.
13395 Also preserve various other info from the definition. */
13397 {
13399 {
13402 }
13408 }
13410 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13411 But preserve olddecl's DECL_UID. */
13412 {
13419 }
13422 }
13424 /* Finish processing of a declaration;
13425 install its initial value.
13426 If the length of an array type is not known before,
13427 it must be determined now, from the initial value, or it is an error. */
13429 static void
13431 {
13437 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13438 level anyway. */
13443 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13444 overlaps DECL_ARG_TYPE. */
13447 else
13451 {
13454 else
13455 {
13456 /* typedef foo = bar; store the type of bar as the type of foo. */
13459 }
13460 }
13462 /* Deduce size of array from initialization, if not already known */
13467 {
13472 }
13475 {
13482 ?
13483 /* A static variable with an incomplete type is an error if it is
13484 initialized. Also if it is not file scope. Otherwise, let it
13485 through, but if it is not `extern' then it may cause an error
13486 message later. */
13488 :
13489 /* An automatic variable with an incomplete type is an error. */
13491 {
13494 }
13499 {
13502 }
13503 }
13505 /* Output the assembler code and/or RTL code for variables and functions,
13506 unless the type is an undefined structure or union. If not, it will get
13507 done when the type is completed. */
13510 {
13516 {
13517 /* Recompute the RTL of a local array now if it used to be an
13518 incomplete type. */
13521 {
13522 /* If we used it already as memory, it must stay in memory. */
13524 /* If it's still incomplete now, no init will save it. */
13528 }
13529 /* Compute and store the initial value. */
13532 }
13533 }
13535 {
13539 }
13541 /* At the end of a declaration, throw away any variable type sizes of types
13542 defined inside that declaration. There is no use computing them in the
13543 following function definition. */
13546 }
13548 /* Finish up a function declaration and compile that function
13549 all the way to assembler language output. The free the storage
13550 for the function definition.
13552 This is called after parsing the body of the function definition.
13554 NESTED is nonzero if the function being finished is nested in another. */
13556 static void
13558 {
13563 {
13566 else
13568 }
13570 /* TREE_READONLY (fndecl) = 1;
13571 This caused &foo to be of type ptr-to-const-function
13572 which then got a warning when stored in a ptr-to-function variable. */
13577 {
13580 /* Must mark the RESULT_DECL as being in this function. */
13584 /* Obey `register' declarations if `setjmp' is called in this fn. */
13585 /* Generate rtl for function exit. */
13588 /* If this is a nested function, protect the local variables in the stack
13589 above us from being collected while we're compiling this function. */
13593 /* Run the optimizers and output the assembler code for this function. */
13596 {
13599 }
13602 /* Undo the GC context switch. */
13605 }
13608 && !nested
13610 {
13611 /* Stop pointing to the local nodes about to be freed. */
13612 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13613 function definition. */
13614 /* For a nested function, this is done in pop_f_function_context. */
13615 /* If rest_of_compilation set this to 0, leave it 0. */
13619 }
13622 {
13623 /* Let the error reporting routines know that we're outside a function.
13624 For a nested function, this value is used in pop_c_function_context
13625 and then reset via pop_function_context. */
13627 }
13628 }
13630 /* Plug-in replacement for identifying the name of a decl and, for a
13631 function, what we call it in diagnostics. For now, "program unit"
13632 should suffice, since it's a bit of a hassle to figure out which
13633 of several kinds of things it is. Note that it could conceivably
13634 be a statement function, which probably isn't really a program unit
13635 per se, but if that comes up, it should be easy to check (being a
13636 nested function and all). */
13640 {
13641 /* Just to keep GCC quiet about the unused variable.
13642 In theory, differing values of V should produce different
13643 output. */
13645 {
13650 }
13651 }
13653 /* g77's function to print out name of current function that caused
13654 an error. */
13656 static void
13659 {
13662 ffeglobal g;
13663 ffesymbol s;
13668 {
13672 }
13673 else
13674 {
13677 {
13680 }
13681 else
13682 {
13685 }
13686 }
13689 {
13695 else
13696 {
13700 }
13704 }
13705 }
13707 /* Similar to `lookup_name' but look only at current binding level. */
13709 static tree
13711 {
13725 }
13727 /* Create a new `struct f_binding_level'. */
13731 {
13732 /* NOSTRICT */
13734 }
13736 /* Save and restore the variables in this file and elsewhere
13737 that keep track of the progress of compilation of the current function.
13738 Used for nested functions. */
13740 struct f_function
13741 {
13743 tree named_labels;
13744 tree shadowed_labels;
13746 };
13750 /* Restore the variables used during compilation of a C function. */
13752 static void
13754 {
13756 tree link;
13758 /* Bring back all the labels that were shadowed. */
13766 {
13767 /* Stop pointing to the local nodes about to be freed. */
13768 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13769 function definition. */
13772 }
13783 }
13785 /* Save and reinitialize the variables
13786 used during compilation of a C function. */
13788 static void
13790 {
13801 }
13803 static void
13805 {
13808 /* Don't try computing parm sizes now -- wait till fn is called. */
13812 /* Fill in arg stuff. */
13823 }
13825 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
13827 static tree
13829 {
13840 }
13842 /* Store the list of declarations of the current level.
13843 This is done for the parameter declarations of a function being defined,
13844 after they are modified in the light of any missing parameters. */
13846 static tree
13848 {
13850 }
13852 /* Store the parameter declarations into the current function declaration.
13853 This is called after parsing the parameter declarations, before
13854 digesting the body of the function.
13856 For an old-style definition, modify the function's type
13857 to specify at least the number of arguments. */
13859 static void
13861 {
13867 /* This is a chain of PARM_DECLs from old-style parm declarations. */
13870 /* Initialize the RTL code for the function. */
13873 /* Set up parameters and prepare for return, for the function. */
13875 }
13877 static tree
13879 {
13884 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13885 level anyway. */
13889 {
13892 }
13896 /* For Fortran, we by default put things in .common when possible. */
13899 /* Add this decl to the current binding level. TEM may equal DECL or it may
13900 be a previous decl of the same name. */
13903 else
13906 /* For a local variable, define the RTL now. */
13908 /* But not if this is a duplicate decl and we preserved the rtl from the
13909 previous one (which may or may not happen). */
13911 {
13917 }
13920 }
13922 /* Create the FUNCTION_DECL for a function definition.
13923 DECLSPECS and DECLARATOR are the parts of the declaration;
13924 they describe the function's name and the type it returns,
13925 but twisted together in a fashion that parallels the syntax of C.
13927 This function creates a binding context for the function body
13928 as well as setting up the FUNCTION_DECL in current_function_decl.
13930 Returns 1 on success. If the DECLARATOR is not suitable for a function
13931 (it defines a datum instead), we return 0, which tells
13932 ffe_parse_file to report a parse error.
13934 NESTED is nonzero for a function nested within another function. */
13936 static void
13938 {
13939 tree decl1;
13940 tree restype;
13946 /* Don't expand any sizes in the return type of the function. */
13950 {
13954 }
13955 else
13956 {
13958 }
13962 else
13963 {
13965 name,
13966 type);
13975 /* Make the init_value nonzero so pushdecl knows this is not tentative.
13976 error_mark_node is replaced below (in poplevel) with the BLOCK. */
13979 /* Record the decl so that the function name is defined. If we already have
13980 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
13983 }
13992 {
13998 }
14004 }
14005 \f
14006 /* Here are the public functions the GNU back end needs. */
14008 tree
14010 {
14023 {
14026 }
14032 e);
14046 }
14048 /* Return the list of declarations of the current level.
14049 Note that this list is in reverse order unless/until
14050 you nreverse it; and when you do nreverse it, you must
14051 store the result back using `storedecls' or you will lose. */
14053 tree
14055 {
14057 }
14059 /* Nonzero if we are currently in the global binding level. */
14061 int
14063 {
14065 }
14067 static void
14069 {
14073 }
14075 /* Delete the node BLOCK from the current binding level.
14076 This is used for the block inside a stmt expr ({...})
14077 so that the block can be reinserted where appropriate. */
14079 static void
14081 {
14082 tree t;
14086 {
14089 else
14091 }
14093 /* Clear TREE_USED which is always set by poplevel.
14094 The flag is set again if insert_block is called. */
14096 }
14098 void
14100 {
14102 current_binding_level->blocks
14104 }
14106 /* Each front end provides its own. */
14113 {
14115 };
14117 #undef LANG_HOOKS_NAME
14119 #undef LANG_HOOKS_INIT
14120 #define LANG_HOOKS_INIT ffe_init
14121 #undef LANG_HOOKS_FINISH
14122 #define LANG_HOOKS_FINISH ffe_finish
14123 #undef LANG_HOOKS_INIT_OPTIONS
14124 #define LANG_HOOKS_INIT_OPTIONS ffe_init_options
14125 #undef LANG_HOOKS_HANDLE_OPTION
14126 #define LANG_HOOKS_HANDLE_OPTION ffe_handle_option
14127 #undef LANG_HOOKS_POST_OPTIONS
14128 #define LANG_HOOKS_POST_OPTIONS ffe_post_options
14129 #undef LANG_HOOKS_PARSE_FILE
14130 #define LANG_HOOKS_PARSE_FILE ffe_parse_file
14131 #undef LANG_HOOKS_MARK_ADDRESSABLE
14132 #define LANG_HOOKS_MARK_ADDRESSABLE ffe_mark_addressable
14133 #undef LANG_HOOKS_PRINT_IDENTIFIER
14134 #define LANG_HOOKS_PRINT_IDENTIFIER ffe_print_identifier
14135 #undef LANG_HOOKS_DECL_PRINTABLE_NAME
14136 #define LANG_HOOKS_DECL_PRINTABLE_NAME ffe_printable_name
14137 #undef LANG_HOOKS_PRINT_ERROR_FUNCTION
14138 #define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function
14139 #undef LANG_HOOKS_TRUTHVALUE_CONVERSION
14140 #define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion
14142 #undef LANG_HOOKS_TYPE_FOR_MODE
14143 #define LANG_HOOKS_TYPE_FOR_MODE ffe_type_for_mode
14144 #undef LANG_HOOKS_TYPE_FOR_SIZE
14145 #define LANG_HOOKS_TYPE_FOR_SIZE ffe_type_for_size
14146 #undef LANG_HOOKS_SIGNED_TYPE
14147 #define LANG_HOOKS_SIGNED_TYPE ffe_signed_type
14148 #undef LANG_HOOKS_UNSIGNED_TYPE
14149 #define LANG_HOOKS_UNSIGNED_TYPE ffe_unsigned_type
14150 #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
14151 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type
14153 /* We do not wish to use alias-set based aliasing at all. Used in the
14154 extreme (every object with its own set, with equivalences recorded) it
14155 might be helpful, but there are problems when it comes to inlining. We
14156 get on ok with flag_argument_noalias, and alias-set aliasing does
14157 currently limit how stack slots can be reused, which is a lose. */
14158 #undef LANG_HOOKS_GET_ALIAS_SET
14159 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14163 /* Table indexed by tree code giving a string containing a character
14164 classifying the tree code. Possibilities are
14165 t, d, s, c, r, <, 1, 2 and e. See tree.def for details. */
14167 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14171 };
14172 #undef DEFTREECODE
14174 /* Table indexed by tree code giving number of expression
14175 operands beyond the fixed part of the node structure.
14176 Not used for types or decls. */
14178 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14182 };
14183 #undef DEFTREECODE
14185 /* Names of tree components.
14186 Used for printing out the tree and error messages. */
14187 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14191 };
14192 #undef DEFTREECODE
14194 static bool
14196 {
14199 /* Open input file. */
14201 {
14204 }
14205 else
14212 }
14215 static bool
14217 {
14218 #ifdef IO_BUFFER_SIZE
14220 #endif
14224 /* If the file is output from cpp, it should contain a first line
14225 `# 1 "real-filename"', and the current design of gcc (toplev.c
14226 in particular and the way it sets up information relied on by
14227 INCLUDE) requires that we read this now, and store the
14228 "real-filename" info in master_input_filename. Ask the lexer
14229 to try doing this. */
14234 /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14235 set the new file name. Maybe in ffe_post_options. */
14237 }
14239 static void
14241 {
14248 }
14250 static bool
14252 {
14256 {
14273 {
14275 {
14278 }
14280 }
14282 {
14284 {
14287 }
14289 }
14292 /* drops in */
14298 #endif
14302 }
14303 }
14305 /* Exit a binding level.
14306 Pop the level off, and restore the state of the identifier-decl mappings
14307 that were in effect when this level was entered.
14309 If KEEP is nonzero, this level had explicit declarations, so
14310 and create a "block" (a BLOCK node) for the level
14311 to record its declarations and subblocks for symbol table output.
14313 If FUNCTIONBODY is nonzero, this level is the body of a function,
14314 so create a block as if KEEP were set and also clear out all
14315 label names.
14317 If REVERSE is nonzero, reverse the order of decls before putting
14318 them into the BLOCK. */
14320 tree
14322 {
14324 /* The chain of decls was accumulated in reverse order.
14325 Put it into forward order, just for cleanliness. */
14326 tree decls;
14329 tree decl;
14332 /* Get the decls in the order they were written.
14333 Usually current_binding_level->names is in reverse order.
14334 But parameter decls were previously put in forward order. */
14337 current_binding_level->names
14339 else
14342 /* Output any nested inline functions within this block
14343 if they weren't already output. */
14350 {
14351 /* If this decl was copied from a file-scope decl
14352 on account of a block-scope extern decl,
14353 propagate TREE_ADDRESSABLE to the file-scope decl.
14355 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14356 true, since then the decl goes through save_for_inline_copying. */
14361 {
14365 }
14366 }
14368 /* If there were any declarations or structure tags in that level,
14369 or if this level is a function body,
14370 create a BLOCK to record them for the life of this function. */
14379 {
14382 }
14384 /* In each subblock, record that this is its superior. */
14389 /* Clear out the meanings of the local variables of this level. */
14392 {
14394 {
14395 /* If the ident. was used or addressed via a local extern decl,
14396 don't forget that fact. */
14398 {
14403 }
14405 }
14406 }
14408 /* If the level being exited is the top level of a function,
14409 check over all the labels, and clear out the current
14410 (function local) meanings of their names. */
14413 {
14414 /* If this is the top level block of a function,
14415 the vars are the function's parameters.
14416 Don't leave them in the BLOCK because they are
14417 found in the FUNCTION_DECL instead. */
14420 }
14422 /* Pop the current level, and free the structure for reuse. */
14424 {
14430 }
14432 /* Dispose of the block that we just made inside some higher level. */
14437 {
14439 current_binding_level->blocks
14441 }
14442 /* If we did not make a block for the level just exited,
14443 any blocks made for inner levels
14444 (since they cannot be recorded as subblocks in that level)
14445 must be carried forward so they will later become subblocks
14446 of something else. */
14448 current_binding_level->blocks
14454 }
14456 static void
14458 {
14461 }
14463 /* Record a decl-node X as belonging to the current lexical scope.
14464 Check for errors (such as an incompatible declaration for the same
14465 name already seen in the same scope).
14467 Returns either X or an old decl for the same name.
14468 If an old decl is returned, it may have been smashed
14469 to agree with what X says. */
14471 tree
14473 {
14482 else
14486 {
14488 {
14491 }
14497 /* Don't push non-parms onto list for parms until we understand
14498 why we're doing this and whether it works. */
14501 || !ffecom_transform_only_dummies_
14507 /* If we are processing a typedef statement, generate a whole new
14508 ..._TYPE node (which will be just an variant of the existing
14509 ..._TYPE node with identical properties) and then install the
14510 TYPE_DECL node generated to represent the typedef name as the
14511 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14513 The whole point here is to end up with a situation where each and every
14514 ..._TYPE node the compiler creates will be uniquely associated with
14515 AT MOST one node representing a typedef name. This way, even though
14516 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14517 (i.e. "typedef name") nodes very early on, later parts of the
14518 compiler can always do the reverse translation and get back the
14519 corresponding typedef name. For example, given:
14521 typedef struct S MY_TYPE; MY_TYPE object;
14523 Later parts of the compiler might only know that `object' was of type
14524 `struct S' if it were not for code just below. With this code
14525 however, later parts of the compiler see something like:
14527 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14529 And they can then deduce (from the node for type struct S') that the
14530 original object declaration was:
14532 MY_TYPE object;
14534 Being able to do this is important for proper support of protoize, and
14535 also for generating precise symbolic debugging information which
14536 takes full account of the programmer's (typedef) vocabulary.
14538 Obviously, we don't want to generate a duplicate ..._TYPE node if the
14539 TYPE_DECL node that we are now processing really represents a
14540 standard built-in type.
14542 Since all standard types are effectively declared at line zero in the
14543 source file, we can easily check to see if we are working on a
14544 standard type by checking the current value of lineno. */
14547 {
14549 {
14552 }
14554 {
14560 }
14561 }
14563 /* This name is new in its binding level. Install the new declaration
14564 and return it. */
14567 else
14569 }
14571 /* Put decls on list in reverse order. We will reverse them later if
14572 necessary. */
14577 }
14579 /* Nonzero if the current level needs to have a BLOCK made. */
14581 static int
14583 {
14584 tree decl;
14587 decl;
14589 {
14592 /* Currently, there aren't supposed to be non-artificial names
14593 at other than the top block for a function -- they're
14594 believed to always be temps. But it's wise to check anyway. */
14596 }
14598 }
14600 /* Enter a new binding level.
14601 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14602 not for that of tags. */
14604 void
14606 {
14612 {
14614 }
14616 /* Reuse or create a struct for this binding level. */
14619 {
14622 }
14623 else
14624 {
14626 }
14628 /* Add this level to the front of the chain (stack) of levels that
14629 are active. */
14634 }
14636 /* Set the BLOCK node for the innermost scope
14637 (the one we are currently in). */
14639 void
14641 {
14647 }
14649 static tree
14651 {
14652 tree type2;
14673 }
14675 static tree
14677 {
14679 ffeinfoKindtype kt;
14680 tree type2;
14701 #endif
14708 {
14713 }
14716 }
14718 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14719 or validate its data type for an `if' or `while' statement or ?..: exp.
14721 This preparation consists of taking the ordinary
14722 representation of an expression expr and producing a valid tree
14723 boolean expression describing whether expr is nonzero. We could
14724 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14725 but we optimize comparisons, &&, ||, and !.
14727 The resulting type should always be `integer_type_node'. */
14729 static tree
14731 {
14736 /* These really should return error_mark_node after 2.4 is stable.
14737 But not all callers handle ERROR_MARK properly. */
14739 {
14754 }
14758 {
14759 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14760 or comparison expressions as truth values at this level. */
14761 #if 0
14763 /* A one-bit unsigned bit-field is already acceptable. */
14768 #endif
14771 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14772 or comparison expressions as truth values at this level. */
14773 #if 0
14776 #endif
14799 else
14805 integer_type_node,
14812 /* These don't change whether an object is nonzero or zero. */
14817 /* These don't change whether an object is zero or nonzero, but
14818 we can't ignore them if their second arg has side-effects. */
14822 else
14826 {
14827 /* Distribute the conversion into the arms of a COND_EXPR. */
14836 }
14839 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14840 since that affects how `default_conversion' will behave. */
14844 /* fall through... */
14846 /* If this is widening the argument, we can ignore it. */
14853 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14854 this case. */
14858 /* fall through... */
14860 /* This and MINUS_EXPR can be changed into a comparison of the
14861 two objects. */
14882 #endif
14887 }
14893 integer_type_node,
14896 expr)),
14899 expr))));
14902 expr,
14904 }
14906 static tree
14908 {
14911 tree t;
14928 #if HOST_BITS_PER_WIDE_INT >= 64
14931 #endif
14950 {
14953 {
14956 else
14958 }
14959 }
14962 }
14964 static tree
14966 {
14967 ffeinfoKindtype kt;
14968 tree type_node;
14987 {
14993 }
14996 }
14998 static tree
15000 {
15002 ffeinfoKindtype kt;
15003 tree type2;
15024 #endif
15031 {
15036 }
15039 }
15040 \f
15041 /* From gcc/cccp.c, the code to handle -I. */
15043 /* Skip leading "./" from a directory name.
15044 This may yield the empty string, which represents the current directory. */
15048 {
15053 dir++;
15055 }
15057 /* The file_name_map structure holds a mapping of file names for a
15058 particular directory. This mapping is read from the file named
15059 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15060 map filenames on a file system with severe filename restrictions,
15061 such as DOS. The format of the file name map file is just a series
15062 of lines with two tokens on each line. The first token is the name
15063 to map, and the second token is the actual name to use. */
15065 struct file_name_map
15066 {
15070 };
15074 /* Current maximum length of directory names in the search path
15075 for include files. (Altered as we get more of them.) */
15079 struct file_name_list
15080 {
15083 /* Mapping of file names for this directory. */
15085 /* Nonzero if name_map is valid. */
15087 };
15092 /* I/O buffer structure.
15093 The `fname' field is nonzero for source files and #include files
15094 and for the dummy text used for -D and -U.
15095 It is zero for rescanning results of macro expansion
15096 and for expanding macro arguments. */
15097 #define INPUT_STACK_MAX 400
15100 /* Filename specified with #line command. */
15102 /* Record where in the search path this file was found.
15103 For #include_next. */
15105 ffewhereLine line;
15106 ffewhereColumn column;
15111 /* Current nesting level of input sources.
15112 `instack[indepth]' is the level currently being read. */
15117 /* Nonzero means -I- has been seen,
15118 so don't look for #include "foo" the source-file directory. */
15121 #ifndef INCLUDE_LEN_FUDGE
15122 #define INCLUDE_LEN_FUDGE 0
15123 #endif
15133 /* Append a chain of `struct file_name_list's
15134 to the end of the main include chain.
15135 FIRST is the beginning of the chain to append, and LAST is the end. */
15137 static void
15140 {
15148 else
15157 }
15161 }
15163 /* Try to open include file FILENAME. SEARCHPTR is the directory
15164 being tried from the include file search path. This function maps
15165 filenames on file systems based on information read by
15166 read_name_map. */
15170 {
15176 {
15180 }
15182 /* First check the mapping for the directory we are using. */
15184 {
15189 {
15191 {
15192 /* Found a match. */
15194 }
15195 }
15196 }
15198 /* Try to find a mapping file for the particular directory we are
15199 looking in. Thus #include <sys/types.h> will look up sys/types.h
15200 in /usr/include/header.gcc and look up types.h in
15201 /usr/include/sys/header.gcc. */
15203 #ifdef DIR_SEPARATOR
15208 }
15209 #endif
15216 {
15217 /* FILENAME is in SEARCHPTR, which we've already checked. */
15219 }
15222 {
15225 }
15226 else
15227 {
15234 }
15240 }
15242 /* Print the file names and line numbers of the #include
15243 commands which led to the current file. */
15245 static void
15247 {
15254 /* If stack of files hasn't changed since we last printed
15255 this info, don't repeat it. */
15263 }
15265 /* Give up if we don't find a source file. */
15269 /* Find the other, outer source files. */
15272 {
15275 {
15278 }
15279 else
15280 {
15282 }
15286 else
15289 /* xgettext:no-c-format */
15296 }
15298 /* Record we have printed the status as of this time. */
15300 }
15302 /* Read a space delimited string of unlimited length from a stdio
15303 file. */
15307 {
15314 {
15317 {
15319 {
15323 }
15325 }
15326 }
15330 }
15332 /* Read the file name map file for DIRNAME. */
15336 {
15337 /* This structure holds a linked list of file name maps, one per
15338 directory. */
15339 struct file_name_map_list
15340 {
15344 };
15367 else
15373 else
15374 {
15378 {
15386 ;
15392 /* Make the real filename absolute. */
15395 else
15396 {
15399 else
15402 }
15410 }
15412 }
15418 }
15420 static void
15422 {
15425 /* Do partial setup of input buffer for the sake of generating
15426 early #line directives (when -g is in effect). */
15433 }
15435 static void
15437 {
15440 indepth--;
15441 input_file_stack_tick++;
15445 }
15447 void
15449 {
15452 else
15453 {
15460 }
15461 }
15463 /* Open INCLUDEd file. */
15467 {
15482 /* If -I- was specified, don't search current dir, only spec'd ones. */
15484 {
15486 {
15492 {
15493 /* Found a named file. Figure out dir of the file,
15494 and put it in front of the search list. */
15497 #ifndef VMS
15499 #ifdef DIR_SEPARATOR
15504 }
15505 #endif
15513 {
15521 }
15522 else
15526 }
15527 }
15528 }
15530 /* Allocate this permanently, because it gets stored in the definitions
15531 of macros. */
15533 /* + 2 above for slash and terminating null. */
15534 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15535 for g77 yet). */
15537 /* If specified file name is absolute, just open it. */
15540 #ifdef DIR_SEPARATOR
15542 #endif
15543 )
15544 {
15548 }
15549 else
15550 {
15553 /* Search directory path, trying to open the file.
15554 Copy each filename tried into FNAME. */
15557 {
15559 {
15560 /* The empty string in a search path is ignored.
15561 This makes it possible to turn off entirely
15562 a standard piece of the list. */
15569 }
15570 else
15574 #ifdef VMS
15575 /* Change this 1/2 Unix 1/2 VMS file specification into a
15576 full VMS file specification */
15578 {
15579 /* Fix up the filename */
15581 }
15582 else
15583 {
15584 /* This is a normal VMS filespec, so use it unchanged. */
15588 /* if it's '#include filename', add the missing .h */
15591 #endif
15592 }
15595 #ifdef EACCES
15597 {
15599 /* xgettext:no-c-format */
15601 FFEBAD_severityWARNING);
15605 }
15606 #endif
15609 }
15610 }
15613 {
15614 /* A file that was not found. */
15623 }
15632 {
15634 /* xgettext:no-c-format */
15636 FFEBAD_severityFATAL);
15641 }
15651 indepth++;
15652 input_file_stack_tick++;
15655 }
15657 /**INDENT* (Do not reformat this comment even with -fca option.)
15658 Data-gathering files: Given the source file listed below, compiled with
15659 f2c I obtained the output file listed after that, and from the output
15660 file I derived the above code.
15662 -------- (begin input file to f2c)
15663 implicit none
15664 character*10 A1,A2
15665 complex C1,C2
15666 integer I1,I2
15667 real R1,R2
15668 double precision D1,D2
15669 C
15670 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15671 c /
15672 call fooI(I1/I2)
15673 call fooR(R1/I1)
15674 call fooD(D1/I1)
15675 call fooC(C1/I1)
15676 call fooR(R1/R2)
15677 call fooD(R1/D1)
15678 call fooD(D1/D2)
15679 call fooD(D1/R1)
15680 call fooC(C1/C2)
15681 call fooC(C1/R1)
15682 call fooZ(C1/D1)
15683 c **
15684 call fooI(I1**I2)
15685 call fooR(R1**I1)
15686 call fooD(D1**I1)
15687 call fooC(C1**I1)
15688 call fooR(R1**R2)
15689 call fooD(R1**D1)
15690 call fooD(D1**D2)
15691 call fooD(D1**R1)
15692 call fooC(C1**C2)
15693 call fooC(C1**R1)
15694 call fooZ(C1**D1)
15695 c FFEINTRIN_impABS
15696 call fooR(ABS(R1))
15697 c FFEINTRIN_impACOS
15698 call fooR(ACOS(R1))
15699 c FFEINTRIN_impAIMAG
15700 call fooR(AIMAG(C1))
15701 c FFEINTRIN_impAINT
15702 call fooR(AINT(R1))
15703 c FFEINTRIN_impALOG
15704 call fooR(ALOG(R1))
15705 c FFEINTRIN_impALOG10
15706 call fooR(ALOG10(R1))
15707 c FFEINTRIN_impAMAX0
15708 call fooR(AMAX0(I1,I2))
15709 c FFEINTRIN_impAMAX1
15710 call fooR(AMAX1(R1,R2))
15711 c FFEINTRIN_impAMIN0
15712 call fooR(AMIN0(I1,I2))
15713 c FFEINTRIN_impAMIN1
15714 call fooR(AMIN1(R1,R2))
15715 c FFEINTRIN_impAMOD
15716 call fooR(AMOD(R1,R2))
15717 c FFEINTRIN_impANINT
15718 call fooR(ANINT(R1))
15719 c FFEINTRIN_impASIN
15720 call fooR(ASIN(R1))
15721 c FFEINTRIN_impATAN
15722 call fooR(ATAN(R1))
15723 c FFEINTRIN_impATAN2
15724 call fooR(ATAN2(R1,R2))
15725 c FFEINTRIN_impCABS
15726 call fooR(CABS(C1))
15727 c FFEINTRIN_impCCOS
15728 call fooC(CCOS(C1))
15729 c FFEINTRIN_impCEXP
15730 call fooC(CEXP(C1))
15731 c FFEINTRIN_impCHAR
15732 call fooA(CHAR(I1))
15733 c FFEINTRIN_impCLOG
15734 call fooC(CLOG(C1))
15735 c FFEINTRIN_impCONJG
15736 call fooC(CONJG(C1))
15737 c FFEINTRIN_impCOS
15738 call fooR(COS(R1))
15739 c FFEINTRIN_impCOSH
15740 call fooR(COSH(R1))
15741 c FFEINTRIN_impCSIN
15742 call fooC(CSIN(C1))
15743 c FFEINTRIN_impCSQRT
15744 call fooC(CSQRT(C1))
15745 c FFEINTRIN_impDABS
15746 call fooD(DABS(D1))
15747 c FFEINTRIN_impDACOS
15748 call fooD(DACOS(D1))
15749 c FFEINTRIN_impDASIN
15750 call fooD(DASIN(D1))
15751 c FFEINTRIN_impDATAN
15752 call fooD(DATAN(D1))
15753 c FFEINTRIN_impDATAN2
15754 call fooD(DATAN2(D1,D2))
15755 c FFEINTRIN_impDCOS
15756 call fooD(DCOS(D1))
15757 c FFEINTRIN_impDCOSH
15758 call fooD(DCOSH(D1))
15759 c FFEINTRIN_impDDIM
15760 call fooD(DDIM(D1,D2))
15761 c FFEINTRIN_impDEXP
15762 call fooD(DEXP(D1))
15763 c FFEINTRIN_impDIM
15764 call fooR(DIM(R1,R2))
15765 c FFEINTRIN_impDINT
15766 call fooD(DINT(D1))
15767 c FFEINTRIN_impDLOG
15768 call fooD(DLOG(D1))
15769 c FFEINTRIN_impDLOG10
15770 call fooD(DLOG10(D1))
15771 c FFEINTRIN_impDMAX1
15772 call fooD(DMAX1(D1,D2))
15773 c FFEINTRIN_impDMIN1
15774 call fooD(DMIN1(D1,D2))
15775 c FFEINTRIN_impDMOD
15776 call fooD(DMOD(D1,D2))
15777 c FFEINTRIN_impDNINT
15778 call fooD(DNINT(D1))
15779 c FFEINTRIN_impDPROD
15780 call fooD(DPROD(R1,R2))
15781 c FFEINTRIN_impDSIGN
15782 call fooD(DSIGN(D1,D2))
15783 c FFEINTRIN_impDSIN
15784 call fooD(DSIN(D1))
15785 c FFEINTRIN_impDSINH
15786 call fooD(DSINH(D1))
15787 c FFEINTRIN_impDSQRT
15788 call fooD(DSQRT(D1))
15789 c FFEINTRIN_impDTAN
15790 call fooD(DTAN(D1))
15791 c FFEINTRIN_impDTANH
15792 call fooD(DTANH(D1))
15793 c FFEINTRIN_impEXP
15794 call fooR(EXP(R1))
15795 c FFEINTRIN_impIABS
15796 call fooI(IABS(I1))
15797 c FFEINTRIN_impICHAR
15798 call fooI(ICHAR(A1))
15799 c FFEINTRIN_impIDIM
15800 call fooI(IDIM(I1,I2))
15801 c FFEINTRIN_impIDNINT
15802 call fooI(IDNINT(D1))
15803 c FFEINTRIN_impINDEX
15804 call fooI(INDEX(A1,A2))
15805 c FFEINTRIN_impISIGN
15806 call fooI(ISIGN(I1,I2))
15807 c FFEINTRIN_impLEN
15808 call fooI(LEN(A1))
15809 c FFEINTRIN_impLGE
15810 call fooL(LGE(A1,A2))
15811 c FFEINTRIN_impLGT
15812 call fooL(LGT(A1,A2))
15813 c FFEINTRIN_impLLE
15814 call fooL(LLE(A1,A2))
15815 c FFEINTRIN_impLLT
15816 call fooL(LLT(A1,A2))
15817 c FFEINTRIN_impMAX0
15818 call fooI(MAX0(I1,I2))
15819 c FFEINTRIN_impMAX1
15820 call fooI(MAX1(R1,R2))
15821 c FFEINTRIN_impMIN0
15822 call fooI(MIN0(I1,I2))
15823 c FFEINTRIN_impMIN1
15824 call fooI(MIN1(R1,R2))
15825 c FFEINTRIN_impMOD
15826 call fooI(MOD(I1,I2))
15827 c FFEINTRIN_impNINT
15828 call fooI(NINT(R1))
15829 c FFEINTRIN_impSIGN
15830 call fooR(SIGN(R1,R2))
15831 c FFEINTRIN_impSIN
15832 call fooR(SIN(R1))
15833 c FFEINTRIN_impSINH
15834 call fooR(SINH(R1))
15835 c FFEINTRIN_impSQRT
15836 call fooR(SQRT(R1))
15837 c FFEINTRIN_impTAN
15838 call fooR(TAN(R1))
15839 c FFEINTRIN_impTANH
15840 call fooR(TANH(R1))
15841 c FFEINTRIN_imp_CMPLX_C
15842 call fooC(cmplx(C1,C2))
15843 c FFEINTRIN_imp_CMPLX_D
15844 call fooZ(cmplx(D1,D2))
15845 c FFEINTRIN_imp_CMPLX_I
15846 call fooC(cmplx(I1,I2))
15847 c FFEINTRIN_imp_CMPLX_R
15848 call fooC(cmplx(R1,R2))
15849 c FFEINTRIN_imp_DBLE_C
15850 call fooD(dble(C1))
15851 c FFEINTRIN_imp_DBLE_D
15852 call fooD(dble(D1))
15853 c FFEINTRIN_imp_DBLE_I
15854 call fooD(dble(I1))
15855 c FFEINTRIN_imp_DBLE_R
15856 call fooD(dble(R1))
15857 c FFEINTRIN_imp_INT_C
15858 call fooI(int(C1))
15859 c FFEINTRIN_imp_INT_D
15860 call fooI(int(D1))
15861 c FFEINTRIN_imp_INT_I
15862 call fooI(int(I1))
15863 c FFEINTRIN_imp_INT_R
15864 call fooI(int(R1))
15865 c FFEINTRIN_imp_REAL_C
15866 call fooR(real(C1))
15867 c FFEINTRIN_imp_REAL_D
15868 call fooR(real(D1))
15869 c FFEINTRIN_imp_REAL_I
15870 call fooR(real(I1))
15871 c FFEINTRIN_imp_REAL_R
15872 call fooR(real(R1))
15873 c
15874 c FFEINTRIN_imp_INT_D:
15875 c
15876 c FFEINTRIN_specIDINT
15877 call fooI(IDINT(D1))
15878 c
15879 c FFEINTRIN_imp_INT_R:
15880 c
15881 c FFEINTRIN_specIFIX
15882 call fooI(IFIX(R1))
15883 c FFEINTRIN_specINT
15884 call fooI(INT(R1))
15885 c
15886 c FFEINTRIN_imp_REAL_D:
15887 c
15888 c FFEINTRIN_specSNGL
15889 call fooR(SNGL(D1))
15890 c
15891 c FFEINTRIN_imp_REAL_I:
15892 c
15893 c FFEINTRIN_specFLOAT
15894 call fooR(FLOAT(I1))
15895 c FFEINTRIN_specREAL
15896 call fooR(REAL(I1))
15897 c
15898 end
15899 -------- (end input file to f2c)
15901 -------- (begin output from providing above input file as input to:
15902 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
15903 -------- -e "s:^#.*$::g"')
15905 // -- translated by f2c (version 19950223).
15906 You must link the resulting object file with the libraries:
15907 -lf2c -lm (in that order)
15908 //
15911 // f2c.h -- Standard Fortran to C header file //
15913 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
15915 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
15920 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
15921 // we assume short, float are OK //
15922 typedef long int // long int // integer;
15923 typedef char *address;
15924 typedef short int shortint;
15925 typedef float real;
15926 typedef double doublereal;
15927 typedef struct { real r, i; } complex;
15928 typedef struct { doublereal r, i; } doublecomplex;
15929 typedef long int // long int // logical;
15930 typedef short int shortlogical;
15931 typedef char logical1;
15932 typedef char integer1;
15933 // typedef long long longint; // // system-dependent //
15938 // Extern is for use with -E //
15943 // I/O stuff //
15952 typedef long int // int or long int // flag;
15953 typedef long int // int or long int // ftnlen;
15954 typedef long int // int or long int // ftnint;
15957 //external read, write//
15958 typedef struct
15959 { flag cierr;
15960 ftnint ciunit;
15961 flag ciend;
15962 char *cifmt;
15963 ftnint cirec;
15964 } cilist;
15966 //internal read, write//
15967 typedef struct
15968 { flag icierr;
15969 char *iciunit;
15970 flag iciend;
15971 char *icifmt;
15972 ftnint icirlen;
15973 ftnint icirnum;
15974 } icilist;
15976 //open//
15977 typedef struct
15978 { flag oerr;
15979 ftnint ounit;
15980 char *ofnm;
15981 ftnlen ofnmlen;
15982 char *osta;
15983 char *oacc;
15984 char *ofm;
15985 ftnint orl;
15986 char *oblnk;
15987 } olist;
15989 //close//
15990 typedef struct
15991 { flag cerr;
15992 ftnint cunit;
15993 char *csta;
15994 } cllist;
15996 //rewind, backspace, endfile//
15997 typedef struct
15998 { flag aerr;
15999 ftnint aunit;
16000 } alist;
16002 // inquire //
16003 typedef struct
16004 { flag inerr;
16005 ftnint inunit;
16006 char *infile;
16007 ftnlen infilen;
16008 ftnint *inex; //parameters in standard's order//
16009 ftnint *inopen;
16010 ftnint *innum;
16011 ftnint *innamed;
16012 char *inname;
16013 ftnlen innamlen;
16014 char *inacc;
16015 ftnlen inacclen;
16016 char *inseq;
16017 ftnlen inseqlen;
16018 char *indir;
16019 ftnlen indirlen;
16020 char *infmt;
16021 ftnlen infmtlen;
16022 char *inform;
16023 ftnint informlen;
16024 char *inunf;
16025 ftnlen inunflen;
16026 ftnint *inrecl;
16027 ftnint *innrec;
16028 char *inblank;
16029 ftnlen inblanklen;
16030 } inlist;
16034 union Multitype { // for multiple entry points //
16035 integer1 g;
16036 shortint h;
16037 integer i;
16038 // longint j; //
16039 real r;
16040 doublereal d;
16041 complex c;
16042 doublecomplex z;
16043 };
16045 typedef union Multitype Multitype;
16047 typedef long Long; // No longer used; formerly in Namelist //
16049 struct Vardesc { // for Namelist //
16050 char *name;
16051 char *addr;
16052 ftnlen *dims;
16053 int type;
16054 };
16055 typedef struct Vardesc Vardesc;
16057 struct Namelist {
16058 char *name;
16059 Vardesc **vars;
16060 int nvars;
16061 };
16062 typedef struct Namelist Namelist;
16071 // procedure parameter types for -A and -C++ //
16076 typedef int // Unknown procedure type // (*U_fp)();
16077 typedef shortint (*J_fp)();
16078 typedef integer (*I_fp)();
16079 typedef real (*R_fp)();
16080 typedef doublereal (*D_fp)(), (*E_fp)();
16081 typedef // Complex // void (*C_fp)();
16082 typedef // Double Complex // void (*Z_fp)();
16083 typedef logical (*L_fp)();
16084 typedef shortlogical (*K_fp)();
16085 typedef // Character // void (*H_fp)();
16086 typedef // Subroutine // int (*S_fp)();
16088 // E_fp is for real functions when -R is not specified //
16089 typedef void C_f; // complex function //
16090 typedef void H_f; // character function //
16091 typedef void Z_f; // double complex function //
16092 typedef doublereal E_f; // real function with -R not specified //
16094 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16097 // (No such symbols should be defined in a strict ANSI C compiler.
16098 We can avoid trouble with f2c-translated code by using
16099 gcc -ansi.) //
16123 // Main program // MAIN__()
16124 {
16125 // System generated locals //
16126 integer i__1;
16127 real r__1, r__2;
16128 doublereal d__1, d__2;
16129 complex q__1;
16130 doublecomplex z__1, z__2, z__3;
16131 logical L__1;
16132 char ch__1[1];
16134 // Builtin functions //
16135 void c_div();
16136 integer pow_ii();
16137 double pow_ri(), pow_di();
16138 void pow_ci();
16139 double pow_dd();
16140 void pow_zz();
16141 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16142 asin(), atan(), atan2(), c_abs();
16143 void c_cos(), c_exp(), c_log(), r_cnjg();
16144 double cos(), cosh();
16145 void c_sin(), c_sqrt();
16146 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16147 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16148 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16149 logical l_ge(), l_gt(), l_le(), l_lt();
16150 integer i_nint();
16151 double r_sign();
16153 // Local variables //
16154 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16155 fool_(), fooz_(), getem_();
16156 static char a1[10], a2[10];
16157 static complex c1, c2;
16158 static doublereal d1, d2;
16159 static integer i1, i2;
16160 static real r1, r2;
16163 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16164 // / //
16165 i__1 = i1 / i2;
16166 fooi_(&i__1);
16167 r__1 = r1 / i1;
16168 foor_(&r__1);
16169 d__1 = d1 / i1;
16170 food_(&d__1);
16171 d__1 = (doublereal) i1;
16172 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16173 fooc_(&q__1);
16174 r__1 = r1 / r2;
16175 foor_(&r__1);
16176 d__1 = r1 / d1;
16177 food_(&d__1);
16178 d__1 = d1 / d2;
16179 food_(&d__1);
16180 d__1 = d1 / r1;
16181 food_(&d__1);
16182 c_div(&q__1, &c1, &c2);
16183 fooc_(&q__1);
16184 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16185 fooc_(&q__1);
16186 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16187 fooz_(&z__1);
16188 // ** //
16189 i__1 = pow_ii(&i1, &i2);
16190 fooi_(&i__1);
16191 r__1 = pow_ri(&r1, &i1);
16192 foor_(&r__1);
16193 d__1 = pow_di(&d1, &i1);
16194 food_(&d__1);
16195 pow_ci(&q__1, &c1, &i1);
16196 fooc_(&q__1);
16197 d__1 = (doublereal) r1;
16198 d__2 = (doublereal) r2;
16199 r__1 = pow_dd(&d__1, &d__2);
16200 foor_(&r__1);
16201 d__2 = (doublereal) r1;
16202 d__1 = pow_dd(&d__2, &d1);
16203 food_(&d__1);
16204 d__1 = pow_dd(&d1, &d2);
16205 food_(&d__1);
16206 d__2 = (doublereal) r1;
16207 d__1 = pow_dd(&d1, &d__2);
16208 food_(&d__1);
16209 z__2.r = c1.r, z__2.i = c1.i;
16210 z__3.r = c2.r, z__3.i = c2.i;
16211 pow_zz(&z__1, &z__2, &z__3);
16212 q__1.r = z__1.r, q__1.i = z__1.i;
16213 fooc_(&q__1);
16214 z__2.r = c1.r, z__2.i = c1.i;
16215 z__3.r = r1, z__3.i = 0.;
16216 pow_zz(&z__1, &z__2, &z__3);
16217 q__1.r = z__1.r, q__1.i = z__1.i;
16218 fooc_(&q__1);
16219 z__2.r = c1.r, z__2.i = c1.i;
16220 z__3.r = d1, z__3.i = 0.;
16221 pow_zz(&z__1, &z__2, &z__3);
16222 fooz_(&z__1);
16223 // FFEINTRIN_impABS //
16224 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16225 foor_(&r__1);
16226 // FFEINTRIN_impACOS //
16227 r__1 = acos(r1);
16228 foor_(&r__1);
16229 // FFEINTRIN_impAIMAG //
16230 r__1 = r_imag(&c1);
16231 foor_(&r__1);
16232 // FFEINTRIN_impAINT //
16233 r__1 = r_int(&r1);
16234 foor_(&r__1);
16235 // FFEINTRIN_impALOG //
16236 r__1 = log(r1);
16237 foor_(&r__1);
16238 // FFEINTRIN_impALOG10 //
16239 r__1 = r_lg10(&r1);
16240 foor_(&r__1);
16241 // FFEINTRIN_impAMAX0 //
16242 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16243 foor_(&r__1);
16244 // FFEINTRIN_impAMAX1 //
16245 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16246 foor_(&r__1);
16247 // FFEINTRIN_impAMIN0 //
16248 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16249 foor_(&r__1);
16250 // FFEINTRIN_impAMIN1 //
16251 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16252 foor_(&r__1);
16253 // FFEINTRIN_impAMOD //
16254 r__1 = r_mod(&r1, &r2);
16255 foor_(&r__1);
16256 // FFEINTRIN_impANINT //
16257 r__1 = r_nint(&r1);
16258 foor_(&r__1);
16259 // FFEINTRIN_impASIN //
16260 r__1 = asin(r1);
16261 foor_(&r__1);
16262 // FFEINTRIN_impATAN //
16263 r__1 = atan(r1);
16264 foor_(&r__1);
16265 // FFEINTRIN_impATAN2 //
16266 r__1 = atan2(r1, r2);
16267 foor_(&r__1);
16268 // FFEINTRIN_impCABS //
16269 r__1 = c_abs(&c1);
16270 foor_(&r__1);
16271 // FFEINTRIN_impCCOS //
16272 c_cos(&q__1, &c1);
16273 fooc_(&q__1);
16274 // FFEINTRIN_impCEXP //
16275 c_exp(&q__1, &c1);
16276 fooc_(&q__1);
16277 // FFEINTRIN_impCHAR //
16278 *(unsigned char *)&ch__1[0] = i1;
16279 fooa_(ch__1, 1L);
16280 // FFEINTRIN_impCLOG //
16281 c_log(&q__1, &c1);
16282 fooc_(&q__1);
16283 // FFEINTRIN_impCONJG //
16284 r_cnjg(&q__1, &c1);
16285 fooc_(&q__1);
16286 // FFEINTRIN_impCOS //
16287 r__1 = cos(r1);
16288 foor_(&r__1);
16289 // FFEINTRIN_impCOSH //
16290 r__1 = cosh(r1);
16291 foor_(&r__1);
16292 // FFEINTRIN_impCSIN //
16293 c_sin(&q__1, &c1);
16294 fooc_(&q__1);
16295 // FFEINTRIN_impCSQRT //
16296 c_sqrt(&q__1, &c1);
16297 fooc_(&q__1);
16298 // FFEINTRIN_impDABS //
16299 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16300 food_(&d__1);
16301 // FFEINTRIN_impDACOS //
16302 d__1 = acos(d1);
16303 food_(&d__1);
16304 // FFEINTRIN_impDASIN //
16305 d__1 = asin(d1);
16306 food_(&d__1);
16307 // FFEINTRIN_impDATAN //
16308 d__1 = atan(d1);
16309 food_(&d__1);
16310 // FFEINTRIN_impDATAN2 //
16311 d__1 = atan2(d1, d2);
16312 food_(&d__1);
16313 // FFEINTRIN_impDCOS //
16314 d__1 = cos(d1);
16315 food_(&d__1);
16316 // FFEINTRIN_impDCOSH //
16317 d__1 = cosh(d1);
16318 food_(&d__1);
16319 // FFEINTRIN_impDDIM //
16320 d__1 = d_dim(&d1, &d2);
16321 food_(&d__1);
16322 // FFEINTRIN_impDEXP //
16323 d__1 = exp(d1);
16324 food_(&d__1);
16325 // FFEINTRIN_impDIM //
16326 r__1 = r_dim(&r1, &r2);
16327 foor_(&r__1);
16328 // FFEINTRIN_impDINT //
16329 d__1 = d_int(&d1);
16330 food_(&d__1);
16331 // FFEINTRIN_impDLOG //
16332 d__1 = log(d1);
16333 food_(&d__1);
16334 // FFEINTRIN_impDLOG10 //
16335 d__1 = d_lg10(&d1);
16336 food_(&d__1);
16337 // FFEINTRIN_impDMAX1 //
16338 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16339 food_(&d__1);
16340 // FFEINTRIN_impDMIN1 //
16341 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16342 food_(&d__1);
16343 // FFEINTRIN_impDMOD //
16344 d__1 = d_mod(&d1, &d2);
16345 food_(&d__1);
16346 // FFEINTRIN_impDNINT //
16347 d__1 = d_nint(&d1);
16348 food_(&d__1);
16349 // FFEINTRIN_impDPROD //
16350 d__1 = (doublereal) r1 * r2;
16351 food_(&d__1);
16352 // FFEINTRIN_impDSIGN //
16353 d__1 = d_sign(&d1, &d2);
16354 food_(&d__1);
16355 // FFEINTRIN_impDSIN //
16356 d__1 = sin(d1);
16357 food_(&d__1);
16358 // FFEINTRIN_impDSINH //
16359 d__1 = sinh(d1);
16360 food_(&d__1);
16361 // FFEINTRIN_impDSQRT //
16362 d__1 = sqrt(d1);
16363 food_(&d__1);
16364 // FFEINTRIN_impDTAN //
16365 d__1 = tan(d1);
16366 food_(&d__1);
16367 // FFEINTRIN_impDTANH //
16368 d__1 = tanh(d1);
16369 food_(&d__1);
16370 // FFEINTRIN_impEXP //
16371 r__1 = exp(r1);
16372 foor_(&r__1);
16373 // FFEINTRIN_impIABS //
16374 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16375 fooi_(&i__1);
16376 // FFEINTRIN_impICHAR //
16377 i__1 = *(unsigned char *)a1;
16378 fooi_(&i__1);
16379 // FFEINTRIN_impIDIM //
16380 i__1 = i_dim(&i1, &i2);
16381 fooi_(&i__1);
16382 // FFEINTRIN_impIDNINT //
16383 i__1 = i_dnnt(&d1);
16384 fooi_(&i__1);
16385 // FFEINTRIN_impINDEX //
16386 i__1 = i_indx(a1, a2, 10L, 10L);
16387 fooi_(&i__1);
16388 // FFEINTRIN_impISIGN //
16389 i__1 = i_sign(&i1, &i2);
16390 fooi_(&i__1);
16391 // FFEINTRIN_impLEN //
16392 i__1 = i_len(a1, 10L);
16393 fooi_(&i__1);
16394 // FFEINTRIN_impLGE //
16395 L__1 = l_ge(a1, a2, 10L, 10L);
16396 fool_(&L__1);
16397 // FFEINTRIN_impLGT //
16398 L__1 = l_gt(a1, a2, 10L, 10L);
16399 fool_(&L__1);
16400 // FFEINTRIN_impLLE //
16401 L__1 = l_le(a1, a2, 10L, 10L);
16402 fool_(&L__1);
16403 // FFEINTRIN_impLLT //
16404 L__1 = l_lt(a1, a2, 10L, 10L);
16405 fool_(&L__1);
16406 // FFEINTRIN_impMAX0 //
16407 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16408 fooi_(&i__1);
16409 // FFEINTRIN_impMAX1 //
16410 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16411 fooi_(&i__1);
16412 // FFEINTRIN_impMIN0 //
16413 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16414 fooi_(&i__1);
16415 // FFEINTRIN_impMIN1 //
16416 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16417 fooi_(&i__1);
16418 // FFEINTRIN_impMOD //
16419 i__1 = i1 % i2;
16420 fooi_(&i__1);
16421 // FFEINTRIN_impNINT //
16422 i__1 = i_nint(&r1);
16423 fooi_(&i__1);
16424 // FFEINTRIN_impSIGN //
16425 r__1 = r_sign(&r1, &r2);
16426 foor_(&r__1);
16427 // FFEINTRIN_impSIN //
16428 r__1 = sin(r1);
16429 foor_(&r__1);
16430 // FFEINTRIN_impSINH //
16431 r__1 = sinh(r1);
16432 foor_(&r__1);
16433 // FFEINTRIN_impSQRT //
16434 r__1 = sqrt(r1);
16435 foor_(&r__1);
16436 // FFEINTRIN_impTAN //
16437 r__1 = tan(r1);
16438 foor_(&r__1);
16439 // FFEINTRIN_impTANH //
16440 r__1 = tanh(r1);
16441 foor_(&r__1);
16442 // FFEINTRIN_imp_CMPLX_C //
16443 r__1 = c1.r;
16444 r__2 = c2.r;
16445 q__1.r = r__1, q__1.i = r__2;
16446 fooc_(&q__1);
16447 // FFEINTRIN_imp_CMPLX_D //
16448 z__1.r = d1, z__1.i = d2;
16449 fooz_(&z__1);
16450 // FFEINTRIN_imp_CMPLX_I //
16451 r__1 = (real) i1;
16452 r__2 = (real) i2;
16453 q__1.r = r__1, q__1.i = r__2;
16454 fooc_(&q__1);
16455 // FFEINTRIN_imp_CMPLX_R //
16456 q__1.r = r1, q__1.i = r2;
16457 fooc_(&q__1);
16458 // FFEINTRIN_imp_DBLE_C //
16459 d__1 = (doublereal) c1.r;
16460 food_(&d__1);
16461 // FFEINTRIN_imp_DBLE_D //
16462 d__1 = d1;
16463 food_(&d__1);
16464 // FFEINTRIN_imp_DBLE_I //
16465 d__1 = (doublereal) i1;
16466 food_(&d__1);
16467 // FFEINTRIN_imp_DBLE_R //
16468 d__1 = (doublereal) r1;
16469 food_(&d__1);
16470 // FFEINTRIN_imp_INT_C //
16471 i__1 = (integer) c1.r;
16472 fooi_(&i__1);
16473 // FFEINTRIN_imp_INT_D //
16474 i__1 = (integer) d1;
16475 fooi_(&i__1);
16476 // FFEINTRIN_imp_INT_I //
16477 i__1 = i1;
16478 fooi_(&i__1);
16479 // FFEINTRIN_imp_INT_R //
16480 i__1 = (integer) r1;
16481 fooi_(&i__1);
16482 // FFEINTRIN_imp_REAL_C //
16483 r__1 = c1.r;
16484 foor_(&r__1);
16485 // FFEINTRIN_imp_REAL_D //
16486 r__1 = (real) d1;
16487 foor_(&r__1);
16488 // FFEINTRIN_imp_REAL_I //
16489 r__1 = (real) i1;
16490 foor_(&r__1);
16491 // FFEINTRIN_imp_REAL_R //
16492 r__1 = r1;
16493 foor_(&r__1);
16495 // FFEINTRIN_imp_INT_D: //
16497 // FFEINTRIN_specIDINT //
16498 i__1 = (integer) d1;
16499 fooi_(&i__1);
16501 // FFEINTRIN_imp_INT_R: //
16503 // FFEINTRIN_specIFIX //
16504 i__1 = (integer) r1;
16505 fooi_(&i__1);
16506 // FFEINTRIN_specINT //
16507 i__1 = (integer) r1;
16508 fooi_(&i__1);
16510 // FFEINTRIN_imp_REAL_D: //
16512 // FFEINTRIN_specSNGL //
16513 r__1 = (real) d1;
16514 foor_(&r__1);
16516 // FFEINTRIN_imp_REAL_I: //
16518 // FFEINTRIN_specFLOAT //
16519 r__1 = (real) i1;
16520 foor_(&r__1);
16521 // FFEINTRIN_specREAL //
16522 r__1 = (real) i1;
16523 foor_(&r__1);
16525 } // MAIN__ //
16527 -------- (end output file from f2c)
16529 */