| blob | 535ddbb87e865892885b6346cb4e1efab839341d |
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
1534 {
1535 tree source_decl;
1536 tree source_offset;
1537 tree source_size;
1538 tree t;
1544 {
1607 scalar_arg);
1612 scalar_arg);
1622 source_tree);
1627 return
1630 scalar_arg)
1633 scalar_arg);
1662 }
1664 /* Come here when source_decl, source_offset, and source_size filled
1665 in appropriately. */
1675 array? Shouldn't happen.... */
1679 dest_offset,
1681 dest_size)),
1683 source_offset));
1696 source_offset,
1698 source_size)),
1700 dest_offset));
1706 }
1708 /* Check whether dest might overlap any of a list of arguments or is
1709 in a COMMON area the callee might know about (and thus modify). */
1711 static bool
1714 {
1715 tree arg;
1716 tree dest_decl;
1717 tree dest_offset;
1718 tree dest_size;
1721 dest_tree);
1726 /* If the decl cannot be determined reliably, or if its in COMMON
1727 and the callee isn't known to not futz with COMMON via other
1728 means, overlap might happen. */
1736 {
1741 }
1744 }
1746 /* Build a string for a variable name as used by NAMELIST. This means that
1747 if we're using the f2c library, we build an uppercase string, since
1748 f2c does this. */
1750 static tree
1752 {
1756 {
1761 tree t;
1765 else
1778 }
1779 }
1781 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1782 type to just get whatever the function returns), handling the
1783 f2c value-returning convention, if required, by prepending
1784 to the arglist a pointer to a temporary to receive the return value. */
1786 static tree
1790 {
1791 tree item;
1792 tree tempvar;
1798 {
1806 callee_commons,
1807 scalar_args))
1808 {
1811 }
1812 else
1813 {
1817 }
1819 item
1823 tempvar));
1831 }
1832 else
1840 }
1842 /* Given two arguments, transform them and make a call to the given
1843 function via ffecom_call_. */
1845 static tree
1850 {
1851 tree left_tree;
1852 tree right_tree;
1853 tree left_length;
1854 tree right_length;
1857 {
1858 /* Pass arguments by reference. */
1861 }
1862 else
1863 {
1864 /* Pass arguments by value. */
1867 }
1875 {
1878 }
1881 {
1885 else
1887 }
1892 }
1894 /* Return ptr/length args for char subexpression
1896 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1897 subexpressions by constructing the appropriate trees for the ptr-to-
1898 character-text and length-of-character-text arguments in a calling
1899 sequence.
1901 Note that if with_null is TRUE, and the expression is an opCONTER,
1902 a null byte is appended to the string. */
1904 static void
1906 {
1907 tree item;
1908 tree high;
1909 ffetargetCharacter1 val;
1910 ffetargetCharacterSize newlen;
1913 {
1918 {
1919 /* Begin FFETARGET-NULL-KLUDGE. */
1922 }
1929 /* End FFETARGET-NULL-KLUDGE. */
1931 = build_type_variant
1932 (build_array_type
1934 build_range_type
1936 ffecom_f2c_ftnlen_one_node,
1937 high)),
1942 item);
1946 {
1951 {
1954 }
1956 {
1959 else
1960 {
1963 }
1964 }
1967 else
1968 /* FFEINFO_kindFUNCTION. */
1974 item);
1975 }
1979 {
1983 {
1986 }
1989 }
1993 {
1994 ffebld start;
1995 ffebld end;
1997 tree start_tree;
1998 tree end_tree;
2000 ffebld left_symter;
2001 tree array;
2009 /* Determine name for pretty-printing range-check errors. */
2013 ;
2016 else
2022 {
2025 }
2029 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2032 {
2034 ;
2035 else
2036 {
2040 char_name);
2042 end_tree);
2045 {
2048 }
2051 }
2052 }
2053 else
2054 {
2058 char_name);
2060 start_tree);
2063 {
2066 }
2071 item,
2074 start_tree,
2075 ffecom_f2c_ftnlen_one_node));
2078 {
2080 ffecom_f2c_ftnlen_one_node,
2082 ffecom_f2c_ftnlen_type_node,
2084 start_tree));
2085 }
2086 else
2087 {
2091 char_name);
2093 end_tree);
2096 {
2099 }
2102 ffecom_f2c_ftnlen_one_node,
2104 ffecom_f2c_ftnlen_type_node,
2106 }
2107 }
2108 }
2112 {
2114 tree tempvar;
2115 tree args;
2117 ffecomGfrt ix;
2120 /* ~~Kludge alert! This should someday be fixed. */
2128 {
2130 {
2131 /* Invocation of an intrinsic returning CHARACTER*1. */
2135 }
2139 }
2140 else
2141 {
2145 {
2148 }
2150 {
2153 }
2157 }
2162 tempvar);
2168 else
2169 {
2172 {
2176 }
2177 else
2178 {
2181 }
2182 }
2188 tempvar);
2189 }
2197 {
2200 }
2206 temporary. */
2207 tree tempvar;
2208 tree args;
2209 tree newlen;
2215 tempvar);
2229 tempvar);
2231 }
2232 else
2236 }
2243 }
2246 }
2248 /* Check the size of the type to be sure it doesn't overflow the
2249 "portable" capacities of the compiler back end. `dummy' types
2250 can generally overflow the normal sizes as long as the computations
2251 themselves don't overflow. A particular target of the back end
2252 must still enforce its size requirements, though, and the back
2253 end takes care of this in stor-layout.c. */
2255 static tree
2257 {
2267 /* An array is too large if size is negative or the type_size overflows
2268 or its "upper half" is larger than 3 (which would make the signed
2269 byte size and offset computations overflow). */
2274 {
2281 }
2284 }
2286 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2287 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2288 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2290 static tree
2292 {
2294 tree highval;
2295 tree tlen;
2300 else
2301 {
2305 else
2309 }
2312 {
2315 }
2316 else
2317 {
2320 }
2324 ffecom_f2c_ftnlen_one_node,
2325 highval));
2329 }
2331 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2333 ffecomConcatList_ catlist;
2334 ffebld expr; // expr of CHARACTER basictype.
2335 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2336 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2338 Scans expr for character subexpressions, updates and returns catlist
2339 accordingly. */
2341 static ffecomConcatList_
2343 ffetargetCharacterSize max)
2344 {
2345 ffetargetCharacterSize sz;
2347 recurse:
2356 {
2363 if they don't need to preserve it. */
2373 {
2377 }
2380 }
2383 else
2387 else
2391 of the destination. */
2393 {
2399 /* ~~Do useful truncations here. */
2405 }
2406 }
2420 dummy arg of sfunc */
2423 {
2424 ffetargetCharacterSize cmax;
2430 }
2432 #endif
2440 }
2441 }
2443 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2445 ffecomConcatList_ catlist;
2446 ffecom_concat_list_kill_(catlist);
2448 Anything allocated within the list info is deallocated. */
2450 static void
2452 {
2456 }
2458 /* Make list of concatenated string exprs.
2460 Returns a flattened list of concatenated subexpressions given a
2461 tree of such expressions. */
2463 static ffecomConcatList_
2465 {
2466 ffecomConcatList_ catlist;
2470 }
2472 /* Provide some kind of useful info on member of aggregate area,
2473 since current g77/gcc technology does not provide debug info
2474 on these members. */
2476 static void
2479 {
2480 tree value;
2481 tree decl;
2485 #if 0
2486 tree type_id;
2490 )
2491 {
2493 {
2508 }
2509 }
2510 #endif
2519 #if 0
2521 #endif
2525 else
2529 aggr_type,
2536 build_range_type
2538 integer_one_node,
2553 }
2555 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2557 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2558 int i; // entry# for this entrypoint (used by master fn)
2559 ffecom_do_entrypoint_(s,i);
2561 Makes a public entry point that calls our private master fn (already
2562 compiled). */
2564 static void
2566 {
2567 ffebld item;
2571 ffeinfoBasictype bt;
2572 ffeinfoKindtype kt;
2573 ffeglobal g;
2574 ffeglobalType gt;
2576 CHARACTER. */
2580 returns. */
2589 {
2592 /* Determine actual return type for function. */
2598 {
2604 }
2611 else
2618 else
2637 {
2639 {
2642 }
2643 }
2646 else
2648 }
2649 else
2658 /* Fall through. */
2668 }
2670 /* build_decl uses the current lineno and input_filename to set the decl
2671 source info. So, I've putzed with ffestd and ffeste code to update that
2672 source info to point to the appropriate statement just before calling
2673 ffecom_do_entrypoint (which calls this fn). */
2676 type,
2683 {
2685 }
2687 /* Reset args in master arg list so they get retransitioned. */
2692 {
2693 ffebld arg;
2694 ffesymbol s;
2702 }
2704 /* Build dummy arg list for this entry point. */
2708 tree type;
2709 tree length;
2713 else
2718 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2722 else
2732 {
2735 }
2736 }
2737 else
2745 /* Disallow temp vars at this level. */
2748 /* Make local var to hold return type for multi-type master fn. */
2751 {
2755 ffecom_multi_type_node_);
2758 }
2759 else
2762 /* Here we emit the actual code for the entry point. */
2764 {
2765 ffebld list;
2766 ffebld arg;
2767 ffesymbol s;
2770 tree prepend;
2771 tree call;
2772 tree actarg;
2773 tree master_fn;
2775 /* Prepare actual arg list based on master arg list. */
2780 {
2788 else
2792 }
2794 /* This code appends the length arguments for character
2795 variables/arrays. */
2800 {
2812 else
2816 }
2818 /* Prepend character-value return info to actual arg list. */
2821 {
2827 }
2829 /* Prepend multi-type return value to actual arg list. */
2832 {
2833 prepend
2837 multi_retval));
2840 }
2842 /* Prepend my entry-point number to the actual arg list. */
2848 /* Build the call to the master function. */
2855 /* Decide whether the master function is a function or subroutine, and
2856 handle the return value for my entry point. */
2860 {
2863 }
2865 {
2867 result
2870 result);
2873 multi_retval,
2877 }
2879 {
2881 result
2886 multi_retval,
2889 }
2891 {
2892 result
2895 result);
2899 }
2900 else
2901 {
2903 result,
2905 call));
2907 }
2908 }
2917 }
2919 /* Transform expr into gcc tree with possible destination
2921 Recursive descent on expr while making corresponding tree nodes and
2922 attaching type info and such. If destination supplied and compatible
2923 with temporary that would be made in certain cases, temporary isn't
2924 made, destination used instead, and dest_used flag set TRUE. */
2926 static tree
2929 {
2930 tree item;
2931 tree list;
2932 tree args;
2933 ffeinfoBasictype bt;
2934 ffeinfoKindtype kt;
2935 tree t;
2939 ffesymbol s;
2951 /* Widen integral arithmetic as desired while preserving signedness. */
2959 {
2961 {
2962 ffebitCount i;
2966 tree purpose;
2974 {
2975 ffebldConstantUnion cu;
2976 ffebitCount length;
2985 {
2987 {
2996 else
3001 else
3002 {
3005 }
3006 }
3007 }
3010 }
3011 }
3017 item
3018 = build_array_type
3021 ffecom_integer_zero_node,
3022 item));
3029 {
3030 ffetargetOffset i;
3035 else
3036 {
3040 /* Becomes PURPOSE first time through loop. */
3042 }
3045 {
3046 ffebldConstantUnion cu
3052 /* Assume item is PURPOSE first time through loop. */
3054 else
3055 {
3058 }
3059 }
3060 }
3065 item
3066 = build_array_type
3069 ffecom_integer_zero_node,
3070 item));
3078 item
3093 {
3094 /* User explicitly wants ASSIGN'ed variables to be at the same
3095 memory address as the variables when used in non-ASSIGN
3096 contexts. That can make old, arcane, non-standard code
3097 work, but don't try to do it when a pointer wouldn't fit
3098 in the normal variable (take other approach, and warn,
3099 instead). */
3102 {
3106 }
3113 {
3118 }
3121 {
3122 /* xgettext:no-c-format */
3124 FFEBAD_severityWARNING);
3129 }
3130 }
3132 /* Don't use the normal variable's tree for ASSIGN, though mark
3133 it as in the system header (housekeeping). Use an explicit,
3134 specially created sibling that is known to be wide enough
3135 to hold pointers to labels. */
3143 {
3147 }
3148 }
3149 else
3150 {
3152 {
3156 }
3160 }
3171 /* ~~~Make sure Fortran rules respected here */
3178 {
3181 }
3188 {
3192 }
3199 {
3203 }
3210 {
3214 }
3221 {
3225 }
3231 {
3234 ffecomGfrt code;
3235 ffeinfoKindtype rtkt;
3236 ffeinfoKindtype ltkt;
3240 {
3244 {
3248 }
3252 {
3258 {
3262 }
3263 else
3264 {
3267 }
3273 {
3276 }
3277 else
3278 {
3281 }
3287 {
3290 }
3291 else
3292 {
3295 }
3303 }
3308 FFETARGET_charactersizeNONE,
3309 FFEEXPR_contextLET);
3312 FFEINFO_basictypeINTEGER,
3314 FFETARGET_charactersizeNONE,
3315 FFEEXPR_contextLET);
3322 FFETARGET_charactersizeNONE,
3323 FFEEXPR_contextLET);
3327 FFEINFO_basictypeREAL,
3329 FFETARGET_charactersizeNONE,
3330 FFEEXPR_contextLET);
3331 /* We used to call FFECOM_gfrtPOW_DD here,
3332 which passes arguments by reference. */
3334 /* Pass arguments by value. */
3341 FFEINFO_basictypeCOMPLEX,
3343 FFETARGET_charactersizeNONE,
3344 FFEEXPR_contextLET);
3348 FFEINFO_basictypeCOMPLEX,
3350 FFETARGET_charactersizeNONE,
3351 FFEEXPR_contextLET);
3360 }
3369 }
3373 {
3384 /* Fall through. */
3387 }
3393 /* Fall through. */
3399 dest_used);
3401 }
3405 {
3408 }
3414 else
3419 else
3430 tree_type,
3431 args,
3440 {
3442 item
3455 /* Fall through. */
3458 }
3463 {
3465 item
3478 /* Fall through. */
3481 }
3487 {
3489 item
3502 /* Fall through. */
3505 }
3510 {
3512 item
3519 return
3527 /* Fall through. */
3530 }
3538 {
3546 {
3553 /* convert() takes care of converting to the subtype first,
3554 at least in gcc-2.7.2. */
3563 /* Fall through. */
3566 }
3571 /* Fall through. */
3574 }
3602 {
3613 {
3614 tree real_type;
3625 {
3628 }
3629 else
3630 {
3633 }
3635 item
3643 arg2)));
3646 else
3649 }
3652 {
3655 tree left_tree;
3656 tree right_tree;
3657 tree left_length;
3658 tree right_length;
3660 /* f2c run-time functions do the implicit blank-padding for us,
3661 so we don't usually have to implement blank-padding ourselves.
3662 (The exception is when we pass an argument to a separately
3663 compiled statement function -- if we know the arg is not the
3664 same length as the dummy, we must truncate or extend it. If
3665 we "inline" statement functions, that necessity goes away as
3666 well.)
3668 Strip off the CONVERT operators that blank-pad. (Truncation by
3669 CONVERT shouldn't happen here, but it can happen in
3670 assignments.) */
3687 {
3688 left_tree
3691 left_tree);
3692 right_tree
3695 right_tree);
3697 item
3701 left_tree,
3702 integer_one_node),
3705 right_tree,
3706 integer_one_node));
3707 }
3708 else
3709 {
3713 left_length);
3718 item,
3720 integer_zero_node));
3721 }
3723 }
3729 /* Fall through. */
3732 }
3754 /* Fall through. */
3757 }
3759 #if 1
3761 #else
3763 {
3780 }
3783 #endif
3784 }
3786 /* Returns the tree that does the intrinsic invocation.
3788 Note: this function applies only to intrinsics returning
3789 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3790 subroutines. */
3792 static tree
3795 {
3796 tree expr_tree;
3799 ffeinfoBasictype bt;
3800 ffeinfoKindtype kt;
3801 tree tree_type;
3802 tree arg1_type;
3804 tree tempvar;
3807 ffebld arg2;
3808 ffebld arg3;
3809 ffeintrinImp codegen_imp;
3810 ffecomGfrt gfrt;
3822 {
3827 {
3832 {
3836 }
3837 else
3839 }
3840 else
3842 }
3843 else
3846 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3847 args. This is used by the MAX/MIN expansions. */
3850 arg1_type = ffecom_tree_type
3853 else
3855 here. */
3857 /* There are several ways for each of the cases in the following switch
3858 statements to exit (from simplest to use to most complicated):
3860 break; (when expr_tree == NULL)
3862 A standard call is made to the specific intrinsic just as if it had been
3863 passed in as a dummy procedure and called as any old procedure. This
3864 method can produce slower code but in some cases it's the easiest way for
3865 now. However, if a (presumably faster) direct call is available,
3866 that is used, so this is the easiest way in many more cases now.
3868 gfrt = FFECOM_gfrtWHATEVER;
3869 break;
3871 gfrt contains the gfrt index of a library function to call, passing the
3872 argument(s) by value rather than by reference. Used when a more
3873 careful choice of library function is needed than that provided
3874 by the vanilla `break;'.
3876 return expr_tree;
3878 The expr_tree has been completely set up and is ready to be returned
3879 as is. No further actions are taken. Use this when the tree is not
3880 in the simple form for one of the arity_n labels. */
3882 /* For info on how the switch statement cases were written, see the files
3883 enclosed in comments below the switch statement. */
3891 {
3899 {
3905 }
3918 else
3921 return
3928 #if 0
3929 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
3932 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3934 return
3937 ffecom_truth_value
3939 saved_expr1,
3941 ffecom_float_zero_))),
3945 saved_expr1)),
3946 NULL_TREE),
3952 arg1_type,
3953 saved_expr1))),
3954 NULL_TREE)
3955 ))
3956 );
3957 #endif
3962 numbers of large magnitudes. */
3967 ffecom_truth_value
3969 integer_type_node,
3970 saved_expr1,
3971 ffecom_float_zero_)),
3973 tree_type,
3974 saved_expr1,
3975 ffecom_float_half_),
3977 tree_type,
3978 saved_expr1,
3979 ffecom_float_half_))));
3982 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3984 return
3987 ffecom_truth_value
3989 saved_expr1,
3991 ffecom_float_zero_))),
3996 arg1_type,
3997 saved_expr1,
3999 ffecom_float_half_)))),
4000 NULL_TREE),
4006 arg1_type,
4008 ffecom_float_half_),
4009 saved_expr1))),
4010 NULL_TREE))
4011 )
4012 );
4013 #endif
4027 {
4032 integer_one_node),
4034 }
4036 expr_tree,
4037 tempvar);
4040 expr_tree);
4046 return
4050 return
4057 return
4064 {
4065 tree arg1_tree;
4069 return
4074 }
4081 {
4086 }
4115 return
4117 ffecom_truth_value
4119 saved_expr1,
4120 saved_expr2)),
4122 saved_expr1,
4123 saved_expr2),
4127 return
4137 {
4142 }
4149 expr_tree
4152 expr_tree);
4153 expr_tree
4156 expr_tree,
4157 integer_one_node);
4162 saved_expr1,
4163 expr_tree,
4166 #endif
4172 #if 0
4174 #else
4176 #endif
4190 {
4195 }
4205 /* We used to call FFECOM_gfrtALOG10 here. */
4208 /* We used to call FFECOM_gfrtDLOG10 here. */
4220 else
4226 {
4231 expr_tree,
4234 }
4245 else
4251 {
4256 expr_tree,
4259 }
4271 /* We used to call FFECOM_gfrtAMOD here. */
4274 /* We used to call FFECOM_gfrtDMOD here. */
4280 #if 0
4281 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4283 #else
4284 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4286 return
4289 ffecom_truth_value
4291 saved_expr1,
4293 ffecom_float_zero_))),
4295 saved_expr1,
4297 ffecom_float_half_)),
4299 saved_expr1,
4301 ffecom_float_half_))));
4302 #endif
4307 {
4310 saved_expr1
4311 = ffecom_save_tree
4315 expr_tree
4317 ffecom_truth_value
4319 arg2_tree,
4321 integer_zero_node))),
4322 saved_expr1,
4324 /* Make sure SAVE_EXPRs get referenced early enough. */
4325 expr_tree
4328 expr_tree);
4329 }
4337 {
4342 }
4354 {
4359 }
4371 else
4374 return
4422 {
4423 ffetargetLogical1 target_true;
4424 ffetargetLogical1 target_false;
4425 tree true_tree;
4426 tree false_tree;
4432 else
4436 else
4439 return
4441 ffecom_truth_value
4447 integer_one_node),
4451 integer_zero_node))),
4452 false_tree,
4453 true_tree);
4454 }
4457 return
4463 integer_one_node),
4468 {
4471 tree uns_type
4474 expr_tree
4483 uns_type,
4485 integer_zero_node)),
4487 integer_type_node,
4489 arg3_tree))));
4490 /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE. */
4491 expr_tree
4493 ffecom_truth_value
4495 arg3_tree,
4496 integer_zero_node)),
4497 expr_tree,
4499 }
4503 return
4512 {
4516 tree uns_type
4519 expr_tree
4521 ffecom_truth_value
4523 arg2_tree,
4524 integer_zero_node)),
4526 arg1_tree,
4527 arg2_tree),
4532 integer_type_node,
4533 arg2_tree))));
4534 /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds. */
4535 expr_tree
4537 ffecom_truth_value
4540 integer_type_node,
4541 arg2_tree),
4543 expr_tree,
4545 /* Make sure SAVE_EXPRs get referenced early enough. */
4546 expr_tree
4551 expr_tree));
4552 }
4556 {
4562 tree shift_neg;
4563 tree shift_pos;
4564 tree mask_arg1;
4565 tree masked_arg1;
4566 tree uns_type
4569 mask_arg1
4573 arg3_tree);
4574 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4575 mask_arg1
4577 ffecom_truth_value
4579 arg3_tree,
4581 mask_arg1,
4584 masked_arg1
4586 arg1_tree,
4588 mask_arg1));
4590 shift_neg
4596 integer_type_node,
4597 arg2_tree))),
4599 arg1_tree,
4601 arg2_tree,
4602 arg3_tree)));
4603 shift_pos
4606 arg1_tree,
4607 arg2_tree),
4612 integer_type_node,
4613 arg3_tree,
4614 arg2_tree))));
4615 expr_tree
4617 ffecom_truth_value
4619 arg2_tree,
4620 integer_zero_node)),
4621 shift_neg,
4622 shift_pos);
4623 expr_tree
4626 mask_arg1,
4627 arg1_tree),
4630 mask_arg1),
4631 expr_tree));
4632 expr_tree
4634 ffecom_truth_value
4638 integer_type_node,
4639 arg2_tree),
4640 arg3_tree),
4642 arg2_tree,
4643 integer_zero_node))),
4644 arg1_tree,
4645 expr_tree);
4646 /* Make sure SAVE_EXPRs get referenced early enough. */
4647 expr_tree
4654 mask_arg1),
4657 masked_arg1),
4658 expr_tree))));
4659 expr_tree
4662 arg3_tree),
4663 expr_tree);
4664 }
4668 {
4671 expr_tree
4675 arg1_tree));
4676 }
4680 {
4681 tree arg1_tree;
4682 tree arg2_tree;
4683 tree arg3_tree;
4685 tree arg4_tree;
4686 tree arg4_type;
4688 tree arg5_tree;
4689 tree prep_arg1;
4690 tree prep_arg4;
4691 tree arg5_plus_arg3;
4706 prep_arg1
4710 arg1_tree,
4711 arg2_tree),
4715 arg4_type,
4716 convert
4718 integer_zero_node)),
4719 arg3_tree))),
4720 arg5_tree);
4721 arg5_plus_arg3
4723 arg5_tree,
4724 arg3_tree));
4725 prep_arg4
4729 integer_zero_node)),
4730 arg5_plus_arg3);
4731 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4732 prep_arg4
4734 ffecom_truth_value
4736 arg5_plus_arg3,
4739 prep_arg4,
4741 prep_arg4
4743 arg4_tree,
4745 prep_arg4,
4749 arg4_type,
4750 convert
4752 integer_zero_node)),
4753 arg5_tree))));
4754 prep_arg1
4756 prep_arg1,
4757 prep_arg4);
4758 /* Fix up (twice), because LSHIFT_EXPR above
4759 can't shift over TYPE_SIZE. */
4760 prep_arg1
4762 ffecom_truth_value
4764 arg3_tree,
4766 integer_zero_node))),
4767 prep_arg1,
4768 arg4_tree);
4769 prep_arg1
4771 ffecom_truth_value
4773 arg3_tree,
4776 prep_arg1,
4777 arg1_tree);
4778 expr_tree
4780 arg4_tree,
4781 prep_arg1);
4782 /* Make sure SAVE_EXPRs get referenced early enough. */
4783 expr_tree
4785 arg1_tree,
4787 arg3_tree,
4789 arg5_tree,
4791 arg5_plus_arg3,
4792 expr_tree))));
4793 expr_tree
4795 arg4_tree,
4796 expr_tree);
4798 }
4808 /* extern int xargc; i__1 = xargc - 1; */
4810 ffecom_tree_xargc_,
4812 integer_one_node));
4817 {
4818 tree arg1_tree;
4819 tree arg2_tree;
4820 tree arg3_tree;
4826 arg1_tree);
4828 /* Pass procedure as a pointer to it, anything else by value. */
4831 else
4834 arg2_tree);
4838 else
4845 expr_tree
4848 FALSE,
4850 NULL_TREE :
4851 tree_type),
4852 arg1_tree,
4857 expr_tree
4860 expr_tree));
4861 }
4865 {
4866 tree arg1_tree;
4867 tree arg2_tree;
4868 tree arg3_tree;
4874 arg1_tree);
4876 /* Pass procedure as a pointer to it, anything else by value. */
4879 else
4882 arg2_tree);
4886 else
4893 expr_tree
4896 FALSE,
4897 NULL_TREE,
4898 arg1_tree,
4903 expr_tree
4906 expr_tree));
4907 }
4918 {
4920 tree arg1_tree;
4921 tree arg2_tree;
4927 else
4934 expr_tree
4937 FALSE,
4938 NULL_TREE,
4939 arg1_tree,
4944 expr_tree
4947 expr_tree));
4948 }
4957 build_pointer_type
4959 integer_zero_node));
4961 return
4964 FALSE,
4965 void_type_node,
4966 expr_tree,
4973 else
4981 {
4983 tree arg1_tree;
4985 tree arg2_tree;
4986 tree arg3_tree;
4992 else
5004 FALSE,
5005 NULL_TREE,
5006 arg1_tree,
5012 expr_tree));
5013 }
5018 {
5020 tree arg1_tree;
5021 tree arg2_tree;
5022 tree arg3_tree;
5030 else
5040 FALSE,
5041 NULL_TREE,
5042 arg1_tree,
5048 expr_tree));
5049 }
5054 {
5055 tree arg1_tree;
5056 tree arg2_tree;
5058 tree arg3_tree;
5064 arg1_tree);
5069 else
5080 FALSE,
5081 NULL_TREE,
5082 arg1_tree,
5088 expr_tree));
5089 }
5093 {
5094 tree arg1_tree;
5095 tree arg2_tree;
5096 tree arg3_tree;
5102 arg1_tree);
5109 else
5117 FALSE,
5118 NULL_TREE,
5119 arg1_tree,
5125 expr_tree));
5126 }
5127 }
5131 {
5132 tree arg1_tree;
5133 tree arg2_tree;
5134 tree arg3_tree;
5140 arg1_tree);
5146 arg2_tree);
5150 else
5158 FALSE,
5159 NULL_TREE,
5160 arg1_tree,
5166 expr_tree));
5167 }
5168 }
5173 {
5175 tree arg1_tree;
5176 tree arg2_tree;
5181 ffecom_f2c_longint_type_node :
5182 ffecom_f2c_integer_type_node),
5186 arg2_tree);
5194 expr_tree
5197 FALSE,
5198 NULL_TREE,
5199 arg1_tree,
5203 }
5208 /* Arg defaults to 0 (normal random case) */
5209 {
5210 tree arg1_tree;
5214 else
5217 arg1_tree);
5220 arg1_tree);
5225 FALSE,
5227 ffecom_f2c_integer_type_node :
5228 ffecom_f2c_real_type_node),
5229 arg1_tree,
5233 }
5238 {
5239 tree arg1_tree;
5240 tree arg2_tree;
5246 arg1_tree);
5250 else
5255 FALSE,
5256 NULL_TREE,
5259 TRUE,
5264 expr_tree));
5265 }
5266 }
5271 {
5272 tree arg1_tree;
5276 expr_tree
5279 FALSE,
5280 NULL_TREE,
5281 NULL_TREE,
5285 expr_tree
5288 expr_tree));
5289 }
5294 {
5295 tree arg1_tree;
5296 tree result_tree;
5304 FALSE,
5305 NULL_TREE,
5308 TRUE,
5312 expr_tree));
5313 }
5316 /* Straightforward calls of libf2c routines: */
5393 }
5402 tree_type,
5407 /* See bottom of this file for f2c transforms used to determine
5408 many of the above implementations. The info seems to confuse
5409 Emacs's C mode indentation, which is why it's been moved to
5410 the bottom of this source file. */
5411 }
5413 /* For power (exponentiation) where right-hand operand is type INTEGER,
5414 generate in-line code to do it the fast way (which, if the operand
5415 is a constant, might just mean a series of multiplies). */
5417 static tree
5419 {
5431 {
5439 {
5440 /* Reciprocal of integer is either 0, -1, or 1, so after
5441 calculating that (which we leave to the back end to do
5442 or not do optimally), don't bother with any multiplying. */
5446 l,
5449 rtype,
5450 r);
5453 result);
5454 }
5456 /* Generate appropriate series of multiplies, preceded
5457 by divide if the exponent is negative. */
5462 {
5465 l,
5475 r,
5476 integer_one_node));
5479 l,
5480 l);
5481 }
5482 }
5485 {
5487 {
5490 else
5492 result,
5493 l);
5494 }
5497 r,
5498 integer_one_node);
5505 l,
5506 l);
5507 }
5509 }
5511 /* Though rhs isn't a constant, in-line code cannot be expanded
5512 while transforming dummies
5513 because the back end cannot be easily convinced to generate
5514 stores (MODIFY_EXPR), handle temporaries, and so on before
5515 all the appropriate rtx's have been generated for things like
5516 dummy args referenced in rhs -- which doesn't happen until
5517 store_parm_decls() is called (expand_function_start, I believe,
5518 does the actual rtx-stuffing of PARM_DECLs).
5520 So, in this case, let the caller generate the call to the
5521 run-time-library function to evaluate the power for us. */
5526 /* Right-hand operand not a constant, expand in-line code to figure
5527 out how to do the multiplies, &c.
5529 The returned expression is expressed this way in GNU C, where l and
5530 r are the "inputs":
5532 ({ typeof (r) rtmp = r;
5533 typeof (l) ltmp = l;
5534 typeof (l) result;
5536 if (rtmp == 0)
5537 result = 1;
5538 else
5539 {
5540 if ((basetypeof (l) == basetypeof (int))
5541 && (rtmp < 0))
5542 {
5543 result = ((typeof (l)) 1) / ltmp;
5544 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5545 result = -result;
5546 }
5547 else
5548 {
5549 result = 1;
5550 if ((basetypeof (l) != basetypeof (int))
5551 && (rtmp < 0))
5552 {
5553 ltmp = ((typeof (l)) 1) / ltmp;
5554 rtmp = -rtmp;
5555 if (rtmp < 0)
5556 {
5557 rtmp = -(rtmp >> 1);
5558 ltmp *= ltmp;
5559 }
5560 }
5561 for (;;)
5562 {
5563 if (rtmp & 1)
5564 result *= ltmp;
5565 if ((rtmp >>= 1) == 0)
5566 break;
5567 ltmp *= ltmp;
5568 }
5569 }
5570 }
5571 result;
5572 })
5574 Note that some of the above is compile-time collapsable, such as
5575 the first part of the if statements that checks the base type of
5576 l against int. The if statements are phrased that way to suggest
5577 an easy way to generate the if/else constructs here, knowing that
5578 the back end should (and probably does) eliminate the resulting
5579 dead code (either the int case or the non-int case), something
5580 it couldn't do without the redundant phrasing, requiring explicit
5581 dead-code elimination here, which would be kind of difficult to
5582 read. */
5584 {
5585 tree rtmp;
5586 tree ltmp;
5587 tree divide;
5588 tree basetypeof_l_is_int;
5589 tree se;
5590 tree t;
5592 basetypeof_l_is_int
5609 else
5613 rtmp,
5614 r));
5616 ltmp,
5617 l));
5620 rtmp,
5624 result,
5628 {
5630 rtmp,
5632 integer_zero_node)),
5635 result,
5636 ffecom_tree_divide_
5639 ltmp,
5641 divide)));
5645 ltmp,
5647 integer_zero_node)),
5650 rtype,
5652 rtype,
5653 rtmp),
5655 integer_one_node)),
5657 integer_zero_node)))),
5660 result,
5662 ltype,
5663 result)));
5666 }
5668 result,
5672 ffecom_truth_value_invert
5675 rtmp,
5677 integer_zero_node)))),
5680 ltmp,
5681 ffecom_tree_divide_
5684 ltmp,
5686 divide)));
5688 rtmp,
5690 rtmp)));
5693 rtmp,
5697 rtmp,
5700 rtype,
5701 rtmp,
5702 integer_one_node))));
5704 ltmp,
5706 ltmp,
5707 ltmp)));
5713 rtmp,
5717 result,
5719 result,
5720 ltmp)));
5723 ffecom_truth_value
5725 rtmp,
5727 rtype,
5728 rtmp,
5729 integer_one_node))));
5731 ltmp,
5733 ltmp,
5734 ltmp)));
5745 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5748 {
5749 /* Make a BIND_EXPR for the BLOCK already made. */
5752 /* Remove the block from the tree at this point.
5753 It gets put back at the proper place
5754 when the BIND_EXPR is expanded. */
5756 }
5757 else
5759 }
5762 }
5764 /* ffecom_expr_transform_ -- Transform symbols in expr
5766 ffebld expr; // FFE expression.
5767 ffecom_expr_transform_ (expr);
5769 Recursive descent on expr while transforming any untransformed SYMTERs. */
5771 static void
5773 {
5774 tree t;
5775 ffesymbol s;
5777 tail_recurse:
5783 {
5791 {
5794 DIMENSION expr? */
5795 }
5805 }
5808 {
5820 }
5823 }
5825 /* Make a type based on info in live f2c.h file. */
5827 static void
5829 {
5831 {
5854 ? signed_char_type_node
5888 }
5893 }
5895 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5896 given size. */
5898 static void
5900 {
5902 tree t;
5907 {
5911 }
5912 }
5914 /* Finish up globals after doing all program units in file
5916 Need to handle only uninitialized COMMON areas. */
5918 static ffeglobal
5920 {
5921 tree cbtype;
5922 tree cbt;
5923 tree size;
5938 /* Give the array a size now. */
5946 integer_zero_node,
5947 size);
5958 }
5960 /* Finish up any untransformed symbols. */
5962 static ffesymbol
5964 {
5968 /* It's easy to know to transform an untransformed symbol, to make sure
5969 we put out debugging info for it. But COMMON variables, unlike
5970 EQUIVALENCE ones, aren't given declarations in addition to the
5971 tree expressions that specify offsets, because COMMON variables
5972 can be referenced in the outer scope where only dummy arguments
5973 (PARM_DECLs) should really be seen. To be safe, just don't do any
5974 VAR_DECLs for COMMON variables when we transform them for real
5975 use, and therefore we do all the VAR_DECL creating here. */
5978 {
5983 /* Not transformed, and not CHARACTER*(*), and not a dummy
5984 argument, which can happen only if the entry point names
5985 it "rides in on" are all invalidated for other reasons. */
5987 }
5991 {
5992 /* This isn't working, at least for dbxout. The .s file looks
5993 okay to me (burley), but in gdb 4.9 at least, the variables
5994 appear to reside somewhere outside of the common area, so
5995 it doesn't make sense to mislead anyone by generating the info
5996 on those variables until this is fixed. NOTE: Same problem
5997 with EQUIVALENCE, sadly...see similar #if later. */
6000 }
6003 }
6005 /* Append underscore(s) to name before calling get_identifier. "us"
6006 is nonzero if the name already contains an underscore and thus
6007 needs two underscores appended. */
6009 static tree
6011 {
6014 tree id;
6028 }
6030 /* Decide whether to append underscore to name before calling
6031 get_identifier. */
6033 static tree
6035 {
6039 /* If name is a built-in name, just return it as is. */
6052 }
6054 /* Decide whether to append underscore to internal name before calling
6055 get_identifier.
6057 This is for non-external, top-function-context names only. Transform
6058 identifier so it doesn't conflict with the transformed result
6059 of using a _different_ external name. E.g. if "CALL FOO" is
6060 transformed into "FOO_();", then the variable in "FOO_ = 3"
6061 must be transformed into something that does not conflict, since
6062 these two things should be independent.
6064 The transformation is as follows. If the name does not contain
6065 an underscore, there is no possible conflict, so just return.
6066 If the name does contain an underscore, then transform it just
6067 like we transform an external identifier. */
6069 static tree
6071 {
6072 /* If name does not contain an underscore, just return it as is. */
6079 name);
6080 }
6082 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6084 tree t;
6085 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6086 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6087 ffesymbol_kindtype(s));
6089 Call after setting up containing function and getting trees for all
6090 other symbols. */
6092 static tree
6094 {
6096 tree type;
6097 tree func;
6098 tree result;
6105 /* For now, we don't have a handy pointer to where the sfunc is actually
6106 defined, though that should be easy to add to an ffesymbol. (The
6107 token/where info available might well point to the place where the type
6108 of the sfunc is declared, especially if that precedes the place where
6109 the sfunc itself is defined, which is typically the case.) We should
6110 put out a null pointer rather than point somewhere wrong, but I want to
6111 see how it works at this point. */
6116 /* Pretransform the expression so any newly discovered things belong to the
6117 outer program unit, not to the statement function. */
6121 /* Make sure no recursive invocation of this fn (a specific case of failing
6122 to pretransform an sfunc's expression, i.e. where its expression
6123 references another untransformed sfunc) happens. */
6132 else
6133 {
6137 error. */
6138 }
6145 /* We don't worry about COMPLEX return values here, because this is
6146 entirely internal to our code, and gcc has the ability to return COMPLEX
6147 directly as a value. */
6151 tree type;
6163 }
6164 else
6174 {
6176 {
6178 tree result_length;
6189 }
6190 else
6191 {
6199 }
6200 }
6216 }
6220 {
6222 }
6224 static tree
6226 {
6233 }
6235 /* Return initialize-to-zero expression for this VAR_DECL. */
6237 /* A somewhat evil way to prevent the garbage collector
6238 from collecting 'tree' structures. */
6239 #define NUM_TRACKED_CHUNK 63
6241 {
6244 };
6247 void
6249 {
6254 {
6257 }
6259 {
6260 /* Need to allocate a new block. */
6268 }
6269 }
6271 static tree
6273 {
6274 tree init;
6279 {
6282 }
6290 {
6294 }
6295 else
6296 {
6299 }
6302 }
6304 static tree
6306 {
6307 tree expr_tree;
6308 tree length_tree;
6311 {
6314 (ffebld_constant_character1
6316 {
6319 }
6323 (ffebld_constant_character1
6337 {
6340 }
6343 {
6346 }
6348 expr_tree
6351 expr_tree);
6352 expr_tree
6355 expr_tree,
6356 integer_one_node);
6362 *maybe_tree
6363 = ffecom_truth_value
6365 length_tree,
6366 ffecom_f2c_ftnlen_zero_node));
6372 {
6375 }
6377 maybe_tree);
6380 {
6381 tree maybe_left;
6382 tree maybe_right;
6383 tree expr_left;
6384 tree expr_right;
6391 maybe_left,
6392 maybe_right);
6394 maybe_left,
6395 expr_left,
6396 expr_right);
6398 }
6403 }
6404 }
6406 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6408 tree length_arg;
6409 ffebld expr;
6410 length_arg = ffecom_intrinsic_len_ (expr);
6412 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6413 subexpressions by constructing the appropriate tree for the
6414 length-of-character-text argument in a calling sequence. */
6416 static tree
6418 {
6419 ffetargetCharacter1 val;
6420 tree length;
6423 {
6431 {
6433 tree item;
6437 {
6440 }
6442 {
6445 else
6446 {
6449 }
6450 }
6455 }
6463 {
6464 ffebld start;
6465 ffebld end;
6467 tree start_tree;
6468 tree end_tree;
6482 {
6484 ;
6485 else
6486 {
6489 }
6490 }
6491 else
6492 {
6497 {
6500 }
6503 {
6505 ffecom_f2c_ftnlen_one_node,
6507 ffecom_f2c_ftnlen_type_node,
6508 length,
6509 start_tree));
6510 }
6511 else
6512 {
6517 {
6520 }
6523 ffecom_f2c_ftnlen_one_node,
6525 ffecom_f2c_ftnlen_type_node,
6527 }
6528 }
6529 }
6533 length
6549 }
6554 }
6556 /* Handle CHARACTER assignments.
6558 Generates code to do the assignment. Used by ordinary assignment
6559 statement handler ffecom_let_stmt and by statement-function
6560 handler to generate code for a statement function. */
6562 static void
6565 {
6566 ffecomConcatList_ catlist;
6567 tree source_length;
6568 tree source_tree;
6569 tree expr_tree;
6578 /* Source might be an opCONVERT, which just means it is a different size
6579 than the destination. Since the underlying implementation here handles
6580 that (directly or via the s_copy or s_cat run-time-library functions),
6581 we don't need the "convenience" of an opCONVERT that tells us to
6582 truncate or blank-pad, particularly since the resulting implementation
6583 would probably be slower than otherwise. */
6590 {
6621 {
6622 dest_tree
6626 dest_tree);
6627 dest_tree
6631 dest_tree,
6632 integer_one_node);
6633 source_tree
6637 source_tree);
6638 source_tree
6642 source_tree,
6643 integer_one_node);
6650 }
6668 }
6670 /* Heavy-duty concatenation. */
6672 {
6675 tree lengths;
6676 tree items;
6677 tree length_array;
6678 tree item_array;
6679 tree citem;
6680 tree clength;
6682 {
6683 tree hook;
6691 }
6694 {
6699 {
6702 }
6704 items
6709 item_array,
6711 citem),
6712 items);
6713 lengths
6718 length_array,
6720 clength),
6721 lengths);
6722 }
6729 items));
6734 lengths));
6736 = build_tree_list
6748 }
6751 }
6753 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6755 ffecomGfrt ix;
6756 ffecom_make_gfrt_(ix);
6758 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6759 for the indicated run-time routine (ix). */
6761 static void
6763 {
6764 tree t;
6765 tree ttype;
6768 {
6833 }
6838 ttype);
6844 /* Sanity check: A function that's const cannot be volatile. */
6848 /* Sanity check: A function that's const cannot return complex. */
6857 }
6859 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
6861 static void
6863 {
6868 }
6870 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
6871 the member so debugger will see it. Otherwise nobody should be
6872 referencing the member. */
6874 static void
6876 {
6877 ffesymbol s;
6878 tree t;
6879 tree mt;
6880 tree type;
6899 type);
6916 }
6918 /* Prepare source expression for assignment into a destination perhaps known
6919 to be of a specific size. */
6921 static void
6923 {
6924 ffecomConcatList_ catlist;
6927 tree ltmp;
6928 tree itmp;
6938 {
6939 ltmp
6942 itmp
6949 }
6957 {
6960 }
6961 }
6963 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
6965 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
6966 (which generates their trees) and then their trees get push_parm_decl'd.
6968 The second arg is TRUE if the dummies are for a statement function, in
6969 which case lengths are not pushed for character arguments (since they are
6970 always known by both the caller and the callee, though the code allows
6971 for someday permitting CHAR*(*) stmtfunc dummies). */
6973 static void
6975 {
6976 ffebld dummy;
6977 ffebld dumlist;
6978 ffesymbol s;
6979 tree parm;
6983 /* First push the parms corresponding to actual dummy "contents". */
6986 {
6989 {
6996 }
7001 {
7005 }
7008 }
7010 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7013 {
7016 {
7020 NOTHING! */
7024 }
7030 length param. */
7037 }
7040 }
7042 /* ffecom_start_progunit_ -- Beginning of program unit
7044 Does GNU back end stuff necessary to teach it about the start of its
7045 equivalent of a Fortran program unit. */
7047 static void
7049 {
7051 ffebld arglist;
7055 ffeinfoBasictype bt;
7056 ffeinfoKindtype kt;
7057 ffeglobal g;
7058 ffeglobalType gt;
7063 bool multi
7064 = altentries
7077 {
7103 {
7109 }
7119 else
7126 else
7141 else
7149 /* Fall through. */
7158 }
7161 {
7164 }
7165 #if FFETARGET_isENFORCED_MAIN
7168 #endif
7169 else
7173 type,
7183 {
7185 }
7187 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7188 exec-transitioning needs current_function_decl to be filled in. So we
7189 do these things in two phases. */
7193 ffecom_which_entrypoint_decl_
7197 integer_type_node);
7199 }
7202 || cmplxfunc
7205 tree type;
7206 tree length;
7212 else
7217 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7221 else
7230 else
7234 {
7237 }
7238 }
7241 {
7244 else
7247 }
7253 /* Disallow temp vars at this level. */
7258 /* This handles any symbols still untransformed, in case -g specified.
7259 This used to be done in ffecom_finish_progunit, but it turns out to
7260 be necessary to do it here so that statement functions are
7261 expanded before code. But don't bother for BLOCK DATA. */
7265 }
7267 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7269 ffesymbol s;
7270 ffecom_sym_transform_(s);
7272 The ffesymbol_hook info for s is updated with appropriate backend info
7273 on the symbol. */
7275 static ffesymbol
7277 {
7281 ffeinfoBasictype bt;
7282 ffeinfoKindtype kt;
7283 ffeglobal g;
7286 /* Must ensure special ASSIGN variables are declared at top of outermost
7287 block, else they'll end up in the innermost block when their first
7288 ASSIGN is seen, which leaves them out of scope when they're the
7289 subject of a GOTO or I/O statement.
7291 We make this variable even if -fugly-assign. Just let it go unused,
7292 in case it turns out there are cases where we really want to use this
7293 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7301 {
7304 }
7305 else
7306 {
7311 }
7321 {
7324 {
7328 /* Before 0.4, this could be ENTITY/DUMMY, but see
7329 ffestu_sym_end_transition -- no longer true (in particular, if
7330 it could be an ENTITY, it _will_ be made one, so that
7331 possibility won't come through here). So we never make length
7332 arg for CHARACTER type. */
7336 ffecom_tree_ptr_to_subr_type);
7350 {
7353 }
7376 /* Fall through. */
7379 }
7384 {
7387 /* ~~Debugging info needed? */
7395 {
7397 tree type;
7402 {
7405 }
7409 {
7412 }
7417 ffestorag est;
7418 tree et;
7419 ffetargetOffset offset;
7436 /* (t_type *) (((char *) &et) + offset) */
7441 et));
7443 t,
7446 t);
7450 }
7451 else
7452 {
7453 tree initexpr;
7458 type);
7462 #ifdef FFECOM_sizeMAXSTACKITEM
7465 #endif
7467 && (ffecom_primary_entry_kind_
7471 else
7477 /* Keep -Wunused from complaining about var if it
7478 is used as sfunc arg or DATA implied-DO. */
7485 {
7488 else
7490 }
7493 else
7499 {
7503 }
7504 }
7505 }
7513 it (& length). */
7518 }
7523 it. */
7527 }
7529 {
7532 }
7535 {
7538 ffecom_multi_retval_);
7543 }
7557 {
7558 tree type;
7559 ffebld dl;
7560 ffebld dim;
7561 tree low;
7562 tree high;
7563 tree old_sizes;
7568 {
7571 context; get it later. */
7573 }
7576 }
7577 else
7590 {
7598 else
7603 {
7604 /* Used to just do high=low. But for ffecom_tree_
7605 canonize_ref_, it probably is important to correctly
7606 assess the size. E.g. given COMPLEX C(*),CFUNC and
7607 C(2)=CFUNC(C), overlap can happen, while it can't
7608 for, say, C(1)=CFUNC(C(2)). */
7609 /* Even more recently used to set to INT_MAX, but that
7610 broke when some overflow checking went into the back
7611 end. Now we just leave the upper bound unspecified. */
7613 }
7614 else
7617 /* Determine whether array is conditionally adjustable,
7618 to decide whether back-end magic is needed.
7620 Normally the front end uses the back-end function
7621 variable_size to wrap SAVE_EXPR's around expressions
7622 affecting the size/shape of an array so that the
7623 size/shape info doesn't change during execution
7624 of the compiled code even though variables and
7625 functions referenced in those expressions might.
7627 variable_size also makes sure those saved expressions
7628 get evaluated immediately upon entry to the
7629 compiled procedure -- the front end normally doesn't
7630 have to worry about that.
7632 However, there is a problem with this that affects
7633 g77's implementation of entry points, and that is
7634 that it is _not_ true that each invocation of the
7635 compiled procedure is permitted to evaluate
7636 array size/shape info -- because it is possible
7637 that, for some invocations, that info is invalid (in
7638 which case it is "promised" -- i.e. a violation of
7639 the Fortran standard -- that the compiled code
7640 won't reference the array or its size/shape
7641 during that particular invocation).
7643 To phrase this in C terms, consider this gcc function:
7645 void foo (int *n, float (*a)[*n])
7646 {
7647 // a is "pointer to array ...", fyi.
7648 }
7650 Suppose that, for some invocations, it is permitted
7651 for a caller of foo to do this:
7653 foo (NULL, NULL);
7655 Now the _written_ code for foo can take such a call
7656 into account by either testing explicitly for whether
7657 (a == NULL) || (n == NULL) -- presumably it is
7658 not permitted to reference *a in various fashions
7659 if (n == NULL) I suppose -- or it can avoid it by
7660 looking at other info (other arguments, static/global
7661 data, etc.).
7663 However, this won't work in gcc 2.5.8 because it'll
7664 automatically emit the code to save the "*n"
7665 expression, which'll yield a NULL dereference for
7666 the "foo (NULL, NULL)" call, something the code
7667 for foo cannot prevent.
7669 g77 definitely needs to avoid executing such
7670 code anytime the pointer to the adjustable array
7671 is NULL, because even if its bounds expressions
7672 don't have any references to possible "absent"
7673 variables like "*n" -- say all variable references
7674 are to COMMON variables, i.e. global (though in C,
7675 local static could actually make sense) -- the
7676 expressions could yield other run-time problems
7677 for allowably "dead" values in those variables.
7679 For example, let's consider a more complicated
7680 version of foo:
7682 extern int i;
7683 extern int j;
7685 void foo (float (*a)[i/j])
7686 {
7687 ...
7688 }
7690 The above is (essentially) quite valid for Fortran
7691 but, again, for a call like "foo (NULL);", it is
7692 permitted for i and j to be undefined when the
7693 call is made. If j happened to be zero, for
7694 example, emitting the code to evaluate "i/j"
7695 could result in a run-time error.
7697 Offhand, though I don't have my F77 or F90
7698 standards handy, it might even be valid for a
7699 bounds expression to contain a function reference,
7700 in which case I doubt it is permitted for an
7701 implementation to invoke that function in the
7702 Fortran case involved here (invocation of an
7703 alternate ENTRY point that doesn't have the adjustable
7704 array as one of its arguments).
7706 So, the code that the compiler would normally emit
7707 to preevaluate the size/shape info for an
7708 adjustable array _must not_ be executed at run time
7709 in certain cases. Specifically, for Fortran,
7710 the case is when the pointer to the adjustable
7711 array == NULL. (For gnu-ish C, it might be nice
7712 for the source code itself to specify an expression
7713 that, if TRUE, inhibits execution of the code. Or
7714 reverse the sense for elegance.)
7716 (Note that g77 could use a different test than NULL,
7717 actually, since it happens to always pass an
7718 integer to the called function that specifies which
7719 entry point is being invoked. Hmm, this might
7720 solve the next problem.)
7722 One way a user could, I suppose, write "foo" so
7723 it works is to insert COND_EXPR's for the
7724 size/shape info so the dangerous stuff isn't
7725 actually done, as in:
7727 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7728 {
7729 ...
7730 }
7732 The next problem is that the front end needs to
7733 be able to tell the back end about the array's
7734 decl _before_ it tells it about the conditional
7735 expression to inhibit evaluation of size/shape info,
7736 as shown above.
7738 To solve this, the front end needs to be able
7739 to give the back end the expression to inhibit
7740 generation of the preevaluation code _after_
7741 it makes the decl for the adjustable array.
7743 Until then, the above example using the COND_EXPR
7744 doesn't pass muster with gcc because the "(a == NULL)"
7745 part has a reference to "a", which is still
7746 undefined at that point.
7748 g77 will therefore use a different mechanism in the
7749 meantime. */
7760 low,
7761 ffecom_integer_zero_node);
7766 high,
7767 ffecom_integer_zero_node);
7768 #endif
7770 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7771 probably. Fixes 950302-1.f. */
7776 /* ~~~Similarly, this fixes dumb0.f. The C front end
7777 does this, which is why dumb0.c would work. */
7782 type
7783 = build_array_type
7788 }
7791 {
7794 }
7798 {
7801 }
7806 /* If this arg is present in every entry point's list of
7807 dummy args, then we're done. */
7813 #if 1
7815 /* If variable_size in stor-layout has been called during
7816 the above, then get_pending_sizes should have the
7817 yet-to-be-evaluated saved expressions pending.
7818 Make the whole lot of them get emitted, conditionally
7819 on whether the array decl ("t" above) is not NULL. */
7821 {
7823 tree tem;
7828 {
7833 else
7834 sizes
7837 temv,
7838 sizes);
7839 }
7842 {
7843 sizes
7847 integer_type_node,
7848 t,
7849 null_pointer_node),
7850 sizes,
7852 integer_zero_node));
7855 sizes
7857 }
7861 }
7863 #else
7864 #if 0
7870 t,
7871 null_pointer_node);
7872 #else
7873 #if 0
7877 {
7883 }
7884 #endif
7885 #endif
7886 #endif
7887 }
7891 {
7892 ffesymbol cs;
7893 ffeglobal cg;
7894 tree ct;
7896 tree type;
7900 {
7903 }
7911 else
7918 else
7919 {
7920 ffetargetOffset offset;
7921 ffestorag cst;
7922 tree toffset;
7933 /* (t_type *) (((char *) &ct) + offset) */
7938 ct));
7944 t);
7948 }
7949 }
7961 /* Fall through. */
7965 }
7970 {
7984 {
7987 }
7992 else
7997 t);
8019 else
8020 t = build_pointer_type
8025 t);
8038 decls. */
8042 /* Fall through. */
8046 }
8051 {
8065 {
8068 }
8072 ffecom_tree_subr_type);
8093 ffecom_tree_ptr_to_subr_type);
8101 decls. */
8105 /* Fall through. */
8109 }
8114 {
8133 /* Fall through. */
8137 }
8142 {
8153 ffecom_tree_blockdata_type);
8176 /* Fall through. */
8180 }
8185 {
8205 /* Fall through. */
8209 }
8214 {
8233 /* Fall through. */
8237 }
8242 {
8262 /* Fall through. */
8266 }
8271 /* Fall through. */
8275 }
8284 }
8286 /* Transform into ASSIGNable symbol.
8288 Symbol has already been transformed, but for whatever reason, the
8289 resulting decl_tree has been deemed not usable for an ASSIGN target.
8290 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8291 another local symbol of type void * and stuff that in the assign_tree
8292 argument. The F77/F90 standards allow this implementation. */
8294 static ffesymbol
8296 {
8301 {
8304 }
8305 else
8306 {
8311 }
8321 {
8323 /* Unlike for regular vars, SAVE status is easy to determine for
8324 ASSIGNed vars, since there's no initialization, there's no
8325 effective storage association (so "SAVE J" does not apply to
8326 K even given "EQUIVALENCE (J,K)"), there's no size issue
8327 to worry about, etc. */
8332 else
8341 /* Note that twinning a DUMMY means the caller won't see
8342 the ASSIGNed value. But both F77 and F90 allow implementations
8343 to do this, i.e. disallow Fortran code that would try and
8344 take advantage of actually putting a label into a variable
8345 via a dummy argument (or any other storage association, for
8346 that matter). */
8353 }
8363 }
8365 /* Implement COMMON area in back end.
8367 Because COMMON-based variables can be referenced in the dimension
8368 expressions of dummy (adjustable) arrays, and because dummies
8369 (in the gcc back end) need to be put in the outer binding level
8370 of a function (which has two binding levels, the outer holding
8371 the dummies and the inner holding the other vars), special care
8372 must be taken to handle COMMON areas.
8374 The current strategy is basically to always tell the back end about
8375 the COMMON area as a top-level external reference to just a block
8376 of storage of the master type of that area (e.g. integer, real,
8377 character, whatever -- not a structure). As a distinct action,
8378 if initial values are provided, tell the back end about the area
8379 as a top-level non-external (initialized) area and remember not to
8380 allow further initialization or expansion of the area. Meanwhile,
8381 if no initialization happens at all, tell the back end about
8382 the largest size we've seen declared so the space does get reserved.
8383 (This function doesn't handle all that stuff, but it does some
8384 of the important things.)
8386 Meanwhile, for COMMON variables themselves, just keep creating
8387 references like *((float *) (&common_area + offset)) each time
8388 we reference the variable. In other words, don't make a VAR_DECL
8389 or any kind of component reference (like we used to do before 0.4),
8390 though we might do that as well just for debugging purposes (and
8391 stuff the rtl with the appropriate offset expression). */
8393 static void
8395 {
8398 tree cbt;
8399 tree cbtype;
8400 tree init;
8401 tree high;
8410 /* First update the size of the area in global terms. */
8419 /* If we already have declared this common block for a previous program
8420 unit, and either we already initialized it or we don't have new
8421 initialization for it, just return what we have without changing it. */
8424 && (!is_init
8426 {
8429 }
8431 /* Process inits. */
8434 {
8436 {
8437 ffebld sexp;
8439 /* Set the padding for the expression, so ffecom_expr
8440 knows to insert that many zeros. */
8442 {
8458 }
8466 }
8467 }
8468 else
8470 }
8471 else
8474 /* cbtype must be permanently allocated! */
8476 /* Allocate the MAX of the areas so far, seen filewide. */
8484 integer_zero_node,
8485 high));
8486 else
8490 {
8491 cbt
8494 cbtype);
8497 }
8498 else
8499 {
8502 }
8512 /* Make sure that any type can live in COMMON and be referenced
8513 without getting a bus error. We could pick the most restrictive
8514 alignment of all entities actually placed in the COMMON, but
8515 this seems easy enough. */
8529 {
8535 }
8542 }
8544 /* Make master area for local EQUIVALENCE. */
8546 static void
8548 {
8549 tree eqt;
8550 tree eqtype;
8551 tree init;
8552 tree high;
8562 /* Process inits. */
8565 {
8567 {
8568 ffebld sexp;
8570 /* Set the padding for the expression, so ffecom_expr
8571 knows to insert that many zeros. */
8573 {
8589 }
8594 }
8595 else
8597 }
8600 else
8606 eqst);
8614 ffecom_integer_zero_node,
8615 high));
8619 ffesymbol_text
8621 eqtype);
8624 || ffecom_member_namelisted_
8625 #ifdef FFECOM_sizeMAXSTACKITEM
8627 #endif
8632 else
8639 else
8644 /* Make sure that any type can live in EQUIVALENCE and be referenced
8645 without getting a bus error. We could pick the most restrictive
8646 alignment of all entities actually placed in the EQUIVALENCE, but
8647 this seems easy enough. */
8661 {
8666 }
8672 eqst);
8673 }
8675 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8677 static tree
8679 {
8680 tree nmlt;
8682 tree nmlinits;
8683 tree nameinit;
8684 tree varsinit;
8685 tree nvarsinit;
8686 tree field;
8687 tree high;
8693 mynumber++),
8694 nmltype);
8700 /* Process inits. */
8710 = build_type_variant
8711 (build_array_type
8714 ffecom_f2c_ftnlen_one_node,
8715 high)),
8720 nameinit);
8724 varsinit);
8728 {
8729 ffebld b;
8733 }
8741 varsinit);
8754 }
8756 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8757 analyzed on the assumption it is calculating a pointer to be
8758 indirected through. It must return the proper decl and offset,
8759 taking into account different units of measurements for offsets. */
8761 static void
8763 {
8765 {
8779 {
8780 /* An offset into COMMON. */
8783 /* Convert offset (presumably in bytes) into canonical units
8784 (presumably bits). */
8789 }
8790 /* Not a COMMON reference, so an unrecognized pattern. */
8801 {
8802 /* A reference to COMMON. */
8806 }
8807 /* Fall through. */
8809 /* Not a COMMON reference, so an unrecognized pattern. */
8812 }
8813 }
8815 /* Given a tree that is possibly intended for use as an lvalue, return
8816 information representing a canonical view of that tree as a decl, an
8817 offset into that decl, and a size for the lvalue.
8819 If there's no applicable decl, NULL_TREE is returned for the decl,
8820 and the other fields are left undefined.
8822 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8823 is returned for the decl, and the other fields are left undefined.
8825 Otherwise, the decl returned currently is either a VAR_DECL or a
8826 PARM_DECL.
8828 The offset returned is always valid, but of course not necessarily
8829 a constant, and not necessarily converted into the appropriate
8830 type, leaving that up to the caller (so as to avoid that overhead
8831 if the decls being looked at are different anyway).
8833 If the size cannot be determined (e.g. an adjustable array),
8834 an ERROR_MARK node is returned for the size. Otherwise, the
8835 size returned is valid, not necessarily a constant, and not
8836 necessarily converted into the appropriate type as with the
8837 offset.
8839 Note that the offset and size expressions are expressed in the
8840 base storage units (usually bits) rather than in the units of
8841 the type of the decl, because two decls with different types
8842 might overlap but with apparently non-overlapping array offsets,
8843 whereas converting the array offsets to consistant offsets will
8844 reveal the overlap. */
8846 static void
8848 {
8849 /* The default path is to report a nonexistant decl. */
8856 {
8924 {
8927 tree init_offset;
8931 {
8934 }
8937 array);
8942 /* Calculate ((element - base) * NBBY) + init_offset. */
8944 element,
8956 }
8960 /* Most of this code is to handle references to COMMON. And so
8961 far that is useful only for calling library functions, since
8962 external (user) functions might reference common areas. But
8963 even calling an external function, it's worthwhile to decode
8964 COMMON references because if not storing into COMMON, we don't
8965 want COMMON-based arguments to gratuitously force use of a
8966 temporary. */
8992 }
8993 }
8995 /* Do divide operation appropriate to type of operands. */
8997 static tree
9000 {
9006 {
9009 left,
9010 right);
9015 left,
9016 right);
9017 {
9018 ffecomGfrt ix;
9023 else
9028 left);
9032 right);
9039 tree_type,
9040 left,
9043 }
9047 {
9048 ffecomGfrt ix;
9053 else
9058 left);
9062 right);
9069 tree_type,
9070 left,
9073 }
9078 left,
9079 right);
9080 }
9081 }
9083 /* Build type info for non-dummy variable. */
9085 static tree
9087 {
9088 tree type;
9089 ffebld dl;
9090 ffebld dim;
9091 tree lowt;
9092 tree hight;
9096 {
9100 type
9101 = build_array_type
9104 ffecom_f2c_ftnlen_one_node,
9105 hight));
9107 }
9110 {
9119 else
9135 }
9138 }
9140 /* Build Namelist type. */
9143 static tree
9145 {
9147 {
9157 string_type_node);
9160 integer_type_node);
9166 }
9169 }
9171 /* Build Vardesc type. */
9174 static tree
9176 {
9178 {
9183 string_type_node);
9185 string_type_node);
9187 ffecom_f2c_ptr_to_ftnlen_type_node);
9189 integer_type_node);
9195 }
9198 }
9200 static tree
9202 {
9203 ffesymbol s;
9209 {
9212 tree var;
9213 tree nameinit;
9214 tree dimsinit;
9215 tree addrinit;
9216 tree typeinit;
9217 tree field;
9218 tree varinits;
9223 mynumber++),
9224 vardesctype);
9230 /* Process inits. */
9236 = build_type_variant
9237 (build_array_type
9240 integer_one_node,
9247 nameinit);
9254 {
9261 }
9262 else
9266 nameinit);
9268 addrinit);
9283 }
9286 }
9288 static tree
9290 {
9291 ffebld b;
9292 tree list;
9294 tree var;
9301 {
9302 tree t;
9308 else
9309 {
9312 }
9313 }
9317 integer_one_node,
9331 }
9333 static tree
9335 {
9338 integer_zero_node);
9340 {
9341 ffebld b;
9342 ffebld e;
9343 tree list;
9344 tree backlist;
9346 tree var;
9347 tree numdim;
9348 tree numelem;
9363 {
9364 tree t;
9365 tree low;
9366 tree back;
9370 else
9371 {
9377 else
9378 {
9381 }
9382 }
9386 else
9393 }
9396 {
9399 else
9403 ffecom_f2c_ftnlen_type_node,
9405 baseoff));
9406 }
9408 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9421 integer_zero_node,
9422 build_int_2
9439 }
9440 }
9442 /* Essentially does a "fold (build1 (code, type, node))" while checking
9443 for certain housekeeping things.
9445 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9446 ffecom_1_fn instead. */
9448 tree
9450 {
9451 tree item;
9458 {
9461 }
9464 {
9465 tree realtype;
9478 {
9481 }
9484 item =
9488 node)),
9491 node)));
9497 }
9506 }
9508 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9509 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9510 does not set TREE_ADDRESSABLE (because calling an inline
9511 function does not mean the function needs to be separately
9512 compiled). */
9514 tree
9516 {
9517 tree item;
9518 tree type;
9533 }
9535 /* Essentially does a "fold (build (code, type, node1, node2))" while
9536 checking for certain housekeeping things. */
9538 tree
9540 {
9541 tree item;
9549 {
9564 {
9567 }
9571 item =
9575 node1),
9577 node2)),
9580 node1),
9582 node2)));
9587 {
9590 }
9594 item =
9598 node1),
9600 node2)),
9603 node1),
9605 node2)));
9610 {
9613 }
9618 node1));
9620 node1));
9622 node2));
9624 node2));
9625 item =
9629 a,
9630 c),
9632 b,
9633 d)),
9636 a,
9637 d),
9639 c,
9640 b)));
9646 {
9649 }
9655 item =
9659 node1),
9661 node2)),
9664 node1),
9666 node2)));
9672 {
9675 }
9681 item =
9685 node1),
9687 node2)),
9690 node1),
9692 node2)));
9698 }
9703 }
9705 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9707 ffesymbol s; // the ENTRY point itself
9708 if (ffecom_2pass_advise_entrypoint(s))
9709 // the ENTRY point has been accepted
9711 Does whatever compiler needs to do when it learns about the entrypoint,
9712 like determine the return type of the master function, count the
9713 number of entrypoints, etc. Returns FALSE if the return type is
9714 not compatible with the return type(s) of other entrypoint(s).
9716 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9717 later (after _finish_progunit) be called with the same entrypoint(s)
9718 as passed to this fn for which TRUE was returned.
9720 03-Jan-92 JCB 2.0
9721 Return FALSE if the return type conflicts with previous entrypoints. */
9723 bool
9725 {
9739 arglist's dummies. */
9749 {
9756 else
9759 }
9760 }
9762 /* If necessary, scan entry arglist for alternate returns. Do this scan
9763 apparently redundantly (it's done below to UNIONize the arglists) so
9764 that we don't complain about RETURN 1 if an offending ENTRY is the only
9765 one with an alternate return. */
9768 {
9772 {
9775 {
9778 }
9779 }
9780 }
9782 /* Now check type compatibility. */
9785 {
9791 ok
9802 {
9805 }
9808 {
9811 }
9813 }
9816 {
9821 }
9823 /* Entrypoint type compatible with previous types. */
9827 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9832 {
9841 appending of arg. */
9844 }
9848 /* Append this arg to the master list. */
9853 else
9855 }
9858 }
9860 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9862 ffesymbol s; // the ENTRY point itself
9863 ffecom_2pass_do_entrypoint(s);
9865 Does whatever compiler needs to do to make the entrypoint actually
9866 happen. Must be called for each entrypoint after
9867 ffecom_finish_progunit is called. */
9869 void
9871 {
9880 }
9881 else
9887 }
9889 /* Essentially does a "fold (build (code, type, node1, node2))" while
9890 checking for certain housekeeping things. Always sets
9891 TREE_SIDE_EFFECTS. */
9893 tree
9895 {
9896 tree item;
9906 }
9908 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9909 checking for certain housekeeping things. */
9911 tree
9913 {
9914 tree item;
9927 }
9929 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9930 checking for certain housekeeping things. Always sets
9931 TREE_SIDE_EFFECTS. */
9933 tree
9935 {
9936 tree item;
9947 }
9949 /* ffecom_arg_expr -- Transform argument expr into gcc tree
9951 See use by ffecom_list_expr.
9953 If expression is NULL, returns an integer zero tree. If it is not
9954 a CHARACTER expression, returns whatever ffecom_expr
9955 returns and sets the length return value to NULL_TREE. Otherwise
9956 generates code to evaluate the character expression, returns the proper
9957 pointer to the result, but does NOT set the length return value to a tree
9958 that specifies the length of the result. (In other words, the length
9959 variable is always set to NULL_TREE, because a length is never passed.)
9961 21-Dec-91 JCB 1.1
9962 Don't set returned length, since nobody needs it (yet; someday if
9963 we allow CHARACTER*(*) dummies to statement functions, we'll need
9964 it). */
9966 tree
9968 {
9969 tree ign;
9980 }
9982 /* Transform expression into constant argument-pointer-to-expression tree.
9984 If the expression can be transformed into a argument-pointer-to-expression
9985 tree that is constant, that is done, and the tree returned. Else
9986 NULL_TREE is returned.
9988 That way, a caller can attempt to provide compile-time initialization
9989 of a variable and, if that fails, *then* choose to start a new block
9990 and resort to using temporaries, as appropriate. */
9992 tree
9994 {
9999 {
10003 }
10010 {
10011 tree t;
10017 }
10025 }
10027 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10029 See use by ffecom_list_ptr_to_expr.
10031 If expression is NULL, returns an integer zero tree. If it is not
10032 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10033 returns and sets the length return value to NULL_TREE. Otherwise
10034 generates code to evaluate the character expression, returns the proper
10035 pointer to the result, AND sets the length return value to a tree that
10036 specifies the length of the result.
10038 If the length argument is NULL, this is a slightly special
10039 case of building a FORMAT expression, that is, an expression that
10040 will be used at run time without regard to length. For the current
10041 implementation, which uses the libf2c library, this means it is nice
10042 to append a null byte to the end of the expression, where feasible,
10043 to make sure any diagnostic about the FORMAT string terminates at
10044 some useful point.
10046 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10047 length argument. This might even be seen as a feature, if a null
10048 byte can always be appended. */
10050 tree
10052 {
10053 tree item;
10054 tree ign_length;
10055 ffecomConcatList_ catlist;
10064 {
10068 {
10069 tree temp_exp;
10070 tree temp_length;
10077 temp_exp);
10078 }
10084 {
10087 }
10093 {
10102 }
10107 }
10120 {
10123 {
10126 }
10134 else
10143 }
10145 {
10148 tree lengths;
10149 tree items;
10150 tree length_array;
10151 tree item_array;
10152 tree citem;
10153 tree clength;
10154 tree temporary;
10155 tree num;
10156 tree known_length;
10157 ffetargetCharacterSize sz;
10160 /* ~~Kludge! */
10163 {
10164 tree hook;
10173 }
10178 {
10183 else
10188 {
10192 }
10194 items
10199 item_array,
10201 citem),
10202 items);
10205 known_length
10207 known_length,
10208 clength);
10209 lengths
10214 length_array,
10216 clength),
10217 lengths);
10218 }
10222 temporary);
10229 items));
10234 lengths));
10236 = build_tree_list
10249 item,
10250 temporary);
10254 }
10259 }
10261 /* Generate call to run-time function.
10263 The first arg is the GNU Fortran Run-Time function index, the second
10264 arg is the list of arguments to pass to it. Returned is the expression
10265 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10266 result (which may be void). */
10268 tree
10270 {
10276 }
10278 /* Transform constant-union to tree. */
10280 tree
10283 {
10284 tree item;
10287 {
10289 {
10293 {
10294 #if FFETARGET_okINTEGER1
10299 #endif
10301 #if FFETARGET_okINTEGER2
10306 #endif
10308 #if FFETARGET_okINTEGER3
10313 #endif
10315 #if FFETARGET_okINTEGER4
10317 #if HOST_BITS_PER_LONGLONG > HOST_BITS_PER_WIDE_INT
10318 {
10322 }
10323 #else
10326 #endif
10328 #endif
10332 /* Fall through. */
10335 }
10338 }
10342 {
10346 {
10347 #if FFETARGET_okLOGICAL1
10351 #endif
10353 #if FFETARGET_okLOGICAL2
10357 #endif
10359 #if FFETARGET_okLOGICAL3
10363 #endif
10365 #if FFETARGET_okLOGICAL4
10369 #endif
10373 /* Fall through. */
10376 }
10379 }
10383 {
10384 REAL_VALUE_TYPE val;
10387 {
10388 #if FFETARGET_okREAL1
10392 #endif
10394 #if FFETARGET_okREAL2
10398 #endif
10400 #if FFETARGET_okREAL3
10404 #endif
10408 /* Fall through. */
10411 }
10413 }
10417 {
10418 REAL_VALUE_TYPE real;
10419 REAL_VALUE_TYPE imag;
10423 {
10424 #if FFETARGET_okCOMPLEX1
10429 #endif
10431 #if FFETARGET_okCOMPLEX2
10436 #endif
10438 #if FFETARGET_okCOMPLEX3
10443 #endif
10447 /* Fall through. */
10450 }
10454 }
10459 ffetargetCharacter1 val;
10462 {
10463 #if FFETARGET_okCHARACTER1
10467 #endif
10471 /* Fall through. */
10474 }
10479 build_range_type
10481 integer_one_node,
10482 build_int_2
10483 (ffetarget_length_character1
10486 }
10490 {
10491 ffetargetHollerith h;
10495 /* If not at least as wide as default INTEGER, widen it. */
10498 else
10499 {
10504 FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10507 str);
10508 }
10511 build_range_type
10513 integer_one_node,
10514 build_int_2
10517 }
10521 {
10522 ffetargetInteger1 ival;
10523 ffetargetTypeless tless;
10524 ffebad error;
10531 }
10536 /* Fall through. */
10539 }
10544 }
10546 /* Transform constant-union to tree, with the type known. */
10548 tree
10550 ffebldConst ct)
10551 {
10552 tree item;
10557 {
10558 #if FFETARGET_okINTEGER1
10563 #endif
10564 #if FFETARGET_okINTEGER2
10569 #endif
10570 #if FFETARGET_okINTEGER3
10575 #endif
10576 #if FFETARGET_okINTEGER4
10578 #if HOST_BITS_PER_LONGLONG > HOST_BITS_PER_WIDE_INT
10579 {
10584 }
10585 #else
10588 #endif
10590 #endif
10591 #if FFETARGET_okLOGICAL1
10596 #endif
10597 #if FFETARGET_okLOGICAL2
10602 #endif
10603 #if FFETARGET_okLOGICAL3
10608 #endif
10609 #if FFETARGET_okLOGICAL4
10614 #endif
10619 }
10626 }
10627 /* Transform expression into constant tree.
10629 If the expression can be transformed into a tree that is constant,
10630 that is done, and the tree returned. Else NULL_TREE is returned.
10632 That way, a caller can attempt to provide compile-time initialization
10633 of a variable and, if that fails, *then* choose to start a new block
10634 and resort to using temporaries, as appropriate. */
10636 tree
10638 {
10649 {
10650 tree t;
10655 }
10658 }
10660 /* Handy way to make a field in a struct/union. */
10662 tree
10664 {
10665 tree field;
10675 }
10677 void
10679 {
10681 }
10683 /* End a compound statement (block). */
10685 tree
10687 {
10689 }
10691 /* ffecom_end_transition -- Perform end transition on all symbols
10693 ffecom_end_transition();
10695 Calls ffecom_sym_end_transition for each global and local symbol. */
10697 void
10699 {
10700 ffebld item;
10710 {
10712 }
10719 {
10720 ffebld callee;
10721 ffesymbol s;
10722 tree dt;
10723 tree t;
10724 tree var;
10731 {
10734 }
10740 number++),
10741 dt);
10753 }
10755 /* This handles any COMMON areas that weren't referenced but have, for
10756 example, important initial data. */
10764 }
10766 /* ffecom_exec_transition -- Perform exec transition on all symbols
10768 ffecom_exec_transition();
10770 Calls ffecom_sym_exec_transition for each global and local symbol.
10771 Make sure error updating not inhibited. */
10773 void
10775 {
10787 {
10789 }
10793 }
10795 /* Handle assignment statement.
10797 Convert dest and source using ffecom_expr, then join them
10798 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
10800 void
10802 {
10803 tree dest_tree;
10804 tree dest_length;
10805 tree source_tree;
10806 tree expr_tree;
10809 {
10811 tree assign_temp;
10813 /* This attempts to replicate the test below, but must not be
10814 true when the test below is false. (Always err on the side
10815 of creating unused temporaries, to avoid ICEs.) */
10820 {
10823 }
10824 else
10825 {
10828 }
10832 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10833 create a temporary through which the assignment is to take place,
10834 since MODIFY_EXPR doesn't handle partial overlap properly. */
10837 {
10839 ffecom_tree_type
10842 FFETARGET_charactersizeNONE,
10844 }
10845 else
10858 else
10859 {
10863 }
10870 {
10872 assign_temp,
10873 source_tree);
10876 dest_tree,
10877 assign_temp);
10878 }
10879 else
10881 dest_tree,
10882 source_tree);
10886 }
10895 source);
10896 }
10898 /* ffecom_expr -- Transform expr into gcc tree
10900 tree t;
10901 ffebld expr; // FFE expression.
10902 tree = ffecom_expr(expr);
10904 Recursive descent on expr while making corresponding tree nodes and
10905 attaching type info and such. */
10907 tree
10909 {
10911 }
10913 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
10915 tree
10917 {
10919 }
10921 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
10923 tree
10925 {
10927 }
10929 /* Transform expr for use as into read/write tree and stabilize the
10930 reference. Not for use on CHARACTER expressions.
10932 Recursive descent on expr while making corresponding tree nodes and
10933 attaching type info and such. */
10935 tree
10937 {
10939 /* Different target types not yet supported. */
10943 }
10945 /* Transform expr for use as into 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 /* Do global stuff. */
10963 void
10965 {
10970 }
10972 /* Public entry point for front end to access finish_decl. */
10974 void
10976 {
10979 }
10981 /* Finish a program unit. */
10983 void
10985 {
10992 }
10994 /* Wrapper for get_identifier. pattern is sprintf-like. */
10996 tree
10998 {
10999 tree decl;
11011 }
11013 ffeinfoBasictype
11015 {
11019 {
11057 }
11058 }
11060 ffeinfoKindtype
11062 {
11066 {
11104 }
11105 }
11107 void
11109 {
11110 tree endlink;
11113 tree t;
11114 tree field;
11115 ffetype type;
11116 ffetype base_type;
11120 tree ffecom_tree_ptr_to_fun_type_void;
11122 /* This block of code comes from the now-obsolete cktyps.c. It checks
11123 whether the compiler environment is buggy in known ways, some of which
11124 would, if not explicitly checked here, result in subtle bugs in g77. */
11127 {
11129 =
11138 {
11142 }
11146 {
11150 }
11154 {
11158 }
11159 }
11166 /* Make the binding_level structure for global names. */
11173 /* Define `int' and `char' first so that dbx will output them first. */
11175 integer_type_node));
11176 /* CHARACTER*1 is unsigned in ICHAR contexts. */
11179 char_type_node));
11181 long_integer_type_node));
11183 unsigned_type_node));
11185 long_unsigned_type_node));
11187 long_long_integer_type_node));
11189 long_long_unsigned_type_node));
11191 short_integer_type_node));
11193 short_unsigned_type_node));
11195 /* Set the sizetype before we make other types. This *should* be the
11196 first type we create. */
11198 set_sizetype
11200 ffecom_typesize_pointer_
11205 /* Define both `signed char' and `unsigned char'. */
11207 signed_char_type_node));
11210 unsigned_char_type_node));
11213 float_type_node));
11215 double_type_node));
11217 long_double_type_node));
11219 /* For now, override what build_common_tree_nodes has done. */
11223 complex_long_double_type_node
11227 complex_integer_type_node));
11229 complex_float_type_node));
11231 complex_double_type_node));
11233 complex_long_double_type_node));
11236 void_type_node));
11237 /* We are not going to have real types in C with less than byte alignment,
11238 so we might as well not have any types that claim to have it. */
11244 ffecom_tree_fun_type_void
11247 ffecom_tree_ptr_to_fun_type_void
11266 t);
11270 {
11275 }
11277 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11278 to size FLOAT_TYPE_SIZE because they have to be the same size as
11279 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11280 Compiler options and other such stuff that change the ways these
11281 types are set should not affect this particular setup. */
11286 t));
11290 type);
11296 type);
11304 t));
11309 t));
11312 type);
11318 type);
11325 t));
11330 t));
11333 type);
11339 type);
11346 t));
11351 t));
11354 type);
11360 type);
11367 t));
11369 #if 0
11375 {
11377 LONG_TYPE_SIZE);
11378 }
11379 #endif
11384 t));
11388 type);
11394 type);
11401 t));
11404 type);
11410 type);
11417 t));
11420 type);
11426 type);
11433 t));
11436 type);
11442 type);
11450 t));
11455 type);
11461 type);
11471 t));
11475 type);
11481 type);
11488 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11490 t));
11494 type);
11500 type);
11507 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11509 t));
11512 type);
11518 type);
11520 type);
11525 /* Make function and ptr-to-function types for non-CHARACTER types. */
11529 {
11531 {
11533 {
11534 /* Figure out the smallest INTEGER type that can hold
11535 a pointer on this machine. */
11538 {
11543 }
11544 }
11547 /* For f2c compatibility, REAL functions are really
11548 implemented as DOUBLE PRECISION. */
11551 t = ffecom_tree_type
11555 NULL_TREE);
11557 }
11558 }
11560 /* Set up pointer types. */
11567 FFEINFO_kindtypeINTEGERDEFAULT),
11570 ffecom_pointer_kind_));
11574 else
11579 ffecom_integer_type_node
11582 integer_zero_node);
11584 integer_one_node);
11586 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11587 Turns out that by TYLONG, runtime/libI77/lio.h really means
11588 "whatever size an ftnint is". For consistency and sanity,
11589 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11590 all are INTEGER, which we also make out of whatever back-end
11591 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11592 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11593 accommodate machines like the Alpha. Note that this suggests
11594 f2c and libf2c are missing a distinction perhaps needed on
11595 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11598 FFETARGET_f2cTYLONG);
11600 FFETARGET_f2cTYSHORT);
11602 FFETARGET_f2cTYINT1);
11604 FFETARGET_f2cTYQUAD);
11606 FFETARGET_f2cTYLOGICAL);
11608 FFETARGET_f2cTYLOGICAL2);
11610 FFETARGET_f2cTYLOGICAL1);
11611 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11613 FFETARGET_f2cTYQUAD);
11615 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11616 loop. CHARACTER items are built as arrays of unsigned char. */
11623 FFEINFO_kindtypeCHARACTER1,
11624 type);
11643 /* Make multi-return-value type and fields. */
11651 {
11668 }
11673 /* Subroutines usually return integer because they might have alternate
11674 returns. */
11676 ffecom_tree_subr_type
11678 ffecom_tree_ptr_to_subr_type
11680 ffecom_tree_blockdata_type
11763 FFECOM_f2cINTEGER,
11766 FFECOM_f2cADDRESS,
11769 FFECOM_f2cREAL,
11772 FFECOM_f2cDOUBLEREAL,
11775 FFECOM_f2cCOMPLEX,
11778 FFECOM_f2cDOUBLECOMPLEX,
11781 FFECOM_f2cLONGINT,
11784 FFECOM_f2cLOGICAL,
11787 FFECOM_f2cFLAG,
11790 FFECOM_f2cFTNLEN,
11793 FFECOM_f2cFTNINT,
11796 ffecom_f2c_ftnlen_zero_node
11799 ffecom_f2c_ftnlen_one_node
11805 ffecom_f2c_ptr_to_ftnlen_type_node
11808 ffecom_f2c_ptr_to_ftnint_type_node
11811 ffecom_f2c_ptr_to_integer_type_node
11814 ffecom_f2c_ptr_to_real_type_node
11822 /* Do "extern int xargc;". */
11826 integer_type_node);
11836 {
11843 }
11844 #endif
11849 /* I/O will probably crash. */
11853 #endif
11858 /* ASSIGN 10 TO I will crash. */
11863 #endif
11864 }
11866 /* ffecom_init_2 -- Initialize
11868 ffecom_init_2(); */
11870 void
11872 {
11883 }
11885 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11887 tree t;
11888 ffebld expr; // FFE opITEM list.
11889 tree = ffecom_list_expr(expr);
11891 List of actual args is transformed into corresponding gcc backend list. */
11893 tree
11895 {
11896 tree list;
11900 tree length;
11903 {
11913 {
11916 }
11917 }
11922 }
11924 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11926 tree t;
11927 ffebld expr; // FFE opITEM list.
11928 tree = ffecom_list_ptr_to_expr(expr);
11930 List of actual args is transformed into corresponding gcc backend list for
11931 use in calling an external procedure (vs. a statement function). */
11933 tree
11935 {
11936 tree list;
11940 tree length;
11943 {
11953 {
11956 }
11957 }
11962 }
11964 /* Obtain gcc's LABEL_DECL tree for label. */
11966 tree
11968 {
11969 tree glabel;
11972 {
11976 {
11982 void_type_node);
11989 ffecom_get_invented_identifier
11993 NULL_TREE),
12014 }
12016 }
12017 else
12018 {
12020 }
12023 }
12025 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12026 a single source specification (as in the fourth argument of MVBITS).
12027 If the type is NULL_TREE, the type of lhs is used to make the type of
12028 the MODIFY_EXPR. */
12030 tree
12032 {
12043 }
12045 /* Register source file name. */
12047 void
12049 {
12051 }
12053 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12055 ffestorag st;
12056 ffecom_notify_init_storage(st);
12058 Gets called when all possible units in an aggregate storage area (a LOCAL
12059 with equivalences or a COMMON) have been initialized. The initialization
12060 info either is in ffestorag_init or, if that is NULL,
12061 ffestorag_accretion:
12063 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12064 even for an array if the array is one element in length!
12066 ffestorag_accretion will contain an opACCTER. It is much like an
12067 opARRTER except it has an ffebit object in it instead of just a size.
12068 The back end can use the info in the ffebit object, if it wants, to
12069 reduce the amount of actual initialization, but in any case it should
12070 kill the ffebit object when done. Also, set accretion to NULL but
12071 init to a non-NULL value.
12073 After performing initialization, DO NOT set init to NULL, because that'll
12074 tell the front end it is ok for more initialization to happen. Instead,
12075 set init to an opANY expression or some such thing that you can use to
12076 tell that you've already initialized the object.
12078 27-Oct-91 JCB 1.1
12079 Support two-pass FFE. */
12081 void
12083 {
12087 {
12093 }
12094 }
12096 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12098 ffesymbol s;
12099 ffecom_notify_init_symbol(s);
12101 Gets called when all possible units in a symbol (not placed in COMMON
12102 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12103 have been initialized. The initialization info either is in
12104 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12106 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12107 even for an array if the array is one element in length!
12109 ffesymbol_accretion will contain an opACCTER. It is much like an
12110 opARRTER except it has an ffebit object in it instead of just a size.
12111 The back end can use the info in the ffebit object, if it wants, to
12112 reduce the amount of actual initialization, but in any case it should
12113 kill the ffebit object when done. Also, set accretion to NULL but
12114 init to a non-NULL value.
12116 After performing initialization, DO NOT set init to NULL, because that'll
12117 tell the front end it is ok for more initialization to happen. Instead,
12118 set init to an opANY expression or some such thing that you can use to
12119 tell that you've already initialized the object.
12121 27-Oct-91 JCB 1.1
12122 Support two-pass FFE. */
12124 void
12126 {
12131 possibilities checked. */
12135 {
12139 }
12140 }
12142 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12144 ffesymbol s;
12145 ffecom_notify_primary_entry(s);
12147 Gets called when implicit or explicit PROGRAM statement seen or when
12148 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12149 global symbol that serves as the entry point. */
12151 void
12153 {
12160 else
12164 {
12167 else
12169 }
12172 {
12173 ffebld list;
12174 ffebld arg;
12179 {
12182 {
12185 }
12186 }
12187 }
12188 }
12192 {
12194 }
12196 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12198 tree t;
12199 ffebld expr; // FFE expression.
12200 tree = ffecom_ptr_to_expr(expr);
12202 Like ffecom_expr, but sticks address-of in front of most things. */
12204 tree
12206 {
12207 tree item;
12208 ffeinfoBasictype bt;
12209 ffeinfoKindtype kt;
12210 ffesymbol s;
12215 {
12219 {
12220 ffecomGfrt ix;
12225 {
12228 }
12229 }
12230 else
12231 {
12234 {
12237 }
12238 }
12244 item);
12261 item);
12275 /* The back end currently optimizes a bit too zealously for us, in that
12276 we fail JCB001 if the following block of code is omitted. It checks
12277 to see if the transformed expression is a symbol or array reference,
12278 and encloses it in a SAVE_EXPR if that is the case. */
12287 #ifdef OFFSET_REF
12289 #endif
12293 {
12295 }
12298 item);
12300 }
12304 }
12306 /* Obtain a temp var with given data type.
12308 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12309 or >= 0 for a CHARACTER type.
12311 elements is -1 for a scalar or > 0 for an array of type. */
12313 tree
12316 {
12317 tree t;
12328 ffecom_f2c_ftnlen_one_node,
12333 integer_zero_node,
12338 commentary,
12339 mynumber++),
12340 type);
12346 }
12348 /* Prepare argument pointer to expression.
12350 Like ffecom_prepare_expr, except for expressions to be evaluated
12351 via ffecom_arg_ptr_to_expr. */
12353 void
12355 {
12356 /* ~~For now, it seems to be the same thing. */
12359 }
12361 /* End of preparations. */
12363 bool
12365 {
12372 }
12374 /* Prepare expression.
12376 This is called before any code is generated for the current block.
12377 It scans the expression, declares any temporaries that might be needed
12378 during evaluation of the expression, and stores those temporaries in
12379 the appropriate "hook" fields of the expression. `dest', if not NULL,
12380 specifies the destination that ffecom_expr_ will see, in case that
12381 helps avoid generating unused temporaries.
12383 ~~Improve to avoid allocating unused temporaries by taking `dest'
12384 into account vis-a-vis aliasing requirements of complex/character
12385 functions. */
12387 void
12389 {
12390 ffeinfoBasictype bt;
12391 ffeinfoKindtype kt;
12392 ffetargetCharacterSize sz;
12404 /* Generate whatever temporaries are needed to represent the result
12405 of the expression. */
12408 {
12411 }
12414 {
12416 /* Don't make temps for SYMTER, CONTER, etc. */
12421 {
12424 {
12425 ffesymbol s;
12437 }
12439 {
12440 /* Requires special treatment. There's no POW_CC function
12441 in libg2c, so POW_ZZ is used, which means we always
12442 need a double-complex temp, not a single-complex. */
12444 }
12446 /* The other ops don't need temps for complex operands. */
12449 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12450 REAL(C). See 19990325-0.f, routine `check', for cases. */
12452 ffecom_tree_type
12454 FFETARGET_charactersizeNONE,
12463 /* ~~Kludge alert! This should someday be fixed. */
12471 }
12475 {
12476 /* This gets special handling, because only one set of temps
12477 is needed for a tree of these -- the tree is treated as
12478 a flattened list of concatenations when generating code. */
12480 ffecomConcatList_ catlist;
12489 {
12490 ltmp
12492 ffecom_f2c_ftnlen_type_node,
12494 itmp
12496 ffecom_f2c_address_type_node,
12498 result
12500 char_type_node,
12508 }
12512 i));
12517 {
12520 }
12521 }
12531 }
12534 {
12537 }
12539 /* Prepare subexpressions for this expr. */
12542 {
12557 {
12558 ffebld item;
12565 }
12569 /* Need to handle character conversion specially. */
12571 {
12583 }
12584 }
12587 }
12589 /* Prepare expression for reading and writing.
12591 Like ffecom_prepare_expr, except for expressions to be evaluated
12592 via ffecom_expr_rw. */
12594 void
12596 {
12597 /* This is all we support for now. */
12600 /* ~~For now, it seems to be the same thing. */
12603 }
12605 /* Prepare expression for writing.
12607 Like ffecom_prepare_expr, except for expressions to be evaluated
12608 via ffecom_expr_w. */
12610 void
12612 {
12613 /* This is all we support for now. */
12616 /* ~~For now, it seems to be the same thing. */
12619 }
12621 /* Prepare expression for returning.
12623 Like ffecom_prepare_expr, except for expressions to be evaluated
12624 via ffecom_return_expr. */
12626 void
12628 {
12632 && ffecom_is_altreturning_
12635 }
12637 /* Prepare pointer to expression.
12639 Like ffecom_prepare_expr, except for expressions to be evaluated
12640 via ffecom_ptr_to_expr. */
12642 void
12644 {
12645 /* ~~For now, it seems to be the same thing. */
12648 }
12650 /* Transform expression into constant pointer-to-expression tree.
12652 If the expression can be transformed into a pointer-to-expression tree
12653 that is constant, that is done, and the tree returned. Else NULL_TREE
12654 is returned.
12656 That way, a caller can attempt to provide compile-time initialization
12657 of a variable and, if that fails, *then* choose to start a new block
12658 and resort to using temporaries, as appropriate. */
12660 tree
12662 {
12674 {
12675 tree t;
12680 }
12683 }
12685 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12687 tree rtn; // NULL_TREE means use expand_null_return()
12688 ffebld expr; // NULL if no alt return expr to RETURN stmt
12689 rtn = ffecom_return_expr(expr);
12691 Based on the program unit type and other info (like return function
12692 type, return master function type when alternate ENTRY points,
12693 whether subroutine has any alternate RETURN points, etc), returns the
12694 appropriate expression to be returned to the caller, or NULL_TREE
12695 meaning no return value or the caller expects it to be returned somewhere
12696 else (which is handled by other parts of this module). */
12698 tree
12700 {
12701 tree rtn;
12704 {
12715 else
12728 into (implicit) dummy. */
12731 }
12733 #if 0
12734 /* Spurious error if RETURN happens before first reference! So elide
12735 this code. In particular, for debugging registry, rtn should always
12736 be non-null after all, but TREE_USED won't be set until we encounter
12737 a reference in the code. Perfectly okay (but weird) code that,
12738 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12739 this diagnostic for no reason. Have people use -O -Wuninitialized
12740 and leave it to the back end to find obviously weird cases. */
12742 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12743 situation; if the return value has never been referenced, it won't
12744 have a tree under 2pass mode. */
12747 {
12754 }
12755 #endif
12763 }
12766 }
12768 /* Do save_expr only if tree is not error_mark_node. */
12770 tree
12772 {
12774 }
12776 /* Start a compound statement (block). */
12778 void
12780 {
12782 }
12784 /* Public entry point for front end to access start_decl. */
12786 tree
12788 {
12791 }
12793 /* ffecom_sym_commit -- Symbol's state being committed to reality
12795 ffesymbol s;
12796 ffecom_sym_commit(s);
12798 Does whatever the backend needs when a symbol is committed after having
12799 been backtrackable for a period of time. */
12801 void
12803 {
12805 }
12807 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12809 ffecom_sym_end_transition();
12811 Does backend-specific stuff and also calls ffest_sym_end_transition
12812 to do the necessary FFE stuff.
12814 Backtracking is never enabled when this fn is called, so don't worry
12815 about it. */
12817 ffesymbol
12819 {
12820 ffestorag st;
12828 {
12829 ffecom_list_blockdata_
12831 FFEINTRIN_specNONE,
12832 FFEINTRIN_impNONE),
12833 ffecom_list_blockdata_);
12834 }
12836 /* This is where we finally notice that a symbol has partial initialization
12837 and finalize it. */
12840 {
12843 }
12847 {
12850 }
12855 {
12856 ffecom_list_common_
12858 FFEINTRIN_specNONE,
12859 FFEINTRIN_impNONE),
12860 ffecom_list_common_);
12861 }
12864 }
12866 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12868 ffecom_sym_exec_transition();
12870 Does backend-specific stuff and also calls ffest_sym_exec_transition
12871 to do the necessary FFE stuff.
12873 See the long-winded description in ffecom_sym_learned for info
12874 on handling the situation where backtracking is inhibited. */
12876 ffesymbol
12878 {
12882 }
12884 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12886 ffesymbol s;
12887 s = ffecom_sym_learned(s);
12889 Called when a new symbol is seen after the exec transition or when more
12890 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
12891 it arrives here is that all its latest info is updated already, so its
12892 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12893 field filled in if its gone through here or exec_transition first, and
12894 so on.
12896 The backend probably wants to check ffesymbol_retractable() to see if
12897 backtracking is in effect. If so, the FFE's changes to the symbol may
12898 be retracted (undone) or committed (ratified), at which time the
12899 appropriate ffecom_sym_retract or _commit function will be called
12900 for that function.
12902 If the backend has its own backtracking mechanism, great, use it so that
12903 committal is a simple operation. Though it doesn't make much difference,
12904 I suppose: the reason for tentative symbol evolution in the FFE is to
12905 enable error detection in weird incorrect statements early and to disable
12906 incorrect error detection on a correct statement. The backend is not
12907 likely to introduce any information that'll get involved in these
12908 considerations, so it is probably just fine that the implementation
12909 model for this fn and for _exec_transition is to not do anything
12910 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12911 and instead wait until ffecom_sym_commit is called (which it never
12912 will be as long as we're using ambiguity-detecting statement analysis in
12913 the FFE, which we are initially to shake out the code, but don't depend
12914 on this), otherwise go ahead and do whatever is needed.
12916 In essence, then, when this fn and _exec_transition get called while
12917 backtracking is enabled, a general mechanism would be to flag which (or
12918 both) of these were called (and in what order? neat question as to what
12919 might happen that I'm too lame to think through right now) and then when
12920 _commit is called reproduce the original calling sequence, if any, for
12921 the two fns (at which point backtracking will, of course, be disabled). */
12923 ffesymbol
12925 {
12929 }
12931 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12933 ffesymbol s;
12934 ffecom_sym_retract(s);
12936 Does whatever the backend needs when a symbol is retracted after having
12937 been backtrackable for a period of time. */
12939 void
12941 {
12945 so nothing needed here. */
12947 {
12966 }
12967 #endif
12968 }
12970 /* Create temporary gcc label. */
12972 tree
12974 {
12975 tree glabel;
12980 mynumber++),
12981 void_type_node);
12986 }
12988 /* Return an expression that is usable as an arg in a conditional context
12989 (IF, DO WHILE, .NOT., and so on).
12991 Use the one provided for the back end as of >2.6.0. */
12993 tree
12995 {
12997 }
12999 /* Return the inversion of a truth value (the inversion of what
13000 ffecom_truth_value builds).
13002 Apparently invert_truthvalue, which is properly in the back end, is
13003 enough for now, so just use it. */
13005 tree
13007 {
13009 }
13011 /* Return the tree that is the type of the expression, as would be
13012 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13013 transforming the expression, generating temporaries, etc. */
13015 tree
13017 {
13018 ffeinfoBasictype bt;
13019 ffeinfoKindtype kt;
13020 tree tree_type;
13029 {
13072 /* Fall through. */
13075 }
13076 }
13078 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13080 If the PARM_DECL already exists, return it, else create it. It's an
13081 integer_type_node argument for the master function that implements a
13082 subroutine or function with more than one entrypoint and is bound at
13083 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13084 first ENTRY statement, and so on). */
13086 tree
13088 {
13092 }
13093 \f
13094 /* The following sections consists of private and public functions
13095 that have the same names and perform roughly the same functions
13096 as counterparts in the C front end. Changes in the C front end
13097 might affect how things should be done here. Only functions
13098 needed by the back end should be public here; the rest should
13099 be private (static in the C sense). Functions needed by other
13100 g77 front-end modules should be accessed by them via public
13101 ffecom_* names, which should themselves call private versions
13102 in this section so the private versions are easy to recognize
13103 when upgrading to a new gcc and finding interesting changes
13104 in the front end.
13106 Functions named after rule "foo:" in c-parse.y are named
13107 "bison_rule_foo_" so they are easy to find. */
13109 static void
13111 {
13116 }
13118 static tree
13120 {
13121 tree t;
13124 /* Make the temps go away. */
13133 }
13135 /* Return a definition for a builtin function named NAME and whose data type
13136 is TYPE. TYPE should be a function type with argument types.
13137 FUNCTION_CODE tells later passes how to compile calls to this function.
13138 See tree.h for its possible values.
13140 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13141 the name to be called if we can't opencode the function. If
13142 ATTRS is nonzero, use that for the function's attribute list. */
13144 tree
13147 tree attrs ATTRIBUTE_UNUSED)
13148 {
13160 }
13162 /* Handle when a new declaration NEWDECL
13163 has the same name as an old one OLDDECL
13164 in the same binding contour.
13165 Prints an error message if appropriate.
13167 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13168 Otherwise, return 0. */
13170 static int
13172 {
13186 /* New decl is completely inconsistent with the old one =>
13187 tell caller to replace the old one.
13188 This is always an error except in the case of shadowing a builtin. */
13192 /* For real parm decl following a forward decl,
13193 return 1 so old decl will be reused. */
13198 /* The new declaration is the same kind of object as the old one.
13199 The declarations may partially match. Print warnings if they don't
13200 match enough. Ultimately, copy most of the information from the new
13201 decl to the old one, and keep using the old one. */
13205 {
13206 /* A function declaration for a built-in function. */
13210 {
13211 /* Accept the return type of the new declaration if same modes. */
13216 {
13217 /* Function types may be shared, so we can't just modify
13218 the return type of olddecl's function type. */
13219 tree newtype
13226 }
13227 }
13230 }
13233 {
13234 /* A function declaration for a predeclared function
13235 that isn't actually built in. */
13239 {
13240 /* If the types don't match, preserve volatility indication.
13241 Later on, we will discard everything else about the
13242 default declaration. */
13244 }
13245 }
13247 /* Copy all the DECL_... slots specified in the new decl
13248 except for any that we copy here from the old type.
13250 Past this point, we don't change OLDTYPE and NEWTYPE
13251 even if we change the types of NEWDECL and OLDDECL. */
13254 {
13255 /* Merge the data types specified in the two decls. */
13261 /* Lay the type out, unless already done. */
13263 {
13270 }
13271 else
13272 {
13273 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13278 {
13281 }
13282 }
13284 /* Keep the old rtl since we can safely use it. */
13287 /* Merge the type qualifiers. */
13291 {
13295 }
13297 /* Keep source location of definition rather than declaration.
13298 Likewise, keep decl at outer scope. */
13301 {
13307 }
13309 /* Merge the unused-warning information. */
13315 /* Merge the initialization information. */
13319 /* Merge the section attribute.
13320 We want to issue an error if the sections conflict but that must be
13321 done later in decl_attributes since we are called before attributes
13322 are assigned. */
13326 /* Copy the assembler name. */
13330 {
13337 }
13338 }
13339 /* If cannot merge, then use the new type and qualifiers,
13340 and don't preserve the old rtl. */
13341 else
13342 {
13347 }
13349 /* Merge the storage class information. */
13350 /* For functions, static overrides non-static. */
13352 {
13354 /* This is since we don't automatically
13355 copy the attributes of NEWDECL into OLDDECL. */
13357 /* If this clears `static', clear it in the identifier too. */
13360 }
13362 {
13365 /* An extern decl does not override previous storage class. */
13367 }
13368 else
13369 {
13372 }
13374 /* If either decl says `inline', this fn is inline,
13375 unless its definition was passed already. */
13380 /* Get rid of any built-in function if new arg types don't match it
13381 or if we have a function definition. */
13385 {
13388 }
13390 /* If redeclaring a builtin function, and not a definition,
13391 it stays built in.
13392 Also preserve various other info from the definition. */
13394 {
13396 {
13399 }
13405 }
13407 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13408 But preserve olddecl's DECL_UID. */
13409 {
13416 }
13419 }
13421 /* Finish processing of a declaration;
13422 install its initial value.
13423 If the length of an array type is not known before,
13424 it must be determined now, from the initial value, or it is an error. */
13426 static void
13428 {
13434 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13435 level anyway. */
13440 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13441 overlaps DECL_ARG_TYPE. */
13444 else
13448 {
13451 else
13452 {
13453 /* typedef foo = bar; store the type of bar as the type of foo. */
13456 }
13457 }
13459 /* Deduce size of array from initialization, if not already known */
13464 {
13469 }
13472 {
13479 ?
13480 /* A static variable with an incomplete type is an error if it is
13481 initialized. Also if it is not file scope. Otherwise, let it
13482 through, but if it is not `extern' then it may cause an error
13483 message later. */
13485 :
13486 /* An automatic variable with an incomplete type is an error. */
13488 {
13491 }
13496 {
13499 }
13500 }
13502 /* Output the assembler code and/or RTL code for variables and functions,
13503 unless the type is an undefined structure or union. If not, it will get
13504 done when the type is completed. */
13507 {
13513 {
13514 /* Recompute the RTL of a local array now if it used to be an
13515 incomplete type. */
13518 {
13519 /* If we used it already as memory, it must stay in memory. */
13521 /* If it's still incomplete now, no init will save it. */
13525 }
13526 /* Compute and store the initial value. */
13529 }
13530 }
13532 {
13536 }
13538 /* At the end of a declaration, throw away any variable type sizes of types
13539 defined inside that declaration. There is no use computing them in the
13540 following function definition. */
13543 }
13545 /* Finish up a function declaration and compile that function
13546 all the way to assembler language output. The free the storage
13547 for the function definition.
13549 This is called after parsing the body of the function definition.
13551 NESTED is nonzero if the function being finished is nested in another. */
13553 static void
13555 {
13560 {
13563 else
13565 }
13567 /* TREE_READONLY (fndecl) = 1;
13568 This caused &foo to be of type ptr-to-const-function
13569 which then got a warning when stored in a ptr-to-function variable. */
13574 {
13577 /* Must mark the RESULT_DECL as being in this function. */
13581 /* Obey `register' declarations if `setjmp' is called in this fn. */
13582 /* Generate rtl for function exit. */
13585 /* If this is a nested function, protect the local variables in the stack
13586 above us from being collected while we're compiling this function. */
13590 /* Run the optimizers and output the assembler code for this function. */
13593 /* Undo the GC context switch. */
13596 }
13599 && !nested
13601 {
13602 /* Stop pointing to the local nodes about to be freed. */
13603 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13604 function definition. */
13605 /* For a nested function, this is done in pop_f_function_context. */
13606 /* If rest_of_compilation set this to 0, leave it 0. */
13610 }
13613 {
13614 /* Let the error reporting routines know that we're outside a function.
13615 For a nested function, this value is used in pop_c_function_context
13616 and then reset via pop_function_context. */
13618 }
13619 }
13621 /* Plug-in replacement for identifying the name of a decl and, for a
13622 function, what we call it in diagnostics. For now, "program unit"
13623 should suffice, since it's a bit of a hassle to figure out which
13624 of several kinds of things it is. Note that it could conceivably
13625 be a statement function, which probably isn't really a program unit
13626 per se, but if that comes up, it should be easy to check (being a
13627 nested function and all). */
13631 {
13632 /* Just to keep GCC quiet about the unused variable.
13633 In theory, differing values of V should produce different
13634 output. */
13636 {
13641 }
13642 }
13644 /* g77's function to print out name of current function that caused
13645 an error. */
13647 static void
13650 {
13653 ffeglobal g;
13654 ffesymbol s;
13659 {
13663 }
13664 else
13665 {
13668 {
13671 }
13672 else
13673 {
13676 }
13677 }
13680 {
13686 else
13687 {
13691 }
13695 }
13696 }
13698 /* Similar to `lookup_name' but look only at current binding level. */
13700 static tree
13702 {
13716 }
13718 /* Create a new `struct f_binding_level'. */
13722 {
13723 /* NOSTRICT */
13725 }
13727 /* Save and restore the variables in this file and elsewhere
13728 that keep track of the progress of compilation of the current function.
13729 Used for nested functions. */
13731 struct f_function
13732 {
13734 tree named_labels;
13735 tree shadowed_labels;
13737 };
13741 /* Restore the variables used during compilation of a C function. */
13743 static void
13745 {
13747 tree link;
13749 /* Bring back all the labels that were shadowed. */
13757 {
13758 /* Stop pointing to the local nodes about to be freed. */
13759 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13760 function definition. */
13763 }
13774 }
13776 /* Save and reinitialize the variables
13777 used during compilation of a C function. */
13779 static void
13781 {
13792 }
13794 static void
13796 {
13799 /* Don't try computing parm sizes now -- wait till fn is called. */
13803 /* Fill in arg stuff. */
13814 }
13816 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
13818 static tree
13820 {
13831 }
13833 /* Store the list of declarations of the current level.
13834 This is done for the parameter declarations of a function being defined,
13835 after they are modified in the light of any missing parameters. */
13837 static tree
13839 {
13841 }
13843 /* Store the parameter declarations into the current function declaration.
13844 This is called after parsing the parameter declarations, before
13845 digesting the body of the function.
13847 For an old-style definition, modify the function's type
13848 to specify at least the number of arguments. */
13850 static void
13852 {
13858 /* This is a chain of PARM_DECLs from old-style parm declarations. */
13861 /* Initialize the RTL code for the function. */
13864 /* Set up parameters and prepare for return, for the function. */
13866 }
13868 static tree
13870 {
13875 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13876 level anyway. */
13880 {
13883 }
13887 /* For Fortran, we by default put things in .common when possible. */
13890 /* Add this decl to the current binding level. TEM may equal DECL or it may
13891 be a previous decl of the same name. */
13894 else
13897 /* For a local variable, define the RTL now. */
13899 /* But not if this is a duplicate decl and we preserved the rtl from the
13900 previous one (which may or may not happen). */
13902 {
13908 }
13911 }
13913 /* Create the FUNCTION_DECL for a function definition.
13914 DECLSPECS and DECLARATOR are the parts of the declaration;
13915 they describe the function's name and the type it returns,
13916 but twisted together in a fashion that parallels the syntax of C.
13918 This function creates a binding context for the function body
13919 as well as setting up the FUNCTION_DECL in current_function_decl.
13921 Returns 1 on success. If the DECLARATOR is not suitable for a function
13922 (it defines a datum instead), we return 0, which tells
13923 ffe_parse_file to report a parse error.
13925 NESTED is nonzero for a function nested within another function. */
13927 static void
13929 {
13930 tree decl1;
13931 tree restype;
13937 /* Don't expand any sizes in the return type of the function. */
13941 {
13945 }
13946 else
13947 {
13949 }
13953 else
13954 {
13956 name,
13957 type);
13966 /* Make the init_value nonzero so pushdecl knows this is not tentative.
13967 error_mark_node is replaced below (in poplevel) with the BLOCK. */
13970 /* Record the decl so that the function name is defined. If we already have
13971 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
13974 }
13983 {
13989 }
13995 }
13996 \f
13997 /* Here are the public functions the GNU back end needs. */
13999 tree
14001 {
14014 {
14017 }
14023 e);
14037 }
14039 /* Return the list of declarations of the current level.
14040 Note that this list is in reverse order unless/until
14041 you nreverse it; and when you do nreverse it, you must
14042 store the result back using `storedecls' or you will lose. */
14044 tree
14046 {
14048 }
14050 /* Nonzero if we are currently in the global binding level. */
14052 int
14054 {
14056 }
14058 static void
14060 {
14064 }
14066 /* Delete the node BLOCK from the current binding level.
14067 This is used for the block inside a stmt expr ({...})
14068 so that the block can be reinserted where appropriate. */
14070 static void
14072 {
14073 tree t;
14077 {
14080 else
14082 }
14084 /* Clear TREE_USED which is always set by poplevel.
14085 The flag is set again if insert_block is called. */
14087 }
14089 void
14091 {
14093 current_binding_level->blocks
14095 }
14097 /* Each front end provides its own. */
14104 {
14106 };
14108 #undef LANG_HOOKS_NAME
14110 #undef LANG_HOOKS_INIT
14111 #define LANG_HOOKS_INIT ffe_init
14112 #undef LANG_HOOKS_FINISH
14113 #define LANG_HOOKS_FINISH ffe_finish
14114 #undef LANG_HOOKS_INIT_OPTIONS
14115 #define LANG_HOOKS_INIT_OPTIONS ffe_init_options
14116 #undef LANG_HOOKS_HANDLE_OPTION
14117 #define LANG_HOOKS_HANDLE_OPTION ffe_handle_option
14118 #undef LANG_HOOKS_POST_OPTIONS
14119 #define LANG_HOOKS_POST_OPTIONS ffe_post_options
14120 #undef LANG_HOOKS_PARSE_FILE
14121 #define LANG_HOOKS_PARSE_FILE ffe_parse_file
14122 #undef LANG_HOOKS_MARK_ADDRESSABLE
14123 #define LANG_HOOKS_MARK_ADDRESSABLE ffe_mark_addressable
14124 #undef LANG_HOOKS_PRINT_IDENTIFIER
14125 #define LANG_HOOKS_PRINT_IDENTIFIER ffe_print_identifier
14126 #undef LANG_HOOKS_DECL_PRINTABLE_NAME
14127 #define LANG_HOOKS_DECL_PRINTABLE_NAME ffe_printable_name
14128 #undef LANG_HOOKS_PRINT_ERROR_FUNCTION
14129 #define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function
14130 #undef LANG_HOOKS_TRUTHVALUE_CONVERSION
14131 #define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion
14133 #undef LANG_HOOKS_TYPE_FOR_MODE
14134 #define LANG_HOOKS_TYPE_FOR_MODE ffe_type_for_mode
14135 #undef LANG_HOOKS_TYPE_FOR_SIZE
14136 #define LANG_HOOKS_TYPE_FOR_SIZE ffe_type_for_size
14137 #undef LANG_HOOKS_SIGNED_TYPE
14138 #define LANG_HOOKS_SIGNED_TYPE ffe_signed_type
14139 #undef LANG_HOOKS_UNSIGNED_TYPE
14140 #define LANG_HOOKS_UNSIGNED_TYPE ffe_unsigned_type
14141 #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
14142 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type
14144 /* We do not wish to use alias-set based aliasing at all. Used in the
14145 extreme (every object with its own set, with equivalences recorded) it
14146 might be helpful, but there are problems when it comes to inlining. We
14147 get on ok with flag_argument_noalias, and alias-set aliasing does
14148 currently limit how stack slots can be reused, which is a lose. */
14149 #undef LANG_HOOKS_GET_ALIAS_SET
14150 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14154 /* Table indexed by tree code giving a string containing a character
14155 classifying the tree code. Possibilities are
14156 t, d, s, c, r, <, 1, 2 and e. See tree.def for details. */
14158 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14162 };
14163 #undef DEFTREECODE
14165 /* Table indexed by tree code giving number of expression
14166 operands beyond the fixed part of the node structure.
14167 Not used for types or decls. */
14169 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14173 };
14174 #undef DEFTREECODE
14176 /* Names of tree components.
14177 Used for printing out the tree and error messages. */
14178 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14182 };
14183 #undef DEFTREECODE
14185 static bool
14187 {
14190 /* Open input file. */
14192 {
14195 }
14196 else
14203 }
14206 static bool
14208 {
14209 #ifdef IO_BUFFER_SIZE
14211 #endif
14215 /* If the file is output from cpp, it should contain a first line
14216 `# 1 "real-filename"', and the current design of gcc (toplev.c
14217 in particular and the way it sets up information relied on by
14218 INCLUDE) requires that we read this now, and store the
14219 "real-filename" info in master_input_filename. Ask the lexer
14220 to try doing this. */
14225 /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14226 set the new file name. Maybe in ffe_post_options. */
14228 }
14230 static void
14232 {
14239 }
14241 static bool
14243 {
14247 {
14264 {
14266 {
14269 }
14271 }
14273 {
14275 {
14278 }
14280 }
14283 /* drops in */
14289 #endif
14293 }
14294 }
14296 /* Exit a binding level.
14297 Pop the level off, and restore the state of the identifier-decl mappings
14298 that were in effect when this level was entered.
14300 If KEEP is nonzero, this level had explicit declarations, so
14301 and create a "block" (a BLOCK node) for the level
14302 to record its declarations and subblocks for symbol table output.
14304 If FUNCTIONBODY is nonzero, this level is the body of a function,
14305 so create a block as if KEEP were set and also clear out all
14306 label names.
14308 If REVERSE is nonzero, reverse the order of decls before putting
14309 them into the BLOCK. */
14311 tree
14313 {
14315 /* The chain of decls was accumulated in reverse order.
14316 Put it into forward order, just for cleanliness. */
14317 tree decls;
14320 tree decl;
14323 /* Get the decls in the order they were written.
14324 Usually current_binding_level->names is in reverse order.
14325 But parameter decls were previously put in forward order. */
14328 current_binding_level->names
14330 else
14333 /* Output any nested inline functions within this block
14334 if they weren't already output. */
14341 {
14342 /* If this decl was copied from a file-scope decl
14343 on account of a block-scope extern decl,
14344 propagate TREE_ADDRESSABLE to the file-scope decl.
14346 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14347 true, since then the decl goes through save_for_inline_copying. */
14352 {
14356 }
14357 }
14359 /* If there were any declarations or structure tags in that level,
14360 or if this level is a function body,
14361 create a BLOCK to record them for the life of this function. */
14370 {
14373 }
14375 /* In each subblock, record that this is its superior. */
14380 /* Clear out the meanings of the local variables of this level. */
14383 {
14385 {
14386 /* If the ident. was used or addressed via a local extern decl,
14387 don't forget that fact. */
14389 {
14394 }
14396 }
14397 }
14399 /* If the level being exited is the top level of a function,
14400 check over all the labels, and clear out the current
14401 (function local) meanings of their names. */
14404 {
14405 /* If this is the top level block of a function,
14406 the vars are the function's parameters.
14407 Don't leave them in the BLOCK because they are
14408 found in the FUNCTION_DECL instead. */
14411 }
14413 /* Pop the current level, and free the structure for reuse. */
14415 {
14421 }
14423 /* Dispose of the block that we just made inside some higher level. */
14428 {
14430 current_binding_level->blocks
14432 }
14433 /* If we did not make a block for the level just exited,
14434 any blocks made for inner levels
14435 (since they cannot be recorded as subblocks in that level)
14436 must be carried forward so they will later become subblocks
14437 of something else. */
14439 current_binding_level->blocks
14445 }
14447 static void
14449 {
14452 }
14454 /* Record a decl-node X as belonging to the current lexical scope.
14455 Check for errors (such as an incompatible declaration for the same
14456 name already seen in the same scope).
14458 Returns either X or an old decl for the same name.
14459 If an old decl is returned, it may have been smashed
14460 to agree with what X says. */
14462 tree
14464 {
14473 else
14477 {
14479 {
14482 }
14488 /* Don't push non-parms onto list for parms until we understand
14489 why we're doing this and whether it works. */
14492 || !ffecom_transform_only_dummies_
14498 /* If we are processing a typedef statement, generate a whole new
14499 ..._TYPE node (which will be just an variant of the existing
14500 ..._TYPE node with identical properties) and then install the
14501 TYPE_DECL node generated to represent the typedef name as the
14502 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14504 The whole point here is to end up with a situation where each and every
14505 ..._TYPE node the compiler creates will be uniquely associated with
14506 AT MOST one node representing a typedef name. This way, even though
14507 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14508 (i.e. "typedef name") nodes very early on, later parts of the
14509 compiler can always do the reverse translation and get back the
14510 corresponding typedef name. For example, given:
14512 typedef struct S MY_TYPE; MY_TYPE object;
14514 Later parts of the compiler might only know that `object' was of type
14515 `struct S' if it were not for code just below. With this code
14516 however, later parts of the compiler see something like:
14518 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14520 And they can then deduce (from the node for type struct S') that the
14521 original object declaration was:
14523 MY_TYPE object;
14525 Being able to do this is important for proper support of protoize, and
14526 also for generating precise symbolic debugging information which
14527 takes full account of the programmer's (typedef) vocabulary.
14529 Obviously, we don't want to generate a duplicate ..._TYPE node if the
14530 TYPE_DECL node that we are now processing really represents a
14531 standard built-in type.
14533 Since all standard types are effectively declared at line zero in the
14534 source file, we can easily check to see if we are working on a
14535 standard type by checking the current value of lineno. */
14538 {
14540 {
14543 }
14545 {
14551 }
14552 }
14554 /* This name is new in its binding level. Install the new declaration
14555 and return it. */
14558 else
14560 }
14562 /* Put decls on list in reverse order. We will reverse them later if
14563 necessary. */
14568 }
14570 /* Nonzero if the current level needs to have a BLOCK made. */
14572 static int
14574 {
14575 tree decl;
14578 decl;
14580 {
14583 /* Currently, there aren't supposed to be non-artificial names
14584 at other than the top block for a function -- they're
14585 believed to always be temps. But it's wise to check anyway. */
14587 }
14589 }
14591 /* Enter a new binding level.
14592 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14593 not for that of tags. */
14595 void
14597 {
14603 {
14605 }
14607 /* Reuse or create a struct for this binding level. */
14610 {
14613 }
14614 else
14615 {
14617 }
14619 /* Add this level to the front of the chain (stack) of levels that
14620 are active. */
14625 }
14627 /* Set the BLOCK node for the innermost scope
14628 (the one we are currently in). */
14630 void
14632 {
14638 }
14640 static tree
14642 {
14643 tree type2;
14664 }
14666 static tree
14668 {
14670 ffeinfoKindtype kt;
14671 tree type2;
14692 #endif
14699 {
14704 }
14707 }
14709 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14710 or validate its data type for an `if' or `while' statement or ?..: exp.
14712 This preparation consists of taking the ordinary
14713 representation of an expression expr and producing a valid tree
14714 boolean expression describing whether expr is nonzero. We could
14715 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14716 but we optimize comparisons, &&, ||, and !.
14718 The resulting type should always be `integer_type_node'. */
14720 static tree
14722 {
14727 /* These really should return error_mark_node after 2.4 is stable.
14728 But not all callers handle ERROR_MARK properly. */
14730 {
14745 }
14749 {
14750 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14751 or comparison expressions as truth values at this level. */
14752 #if 0
14754 /* A one-bit unsigned bit-field is already acceptable. */
14759 #endif
14762 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14763 or comparison expressions as truth values at this level. */
14764 #if 0
14767 #endif
14790 else
14796 integer_type_node,
14803 /* These don't change whether an object is nonzero or zero. */
14808 /* These don't change whether an object is zero or nonzero, but
14809 we can't ignore them if their second arg has side-effects. */
14813 else
14817 {
14818 /* Distribute the conversion into the arms of a COND_EXPR. */
14827 }
14830 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14831 since that affects how `default_conversion' will behave. */
14835 /* fall through... */
14837 /* If this is widening the argument, we can ignore it. */
14844 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14845 this case. */
14849 /* fall through... */
14851 /* This and MINUS_EXPR can be changed into a comparison of the
14852 two objects. */
14873 #endif
14878 }
14884 integer_type_node,
14887 expr)),
14890 expr))));
14893 expr,
14895 }
14897 static tree
14899 {
14902 tree t;
14919 #if HOST_BITS_PER_WIDE_INT >= 64
14922 #endif
14941 {
14944 {
14947 else
14949 }
14950 }
14953 }
14955 static tree
14957 {
14958 ffeinfoKindtype kt;
14959 tree type_node;
14978 {
14984 }
14987 }
14989 static tree
14991 {
14993 ffeinfoKindtype kt;
14994 tree type2;
15015 #endif
15022 {
15027 }
15030 }
15031 \f
15032 /* From gcc/cccp.c, the code to handle -I. */
15034 /* Skip leading "./" from a directory name.
15035 This may yield the empty string, which represents the current directory. */
15039 {
15044 dir++;
15046 }
15048 /* The file_name_map structure holds a mapping of file names for a
15049 particular directory. This mapping is read from the file named
15050 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15051 map filenames on a file system with severe filename restrictions,
15052 such as DOS. The format of the file name map file is just a series
15053 of lines with two tokens on each line. The first token is the name
15054 to map, and the second token is the actual name to use. */
15056 struct file_name_map
15057 {
15061 };
15065 /* Current maximum length of directory names in the search path
15066 for include files. (Altered as we get more of them.) */
15070 struct file_name_list
15071 {
15074 /* Mapping of file names for this directory. */
15076 /* Nonzero if name_map is valid. */
15078 };
15083 /* I/O buffer structure.
15084 The `fname' field is nonzero for source files and #include files
15085 and for the dummy text used for -D and -U.
15086 It is zero for rescanning results of macro expansion
15087 and for expanding macro arguments. */
15088 #define INPUT_STACK_MAX 400
15091 /* Filename specified with #line command. */
15093 /* Record where in the search path this file was found.
15094 For #include_next. */
15096 ffewhereLine line;
15097 ffewhereColumn column;
15102 /* Current nesting level of input sources.
15103 `instack[indepth]' is the level currently being read. */
15108 /* Nonzero means -I- has been seen,
15109 so don't look for #include "foo" the source-file directory. */
15112 #ifndef INCLUDE_LEN_FUDGE
15113 #define INCLUDE_LEN_FUDGE 0
15114 #endif
15124 /* Append a chain of `struct file_name_list's
15125 to the end of the main include chain.
15126 FIRST is the beginning of the chain to append, and LAST is the end. */
15128 static void
15131 {
15139 else
15148 }
15152 }
15154 /* Try to open include file FILENAME. SEARCHPTR is the directory
15155 being tried from the include file search path. This function maps
15156 filenames on file systems based on information read by
15157 read_name_map. */
15161 {
15167 {
15171 }
15173 /* First check the mapping for the directory we are using. */
15175 {
15180 {
15182 {
15183 /* Found a match. */
15185 }
15186 }
15187 }
15189 /* Try to find a mapping file for the particular directory we are
15190 looking in. Thus #include <sys/types.h> will look up sys/types.h
15191 in /usr/include/header.gcc and look up types.h in
15192 /usr/include/sys/header.gcc. */
15194 #ifdef DIR_SEPARATOR
15199 }
15200 #endif
15207 {
15208 /* FILENAME is in SEARCHPTR, which we've already checked. */
15210 }
15213 {
15216 }
15217 else
15218 {
15225 }
15231 }
15233 /* Print the file names and line numbers of the #include
15234 commands which led to the current file. */
15236 static void
15238 {
15245 /* If stack of files hasn't changed since we last printed
15246 this info, don't repeat it. */
15254 }
15256 /* Give up if we don't find a source file. */
15260 /* Find the other, outer source files. */
15263 {
15266 {
15269 }
15270 else
15271 {
15273 }
15277 else
15280 /* xgettext:no-c-format */
15287 }
15289 /* Record we have printed the status as of this time. */
15291 }
15293 /* Read a space delimited string of unlimited length from a stdio
15294 file. */
15298 {
15305 {
15308 {
15310 {
15314 }
15316 }
15317 }
15321 }
15323 /* Read the file name map file for DIRNAME. */
15327 {
15328 /* This structure holds a linked list of file name maps, one per
15329 directory. */
15330 struct file_name_map_list
15331 {
15335 };
15358 else
15364 else
15365 {
15369 {
15377 ;
15383 /* Make the real filename absolute. */
15386 else
15387 {
15390 else
15393 }
15401 }
15403 }
15409 }
15411 static void
15413 {
15416 /* Do partial setup of input buffer for the sake of generating
15417 early #line directives (when -g is in effect). */
15424 }
15426 static void
15428 {
15431 indepth--;
15432 input_file_stack_tick++;
15436 }
15438 void
15440 {
15443 else
15444 {
15451 }
15452 }
15454 /* Open INCLUDEd file. */
15458 {
15473 /* If -I- was specified, don't search current dir, only spec'd ones. */
15475 {
15477 {
15483 {
15484 /* Found a named file. Figure out dir of the file,
15485 and put it in front of the search list. */
15488 #ifndef VMS
15490 #ifdef DIR_SEPARATOR
15495 }
15496 #endif
15504 {
15512 }
15513 else
15517 }
15518 }
15519 }
15521 /* Allocate this permanently, because it gets stored in the definitions
15522 of macros. */
15524 /* + 2 above for slash and terminating null. */
15525 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15526 for g77 yet). */
15528 /* If specified file name is absolute, just open it. */
15531 #ifdef DIR_SEPARATOR
15533 #endif
15534 )
15535 {
15539 }
15540 else
15541 {
15544 /* Search directory path, trying to open the file.
15545 Copy each filename tried into FNAME. */
15548 {
15550 {
15551 /* The empty string in a search path is ignored.
15552 This makes it possible to turn off entirely
15553 a standard piece of the list. */
15560 }
15561 else
15565 #ifdef VMS
15566 /* Change this 1/2 Unix 1/2 VMS file specification into a
15567 full VMS file specification */
15569 {
15570 /* Fix up the filename */
15572 }
15573 else
15574 {
15575 /* This is a normal VMS filespec, so use it unchanged. */
15579 /* if it's '#include filename', add the missing .h */
15582 #endif
15583 }
15586 #ifdef EACCES
15588 {
15590 /* xgettext:no-c-format */
15592 FFEBAD_severityWARNING);
15596 }
15597 #endif
15600 }
15601 }
15604 {
15605 /* A file that was not found. */
15614 }
15623 {
15625 /* xgettext:no-c-format */
15627 FFEBAD_severityFATAL);
15632 }
15642 indepth++;
15643 input_file_stack_tick++;
15646 }
15648 /**INDENT* (Do not reformat this comment even with -fca option.)
15649 Data-gathering files: Given the source file listed below, compiled with
15650 f2c I obtained the output file listed after that, and from the output
15651 file I derived the above code.
15653 -------- (begin input file to f2c)
15654 implicit none
15655 character*10 A1,A2
15656 complex C1,C2
15657 integer I1,I2
15658 real R1,R2
15659 double precision D1,D2
15660 C
15661 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15662 c /
15663 call fooI(I1/I2)
15664 call fooR(R1/I1)
15665 call fooD(D1/I1)
15666 call fooC(C1/I1)
15667 call fooR(R1/R2)
15668 call fooD(R1/D1)
15669 call fooD(D1/D2)
15670 call fooD(D1/R1)
15671 call fooC(C1/C2)
15672 call fooC(C1/R1)
15673 call fooZ(C1/D1)
15674 c **
15675 call fooI(I1**I2)
15676 call fooR(R1**I1)
15677 call fooD(D1**I1)
15678 call fooC(C1**I1)
15679 call fooR(R1**R2)
15680 call fooD(R1**D1)
15681 call fooD(D1**D2)
15682 call fooD(D1**R1)
15683 call fooC(C1**C2)
15684 call fooC(C1**R1)
15685 call fooZ(C1**D1)
15686 c FFEINTRIN_impABS
15687 call fooR(ABS(R1))
15688 c FFEINTRIN_impACOS
15689 call fooR(ACOS(R1))
15690 c FFEINTRIN_impAIMAG
15691 call fooR(AIMAG(C1))
15692 c FFEINTRIN_impAINT
15693 call fooR(AINT(R1))
15694 c FFEINTRIN_impALOG
15695 call fooR(ALOG(R1))
15696 c FFEINTRIN_impALOG10
15697 call fooR(ALOG10(R1))
15698 c FFEINTRIN_impAMAX0
15699 call fooR(AMAX0(I1,I2))
15700 c FFEINTRIN_impAMAX1
15701 call fooR(AMAX1(R1,R2))
15702 c FFEINTRIN_impAMIN0
15703 call fooR(AMIN0(I1,I2))
15704 c FFEINTRIN_impAMIN1
15705 call fooR(AMIN1(R1,R2))
15706 c FFEINTRIN_impAMOD
15707 call fooR(AMOD(R1,R2))
15708 c FFEINTRIN_impANINT
15709 call fooR(ANINT(R1))
15710 c FFEINTRIN_impASIN
15711 call fooR(ASIN(R1))
15712 c FFEINTRIN_impATAN
15713 call fooR(ATAN(R1))
15714 c FFEINTRIN_impATAN2
15715 call fooR(ATAN2(R1,R2))
15716 c FFEINTRIN_impCABS
15717 call fooR(CABS(C1))
15718 c FFEINTRIN_impCCOS
15719 call fooC(CCOS(C1))
15720 c FFEINTRIN_impCEXP
15721 call fooC(CEXP(C1))
15722 c FFEINTRIN_impCHAR
15723 call fooA(CHAR(I1))
15724 c FFEINTRIN_impCLOG
15725 call fooC(CLOG(C1))
15726 c FFEINTRIN_impCONJG
15727 call fooC(CONJG(C1))
15728 c FFEINTRIN_impCOS
15729 call fooR(COS(R1))
15730 c FFEINTRIN_impCOSH
15731 call fooR(COSH(R1))
15732 c FFEINTRIN_impCSIN
15733 call fooC(CSIN(C1))
15734 c FFEINTRIN_impCSQRT
15735 call fooC(CSQRT(C1))
15736 c FFEINTRIN_impDABS
15737 call fooD(DABS(D1))
15738 c FFEINTRIN_impDACOS
15739 call fooD(DACOS(D1))
15740 c FFEINTRIN_impDASIN
15741 call fooD(DASIN(D1))
15742 c FFEINTRIN_impDATAN
15743 call fooD(DATAN(D1))
15744 c FFEINTRIN_impDATAN2
15745 call fooD(DATAN2(D1,D2))
15746 c FFEINTRIN_impDCOS
15747 call fooD(DCOS(D1))
15748 c FFEINTRIN_impDCOSH
15749 call fooD(DCOSH(D1))
15750 c FFEINTRIN_impDDIM
15751 call fooD(DDIM(D1,D2))
15752 c FFEINTRIN_impDEXP
15753 call fooD(DEXP(D1))
15754 c FFEINTRIN_impDIM
15755 call fooR(DIM(R1,R2))
15756 c FFEINTRIN_impDINT
15757 call fooD(DINT(D1))
15758 c FFEINTRIN_impDLOG
15759 call fooD(DLOG(D1))
15760 c FFEINTRIN_impDLOG10
15761 call fooD(DLOG10(D1))
15762 c FFEINTRIN_impDMAX1
15763 call fooD(DMAX1(D1,D2))
15764 c FFEINTRIN_impDMIN1
15765 call fooD(DMIN1(D1,D2))
15766 c FFEINTRIN_impDMOD
15767 call fooD(DMOD(D1,D2))
15768 c FFEINTRIN_impDNINT
15769 call fooD(DNINT(D1))
15770 c FFEINTRIN_impDPROD
15771 call fooD(DPROD(R1,R2))
15772 c FFEINTRIN_impDSIGN
15773 call fooD(DSIGN(D1,D2))
15774 c FFEINTRIN_impDSIN
15775 call fooD(DSIN(D1))
15776 c FFEINTRIN_impDSINH
15777 call fooD(DSINH(D1))
15778 c FFEINTRIN_impDSQRT
15779 call fooD(DSQRT(D1))
15780 c FFEINTRIN_impDTAN
15781 call fooD(DTAN(D1))
15782 c FFEINTRIN_impDTANH
15783 call fooD(DTANH(D1))
15784 c FFEINTRIN_impEXP
15785 call fooR(EXP(R1))
15786 c FFEINTRIN_impIABS
15787 call fooI(IABS(I1))
15788 c FFEINTRIN_impICHAR
15789 call fooI(ICHAR(A1))
15790 c FFEINTRIN_impIDIM
15791 call fooI(IDIM(I1,I2))
15792 c FFEINTRIN_impIDNINT
15793 call fooI(IDNINT(D1))
15794 c FFEINTRIN_impINDEX
15795 call fooI(INDEX(A1,A2))
15796 c FFEINTRIN_impISIGN
15797 call fooI(ISIGN(I1,I2))
15798 c FFEINTRIN_impLEN
15799 call fooI(LEN(A1))
15800 c FFEINTRIN_impLGE
15801 call fooL(LGE(A1,A2))
15802 c FFEINTRIN_impLGT
15803 call fooL(LGT(A1,A2))
15804 c FFEINTRIN_impLLE
15805 call fooL(LLE(A1,A2))
15806 c FFEINTRIN_impLLT
15807 call fooL(LLT(A1,A2))
15808 c FFEINTRIN_impMAX0
15809 call fooI(MAX0(I1,I2))
15810 c FFEINTRIN_impMAX1
15811 call fooI(MAX1(R1,R2))
15812 c FFEINTRIN_impMIN0
15813 call fooI(MIN0(I1,I2))
15814 c FFEINTRIN_impMIN1
15815 call fooI(MIN1(R1,R2))
15816 c FFEINTRIN_impMOD
15817 call fooI(MOD(I1,I2))
15818 c FFEINTRIN_impNINT
15819 call fooI(NINT(R1))
15820 c FFEINTRIN_impSIGN
15821 call fooR(SIGN(R1,R2))
15822 c FFEINTRIN_impSIN
15823 call fooR(SIN(R1))
15824 c FFEINTRIN_impSINH
15825 call fooR(SINH(R1))
15826 c FFEINTRIN_impSQRT
15827 call fooR(SQRT(R1))
15828 c FFEINTRIN_impTAN
15829 call fooR(TAN(R1))
15830 c FFEINTRIN_impTANH
15831 call fooR(TANH(R1))
15832 c FFEINTRIN_imp_CMPLX_C
15833 call fooC(cmplx(C1,C2))
15834 c FFEINTRIN_imp_CMPLX_D
15835 call fooZ(cmplx(D1,D2))
15836 c FFEINTRIN_imp_CMPLX_I
15837 call fooC(cmplx(I1,I2))
15838 c FFEINTRIN_imp_CMPLX_R
15839 call fooC(cmplx(R1,R2))
15840 c FFEINTRIN_imp_DBLE_C
15841 call fooD(dble(C1))
15842 c FFEINTRIN_imp_DBLE_D
15843 call fooD(dble(D1))
15844 c FFEINTRIN_imp_DBLE_I
15845 call fooD(dble(I1))
15846 c FFEINTRIN_imp_DBLE_R
15847 call fooD(dble(R1))
15848 c FFEINTRIN_imp_INT_C
15849 call fooI(int(C1))
15850 c FFEINTRIN_imp_INT_D
15851 call fooI(int(D1))
15852 c FFEINTRIN_imp_INT_I
15853 call fooI(int(I1))
15854 c FFEINTRIN_imp_INT_R
15855 call fooI(int(R1))
15856 c FFEINTRIN_imp_REAL_C
15857 call fooR(real(C1))
15858 c FFEINTRIN_imp_REAL_D
15859 call fooR(real(D1))
15860 c FFEINTRIN_imp_REAL_I
15861 call fooR(real(I1))
15862 c FFEINTRIN_imp_REAL_R
15863 call fooR(real(R1))
15864 c
15865 c FFEINTRIN_imp_INT_D:
15866 c
15867 c FFEINTRIN_specIDINT
15868 call fooI(IDINT(D1))
15869 c
15870 c FFEINTRIN_imp_INT_R:
15871 c
15872 c FFEINTRIN_specIFIX
15873 call fooI(IFIX(R1))
15874 c FFEINTRIN_specINT
15875 call fooI(INT(R1))
15876 c
15877 c FFEINTRIN_imp_REAL_D:
15878 c
15879 c FFEINTRIN_specSNGL
15880 call fooR(SNGL(D1))
15881 c
15882 c FFEINTRIN_imp_REAL_I:
15883 c
15884 c FFEINTRIN_specFLOAT
15885 call fooR(FLOAT(I1))
15886 c FFEINTRIN_specREAL
15887 call fooR(REAL(I1))
15888 c
15889 end
15890 -------- (end input file to f2c)
15892 -------- (begin output from providing above input file as input to:
15893 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
15894 -------- -e "s:^#.*$::g"')
15896 // -- translated by f2c (version 19950223).
15897 You must link the resulting object file with the libraries:
15898 -lf2c -lm (in that order)
15899 //
15902 // f2c.h -- Standard Fortran to C header file //
15904 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
15906 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
15911 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
15912 // we assume short, float are OK //
15913 typedef long int // long int // integer;
15914 typedef char *address;
15915 typedef short int shortint;
15916 typedef float real;
15917 typedef double doublereal;
15918 typedef struct { real r, i; } complex;
15919 typedef struct { doublereal r, i; } doublecomplex;
15920 typedef long int // long int // logical;
15921 typedef short int shortlogical;
15922 typedef char logical1;
15923 typedef char integer1;
15924 // typedef long long longint; // // system-dependent //
15929 // Extern is for use with -E //
15934 // I/O stuff //
15943 typedef long int // int or long int // flag;
15944 typedef long int // int or long int // ftnlen;
15945 typedef long int // int or long int // ftnint;
15948 //external read, write//
15949 typedef struct
15950 { flag cierr;
15951 ftnint ciunit;
15952 flag ciend;
15953 char *cifmt;
15954 ftnint cirec;
15955 } cilist;
15957 //internal read, write//
15958 typedef struct
15959 { flag icierr;
15960 char *iciunit;
15961 flag iciend;
15962 char *icifmt;
15963 ftnint icirlen;
15964 ftnint icirnum;
15965 } icilist;
15967 //open//
15968 typedef struct
15969 { flag oerr;
15970 ftnint ounit;
15971 char *ofnm;
15972 ftnlen ofnmlen;
15973 char *osta;
15974 char *oacc;
15975 char *ofm;
15976 ftnint orl;
15977 char *oblnk;
15978 } olist;
15980 //close//
15981 typedef struct
15982 { flag cerr;
15983 ftnint cunit;
15984 char *csta;
15985 } cllist;
15987 //rewind, backspace, endfile//
15988 typedef struct
15989 { flag aerr;
15990 ftnint aunit;
15991 } alist;
15993 // inquire //
15994 typedef struct
15995 { flag inerr;
15996 ftnint inunit;
15997 char *infile;
15998 ftnlen infilen;
15999 ftnint *inex; //parameters in standard's order//
16000 ftnint *inopen;
16001 ftnint *innum;
16002 ftnint *innamed;
16003 char *inname;
16004 ftnlen innamlen;
16005 char *inacc;
16006 ftnlen inacclen;
16007 char *inseq;
16008 ftnlen inseqlen;
16009 char *indir;
16010 ftnlen indirlen;
16011 char *infmt;
16012 ftnlen infmtlen;
16013 char *inform;
16014 ftnint informlen;
16015 char *inunf;
16016 ftnlen inunflen;
16017 ftnint *inrecl;
16018 ftnint *innrec;
16019 char *inblank;
16020 ftnlen inblanklen;
16021 } inlist;
16025 union Multitype { // for multiple entry points //
16026 integer1 g;
16027 shortint h;
16028 integer i;
16029 // longint j; //
16030 real r;
16031 doublereal d;
16032 complex c;
16033 doublecomplex z;
16034 };
16036 typedef union Multitype Multitype;
16038 typedef long Long; // No longer used; formerly in Namelist //
16040 struct Vardesc { // for Namelist //
16041 char *name;
16042 char *addr;
16043 ftnlen *dims;
16044 int type;
16045 };
16046 typedef struct Vardesc Vardesc;
16048 struct Namelist {
16049 char *name;
16050 Vardesc **vars;
16051 int nvars;
16052 };
16053 typedef struct Namelist Namelist;
16062 // procedure parameter types for -A and -C++ //
16067 typedef int // Unknown procedure type // (*U_fp)();
16068 typedef shortint (*J_fp)();
16069 typedef integer (*I_fp)();
16070 typedef real (*R_fp)();
16071 typedef doublereal (*D_fp)(), (*E_fp)();
16072 typedef // Complex // void (*C_fp)();
16073 typedef // Double Complex // void (*Z_fp)();
16074 typedef logical (*L_fp)();
16075 typedef shortlogical (*K_fp)();
16076 typedef // Character // void (*H_fp)();
16077 typedef // Subroutine // int (*S_fp)();
16079 // E_fp is for real functions when -R is not specified //
16080 typedef void C_f; // complex function //
16081 typedef void H_f; // character function //
16082 typedef void Z_f; // double complex function //
16083 typedef doublereal E_f; // real function with -R not specified //
16085 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16088 // (No such symbols should be defined in a strict ANSI C compiler.
16089 We can avoid trouble with f2c-translated code by using
16090 gcc -ansi.) //
16114 // Main program // MAIN__()
16115 {
16116 // System generated locals //
16117 integer i__1;
16118 real r__1, r__2;
16119 doublereal d__1, d__2;
16120 complex q__1;
16121 doublecomplex z__1, z__2, z__3;
16122 logical L__1;
16123 char ch__1[1];
16125 // Builtin functions //
16126 void c_div();
16127 integer pow_ii();
16128 double pow_ri(), pow_di();
16129 void pow_ci();
16130 double pow_dd();
16131 void pow_zz();
16132 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16133 asin(), atan(), atan2(), c_abs();
16134 void c_cos(), c_exp(), c_log(), r_cnjg();
16135 double cos(), cosh();
16136 void c_sin(), c_sqrt();
16137 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16138 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16139 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16140 logical l_ge(), l_gt(), l_le(), l_lt();
16141 integer i_nint();
16142 double r_sign();
16144 // Local variables //
16145 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16146 fool_(), fooz_(), getem_();
16147 static char a1[10], a2[10];
16148 static complex c1, c2;
16149 static doublereal d1, d2;
16150 static integer i1, i2;
16151 static real r1, r2;
16154 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16155 // / //
16156 i__1 = i1 / i2;
16157 fooi_(&i__1);
16158 r__1 = r1 / i1;
16159 foor_(&r__1);
16160 d__1 = d1 / i1;
16161 food_(&d__1);
16162 d__1 = (doublereal) i1;
16163 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16164 fooc_(&q__1);
16165 r__1 = r1 / r2;
16166 foor_(&r__1);
16167 d__1 = r1 / d1;
16168 food_(&d__1);
16169 d__1 = d1 / d2;
16170 food_(&d__1);
16171 d__1 = d1 / r1;
16172 food_(&d__1);
16173 c_div(&q__1, &c1, &c2);
16174 fooc_(&q__1);
16175 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16176 fooc_(&q__1);
16177 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16178 fooz_(&z__1);
16179 // ** //
16180 i__1 = pow_ii(&i1, &i2);
16181 fooi_(&i__1);
16182 r__1 = pow_ri(&r1, &i1);
16183 foor_(&r__1);
16184 d__1 = pow_di(&d1, &i1);
16185 food_(&d__1);
16186 pow_ci(&q__1, &c1, &i1);
16187 fooc_(&q__1);
16188 d__1 = (doublereal) r1;
16189 d__2 = (doublereal) r2;
16190 r__1 = pow_dd(&d__1, &d__2);
16191 foor_(&r__1);
16192 d__2 = (doublereal) r1;
16193 d__1 = pow_dd(&d__2, &d1);
16194 food_(&d__1);
16195 d__1 = pow_dd(&d1, &d2);
16196 food_(&d__1);
16197 d__2 = (doublereal) r1;
16198 d__1 = pow_dd(&d1, &d__2);
16199 food_(&d__1);
16200 z__2.r = c1.r, z__2.i = c1.i;
16201 z__3.r = c2.r, z__3.i = c2.i;
16202 pow_zz(&z__1, &z__2, &z__3);
16203 q__1.r = z__1.r, q__1.i = z__1.i;
16204 fooc_(&q__1);
16205 z__2.r = c1.r, z__2.i = c1.i;
16206 z__3.r = r1, z__3.i = 0.;
16207 pow_zz(&z__1, &z__2, &z__3);
16208 q__1.r = z__1.r, q__1.i = z__1.i;
16209 fooc_(&q__1);
16210 z__2.r = c1.r, z__2.i = c1.i;
16211 z__3.r = d1, z__3.i = 0.;
16212 pow_zz(&z__1, &z__2, &z__3);
16213 fooz_(&z__1);
16214 // FFEINTRIN_impABS //
16215 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16216 foor_(&r__1);
16217 // FFEINTRIN_impACOS //
16218 r__1 = acos(r1);
16219 foor_(&r__1);
16220 // FFEINTRIN_impAIMAG //
16221 r__1 = r_imag(&c1);
16222 foor_(&r__1);
16223 // FFEINTRIN_impAINT //
16224 r__1 = r_int(&r1);
16225 foor_(&r__1);
16226 // FFEINTRIN_impALOG //
16227 r__1 = log(r1);
16228 foor_(&r__1);
16229 // FFEINTRIN_impALOG10 //
16230 r__1 = r_lg10(&r1);
16231 foor_(&r__1);
16232 // FFEINTRIN_impAMAX0 //
16233 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16234 foor_(&r__1);
16235 // FFEINTRIN_impAMAX1 //
16236 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16237 foor_(&r__1);
16238 // FFEINTRIN_impAMIN0 //
16239 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16240 foor_(&r__1);
16241 // FFEINTRIN_impAMIN1 //
16242 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16243 foor_(&r__1);
16244 // FFEINTRIN_impAMOD //
16245 r__1 = r_mod(&r1, &r2);
16246 foor_(&r__1);
16247 // FFEINTRIN_impANINT //
16248 r__1 = r_nint(&r1);
16249 foor_(&r__1);
16250 // FFEINTRIN_impASIN //
16251 r__1 = asin(r1);
16252 foor_(&r__1);
16253 // FFEINTRIN_impATAN //
16254 r__1 = atan(r1);
16255 foor_(&r__1);
16256 // FFEINTRIN_impATAN2 //
16257 r__1 = atan2(r1, r2);
16258 foor_(&r__1);
16259 // FFEINTRIN_impCABS //
16260 r__1 = c_abs(&c1);
16261 foor_(&r__1);
16262 // FFEINTRIN_impCCOS //
16263 c_cos(&q__1, &c1);
16264 fooc_(&q__1);
16265 // FFEINTRIN_impCEXP //
16266 c_exp(&q__1, &c1);
16267 fooc_(&q__1);
16268 // FFEINTRIN_impCHAR //
16269 *(unsigned char *)&ch__1[0] = i1;
16270 fooa_(ch__1, 1L);
16271 // FFEINTRIN_impCLOG //
16272 c_log(&q__1, &c1);
16273 fooc_(&q__1);
16274 // FFEINTRIN_impCONJG //
16275 r_cnjg(&q__1, &c1);
16276 fooc_(&q__1);
16277 // FFEINTRIN_impCOS //
16278 r__1 = cos(r1);
16279 foor_(&r__1);
16280 // FFEINTRIN_impCOSH //
16281 r__1 = cosh(r1);
16282 foor_(&r__1);
16283 // FFEINTRIN_impCSIN //
16284 c_sin(&q__1, &c1);
16285 fooc_(&q__1);
16286 // FFEINTRIN_impCSQRT //
16287 c_sqrt(&q__1, &c1);
16288 fooc_(&q__1);
16289 // FFEINTRIN_impDABS //
16290 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16291 food_(&d__1);
16292 // FFEINTRIN_impDACOS //
16293 d__1 = acos(d1);
16294 food_(&d__1);
16295 // FFEINTRIN_impDASIN //
16296 d__1 = asin(d1);
16297 food_(&d__1);
16298 // FFEINTRIN_impDATAN //
16299 d__1 = atan(d1);
16300 food_(&d__1);
16301 // FFEINTRIN_impDATAN2 //
16302 d__1 = atan2(d1, d2);
16303 food_(&d__1);
16304 // FFEINTRIN_impDCOS //
16305 d__1 = cos(d1);
16306 food_(&d__1);
16307 // FFEINTRIN_impDCOSH //
16308 d__1 = cosh(d1);
16309 food_(&d__1);
16310 // FFEINTRIN_impDDIM //
16311 d__1 = d_dim(&d1, &d2);
16312 food_(&d__1);
16313 // FFEINTRIN_impDEXP //
16314 d__1 = exp(d1);
16315 food_(&d__1);
16316 // FFEINTRIN_impDIM //
16317 r__1 = r_dim(&r1, &r2);
16318 foor_(&r__1);
16319 // FFEINTRIN_impDINT //
16320 d__1 = d_int(&d1);
16321 food_(&d__1);
16322 // FFEINTRIN_impDLOG //
16323 d__1 = log(d1);
16324 food_(&d__1);
16325 // FFEINTRIN_impDLOG10 //
16326 d__1 = d_lg10(&d1);
16327 food_(&d__1);
16328 // FFEINTRIN_impDMAX1 //
16329 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16330 food_(&d__1);
16331 // FFEINTRIN_impDMIN1 //
16332 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16333 food_(&d__1);
16334 // FFEINTRIN_impDMOD //
16335 d__1 = d_mod(&d1, &d2);
16336 food_(&d__1);
16337 // FFEINTRIN_impDNINT //
16338 d__1 = d_nint(&d1);
16339 food_(&d__1);
16340 // FFEINTRIN_impDPROD //
16341 d__1 = (doublereal) r1 * r2;
16342 food_(&d__1);
16343 // FFEINTRIN_impDSIGN //
16344 d__1 = d_sign(&d1, &d2);
16345 food_(&d__1);
16346 // FFEINTRIN_impDSIN //
16347 d__1 = sin(d1);
16348 food_(&d__1);
16349 // FFEINTRIN_impDSINH //
16350 d__1 = sinh(d1);
16351 food_(&d__1);
16352 // FFEINTRIN_impDSQRT //
16353 d__1 = sqrt(d1);
16354 food_(&d__1);
16355 // FFEINTRIN_impDTAN //
16356 d__1 = tan(d1);
16357 food_(&d__1);
16358 // FFEINTRIN_impDTANH //
16359 d__1 = tanh(d1);
16360 food_(&d__1);
16361 // FFEINTRIN_impEXP //
16362 r__1 = exp(r1);
16363 foor_(&r__1);
16364 // FFEINTRIN_impIABS //
16365 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16366 fooi_(&i__1);
16367 // FFEINTRIN_impICHAR //
16368 i__1 = *(unsigned char *)a1;
16369 fooi_(&i__1);
16370 // FFEINTRIN_impIDIM //
16371 i__1 = i_dim(&i1, &i2);
16372 fooi_(&i__1);
16373 // FFEINTRIN_impIDNINT //
16374 i__1 = i_dnnt(&d1);
16375 fooi_(&i__1);
16376 // FFEINTRIN_impINDEX //
16377 i__1 = i_indx(a1, a2, 10L, 10L);
16378 fooi_(&i__1);
16379 // FFEINTRIN_impISIGN //
16380 i__1 = i_sign(&i1, &i2);
16381 fooi_(&i__1);
16382 // FFEINTRIN_impLEN //
16383 i__1 = i_len(a1, 10L);
16384 fooi_(&i__1);
16385 // FFEINTRIN_impLGE //
16386 L__1 = l_ge(a1, a2, 10L, 10L);
16387 fool_(&L__1);
16388 // FFEINTRIN_impLGT //
16389 L__1 = l_gt(a1, a2, 10L, 10L);
16390 fool_(&L__1);
16391 // FFEINTRIN_impLLE //
16392 L__1 = l_le(a1, a2, 10L, 10L);
16393 fool_(&L__1);
16394 // FFEINTRIN_impLLT //
16395 L__1 = l_lt(a1, a2, 10L, 10L);
16396 fool_(&L__1);
16397 // FFEINTRIN_impMAX0 //
16398 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16399 fooi_(&i__1);
16400 // FFEINTRIN_impMAX1 //
16401 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16402 fooi_(&i__1);
16403 // FFEINTRIN_impMIN0 //
16404 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16405 fooi_(&i__1);
16406 // FFEINTRIN_impMIN1 //
16407 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16408 fooi_(&i__1);
16409 // FFEINTRIN_impMOD //
16410 i__1 = i1 % i2;
16411 fooi_(&i__1);
16412 // FFEINTRIN_impNINT //
16413 i__1 = i_nint(&r1);
16414 fooi_(&i__1);
16415 // FFEINTRIN_impSIGN //
16416 r__1 = r_sign(&r1, &r2);
16417 foor_(&r__1);
16418 // FFEINTRIN_impSIN //
16419 r__1 = sin(r1);
16420 foor_(&r__1);
16421 // FFEINTRIN_impSINH //
16422 r__1 = sinh(r1);
16423 foor_(&r__1);
16424 // FFEINTRIN_impSQRT //
16425 r__1 = sqrt(r1);
16426 foor_(&r__1);
16427 // FFEINTRIN_impTAN //
16428 r__1 = tan(r1);
16429 foor_(&r__1);
16430 // FFEINTRIN_impTANH //
16431 r__1 = tanh(r1);
16432 foor_(&r__1);
16433 // FFEINTRIN_imp_CMPLX_C //
16434 r__1 = c1.r;
16435 r__2 = c2.r;
16436 q__1.r = r__1, q__1.i = r__2;
16437 fooc_(&q__1);
16438 // FFEINTRIN_imp_CMPLX_D //
16439 z__1.r = d1, z__1.i = d2;
16440 fooz_(&z__1);
16441 // FFEINTRIN_imp_CMPLX_I //
16442 r__1 = (real) i1;
16443 r__2 = (real) i2;
16444 q__1.r = r__1, q__1.i = r__2;
16445 fooc_(&q__1);
16446 // FFEINTRIN_imp_CMPLX_R //
16447 q__1.r = r1, q__1.i = r2;
16448 fooc_(&q__1);
16449 // FFEINTRIN_imp_DBLE_C //
16450 d__1 = (doublereal) c1.r;
16451 food_(&d__1);
16452 // FFEINTRIN_imp_DBLE_D //
16453 d__1 = d1;
16454 food_(&d__1);
16455 // FFEINTRIN_imp_DBLE_I //
16456 d__1 = (doublereal) i1;
16457 food_(&d__1);
16458 // FFEINTRIN_imp_DBLE_R //
16459 d__1 = (doublereal) r1;
16460 food_(&d__1);
16461 // FFEINTRIN_imp_INT_C //
16462 i__1 = (integer) c1.r;
16463 fooi_(&i__1);
16464 // FFEINTRIN_imp_INT_D //
16465 i__1 = (integer) d1;
16466 fooi_(&i__1);
16467 // FFEINTRIN_imp_INT_I //
16468 i__1 = i1;
16469 fooi_(&i__1);
16470 // FFEINTRIN_imp_INT_R //
16471 i__1 = (integer) r1;
16472 fooi_(&i__1);
16473 // FFEINTRIN_imp_REAL_C //
16474 r__1 = c1.r;
16475 foor_(&r__1);
16476 // FFEINTRIN_imp_REAL_D //
16477 r__1 = (real) d1;
16478 foor_(&r__1);
16479 // FFEINTRIN_imp_REAL_I //
16480 r__1 = (real) i1;
16481 foor_(&r__1);
16482 // FFEINTRIN_imp_REAL_R //
16483 r__1 = r1;
16484 foor_(&r__1);
16486 // FFEINTRIN_imp_INT_D: //
16488 // FFEINTRIN_specIDINT //
16489 i__1 = (integer) d1;
16490 fooi_(&i__1);
16492 // FFEINTRIN_imp_INT_R: //
16494 // FFEINTRIN_specIFIX //
16495 i__1 = (integer) r1;
16496 fooi_(&i__1);
16497 // FFEINTRIN_specINT //
16498 i__1 = (integer) r1;
16499 fooi_(&i__1);
16501 // FFEINTRIN_imp_REAL_D: //
16503 // FFEINTRIN_specSNGL //
16504 r__1 = (real) d1;
16505 foor_(&r__1);
16507 // FFEINTRIN_imp_REAL_I: //
16509 // FFEINTRIN_specFLOAT //
16510 r__1 = (real) i1;
16511 foor_(&r__1);
16512 // FFEINTRIN_specREAL //
16513 r__1 = (real) i1;
16514 foor_(&r__1);
16516 } // MAIN__ //
16518 -------- (end output file from f2c)
16520 */