| blob | aec7ce33722dcda0ec22f0fa5f2fad6705fd30dd |
1 /* com.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
3 Free Software Foundation, Inc.
4 Contributed by James Craig Burley.
6 This file is part of GNU Fortran.
8 GNU Fortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
11 any later version.
13 GNU Fortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Fortran; see the file COPYING. If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
21 02111-1307, USA.
23 Related Modules:
24 None
26 Description:
27 Contains compiler-specific functions.
29 Modifications:
30 */
32 /* Understanding this module means understanding the interface between
33 the g77 front end and the gcc back end (or, perhaps, some other
34 back end). In here are the functions called by the front end proper
35 to notify whatever back end is in place about certain things, and
36 also the back-end-specific functions. It's a bear to deal with, so
37 lately I've been trying to simplify things, especially with regard
38 to the gcc-back-end-specific stuff.
40 Building expressions generally seems quite easy, but building decls
41 has been challenging and is undergoing revision. gcc has several
42 kinds of decls:
44 TYPE_DECL -- a type (int, float, struct, function, etc.)
45 CONST_DECL -- a constant of some type other than function
46 LABEL_DECL -- a variable or a constant?
47 PARM_DECL -- an argument to a function (a variable that is a dummy)
48 RESULT_DECL -- the return value of a function (a variable)
49 VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
50 FUNCTION_DECL -- a function (either the actual function or an extern ref)
51 FIELD_DECL -- a field in a struct or union (goes into types)
53 g77 has a set of functions that somewhat parallels the gcc front end
54 when it comes to building decls:
56 Internal Function (one we define, not just declare as extern):
57 if (is_nested) push_f_function_context ();
58 start_function (get_identifier ("function_name"), function_type,
59 is_nested, is_public);
60 // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
61 store_parm_decls (is_main_program);
62 ffecom_start_compstmt ();
63 // for stmts and decls inside function, do appropriate things;
64 ffecom_end_compstmt ();
65 finish_function (is_nested);
66 if (is_nested) pop_f_function_context ();
68 Everything Else:
69 tree d;
70 tree init;
71 // fill in external, public, static, &c for decl, and
72 // set DECL_INITIAL to error_mark_node if going to initialize
73 // set is_top_level TRUE only if not at top level and decl
74 // must go in top level (i.e. not within current function decl context)
75 d = start_decl (decl, is_top_level);
76 init = ...; // if have initializer
77 finish_decl (d, init, is_top_level);
79 */
81 /* Include files. */
98 /* VMS-specific definitions */
99 #ifdef VMS
100 #include <descrip.h>
103 #define read(fd,buf,size) VMS_read (fd,buf,size)
104 #define write(fd,buf,size) VMS_write (fd,buf,size)
105 #define open(fname,mode,prot) VMS_open (fname,mode,prot)
106 #define fopen(fname,mode) VMS_fopen (fname,mode)
107 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
108 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
109 #define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
119 #define ino_t vms_ino_t
140 /* Externals defined here. */
142 /* Stream for reading from the input file. */
145 /* These definitions parallel those in c-decl.c so that code from that
146 module can be used pretty much as is. Much of these defs aren't
147 otherwise used, i.e. by g77 code per se, except some of them are used
148 to build some of them that are. The ones that are global (i.e. not
149 "static") are those that ste.c and such might use (directly
150 or by using com macros that reference them in their definitions). */
152 tree string_type_node;
154 /* The rest of these are inventions for g77, though there might be
155 similar things in the C front end. As they are found, these
156 inventions should be renamed to be canonical. Note that only
157 the ones currently required to be global are so. */
166 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
167 just use build_function_type and build_pointer_type on the
168 appropriate _tree_type array element. */
179 ffecomSymbol ffecom_symbol_null_
180 =
181 {
182 NULL_TREE,
183 NULL_TREE,
184 NULL_TREE,
185 NULL_TREE,
186 false
187 };
192 tree ffecom_f2c_integer_type_node;
194 tree ffecom_f2c_address_type_node;
195 tree ffecom_f2c_real_type_node;
197 tree ffecom_f2c_doublereal_type_node;
198 tree ffecom_f2c_complex_type_node;
199 tree ffecom_f2c_doublecomplex_type_node;
200 tree ffecom_f2c_longint_type_node;
201 tree ffecom_f2c_logical_type_node;
202 tree ffecom_f2c_flag_type_node;
203 tree ffecom_f2c_ftnlen_type_node;
204 tree ffecom_f2c_ftnlen_zero_node;
205 tree ffecom_f2c_ftnlen_one_node;
206 tree ffecom_f2c_ftnlen_two_node;
207 tree ffecom_f2c_ptr_to_ftnlen_type_node;
208 tree ffecom_f2c_ftnint_type_node;
209 tree ffecom_f2c_ptr_to_ftnint_type_node;
211 /* Simple definitions and enumerations. */
213 #ifndef FFECOM_sizeMAXSTACKITEM
215 larger than this # bytes
216 off stack if possible. */
217 #endif
219 /* For systems that have large enough stacks, they should define
220 this to 0, and here, for ease of use later on, we just undefine
221 it if it is 0. */
223 #if FFECOM_sizeMAXSTACKITEM == 0
224 #undef FFECOM_sizeMAXSTACKITEM
225 #endif
228 {
229 FFECOM_rttypeVOID_,
244 FFECOM_rttype_
247 /* Internal typedefs. */
251 /* Private include files. */
254 /* Internal structure definitions. */
256 struct _ffecom_concat_list_
257 {
261 ffetargetCharacterSize minlen;
262 ffetargetCharacterSize maxlen;
263 };
265 /* Static functions (internal). */
299 static ffecomConcatList_
301 ffebld expr,
302 ffetargetCharacterSize max);
305 ffetargetCharacterSize max);
308 ffetargetOffset offset);
325 ffeinfoBasictype bt,
326 ffeinfoKindtype kt);
334 tree dest_length,
335 ffetargetCharacterSize dest_size,
336 ffebld source);
341 ffebld source);
351 tree t);
358 ffeinfoBasictype bt,
359 ffeinfoKindtype kt);
368 /* These are static functions that parallel those found in the C front
369 end and thus have the same names. */
393 ffewhereColumn c);
395 /* Static objects accessed by functions in this module. */
429 /* Holds pointer-to-function expressions. */
433 /* Holds the external names of the functions. */
436 =
437 {
438 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
440 #undef DEFGFRT
441 };
443 /* Whether the function returns. */
446 =
447 {
448 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
450 #undef DEFGFRT
451 };
453 /* Whether the function returns type complex. */
456 =
457 {
458 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
460 #undef DEFGFRT
461 };
463 /* Whether the function is const
464 (i.e., has no side effects and only depends on its arguments). */
467 =
468 {
469 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
471 #undef DEFGFRT
472 };
474 /* Type code for the function return value. */
477 =
478 {
479 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
481 #undef DEFGFRT
482 };
484 /* String of codes for the function's arguments. */
487 =
488 {
489 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
491 #undef DEFGFRT
492 };
494 /* Internal macros. */
496 /* We let tm.h override the types used here, to handle trivial differences
497 such as the choice of unsigned int or long unsigned int for size_t.
498 When machines start needing nontrivial differences in the size type,
499 it would be best to do something here to figure out automatically
500 from other information what type to use. */
502 #ifndef SIZE_TYPE
504 #endif
506 #define ffecom_concat_list_count_(catlist) ((catlist).count)
507 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
508 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
509 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
511 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
512 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
514 /* For each binding contour we allocate a binding_level structure
515 * which records the names defined in that contour.
516 * Contours include:
517 * 0) the global one
518 * 1) one for each function definition,
519 * where internal declarations of the parameters appear.
520 *
521 * The current meaning of a name can be found by searching the levels from
522 * the current one out to the global one.
523 */
525 /* Note that the information in the `names' component of the global contour
526 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
529 {
530 /* A chain of _DECL nodes for all variables, constants, functions,
531 and typedef types. These are in the reverse of the order supplied.
532 */
533 tree names;
535 /* For each level (except not the global one),
536 a chain of BLOCK nodes for all the levels
537 that were entered and exited one level down. */
538 tree blocks;
540 /* The BLOCK node for this level, if one has been preallocated.
541 If 0, the BLOCK is allocated (if needed) when the level is popped. */
542 tree this_block;
544 /* The binding level which this one is contained in (inherits from). */
547 /* 0: no ffecom_prepare_* functions called at this level yet;
548 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
549 2: ffecom_prepare_end called. */
551 };
553 #define NULL_BINDING_LEVEL (struct f_binding_level *) NULL
555 /* The binding level currently in effect. */
559 /* A chain of binding_level structures awaiting reuse. */
563 /* The outermost binding level, for names of file scope.
564 This is created when the compiler is started and exists
565 through the entire run. */
569 /* Binding level structures are initialized by copying this one. */
571 static const struct f_binding_level clear_binding_level
572 =
575 /* Language-dependent contents of an identifier. */
578 {
580 tree global_value;
581 tree local_value;
582 tree label_value;
584 };
586 /* Macros for access to language-specific slots in an identifier. */
587 /* Each of these slots contains a DECL node or null. */
589 /* This represents the value which the identifier has in the
590 file-scope namespace. */
591 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
592 (((struct lang_identifier *)(NODE))->global_value)
593 /* This represents the value which the identifier has in the current
594 scope. */
595 #define IDENTIFIER_LOCAL_VALUE(NODE) \
596 (((struct lang_identifier *)(NODE))->local_value)
597 /* This represents the value which the identifier has as a label in
598 the current label scope. */
599 #define IDENTIFIER_LABEL_VALUE(NODE) \
600 (((struct lang_identifier *)(NODE))->label_value)
601 /* This is nonzero if the identifier was "made up" by g77 code. */
602 #define IDENTIFIER_INVENTED(NODE) \
603 (((struct lang_identifier *)(NODE))->invented)
605 /* The resulting tree type. */
606 union lang_tree_node
609 {
612 generic;
614 };
616 /* Fortran doesn't use either of these. */
618 {
619 };
621 {
622 };
624 /* In identifiers, C uses the following fields in a special way:
625 TREE_PUBLIC to record that there was a previous local extern decl.
626 TREE_USED to record that such a decl was used.
627 TREE_ADDRESSABLE to record that the address of such a decl was used. */
629 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
630 that have names. Here so we can clear out their names' definitions
631 at the end of the function. */
635 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
638 \f
639 /* Return the subscript expression, modified to do range-checking.
641 `array' is the array to be checked against.
642 `element' is the subscript expression to check.
643 `dim' is the dimension number (starting at 0).
644 `total_dims' is the total number of dimensions (0 for CHARACTER substring).
645 */
647 static tree
650 {
653 tree cond;
654 tree die;
655 tree args;
661 {
665 else
666 {
670 }
671 }
675 {
676 /* Special handling for substring range checks. Fortran allows the
677 end subscript < begin subscript, which means that expressions like
678 string(1:0) are valid (and yield a null string). In view of this,
679 enforce two simpler conditions:
680 1) element<=high for end-substring;
681 2) element>=low for start-substring.
682 Run-time character movement will enforce remaining conditions.
684 More complicated checks would be better, but present structure only
685 provides one index element at a time, so it is not possible to
686 enforce a check of both i and j in string(i:j). If it were, the
687 complete set of rules would read,
688 if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
689 ((low<=i<=high) && (low<=j<=high)) )
690 ok ;
691 else
692 range error ;
693 */
696 else
698 }
699 else
700 {
701 /* Array reference substring range checking. */
704 low,
705 element);
707 {
709 cond,
711 element,
712 high));
713 }
714 }
716 {
720 tree arg3;
721 tree arg2;
722 tree arg1;
723 tree arg4;
726 {
743 array_name,
749 }
753 build_range_type
755 integer_one_node,
761 arg1);
763 /* s_rnge adds one to the element to print it, so bias against
764 that -- want to print a faithful *subscript* value. */
768 element,
770 integer_one_node)));
774 NULL);
782 build_range_type
784 integer_one_node,
790 arg3);
804 }
812 cond,
813 element,
814 die);
817 }
819 /* Return the computed element of an array reference.
821 `item' is NULL_TREE, or the transformed pointer to the array.
822 `expr' is the original opARRAYREF expression, which is transformed
823 if `item' is NULL_TREE.
824 `want_ptr' is nonzero if a pointer to the element, instead of
825 the element itself, is to be returned. */
827 static tree
829 {
835 tree array;
836 tree element;
837 tree tree_type;
838 tree tree_type_x;
840 ffetype type;
841 ffebld list;
845 else
848 /* Build up ARRAY_REFs in reverse order (since we're column major
849 here in Fortran land). */
854 {
861 /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
862 pointers and 32-bit integers. Do the full 64-bit pointer
863 arithmetic, for codes using arrays for nonstandard heap-like
864 work. */
866 }
873 {
876 else
885 }
891 {
892 tree min;
897 {
902 array_name);
906 /* Widen integral arithmetic as desired while preserving
907 signedness. */
922 item,
927 tree_type_x,
929 }
931 {
934 item);
935 }
936 }
937 else
938 {
942 {
948 array_name);
952 /* Widen integral arithmetic as desired while preserving
953 signedness. */
965 item,
966 element);
967 }
968 }
971 }
973 /* This is like gcc's stabilize_reference -- in fact, most of the code
974 comes from that -- but it handles the situation where the reference
975 is going to have its subparts picked at, and it shouldn't change
976 (or trigger extra invocations of functions in the subtrees) due to
977 this. save_expr is a bit overzealous, because we don't need the
978 entire thing calculated and saved like a temp. So, for DECLs, no
979 change is needed, because these are stable aggregates, and ARRAY_REF
980 and such might well be stable too, but for things like calculations,
981 we do need to calculate a snapshot of a value before picking at it. */
983 static tree
985 {
986 tree result;
990 {
994 /* No action is needed in this case. */
1046 }
1054 }
1056 /* A rip-off of gcc's convert.c convert_to_complex function,
1057 reworked to handle complex implemented as C structures
1058 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
1060 static tree
1062 {
1064 tree subtype;
1071 {
1075 }
1078 {
1082 else
1083 {
1086 type,
1090 expr)),
1094 expr)));
1095 }
1096 }
1100 else
1106 }
1108 /* Like gcc's convert(), but crashes if widening might happen. */
1110 static tree
1112 {
1125 {
1128 }
1135 {
1142 }
1144 {
1147 }
1149 {
1153 }
1155 {
1159 }
1161 {
1163 /* Check that at least the first field name agrees. */
1172 }
1176 }
1178 /* Like gcc's convert(), but crashes if narrowing might happen. */
1180 static tree
1182 {
1195 {
1198 }
1205 {
1212 }
1214 {
1217 }
1219 {
1223 }
1225 {
1229 }
1231 {
1233 /* Check that at least the first field name agrees. */
1242 }
1246 }
1248 /* Handles making a COMPLEX type, either the standard
1249 (but buggy?) gbe way, or the safer (but less elegant?)
1250 f2c way. */
1252 static tree
1254 {
1255 tree type;
1256 tree realfield;
1257 tree imagfield;
1260 {
1266 }
1267 else
1268 {
1272 }
1275 }
1277 /* Chooses either the gbe or the f2c way to build a
1278 complex constant. */
1280 static tree
1282 {
1283 tree bothparts;
1286 {
1290 }
1291 else
1292 {
1294 }
1297 }
1299 static tree
1301 {
1302 tree list;
1306 tree length;
1307 ffebld exprh;
1308 tree item;
1317 {
1319 {
1322 {
1325 }
1327 {
1366 }
1367 }
1374 || (ptr
1375 && (TYPE_MODE
1379 *plist
1383 else
1384 {
1388 {
1391 item);
1392 }
1393 *plist
1395 item);
1396 }
1401 {
1404 }
1405 }
1407 /* We've run out of args in the call; if the implementation expects
1408 more, supply null pointers for them, which the implementation can
1409 check to see if an arg was omitted. */
1412 {
1415 else
1419 {
1433 }
1434 *plist
1436 null_pointer_node);
1438 }
1443 }
1445 static tree
1447 {
1448 ffebld item;
1450 ffetype type;
1452 tree t;
1455 {
1468 {
1471 }
1472 }
1479 }
1481 /* Check whether a partial overlap between two expressions is possible.
1483 Can *starting* to write a portion of expr1 change the value
1484 computed (perhaps already, *partially*) by expr2?
1486 Currently, this is a concern only for a COMPLEX expr1. But if it
1487 isn't in COMMON or local EQUIVALENCE, since we don't support
1488 aliasing of arguments, it isn't a concern. */
1490 static bool
1492 {
1493 ffesymbol sym;
1494 ffestorag st;
1497 {
1510 }
1518 /* It's in COMMON or local EQUIVALENCE. */
1521 }
1523 /* Check whether dest and source might overlap. ffebld versions of these
1524 might or might not be passed, will be NULL if not.
1526 The test is really whether source_tree is modifiable and, if modified,
1527 might overlap destination such that the value(s) in the destination might
1528 change before it is finally modified. dest_* are the canonized
1529 destination itself. */
1531 static bool
1535 {
1536 tree source_decl;
1537 tree source_offset;
1538 tree source_size;
1539 tree t;
1545 {
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
1718 {
1719 tree arg;
1720 tree dest_decl;
1721 tree dest_offset;
1722 tree dest_size;
1725 dest_tree);
1730 /* If the decl cannot be determined reliably, or if its in COMMON
1731 and the callee isn't known to not futz with COMMON via other
1732 means, overlap might happen. */
1740 {
1745 }
1748 }
1750 /* Build a string for a variable name as used by NAMELIST. This means that
1751 if we're using the f2c library, we build an uppercase string, since
1752 f2c does this. */
1754 static tree
1756 {
1760 {
1765 tree t;
1769 else
1782 }
1783 }
1785 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1786 type to just get whatever the function returns), handling the
1787 f2c value-returning convention, if required, by prepending
1788 to the arglist a pointer to a temporary to receive the return value. */
1790 static tree
1795 {
1796 tree item;
1797 tree tempvar;
1803 {
1811 callee_commons,
1812 scalar_args))
1813 {
1816 }
1817 else
1818 {
1822 }
1824 item
1828 tempvar));
1836 }
1837 else
1845 }
1847 /* Given two arguments, transform them and make a call to the given
1848 function via ffecom_call_. */
1850 static tree
1855 {
1856 tree left_tree;
1857 tree right_tree;
1858 tree left_length;
1859 tree right_length;
1862 {
1863 /* Pass arguments by reference. */
1866 }
1867 else
1868 {
1869 /* Pass arguments by value. */
1872 }
1880 {
1883 }
1886 {
1890 else
1892 }
1897 }
1899 /* Return ptr/length args for char subexpression
1901 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1902 subexpressions by constructing the appropriate trees for the ptr-to-
1903 character-text and length-of-character-text arguments in a calling
1904 sequence.
1906 Note that if with_null is TRUE, and the expression is an opCONTER,
1907 a null byte is appended to the string. */
1909 static void
1911 {
1912 tree item;
1913 tree high;
1914 ffetargetCharacter1 val;
1915 ffetargetCharacterSize newlen;
1918 {
1923 {
1924 /* Begin FFETARGET-NULL-KLUDGE. */
1927 }
1934 /* End FFETARGET-NULL-KLUDGE. */
1936 = build_type_variant
1937 (build_array_type
1939 build_range_type
1941 ffecom_f2c_ftnlen_one_node,
1942 high)),
1947 item);
1951 {
1956 {
1959 }
1961 {
1964 else
1965 {
1968 }
1969 }
1972 else
1973 /* FFEINFO_kindFUNCTION. */
1979 item);
1980 }
1984 {
1988 {
1991 }
1994 }
1998 {
1999 ffebld start;
2000 ffebld end;
2002 tree start_tree;
2003 tree end_tree;
2005 ffebld left_symter;
2006 tree array;
2014 /* Determine name for pretty-printing range-check errors. */
2018 ;
2021 else
2027 {
2030 }
2034 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2037 {
2039 ;
2040 else
2041 {
2045 char_name);
2047 end_tree);
2050 {
2053 }
2056 }
2057 }
2058 else
2059 {
2063 char_name);
2065 start_tree);
2068 {
2071 }
2076 item,
2079 start_tree,
2080 ffecom_f2c_ftnlen_one_node));
2083 {
2085 ffecom_f2c_ftnlen_one_node,
2087 ffecom_f2c_ftnlen_type_node,
2089 start_tree));
2090 }
2091 else
2092 {
2096 char_name);
2098 end_tree);
2101 {
2104 }
2107 ffecom_f2c_ftnlen_one_node,
2109 ffecom_f2c_ftnlen_type_node,
2111 }
2112 }
2113 }
2117 {
2119 tree tempvar;
2120 tree args;
2122 ffecomGfrt ix;
2125 /* ~~Kludge alert! This should someday be fixed. */
2133 {
2135 {
2136 /* Invocation of an intrinsic returning CHARACTER*1. */
2140 }
2144 }
2145 else
2146 {
2150 {
2153 }
2155 {
2158 }
2162 }
2167 tempvar);
2173 else
2174 {
2177 {
2181 }
2182 else
2183 {
2186 }
2187 }
2193 tempvar);
2194 }
2202 {
2205 }
2211 temporary. */
2212 tree tempvar;
2213 tree args;
2214 tree newlen;
2220 tempvar);
2234 tempvar);
2236 }
2237 else
2241 }
2248 }
2251 }
2253 /* Check the size of the type to be sure it doesn't overflow the
2254 "portable" capacities of the compiler back end. `dummy' types
2255 can generally overflow the normal sizes as long as the computations
2256 themselves don't overflow. A particular target of the back end
2257 must still enforce its size requirements, though, and the back
2258 end takes care of this in stor-layout.c. */
2260 static tree
2262 {
2272 /* An array is too large if size is negative or the type_size overflows
2273 or its "upper half" is larger than 3 (which would make the signed
2274 byte size and offset computations overflow). */
2279 {
2286 }
2289 }
2291 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2292 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2293 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2295 static tree
2297 {
2299 tree highval;
2300 tree tlen;
2305 else
2306 {
2310 else
2314 }
2317 {
2320 }
2321 else
2322 {
2325 }
2329 ffecom_f2c_ftnlen_one_node,
2330 highval));
2334 }
2336 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2338 ffecomConcatList_ catlist;
2339 ffebld expr; // expr of CHARACTER basictype.
2340 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2341 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2343 Scans expr for character subexpressions, updates and returns catlist
2344 accordingly. */
2346 static ffecomConcatList_
2348 ffetargetCharacterSize max)
2349 {
2350 ffetargetCharacterSize sz;
2352 recurse:
2361 {
2368 if they don't need to preserve it. */
2378 {
2382 }
2385 }
2388 else
2392 else
2396 of the destination. */
2398 {
2404 /* ~~Do useful truncations here. */
2410 }
2411 }
2425 dummy arg of sfunc */
2428 {
2429 ffetargetCharacterSize cmax;
2435 }
2437 #endif
2445 }
2446 }
2448 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2450 ffecomConcatList_ catlist;
2451 ffecom_concat_list_kill_(catlist);
2453 Anything allocated within the list info is deallocated. */
2455 static void
2457 {
2461 }
2463 /* Make list of concatenated string exprs.
2465 Returns a flattened list of concatenated subexpressions given a
2466 tree of such expressions. */
2468 static ffecomConcatList_
2470 {
2471 ffecomConcatList_ catlist;
2475 }
2477 /* Provide some kind of useful info on member of aggregate area,
2478 since current g77/gcc technology does not provide debug info
2479 on these members. */
2481 static void
2484 {
2485 tree value;
2486 tree decl;
2490 #if 0
2491 tree type_id;
2495 )
2496 {
2498 {
2513 }
2514 }
2515 #endif
2524 #if 0
2526 #endif
2530 else
2534 aggr_type,
2541 build_range_type
2543 integer_one_node,
2558 }
2560 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2562 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2563 int i; // entry# for this entrypoint (used by master fn)
2564 ffecom_do_entrypoint_(s,i);
2566 Makes a public entry point that calls our private master fn (already
2567 compiled). */
2569 static void
2571 {
2572 ffebld item;
2576 ffeinfoBasictype bt;
2577 ffeinfoKindtype kt;
2578 ffeglobal g;
2579 ffeglobalType gt;
2581 CHARACTER. */
2585 returns. */
2594 {
2597 /* Determine actual return type for function. */
2603 {
2609 }
2616 else
2623 else
2642 {
2644 {
2647 }
2648 }
2651 else
2653 }
2654 else
2663 /* Fall through. */
2673 }
2675 /* build_decl uses the current lineno and input_filename to set the decl
2676 source info. So, I've putzed with ffestd and ffeste code to update that
2677 source info to point to the appropriate statement just before calling
2678 ffecom_do_entrypoint (which calls this fn). */
2681 type,
2688 {
2690 }
2692 /* Reset args in master arg list so they get retransitioned. */
2697 {
2698 ffebld arg;
2699 ffesymbol s;
2707 }
2709 /* Build dummy arg list for this entry point. */
2713 tree type;
2714 tree length;
2718 else
2723 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2727 else
2737 {
2740 }
2741 }
2742 else
2750 /* Disallow temp vars at this level. */
2753 /* Make local var to hold return type for multi-type master fn. */
2756 {
2760 ffecom_multi_type_node_);
2763 }
2764 else
2767 /* Here we emit the actual code for the entry point. */
2769 {
2770 ffebld list;
2771 ffebld arg;
2772 ffesymbol s;
2775 tree prepend;
2776 tree call;
2777 tree actarg;
2778 tree master_fn;
2780 /* Prepare actual arg list based on master arg list. */
2785 {
2793 else
2797 }
2799 /* This code appends the length arguments for character
2800 variables/arrays. */
2805 {
2817 else
2821 }
2823 /* Prepend character-value return info to actual arg list. */
2826 {
2832 }
2834 /* Prepend multi-type return value to actual arg list. */
2837 {
2838 prepend
2842 multi_retval));
2845 }
2847 /* Prepend my entry-point number to the actual arg list. */
2853 /* Build the call to the master function. */
2860 /* Decide whether the master function is a function or subroutine, and
2861 handle the return value for my entry point. */
2865 {
2868 }
2870 {
2872 result
2875 result);
2878 multi_retval,
2882 }
2884 {
2886 result
2891 multi_retval,
2894 }
2896 {
2897 result
2900 result);
2904 }
2905 else
2906 {
2908 result,
2910 call));
2912 }
2913 }
2922 }
2924 /* Transform expr into gcc tree with possible destination
2926 Recursive descent on expr while making corresponding tree nodes and
2927 attaching type info and such. If destination supplied and compatible
2928 with temporary that would be made in certain cases, temporary isn't
2929 made, destination used instead, and dest_used flag set TRUE. */
2931 static tree
2934 {
2935 tree item;
2936 tree list;
2937 tree args;
2938 ffeinfoBasictype bt;
2939 ffeinfoKindtype kt;
2940 tree t;
2944 ffesymbol s;
2956 /* Widen integral arithmetic as desired while preserving signedness. */
2964 {
2966 {
2967 ffebitCount i;
2971 tree purpose;
2979 {
2980 ffebldConstantUnion cu;
2981 ffebitCount length;
2990 {
2992 {
3001 else
3006 else
3007 {
3010 }
3011 }
3012 }
3015 }
3016 }
3022 item
3023 = build_array_type
3026 ffecom_integer_zero_node,
3027 item));
3034 {
3035 ffetargetOffset i;
3040 else
3041 {
3045 /* Becomes PURPOSE first time through loop. */
3047 }
3050 {
3051 ffebldConstantUnion cu
3057 /* Assume item is PURPOSE first time through loop. */
3059 else
3060 {
3063 }
3064 }
3065 }
3070 item
3071 = build_array_type
3074 ffecom_integer_zero_node,
3075 item));
3083 item
3098 {
3099 /* User explicitly wants ASSIGN'ed variables to be at the same
3100 memory address as the variables when used in non-ASSIGN
3101 contexts. That can make old, arcane, non-standard code
3102 work, but don't try to do it when a pointer wouldn't fit
3103 in the normal variable (take other approach, and warn,
3104 instead). */
3107 {
3111 }
3118 {
3123 }
3126 {
3127 /* xgettext:no-c-format */
3129 FFEBAD_severityWARNING);
3134 }
3135 }
3137 /* Don't use the normal variable's tree for ASSIGN, though mark
3138 it as in the system header (housekeeping). Use an explicit,
3139 specially created sibling that is known to be wide enough
3140 to hold pointers to labels. */
3148 {
3152 }
3153 }
3154 else
3155 {
3157 {
3161 }
3165 }
3176 /* ~~~Make sure Fortran rules respected here */
3183 {
3186 }
3193 {
3197 }
3204 {
3208 }
3215 {
3219 }
3226 {
3230 }
3236 {
3239 ffecomGfrt code;
3240 ffeinfoKindtype rtkt;
3241 ffeinfoKindtype ltkt;
3245 {
3249 {
3253 }
3257 {
3263 {
3267 }
3268 else
3269 {
3272 }
3278 {
3281 }
3282 else
3283 {
3286 }
3292 {
3295 }
3296 else
3297 {
3300 }
3308 }
3313 FFETARGET_charactersizeNONE,
3314 FFEEXPR_contextLET);
3317 FFEINFO_basictypeINTEGER,
3319 FFETARGET_charactersizeNONE,
3320 FFEEXPR_contextLET);
3327 FFETARGET_charactersizeNONE,
3328 FFEEXPR_contextLET);
3332 FFEINFO_basictypeREAL,
3334 FFETARGET_charactersizeNONE,
3335 FFEEXPR_contextLET);
3336 /* We used to call FFECOM_gfrtPOW_DD here,
3337 which passes arguments by reference. */
3339 /* Pass arguments by value. */
3346 FFEINFO_basictypeCOMPLEX,
3348 FFETARGET_charactersizeNONE,
3349 FFEEXPR_contextLET);
3353 FFEINFO_basictypeCOMPLEX,
3355 FFETARGET_charactersizeNONE,
3356 FFEEXPR_contextLET);
3365 }
3374 }
3378 {
3389 /* Fall through. */
3392 }
3398 /* Fall through. */
3404 dest_used);
3406 }
3410 {
3413 }
3419 else
3424 else
3435 tree_type,
3436 args,
3445 {
3447 item
3460 /* Fall through. */
3463 }
3468 {
3470 item
3483 /* Fall through. */
3486 }
3492 {
3494 item
3507 /* Fall through. */
3510 }
3515 {
3517 item
3524 return
3532 /* Fall through. */
3535 }
3543 {
3551 {
3558 /* convert() takes care of converting to the subtype first,
3559 at least in gcc-2.7.2. */
3568 /* Fall through. */
3571 }
3576 /* Fall through. */
3579 }
3607 {
3618 {
3619 tree real_type;
3630 {
3633 }
3634 else
3635 {
3638 }
3640 item
3648 arg2)));
3651 else
3654 }
3657 {
3660 tree left_tree;
3661 tree right_tree;
3662 tree left_length;
3663 tree right_length;
3665 /* f2c run-time functions do the implicit blank-padding for us,
3666 so we don't usually have to implement blank-padding ourselves.
3667 (The exception is when we pass an argument to a separately
3668 compiled statement function -- if we know the arg is not the
3669 same length as the dummy, we must truncate or extend it. If
3670 we "inline" statement functions, that necessity goes away as
3671 well.)
3673 Strip off the CONVERT operators that blank-pad. (Truncation by
3674 CONVERT shouldn't happen here, but it can happen in
3675 assignments.) */
3692 {
3693 left_tree
3696 left_tree);
3697 right_tree
3700 right_tree);
3702 item
3706 left_tree,
3707 integer_one_node),
3710 right_tree,
3711 integer_one_node));
3712 }
3713 else
3714 {
3718 left_length);
3723 item,
3725 integer_zero_node));
3726 }
3728 }
3734 /* Fall through. */
3737 }
3759 /* Fall through. */
3762 }
3764 #if 1
3766 #else
3768 {
3785 }
3788 #endif
3789 }
3791 /* Returns the tree that does the intrinsic invocation.
3793 Note: this function applies only to intrinsics returning
3794 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3795 subroutines. */
3797 static tree
3800 {
3801 tree expr_tree;
3804 ffeinfoBasictype bt;
3805 ffeinfoKindtype kt;
3806 tree tree_type;
3807 tree arg1_type;
3809 tree tempvar;
3812 ffebld arg2;
3813 ffebld arg3;
3814 ffeintrinImp codegen_imp;
3815 ffecomGfrt gfrt;
3827 {
3832 {
3837 {
3841 }
3842 else
3844 }
3845 else
3847 }
3848 else
3851 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3852 args. This is used by the MAX/MIN expansions. */
3855 arg1_type = ffecom_tree_type
3858 else
3860 here. */
3862 /* There are several ways for each of the cases in the following switch
3863 statements to exit (from simplest to use to most complicated):
3865 break; (when expr_tree == NULL)
3867 A standard call is made to the specific intrinsic just as if it had been
3868 passed in as a dummy procedure and called as any old procedure. This
3869 method can produce slower code but in some cases it's the easiest way for
3870 now. However, if a (presumably faster) direct call is available,
3871 that is used, so this is the easiest way in many more cases now.
3873 gfrt = FFECOM_gfrtWHATEVER;
3874 break;
3876 gfrt contains the gfrt index of a library function to call, passing the
3877 argument(s) by value rather than by reference. Used when a more
3878 careful choice of library function is needed than that provided
3879 by the vanilla `break;'.
3881 return expr_tree;
3883 The expr_tree has been completely set up and is ready to be returned
3884 as is. No further actions are taken. Use this when the tree is not
3885 in the simple form for one of the arity_n labels. */
3887 /* For info on how the switch statement cases were written, see the files
3888 enclosed in comments below the switch statement. */
3896 {
3904 {
3910 }
3923 else
3926 return
3933 #if 0
3934 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
3937 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3939 return
3942 ffecom_truth_value
3944 saved_expr1,
3946 ffecom_float_zero_))),
3950 saved_expr1)),
3951 NULL_TREE),
3957 arg1_type,
3958 saved_expr1))),
3959 NULL_TREE)
3960 ))
3961 );
3962 #endif
3967 numbers of large magnitudes. */
3972 ffecom_truth_value
3974 integer_type_node,
3975 saved_expr1,
3976 ffecom_float_zero_)),
3978 tree_type,
3979 saved_expr1,
3980 ffecom_float_half_),
3982 tree_type,
3983 saved_expr1,
3984 ffecom_float_half_))));
3987 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3989 return
3992 ffecom_truth_value
3994 saved_expr1,
3996 ffecom_float_zero_))),
4001 arg1_type,
4002 saved_expr1,
4004 ffecom_float_half_)))),
4005 NULL_TREE),
4011 arg1_type,
4013 ffecom_float_half_),
4014 saved_expr1))),
4015 NULL_TREE))
4016 )
4017 );
4018 #endif
4032 {
4037 integer_one_node),
4039 }
4041 expr_tree,
4042 tempvar);
4045 expr_tree);
4051 return
4055 return
4062 return
4069 {
4070 tree arg1_tree;
4074 return
4079 }
4086 {
4091 }
4120 return
4122 ffecom_truth_value
4124 saved_expr1,
4125 saved_expr2)),
4127 saved_expr1,
4128 saved_expr2),
4132 return
4142 {
4147 }
4154 expr_tree
4157 expr_tree);
4158 expr_tree
4161 expr_tree,
4162 integer_one_node);
4167 saved_expr1,
4168 expr_tree,
4171 #endif
4177 #if 0
4179 #else
4181 #endif
4195 {
4200 }
4210 /* We used to call FFECOM_gfrtALOG10 here. */
4213 /* We used to call FFECOM_gfrtDLOG10 here. */
4225 else
4231 {
4236 expr_tree,
4239 }
4250 else
4256 {
4261 expr_tree,
4264 }
4276 /* We used to call FFECOM_gfrtAMOD here. */
4279 /* We used to call FFECOM_gfrtDMOD here. */
4285 #if 0
4286 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4288 #else
4289 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4291 return
4294 ffecom_truth_value
4296 saved_expr1,
4298 ffecom_float_zero_))),
4300 saved_expr1,
4302 ffecom_float_half_)),
4304 saved_expr1,
4306 ffecom_float_half_))));
4307 #endif
4312 {
4315 saved_expr1
4316 = ffecom_save_tree
4320 expr_tree
4322 ffecom_truth_value
4324 arg2_tree,
4326 integer_zero_node))),
4327 saved_expr1,
4329 /* Make sure SAVE_EXPRs get referenced early enough. */
4330 expr_tree
4333 expr_tree);
4334 }
4342 {
4347 }
4359 {
4364 }
4376 else
4379 return
4427 {
4428 ffetargetLogical1 target_true;
4429 ffetargetLogical1 target_false;
4430 tree true_tree;
4431 tree false_tree;
4437 else
4441 else
4444 return
4446 ffecom_truth_value
4452 integer_one_node),
4456 integer_zero_node))),
4457 false_tree,
4458 true_tree);
4459 }
4462 return
4468 integer_one_node),
4473 {
4476 tree uns_type
4479 expr_tree
4488 uns_type,
4490 integer_zero_node)),
4492 integer_type_node,
4494 arg3_tree))));
4495 /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE. */
4496 expr_tree
4498 ffecom_truth_value
4500 arg3_tree,
4501 integer_zero_node)),
4502 expr_tree,
4504 }
4508 return
4517 {
4521 tree uns_type
4524 expr_tree
4526 ffecom_truth_value
4528 arg2_tree,
4529 integer_zero_node)),
4531 arg1_tree,
4532 arg2_tree),
4537 integer_type_node,
4538 arg2_tree))));
4539 /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds. */
4540 expr_tree
4542 ffecom_truth_value
4545 integer_type_node,
4546 arg2_tree),
4548 expr_tree,
4550 /* Make sure SAVE_EXPRs get referenced early enough. */
4551 expr_tree
4556 expr_tree));
4557 }
4561 {
4567 tree shift_neg;
4568 tree shift_pos;
4569 tree mask_arg1;
4570 tree masked_arg1;
4571 tree uns_type
4574 mask_arg1
4578 arg3_tree);
4579 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4580 mask_arg1
4582 ffecom_truth_value
4584 arg3_tree,
4586 mask_arg1,
4589 masked_arg1
4591 arg1_tree,
4593 mask_arg1));
4595 shift_neg
4601 integer_type_node,
4602 arg2_tree))),
4604 arg1_tree,
4606 arg2_tree,
4607 arg3_tree)));
4608 shift_pos
4611 arg1_tree,
4612 arg2_tree),
4617 integer_type_node,
4618 arg3_tree,
4619 arg2_tree))));
4620 expr_tree
4622 ffecom_truth_value
4624 arg2_tree,
4625 integer_zero_node)),
4626 shift_neg,
4627 shift_pos);
4628 expr_tree
4631 mask_arg1,
4632 arg1_tree),
4635 mask_arg1),
4636 expr_tree));
4637 expr_tree
4639 ffecom_truth_value
4643 integer_type_node,
4644 arg2_tree),
4645 arg3_tree),
4647 arg2_tree,
4648 integer_zero_node))),
4649 arg1_tree,
4650 expr_tree);
4651 /* Make sure SAVE_EXPRs get referenced early enough. */
4652 expr_tree
4659 mask_arg1),
4662 masked_arg1),
4663 expr_tree))));
4664 expr_tree
4667 arg3_tree),
4668 expr_tree);
4669 }
4673 {
4676 expr_tree
4680 arg1_tree));
4681 }
4685 {
4686 tree arg1_tree;
4687 tree arg2_tree;
4688 tree arg3_tree;
4690 tree arg4_tree;
4691 tree arg4_type;
4693 tree arg5_tree;
4694 tree prep_arg1;
4695 tree prep_arg4;
4696 tree arg5_plus_arg3;
4711 prep_arg1
4715 arg1_tree,
4716 arg2_tree),
4720 arg4_type,
4721 convert
4723 integer_zero_node)),
4724 arg3_tree))),
4725 arg5_tree);
4726 arg5_plus_arg3
4728 arg5_tree,
4729 arg3_tree));
4730 prep_arg4
4734 integer_zero_node)),
4735 arg5_plus_arg3);
4736 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4737 prep_arg4
4739 ffecom_truth_value
4741 arg5_plus_arg3,
4744 prep_arg4,
4746 prep_arg4
4748 arg4_tree,
4750 prep_arg4,
4754 arg4_type,
4755 convert
4757 integer_zero_node)),
4758 arg5_tree))));
4759 prep_arg1
4761 prep_arg1,
4762 prep_arg4);
4763 /* Fix up (twice), because LSHIFT_EXPR above
4764 can't shift over TYPE_SIZE. */
4765 prep_arg1
4767 ffecom_truth_value
4769 arg3_tree,
4771 integer_zero_node))),
4772 prep_arg1,
4773 arg4_tree);
4774 prep_arg1
4776 ffecom_truth_value
4778 arg3_tree,
4781 prep_arg1,
4782 arg1_tree);
4783 expr_tree
4785 arg4_tree,
4786 prep_arg1);
4787 /* Make sure SAVE_EXPRs get referenced early enough. */
4788 expr_tree
4790 arg1_tree,
4792 arg3_tree,
4794 arg5_tree,
4796 arg5_plus_arg3,
4797 expr_tree))));
4798 expr_tree
4800 arg4_tree,
4801 expr_tree);
4803 }
4813 /* extern int xargc; i__1 = xargc - 1; */
4815 ffecom_tree_xargc_,
4817 integer_one_node));
4822 {
4823 tree arg1_tree;
4824 tree arg2_tree;
4825 tree arg3_tree;
4831 arg1_tree);
4833 /* Pass procedure as a pointer to it, anything else by value. */
4836 else
4839 arg2_tree);
4843 else
4850 expr_tree
4853 FALSE,
4855 NULL_TREE :
4856 tree_type),
4857 arg1_tree,
4862 expr_tree
4865 expr_tree));
4866 }
4870 {
4871 tree arg1_tree;
4872 tree arg2_tree;
4873 tree arg3_tree;
4879 arg1_tree);
4881 /* Pass procedure as a pointer to it, anything else by value. */
4884 else
4887 arg2_tree);
4891 else
4898 expr_tree
4901 FALSE,
4902 NULL_TREE,
4903 arg1_tree,
4908 expr_tree
4911 expr_tree));
4912 }
4923 {
4925 tree arg1_tree;
4926 tree arg2_tree;
4932 else
4939 expr_tree
4942 FALSE,
4943 NULL_TREE,
4944 arg1_tree,
4949 expr_tree
4952 expr_tree));
4953 }
4962 build_pointer_type
4964 integer_zero_node));
4966 return
4969 FALSE,
4970 void_type_node,
4971 expr_tree,
4978 else
4986 {
4988 tree arg1_tree;
4990 tree arg2_tree;
4991 tree arg3_tree;
4997 else
5009 FALSE,
5010 NULL_TREE,
5011 arg1_tree,
5017 expr_tree));
5018 }
5023 {
5025 tree arg1_tree;
5026 tree arg2_tree;
5027 tree arg3_tree;
5035 else
5045 FALSE,
5046 NULL_TREE,
5047 arg1_tree,
5053 expr_tree));
5054 }
5059 {
5060 tree arg1_tree;
5061 tree arg2_tree;
5063 tree arg3_tree;
5069 arg1_tree);
5074 else
5085 FALSE,
5086 NULL_TREE,
5087 arg1_tree,
5093 expr_tree));
5094 }
5098 {
5099 tree arg1_tree;
5100 tree arg2_tree;
5101 tree arg3_tree;
5107 arg1_tree);
5114 else
5122 FALSE,
5123 NULL_TREE,
5124 arg1_tree,
5130 expr_tree));
5131 }
5132 }
5136 {
5137 tree arg1_tree;
5138 tree arg2_tree;
5139 tree arg3_tree;
5145 arg1_tree);
5151 arg2_tree);
5155 else
5163 FALSE,
5164 NULL_TREE,
5165 arg1_tree,
5171 expr_tree));
5172 }
5173 }
5178 {
5180 tree arg1_tree;
5181 tree arg2_tree;
5186 ffecom_f2c_longint_type_node :
5187 ffecom_f2c_integer_type_node),
5191 arg2_tree);
5199 expr_tree
5202 FALSE,
5203 NULL_TREE,
5204 arg1_tree,
5208 }
5213 /* Arg defaults to 0 (normal random case) */
5214 {
5215 tree arg1_tree;
5219 else
5222 arg1_tree);
5225 arg1_tree);
5230 FALSE,
5232 ffecom_f2c_integer_type_node :
5233 ffecom_f2c_real_type_node),
5234 arg1_tree,
5238 }
5243 {
5244 tree arg1_tree;
5245 tree arg2_tree;
5251 arg1_tree);
5255 else
5260 FALSE,
5261 NULL_TREE,
5264 TRUE,
5269 expr_tree));
5270 }
5271 }
5276 {
5277 tree arg1_tree;
5281 expr_tree
5284 FALSE,
5285 NULL_TREE,
5286 NULL_TREE,
5290 expr_tree
5293 expr_tree));
5294 }
5299 {
5300 tree arg1_tree;
5301 tree result_tree;
5309 FALSE,
5310 NULL_TREE,
5313 TRUE,
5317 expr_tree));
5318 }
5321 /* Straightforward calls of libf2c routines: */
5398 }
5407 tree_type,
5412 /* See bottom of this file for f2c transforms used to determine
5413 many of the above implementations. The info seems to confuse
5414 Emacs's C mode indentation, which is why it's been moved to
5415 the bottom of this source file. */
5416 }
5418 /* For power (exponentiation) where right-hand operand is type INTEGER,
5419 generate in-line code to do it the fast way (which, if the operand
5420 is a constant, might just mean a series of multiplies). */
5422 static tree
5424 {
5436 {
5444 {
5445 /* Reciprocal of integer is either 0, -1, or 1, so after
5446 calculating that (which we leave to the back end to do
5447 or not do optimally), don't bother with any multiplying. */
5451 l,
5454 rtype,
5455 r);
5458 result);
5459 }
5461 /* Generate appropriate series of multiplies, preceded
5462 by divide if the exponent is negative. */
5467 {
5470 l,
5480 r,
5481 integer_one_node));
5484 l,
5485 l);
5486 }
5487 }
5490 {
5492 {
5495 else
5497 result,
5498 l);
5499 }
5502 r,
5503 integer_one_node);
5510 l,
5511 l);
5512 }
5514 }
5516 /* Though rhs isn't a constant, in-line code cannot be expanded
5517 while transforming dummies
5518 because the back end cannot be easily convinced to generate
5519 stores (MODIFY_EXPR), handle temporaries, and so on before
5520 all the appropriate rtx's have been generated for things like
5521 dummy args referenced in rhs -- which doesn't happen until
5522 store_parm_decls() is called (expand_function_start, I believe,
5523 does the actual rtx-stuffing of PARM_DECLs).
5525 So, in this case, let the caller generate the call to the
5526 run-time-library function to evaluate the power for us. */
5531 /* Right-hand operand not a constant, expand in-line code to figure
5532 out how to do the multiplies, &c.
5534 The returned expression is expressed this way in GNU C, where l and
5535 r are the "inputs":
5537 ({ typeof (r) rtmp = r;
5538 typeof (l) ltmp = l;
5539 typeof (l) result;
5541 if (rtmp == 0)
5542 result = 1;
5543 else
5544 {
5545 if ((basetypeof (l) == basetypeof (int))
5546 && (rtmp < 0))
5547 {
5548 result = ((typeof (l)) 1) / ltmp;
5549 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5550 result = -result;
5551 }
5552 else
5553 {
5554 result = 1;
5555 if ((basetypeof (l) != basetypeof (int))
5556 && (rtmp < 0))
5557 {
5558 ltmp = ((typeof (l)) 1) / ltmp;
5559 rtmp = -rtmp;
5560 if (rtmp < 0)
5561 {
5562 rtmp = -(rtmp >> 1);
5563 ltmp *= ltmp;
5564 }
5565 }
5566 for (;;)
5567 {
5568 if (rtmp & 1)
5569 result *= ltmp;
5570 if ((rtmp >>= 1) == 0)
5571 break;
5572 ltmp *= ltmp;
5573 }
5574 }
5575 }
5576 result;
5577 })
5579 Note that some of the above is compile-time collapsable, such as
5580 the first part of the if statements that checks the base type of
5581 l against int. The if statements are phrased that way to suggest
5582 an easy way to generate the if/else constructs here, knowing that
5583 the back end should (and probably does) eliminate the resulting
5584 dead code (either the int case or the non-int case), something
5585 it couldn't do without the redundant phrasing, requiring explicit
5586 dead-code elimination here, which would be kind of difficult to
5587 read. */
5589 {
5590 tree rtmp;
5591 tree ltmp;
5592 tree divide;
5593 tree basetypeof_l_is_int;
5594 tree se;
5595 tree t;
5597 basetypeof_l_is_int
5614 else
5618 rtmp,
5619 r));
5621 ltmp,
5622 l));
5625 rtmp,
5629 result,
5633 {
5635 rtmp,
5637 integer_zero_node)),
5640 result,
5641 ffecom_tree_divide_
5644 ltmp,
5646 divide)));
5650 ltmp,
5652 integer_zero_node)),
5655 rtype,
5657 rtype,
5658 rtmp),
5660 integer_one_node)),
5662 integer_zero_node)))),
5665 result,
5667 ltype,
5668 result)));
5671 }
5673 result,
5677 ffecom_truth_value_invert
5680 rtmp,
5682 integer_zero_node)))),
5685 ltmp,
5686 ffecom_tree_divide_
5689 ltmp,
5691 divide)));
5693 rtmp,
5695 rtmp)));
5698 rtmp,
5702 rtmp,
5705 rtype,
5706 rtmp,
5707 integer_one_node))));
5709 ltmp,
5711 ltmp,
5712 ltmp)));
5718 rtmp,
5722 result,
5724 result,
5725 ltmp)));
5728 ffecom_truth_value
5730 rtmp,
5732 rtype,
5733 rtmp,
5734 integer_one_node))));
5736 ltmp,
5738 ltmp,
5739 ltmp)));
5750 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5753 {
5754 /* Make a BIND_EXPR for the BLOCK already made. */
5757 /* Remove the block from the tree at this point.
5758 It gets put back at the proper place
5759 when the BIND_EXPR is expanded. */
5761 }
5762 else
5764 }
5767 }
5769 /* ffecom_expr_transform_ -- Transform symbols in expr
5771 ffebld expr; // FFE expression.
5772 ffecom_expr_transform_ (expr);
5774 Recursive descent on expr while transforming any untransformed SYMTERs. */
5776 static void
5778 {
5779 tree t;
5780 ffesymbol s;
5782 tail_recurse:
5788 {
5796 {
5799 DIMENSION expr? */
5800 }
5810 }
5813 {
5825 }
5828 }
5830 /* Make a type based on info in live f2c.h file. */
5832 static void
5834 {
5836 {
5859 ? signed_char_type_node
5893 }
5898 }
5900 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5901 given size. */
5903 static void
5906 {
5908 tree t;
5913 {
5917 }
5918 }
5920 /* Finish up globals after doing all program units in file
5922 Need to handle only uninitialized COMMON areas. */
5924 static ffeglobal
5926 {
5927 tree cbtype;
5928 tree cbt;
5929 tree size;
5944 /* Give the array a size now. */
5952 integer_zero_node,
5953 size);
5964 }
5966 /* Finish up any untransformed symbols. */
5968 static ffesymbol
5970 {
5974 /* It's easy to know to transform an untransformed symbol, to make sure
5975 we put out debugging info for it. But COMMON variables, unlike
5976 EQUIVALENCE ones, aren't given declarations in addition to the
5977 tree expressions that specify offsets, because COMMON variables
5978 can be referenced in the outer scope where only dummy arguments
5979 (PARM_DECLs) should really be seen. To be safe, just don't do any
5980 VAR_DECLs for COMMON variables when we transform them for real
5981 use, and therefore we do all the VAR_DECL creating here. */
5984 {
5989 /* Not transformed, and not CHARACTER*(*), and not a dummy
5990 argument, which can happen only if the entry point names
5991 it "rides in on" are all invalidated for other reasons. */
5993 }
5997 {
5998 /* This isn't working, at least for dbxout. The .s file looks
5999 okay to me (burley), but in gdb 4.9 at least, the variables
6000 appear to reside somewhere outside of the common area, so
6001 it doesn't make sense to mislead anyone by generating the info
6002 on those variables until this is fixed. NOTE: Same problem
6003 with EQUIVALENCE, sadly...see similar #if later. */
6006 }
6009 }
6011 /* Append underscore(s) to name before calling get_identifier. "us"
6012 is nonzero if the name already contains an underscore and thus
6013 needs two underscores appended. */
6015 static tree
6017 {
6020 tree id;
6034 }
6036 /* Decide whether to append underscore to name before calling
6037 get_identifier. */
6039 static tree
6041 {
6045 /* If name is a built-in name, just return it as is. */
6058 }
6060 /* Decide whether to append underscore to internal name before calling
6061 get_identifier.
6063 This is for non-external, top-function-context names only. Transform
6064 identifier so it doesn't conflict with the transformed result
6065 of using a _different_ external name. E.g. if "CALL FOO" is
6066 transformed into "FOO_();", then the variable in "FOO_ = 3"
6067 must be transformed into something that does not conflict, since
6068 these two things should be independent.
6070 The transformation is as follows. If the name does not contain
6071 an underscore, there is no possible conflict, so just return.
6072 If the name does contain an underscore, then transform it just
6073 like we transform an external identifier. */
6075 static tree
6077 {
6078 /* If name does not contain an underscore, just return it as is. */
6085 name);
6086 }
6088 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6090 tree t;
6091 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6092 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6093 ffesymbol_kindtype(s));
6095 Call after setting up containing function and getting trees for all
6096 other symbols. */
6098 static tree
6100 {
6102 tree type;
6103 tree func;
6104 tree result;
6111 /* For now, we don't have a handy pointer to where the sfunc is actually
6112 defined, though that should be easy to add to an ffesymbol. (The
6113 token/where info available might well point to the place where the type
6114 of the sfunc is declared, especially if that precedes the place where
6115 the sfunc itself is defined, which is typically the case.) We should
6116 put out a null pointer rather than point somewhere wrong, but I want to
6117 see how it works at this point. */
6122 /* Pretransform the expression so any newly discovered things belong to the
6123 outer program unit, not to the statement function. */
6127 /* Make sure no recursive invocation of this fn (a specific case of failing
6128 to pretransform an sfunc's expression, i.e. where its expression
6129 references another untransformed sfunc) happens. */
6138 else
6139 {
6143 error. */
6144 }
6151 /* We don't worry about COMPLEX return values here, because this is
6152 entirely internal to our code, and gcc has the ability to return COMPLEX
6153 directly as a value. */
6157 tree type;
6169 }
6170 else
6180 {
6182 {
6184 tree result_length;
6195 }
6196 else
6197 {
6205 }
6206 }
6222 }
6226 {
6228 }
6230 static tree
6232 {
6239 }
6241 /* Return initialize-to-zero expression for this VAR_DECL. */
6243 /* A somewhat evil way to prevent the garbage collector
6244 from collecting 'tree' structures. */
6245 #define NUM_TRACKED_CHUNK 63
6247 {
6250 };
6253 void
6255 {
6260 {
6263 }
6265 {
6266 /* Need to allocate a new block. */
6274 }
6275 }
6277 static tree
6279 {
6280 tree init;
6285 {
6288 }
6296 {
6300 }
6301 else
6302 {
6305 }
6308 }
6310 static tree
6313 {
6314 tree expr_tree;
6315 tree length_tree;
6318 {
6321 (ffebld_constant_character1
6323 {
6326 }
6330 (ffebld_constant_character1
6344 {
6347 }
6350 {
6353 }
6355 expr_tree
6358 expr_tree);
6359 expr_tree
6362 expr_tree,
6363 integer_one_node);
6369 *maybe_tree
6370 = ffecom_truth_value
6372 length_tree,
6373 ffecom_f2c_ftnlen_zero_node));
6379 {
6382 }
6384 maybe_tree);
6387 {
6388 tree maybe_left;
6389 tree maybe_right;
6390 tree expr_left;
6391 tree expr_right;
6398 maybe_left,
6399 maybe_right);
6401 maybe_left,
6402 expr_left,
6403 expr_right);
6405 }
6410 }
6411 }
6413 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6415 tree length_arg;
6416 ffebld expr;
6417 length_arg = ffecom_intrinsic_len_ (expr);
6419 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6420 subexpressions by constructing the appropriate tree for the
6421 length-of-character-text argument in a calling sequence. */
6423 static tree
6425 {
6426 ffetargetCharacter1 val;
6427 tree length;
6430 {
6438 {
6440 tree item;
6444 {
6447 }
6449 {
6452 else
6453 {
6456 }
6457 }
6462 }
6470 {
6471 ffebld start;
6472 ffebld end;
6474 tree start_tree;
6475 tree end_tree;
6489 {
6491 ;
6492 else
6493 {
6496 }
6497 }
6498 else
6499 {
6504 {
6507 }
6510 {
6512 ffecom_f2c_ftnlen_one_node,
6514 ffecom_f2c_ftnlen_type_node,
6515 length,
6516 start_tree));
6517 }
6518 else
6519 {
6524 {
6527 }
6530 ffecom_f2c_ftnlen_one_node,
6532 ffecom_f2c_ftnlen_type_node,
6534 }
6535 }
6536 }
6540 length
6556 }
6561 }
6563 /* Handle CHARACTER assignments.
6565 Generates code to do the assignment. Used by ordinary assignment
6566 statement handler ffecom_let_stmt and by statement-function
6567 handler to generate code for a statement function. */
6569 static void
6572 {
6573 ffecomConcatList_ catlist;
6574 tree source_length;
6575 tree source_tree;
6576 tree expr_tree;
6585 /* Source might be an opCONVERT, which just means it is a different size
6586 than the destination. Since the underlying implementation here handles
6587 that (directly or via the s_copy or s_cat run-time-library functions),
6588 we don't need the "convenience" of an opCONVERT that tells us to
6589 truncate or blank-pad, particularly since the resulting implementation
6590 would probably be slower than otherwise. */
6597 {
6628 {
6629 dest_tree
6633 dest_tree);
6634 dest_tree
6638 dest_tree,
6639 integer_one_node);
6640 source_tree
6644 source_tree);
6645 source_tree
6649 source_tree,
6650 integer_one_node);
6657 }
6675 }
6677 /* Heavy-duty concatenation. */
6679 {
6682 tree lengths;
6683 tree items;
6684 tree length_array;
6685 tree item_array;
6686 tree citem;
6687 tree clength;
6689 {
6690 tree hook;
6698 }
6701 {
6706 {
6709 }
6711 items
6716 item_array,
6718 citem),
6719 items);
6720 lengths
6725 length_array,
6727 clength),
6728 lengths);
6729 }
6736 items));
6741 lengths));
6743 = build_tree_list
6755 }
6758 }
6760 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6762 ffecomGfrt ix;
6763 ffecom_make_gfrt_(ix);
6765 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6766 for the indicated run-time routine (ix). */
6768 static void
6770 {
6771 tree t;
6772 tree ttype;
6775 {
6840 }
6845 ttype);
6851 /* Sanity check: A function that's const cannot be volatile. */
6855 /* Sanity check: A function that's const cannot return complex. */
6864 }
6866 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
6868 static void
6870 {
6875 }
6877 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
6878 the member so debugger will see it. Otherwise nobody should be
6879 referencing the member. */
6881 static void
6883 {
6884 ffesymbol s;
6885 tree t;
6886 tree mt;
6887 tree type;
6906 type);
6923 }
6925 /* Prepare source expression for assignment into a destination perhaps known
6926 to be of a specific size. */
6928 static void
6930 {
6931 ffecomConcatList_ catlist;
6934 tree ltmp;
6935 tree itmp;
6945 {
6946 ltmp
6949 itmp
6956 }
6964 {
6967 }
6968 }
6970 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
6972 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
6973 (which generates their trees) and then their trees get push_parm_decl'd.
6975 The second arg is TRUE if the dummies are for a statement function, in
6976 which case lengths are not pushed for character arguments (since they are
6977 always known by both the caller and the callee, though the code allows
6978 for someday permitting CHAR*(*) stmtfunc dummies). */
6980 static void
6982 {
6983 ffebld dummy;
6984 ffebld dumlist;
6985 ffesymbol s;
6986 tree parm;
6990 /* First push the parms corresponding to actual dummy "contents". */
6993 {
6996 {
7003 }
7008 {
7012 }
7015 }
7017 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7020 {
7023 {
7027 NOTHING! */
7031 }
7037 length param. */
7044 }
7047 }
7049 /* ffecom_start_progunit_ -- Beginning of program unit
7051 Does GNU back end stuff necessary to teach it about the start of its
7052 equivalent of a Fortran program unit. */
7054 static void
7056 {
7058 ffebld arglist;
7062 ffeinfoBasictype bt;
7063 ffeinfoKindtype kt;
7064 ffeglobal g;
7065 ffeglobalType gt;
7070 bool multi
7071 = altentries
7084 {
7110 {
7116 }
7126 else
7133 else
7148 else
7156 /* Fall through. */
7165 }
7168 {
7171 }
7172 #if FFETARGET_isENFORCED_MAIN
7175 #endif
7176 else
7180 type,
7190 {
7192 }
7194 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7195 exec-transitioning needs current_function_decl to be filled in. So we
7196 do these things in two phases. */
7200 ffecom_which_entrypoint_decl_
7204 integer_type_node);
7206 }
7209 || cmplxfunc
7212 tree type;
7213 tree length;
7219 else
7224 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7228 else
7237 else
7241 {
7244 }
7245 }
7248 {
7251 else
7254 }
7260 /* Disallow temp vars at this level. */
7265 /* This handles any symbols still untransformed, in case -g specified.
7266 This used to be done in ffecom_finish_progunit, but it turns out to
7267 be necessary to do it here so that statement functions are
7268 expanded before code. But don't bother for BLOCK DATA. */
7272 }
7274 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7276 ffesymbol s;
7277 ffecom_sym_transform_(s);
7279 The ffesymbol_hook info for s is updated with appropriate backend info
7280 on the symbol. */
7282 static ffesymbol
7284 {
7288 ffeinfoBasictype bt;
7289 ffeinfoKindtype kt;
7290 ffeglobal g;
7293 /* Must ensure special ASSIGN variables are declared at top of outermost
7294 block, else they'll end up in the innermost block when their first
7295 ASSIGN is seen, which leaves them out of scope when they're the
7296 subject of a GOTO or I/O statement.
7298 We make this variable even if -fugly-assign. Just let it go unused,
7299 in case it turns out there are cases where we really want to use this
7300 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7308 {
7311 }
7312 else
7313 {
7318 }
7328 {
7331 {
7335 /* Before 0.4, this could be ENTITY/DUMMY, but see
7336 ffestu_sym_end_transition -- no longer true (in particular, if
7337 it could be an ENTITY, it _will_ be made one, so that
7338 possibility won't come through here). So we never make length
7339 arg for CHARACTER type. */
7343 ffecom_tree_ptr_to_subr_type);
7357 {
7360 }
7383 /* Fall through. */
7386 }
7391 {
7394 /* ~~Debugging info needed? */
7402 {
7404 tree type;
7409 {
7412 }
7416 {
7419 }
7424 ffestorag est;
7425 tree et;
7426 ffetargetOffset offset;
7443 /* (t_type *) (((char *) &et) + offset) */
7448 et));
7450 t,
7453 t);
7457 }
7458 else
7459 {
7460 tree initexpr;
7465 type);
7469 #ifdef FFECOM_sizeMAXSTACKITEM
7472 #endif
7474 && (ffecom_primary_entry_kind_
7478 else
7484 /* Keep -Wunused from complaining about var if it
7485 is used as sfunc arg or DATA implied-DO. */
7492 {
7495 else
7497 }
7500 else
7506 {
7510 }
7511 }
7512 }
7520 it (& length). */
7525 }
7530 it. */
7534 }
7536 {
7539 }
7542 {
7545 ffecom_multi_retval_);
7550 }
7564 {
7565 tree type;
7566 ffebld dl;
7567 ffebld dim;
7568 tree low;
7569 tree high;
7570 tree old_sizes;
7575 {
7578 context; get it later. */
7580 }
7583 }
7584 else
7597 {
7605 else
7610 {
7611 /* Used to just do high=low. But for ffecom_tree_
7612 canonize_ref_, it probably is important to correctly
7613 assess the size. E.g. given COMPLEX C(*),CFUNC and
7614 C(2)=CFUNC(C), overlap can happen, while it can't
7615 for, say, C(1)=CFUNC(C(2)). */
7616 /* Even more recently used to set to INT_MAX, but that
7617 broke when some overflow checking went into the back
7618 end. Now we just leave the upper bound unspecified. */
7620 }
7621 else
7624 /* Determine whether array is conditionally adjustable,
7625 to decide whether back-end magic is needed.
7627 Normally the front end uses the back-end function
7628 variable_size to wrap SAVE_EXPR's around expressions
7629 affecting the size/shape of an array so that the
7630 size/shape info doesn't change during execution
7631 of the compiled code even though variables and
7632 functions referenced in those expressions might.
7634 variable_size also makes sure those saved expressions
7635 get evaluated immediately upon entry to the
7636 compiled procedure -- the front end normally doesn't
7637 have to worry about that.
7639 However, there is a problem with this that affects
7640 g77's implementation of entry points, and that is
7641 that it is _not_ true that each invocation of the
7642 compiled procedure is permitted to evaluate
7643 array size/shape info -- because it is possible
7644 that, for some invocations, that info is invalid (in
7645 which case it is "promised" -- i.e. a violation of
7646 the Fortran standard -- that the compiled code
7647 won't reference the array or its size/shape
7648 during that particular invocation).
7650 To phrase this in C terms, consider this gcc function:
7652 void foo (int *n, float (*a)[*n])
7653 {
7654 // a is "pointer to array ...", fyi.
7655 }
7657 Suppose that, for some invocations, it is permitted
7658 for a caller of foo to do this:
7660 foo (NULL, NULL);
7662 Now the _written_ code for foo can take such a call
7663 into account by either testing explicitly for whether
7664 (a == NULL) || (n == NULL) -- presumably it is
7665 not permitted to reference *a in various fashions
7666 if (n == NULL) I suppose -- or it can avoid it by
7667 looking at other info (other arguments, static/global
7668 data, etc.).
7670 However, this won't work in gcc 2.5.8 because it'll
7671 automatically emit the code to save the "*n"
7672 expression, which'll yield a NULL dereference for
7673 the "foo (NULL, NULL)" call, something the code
7674 for foo cannot prevent.
7676 g77 definitely needs to avoid executing such
7677 code anytime the pointer to the adjustable array
7678 is NULL, because even if its bounds expressions
7679 don't have any references to possible "absent"
7680 variables like "*n" -- say all variable references
7681 are to COMMON variables, i.e. global (though in C,
7682 local static could actually make sense) -- the
7683 expressions could yield other run-time problems
7684 for allowably "dead" values in those variables.
7686 For example, let's consider a more complicated
7687 version of foo:
7689 extern int i;
7690 extern int j;
7692 void foo (float (*a)[i/j])
7693 {
7694 ...
7695 }
7697 The above is (essentially) quite valid for Fortran
7698 but, again, for a call like "foo (NULL);", it is
7699 permitted for i and j to be undefined when the
7700 call is made. If j happened to be zero, for
7701 example, emitting the code to evaluate "i/j"
7702 could result in a run-time error.
7704 Offhand, though I don't have my F77 or F90
7705 standards handy, it might even be valid for a
7706 bounds expression to contain a function reference,
7707 in which case I doubt it is permitted for an
7708 implementation to invoke that function in the
7709 Fortran case involved here (invocation of an
7710 alternate ENTRY point that doesn't have the adjustable
7711 array as one of its arguments).
7713 So, the code that the compiler would normally emit
7714 to preevaluate the size/shape info for an
7715 adjustable array _must not_ be executed at run time
7716 in certain cases. Specifically, for Fortran,
7717 the case is when the pointer to the adjustable
7718 array == NULL. (For gnu-ish C, it might be nice
7719 for the source code itself to specify an expression
7720 that, if TRUE, inhibits execution of the code. Or
7721 reverse the sense for elegance.)
7723 (Note that g77 could use a different test than NULL,
7724 actually, since it happens to always pass an
7725 integer to the called function that specifies which
7726 entry point is being invoked. Hmm, this might
7727 solve the next problem.)
7729 One way a user could, I suppose, write "foo" so
7730 it works is to insert COND_EXPR's for the
7731 size/shape info so the dangerous stuff isn't
7732 actually done, as in:
7734 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7735 {
7736 ...
7737 }
7739 The next problem is that the front end needs to
7740 be able to tell the back end about the array's
7741 decl _before_ it tells it about the conditional
7742 expression to inhibit evaluation of size/shape info,
7743 as shown above.
7745 To solve this, the front end needs to be able
7746 to give the back end the expression to inhibit
7747 generation of the preevaluation code _after_
7748 it makes the decl for the adjustable array.
7750 Until then, the above example using the COND_EXPR
7751 doesn't pass muster with gcc because the "(a == NULL)"
7752 part has a reference to "a", which is still
7753 undefined at that point.
7755 g77 will therefore use a different mechanism in the
7756 meantime. */
7767 low,
7768 ffecom_integer_zero_node);
7773 high,
7774 ffecom_integer_zero_node);
7775 #endif
7777 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7778 probably. Fixes 950302-1.f. */
7783 /* ~~~Similarly, this fixes dumb0.f. The C front end
7784 does this, which is why dumb0.c would work. */
7789 type
7790 = build_array_type
7795 }
7798 {
7801 }
7805 {
7808 }
7813 /* If this arg is present in every entry point's list of
7814 dummy args, then we're done. */
7820 #if 1
7822 /* If variable_size in stor-layout has been called during
7823 the above, then get_pending_sizes should have the
7824 yet-to-be-evaluated saved expressions pending.
7825 Make the whole lot of them get emitted, conditionally
7826 on whether the array decl ("t" above) is not NULL. */
7828 {
7830 tree tem;
7835 {
7840 else
7841 sizes
7844 temv,
7845 sizes);
7846 }
7849 {
7850 sizes
7854 integer_type_node,
7855 t,
7856 null_pointer_node),
7857 sizes,
7859 integer_zero_node));
7862 sizes
7864 }
7868 }
7870 #else
7871 #if 0
7877 t,
7878 null_pointer_node);
7879 #else
7880 #if 0
7884 {
7890 }
7891 #endif
7892 #endif
7893 #endif
7894 }
7898 {
7899 ffesymbol cs;
7900 ffeglobal cg;
7901 tree ct;
7903 tree type;
7907 {
7910 }
7918 else
7925 else
7926 {
7927 ffetargetOffset offset;
7928 ffestorag cst;
7939 /* (t_type *) (((char *) &ct) + offset) */
7944 ct));
7946 t,
7949 t);
7953 }
7954 }
7966 /* Fall through. */
7970 }
7975 {
7989 {
7992 }
7997 else
8002 t);
8024 else
8025 t = build_pointer_type
8030 t);
8043 decls. */
8047 /* Fall through. */
8051 }
8056 {
8070 {
8073 }
8077 ffecom_tree_subr_type);
8098 ffecom_tree_ptr_to_subr_type);
8106 decls. */
8110 /* Fall through. */
8114 }
8119 {
8138 /* Fall through. */
8142 }
8147 {
8158 ffecom_tree_blockdata_type);
8181 /* Fall through. */
8185 }
8190 {
8210 /* Fall through. */
8214 }
8219 {
8238 /* Fall through. */
8242 }
8247 {
8267 /* Fall through. */
8271 }
8276 /* Fall through. */
8280 }
8289 }
8291 /* Transform into ASSIGNable symbol.
8293 Symbol has already been transformed, but for whatever reason, the
8294 resulting decl_tree has been deemed not usable for an ASSIGN target.
8295 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8296 another local symbol of type void * and stuff that in the assign_tree
8297 argument. The F77/F90 standards allow this implementation. */
8299 static ffesymbol
8301 {
8306 {
8309 }
8310 else
8311 {
8316 }
8326 {
8328 /* Unlike for regular vars, SAVE status is easy to determine for
8329 ASSIGNed vars, since there's no initialization, there's no
8330 effective storage association (so "SAVE J" does not apply to
8331 K even given "EQUIVALENCE (J,K)"), there's no size issue
8332 to worry about, etc. */
8337 else
8346 /* Note that twinning a DUMMY means the caller won't see
8347 the ASSIGNed value. But both F77 and F90 allow implementations
8348 to do this, i.e. disallow Fortran code that would try and
8349 take advantage of actually putting a label into a variable
8350 via a dummy argument (or any other storage association, for
8351 that matter). */
8358 }
8368 }
8370 /* Implement COMMON area in back end.
8372 Because COMMON-based variables can be referenced in the dimension
8373 expressions of dummy (adjustable) arrays, and because dummies
8374 (in the gcc back end) need to be put in the outer binding level
8375 of a function (which has two binding levels, the outer holding
8376 the dummies and the inner holding the other vars), special care
8377 must be taken to handle COMMON areas.
8379 The current strategy is basically to always tell the back end about
8380 the COMMON area as a top-level external reference to just a block
8381 of storage of the master type of that area (e.g. integer, real,
8382 character, whatever -- not a structure). As a distinct action,
8383 if initial values are provided, tell the back end about the area
8384 as a top-level non-external (initialized) area and remember not to
8385 allow further initialization or expansion of the area. Meanwhile,
8386 if no initialization happens at all, tell the back end about
8387 the largest size we've seen declared so the space does get reserved.
8388 (This function doesn't handle all that stuff, but it does some
8389 of the important things.)
8391 Meanwhile, for COMMON variables themselves, just keep creating
8392 references like *((float *) (&common_area + offset)) each time
8393 we reference the variable. In other words, don't make a VAR_DECL
8394 or any kind of component reference (like we used to do before 0.4),
8395 though we might do that as well just for debugging purposes (and
8396 stuff the rtl with the appropriate offset expression). */
8398 static void
8400 {
8403 tree cbt;
8404 tree cbtype;
8405 tree init;
8406 tree high;
8415 /* First update the size of the area in global terms. */
8424 /* If we already have declared this common block for a previous program
8425 unit, and either we already initialized it or we don't have new
8426 initialization for it, just return what we have without changing it. */
8429 && (!is_init
8431 {
8434 }
8436 /* Process inits. */
8439 {
8441 {
8442 ffebld sexp;
8444 /* Set the padding for the expression, so ffecom_expr
8445 knows to insert that many zeros. */
8447 {
8463 }
8471 }
8472 }
8473 else
8475 }
8476 else
8479 /* cbtype must be permanently allocated! */
8481 /* Allocate the MAX of the areas so far, seen filewide. */
8489 integer_zero_node,
8490 high));
8491 else
8495 {
8496 cbt
8499 cbtype);
8502 }
8503 else
8504 {
8507 }
8517 /* Make sure that any type can live in COMMON and be referenced
8518 without getting a bus error. We could pick the most restrictive
8519 alignment of all entities actually placed in the COMMON, but
8520 this seems easy enough. */
8534 {
8540 }
8547 }
8549 /* Make master area for local EQUIVALENCE. */
8551 static void
8553 {
8554 tree eqt;
8555 tree eqtype;
8556 tree init;
8557 tree high;
8567 /* Process inits. */
8570 {
8572 {
8573 ffebld sexp;
8575 /* Set the padding for the expression, so ffecom_expr
8576 knows to insert that many zeros. */
8578 {
8594 }
8599 }
8600 else
8602 }
8605 else
8611 eqst);
8619 ffecom_integer_zero_node,
8620 high));
8624 ffesymbol_text
8626 eqtype);
8629 || ffecom_member_namelisted_
8630 #ifdef FFECOM_sizeMAXSTACKITEM
8632 #endif
8637 else
8644 else
8649 /* Make sure that any type can live in EQUIVALENCE and be referenced
8650 without getting a bus error. We could pick the most restrictive
8651 alignment of all entities actually placed in the EQUIVALENCE, but
8652 this seems easy enough. */
8666 {
8671 }
8677 eqst);
8678 }
8680 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8682 static tree
8684 {
8685 tree nmlt;
8687 tree nmlinits;
8688 tree nameinit;
8689 tree varsinit;
8690 tree nvarsinit;
8691 tree field;
8692 tree high;
8698 mynumber++),
8699 nmltype);
8705 /* Process inits. */
8715 = build_type_variant
8716 (build_array_type
8719 ffecom_f2c_ftnlen_one_node,
8720 high)),
8725 nameinit);
8729 varsinit);
8733 {
8734 ffebld b;
8738 }
8746 varsinit);
8759 }
8761 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8762 analyzed on the assumption it is calculating a pointer to be
8763 indirected through. It must return the proper decl and offset,
8764 taking into account different units of measurements for offsets. */
8766 static void
8768 tree t)
8769 {
8771 {
8785 {
8786 /* An offset into COMMON. */
8789 /* Convert offset (presumably in bytes) into canonical units
8790 (presumably bits). */
8795 }
8796 /* Not a COMMON reference, so an unrecognized pattern. */
8807 {
8808 /* A reference to COMMON. */
8812 }
8813 /* Fall through. */
8815 /* Not a COMMON reference, so an unrecognized pattern. */
8818 }
8819 }
8821 /* Given a tree that is possibly intended for use as an lvalue, return
8822 information representing a canonical view of that tree as a decl, an
8823 offset into that decl, and a size for the lvalue.
8825 If there's no applicable decl, NULL_TREE is returned for the decl,
8826 and the other fields are left undefined.
8828 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8829 is returned for the decl, and the other fields are left undefined.
8831 Otherwise, the decl returned currently is either a VAR_DECL or a
8832 PARM_DECL.
8834 The offset returned is always valid, but of course not necessarily
8835 a constant, and not necessarily converted into the appropriate
8836 type, leaving that up to the caller (so as to avoid that overhead
8837 if the decls being looked at are different anyway).
8839 If the size cannot be determined (e.g. an adjustable array),
8840 an ERROR_MARK node is returned for the size. Otherwise, the
8841 size returned is valid, not necessarily a constant, and not
8842 necessarily converted into the appropriate type as with the
8843 offset.
8845 Note that the offset and size expressions are expressed in the
8846 base storage units (usually bits) rather than in the units of
8847 the type of the decl, because two decls with different types
8848 might overlap but with apparently non-overlapping array offsets,
8849 whereas converting the array offsets to consistant offsets will
8850 reveal the overlap. */
8852 static void
8855 {
8856 /* The default path is to report a nonexistant decl. */
8863 {
8933 {
8936 tree init_offset;
8940 {
8943 }
8946 array);
8951 /* Calculate ((element - base) * NBBY) + init_offset. */
8953 element,
8965 }
8969 /* Most of this code is to handle references to COMMON. And so
8970 far that is useful only for calling library functions, since
8971 external (user) functions might reference common areas. But
8972 even calling an external function, it's worthwhile to decode
8973 COMMON references because if not storing into COMMON, we don't
8974 want COMMON-based arguments to gratuitously force use of a
8975 temporary. */
9001 }
9002 }
9004 /* Do divide operation appropriate to type of operands. */
9006 static tree
9009 tree hook)
9010 {
9016 {
9019 left,
9020 right);
9025 left,
9026 right);
9027 {
9028 ffecomGfrt ix;
9033 else
9038 left);
9042 right);
9049 tree_type,
9050 left,
9053 }
9057 {
9058 ffecomGfrt ix;
9063 else
9068 left);
9072 right);
9079 tree_type,
9080 left,
9083 }
9088 left,
9089 right);
9090 }
9091 }
9093 /* Build type info for non-dummy variable. */
9095 static tree
9097 ffeinfoKindtype kt)
9098 {
9099 tree type;
9100 ffebld dl;
9101 ffebld dim;
9102 tree lowt;
9103 tree hight;
9107 {
9111 type
9112 = build_array_type
9115 ffecom_f2c_ftnlen_one_node,
9116 hight));
9118 }
9121 {
9130 else
9146 }
9149 }
9151 /* Build Namelist type. */
9154 static tree
9156 {
9158 {
9168 string_type_node);
9171 integer_type_node);
9177 }
9180 }
9182 /* Build Vardesc type. */
9185 static tree
9187 {
9189 {
9194 string_type_node);
9196 string_type_node);
9198 ffecom_f2c_ptr_to_ftnlen_type_node);
9200 integer_type_node);
9206 }
9209 }
9211 static tree
9213 {
9214 ffesymbol s;
9220 {
9223 tree var;
9224 tree nameinit;
9225 tree dimsinit;
9226 tree addrinit;
9227 tree typeinit;
9228 tree field;
9229 tree varinits;
9234 mynumber++),
9235 vardesctype);
9241 /* Process inits. */
9247 = build_type_variant
9248 (build_array_type
9251 integer_one_node,
9258 nameinit);
9265 {
9272 }
9273 else
9277 nameinit);
9279 addrinit);
9294 }
9297 }
9299 static tree
9301 {
9302 ffebld b;
9303 tree list;
9305 tree var;
9312 {
9313 tree t;
9319 else
9320 {
9323 }
9324 }
9328 integer_one_node,
9342 }
9344 static tree
9346 {
9349 integer_zero_node);
9351 {
9352 ffebld b;
9353 ffebld e;
9354 tree list;
9355 tree backlist;
9357 tree var;
9358 tree numdim;
9359 tree numelem;
9374 {
9375 tree t;
9376 tree low;
9377 tree back;
9381 else
9382 {
9388 else
9389 {
9392 }
9393 }
9397 else
9404 }
9407 {
9410 else
9414 ffecom_f2c_ftnlen_type_node,
9416 baseoff));
9417 }
9419 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9432 integer_zero_node,
9433 build_int_2
9450 }
9451 }
9453 /* Essentially does a "fold (build1 (code, type, node))" while checking
9454 for certain housekeeping things.
9456 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9457 ffecom_1_fn instead. */
9459 tree
9461 {
9462 tree item;
9469 {
9472 }
9475 {
9476 tree realtype;
9489 {
9492 }
9495 item =
9499 node)),
9502 node)));
9508 }
9517 }
9519 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9520 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9521 does not set TREE_ADDRESSABLE (because calling an inline
9522 function does not mean the function needs to be separately
9523 compiled). */
9525 tree
9527 {
9528 tree item;
9529 tree type;
9544 }
9546 /* Essentially does a "fold (build (code, type, node1, node2))" while
9547 checking for certain housekeeping things. */
9549 tree
9551 tree node2)
9552 {
9553 tree item;
9561 {
9576 {
9579 }
9583 item =
9587 node1),
9589 node2)),
9592 node1),
9594 node2)));
9599 {
9602 }
9606 item =
9610 node1),
9612 node2)),
9615 node1),
9617 node2)));
9622 {
9625 }
9630 node1));
9632 node1));
9634 node2));
9636 node2));
9637 item =
9641 a,
9642 c),
9644 b,
9645 d)),
9648 a,
9649 d),
9651 c,
9652 b)));
9658 {
9661 }
9667 item =
9671 node1),
9673 node2)),
9676 node1),
9678 node2)));
9684 {
9687 }
9693 item =
9697 node1),
9699 node2)),
9702 node1),
9704 node2)));
9710 }
9715 }
9717 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9719 ffesymbol s; // the ENTRY point itself
9720 if (ffecom_2pass_advise_entrypoint(s))
9721 // the ENTRY point has been accepted
9723 Does whatever compiler needs to do when it learns about the entrypoint,
9724 like determine the return type of the master function, count the
9725 number of entrypoints, etc. Returns FALSE if the return type is
9726 not compatible with the return type(s) of other entrypoint(s).
9728 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9729 later (after _finish_progunit) be called with the same entrypoint(s)
9730 as passed to this fn for which TRUE was returned.
9732 03-Jan-92 JCB 2.0
9733 Return FALSE if the return type conflicts with previous entrypoints. */
9735 bool
9737 {
9751 arglist's dummies. */
9761 {
9768 else
9771 }
9772 }
9774 /* If necessary, scan entry arglist for alternate returns. Do this scan
9775 apparently redundantly (it's done below to UNIONize the arglists) so
9776 that we don't complain about RETURN 1 if an offending ENTRY is the only
9777 one with an alternate return. */
9780 {
9784 {
9787 {
9790 }
9791 }
9792 }
9794 /* Now check type compatibility. */
9797 {
9803 ok
9814 {
9817 }
9820 {
9823 }
9825 }
9828 {
9833 }
9835 /* Entrypoint type compatible with previous types. */
9839 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9844 {
9853 appending of arg. */
9856 }
9860 /* Append this arg to the master list. */
9865 else
9867 }
9870 }
9872 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9874 ffesymbol s; // the ENTRY point itself
9875 ffecom_2pass_do_entrypoint(s);
9877 Does whatever compiler needs to do to make the entrypoint actually
9878 happen. Must be called for each entrypoint after
9879 ffecom_finish_progunit is called. */
9881 void
9883 {
9892 }
9893 else
9899 }
9901 /* Essentially does a "fold (build (code, type, node1, node2))" while
9902 checking for certain housekeeping things. Always sets
9903 TREE_SIDE_EFFECTS. */
9905 tree
9907 tree node2)
9908 {
9909 tree item;
9919 }
9921 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9922 checking for certain housekeeping things. */
9924 tree
9927 {
9928 tree item;
9941 }
9943 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9944 checking for certain housekeeping things. Always sets
9945 TREE_SIDE_EFFECTS. */
9947 tree
9950 {
9951 tree item;
9962 }
9964 /* ffecom_arg_expr -- Transform argument expr into gcc tree
9966 See use by ffecom_list_expr.
9968 If expression is NULL, returns an integer zero tree. If it is not
9969 a CHARACTER expression, returns whatever ffecom_expr
9970 returns and sets the length return value to NULL_TREE. Otherwise
9971 generates code to evaluate the character expression, returns the proper
9972 pointer to the result, but does NOT set the length return value to a tree
9973 that specifies the length of the result. (In other words, the length
9974 variable is always set to NULL_TREE, because a length is never passed.)
9976 21-Dec-91 JCB 1.1
9977 Don't set returned length, since nobody needs it (yet; someday if
9978 we allow CHARACTER*(*) dummies to statement functions, we'll need
9979 it). */
9981 tree
9983 {
9984 tree ign;
9995 }
9997 /* Transform expression into constant argument-pointer-to-expression tree.
9999 If the expression can be transformed into a argument-pointer-to-expression
10000 tree that is constant, that is done, and the tree returned. Else
10001 NULL_TREE is returned.
10003 That way, a caller can attempt to provide compile-time initialization
10004 of a variable and, if that fails, *then* choose to start a new block
10005 and resort to using temporaries, as appropriate. */
10007 tree
10009 {
10014 {
10018 }
10025 {
10026 tree t;
10032 }
10040 }
10042 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10044 See use by ffecom_list_ptr_to_expr.
10046 If expression is NULL, returns an integer zero tree. If it is not
10047 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10048 returns and sets the length return value to NULL_TREE. Otherwise
10049 generates code to evaluate the character expression, returns the proper
10050 pointer to the result, AND sets the length return value to a tree that
10051 specifies the length of the result.
10053 If the length argument is NULL, this is a slightly special
10054 case of building a FORMAT expression, that is, an expression that
10055 will be used at run time without regard to length. For the current
10056 implementation, which uses the libf2c library, this means it is nice
10057 to append a null byte to the end of the expression, where feasible,
10058 to make sure any diagnostic about the FORMAT string terminates at
10059 some useful point.
10061 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10062 length argument. This might even be seen as a feature, if a null
10063 byte can always be appended. */
10065 tree
10067 {
10068 tree item;
10069 tree ign_length;
10070 ffecomConcatList_ catlist;
10079 {
10083 {
10084 tree temp_exp;
10085 tree temp_length;
10092 temp_exp);
10093 }
10099 {
10102 }
10108 {
10117 }
10122 }
10135 {
10138 {
10141 }
10149 else
10158 }
10160 {
10163 tree lengths;
10164 tree items;
10165 tree length_array;
10166 tree item_array;
10167 tree citem;
10168 tree clength;
10169 tree temporary;
10170 tree num;
10171 tree known_length;
10172 ffetargetCharacterSize sz;
10175 /* ~~Kludge! */
10178 {
10179 tree hook;
10188 }
10193 {
10198 else
10203 {
10207 }
10209 items
10214 item_array,
10216 citem),
10217 items);
10220 known_length
10222 known_length,
10223 clength);
10224 lengths
10229 length_array,
10231 clength),
10232 lengths);
10233 }
10237 temporary);
10244 items));
10249 lengths));
10251 = build_tree_list
10264 item,
10265 temporary);
10269 }
10274 }
10276 /* Generate call to run-time function.
10278 The first arg is the GNU Fortran Run-Time function index, the second
10279 arg is the list of arguments to pass to it. Returned is the expression
10280 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10281 result (which may be void). */
10283 tree
10285 {
10291 }
10293 /* Transform constant-union to tree. */
10295 tree
10298 {
10299 tree item;
10302 {
10304 {
10308 {
10309 #if FFETARGET_okINTEGER1
10314 #endif
10316 #if FFETARGET_okINTEGER2
10321 #endif
10323 #if FFETARGET_okINTEGER3
10328 #endif
10330 #if FFETARGET_okINTEGER4
10332 #if HOST_BITS_PER_LONGLONG > HOST_BITS_PER_WIDE_INT
10333 {
10337 }
10338 #else
10341 #endif
10343 #endif
10347 /* Fall through. */
10350 }
10353 }
10357 {
10361 {
10362 #if FFETARGET_okLOGICAL1
10366 #endif
10368 #if FFETARGET_okLOGICAL2
10372 #endif
10374 #if FFETARGET_okLOGICAL3
10378 #endif
10380 #if FFETARGET_okLOGICAL4
10384 #endif
10388 /* Fall through. */
10391 }
10394 }
10398 {
10399 REAL_VALUE_TYPE val;
10402 {
10403 #if FFETARGET_okREAL1
10407 #endif
10409 #if FFETARGET_okREAL2
10413 #endif
10415 #if FFETARGET_okREAL3
10419 #endif
10423 /* Fall through. */
10426 }
10428 }
10432 {
10433 REAL_VALUE_TYPE real;
10434 REAL_VALUE_TYPE imag;
10438 {
10439 #if FFETARGET_okCOMPLEX1
10444 #endif
10446 #if FFETARGET_okCOMPLEX2
10451 #endif
10453 #if FFETARGET_okCOMPLEX3
10458 #endif
10462 /* Fall through. */
10465 }
10469 }
10474 ffetargetCharacter1 val;
10477 {
10478 #if FFETARGET_okCHARACTER1
10482 #endif
10486 /* Fall through. */
10489 }
10494 build_range_type
10496 integer_one_node,
10497 build_int_2
10498 (ffetarget_length_character1
10501 }
10505 {
10506 ffetargetHollerith h;
10510 /* If not at least as wide as default INTEGER, widen it. */
10513 else
10514 {
10519 FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10522 str);
10523 }
10526 build_range_type
10528 integer_one_node,
10529 build_int_2
10532 }
10536 {
10537 ffetargetInteger1 ival;
10538 ffetargetTypeless tless;
10539 ffebad error;
10546 }
10551 /* Fall through. */
10554 }
10559 }
10561 /* Transform constant-union to tree, with the type known. */
10563 tree
10566 {
10567 tree item;
10572 {
10573 #if FFETARGET_okINTEGER1
10578 #endif
10579 #if FFETARGET_okINTEGER2
10584 #endif
10585 #if FFETARGET_okINTEGER3
10590 #endif
10591 #if FFETARGET_okINTEGER4
10593 #if HOST_BITS_PER_LONGLONG > HOST_BITS_PER_WIDE_INT
10594 {
10599 }
10600 #else
10603 #endif
10605 #endif
10606 #if FFETARGET_okLOGICAL1
10611 #endif
10612 #if FFETARGET_okLOGICAL2
10617 #endif
10618 #if FFETARGET_okLOGICAL3
10623 #endif
10624 #if FFETARGET_okLOGICAL4
10629 #endif
10634 }
10641 }
10642 /* Transform expression into constant tree.
10644 If the expression can be transformed into a tree that is constant,
10645 that is done, and the tree returned. Else NULL_TREE is returned.
10647 That way, a caller can attempt to provide compile-time initialization
10648 of a variable and, if that fails, *then* choose to start a new block
10649 and resort to using temporaries, as appropriate. */
10651 tree
10653 {
10664 {
10665 tree t;
10670 }
10673 }
10675 /* Handy way to make a field in a struct/union. */
10677 tree
10680 {
10681 tree field;
10691 }
10693 void
10695 {
10697 }
10699 /* End a compound statement (block). */
10701 tree
10703 {
10705 }
10707 /* ffecom_end_transition -- Perform end transition on all symbols
10709 ffecom_end_transition();
10711 Calls ffecom_sym_end_transition for each global and local symbol. */
10713 void
10715 {
10716 ffebld item;
10726 {
10728 }
10735 {
10736 ffebld callee;
10737 ffesymbol s;
10738 tree dt;
10739 tree t;
10740 tree var;
10747 {
10750 }
10756 number++),
10757 dt);
10769 }
10771 /* This handles any COMMON areas that weren't referenced but have, for
10772 example, important initial data. */
10780 }
10782 /* ffecom_exec_transition -- Perform exec transition on all symbols
10784 ffecom_exec_transition();
10786 Calls ffecom_sym_exec_transition for each global and local symbol.
10787 Make sure error updating not inhibited. */
10789 void
10791 {
10803 {
10805 }
10809 }
10811 /* Handle assignment statement.
10813 Convert dest and source using ffecom_expr, then join them
10814 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
10816 void
10818 {
10819 tree dest_tree;
10820 tree dest_length;
10821 tree source_tree;
10822 tree expr_tree;
10825 {
10827 tree assign_temp;
10829 /* This attempts to replicate the test below, but must not be
10830 true when the test below is false. (Always err on the side
10831 of creating unused temporaries, to avoid ICEs.) */
10836 {
10839 }
10840 else
10841 {
10844 }
10848 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10849 create a temporary through which the assignment is to take place,
10850 since MODIFY_EXPR doesn't handle partial overlap properly. */
10853 {
10855 ffecom_tree_type
10858 FFETARGET_charactersizeNONE,
10860 }
10861 else
10874 else
10875 {
10879 }
10886 {
10888 assign_temp,
10889 source_tree);
10892 dest_tree,
10893 assign_temp);
10894 }
10895 else
10897 dest_tree,
10898 source_tree);
10902 }
10911 source);
10912 }
10914 /* ffecom_expr -- Transform expr into gcc tree
10916 tree t;
10917 ffebld expr; // FFE expression.
10918 tree = ffecom_expr(expr);
10920 Recursive descent on expr while making corresponding tree nodes and
10921 attaching type info and such. */
10923 tree
10925 {
10927 }
10929 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
10931 tree
10933 {
10935 }
10937 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
10939 tree
10941 {
10943 }
10945 /* Transform expr for use as into read/write tree and stabilize the
10946 reference. Not for use on CHARACTER expressions.
10948 Recursive descent on expr while making corresponding tree nodes and
10949 attaching type info and such. */
10951 tree
10953 {
10955 /* Different target types not yet supported. */
10959 }
10961 /* Transform expr for use as into write tree and stabilize the
10962 reference. Not for use on CHARACTER expressions.
10964 Recursive descent on expr while making corresponding tree nodes and
10965 attaching type info and such. */
10967 tree
10969 {
10971 /* Different target types not yet supported. */
10975 }
10977 /* Do global stuff. */
10979 void
10981 {
10986 }
10988 /* Public entry point for front end to access finish_decl. */
10990 void
10992 {
10995 }
10997 /* Finish a program unit. */
10999 void
11001 {
11008 }
11010 /* Wrapper for get_identifier. pattern is sprintf-like. */
11012 tree
11014 {
11015 tree decl;
11027 }
11029 ffeinfoBasictype
11031 {
11035 {
11073 }
11074 }
11076 ffeinfoKindtype
11078 {
11082 {
11120 }
11121 }
11123 void
11125 {
11126 tree endlink;
11129 tree t;
11130 tree field;
11131 ffetype type;
11132 ffetype base_type;
11136 tree ffecom_tree_ptr_to_fun_type_void;
11138 /* This block of code comes from the now-obsolete cktyps.c. It checks
11139 whether the compiler environment is buggy in known ways, some of which
11140 would, if not explicitly checked here, result in subtle bugs in g77. */
11143 {
11145 =
11154 {
11158 }
11162 {
11166 }
11170 {
11174 }
11175 }
11182 /* Make the binding_level structure for global names. */
11189 /* Define `int' and `char' first so that dbx will output them first. */
11191 integer_type_node));
11192 /* CHARACTER*1 is unsigned in ICHAR contexts. */
11195 char_type_node));
11197 long_integer_type_node));
11199 unsigned_type_node));
11201 long_unsigned_type_node));
11203 long_long_integer_type_node));
11205 long_long_unsigned_type_node));
11207 short_integer_type_node));
11209 short_unsigned_type_node));
11211 /* Set the sizetype before we make other types. This *should* be the
11212 first type we create. */
11214 set_sizetype
11216 ffecom_typesize_pointer_
11221 /* Define both `signed char' and `unsigned char'. */
11223 signed_char_type_node));
11226 unsigned_char_type_node));
11229 float_type_node));
11231 double_type_node));
11233 long_double_type_node));
11235 /* For now, override what build_common_tree_nodes has done. */
11239 complex_long_double_type_node
11243 complex_integer_type_node));
11245 complex_float_type_node));
11247 complex_double_type_node));
11249 complex_long_double_type_node));
11252 void_type_node));
11253 /* We are not going to have real types in C with less than byte alignment,
11254 so we might as well not have any types that claim to have it. */
11260 ffecom_tree_fun_type_void
11263 ffecom_tree_ptr_to_fun_type_void
11282 t);
11286 {
11291 }
11293 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11294 to size FLOAT_TYPE_SIZE because they have to be the same size as
11295 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11296 Compiler options and other such stuff that change the ways these
11297 types are set should not affect this particular setup. */
11302 t));
11306 type);
11312 type);
11320 t));
11325 t));
11328 type);
11334 type);
11341 t));
11346 t));
11349 type);
11355 type);
11362 t));
11367 t));
11370 type);
11376 type);
11383 t));
11385 #if 0
11391 {
11393 LONG_TYPE_SIZE);
11394 }
11395 #endif
11400 t));
11404 type);
11410 type);
11417 t));
11420 type);
11426 type);
11433 t));
11436 type);
11442 type);
11449 t));
11452 type);
11458 type);
11466 t));
11471 type);
11477 type);
11487 t));
11491 type);
11497 type);
11504 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11506 t));
11510 type);
11516 type);
11523 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11525 t));
11528 type);
11534 type);
11536 type);
11541 /* Make function and ptr-to-function types for non-CHARACTER types. */
11545 {
11547 {
11549 {
11550 /* Figure out the smallest INTEGER type that can hold
11551 a pointer on this machine. */
11554 {
11559 }
11560 }
11563 /* For f2c compatibility, REAL functions are really
11564 implemented as DOUBLE PRECISION. */
11567 t = ffecom_tree_type
11571 NULL_TREE);
11573 }
11574 }
11576 /* Set up pointer types. */
11583 FFEINFO_kindtypeINTEGERDEFAULT),
11586 ffecom_pointer_kind_));
11590 else
11595 ffecom_integer_type_node
11598 integer_zero_node);
11600 integer_one_node);
11602 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11603 Turns out that by TYLONG, runtime/libI77/lio.h really means
11604 "whatever size an ftnint is". For consistency and sanity,
11605 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11606 all are INTEGER, which we also make out of whatever back-end
11607 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11608 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11609 accommodate machines like the Alpha. Note that this suggests
11610 f2c and libf2c are missing a distinction perhaps needed on
11611 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11614 FFETARGET_f2cTYLONG);
11616 FFETARGET_f2cTYSHORT);
11618 FFETARGET_f2cTYINT1);
11620 FFETARGET_f2cTYQUAD);
11622 FFETARGET_f2cTYLOGICAL);
11624 FFETARGET_f2cTYLOGICAL2);
11626 FFETARGET_f2cTYLOGICAL1);
11627 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11629 FFETARGET_f2cTYQUAD);
11631 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11632 loop. CHARACTER items are built as arrays of unsigned char. */
11639 FFEINFO_kindtypeCHARACTER1,
11640 type);
11659 /* Make multi-return-value type and fields. */
11667 {
11684 }
11689 /* Subroutines usually return integer because they might have alternate
11690 returns. */
11692 ffecom_tree_subr_type
11694 ffecom_tree_ptr_to_subr_type
11696 ffecom_tree_blockdata_type
11779 FFECOM_f2cINTEGER,
11782 FFECOM_f2cADDRESS,
11785 FFECOM_f2cREAL,
11788 FFECOM_f2cDOUBLEREAL,
11791 FFECOM_f2cCOMPLEX,
11794 FFECOM_f2cDOUBLECOMPLEX,
11797 FFECOM_f2cLONGINT,
11800 FFECOM_f2cLOGICAL,
11803 FFECOM_f2cFLAG,
11806 FFECOM_f2cFTNLEN,
11809 FFECOM_f2cFTNINT,
11812 ffecom_f2c_ftnlen_zero_node
11815 ffecom_f2c_ftnlen_one_node
11821 ffecom_f2c_ptr_to_ftnlen_type_node
11824 ffecom_f2c_ptr_to_ftnint_type_node
11827 ffecom_f2c_ptr_to_integer_type_node
11830 ffecom_f2c_ptr_to_real_type_node
11835 {
11836 REAL_VALUE_TYPE point_5;
11841 }
11843 /* Do "extern int xargc;". */
11847 integer_type_node);
11857 {
11864 }
11865 #endif
11870 /* I/O will probably crash. */
11874 #endif
11879 /* ASSIGN 10 TO I will crash. */
11884 #endif
11885 }
11887 /* ffecom_init_2 -- Initialize
11889 ffecom_init_2(); */
11891 void
11893 {
11904 }
11906 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11908 tree t;
11909 ffebld expr; // FFE opITEM list.
11910 tree = ffecom_list_expr(expr);
11912 List of actual args is transformed into corresponding gcc backend list. */
11914 tree
11916 {
11917 tree list;
11921 tree length;
11924 {
11934 {
11937 }
11938 }
11943 }
11945 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11947 tree t;
11948 ffebld expr; // FFE opITEM list.
11949 tree = ffecom_list_ptr_to_expr(expr);
11951 List of actual args is transformed into corresponding gcc backend list for
11952 use in calling an external procedure (vs. a statement function). */
11954 tree
11956 {
11957 tree list;
11961 tree length;
11964 {
11974 {
11977 }
11978 }
11983 }
11985 /* Obtain gcc's LABEL_DECL tree for label. */
11987 tree
11989 {
11990 tree glabel;
11993 {
11997 {
12003 void_type_node);
12010 ffecom_get_invented_identifier
12014 NULL_TREE),
12035 }
12037 }
12038 else
12039 {
12041 }
12044 }
12046 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12047 a single source specification (as in the fourth argument of MVBITS).
12048 If the type is NULL_TREE, the type of lhs is used to make the type of
12049 the MODIFY_EXPR. */
12051 tree
12053 tree rhs)
12054 {
12065 }
12067 /* Register source file name. */
12069 void
12071 {
12073 }
12075 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12077 ffestorag st;
12078 ffecom_notify_init_storage(st);
12080 Gets called when all possible units in an aggregate storage area (a LOCAL
12081 with equivalences or a COMMON) have been initialized. The initialization
12082 info either is in ffestorag_init or, if that is NULL,
12083 ffestorag_accretion:
12085 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12086 even for an array if the array is one element in length!
12088 ffestorag_accretion will contain an opACCTER. It is much like an
12089 opARRTER except it has an ffebit object in it instead of just a size.
12090 The back end can use the info in the ffebit object, if it wants, to
12091 reduce the amount of actual initialization, but in any case it should
12092 kill the ffebit object when done. Also, set accretion to NULL but
12093 init to a non-NULL value.
12095 After performing initialization, DO NOT set init to NULL, because that'll
12096 tell the front end it is ok for more initialization to happen. Instead,
12097 set init to an opANY expression or some such thing that you can use to
12098 tell that you've already initialized the object.
12100 27-Oct-91 JCB 1.1
12101 Support two-pass FFE. */
12103 void
12105 {
12109 {
12115 }
12116 }
12118 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12120 ffesymbol s;
12121 ffecom_notify_init_symbol(s);
12123 Gets called when all possible units in a symbol (not placed in COMMON
12124 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12125 have been initialized. The initialization info either is in
12126 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12128 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12129 even for an array if the array is one element in length!
12131 ffesymbol_accretion will contain an opACCTER. It is much like an
12132 opARRTER except it has an ffebit object in it instead of just a size.
12133 The back end can use the info in the ffebit object, if it wants, to
12134 reduce the amount of actual initialization, but in any case it should
12135 kill the ffebit object when done. Also, set accretion to NULL but
12136 init to a non-NULL value.
12138 After performing initialization, DO NOT set init to NULL, because that'll
12139 tell the front end it is ok for more initialization to happen. Instead,
12140 set init to an opANY expression or some such thing that you can use to
12141 tell that you've already initialized the object.
12143 27-Oct-91 JCB 1.1
12144 Support two-pass FFE. */
12146 void
12148 {
12153 possibilities checked. */
12157 {
12161 }
12162 }
12164 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12166 ffesymbol s;
12167 ffecom_notify_primary_entry(s);
12169 Gets called when implicit or explicit PROGRAM statement seen or when
12170 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12171 global symbol that serves as the entry point. */
12173 void
12175 {
12182 else
12186 {
12189 else
12191 }
12194 {
12195 ffebld list;
12196 ffebld arg;
12201 {
12204 {
12207 }
12208 }
12209 }
12210 }
12214 {
12216 }
12218 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12220 tree t;
12221 ffebld expr; // FFE expression.
12222 tree = ffecom_ptr_to_expr(expr);
12224 Like ffecom_expr, but sticks address-of in front of most things. */
12226 tree
12228 {
12229 tree item;
12230 ffeinfoBasictype bt;
12231 ffeinfoKindtype kt;
12232 ffesymbol s;
12237 {
12241 {
12242 ffecomGfrt ix;
12247 {
12250 }
12251 }
12252 else
12253 {
12256 {
12259 }
12260 }
12266 item);
12283 item);
12297 /* The back end currently optimizes a bit too zealously for us, in that
12298 we fail JCB001 if the following block of code is omitted. It checks
12299 to see if the transformed expression is a symbol or array reference,
12300 and encloses it in a SAVE_EXPR if that is the case. */
12309 #ifdef OFFSET_REF
12311 #endif
12315 {
12317 }
12320 item);
12322 }
12326 }
12328 /* Obtain a temp var with given data type.
12330 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12331 or >= 0 for a CHARACTER type.
12333 elements is -1 for a scalar or > 0 for an array of type. */
12335 tree
12338 {
12339 tree t;
12350 ffecom_f2c_ftnlen_one_node,
12355 integer_zero_node,
12360 commentary,
12361 mynumber++),
12362 type);
12368 }
12370 /* Prepare argument pointer to expression.
12372 Like ffecom_prepare_expr, except for expressions to be evaluated
12373 via ffecom_arg_ptr_to_expr. */
12375 void
12377 {
12378 /* ~~For now, it seems to be the same thing. */
12381 }
12383 /* End of preparations. */
12385 bool
12387 {
12394 }
12396 /* Prepare expression.
12398 This is called before any code is generated for the current block.
12399 It scans the expression, declares any temporaries that might be needed
12400 during evaluation of the expression, and stores those temporaries in
12401 the appropriate "hook" fields of the expression. `dest', if not NULL,
12402 specifies the destination that ffecom_expr_ will see, in case that
12403 helps avoid generating unused temporaries.
12405 ~~Improve to avoid allocating unused temporaries by taking `dest'
12406 into account vis-a-vis aliasing requirements of complex/character
12407 functions. */
12409 void
12411 {
12412 ffeinfoBasictype bt;
12413 ffeinfoKindtype kt;
12414 ffetargetCharacterSize sz;
12426 /* Generate whatever temporaries are needed to represent the result
12427 of the expression. */
12430 {
12433 }
12436 {
12438 /* Don't make temps for SYMTER, CONTER, etc. */
12443 {
12446 {
12447 ffesymbol s;
12459 }
12461 {
12462 /* Requires special treatment. There's no POW_CC function
12463 in libg2c, so POW_ZZ is used, which means we always
12464 need a double-complex temp, not a single-complex. */
12466 }
12468 /* The other ops don't need temps for complex operands. */
12471 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12472 REAL(C). See 19990325-0.f, routine `check', for cases. */
12474 ffecom_tree_type
12476 FFETARGET_charactersizeNONE,
12485 /* ~~Kludge alert! This should someday be fixed. */
12493 }
12497 {
12498 /* This gets special handling, because only one set of temps
12499 is needed for a tree of these -- the tree is treated as
12500 a flattened list of concatenations when generating code. */
12502 ffecomConcatList_ catlist;
12511 {
12512 ltmp
12514 ffecom_f2c_ftnlen_type_node,
12516 itmp
12518 ffecom_f2c_address_type_node,
12520 result
12522 char_type_node,
12530 }
12534 i));
12539 {
12542 }
12543 }
12553 }
12556 {
12559 }
12561 /* Prepare subexpressions for this expr. */
12564 {
12579 {
12580 ffebld item;
12587 }
12591 /* Need to handle character conversion specially. */
12593 {
12605 }
12606 }
12609 }
12611 /* Prepare expression for reading and writing.
12613 Like ffecom_prepare_expr, except for expressions to be evaluated
12614 via ffecom_expr_rw. */
12616 void
12618 {
12619 /* This is all we support for now. */
12622 /* ~~For now, it seems to be the same thing. */
12625 }
12627 /* Prepare expression for writing.
12629 Like ffecom_prepare_expr, except for expressions to be evaluated
12630 via ffecom_expr_w. */
12632 void
12634 {
12635 /* This is all we support for now. */
12638 /* ~~For now, it seems to be the same thing. */
12641 }
12643 /* Prepare expression for returning.
12645 Like ffecom_prepare_expr, except for expressions to be evaluated
12646 via ffecom_return_expr. */
12648 void
12650 {
12654 && ffecom_is_altreturning_
12657 }
12659 /* Prepare pointer to expression.
12661 Like ffecom_prepare_expr, except for expressions to be evaluated
12662 via ffecom_ptr_to_expr. */
12664 void
12666 {
12667 /* ~~For now, it seems to be the same thing. */
12670 }
12672 /* Transform expression into constant pointer-to-expression tree.
12674 If the expression can be transformed into a pointer-to-expression tree
12675 that is constant, that is done, and the tree returned. Else NULL_TREE
12676 is returned.
12678 That way, a caller can attempt to provide compile-time initialization
12679 of a variable and, if that fails, *then* choose to start a new block
12680 and resort to using temporaries, as appropriate. */
12682 tree
12684 {
12696 {
12697 tree t;
12702 }
12705 }
12707 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12709 tree rtn; // NULL_TREE means use expand_null_return()
12710 ffebld expr; // NULL if no alt return expr to RETURN stmt
12711 rtn = ffecom_return_expr(expr);
12713 Based on the program unit type and other info (like return function
12714 type, return master function type when alternate ENTRY points,
12715 whether subroutine has any alternate RETURN points, etc), returns the
12716 appropriate expression to be returned to the caller, or NULL_TREE
12717 meaning no return value or the caller expects it to be returned somewhere
12718 else (which is handled by other parts of this module). */
12720 tree
12722 {
12723 tree rtn;
12726 {
12737 else
12750 into (implicit) dummy. */
12753 }
12755 #if 0
12756 /* Spurious error if RETURN happens before first reference! So elide
12757 this code. In particular, for debugging registry, rtn should always
12758 be non-null after all, but TREE_USED won't be set until we encounter
12759 a reference in the code. Perfectly okay (but weird) code that,
12760 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12761 this diagnostic for no reason. Have people use -O -Wuninitialized
12762 and leave it to the back end to find obviously weird cases. */
12764 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12765 situation; if the return value has never been referenced, it won't
12766 have a tree under 2pass mode. */
12769 {
12776 }
12777 #endif
12785 }
12788 }
12790 /* Do save_expr only if tree is not error_mark_node. */
12792 tree
12794 {
12796 }
12798 /* Start a compound statement (block). */
12800 void
12802 {
12804 }
12806 /* Public entry point for front end to access start_decl. */
12808 tree
12810 {
12813 }
12815 /* ffecom_sym_commit -- Symbol's state being committed to reality
12817 ffesymbol s;
12818 ffecom_sym_commit(s);
12820 Does whatever the backend needs when a symbol is committed after having
12821 been backtrackable for a period of time. */
12823 void
12825 {
12827 }
12829 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12831 ffecom_sym_end_transition();
12833 Does backend-specific stuff and also calls ffest_sym_end_transition
12834 to do the necessary FFE stuff.
12836 Backtracking is never enabled when this fn is called, so don't worry
12837 about it. */
12839 ffesymbol
12841 {
12842 ffestorag st;
12850 {
12851 ffecom_list_blockdata_
12853 FFEINTRIN_specNONE,
12854 FFEINTRIN_impNONE),
12855 ffecom_list_blockdata_);
12856 }
12858 /* This is where we finally notice that a symbol has partial initialization
12859 and finalize it. */
12862 {
12865 }
12869 {
12872 }
12877 {
12878 ffecom_list_common_
12880 FFEINTRIN_specNONE,
12881 FFEINTRIN_impNONE),
12882 ffecom_list_common_);
12883 }
12886 }
12888 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12890 ffecom_sym_exec_transition();
12892 Does backend-specific stuff and also calls ffest_sym_exec_transition
12893 to do the necessary FFE stuff.
12895 See the long-winded description in ffecom_sym_learned for info
12896 on handling the situation where backtracking is inhibited. */
12898 ffesymbol
12900 {
12904 }
12906 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12908 ffesymbol s;
12909 s = ffecom_sym_learned(s);
12911 Called when a new symbol is seen after the exec transition or when more
12912 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
12913 it arrives here is that all its latest info is updated already, so its
12914 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12915 field filled in if its gone through here or exec_transition first, and
12916 so on.
12918 The backend probably wants to check ffesymbol_retractable() to see if
12919 backtracking is in effect. If so, the FFE's changes to the symbol may
12920 be retracted (undone) or committed (ratified), at which time the
12921 appropriate ffecom_sym_retract or _commit function will be called
12922 for that function.
12924 If the backend has its own backtracking mechanism, great, use it so that
12925 committal is a simple operation. Though it doesn't make much difference,
12926 I suppose: the reason for tentative symbol evolution in the FFE is to
12927 enable error detection in weird incorrect statements early and to disable
12928 incorrect error detection on a correct statement. The backend is not
12929 likely to introduce any information that'll get involved in these
12930 considerations, so it is probably just fine that the implementation
12931 model for this fn and for _exec_transition is to not do anything
12932 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12933 and instead wait until ffecom_sym_commit is called (which it never
12934 will be as long as we're using ambiguity-detecting statement analysis in
12935 the FFE, which we are initially to shake out the code, but don't depend
12936 on this), otherwise go ahead and do whatever is needed.
12938 In essence, then, when this fn and _exec_transition get called while
12939 backtracking is enabled, a general mechanism would be to flag which (or
12940 both) of these were called (and in what order? neat question as to what
12941 might happen that I'm too lame to think through right now) and then when
12942 _commit is called reproduce the original calling sequence, if any, for
12943 the two fns (at which point backtracking will, of course, be disabled). */
12945 ffesymbol
12947 {
12951 }
12953 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12955 ffesymbol s;
12956 ffecom_sym_retract(s);
12958 Does whatever the backend needs when a symbol is retracted after having
12959 been backtrackable for a period of time. */
12961 void
12963 {
12967 so nothing needed here. */
12969 {
12988 }
12989 #endif
12990 }
12992 /* Create temporary gcc label. */
12994 tree
12996 {
12997 tree glabel;
13002 mynumber++),
13003 void_type_node);
13008 }
13010 /* Return an expression that is usable as an arg in a conditional context
13011 (IF, DO WHILE, .NOT., and so on).
13013 Use the one provided for the back end as of >2.6.0. */
13015 tree
13017 {
13019 }
13021 /* Return the inversion of a truth value (the inversion of what
13022 ffecom_truth_value builds).
13024 Apparently invert_truthvalue, which is properly in the back end, is
13025 enough for now, so just use it. */
13027 tree
13029 {
13031 }
13033 /* Return the tree that is the type of the expression, as would be
13034 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13035 transforming the expression, generating temporaries, etc. */
13037 tree
13039 {
13040 ffeinfoBasictype bt;
13041 ffeinfoKindtype kt;
13042 tree tree_type;
13051 {
13094 /* Fall through. */
13097 }
13098 }
13100 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13102 If the PARM_DECL already exists, return it, else create it. It's an
13103 integer_type_node argument for the master function that implements a
13104 subroutine or function with more than one entrypoint and is bound at
13105 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13106 first ENTRY statement, and so on). */
13108 tree
13110 {
13114 }
13115 \f
13116 /* The following sections consists of private and public functions
13117 that have the same names and perform roughly the same functions
13118 as counterparts in the C front end. Changes in the C front end
13119 might affect how things should be done here. Only functions
13120 needed by the back end should be public here; the rest should
13121 be private (static in the C sense). Functions needed by other
13122 g77 front-end modules should be accessed by them via public
13123 ffecom_* names, which should themselves call private versions
13124 in this section so the private versions are easy to recognize
13125 when upgrading to a new gcc and finding interesting changes
13126 in the front end.
13128 Functions named after rule "foo:" in c-parse.y are named
13129 "bison_rule_foo_" so they are easy to find. */
13131 static void
13133 {
13138 }
13140 static tree
13142 {
13143 tree t;
13146 /* Make the temps go away. */
13155 }
13157 /* Return a definition for a builtin function named NAME and whose data type
13158 is TYPE. TYPE should be a function type with argument types.
13159 FUNCTION_CODE tells later passes how to compile calls to this function.
13160 See tree.h for its possible values.
13162 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13163 the name to be called if we can't opencode the function. If
13164 ATTRS is nonzero, use that for the function's attribute list. */
13166 tree
13170 tree attrs ATTRIBUTE_UNUSED)
13171 {
13183 }
13185 /* Handle when a new declaration NEWDECL
13186 has the same name as an old one OLDDECL
13187 in the same binding contour.
13188 Prints an error message if appropriate.
13190 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13191 Otherwise, return 0. */
13193 static int
13195 {
13209 /* New decl is completely inconsistent with the old one =>
13210 tell caller to replace the old one.
13211 This is always an error except in the case of shadowing a builtin. */
13215 /* For real parm decl following a forward decl,
13216 return 1 so old decl will be reused. */
13221 /* The new declaration is the same kind of object as the old one.
13222 The declarations may partially match. Print warnings if they don't
13223 match enough. Ultimately, copy most of the information from the new
13224 decl to the old one, and keep using the old one. */
13228 {
13229 /* A function declaration for a built-in function. */
13233 {
13234 /* Accept the return type of the new declaration if same modes. */
13239 {
13240 /* Function types may be shared, so we can't just modify
13241 the return type of olddecl's function type. */
13242 tree newtype
13249 }
13250 }
13253 }
13256 {
13257 /* A function declaration for a predeclared function
13258 that isn't actually built in. */
13262 {
13263 /* If the types don't match, preserve volatility indication.
13264 Later on, we will discard everything else about the
13265 default declaration. */
13267 }
13268 }
13270 /* Copy all the DECL_... slots specified in the new decl
13271 except for any that we copy here from the old type.
13273 Past this point, we don't change OLDTYPE and NEWTYPE
13274 even if we change the types of NEWDECL and OLDDECL. */
13277 {
13278 /* Merge the data types specified in the two decls. */
13284 /* Lay the type out, unless already done. */
13286 {
13293 }
13294 else
13295 {
13296 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13301 {
13304 }
13305 }
13307 /* Keep the old rtl since we can safely use it. */
13310 /* Merge the type qualifiers. */
13314 {
13318 }
13320 /* Keep source location of definition rather than declaration.
13321 Likewise, keep decl at outer scope. */
13324 {
13331 }
13333 /* Merge the unused-warning information. */
13339 /* Merge the initialization information. */
13343 /* Merge the section attribute.
13344 We want to issue an error if the sections conflict but that must be
13345 done later in decl_attributes since we are called before attributes
13346 are assigned. */
13350 /* Copy the assembler name. */
13354 {
13361 }
13362 }
13363 /* If cannot merge, then use the new type and qualifiers,
13364 and don't preserve the old rtl. */
13365 else
13366 {
13371 }
13373 /* Merge the storage class information. */
13374 /* For functions, static overrides non-static. */
13376 {
13378 /* This is since we don't automatically
13379 copy the attributes of NEWDECL into OLDDECL. */
13381 /* If this clears `static', clear it in the identifier too. */
13384 }
13386 {
13389 /* An extern decl does not override previous storage class. */
13391 }
13392 else
13393 {
13396 }
13398 /* If either decl says `inline', this fn is inline,
13399 unless its definition was passed already. */
13404 /* Get rid of any built-in function if new arg types don't match it
13405 or if we have a function definition. */
13409 {
13412 }
13414 /* If redeclaring a builtin function, and not a definition,
13415 it stays built in.
13416 Also preserve various other info from the definition. */
13418 {
13420 {
13423 }
13429 }
13431 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13432 But preserve olddecl's DECL_UID. */
13433 {
13440 }
13443 }
13445 /* Finish processing of a declaration;
13446 install its initial value.
13447 If the length of an array type is not known before,
13448 it must be determined now, from the initial value, or it is an error. */
13450 static void
13452 {
13458 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13459 level anyway. */
13464 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13465 overlaps DECL_ARG_TYPE. */
13468 else
13472 {
13475 else
13476 {
13477 /* typedef foo = bar; store the type of bar as the type of foo. */
13480 }
13481 }
13483 /* Deduce size of array from initialization, if not already known */
13488 {
13493 }
13496 {
13503 ?
13504 /* A static variable with an incomplete type is an error if it is
13505 initialized. Also if it is not file scope. Otherwise, let it
13506 through, but if it is not `extern' then it may cause an error
13507 message later. */
13509 :
13510 /* An automatic variable with an incomplete type is an error. */
13512 {
13515 }
13520 {
13523 }
13524 }
13526 /* Output the assembler code and/or RTL code for variables and functions,
13527 unless the type is an undefined structure or union. If not, it will get
13528 done when the type is completed. */
13531 {
13537 {
13538 /* Recompute the RTL of a local array now if it used to be an
13539 incomplete type. */
13542 {
13543 /* If we used it already as memory, it must stay in memory. */
13545 /* If it's still incomplete now, no init will save it. */
13549 }
13550 /* Compute and store the initial value. */
13553 }
13554 }
13556 {
13560 }
13562 /* At the end of a declaration, throw away any variable type sizes of types
13563 defined inside that declaration. There is no use computing them in the
13564 following function definition. */
13567 }
13569 /* Finish up a function declaration and compile that function
13570 all the way to assembler language output. The free the storage
13571 for the function definition.
13573 This is called after parsing the body of the function definition.
13575 NESTED is nonzero if the function being finished is nested in another. */
13577 static void
13579 {
13584 {
13587 else
13589 }
13591 /* TREE_READONLY (fndecl) = 1;
13592 This caused &foo to be of type ptr-to-const-function
13593 which then got a warning when stored in a ptr-to-function variable. */
13598 {
13601 /* Must mark the RESULT_DECL as being in this function. */
13605 /* Obey `register' declarations if `setjmp' is called in this fn. */
13606 /* Generate rtl for function exit. */
13609 /* If this is a nested function, protect the local variables in the stack
13610 above us from being collected while we're compiling this function. */
13614 /* Run the optimizers and output the assembler code for this function. */
13617 /* Undo the GC context switch. */
13620 }
13623 && !nested
13625 {
13626 /* Stop pointing to the local nodes about to be freed. */
13627 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13628 function definition. */
13629 /* For a nested function, this is done in pop_f_function_context. */
13630 /* If rest_of_compilation set this to 0, leave it 0. */
13634 }
13637 {
13638 /* Let the error reporting routines know that we're outside a function.
13639 For a nested function, this value is used in pop_c_function_context
13640 and then reset via pop_function_context. */
13642 }
13643 }
13645 /* Plug-in replacement for identifying the name of a decl and, for a
13646 function, what we call it in diagnostics. For now, "program unit"
13647 should suffice, since it's a bit of a hassle to figure out which
13648 of several kinds of things it is. Note that it could conceivably
13649 be a statement function, which probably isn't really a program unit
13650 per se, but if that comes up, it should be easy to check (being a
13651 nested function and all). */
13655 {
13656 /* Just to keep GCC quiet about the unused variable.
13657 In theory, differing values of V should produce different
13658 output. */
13660 {
13665 }
13666 }
13668 /* g77's function to print out name of current function that caused
13669 an error. */
13671 static void
13674 {
13677 ffeglobal g;
13678 ffesymbol s;
13683 {
13687 }
13688 else
13689 {
13692 {
13695 }
13696 else
13697 {
13700 }
13701 }
13704 {
13710 else
13711 {
13715 }
13719 }
13720 }
13722 /* Similar to `lookup_name' but look only at current binding level. */
13724 static tree
13726 {
13740 }
13742 /* Create a new `struct f_binding_level'. */
13746 {
13747 /* NOSTRICT */
13749 }
13751 /* Save and restore the variables in this file and elsewhere
13752 that keep track of the progress of compilation of the current function.
13753 Used for nested functions. */
13755 struct f_function
13756 {
13758 tree named_labels;
13759 tree shadowed_labels;
13761 };
13765 /* Restore the variables used during compilation of a C function. */
13767 static void
13769 {
13771 tree link;
13773 /* Bring back all the labels that were shadowed. */
13781 {
13782 /* Stop pointing to the local nodes about to be freed. */
13783 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13784 function definition. */
13787 }
13798 }
13800 /* Save and reinitialize the variables
13801 used during compilation of a C function. */
13803 static void
13805 {
13817 }
13819 static void
13821 {
13824 /* Don't try computing parm sizes now -- wait till fn is called. */
13828 /* Fill in arg stuff. */
13839 }
13841 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
13843 static tree
13845 {
13856 }
13858 /* Store the list of declarations of the current level.
13859 This is done for the parameter declarations of a function being defined,
13860 after they are modified in the light of any missing parameters. */
13862 static tree
13864 {
13866 }
13868 /* Store the parameter declarations into the current function declaration.
13869 This is called after parsing the parameter declarations, before
13870 digesting the body of the function.
13872 For an old-style definition, modify the function's type
13873 to specify at least the number of arguments. */
13875 static void
13877 {
13883 /* This is a chain of PARM_DECLs from old-style parm declarations. */
13886 /* Initialize the RTL code for the function. */
13889 /* Set up parameters and prepare for return, for the function. */
13891 }
13893 static tree
13895 {
13900 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13901 level anyway. */
13905 {
13908 }
13912 /* For Fortran, we by default put things in .common when possible. */
13915 /* Add this decl to the current binding level. TEM may equal DECL or it may
13916 be a previous decl of the same name. */
13919 else
13922 /* For a local variable, define the RTL now. */
13924 /* But not if this is a duplicate decl and we preserved the rtl from the
13925 previous one (which may or may not happen). */
13927 {
13933 }
13936 }
13938 /* Create the FUNCTION_DECL for a function definition.
13939 DECLSPECS and DECLARATOR are the parts of the declaration;
13940 they describe the function's name and the type it returns,
13941 but twisted together in a fashion that parallels the syntax of C.
13943 This function creates a binding context for the function body
13944 as well as setting up the FUNCTION_DECL in current_function_decl.
13946 Returns 1 on success. If the DECLARATOR is not suitable for a function
13947 (it defines a datum instead), we return 0, which tells
13948 ffe_parse_file to report a parse error.
13950 NESTED is nonzero for a function nested within another function. */
13952 static void
13954 {
13955 tree decl1;
13956 tree restype;
13962 /* Don't expand any sizes in the return type of the function. */
13966 {
13970 }
13971 else
13972 {
13974 }
13978 else
13979 {
13981 name,
13982 type);
13991 /* Make the init_value nonzero so pushdecl knows this is not tentative.
13992 error_mark_node is replaced below (in poplevel) with the BLOCK. */
13995 /* Record the decl so that the function name is defined. If we already have
13996 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
13999 }
14008 {
14014 }
14020 }
14021 \f
14022 /* Here are the public functions the GNU back end needs. */
14024 tree
14026 {
14039 {
14042 }
14048 e);
14062 }
14064 /* Return the list of declarations of the current level.
14065 Note that this list is in reverse order unless/until
14066 you nreverse it; and when you do nreverse it, you must
14067 store the result back using `storedecls' or you will lose. */
14069 tree
14071 {
14073 }
14075 /* Nonzero if we are currently in the global binding level. */
14077 int
14079 {
14081 }
14083 static void
14085 {
14089 }
14091 /* Delete the node BLOCK from the current binding level.
14092 This is used for the block inside a stmt expr ({...})
14093 so that the block can be reinserted where appropriate. */
14095 static void
14097 {
14098 tree t;
14102 {
14105 else
14107 }
14109 /* Clear TREE_USED which is always set by poplevel.
14110 The flag is set again if insert_block is called. */
14112 }
14114 void
14116 {
14118 current_binding_level->blocks
14120 }
14122 /* Each front end provides its own. */
14129 {
14131 };
14133 #undef LANG_HOOKS_NAME
14135 #undef LANG_HOOKS_INIT
14136 #define LANG_HOOKS_INIT ffe_init
14137 #undef LANG_HOOKS_FINISH
14138 #define LANG_HOOKS_FINISH ffe_finish
14139 #undef LANG_HOOKS_INIT_OPTIONS
14140 #define LANG_HOOKS_INIT_OPTIONS ffe_init_options
14141 #undef LANG_HOOKS_HANDLE_OPTION
14142 #define LANG_HOOKS_HANDLE_OPTION ffe_handle_option
14143 #undef LANG_HOOKS_POST_OPTIONS
14144 #define LANG_HOOKS_POST_OPTIONS ffe_post_options
14145 #undef LANG_HOOKS_PARSE_FILE
14146 #define LANG_HOOKS_PARSE_FILE ffe_parse_file
14147 #undef LANG_HOOKS_MARK_ADDRESSABLE
14148 #define LANG_HOOKS_MARK_ADDRESSABLE ffe_mark_addressable
14149 #undef LANG_HOOKS_PRINT_IDENTIFIER
14150 #define LANG_HOOKS_PRINT_IDENTIFIER ffe_print_identifier
14151 #undef LANG_HOOKS_DECL_PRINTABLE_NAME
14152 #define LANG_HOOKS_DECL_PRINTABLE_NAME ffe_printable_name
14153 #undef LANG_HOOKS_PRINT_ERROR_FUNCTION
14154 #define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function
14155 #undef LANG_HOOKS_TRUTHVALUE_CONVERSION
14156 #define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion
14158 #undef LANG_HOOKS_TYPE_FOR_MODE
14159 #define LANG_HOOKS_TYPE_FOR_MODE ffe_type_for_mode
14160 #undef LANG_HOOKS_TYPE_FOR_SIZE
14161 #define LANG_HOOKS_TYPE_FOR_SIZE ffe_type_for_size
14162 #undef LANG_HOOKS_SIGNED_TYPE
14163 #define LANG_HOOKS_SIGNED_TYPE ffe_signed_type
14164 #undef LANG_HOOKS_UNSIGNED_TYPE
14165 #define LANG_HOOKS_UNSIGNED_TYPE ffe_unsigned_type
14166 #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
14167 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type
14169 /* We do not wish to use alias-set based aliasing at all. Used in the
14170 extreme (every object with its own set, with equivalences recorded) it
14171 might be helpful, but there are problems when it comes to inlining. We
14172 get on ok with flag_argument_noalias, and alias-set aliasing does
14173 currently limit how stack slots can be reused, which is a lose. */
14174 #undef LANG_HOOKS_GET_ALIAS_SET
14175 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14179 /* Table indexed by tree code giving a string containing a character
14180 classifying the tree code. Possibilities are
14181 t, d, s, c, r, <, 1, 2 and e. See tree.def for details. */
14183 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14187 };
14188 #undef DEFTREECODE
14190 /* Table indexed by tree code giving number of expression
14191 operands beyond the fixed part of the node structure.
14192 Not used for types or decls. */
14194 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14198 };
14199 #undef DEFTREECODE
14201 /* Names of tree components.
14202 Used for printing out the tree and error messages. */
14203 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14207 };
14208 #undef DEFTREECODE
14210 static bool
14213 {
14216 /* Open input file. */
14218 {
14221 }
14222 else
14229 }
14232 static bool
14234 {
14235 #ifdef IO_BUFFER_SIZE
14237 #endif
14241 /* If the file is output from cpp, it should contain a first line
14242 `# 1 "real-filename"', and the current design of gcc (toplev.c
14243 in particular and the way it sets up information relied on by
14244 INCLUDE) requires that we read this now, and store the
14245 "real-filename" info in master_input_filename. Ask the lexer
14246 to try doing this. */
14249 /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14250 set the new file name. Maybe in ffe_post_options. */
14252 }
14254 static void
14256 {
14263 }
14265 static bool
14267 {
14271 {
14288 {
14290 {
14293 }
14295 }
14297 {
14299 {
14302 }
14304 }
14307 /* drops in */
14313 #endif
14317 }
14318 }
14320 /* Exit a binding level.
14321 Pop the level off, and restore the state of the identifier-decl mappings
14322 that were in effect when this level was entered.
14324 If KEEP is nonzero, this level had explicit declarations, so
14325 and create a "block" (a BLOCK node) for the level
14326 to record its declarations and subblocks for symbol table output.
14328 If FUNCTIONBODY is nonzero, this level is the body of a function,
14329 so create a block as if KEEP were set and also clear out all
14330 label names.
14332 If REVERSE is nonzero, reverse the order of decls before putting
14333 them into the BLOCK. */
14335 tree
14337 {
14339 /* The chain of decls was accumulated in reverse order.
14340 Put it into forward order, just for cleanliness. */
14341 tree decls;
14344 tree decl;
14347 /* Get the decls in the order they were written.
14348 Usually current_binding_level->names is in reverse order.
14349 But parameter decls were previously put in forward order. */
14352 current_binding_level->names
14354 else
14357 /* Output any nested inline functions within this block
14358 if they weren't already output. */
14365 {
14366 /* If this decl was copied from a file-scope decl
14367 on account of a block-scope extern decl,
14368 propagate TREE_ADDRESSABLE to the file-scope decl.
14370 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14371 true, since then the decl goes through save_for_inline_copying. */
14376 {
14380 }
14381 }
14383 /* If there were any declarations or structure tags in that level,
14384 or if this level is a function body,
14385 create a BLOCK to record them for the life of this function. */
14394 {
14397 }
14399 /* In each subblock, record that this is its superior. */
14404 /* Clear out the meanings of the local variables of this level. */
14407 {
14409 {
14410 /* If the ident. was used or addressed via a local extern decl,
14411 don't forget that fact. */
14413 {
14418 }
14420 }
14421 }
14423 /* If the level being exited is the top level of a function,
14424 check over all the labels, and clear out the current
14425 (function local) meanings of their names. */
14428 {
14429 /* If this is the top level block of a function,
14430 the vars are the function's parameters.
14431 Don't leave them in the BLOCK because they are
14432 found in the FUNCTION_DECL instead. */
14435 }
14437 /* Pop the current level, and free the structure for reuse. */
14439 {
14445 }
14447 /* Dispose of the block that we just made inside some higher level. */
14452 {
14454 current_binding_level->blocks
14456 }
14457 /* If we did not make a block for the level just exited,
14458 any blocks made for inner levels
14459 (since they cannot be recorded as subblocks in that level)
14460 must be carried forward so they will later become subblocks
14461 of something else. */
14463 current_binding_level->blocks
14469 }
14471 static void
14473 {
14476 }
14478 /* Record a decl-node X as belonging to the current lexical scope.
14479 Check for errors (such as an incompatible declaration for the same
14480 name already seen in the same scope).
14482 Returns either X or an old decl for the same name.
14483 If an old decl is returned, it may have been smashed
14484 to agree with what X says. */
14486 tree
14488 {
14497 else
14501 {
14503 {
14506 }
14512 /* Don't push non-parms onto list for parms until we understand
14513 why we're doing this and whether it works. */
14516 || !ffecom_transform_only_dummies_
14522 /* If we are processing a typedef statement, generate a whole new
14523 ..._TYPE node (which will be just an variant of the existing
14524 ..._TYPE node with identical properties) and then install the
14525 TYPE_DECL node generated to represent the typedef name as the
14526 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14528 The whole point here is to end up with a situation where each and every
14529 ..._TYPE node the compiler creates will be uniquely associated with
14530 AT MOST one node representing a typedef name. This way, even though
14531 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14532 (i.e. "typedef name") nodes very early on, later parts of the
14533 compiler can always do the reverse translation and get back the
14534 corresponding typedef name. For example, given:
14536 typedef struct S MY_TYPE; MY_TYPE object;
14538 Later parts of the compiler might only know that `object' was of type
14539 `struct S' if it were not for code just below. With this code
14540 however, later parts of the compiler see something like:
14542 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14544 And they can then deduce (from the node for type struct S') that the
14545 original object declaration was:
14547 MY_TYPE object;
14549 Being able to do this is important for proper support of protoize, and
14550 also for generating precise symbolic debugging information which
14551 takes full account of the programmer's (typedef) vocabulary.
14553 Obviously, we don't want to generate a duplicate ..._TYPE node if the
14554 TYPE_DECL node that we are now processing really represents a
14555 standard built-in type.
14557 Since all standard types are effectively declared at line zero in the
14558 source file, we can easily check to see if we are working on a
14559 standard type by checking the current value of lineno. */
14562 {
14564 {
14567 }
14569 {
14575 }
14576 }
14578 /* This name is new in its binding level. Install the new declaration
14579 and return it. */
14582 else
14584 }
14586 /* Put decls on list in reverse order. We will reverse them later if
14587 necessary. */
14592 }
14594 /* Nonzero if the current level needs to have a BLOCK made. */
14596 static int
14598 {
14599 tree decl;
14602 decl;
14604 {
14607 /* Currently, there aren't supposed to be non-artificial names
14608 at other than the top block for a function -- they're
14609 believed to always be temps. But it's wise to check anyway. */
14611 }
14613 }
14615 /* Enter a new binding level.
14616 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14617 not for that of tags. */
14619 void
14621 {
14627 {
14629 }
14631 /* Reuse or create a struct for this binding level. */
14634 {
14637 }
14638 else
14639 {
14641 }
14643 /* Add this level to the front of the chain (stack) of levels that
14644 are active. */
14649 }
14651 /* Set the BLOCK node for the innermost scope
14652 (the one we are currently in). */
14654 void
14656 {
14662 }
14664 static tree
14666 {
14667 tree type2;
14688 }
14690 static tree
14692 {
14694 ffeinfoKindtype kt;
14695 tree type2;
14716 #endif
14723 {
14728 }
14731 }
14733 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14734 or validate its data type for an `if' or `while' statement or ?..: exp.
14736 This preparation consists of taking the ordinary
14737 representation of an expression expr and producing a valid tree
14738 boolean expression describing whether expr is nonzero. We could
14739 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14740 but we optimize comparisons, &&, ||, and !.
14742 The resulting type should always be `integer_type_node'. */
14744 static tree
14746 {
14751 /* These really should return error_mark_node after 2.4 is stable.
14752 But not all callers handle ERROR_MARK properly. */
14754 {
14769 }
14773 {
14774 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14775 or comparison expressions as truth values at this level. */
14776 #if 0
14778 /* A one-bit unsigned bit-field is already acceptable. */
14783 #endif
14786 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14787 or comparison expressions as truth values at this level. */
14788 #if 0
14791 #endif
14814 else
14820 integer_type_node,
14828 /* These don't change whether an object is nonzero or zero. */
14833 /* These don't change whether an object is zero or nonzero, but
14834 we can't ignore them if their second arg has side-effects. */
14838 else
14842 {
14843 /* Distribute the conversion into the arms of a COND_EXPR. */
14852 }
14855 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14856 since that affects how `default_conversion' will behave. */
14860 /* fall through... */
14862 /* If this is widening the argument, we can ignore it. */
14869 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14870 this case. */
14874 /* fall through... */
14876 /* This and MINUS_EXPR can be changed into a comparison of the
14877 two objects. */
14898 #endif
14903 }
14909 integer_type_node,
14912 expr)),
14915 expr))));
14918 expr,
14920 }
14922 static tree
14924 {
14927 tree t;
14944 #if HOST_BITS_PER_WIDE_INT >= 64
14947 #endif
14966 {
14969 {
14972 else
14974 }
14975 }
14978 }
14980 static tree
14982 {
14983 ffeinfoKindtype kt;
14984 tree type_node;
15003 {
15009 }
15012 }
15014 static tree
15016 {
15018 ffeinfoKindtype kt;
15019 tree type2;
15040 #endif
15047 {
15052 }
15055 }
15056 \f
15057 /* From gcc/cccp.c, the code to handle -I. */
15059 /* Skip leading "./" from a directory name.
15060 This may yield the empty string, which represents the current directory. */
15064 {
15069 dir++;
15071 }
15073 /* The file_name_map structure holds a mapping of file names for a
15074 particular directory. This mapping is read from the file named
15075 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15076 map filenames on a file system with severe filename restrictions,
15077 such as DOS. The format of the file name map file is just a series
15078 of lines with two tokens on each line. The first token is the name
15079 to map, and the second token is the actual name to use. */
15081 struct file_name_map
15082 {
15086 };
15090 /* Current maximum length of directory names in the search path
15091 for include files. (Altered as we get more of them.) */
15095 struct file_name_list
15096 {
15099 /* Mapping of file names for this directory. */
15101 /* Nonzero if name_map is valid. */
15103 };
15108 /* I/O buffer structure.
15109 The `fname' field is nonzero for source files and #include files
15110 and for the dummy text used for -D and -U.
15111 It is zero for rescanning results of macro expansion
15112 and for expanding macro arguments. */
15113 #define INPUT_STACK_MAX 400
15116 /* Filename specified with #line command. */
15118 /* Record where in the search path this file was found.
15119 For #include_next. */
15121 ffewhereLine line;
15122 ffewhereColumn column;
15128 /* Current nesting level of input sources.
15129 `instack[indepth]' is the level currently being read. */
15134 /* Nonzero means -I- has been seen,
15135 so don't look for #include "foo" the source-file directory. */
15138 #ifndef INCLUDE_LEN_FUDGE
15139 #define INCLUDE_LEN_FUDGE 0
15140 #endif
15150 /* Append a chain of `struct file_name_list's
15151 to the end of the main include chain.
15152 FIRST is the beginning of the chain to append, and LAST is the end. */
15154 static void
15156 {
15164 else
15173 }
15177 }
15179 /* Try to open include file FILENAME. SEARCHPTR is the directory
15180 being tried from the include file search path. This function maps
15181 filenames on file systems based on information read by
15182 read_name_map. */
15186 {
15192 {
15196 }
15198 /* First check the mapping for the directory we are using. */
15200 {
15205 {
15207 {
15208 /* Found a match. */
15210 }
15211 }
15212 }
15214 /* Try to find a mapping file for the particular directory we are
15215 looking in. Thus #include <sys/types.h> will look up sys/types.h
15216 in /usr/include/header.gcc and look up types.h in
15217 /usr/include/sys/header.gcc. */
15219 #ifdef DIR_SEPARATOR
15224 }
15225 #endif
15232 {
15233 /* FILENAME is in SEARCHPTR, which we've already checked. */
15235 }
15238 {
15241 }
15242 else
15243 {
15250 }
15256 }
15258 /* Print the file names and line numbers of the #include
15259 commands which led to the current file. */
15261 static void
15263 {
15270 /* If stack of files hasn't changed since we last printed
15271 this info, don't repeat it. */
15279 }
15281 /* Give up if we don't find a source file. */
15285 /* Find the other, outer source files. */
15288 {
15291 {
15294 }
15295 else
15296 {
15298 }
15302 else
15305 /* xgettext:no-c-format */
15312 }
15314 /* Record we have printed the status as of this time. */
15316 }
15318 /* Read a space delimited string of unlimited length from a stdio
15319 file. */
15323 {
15330 {
15333 {
15335 {
15339 }
15341 }
15342 }
15346 }
15348 /* Read the file name map file for DIRNAME. */
15352 {
15353 /* This structure holds a linked list of file name maps, one per
15354 directory. */
15355 struct file_name_map_list
15356 {
15360 };
15384 else
15390 else
15391 {
15395 {
15403 ;
15410 /* Make the real filename absolute. */
15413 else
15414 {
15417 else
15420 }
15428 }
15430 }
15436 }
15438 static void
15440 {
15443 /* Do partial setup of input buffer for the sake of generating
15444 early #line directives (when -g is in effect). */
15451 }
15453 static void
15455 {
15458 indepth--;
15459 input_file_stack_tick++;
15463 }
15465 void
15467 {
15470 else
15471 {
15478 }
15479 }
15481 /* Open INCLUDEd file. */
15485 {
15500 /* If -I- was specified, don't search current dir, only spec'd ones. */
15502 {
15504 {
15510 {
15511 /* Found a named file. Figure out dir of the file,
15512 and put it in front of the search list. */
15515 #ifndef VMS
15517 #ifdef DIR_SEPARATOR
15522 }
15523 #endif
15531 {
15539 }
15540 else
15544 }
15545 }
15546 }
15548 /* Allocate this permanently, because it gets stored in the definitions
15549 of macros. */
15551 /* + 2 above for slash and terminating null. */
15552 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15553 for g77 yet). */
15555 /* If specified file name is absolute, just open it. */
15558 #ifdef DIR_SEPARATOR
15560 #endif
15561 )
15562 {
15566 }
15567 else
15568 {
15571 /* Search directory path, trying to open the file.
15572 Copy each filename tried into FNAME. */
15575 {
15577 {
15578 /* The empty string in a search path is ignored.
15579 This makes it possible to turn off entirely
15580 a standard piece of the list. */
15587 }
15588 else
15592 #ifdef VMS
15593 /* Change this 1/2 Unix 1/2 VMS file specification into a
15594 full VMS file specification */
15596 {
15597 /* Fix up the filename */
15599 }
15600 else
15601 {
15602 /* This is a normal VMS filespec, so use it unchanged. */
15606 /* if it's '#include filename', add the missing .h */
15609 #endif
15610 }
15613 #ifdef EACCES
15615 {
15617 /* xgettext:no-c-format */
15619 FFEBAD_severityWARNING);
15623 }
15624 #endif
15627 }
15628 }
15631 {
15632 /* A file that was not found. */
15641 }
15650 {
15652 /* xgettext:no-c-format */
15654 FFEBAD_severityFATAL);
15659 }
15669 indepth++;
15670 input_file_stack_tick++;
15673 }
15675 /**INDENT* (Do not reformat this comment even with -fca option.)
15676 Data-gathering files: Given the source file listed below, compiled with
15677 f2c I obtained the output file listed after that, and from the output
15678 file I derived the above code.
15680 -------- (begin input file to f2c)
15681 implicit none
15682 character*10 A1,A2
15683 complex C1,C2
15684 integer I1,I2
15685 real R1,R2
15686 double precision D1,D2
15687 C
15688 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15689 c /
15690 call fooI(I1/I2)
15691 call fooR(R1/I1)
15692 call fooD(D1/I1)
15693 call fooC(C1/I1)
15694 call fooR(R1/R2)
15695 call fooD(R1/D1)
15696 call fooD(D1/D2)
15697 call fooD(D1/R1)
15698 call fooC(C1/C2)
15699 call fooC(C1/R1)
15700 call fooZ(C1/D1)
15701 c **
15702 call fooI(I1**I2)
15703 call fooR(R1**I1)
15704 call fooD(D1**I1)
15705 call fooC(C1**I1)
15706 call fooR(R1**R2)
15707 call fooD(R1**D1)
15708 call fooD(D1**D2)
15709 call fooD(D1**R1)
15710 call fooC(C1**C2)
15711 call fooC(C1**R1)
15712 call fooZ(C1**D1)
15713 c FFEINTRIN_impABS
15714 call fooR(ABS(R1))
15715 c FFEINTRIN_impACOS
15716 call fooR(ACOS(R1))
15717 c FFEINTRIN_impAIMAG
15718 call fooR(AIMAG(C1))
15719 c FFEINTRIN_impAINT
15720 call fooR(AINT(R1))
15721 c FFEINTRIN_impALOG
15722 call fooR(ALOG(R1))
15723 c FFEINTRIN_impALOG10
15724 call fooR(ALOG10(R1))
15725 c FFEINTRIN_impAMAX0
15726 call fooR(AMAX0(I1,I2))
15727 c FFEINTRIN_impAMAX1
15728 call fooR(AMAX1(R1,R2))
15729 c FFEINTRIN_impAMIN0
15730 call fooR(AMIN0(I1,I2))
15731 c FFEINTRIN_impAMIN1
15732 call fooR(AMIN1(R1,R2))
15733 c FFEINTRIN_impAMOD
15734 call fooR(AMOD(R1,R2))
15735 c FFEINTRIN_impANINT
15736 call fooR(ANINT(R1))
15737 c FFEINTRIN_impASIN
15738 call fooR(ASIN(R1))
15739 c FFEINTRIN_impATAN
15740 call fooR(ATAN(R1))
15741 c FFEINTRIN_impATAN2
15742 call fooR(ATAN2(R1,R2))
15743 c FFEINTRIN_impCABS
15744 call fooR(CABS(C1))
15745 c FFEINTRIN_impCCOS
15746 call fooC(CCOS(C1))
15747 c FFEINTRIN_impCEXP
15748 call fooC(CEXP(C1))
15749 c FFEINTRIN_impCHAR
15750 call fooA(CHAR(I1))
15751 c FFEINTRIN_impCLOG
15752 call fooC(CLOG(C1))
15753 c FFEINTRIN_impCONJG
15754 call fooC(CONJG(C1))
15755 c FFEINTRIN_impCOS
15756 call fooR(COS(R1))
15757 c FFEINTRIN_impCOSH
15758 call fooR(COSH(R1))
15759 c FFEINTRIN_impCSIN
15760 call fooC(CSIN(C1))
15761 c FFEINTRIN_impCSQRT
15762 call fooC(CSQRT(C1))
15763 c FFEINTRIN_impDABS
15764 call fooD(DABS(D1))
15765 c FFEINTRIN_impDACOS
15766 call fooD(DACOS(D1))
15767 c FFEINTRIN_impDASIN
15768 call fooD(DASIN(D1))
15769 c FFEINTRIN_impDATAN
15770 call fooD(DATAN(D1))
15771 c FFEINTRIN_impDATAN2
15772 call fooD(DATAN2(D1,D2))
15773 c FFEINTRIN_impDCOS
15774 call fooD(DCOS(D1))
15775 c FFEINTRIN_impDCOSH
15776 call fooD(DCOSH(D1))
15777 c FFEINTRIN_impDDIM
15778 call fooD(DDIM(D1,D2))
15779 c FFEINTRIN_impDEXP
15780 call fooD(DEXP(D1))
15781 c FFEINTRIN_impDIM
15782 call fooR(DIM(R1,R2))
15783 c FFEINTRIN_impDINT
15784 call fooD(DINT(D1))
15785 c FFEINTRIN_impDLOG
15786 call fooD(DLOG(D1))
15787 c FFEINTRIN_impDLOG10
15788 call fooD(DLOG10(D1))
15789 c FFEINTRIN_impDMAX1
15790 call fooD(DMAX1(D1,D2))
15791 c FFEINTRIN_impDMIN1
15792 call fooD(DMIN1(D1,D2))
15793 c FFEINTRIN_impDMOD
15794 call fooD(DMOD(D1,D2))
15795 c FFEINTRIN_impDNINT
15796 call fooD(DNINT(D1))
15797 c FFEINTRIN_impDPROD
15798 call fooD(DPROD(R1,R2))
15799 c FFEINTRIN_impDSIGN
15800 call fooD(DSIGN(D1,D2))
15801 c FFEINTRIN_impDSIN
15802 call fooD(DSIN(D1))
15803 c FFEINTRIN_impDSINH
15804 call fooD(DSINH(D1))
15805 c FFEINTRIN_impDSQRT
15806 call fooD(DSQRT(D1))
15807 c FFEINTRIN_impDTAN
15808 call fooD(DTAN(D1))
15809 c FFEINTRIN_impDTANH
15810 call fooD(DTANH(D1))
15811 c FFEINTRIN_impEXP
15812 call fooR(EXP(R1))
15813 c FFEINTRIN_impIABS
15814 call fooI(IABS(I1))
15815 c FFEINTRIN_impICHAR
15816 call fooI(ICHAR(A1))
15817 c FFEINTRIN_impIDIM
15818 call fooI(IDIM(I1,I2))
15819 c FFEINTRIN_impIDNINT
15820 call fooI(IDNINT(D1))
15821 c FFEINTRIN_impINDEX
15822 call fooI(INDEX(A1,A2))
15823 c FFEINTRIN_impISIGN
15824 call fooI(ISIGN(I1,I2))
15825 c FFEINTRIN_impLEN
15826 call fooI(LEN(A1))
15827 c FFEINTRIN_impLGE
15828 call fooL(LGE(A1,A2))
15829 c FFEINTRIN_impLGT
15830 call fooL(LGT(A1,A2))
15831 c FFEINTRIN_impLLE
15832 call fooL(LLE(A1,A2))
15833 c FFEINTRIN_impLLT
15834 call fooL(LLT(A1,A2))
15835 c FFEINTRIN_impMAX0
15836 call fooI(MAX0(I1,I2))
15837 c FFEINTRIN_impMAX1
15838 call fooI(MAX1(R1,R2))
15839 c FFEINTRIN_impMIN0
15840 call fooI(MIN0(I1,I2))
15841 c FFEINTRIN_impMIN1
15842 call fooI(MIN1(R1,R2))
15843 c FFEINTRIN_impMOD
15844 call fooI(MOD(I1,I2))
15845 c FFEINTRIN_impNINT
15846 call fooI(NINT(R1))
15847 c FFEINTRIN_impSIGN
15848 call fooR(SIGN(R1,R2))
15849 c FFEINTRIN_impSIN
15850 call fooR(SIN(R1))
15851 c FFEINTRIN_impSINH
15852 call fooR(SINH(R1))
15853 c FFEINTRIN_impSQRT
15854 call fooR(SQRT(R1))
15855 c FFEINTRIN_impTAN
15856 call fooR(TAN(R1))
15857 c FFEINTRIN_impTANH
15858 call fooR(TANH(R1))
15859 c FFEINTRIN_imp_CMPLX_C
15860 call fooC(cmplx(C1,C2))
15861 c FFEINTRIN_imp_CMPLX_D
15862 call fooZ(cmplx(D1,D2))
15863 c FFEINTRIN_imp_CMPLX_I
15864 call fooC(cmplx(I1,I2))
15865 c FFEINTRIN_imp_CMPLX_R
15866 call fooC(cmplx(R1,R2))
15867 c FFEINTRIN_imp_DBLE_C
15868 call fooD(dble(C1))
15869 c FFEINTRIN_imp_DBLE_D
15870 call fooD(dble(D1))
15871 c FFEINTRIN_imp_DBLE_I
15872 call fooD(dble(I1))
15873 c FFEINTRIN_imp_DBLE_R
15874 call fooD(dble(R1))
15875 c FFEINTRIN_imp_INT_C
15876 call fooI(int(C1))
15877 c FFEINTRIN_imp_INT_D
15878 call fooI(int(D1))
15879 c FFEINTRIN_imp_INT_I
15880 call fooI(int(I1))
15881 c FFEINTRIN_imp_INT_R
15882 call fooI(int(R1))
15883 c FFEINTRIN_imp_REAL_C
15884 call fooR(real(C1))
15885 c FFEINTRIN_imp_REAL_D
15886 call fooR(real(D1))
15887 c FFEINTRIN_imp_REAL_I
15888 call fooR(real(I1))
15889 c FFEINTRIN_imp_REAL_R
15890 call fooR(real(R1))
15891 c
15892 c FFEINTRIN_imp_INT_D:
15893 c
15894 c FFEINTRIN_specIDINT
15895 call fooI(IDINT(D1))
15896 c
15897 c FFEINTRIN_imp_INT_R:
15898 c
15899 c FFEINTRIN_specIFIX
15900 call fooI(IFIX(R1))
15901 c FFEINTRIN_specINT
15902 call fooI(INT(R1))
15903 c
15904 c FFEINTRIN_imp_REAL_D:
15905 c
15906 c FFEINTRIN_specSNGL
15907 call fooR(SNGL(D1))
15908 c
15909 c FFEINTRIN_imp_REAL_I:
15910 c
15911 c FFEINTRIN_specFLOAT
15912 call fooR(FLOAT(I1))
15913 c FFEINTRIN_specREAL
15914 call fooR(REAL(I1))
15915 c
15916 end
15917 -------- (end input file to f2c)
15919 -------- (begin output from providing above input file as input to:
15920 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
15921 -------- -e "s:^#.*$::g"')
15923 // -- translated by f2c (version 19950223).
15924 You must link the resulting object file with the libraries:
15925 -lf2c -lm (in that order)
15926 //
15929 // f2c.h -- Standard Fortran to C header file //
15931 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
15933 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
15938 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
15939 // we assume short, float are OK //
15940 typedef long int // long int // integer;
15941 typedef char *address;
15942 typedef short int shortint;
15943 typedef float real;
15944 typedef double doublereal;
15945 typedef struct { real r, i; } complex;
15946 typedef struct { doublereal r, i; } doublecomplex;
15947 typedef long int // long int // logical;
15948 typedef short int shortlogical;
15949 typedef char logical1;
15950 typedef char integer1;
15951 // typedef long long longint; // // system-dependent //
15956 // Extern is for use with -E //
15961 // I/O stuff //
15970 typedef long int // int or long int // flag;
15971 typedef long int // int or long int // ftnlen;
15972 typedef long int // int or long int // ftnint;
15975 //external read, write//
15976 typedef struct
15977 { flag cierr;
15978 ftnint ciunit;
15979 flag ciend;
15980 char *cifmt;
15981 ftnint cirec;
15982 } cilist;
15984 //internal read, write//
15985 typedef struct
15986 { flag icierr;
15987 char *iciunit;
15988 flag iciend;
15989 char *icifmt;
15990 ftnint icirlen;
15991 ftnint icirnum;
15992 } icilist;
15994 //open//
15995 typedef struct
15996 { flag oerr;
15997 ftnint ounit;
15998 char *ofnm;
15999 ftnlen ofnmlen;
16000 char *osta;
16001 char *oacc;
16002 char *ofm;
16003 ftnint orl;
16004 char *oblnk;
16005 } olist;
16007 //close//
16008 typedef struct
16009 { flag cerr;
16010 ftnint cunit;
16011 char *csta;
16012 } cllist;
16014 //rewind, backspace, endfile//
16015 typedef struct
16016 { flag aerr;
16017 ftnint aunit;
16018 } alist;
16020 // inquire //
16021 typedef struct
16022 { flag inerr;
16023 ftnint inunit;
16024 char *infile;
16025 ftnlen infilen;
16026 ftnint *inex; //parameters in standard's order//
16027 ftnint *inopen;
16028 ftnint *innum;
16029 ftnint *innamed;
16030 char *inname;
16031 ftnlen innamlen;
16032 char *inacc;
16033 ftnlen inacclen;
16034 char *inseq;
16035 ftnlen inseqlen;
16036 char *indir;
16037 ftnlen indirlen;
16038 char *infmt;
16039 ftnlen infmtlen;
16040 char *inform;
16041 ftnint informlen;
16042 char *inunf;
16043 ftnlen inunflen;
16044 ftnint *inrecl;
16045 ftnint *innrec;
16046 char *inblank;
16047 ftnlen inblanklen;
16048 } inlist;
16052 union Multitype { // for multiple entry points //
16053 integer1 g;
16054 shortint h;
16055 integer i;
16056 // longint j; //
16057 real r;
16058 doublereal d;
16059 complex c;
16060 doublecomplex z;
16061 };
16063 typedef union Multitype Multitype;
16065 typedef long Long; // No longer used; formerly in Namelist //
16067 struct Vardesc { // for Namelist //
16068 char *name;
16069 char *addr;
16070 ftnlen *dims;
16071 int type;
16072 };
16073 typedef struct Vardesc Vardesc;
16075 struct Namelist {
16076 char *name;
16077 Vardesc **vars;
16078 int nvars;
16079 };
16080 typedef struct Namelist Namelist;
16089 // procedure parameter types for -A and -C++ //
16094 typedef int // Unknown procedure type // (*U_fp)();
16095 typedef shortint (*J_fp)();
16096 typedef integer (*I_fp)();
16097 typedef real (*R_fp)();
16098 typedef doublereal (*D_fp)(), (*E_fp)();
16099 typedef // Complex // void (*C_fp)();
16100 typedef // Double Complex // void (*Z_fp)();
16101 typedef logical (*L_fp)();
16102 typedef shortlogical (*K_fp)();
16103 typedef // Character // void (*H_fp)();
16104 typedef // Subroutine // int (*S_fp)();
16106 // E_fp is for real functions when -R is not specified //
16107 typedef void C_f; // complex function //
16108 typedef void H_f; // character function //
16109 typedef void Z_f; // double complex function //
16110 typedef doublereal E_f; // real function with -R not specified //
16112 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16115 // (No such symbols should be defined in a strict ANSI C compiler.
16116 We can avoid trouble with f2c-translated code by using
16117 gcc -ansi.) //
16141 // Main program // MAIN__()
16142 {
16143 // System generated locals //
16144 integer i__1;
16145 real r__1, r__2;
16146 doublereal d__1, d__2;
16147 complex q__1;
16148 doublecomplex z__1, z__2, z__3;
16149 logical L__1;
16150 char ch__1[1];
16152 // Builtin functions //
16153 void c_div();
16154 integer pow_ii();
16155 double pow_ri(), pow_di();
16156 void pow_ci();
16157 double pow_dd();
16158 void pow_zz();
16159 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16160 asin(), atan(), atan2(), c_abs();
16161 void c_cos(), c_exp(), c_log(), r_cnjg();
16162 double cos(), cosh();
16163 void c_sin(), c_sqrt();
16164 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16165 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16166 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16167 logical l_ge(), l_gt(), l_le(), l_lt();
16168 integer i_nint();
16169 double r_sign();
16171 // Local variables //
16172 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16173 fool_(), fooz_(), getem_();
16174 static char a1[10], a2[10];
16175 static complex c1, c2;
16176 static doublereal d1, d2;
16177 static integer i1, i2;
16178 static real r1, r2;
16181 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16182 // / //
16183 i__1 = i1 / i2;
16184 fooi_(&i__1);
16185 r__1 = r1 / i1;
16186 foor_(&r__1);
16187 d__1 = d1 / i1;
16188 food_(&d__1);
16189 d__1 = (doublereal) i1;
16190 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16191 fooc_(&q__1);
16192 r__1 = r1 / r2;
16193 foor_(&r__1);
16194 d__1 = r1 / d1;
16195 food_(&d__1);
16196 d__1 = d1 / d2;
16197 food_(&d__1);
16198 d__1 = d1 / r1;
16199 food_(&d__1);
16200 c_div(&q__1, &c1, &c2);
16201 fooc_(&q__1);
16202 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16203 fooc_(&q__1);
16204 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16205 fooz_(&z__1);
16206 // ** //
16207 i__1 = pow_ii(&i1, &i2);
16208 fooi_(&i__1);
16209 r__1 = pow_ri(&r1, &i1);
16210 foor_(&r__1);
16211 d__1 = pow_di(&d1, &i1);
16212 food_(&d__1);
16213 pow_ci(&q__1, &c1, &i1);
16214 fooc_(&q__1);
16215 d__1 = (doublereal) r1;
16216 d__2 = (doublereal) r2;
16217 r__1 = pow_dd(&d__1, &d__2);
16218 foor_(&r__1);
16219 d__2 = (doublereal) r1;
16220 d__1 = pow_dd(&d__2, &d1);
16221 food_(&d__1);
16222 d__1 = pow_dd(&d1, &d2);
16223 food_(&d__1);
16224 d__2 = (doublereal) r1;
16225 d__1 = pow_dd(&d1, &d__2);
16226 food_(&d__1);
16227 z__2.r = c1.r, z__2.i = c1.i;
16228 z__3.r = c2.r, z__3.i = c2.i;
16229 pow_zz(&z__1, &z__2, &z__3);
16230 q__1.r = z__1.r, q__1.i = z__1.i;
16231 fooc_(&q__1);
16232 z__2.r = c1.r, z__2.i = c1.i;
16233 z__3.r = r1, z__3.i = 0.;
16234 pow_zz(&z__1, &z__2, &z__3);
16235 q__1.r = z__1.r, q__1.i = z__1.i;
16236 fooc_(&q__1);
16237 z__2.r = c1.r, z__2.i = c1.i;
16238 z__3.r = d1, z__3.i = 0.;
16239 pow_zz(&z__1, &z__2, &z__3);
16240 fooz_(&z__1);
16241 // FFEINTRIN_impABS //
16242 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16243 foor_(&r__1);
16244 // FFEINTRIN_impACOS //
16245 r__1 = acos(r1);
16246 foor_(&r__1);
16247 // FFEINTRIN_impAIMAG //
16248 r__1 = r_imag(&c1);
16249 foor_(&r__1);
16250 // FFEINTRIN_impAINT //
16251 r__1 = r_int(&r1);
16252 foor_(&r__1);
16253 // FFEINTRIN_impALOG //
16254 r__1 = log(r1);
16255 foor_(&r__1);
16256 // FFEINTRIN_impALOG10 //
16257 r__1 = r_lg10(&r1);
16258 foor_(&r__1);
16259 // FFEINTRIN_impAMAX0 //
16260 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16261 foor_(&r__1);
16262 // FFEINTRIN_impAMAX1 //
16263 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16264 foor_(&r__1);
16265 // FFEINTRIN_impAMIN0 //
16266 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16267 foor_(&r__1);
16268 // FFEINTRIN_impAMIN1 //
16269 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16270 foor_(&r__1);
16271 // FFEINTRIN_impAMOD //
16272 r__1 = r_mod(&r1, &r2);
16273 foor_(&r__1);
16274 // FFEINTRIN_impANINT //
16275 r__1 = r_nint(&r1);
16276 foor_(&r__1);
16277 // FFEINTRIN_impASIN //
16278 r__1 = asin(r1);
16279 foor_(&r__1);
16280 // FFEINTRIN_impATAN //
16281 r__1 = atan(r1);
16282 foor_(&r__1);
16283 // FFEINTRIN_impATAN2 //
16284 r__1 = atan2(r1, r2);
16285 foor_(&r__1);
16286 // FFEINTRIN_impCABS //
16287 r__1 = c_abs(&c1);
16288 foor_(&r__1);
16289 // FFEINTRIN_impCCOS //
16290 c_cos(&q__1, &c1);
16291 fooc_(&q__1);
16292 // FFEINTRIN_impCEXP //
16293 c_exp(&q__1, &c1);
16294 fooc_(&q__1);
16295 // FFEINTRIN_impCHAR //
16296 *(unsigned char *)&ch__1[0] = i1;
16297 fooa_(ch__1, 1L);
16298 // FFEINTRIN_impCLOG //
16299 c_log(&q__1, &c1);
16300 fooc_(&q__1);
16301 // FFEINTRIN_impCONJG //
16302 r_cnjg(&q__1, &c1);
16303 fooc_(&q__1);
16304 // FFEINTRIN_impCOS //
16305 r__1 = cos(r1);
16306 foor_(&r__1);
16307 // FFEINTRIN_impCOSH //
16308 r__1 = cosh(r1);
16309 foor_(&r__1);
16310 // FFEINTRIN_impCSIN //
16311 c_sin(&q__1, &c1);
16312 fooc_(&q__1);
16313 // FFEINTRIN_impCSQRT //
16314 c_sqrt(&q__1, &c1);
16315 fooc_(&q__1);
16316 // FFEINTRIN_impDABS //
16317 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16318 food_(&d__1);
16319 // FFEINTRIN_impDACOS //
16320 d__1 = acos(d1);
16321 food_(&d__1);
16322 // FFEINTRIN_impDASIN //
16323 d__1 = asin(d1);
16324 food_(&d__1);
16325 // FFEINTRIN_impDATAN //
16326 d__1 = atan(d1);
16327 food_(&d__1);
16328 // FFEINTRIN_impDATAN2 //
16329 d__1 = atan2(d1, d2);
16330 food_(&d__1);
16331 // FFEINTRIN_impDCOS //
16332 d__1 = cos(d1);
16333 food_(&d__1);
16334 // FFEINTRIN_impDCOSH //
16335 d__1 = cosh(d1);
16336 food_(&d__1);
16337 // FFEINTRIN_impDDIM //
16338 d__1 = d_dim(&d1, &d2);
16339 food_(&d__1);
16340 // FFEINTRIN_impDEXP //
16341 d__1 = exp(d1);
16342 food_(&d__1);
16343 // FFEINTRIN_impDIM //
16344 r__1 = r_dim(&r1, &r2);
16345 foor_(&r__1);
16346 // FFEINTRIN_impDINT //
16347 d__1 = d_int(&d1);
16348 food_(&d__1);
16349 // FFEINTRIN_impDLOG //
16350 d__1 = log(d1);
16351 food_(&d__1);
16352 // FFEINTRIN_impDLOG10 //
16353 d__1 = d_lg10(&d1);
16354 food_(&d__1);
16355 // FFEINTRIN_impDMAX1 //
16356 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16357 food_(&d__1);
16358 // FFEINTRIN_impDMIN1 //
16359 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16360 food_(&d__1);
16361 // FFEINTRIN_impDMOD //
16362 d__1 = d_mod(&d1, &d2);
16363 food_(&d__1);
16364 // FFEINTRIN_impDNINT //
16365 d__1 = d_nint(&d1);
16366 food_(&d__1);
16367 // FFEINTRIN_impDPROD //
16368 d__1 = (doublereal) r1 * r2;
16369 food_(&d__1);
16370 // FFEINTRIN_impDSIGN //
16371 d__1 = d_sign(&d1, &d2);
16372 food_(&d__1);
16373 // FFEINTRIN_impDSIN //
16374 d__1 = sin(d1);
16375 food_(&d__1);
16376 // FFEINTRIN_impDSINH //
16377 d__1 = sinh(d1);
16378 food_(&d__1);
16379 // FFEINTRIN_impDSQRT //
16380 d__1 = sqrt(d1);
16381 food_(&d__1);
16382 // FFEINTRIN_impDTAN //
16383 d__1 = tan(d1);
16384 food_(&d__1);
16385 // FFEINTRIN_impDTANH //
16386 d__1 = tanh(d1);
16387 food_(&d__1);
16388 // FFEINTRIN_impEXP //
16389 r__1 = exp(r1);
16390 foor_(&r__1);
16391 // FFEINTRIN_impIABS //
16392 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16393 fooi_(&i__1);
16394 // FFEINTRIN_impICHAR //
16395 i__1 = *(unsigned char *)a1;
16396 fooi_(&i__1);
16397 // FFEINTRIN_impIDIM //
16398 i__1 = i_dim(&i1, &i2);
16399 fooi_(&i__1);
16400 // FFEINTRIN_impIDNINT //
16401 i__1 = i_dnnt(&d1);
16402 fooi_(&i__1);
16403 // FFEINTRIN_impINDEX //
16404 i__1 = i_indx(a1, a2, 10L, 10L);
16405 fooi_(&i__1);
16406 // FFEINTRIN_impISIGN //
16407 i__1 = i_sign(&i1, &i2);
16408 fooi_(&i__1);
16409 // FFEINTRIN_impLEN //
16410 i__1 = i_len(a1, 10L);
16411 fooi_(&i__1);
16412 // FFEINTRIN_impLGE //
16413 L__1 = l_ge(a1, a2, 10L, 10L);
16414 fool_(&L__1);
16415 // FFEINTRIN_impLGT //
16416 L__1 = l_gt(a1, a2, 10L, 10L);
16417 fool_(&L__1);
16418 // FFEINTRIN_impLLE //
16419 L__1 = l_le(a1, a2, 10L, 10L);
16420 fool_(&L__1);
16421 // FFEINTRIN_impLLT //
16422 L__1 = l_lt(a1, a2, 10L, 10L);
16423 fool_(&L__1);
16424 // FFEINTRIN_impMAX0 //
16425 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16426 fooi_(&i__1);
16427 // FFEINTRIN_impMAX1 //
16428 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16429 fooi_(&i__1);
16430 // FFEINTRIN_impMIN0 //
16431 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16432 fooi_(&i__1);
16433 // FFEINTRIN_impMIN1 //
16434 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16435 fooi_(&i__1);
16436 // FFEINTRIN_impMOD //
16437 i__1 = i1 % i2;
16438 fooi_(&i__1);
16439 // FFEINTRIN_impNINT //
16440 i__1 = i_nint(&r1);
16441 fooi_(&i__1);
16442 // FFEINTRIN_impSIGN //
16443 r__1 = r_sign(&r1, &r2);
16444 foor_(&r__1);
16445 // FFEINTRIN_impSIN //
16446 r__1 = sin(r1);
16447 foor_(&r__1);
16448 // FFEINTRIN_impSINH //
16449 r__1 = sinh(r1);
16450 foor_(&r__1);
16451 // FFEINTRIN_impSQRT //
16452 r__1 = sqrt(r1);
16453 foor_(&r__1);
16454 // FFEINTRIN_impTAN //
16455 r__1 = tan(r1);
16456 foor_(&r__1);
16457 // FFEINTRIN_impTANH //
16458 r__1 = tanh(r1);
16459 foor_(&r__1);
16460 // FFEINTRIN_imp_CMPLX_C //
16461 r__1 = c1.r;
16462 r__2 = c2.r;
16463 q__1.r = r__1, q__1.i = r__2;
16464 fooc_(&q__1);
16465 // FFEINTRIN_imp_CMPLX_D //
16466 z__1.r = d1, z__1.i = d2;
16467 fooz_(&z__1);
16468 // FFEINTRIN_imp_CMPLX_I //
16469 r__1 = (real) i1;
16470 r__2 = (real) i2;
16471 q__1.r = r__1, q__1.i = r__2;
16472 fooc_(&q__1);
16473 // FFEINTRIN_imp_CMPLX_R //
16474 q__1.r = r1, q__1.i = r2;
16475 fooc_(&q__1);
16476 // FFEINTRIN_imp_DBLE_C //
16477 d__1 = (doublereal) c1.r;
16478 food_(&d__1);
16479 // FFEINTRIN_imp_DBLE_D //
16480 d__1 = d1;
16481 food_(&d__1);
16482 // FFEINTRIN_imp_DBLE_I //
16483 d__1 = (doublereal) i1;
16484 food_(&d__1);
16485 // FFEINTRIN_imp_DBLE_R //
16486 d__1 = (doublereal) r1;
16487 food_(&d__1);
16488 // FFEINTRIN_imp_INT_C //
16489 i__1 = (integer) c1.r;
16490 fooi_(&i__1);
16491 // FFEINTRIN_imp_INT_D //
16492 i__1 = (integer) d1;
16493 fooi_(&i__1);
16494 // FFEINTRIN_imp_INT_I //
16495 i__1 = i1;
16496 fooi_(&i__1);
16497 // FFEINTRIN_imp_INT_R //
16498 i__1 = (integer) r1;
16499 fooi_(&i__1);
16500 // FFEINTRIN_imp_REAL_C //
16501 r__1 = c1.r;
16502 foor_(&r__1);
16503 // FFEINTRIN_imp_REAL_D //
16504 r__1 = (real) d1;
16505 foor_(&r__1);
16506 // FFEINTRIN_imp_REAL_I //
16507 r__1 = (real) i1;
16508 foor_(&r__1);
16509 // FFEINTRIN_imp_REAL_R //
16510 r__1 = r1;
16511 foor_(&r__1);
16513 // FFEINTRIN_imp_INT_D: //
16515 // FFEINTRIN_specIDINT //
16516 i__1 = (integer) d1;
16517 fooi_(&i__1);
16519 // FFEINTRIN_imp_INT_R: //
16521 // FFEINTRIN_specIFIX //
16522 i__1 = (integer) r1;
16523 fooi_(&i__1);
16524 // FFEINTRIN_specINT //
16525 i__1 = (integer) r1;
16526 fooi_(&i__1);
16528 // FFEINTRIN_imp_REAL_D: //
16530 // FFEINTRIN_specSNGL //
16531 r__1 = (real) d1;
16532 foor_(&r__1);
16534 // FFEINTRIN_imp_REAL_I: //
16536 // FFEINTRIN_specFLOAT //
16537 r__1 = (real) i1;
16538 foor_(&r__1);
16539 // FFEINTRIN_specREAL //
16540 r__1 = (real) i1;
16541 foor_(&r__1);
16543 } // MAIN__ //
16545 -------- (end output file from f2c)
16547 */