| blob | c086c489e1ab3a2d8cb2db1764b19ec9235cd72e |
1 /* com.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
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. */
84 #if FFECOM_targetCURRENT == FFECOM_targetGCC
97 /* VMS-specific definitions */
98 #ifdef VMS
99 #include <descrip.h>
102 #define read(fd,buf,size) VMS_read (fd,buf,size)
103 #define write(fd,buf,size) VMS_write (fd,buf,size)
104 #define open(fname,mode,prot) VMS_open (fname,mode,prot)
105 #define fopen(fname,mode) VMS_fopen (fname,mode)
106 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
107 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
108 #define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
118 #define ino_t vms_ino_t
139 /* Externals defined here. */
141 #if FFECOM_targetCURRENT == FFECOM_targetGCC
143 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
144 reference it. */
148 /* Stream for reading from the input file. */
151 /* These definitions parallel those in c-decl.c so that code from that
152 module can be used pretty much as is. Much of these defs aren't
153 otherwise used, i.e. by g77 code per se, except some of them are used
154 to build some of them that are. The ones that are global (i.e. not
155 "static") are those that ste.c and such might use (directly
156 or by using com macros that reference them in their definitions). */
158 tree string_type_node;
160 /* The rest of these are inventions for g77, though there might be
161 similar things in the C front end. As they are found, these
162 inventions should be renamed to be canonical. Note that only
163 the ones currently required to be global are so. */
172 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
173 just use build_function_type and build_pointer_type on the
174 appropriate _tree_type array element. */
184 ffecomSymbol ffecom_symbol_null_
185 =
186 {
187 NULL_TREE,
188 NULL_TREE,
189 NULL_TREE,
190 NULL_TREE,
191 false
192 };
197 tree ffecom_f2c_integer_type_node;
198 tree ffecom_f2c_ptr_to_integer_type_node;
199 tree ffecom_f2c_address_type_node;
200 tree ffecom_f2c_real_type_node;
201 tree ffecom_f2c_ptr_to_real_type_node;
202 tree ffecom_f2c_doublereal_type_node;
203 tree ffecom_f2c_complex_type_node;
204 tree ffecom_f2c_doublecomplex_type_node;
205 tree ffecom_f2c_longint_type_node;
206 tree ffecom_f2c_logical_type_node;
207 tree ffecom_f2c_flag_type_node;
208 tree ffecom_f2c_ftnlen_type_node;
209 tree ffecom_f2c_ftnlen_zero_node;
210 tree ffecom_f2c_ftnlen_one_node;
211 tree ffecom_f2c_ftnlen_two_node;
212 tree ffecom_f2c_ptr_to_ftnlen_type_node;
213 tree ffecom_f2c_ftnint_type_node;
214 tree ffecom_f2c_ptr_to_ftnint_type_node;
217 /* Simple definitions and enumerations. */
219 #ifndef FFECOM_sizeMAXSTACKITEM
221 larger than this # bytes
222 off stack if possible. */
223 #endif
225 /* For systems that have large enough stacks, they should define
226 this to 0, and here, for ease of use later on, we just undefine
227 it if it is 0. */
229 #if FFECOM_sizeMAXSTACKITEM == 0
230 #undef FFECOM_sizeMAXSTACKITEM
231 #endif
234 {
235 FFECOM_rttypeVOID_,
250 FFECOM_rttype_
253 /* Internal typedefs. */
255 #if FFECOM_targetCURRENT == FFECOM_targetGCC
259 /* Private include files. */
262 /* Internal structure definitions. */
264 #if FFECOM_targetCURRENT == FFECOM_targetGCC
265 struct _ffecom_concat_list_
266 {
270 ffetargetCharacterSize minlen;
271 ffetargetCharacterSize maxlen;
272 };
275 /* Static functions (internal). */
277 #if FFECOM_targetCURRENT == FFECOM_targetGCC
302 static ffecomConcatList_
304 ffebld expr,
305 ffetargetCharacterSize max);
308 ffetargetCharacterSize max);
311 ffetargetOffset offset);
328 ffeinfoBasictype bt,
329 ffeinfoKindtype kt);
337 tree dest_length,
338 ffetargetCharacterSize dest_size,
339 ffebld source);
344 ffebld source);
354 tree t);
361 ffeinfoBasictype bt,
362 ffeinfoKindtype kt);
372 /* These are static functions that parallel those found in the C front
373 end and thus have the same names. */
375 #if FFECOM_targetCURRENT == FFECOM_targetGCC
395 #if FFECOM_GCC_INCLUDE
401 ffewhereColumn c);
404 /* Static objects accessed by functions in this module. */
410 #if FFECOM_targetCURRENT == FFECOM_targetGCC
431 static tree
439 /* Holds pointer-to-function expressions. */
442 =
443 {
444 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
446 #undef DEFGFRT
447 };
449 /* Holds the external names of the functions. */
452 =
453 {
454 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
456 #undef DEFGFRT
457 };
459 /* Whether the function returns. */
462 =
463 {
464 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
466 #undef DEFGFRT
467 };
469 /* Whether the function returns type complex. */
472 =
473 {
474 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
476 #undef DEFGFRT
477 };
479 /* Whether the function is const
480 (i.e., has no side effects and only depends on its arguments). */
483 =
484 {
485 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
487 #undef DEFGFRT
488 };
490 /* Type code for the function return value. */
493 =
494 {
495 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
497 #undef DEFGFRT
498 };
500 /* String of codes for the function's arguments. */
503 =
504 {
505 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
507 #undef DEFGFRT
508 };
511 /* Internal macros. */
513 #if FFECOM_targetCURRENT == FFECOM_targetGCC
515 /* We let tm.h override the types used here, to handle trivial differences
516 such as the choice of unsigned int or long unsigned int for size_t.
517 When machines start needing nontrivial differences in the size type,
518 it would be best to do something here to figure out automatically
519 from other information what type to use. */
521 #ifndef SIZE_TYPE
523 #endif
525 #define ffecom_concat_list_count_(catlist) ((catlist).count)
526 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
527 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
528 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
530 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
531 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
533 /* For each binding contour we allocate a binding_level structure
534 * which records the names defined in that contour.
535 * Contours include:
536 * 0) the global one
537 * 1) one for each function definition,
538 * where internal declarations of the parameters appear.
539 *
540 * The current meaning of a name can be found by searching the levels from
541 * the current one out to the global one.
542 */
544 /* Note that the information in the `names' component of the global contour
545 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
547 struct binding_level
548 {
549 /* A chain of _DECL nodes for all variables, constants, functions,
550 and typedef types. These are in the reverse of the order supplied.
551 */
552 tree names;
554 /* For each level (except not the global one),
555 a chain of BLOCK nodes for all the levels
556 that were entered and exited one level down. */
557 tree blocks;
559 /* The BLOCK node for this level, if one has been preallocated.
560 If 0, the BLOCK is allocated (if needed) when the level is popped. */
561 tree this_block;
563 /* The binding level which this one is contained in (inherits from). */
566 /* 0: no ffecom_prepare_* functions called at this level yet;
567 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
568 2: ffecom_prepare_end called. */
570 };
572 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
574 /* The binding level currently in effect. */
578 /* A chain of binding_level structures awaiting reuse. */
582 /* The outermost binding level, for names of file scope.
583 This is created when the compiler is started and exists
584 through the entire run. */
588 /* Binding level structures are initialized by copying this one. */
590 static struct binding_level clear_binding_level
591 =
594 /* Language-dependent contents of an identifier. */
596 struct lang_identifier
597 {
601 };
603 /* Macros for access to language-specific slots in an identifier. */
604 /* Each of these slots contains a DECL node or null. */
606 /* This represents the value which the identifier has in the
607 file-scope namespace. */
608 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
609 (((struct lang_identifier *)(NODE))->global_value)
610 /* This represents the value which the identifier has in the current
611 scope. */
612 #define IDENTIFIER_LOCAL_VALUE(NODE) \
613 (((struct lang_identifier *)(NODE))->local_value)
614 /* This represents the value which the identifier has as a label in
615 the current label scope. */
616 #define IDENTIFIER_LABEL_VALUE(NODE) \
617 (((struct lang_identifier *)(NODE))->label_value)
618 /* This is nonzero if the identifier was "made up" by g77 code. */
619 #define IDENTIFIER_INVENTED(NODE) \
620 (((struct lang_identifier *)(NODE))->invented)
622 /* In identifiers, C uses the following fields in a special way:
623 TREE_PUBLIC to record that there was a previous local extern decl.
624 TREE_USED to record that such a decl was used.
625 TREE_ADDRESSABLE to record that the address of such a decl was used. */
627 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
628 that have names. Here so we can clear out their names' definitions
629 at the end of the function. */
633 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
638 \f
639 /* Return the subscript expression, modified to do range-checking.
641 `array' is the array to be checked against.
642 `element' is the subscript expression to check.
643 `dim' is the dimension number (starting at 0).
644 `total_dims' is the total number of dimensions (0 for CHARACTER substring).
645 */
647 static tree
650 {
653 tree cond;
654 tree die;
655 tree args;
661 {
665 else
666 {
670 }
671 }
675 {
676 /* Special handling for substring range checks. Fortran allows the
677 end subscript < begin subscript, which means that expressions like
678 string(1:0) are valid (and yield a null string). In view of this,
679 enforce two simpler conditions:
680 1) element<=high for end-substring;
681 2) element>=low for start-substring.
682 Run-time character movement will enforce remaining conditions.
684 More complicated checks would be better, but present structure only
685 provides one index element at a time, so it is not possible to
686 enforce a check of both i and j in string(i:j). If it were, the
687 complete set of rules would read,
688 if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
689 ((low<=i<=high) && (low<=j<=high)) )
690 ok ;
691 else
692 range error ;
693 */
696 else
698 }
699 else
700 {
701 /* Array reference substring range checking. */
704 low,
705 element);
707 {
709 cond,
711 element,
712 high));
713 }
714 }
716 {
720 tree arg3;
721 tree arg2;
722 tree arg1;
723 tree arg4;
726 {
743 array_name,
749 }
753 build_range_type
755 integer_one_node,
761 arg1);
763 /* s_rnge adds one to the element to print it, so bias against
764 that -- want to print a faithful *subscript* value. */
768 element,
770 integer_one_node)));
774 NULL);
782 build_range_type
784 integer_one_node,
790 arg3);
804 }
811 cond,
812 element,
813 die);
816 }
818 /* Return the computed element of an array reference.
820 `item' is NULL_TREE, or the transformed pointer to the array.
821 `expr' is the original opARRAYREF expression, which is transformed
822 if `item' is NULL_TREE.
823 `want_ptr' is non-zero if a pointer to the element, instead of
824 the element itself, is to be returned. */
826 static tree
828 {
834 tree array;
835 tree element;
836 tree tree_type;
837 tree tree_type_x;
839 ffetype type;
840 ffebld list;
844 else
847 /* Build up ARRAY_REFs in reverse order (since we're column major
848 here in Fortran land). */
853 {
860 /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
861 pointers and 32-bit integers. Do the full 64-bit pointer
862 arithmetic, for codes using arrays for nonstandard heap-like
863 work. */
865 }
872 {
875 else
884 }
890 {
891 tree min;
896 {
901 array_name);
905 /* Widen integral arithmetic as desired while preserving
906 signedness. */
921 item,
926 tree_type_x,
928 }
930 {
933 item);
934 }
935 }
936 else
937 {
941 {
947 array_name);
951 /* Widen integral arithmetic as desired while preserving
952 signedness. */
964 item,
965 element);
966 }
967 }
970 }
972 /* This is like gcc's stabilize_reference -- in fact, most of the code
973 comes from that -- but it handles the situation where the reference
974 is going to have its subparts picked at, and it shouldn't change
975 (or trigger extra invocations of functions in the subtrees) due to
976 this. save_expr is a bit overzealous, because we don't need the
977 entire thing calculated and saved like a temp. So, for DECLs, no
978 change is needed, because these are stable aggregates, and ARRAY_REF
979 and such might well be stable too, but for things like calculations,
980 we do need to calculate a snapshot of a value before picking at it. */
982 #if FFECOM_targetCURRENT == FFECOM_targetGCC
983 static tree
985 {
986 tree result;
990 {
994 /* No action is needed in this case. */
1046 }
1054 }
1055 #endif
1057 /* A rip-off of gcc's convert.c convert_to_complex function,
1058 reworked to handle complex implemented as C structures
1059 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
1061 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1062 static tree
1064 {
1066 tree subtype;
1073 {
1077 }
1080 {
1084 else
1085 {
1088 type,
1092 expr)),
1096 expr)));
1097 }
1098 }
1102 else
1108 }
1109 #endif
1111 /* Like gcc's convert(), but crashes if widening might happen. */
1113 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1114 static tree
1117 {
1130 {
1133 }
1140 {
1147 }
1149 {
1152 }
1154 {
1158 }
1160 {
1164 }
1166 {
1168 /* Check that at least the first field name agrees. */
1177 }
1181 }
1182 #endif
1184 /* Like gcc's convert(), but crashes if narrowing might happen. */
1186 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1187 static tree
1190 {
1203 {
1206 }
1213 {
1220 }
1222 {
1225 }
1227 {
1231 }
1233 {
1237 }
1239 {
1241 /* Check that at least the first field name agrees. */
1250 }
1254 }
1255 #endif
1257 /* Handles making a COMPLEX type, either the standard
1258 (but buggy?) gbe way, or the safer (but less elegant?)
1259 f2c way. */
1261 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1262 static tree
1264 {
1265 tree type;
1266 tree realfield;
1267 tree imagfield;
1270 {
1276 }
1277 else
1278 {
1282 }
1285 }
1286 #endif
1288 /* Chooses either the gbe or the f2c way to build a
1289 complex constant. */
1291 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1292 static tree
1294 {
1295 tree bothparts;
1298 {
1302 }
1303 else
1304 {
1306 }
1309 }
1310 #endif
1312 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1313 static tree
1315 {
1316 tree list;
1320 tree length;
1321 ffebld exprh;
1322 tree item;
1331 {
1333 {
1336 {
1339 }
1341 {
1380 }
1381 }
1388 || (ptr
1389 && (TYPE_MODE
1393 *plist
1397 else
1398 {
1402 {
1405 item);
1406 }
1407 *plist
1409 item);
1410 }
1415 {
1418 }
1419 }
1421 /* We've run out of args in the call; if the implementation expects
1422 more, supply null pointers for them, which the implementation can
1423 check to see if an arg was omitted. */
1426 {
1429 else
1433 {
1447 }
1448 *plist
1450 null_pointer_node);
1452 }
1457 }
1458 #endif
1460 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1461 static tree
1463 {
1464 ffebld item;
1466 ffetype type;
1468 tree t;
1471 {
1484 {
1487 }
1488 }
1495 }
1496 #endif
1498 /* Check whether a partial overlap between two expressions is possible.
1500 Can *starting* to write a portion of expr1 change the value
1501 computed (perhaps already, *partially*) by expr2?
1503 Currently, this is a concern only for a COMPLEX expr1. But if it
1504 isn't in COMMON or local EQUIVALENCE, since we don't support
1505 aliasing of arguments, it isn't a concern. */
1507 static bool
1509 {
1510 ffesymbol sym;
1511 ffestorag st;
1514 {
1527 }
1535 /* It's in COMMON or local EQUIVALENCE. */
1538 }
1540 /* Check whether dest and source might overlap. ffebld versions of these
1541 might or might not be passed, will be NULL if not.
1543 The test is really whether source_tree is modifiable and, if modified,
1544 might overlap destination such that the value(s) in the destination might
1545 change before it is finally modified. dest_* are the canonized
1546 destination itself. */
1548 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1549 static bool
1553 {
1554 tree source_decl;
1555 tree source_offset;
1556 tree source_size;
1557 tree t;
1563 {
1628 scalar_arg);
1633 scalar_arg);
1643 source_tree);
1648 return
1651 scalar_arg)
1654 scalar_arg);
1683 }
1685 /* Come here when source_decl, source_offset, and source_size filled
1686 in appropriately. */
1696 array? Shouldn't happen.... */
1700 dest_offset,
1702 dest_size)),
1704 source_offset));
1717 source_offset,
1719 source_size)),
1721 dest_offset));
1727 }
1728 #endif
1730 /* Check whether dest might overlap any of a list of arguments or is
1731 in a COMMON area the callee might know about (and thus modify). */
1733 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1734 static bool
1738 {
1739 tree arg;
1740 tree dest_decl;
1741 tree dest_offset;
1742 tree dest_size;
1745 dest_tree);
1750 /* If the decl cannot be determined reliably, or if its in COMMON
1751 and the callee isn't known to not futz with COMMON via other
1752 means, overlap might happen. */
1760 {
1765 }
1768 }
1769 #endif
1771 /* Build a string for a variable name as used by NAMELIST. This means that
1772 if we're using the f2c library, we build an uppercase string, since
1773 f2c does this. */
1775 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1776 static tree
1778 {
1782 {
1787 tree t;
1791 else
1804 }
1805 }
1807 #endif
1808 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1809 type to just get whatever the function returns), handling the
1810 f2c value-returning convention, if required, by prepending
1811 to the arglist a pointer to a temporary to receive the return value. */
1813 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1814 static tree
1819 {
1820 tree item;
1821 tree tempvar;
1827 {
1835 callee_commons,
1836 scalar_args))
1837 {
1838 #ifdef HOHO
1841 FFETARGET_charactersizeNONE,
1843 #else
1846 #endif
1847 }
1848 else
1849 {
1853 }
1855 item
1859 tempvar));
1867 }
1868 else
1876 }
1877 #endif
1879 /* Given two arguments, transform them and make a call to the given
1880 function via ffecom_call_. */
1882 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1883 static tree
1888 {
1889 tree left_tree;
1890 tree right_tree;
1891 tree left_length;
1892 tree right_length;
1895 {
1896 /* Pass arguments by reference. */
1899 }
1900 else
1901 {
1902 /* Pass arguments by value. */
1905 }
1913 {
1916 }
1919 {
1923 else
1925 }
1930 }
1931 #endif
1933 /* Return ptr/length args for char subexpression
1935 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1936 subexpressions by constructing the appropriate trees for the ptr-to-
1937 character-text and length-of-character-text arguments in a calling
1938 sequence.
1940 Note that if with_null is TRUE, and the expression is an opCONTER,
1941 a null byte is appended to the string. */
1943 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1944 static void
1946 {
1947 tree item;
1948 tree high;
1949 ffetargetCharacter1 val;
1950 ffetargetCharacterSize newlen;
1953 {
1958 {
1959 /* Begin FFETARGET-NULL-KLUDGE. */
1962 }
1969 /* End FFETARGET-NULL-KLUDGE. */
1971 = build_type_variant
1972 (build_array_type
1974 build_range_type
1976 ffecom_f2c_ftnlen_one_node,
1977 high)),
1982 item);
1986 {
1991 {
1994 }
1996 {
1999 else
2000 {
2003 }
2004 }
2007 else
2008 /* FFEINFO_kindFUNCTION. */
2014 item);
2015 }
2019 {
2023 {
2026 }
2029 }
2033 {
2034 ffebld start;
2035 ffebld end;
2037 tree start_tree;
2038 tree end_tree;
2040 ffebld left_symter;
2041 tree array;
2049 /* Determine name for pretty-printing range-check errors. */
2053 ;
2056 else
2062 {
2065 }
2069 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2072 {
2074 ;
2075 else
2076 {
2080 char_name);
2082 end_tree);
2085 {
2088 }
2091 }
2092 }
2093 else
2094 {
2098 char_name);
2100 start_tree);
2103 {
2106 }
2111 item,
2114 start_tree,
2115 ffecom_f2c_ftnlen_one_node));
2118 {
2120 ffecom_f2c_ftnlen_one_node,
2122 ffecom_f2c_ftnlen_type_node,
2124 start_tree));
2125 }
2126 else
2127 {
2131 char_name);
2133 end_tree);
2136 {
2139 }
2142 ffecom_f2c_ftnlen_one_node,
2144 ffecom_f2c_ftnlen_type_node,
2146 }
2147 }
2148 }
2152 {
2154 tree tempvar;
2155 tree args;
2157 ffecomGfrt ix;
2160 /* ~~Kludge alert! This should someday be fixed. */
2168 {
2170 {
2171 /* Invocation of an intrinsic returning CHARACTER*1. */
2175 }
2179 }
2180 else
2181 {
2185 {
2188 }
2190 {
2193 }
2197 }
2199 #ifdef HOHO
2201 #else
2204 #endif
2207 tempvar);
2213 else
2214 {
2217 {
2221 }
2222 else
2223 {
2226 }
2227 }
2233 tempvar);
2234 }
2242 {
2245 }
2251 temporary. */
2252 tree tempvar;
2253 tree args;
2254 tree newlen;
2256 #ifdef HOHO
2259 #else
2262 #endif
2265 tempvar);
2279 tempvar);
2281 }
2282 else
2286 }
2293 }
2296 }
2297 #endif
2299 /* Check the size of the type to be sure it doesn't overflow the
2300 "portable" capacities of the compiler back end. `dummy' types
2301 can generally overflow the normal sizes as long as the computations
2302 themselves don't overflow. A particular target of the back end
2303 must still enforce its size requirements, though, and the back
2304 end takes care of this in stor-layout.c. */
2306 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2307 static tree
2309 {
2322 {
2329 }
2332 }
2333 #endif
2335 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2336 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2337 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2339 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2340 static tree
2342 {
2344 tree highval;
2345 tree tlen;
2350 else
2351 {
2355 else
2358 #if BUILT_FOR_270
2360 #endif
2361 }
2364 {
2367 }
2368 else
2369 {
2372 }
2376 ffecom_f2c_ftnlen_one_node,
2377 highval));
2381 }
2383 #endif
2384 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2386 ffecomConcatList_ catlist;
2387 ffebld expr; // expr of CHARACTER basictype.
2388 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2389 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2391 Scans expr for character subexpressions, updates and returns catlist
2392 accordingly. */
2394 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2395 static ffecomConcatList_
2397 ffetargetCharacterSize max)
2398 {
2399 ffetargetCharacterSize sz;
2410 {
2417 if they don't need to preserve it. */
2427 {
2431 }
2434 }
2437 else
2441 else
2445 of the destination. */
2447 {
2453 /* ~~Do useful truncations here. */
2459 }
2460 }
2474 dummy arg of sfunc */
2477 {
2478 ffetargetCharacterSize cmax;
2484 }
2486 #endif
2494 }
2495 }
2497 #endif
2498 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2500 ffecomConcatList_ catlist;
2501 ffecom_concat_list_kill_(catlist);
2503 Anything allocated within the list info is deallocated. */
2505 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2506 static void
2508 {
2512 }
2514 #endif
2515 /* Make list of concatenated string exprs.
2517 Returns a flattened list of concatenated subexpressions given a
2518 tree of such expressions. */
2520 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2521 static ffecomConcatList_
2523 {
2524 ffecomConcatList_ catlist;
2528 }
2530 #endif
2532 /* Provide some kind of useful info on member of aggregate area,
2533 since current g77/gcc technology does not provide debug info
2534 on these members. */
2536 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2537 static void
2540 {
2541 tree value;
2542 tree decl;
2546 #if 0
2547 tree type_id;
2551 )
2552 {
2554 {
2569 }
2570 }
2571 #endif
2580 #if 0
2582 #endif
2586 else
2590 aggr_type,
2597 build_range_type
2599 integer_one_node,
2614 }
2615 #endif
2617 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2619 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2620 int i; // entry# for this entrypoint (used by master fn)
2621 ffecom_do_entrypoint_(s,i);
2623 Makes a public entry point that calls our private master fn (already
2624 compiled). */
2626 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2627 static void
2629 {
2630 ffebld item;
2634 ffeinfoBasictype bt;
2635 ffeinfoKindtype kt;
2636 ffeglobal g;
2637 ffeglobalType gt;
2639 CHARACTER. */
2652 {
2655 /* Determine actual return type for function. */
2661 {
2667 }
2674 else
2681 else
2700 {
2702 {
2705 }
2706 }
2709 else
2711 }
2712 else
2721 /* Fall through. */
2731 }
2733 /* build_decl uses the current lineno and input_filename to set the decl
2734 source info. So, I've putzed with ffestd and ffeste code to update that
2735 source info to point to the appropriate statement just before calling
2736 ffecom_do_entrypoint (which calls this fn). */
2739 type,
2746 {
2748 }
2750 /* Reset args in master arg list so they get retransitioned. */
2755 {
2756 ffebld arg;
2757 ffesymbol s;
2765 }
2767 /* Build dummy arg list for this entry point. */
2771 tree type;
2772 tree length;
2776 else
2781 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2785 else
2795 {
2798 }
2799 }
2800 else
2808 /* Disallow temp vars at this level. */
2811 /* Make local var to hold return type for multi-type master fn. */
2814 {
2818 ffecom_multi_type_node_);
2821 }
2822 else
2825 /* Here we emit the actual code for the entry point. */
2827 {
2828 ffebld list;
2829 ffebld arg;
2830 ffesymbol s;
2833 tree prepend;
2834 tree call;
2835 tree actarg;
2836 tree master_fn;
2838 /* Prepare actual arg list based on master arg list. */
2843 {
2851 else
2855 }
2857 /* This code appends the length arguments for character
2858 variables/arrays. */
2863 {
2875 else
2879 }
2881 /* Prepend character-value return info to actual arg list. */
2884 {
2890 }
2892 /* Prepend multi-type return value to actual arg list. */
2895 {
2896 prepend
2900 multi_retval));
2903 }
2905 /* Prepend my entry-point number to the actual arg list. */
2911 /* Build the call to the master function. */
2918 /* Decide whether the master function is a function or subroutine, and
2919 handle the return value for my entry point. */
2923 {
2926 }
2928 {
2930 result
2933 result);
2936 multi_retval,
2940 }
2942 {
2944 result
2949 multi_retval,
2952 }
2954 {
2955 result
2958 result);
2962 }
2963 else
2964 {
2966 result,
2968 call));
2970 }
2971 }
2981 }
2983 #endif
2984 /* Transform expr into gcc tree with possible destination
2986 Recursive descent on expr while making corresponding tree nodes and
2987 attaching type info and such. If destination supplied and compatible
2988 with temporary that would be made in certain cases, temporary isn't
2989 made, destination used instead, and dest_used flag set TRUE. */
2991 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2992 static tree
2995 {
2996 tree item;
2997 tree list;
2998 tree args;
2999 ffeinfoBasictype bt;
3000 ffeinfoKindtype kt;
3001 tree t;
3005 ffesymbol s;
3017 /* Widen integral arithmetic as desired while preserving signedness. */
3025 {
3027 {
3028 ffebitCount i;
3032 tree purpose;
3040 {
3041 ffebldConstantUnion cu;
3042 ffebitCount length;
3051 {
3053 {
3062 else
3067 else
3068 {
3071 }
3072 }
3073 }
3076 }
3077 }
3083 item
3084 = build_array_type
3087 ffecom_integer_zero_node,
3088 item));
3095 {
3096 ffetargetOffset i;
3101 else
3102 {
3106 /* Becomes PURPOSE first time through loop. */
3108 }
3111 {
3112 ffebldConstantUnion cu
3118 /* Assume item is PURPOSE first time through loop. */
3120 else
3121 {
3124 }
3125 }
3126 }
3131 item
3132 = build_array_type
3135 ffecom_integer_zero_node,
3136 item));
3144 item
3159 {
3160 /* User explicitly wants ASSIGN'ed variables to be at the same
3161 memory address as the variables when used in non-ASSIGN
3162 contexts. That can make old, arcane, non-standard code
3163 work, but don't try to do it when a pointer wouldn't fit
3164 in the normal variable (take other approach, and warn,
3165 instead). */
3168 {
3172 }
3179 {
3184 }
3187 {
3189 FFEBAD_severityWARNING);
3194 }
3195 }
3197 /* Don't use the normal variable's tree for ASSIGN, though mark
3198 it as in the system header (housekeeping). Use an explicit,
3199 specially created sibling that is known to be wide enough
3200 to hold pointers to labels. */
3208 {
3212 }
3213 }
3214 else
3215 {
3217 {
3221 }
3225 }
3236 /* ~~~Make sure Fortran rules respected here */
3243 {
3246 }
3253 {
3257 }
3264 {
3268 }
3275 {
3279 }
3286 {
3290 }
3296 {
3299 ffecomGfrt code;
3300 ffeinfoKindtype rtkt;
3301 ffeinfoKindtype ltkt;
3305 {
3309 {
3313 }
3317 {
3323 {
3327 }
3328 else
3329 {
3332 }
3338 {
3341 }
3342 else
3343 {
3346 }
3352 {
3355 }
3356 else
3357 {
3360 }
3368 }
3373 FFETARGET_charactersizeNONE,
3374 FFEEXPR_contextLET);
3377 FFEINFO_basictypeINTEGER,
3379 FFETARGET_charactersizeNONE,
3380 FFEEXPR_contextLET);
3387 FFETARGET_charactersizeNONE,
3388 FFEEXPR_contextLET);
3392 FFEINFO_basictypeREAL,
3394 FFETARGET_charactersizeNONE,
3395 FFEEXPR_contextLET);
3396 /* We used to call FFECOM_gfrtPOW_DD here,
3397 which passes arguments by reference. */
3399 /* Pass arguments by value. */
3406 FFEINFO_basictypeCOMPLEX,
3408 FFETARGET_charactersizeNONE,
3409 FFEEXPR_contextLET);
3413 FFEINFO_basictypeCOMPLEX,
3415 FFETARGET_charactersizeNONE,
3416 FFEEXPR_contextLET);
3425 }
3434 }
3438 {
3449 /* Fall through. */
3452 }
3458 /* Fall through. */
3464 dest_used);
3466 }
3470 {
3473 }
3479 else
3484 else
3495 tree_type,
3496 args,
3505 {
3507 item
3520 /* Fall through. */
3523 }
3528 {
3530 item
3543 /* Fall through. */
3546 }
3552 {
3554 item
3567 /* Fall through. */
3570 }
3575 {
3577 item
3584 return
3592 /* Fall through. */
3595 }
3603 {
3611 {
3618 /* convert() takes care of converting to the subtype first,
3619 at least in gcc-2.7.2. */
3628 /* Fall through. */
3631 }
3636 /* Fall through. */
3639 }
3667 {
3678 {
3679 tree real_type;
3690 {
3693 }
3694 else
3695 {
3698 }
3700 item
3708 arg2)));
3711 else
3714 }
3717 {
3720 tree left_tree;
3721 tree right_tree;
3722 tree left_length;
3723 tree right_length;
3725 /* f2c run-time functions do the implicit blank-padding for us,
3726 so we don't usually have to implement blank-padding ourselves.
3727 (The exception is when we pass an argument to a separately
3728 compiled statement function -- if we know the arg is not the
3729 same length as the dummy, we must truncate or extend it. If
3730 we "inline" statement functions, that necessity goes away as
3731 well.)
3733 Strip off the CONVERT operators that blank-pad. (Truncation by
3734 CONVERT shouldn't happen here, but it can happen in
3735 assignments.) */
3752 {
3753 left_tree
3756 left_tree);
3757 right_tree
3760 right_tree);
3762 item
3766 left_tree,
3767 integer_one_node),
3770 right_tree,
3771 integer_one_node));
3772 }
3773 else
3774 {
3778 left_length);
3783 item,
3785 integer_zero_node));
3786 }
3788 }
3794 /* Fall through. */
3797 }
3815 /* Fall through. */
3818 }
3820 #if 1
3822 #else
3824 {
3841 }
3844 #endif
3845 }
3847 #endif
3848 /* Returns the tree that does the intrinsic invocation.
3850 Note: this function applies only to intrinsics returning
3851 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3852 subroutines. */
3854 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3855 static tree
3858 {
3859 tree expr_tree;
3862 ffeinfoBasictype bt;
3863 ffeinfoKindtype kt;
3864 tree tree_type;
3865 tree arg1_type;
3867 tree tempvar;
3870 ffebld arg2;
3871 ffebld arg3;
3872 ffeintrinImp codegen_imp;
3873 ffecomGfrt gfrt;
3885 {
3890 {
3895 {
3899 }
3900 else
3902 }
3903 else
3905 }
3906 else
3909 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3910 args. This is used by the MAX/MIN expansions. */
3913 arg1_type = ffecom_tree_type
3916 else
3918 here. */
3920 /* There are several ways for each of the cases in the following switch
3921 statements to exit (from simplest to use to most complicated):
3923 break; (when expr_tree == NULL)
3925 A standard call is made to the specific intrinsic just as if it had been
3926 passed in as a dummy procedure and called as any old procedure. This
3927 method can produce slower code but in some cases it's the easiest way for
3928 now. However, if a (presumably faster) direct call is available,
3929 that is used, so this is the easiest way in many more cases now.
3931 gfrt = FFECOM_gfrtWHATEVER;
3932 break;
3934 gfrt contains the gfrt index of a library function to call, passing the
3935 argument(s) by value rather than by reference. Used when a more
3936 careful choice of library function is needed than that provided
3937 by the vanilla `break;'.
3939 return expr_tree;
3941 The expr_tree has been completely set up and is ready to be returned
3942 as is. No further actions are taken. Use this when the tree is not
3943 in the simple form for one of the arity_n labels. */
3945 /* For info on how the switch statement cases were written, see the files
3946 enclosed in comments below the switch statement. */
3954 {
3962 {
3968 }
3981 else
3984 return
3991 #if 0
3992 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
3995 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3997 return
4000 ffecom_truth_value
4002 saved_expr1,
4004 ffecom_float_zero_))),
4008 saved_expr1)),
4009 NULL_TREE),
4015 arg1_type,
4016 saved_expr1))),
4017 NULL_TREE)
4018 ))
4019 );
4020 #endif
4025 numbers of large magnitudes. */
4030 ffecom_truth_value
4032 integer_type_node,
4033 saved_expr1,
4034 ffecom_float_zero_)),
4036 tree_type,
4037 saved_expr1,
4038 ffecom_float_half_),
4040 tree_type,
4041 saved_expr1,
4042 ffecom_float_half_))));
4045 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4047 return
4050 ffecom_truth_value
4052 saved_expr1,
4054 ffecom_float_zero_))),
4059 arg1_type,
4060 saved_expr1,
4062 ffecom_float_half_)))),
4063 NULL_TREE),
4069 arg1_type,
4071 ffecom_float_half_),
4072 saved_expr1))),
4073 NULL_TREE))
4074 )
4075 );
4076 #endif
4088 #ifdef HOHO
4090 #else
4093 #endif
4094 {
4099 integer_one_node),
4101 }
4103 expr_tree,
4104 tempvar);
4107 expr_tree);
4113 return
4117 return
4124 return
4131 {
4132 tree arg1_tree;
4136 return
4141 }
4148 {
4153 }
4182 return
4184 ffecom_truth_value
4186 saved_expr1,
4187 saved_expr2)),
4189 saved_expr1,
4190 saved_expr2),
4194 return
4204 {
4209 }
4216 expr_tree
4219 expr_tree);
4220 expr_tree
4223 expr_tree,
4224 integer_one_node);
4229 saved_expr1,
4230 expr_tree,
4233 #endif
4239 #if 0
4241 #else
4243 #endif
4257 {
4262 }
4272 /* We used to call FFECOM_gfrtALOG10 here. */
4275 /* We used to call FFECOM_gfrtDLOG10 here. */
4287 else
4293 {
4298 expr_tree,
4301 }
4312 else
4318 {
4323 expr_tree,
4326 }
4338 /* We used to call FFECOM_gfrtAMOD here. */
4341 /* We used to call FFECOM_gfrtDMOD here. */
4347 #if 0
4348 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4350 #else
4351 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4353 return
4356 ffecom_truth_value
4358 saved_expr1,
4360 ffecom_float_zero_))),
4362 saved_expr1,
4364 ffecom_float_half_)),
4366 saved_expr1,
4368 ffecom_float_half_))));
4369 #endif
4374 {
4377 saved_expr1
4378 = ffecom_save_tree
4382 expr_tree
4384 ffecom_truth_value
4386 arg2_tree,
4388 integer_zero_node))),
4389 saved_expr1,
4391 /* Make sure SAVE_EXPRs get referenced early enough. */
4392 expr_tree
4395 expr_tree);
4396 }
4404 {
4409 }
4421 {
4426 }
4438 else
4441 return
4489 {
4490 ffetargetLogical1 target_true;
4491 ffetargetLogical1 target_false;
4492 tree true_tree;
4493 tree false_tree;
4499 else
4503 else
4506 return
4508 ffecom_truth_value
4514 integer_one_node),
4518 integer_zero_node))),
4519 false_tree,
4520 true_tree);
4521 }
4524 return
4530 integer_one_node),
4535 {
4538 tree uns_type
4541 expr_tree
4550 uns_type,
4552 integer_zero_node)),
4554 integer_type_node,
4556 arg3_tree))));
4557 /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE. */
4558 expr_tree
4560 ffecom_truth_value
4562 arg3_tree,
4563 integer_zero_node)),
4564 expr_tree,
4566 }
4570 return
4579 {
4583 tree uns_type
4586 expr_tree
4588 ffecom_truth_value
4590 arg2_tree,
4591 integer_zero_node)),
4593 arg1_tree,
4594 arg2_tree),
4599 integer_type_node,
4600 arg2_tree))));
4601 /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds. */
4602 expr_tree
4604 ffecom_truth_value
4607 integer_type_node,
4608 arg2_tree),
4610 expr_tree,
4612 /* Make sure SAVE_EXPRs get referenced early enough. */
4613 expr_tree
4618 expr_tree));
4619 }
4623 {
4629 tree shift_neg;
4630 tree shift_pos;
4631 tree mask_arg1;
4632 tree masked_arg1;
4633 tree uns_type
4636 mask_arg1
4640 arg3_tree);
4641 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4642 mask_arg1
4644 ffecom_truth_value
4646 arg3_tree,
4648 mask_arg1,
4651 masked_arg1
4653 arg1_tree,
4655 mask_arg1));
4657 shift_neg
4663 integer_type_node,
4664 arg2_tree))),
4666 arg1_tree,
4668 arg2_tree,
4669 arg3_tree)));
4670 shift_pos
4673 arg1_tree,
4674 arg2_tree),
4679 integer_type_node,
4680 arg3_tree,
4681 arg2_tree))));
4682 expr_tree
4684 ffecom_truth_value
4686 arg2_tree,
4687 integer_zero_node)),
4688 shift_neg,
4689 shift_pos);
4690 expr_tree
4693 mask_arg1,
4694 arg1_tree),
4697 mask_arg1),
4698 expr_tree));
4699 expr_tree
4701 ffecom_truth_value
4705 integer_type_node,
4706 arg2_tree),
4707 arg3_tree),
4709 arg2_tree,
4710 integer_zero_node))),
4711 arg1_tree,
4712 expr_tree);
4713 /* Make sure SAVE_EXPRs get referenced early enough. */
4714 expr_tree
4721 mask_arg1),
4724 masked_arg1),
4725 expr_tree))));
4726 expr_tree
4729 arg3_tree),
4730 expr_tree);
4731 }
4735 {
4738 expr_tree
4742 arg1_tree));
4743 }
4747 {
4748 tree arg1_tree;
4749 tree arg2_tree;
4750 tree arg3_tree;
4752 tree arg4_tree;
4753 tree arg4_type;
4755 tree arg5_tree;
4756 tree prep_arg1;
4757 tree prep_arg4;
4758 tree arg5_plus_arg3;
4773 prep_arg1
4777 arg1_tree,
4778 arg2_tree),
4782 arg4_type,
4783 convert
4785 integer_zero_node)),
4786 arg3_tree))),
4787 arg5_tree);
4788 arg5_plus_arg3
4790 arg5_tree,
4791 arg3_tree));
4792 prep_arg4
4796 integer_zero_node)),
4797 arg5_plus_arg3);
4798 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4799 prep_arg4
4801 ffecom_truth_value
4803 arg5_plus_arg3,
4806 prep_arg4,
4808 prep_arg4
4810 arg4_tree,
4812 prep_arg4,
4816 arg4_type,
4817 convert
4819 integer_zero_node)),
4820 arg5_tree))));
4821 prep_arg1
4823 prep_arg1,
4824 prep_arg4);
4825 /* Fix up (twice), because LSHIFT_EXPR above
4826 can't shift over TYPE_SIZE. */
4827 prep_arg1
4829 ffecom_truth_value
4831 arg3_tree,
4833 integer_zero_node))),
4834 prep_arg1,
4835 arg4_tree);
4836 prep_arg1
4838 ffecom_truth_value
4840 arg3_tree,
4843 prep_arg1,
4844 arg1_tree);
4845 expr_tree
4847 arg4_tree,
4848 prep_arg1);
4849 /* Make sure SAVE_EXPRs get referenced early enough. */
4850 expr_tree
4852 arg1_tree,
4854 arg3_tree,
4856 arg5_tree,
4858 arg5_plus_arg3,
4859 expr_tree))));
4860 expr_tree
4862 arg4_tree,
4863 expr_tree);
4865 }
4875 /* extern int xargc; i__1 = xargc - 1; */
4877 ffecom_tree_xargc_,
4879 integer_one_node));
4884 {
4885 tree arg1_tree;
4886 tree arg2_tree;
4887 tree arg3_tree;
4893 arg1_tree);
4895 /* Pass procedure as a pointer to it, anything else by value. */
4898 else
4901 arg2_tree);
4905 else
4912 expr_tree
4915 FALSE,
4917 NULL_TREE :
4918 tree_type),
4919 arg1_tree,
4924 expr_tree
4927 expr_tree));
4928 }
4932 {
4933 tree arg1_tree;
4934 tree arg2_tree;
4935 tree arg3_tree;
4941 arg1_tree);
4943 /* Pass procedure as a pointer to it, anything else by value. */
4946 else
4949 arg2_tree);
4953 else
4960 expr_tree
4963 FALSE,
4964 NULL_TREE,
4965 arg1_tree,
4970 expr_tree
4973 expr_tree));
4974 }
4985 {
4987 tree arg1_tree;
4988 tree arg2_tree;
4994 else
5001 expr_tree
5004 FALSE,
5005 NULL_TREE,
5006 arg1_tree,
5011 expr_tree
5014 expr_tree));
5015 }
5024 build_pointer_type
5026 integer_zero_node));
5028 return
5031 FALSE,
5032 void_type_node,
5033 expr_tree,
5040 else
5048 {
5050 tree arg1_tree;
5052 tree arg2_tree;
5053 tree arg3_tree;
5059 else
5071 FALSE,
5072 NULL_TREE,
5073 arg1_tree,
5079 expr_tree));
5080 }
5085 {
5087 tree arg1_tree;
5088 tree arg2_tree;
5089 tree arg3_tree;
5097 else
5107 FALSE,
5108 NULL_TREE,
5109 arg1_tree,
5115 expr_tree));
5116 }
5121 {
5122 tree arg1_tree;
5123 tree arg2_tree;
5125 tree arg3_tree;
5131 arg1_tree);
5136 else
5147 FALSE,
5148 NULL_TREE,
5149 arg1_tree,
5155 expr_tree));
5156 }
5160 {
5161 tree arg1_tree;
5162 tree arg2_tree;
5163 tree arg3_tree;
5169 arg1_tree);
5176 else
5184 FALSE,
5185 NULL_TREE,
5186 arg1_tree,
5192 expr_tree));
5193 }
5194 }
5198 {
5199 tree arg1_tree;
5200 tree arg2_tree;
5201 tree arg3_tree;
5207 arg1_tree);
5213 arg2_tree);
5217 else
5225 FALSE,
5226 NULL_TREE,
5227 arg1_tree,
5233 expr_tree));
5234 }
5235 }
5240 {
5242 tree arg1_tree;
5243 tree arg2_tree;
5248 ffecom_f2c_longint_type_node :
5249 ffecom_f2c_integer_type_node),
5253 arg2_tree);
5261 expr_tree
5264 FALSE,
5265 NULL_TREE,
5266 arg1_tree,
5270 }
5275 /* Arg defaults to 0 (normal random case) */
5276 {
5277 tree arg1_tree;
5281 else
5284 arg1_tree);
5287 arg1_tree);
5292 FALSE,
5294 ffecom_f2c_integer_type_node :
5295 ffecom_f2c_real_type_node),
5296 arg1_tree,
5300 }
5305 {
5306 tree arg1_tree;
5307 tree arg2_tree;
5313 arg1_tree);
5317 else
5322 FALSE,
5323 NULL_TREE,
5326 TRUE,
5331 expr_tree));
5332 }
5333 }
5338 {
5339 tree arg1_tree;
5343 expr_tree
5346 FALSE,
5347 NULL_TREE,
5348 NULL_TREE,
5352 expr_tree
5355 expr_tree));
5356 }
5361 {
5362 tree arg1_tree;
5363 tree result_tree;
5371 FALSE,
5372 NULL_TREE,
5375 TRUE,
5379 expr_tree));
5380 }
5383 /* Straightforward calls of libf2c routines: */
5460 }
5469 tree_type,
5474 /* See bottom of this file for f2c transforms used to determine
5475 many of the above implementations. The info seems to confuse
5476 Emacs's C mode indentation, which is why it's been moved to
5477 the bottom of this source file. */
5478 }
5480 #endif
5481 /* For power (exponentiation) where right-hand operand is type INTEGER,
5482 generate in-line code to do it the fast way (which, if the operand
5483 is a constant, might just mean a series of multiplies). */
5485 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5486 static tree
5488 {
5500 {
5508 {
5509 /* Reciprocal of integer is either 0, -1, or 1, so after
5510 calculating that (which we leave to the back end to do
5511 or not do optimally), don't bother with any multiplying. */
5515 l,
5518 rtype,
5519 r);
5522 result);
5523 }
5525 /* Generate appropriate series of multiplies, preceded
5526 by divide if the exponent is negative. */
5531 {
5534 l,
5544 r,
5545 integer_one_node));
5548 l,
5549 l);
5550 }
5551 }
5554 {
5556 {
5559 else
5561 result,
5562 l);
5563 }
5566 r,
5567 integer_one_node);
5574 l,
5575 l);
5576 }
5578 }
5580 /* Though rhs isn't a constant, in-line code cannot be expanded
5581 while transforming dummies
5582 because the back end cannot be easily convinced to generate
5583 stores (MODIFY_EXPR), handle temporaries, and so on before
5584 all the appropriate rtx's have been generated for things like
5585 dummy args referenced in rhs -- which doesn't happen until
5586 store_parm_decls() is called (expand_function_start, I believe,
5587 does the actual rtx-stuffing of PARM_DECLs).
5589 So, in this case, let the caller generate the call to the
5590 run-time-library function to evaluate the power for us. */
5595 /* Right-hand operand not a constant, expand in-line code to figure
5596 out how to do the multiplies, &c.
5598 The returned expression is expressed this way in GNU C, where l and
5599 r are the "inputs":
5601 ({ typeof (r) rtmp = r;
5602 typeof (l) ltmp = l;
5603 typeof (l) result;
5605 if (rtmp == 0)
5606 result = 1;
5607 else
5608 {
5609 if ((basetypeof (l) == basetypeof (int))
5610 && (rtmp < 0))
5611 {
5612 result = ((typeof (l)) 1) / ltmp;
5613 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5614 result = -result;
5615 }
5616 else
5617 {
5618 result = 1;
5619 if ((basetypeof (l) != basetypeof (int))
5620 && (rtmp < 0))
5621 {
5622 ltmp = ((typeof (l)) 1) / ltmp;
5623 rtmp = -rtmp;
5624 if (rtmp < 0)
5625 {
5626 rtmp = -(rtmp >> 1);
5627 ltmp *= ltmp;
5628 }
5629 }
5630 for (;;)
5631 {
5632 if (rtmp & 1)
5633 result *= ltmp;
5634 if ((rtmp >>= 1) == 0)
5635 break;
5636 ltmp *= ltmp;
5637 }
5638 }
5639 }
5640 result;
5641 })
5643 Note that some of the above is compile-time collapsable, such as
5644 the first part of the if statements that checks the base type of
5645 l against int. The if statements are phrased that way to suggest
5646 an easy way to generate the if/else constructs here, knowing that
5647 the back end should (and probably does) eliminate the resulting
5648 dead code (either the int case or the non-int case), something
5649 it couldn't do without the redundant phrasing, requiring explicit
5650 dead-code elimination here, which would be kind of difficult to
5651 read. */
5653 {
5654 tree rtmp;
5655 tree ltmp;
5656 tree divide;
5657 tree basetypeof_l_is_int;
5658 tree se;
5659 tree t;
5661 basetypeof_l_is_int
5668 #ifndef HAHA
5679 else
5682 {
5683 tree hook;
5696 else
5698 }
5702 rtmp,
5703 r));
5705 ltmp,
5706 l));
5709 rtmp,
5713 result,
5717 {
5719 rtmp,
5721 integer_zero_node)),
5724 result,
5725 ffecom_tree_divide_
5728 ltmp,
5730 divide)));
5734 ltmp,
5736 integer_zero_node)),
5739 rtype,
5741 rtype,
5742 rtmp),
5744 integer_one_node)),
5746 integer_zero_node)))),
5749 result,
5751 ltype,
5752 result)));
5755 }
5757 result,
5761 ffecom_truth_value_invert
5764 rtmp,
5766 integer_zero_node)))),
5769 ltmp,
5770 ffecom_tree_divide_
5773 ltmp,
5775 divide)));
5777 rtmp,
5779 rtmp)));
5782 rtmp,
5786 rtmp,
5789 rtype,
5790 rtmp,
5791 integer_one_node))));
5793 ltmp,
5795 ltmp,
5796 ltmp)));
5802 rtmp,
5806 result,
5808 result,
5809 ltmp)));
5812 ffecom_truth_value
5814 rtmp,
5816 rtype,
5817 rtmp,
5818 integer_one_node))));
5820 ltmp,
5822 ltmp,
5823 ltmp)));
5834 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5837 {
5838 /* Make a BIND_EXPR for the BLOCK already made. */
5841 /* Remove the block from the tree at this point.
5842 It gets put back at the proper place
5843 when the BIND_EXPR is expanded. */
5845 }
5846 else
5848 }
5851 }
5853 #endif
5854 /* ffecom_expr_transform_ -- Transform symbols in expr
5856 ffebld expr; // FFE expression.
5857 ffecom_expr_transform_ (expr);
5859 Recursive descent on expr while transforming any untransformed SYMTERs. */
5861 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5862 static void
5864 {
5865 tree t;
5866 ffesymbol s;
5874 {
5882 {
5885 DIMENSION expr? */
5886 }
5896 }
5899 {
5911 }
5914 }
5916 #endif
5917 /* Make a type based on info in live f2c.h file. */
5919 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5920 static void
5922 {
5924 {
5947 ? signed_char_type_node
5981 }
5986 }
5988 #endif
5989 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5990 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5991 given size. */
5993 static void
5996 {
5998 tree t;
6003 {
6007 }
6008 }
6010 #endif
6011 /* Finish up globals after doing all program units in file
6013 Need to handle only uninitialized COMMON areas. */
6015 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6016 static ffeglobal
6018 {
6019 tree cbtype;
6020 tree cbt;
6021 tree size;
6036 /* Give the array a size now. */
6044 integer_zero_node,
6045 size);
6056 }
6058 #endif
6059 /* Finish up any untransformed symbols. */
6061 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6062 static ffesymbol
6064 {
6068 /* It's easy to know to transform an untransformed symbol, to make sure
6069 we put out debugging info for it. But COMMON variables, unlike
6070 EQUIVALENCE ones, aren't given declarations in addition to the
6071 tree expressions that specify offsets, because COMMON variables
6072 can be referenced in the outer scope where only dummy arguments
6073 (PARM_DECLs) should really be seen. To be safe, just don't do any
6074 VAR_DECLs for COMMON variables when we transform them for real
6075 use, and therefore we do all the VAR_DECL creating here. */
6078 {
6083 /* Not transformed, and not CHARACTER*(*), and not a dummy
6084 argument, which can happen only if the entry point names
6085 it "rides in on" are all invalidated for other reasons. */
6087 }
6091 {
6092 /* This isn't working, at least for dbxout. The .s file looks
6093 okay to me (burley), but in gdb 4.9 at least, the variables
6094 appear to reside somewhere outside of the common area, so
6095 it doesn't make sense to mislead anyone by generating the info
6096 on those variables until this is fixed. NOTE: Same problem
6097 with EQUIVALENCE, sadly...see similar #if later. */
6100 }
6103 }
6105 #endif
6106 /* Append underscore(s) to name before calling get_identifier. "us"
6107 is nonzero if the name already contains an underscore and thus
6108 needs two underscores appended. */
6110 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6111 static tree
6113 {
6116 tree id;
6130 }
6132 #endif
6133 /* Decide whether to append underscore to name before calling
6134 get_identifier. */
6136 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6137 static tree
6139 {
6143 /* If name is a built-in name, just return it as is. */
6147 #if FFETARGET_isENFORCED_MAIN_NAME
6149 #else
6151 #endif
6160 }
6162 #endif
6163 /* Decide whether to append underscore to internal name before calling
6164 get_identifier.
6166 This is for non-external, top-function-context names only. Transform
6167 identifier so it doesn't conflict with the transformed result
6168 of using a _different_ external name. E.g. if "CALL FOO" is
6169 transformed into "FOO_();", then the variable in "FOO_ = 3"
6170 must be transformed into something that does not conflict, since
6171 these two things should be independent.
6173 The transformation is as follows. If the name does not contain
6174 an underscore, there is no possible conflict, so just return.
6175 If the name does contain an underscore, then transform it just
6176 like we transform an external identifier. */
6178 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6179 static tree
6181 {
6182 /* If name does not contain an underscore, just return it as is. */
6189 name);
6190 }
6192 #endif
6193 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6195 tree t;
6196 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6197 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6198 ffesymbol_kindtype(s));
6200 Call after setting up containing function and getting trees for all
6201 other symbols. */
6203 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6204 static tree
6206 {
6208 tree type;
6209 tree func;
6210 tree result;
6218 /* For now, we don't have a handy pointer to where the sfunc is actually
6219 defined, though that should be easy to add to an ffesymbol. (The
6220 token/where info available might well point to the place where the type
6221 of the sfunc is declared, especially if that precedes the place where
6222 the sfunc itself is defined, which is typically the case.) We should
6223 put out a null pointer rather than point somewhere wrong, but I want to
6224 see how it works at this point. */
6229 /* Pretransform the expression so any newly discovered things belong to the
6230 outer program unit, not to the statement function. */
6234 /* Make sure no recursive invocation of this fn (a specific case of failing
6235 to pretransform an sfunc's expression, i.e. where its expression
6236 references another untransformed sfunc) happens. */
6245 else
6246 {
6250 error. */
6251 }
6258 /* We don't worry about COMPLEX return values here, because this is
6259 entirely internal to our code, and gcc has the ability to return COMPLEX
6260 directly as a value. */
6264 tree type;
6276 }
6277 else
6287 {
6289 {
6291 tree result_length;
6302 }
6303 else
6304 {
6312 }
6313 }
6330 }
6332 #endif
6334 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6337 {
6339 }
6341 #endif
6342 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6343 static tree
6345 {
6352 }
6354 #endif
6355 /* Return initialize-to-zero expression for this VAR_DECL. */
6357 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6358 /* A somewhat evil way to prevent the garbage collector
6359 from collecting 'tree' structures. */
6360 #define NUM_TRACKED_CHUNK 63
6361 static struct tree_ggc_tracker
6362 {
6367 static void
6369 {
6376 {
6380 }
6381 }
6383 void
6385 {
6390 {
6393 }
6395 {
6396 /* Need to allocate a new block. */
6404 }
6405 }
6407 static tree
6409 {
6410 tree init;
6415 {
6418 }
6426 {
6430 }
6431 else
6432 {
6435 }
6438 }
6440 #endif
6441 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6442 static tree
6445 {
6446 tree expr_tree;
6447 tree length_tree;
6450 {
6453 (ffebld_constant_character1
6455 {
6458 }
6462 (ffebld_constant_character1
6476 {
6479 }
6482 {
6485 }
6487 expr_tree
6490 expr_tree);
6491 expr_tree
6494 expr_tree,
6495 integer_one_node);
6501 *maybe_tree
6502 = ffecom_truth_value
6504 length_tree,
6505 ffecom_f2c_ftnlen_zero_node));
6511 {
6514 }
6516 maybe_tree);
6519 {
6520 tree maybe_left;
6521 tree maybe_right;
6522 tree expr_left;
6523 tree expr_right;
6530 maybe_left,
6531 maybe_right);
6533 maybe_left,
6534 expr_left,
6535 expr_right);
6537 }
6542 }
6543 }
6545 #endif
6546 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6548 tree length_arg;
6549 ffebld expr;
6550 length_arg = ffecom_intrinsic_len_ (expr);
6552 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6553 subexpressions by constructing the appropriate tree for the
6554 length-of-character-text argument in a calling sequence. */
6556 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6557 static tree
6559 {
6560 ffetargetCharacter1 val;
6561 tree length;
6564 {
6572 {
6574 tree item;
6578 {
6581 }
6583 {
6586 else
6587 {
6590 }
6591 }
6596 }
6604 {
6605 ffebld start;
6606 ffebld end;
6608 tree start_tree;
6609 tree end_tree;
6623 {
6625 ;
6626 else
6627 {
6630 }
6631 }
6632 else
6633 {
6638 {
6641 }
6644 {
6646 ffecom_f2c_ftnlen_one_node,
6648 ffecom_f2c_ftnlen_type_node,
6649 length,
6650 start_tree));
6651 }
6652 else
6653 {
6658 {
6661 }
6664 ffecom_f2c_ftnlen_one_node,
6666 ffecom_f2c_ftnlen_type_node,
6668 }
6669 }
6670 }
6674 length
6690 }
6695 }
6697 #endif
6698 /* Handle CHARACTER assignments.
6700 Generates code to do the assignment. Used by ordinary assignment
6701 statement handler ffecom_let_stmt and by statement-function
6702 handler to generate code for a statement function. */
6704 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6705 static void
6708 {
6709 ffecomConcatList_ catlist;
6710 tree source_length;
6711 tree source_tree;
6712 tree expr_tree;
6721 /* Source might be an opCONVERT, which just means it is a different size
6722 than the destination. Since the underlying implementation here handles
6723 that (directly or via the s_copy or s_cat run-time-library functions),
6724 we don't need the "convenience" of an opCONVERT that tells us to
6725 truncate or blank-pad, particularly since the resulting implementation
6726 would probably be slower than otherwise. */
6733 {
6764 {
6765 dest_tree
6769 dest_tree);
6770 dest_tree
6774 dest_tree,
6775 integer_one_node);
6776 source_tree
6780 source_tree);
6781 source_tree
6785 source_tree,
6786 integer_one_node);
6793 }
6811 }
6813 /* Heavy-duty concatenation. */
6815 {
6818 tree lengths;
6819 tree items;
6820 tree length_array;
6821 tree item_array;
6822 tree citem;
6823 tree clength;
6825 #ifdef HOHO
6826 length_array
6827 = lengths
6831 FFETARGET_charactersizeNONE,
6833 #else
6834 {
6835 tree hook;
6843 }
6844 #endif
6847 {
6852 {
6855 }
6857 items
6862 item_array,
6864 citem),
6865 items);
6866 lengths
6871 length_array,
6873 clength),
6874 lengths);
6875 }
6882 items));
6887 lengths));
6889 = build_tree_list
6901 }
6904 }
6906 #endif
6907 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6909 ffecomGfrt ix;
6910 ffecom_make_gfrt_(ix);
6912 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6913 for the indicated run-time routine (ix). */
6915 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6916 static void
6918 {
6919 tree t;
6920 tree ttype;
6923 {
6988 }
6993 ttype);
6999 /* Sanity check: A function that's const cannot be volatile. */
7003 /* Sanity check: A function that's const cannot return complex. */
7012 }
7014 #endif
7015 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
7017 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7018 static void
7020 {
7025 }
7027 #endif
7028 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
7029 the member so debugger will see it. Otherwise nobody should be
7030 referencing the member. */
7032 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7033 static void
7035 {
7036 ffesymbol s;
7037 tree t;
7038 tree mt;
7039 tree type;
7058 type);
7075 }
7077 #endif
7078 /* Prepare source expression for assignment into a destination perhaps known
7079 to be of a specific size. */
7081 static void
7083 {
7084 ffecomConcatList_ catlist;
7087 tree ltmp;
7088 tree itmp;
7098 {
7099 ltmp
7102 itmp
7109 }
7117 {
7120 }
7121 }
7123 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7125 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
7126 (which generates their trees) and then their trees get push_parm_decl'd.
7128 The second arg is TRUE if the dummies are for a statement function, in
7129 which case lengths are not pushed for character arguments (since they are
7130 always known by both the caller and the callee, though the code allows
7131 for someday permitting CHAR*(*) stmtfunc dummies). */
7133 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7134 static void
7136 {
7137 ffebld dummy;
7138 ffebld dumlist;
7139 ffesymbol s;
7140 tree parm;
7144 /* First push the parms corresponding to actual dummy "contents". */
7147 {
7150 {
7157 }
7162 {
7166 }
7169 }
7171 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7174 {
7177 {
7181 NOTHING! */
7185 }
7191 length param. */
7198 }
7201 }
7203 #endif
7204 /* ffecom_start_progunit_ -- Beginning of program unit
7206 Does GNU back end stuff necessary to teach it about the start of its
7207 equivalent of a Fortran program unit. */
7209 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7210 static void
7212 {
7214 ffebld arglist;
7218 ffeinfoBasictype bt;
7219 ffeinfoKindtype kt;
7220 ffeglobal g;
7221 ffeglobalType gt;
7226 bool multi
7227 = altentries
7241 {
7267 {
7273 }
7283 else
7290 else
7305 else
7313 /* Fall through. */
7322 }
7325 {
7328 }
7329 #if FFETARGET_isENFORCED_MAIN
7332 #endif
7333 else
7337 type,
7347 {
7349 }
7351 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7352 exec-transitioning needs current_function_decl to be filled in. So we
7353 do these things in two phases. */
7357 ffecom_which_entrypoint_decl_
7361 integer_type_node);
7363 }
7366 || cmplxfunc
7369 tree type;
7370 tree length;
7376 else
7381 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7385 else
7394 else
7398 {
7401 }
7402 }
7405 {
7408 else
7411 }
7417 /* Disallow temp vars at this level. */
7423 /* This handles any symbols still untransformed, in case -g specified.
7424 This used to be done in ffecom_finish_progunit, but it turns out to
7425 be necessary to do it here so that statement functions are
7426 expanded before code. But don't bother for BLOCK DATA. */
7430 }
7432 #endif
7433 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7435 ffesymbol s;
7436 ffecom_sym_transform_(s);
7438 The ffesymbol_hook info for s is updated with appropriate backend info
7439 on the symbol. */
7441 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7442 static ffesymbol
7444 {
7448 ffeinfoBasictype bt;
7449 ffeinfoKindtype kt;
7450 ffeglobal g;
7454 /* Must ensure special ASSIGN variables are declared at top of outermost
7455 block, else they'll end up in the innermost block when their first
7456 ASSIGN is seen, which leaves them out of scope when they're the
7457 subject of a GOTO or I/O statement.
7459 We make this variable even if -fugly-assign. Just let it go unused,
7460 in case it turns out there are cases where we really want to use this
7461 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7469 {
7472 }
7473 else
7474 {
7479 }
7489 {
7492 {
7496 /* Before 0.4, this could be ENTITY/DUMMY, but see
7497 ffestu_sym_end_transition -- no longer true (in particular, if
7498 it could be an ENTITY, it _will_ be made one, so that
7499 possibility won't come through here). So we never make length
7500 arg for CHARACTER type. */
7504 ffecom_tree_ptr_to_subr_type);
7505 #if BUILT_FOR_270
7507 #endif
7520 {
7523 }
7546 /* Fall through. */
7549 }
7554 {
7557 /* ~~Debugging info needed? */
7565 {
7567 tree type;
7571 {
7574 }
7579 {
7582 }
7587 ffestorag est;
7588 tree et;
7589 ffetargetOffset offset;
7606 /* (t_type *) (((char *) &et) + offset) */
7611 et));
7613 t,
7616 t);
7620 }
7621 else
7622 {
7623 tree initexpr;
7628 type);
7632 #ifdef FFECOM_sizeMAXSTACKITEM
7635 #endif
7637 && (ffecom_primary_entry_kind_
7641 else
7647 /* Keep -Wunused from complaining about var if it
7648 is used as sfunc arg or DATA implied-DO. */
7655 {
7658 else
7660 }
7663 else
7669 {
7673 }
7674 }
7675 }
7683 it (& length). */
7688 }
7693 it. */
7697 }
7699 {
7702 }
7705 {
7708 ffecom_multi_retval_);
7713 }
7727 {
7728 tree type;
7729 ffebld dl;
7730 ffebld dim;
7731 tree low;
7732 tree high;
7733 tree old_sizes;
7738 {
7741 context; get it later. */
7743 }
7746 }
7747 else
7760 {
7768 else
7773 {
7774 /* Used to just do high=low. But for ffecom_tree_
7775 canonize_ref_, it probably is important to correctly
7776 assess the size. E.g. given COMPLEX C(*),CFUNC and
7777 C(2)=CFUNC(C), overlap can happen, while it can't
7778 for, say, C(1)=CFUNC(C(2)). */
7779 /* Even more recently used to set to INT_MAX, but that
7780 broke when some overflow checking went into the back
7781 end. Now we just leave the upper bound unspecified. */
7783 }
7784 else
7787 /* Determine whether array is conditionally adjustable,
7788 to decide whether back-end magic is needed.
7790 Normally the front end uses the back-end function
7791 variable_size to wrap SAVE_EXPR's around expressions
7792 affecting the size/shape of an array so that the
7793 size/shape info doesn't change during execution
7794 of the compiled code even though variables and
7795 functions referenced in those expressions might.
7797 variable_size also makes sure those saved expressions
7798 get evaluated immediately upon entry to the
7799 compiled procedure -- the front end normally doesn't
7800 have to worry about that.
7802 However, there is a problem with this that affects
7803 g77's implementation of entry points, and that is
7804 that it is _not_ true that each invocation of the
7805 compiled procedure is permitted to evaluate
7806 array size/shape info -- because it is possible
7807 that, for some invocations, that info is invalid (in
7808 which case it is "promised" -- i.e. a violation of
7809 the Fortran standard -- that the compiled code
7810 won't reference the array or its size/shape
7811 during that particular invocation).
7813 To phrase this in C terms, consider this gcc function:
7815 void foo (int *n, float (*a)[*n])
7816 {
7817 // a is "pointer to array ...", fyi.
7818 }
7820 Suppose that, for some invocations, it is permitted
7821 for a caller of foo to do this:
7823 foo (NULL, NULL);
7825 Now the _written_ code for foo can take such a call
7826 into account by either testing explicitly for whether
7827 (a == NULL) || (n == NULL) -- presumably it is
7828 not permitted to reference *a in various fashions
7829 if (n == NULL) I suppose -- or it can avoid it by
7830 looking at other info (other arguments, static/global
7831 data, etc.).
7833 However, this won't work in gcc 2.5.8 because it'll
7834 automatically emit the code to save the "*n"
7835 expression, which'll yield a NULL dereference for
7836 the "foo (NULL, NULL)" call, something the code
7837 for foo cannot prevent.
7839 g77 definitely needs to avoid executing such
7840 code anytime the pointer to the adjustable array
7841 is NULL, because even if its bounds expressions
7842 don't have any references to possible "absent"
7843 variables like "*n" -- say all variable references
7844 are to COMMON variables, i.e. global (though in C,
7845 local static could actually make sense) -- the
7846 expressions could yield other run-time problems
7847 for allowably "dead" values in those variables.
7849 For example, let's consider a more complicated
7850 version of foo:
7852 extern int i;
7853 extern int j;
7855 void foo (float (*a)[i/j])
7856 {
7857 ...
7858 }
7860 The above is (essentially) quite valid for Fortran
7861 but, again, for a call like "foo (NULL);", it is
7862 permitted for i and j to be undefined when the
7863 call is made. If j happened to be zero, for
7864 example, emitting the code to evaluate "i/j"
7865 could result in a run-time error.
7867 Offhand, though I don't have my F77 or F90
7868 standards handy, it might even be valid for a
7869 bounds expression to contain a function reference,
7870 in which case I doubt it is permitted for an
7871 implementation to invoke that function in the
7872 Fortran case involved here (invocation of an
7873 alternate ENTRY point that doesn't have the adjustable
7874 array as one of its arguments).
7876 So, the code that the compiler would normally emit
7877 to preevaluate the size/shape info for an
7878 adjustable array _must not_ be executed at run time
7879 in certain cases. Specifically, for Fortran,
7880 the case is when the pointer to the adjustable
7881 array == NULL. (For gnu-ish C, it might be nice
7882 for the source code itself to specify an expression
7883 that, if TRUE, inhibits execution of the code. Or
7884 reverse the sense for elegance.)
7886 (Note that g77 could use a different test than NULL,
7887 actually, since it happens to always pass an
7888 integer to the called function that specifies which
7889 entry point is being invoked. Hmm, this might
7890 solve the next problem.)
7892 One way a user could, I suppose, write "foo" so
7893 it works is to insert COND_EXPR's for the
7894 size/shape info so the dangerous stuff isn't
7895 actually done, as in:
7897 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7898 {
7899 ...
7900 }
7902 The next problem is that the front end needs to
7903 be able to tell the back end about the array's
7904 decl _before_ it tells it about the conditional
7905 expression to inhibit evaluation of size/shape info,
7906 as shown above.
7908 To solve this, the front end needs to be able
7909 to give the back end the expression to inhibit
7910 generation of the preevaluation code _after_
7911 it makes the decl for the adjustable array.
7913 Until then, the above example using the COND_EXPR
7914 doesn't pass muster with gcc because the "(a == NULL)"
7915 part has a reference to "a", which is still
7916 undefined at that point.
7918 g77 will therefore use a different mechanism in the
7919 meantime. */
7930 low,
7931 ffecom_integer_zero_node);
7936 high,
7937 ffecom_integer_zero_node);
7938 #endif
7940 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7941 probably. Fixes 950302-1.f. */
7946 /* ~~~Similarly, this fixes dumb0.f. The C front end
7947 does this, which is why dumb0.c would work. */
7952 type
7953 = build_array_type
7958 }
7961 {
7964 }
7968 {
7971 }
7974 #if BUILT_FOR_270
7976 #endif
7978 /* If this arg is present in every entry point's list of
7979 dummy args, then we're done. */
7985 #if 1
7987 /* If variable_size in stor-layout has been called during
7988 the above, then get_pending_sizes should have the
7989 yet-to-be-evaluated saved expressions pending.
7990 Make the whole lot of them get emitted, conditionally
7991 on whether the array decl ("t" above) is not NULL. */
7993 {
7995 tree tem;
8000 {
8005 else
8006 sizes
8009 temv,
8010 sizes);
8011 }
8014 {
8015 sizes
8019 integer_type_node,
8020 t,
8021 null_pointer_node),
8022 sizes,
8024 integer_zero_node));
8027 sizes
8029 }
8033 }
8035 #else
8036 #if 0
8042 t,
8043 null_pointer_node);
8044 #else
8045 #if 0
8049 {
8055 }
8056 #endif
8057 #endif
8058 #endif
8059 }
8063 {
8064 ffesymbol cs;
8065 ffeglobal cg;
8066 tree ct;
8068 tree type;
8072 {
8075 }
8083 else
8090 else
8091 {
8092 ffetargetOffset offset;
8093 ffestorag cst;
8104 /* (t_type *) (((char *) &ct) + offset) */
8109 ct));
8111 t,
8114 t);
8118 }
8119 }
8131 /* Fall through. */
8135 }
8140 {
8154 {
8157 }
8162 else
8167 t);
8189 else
8190 t = build_pointer_type
8195 t);
8196 #if BUILT_FOR_270
8198 #endif
8210 decls. */
8214 /* Fall through. */
8218 }
8223 {
8237 {
8240 }
8244 ffecom_tree_subr_type);
8265 ffecom_tree_ptr_to_subr_type);
8266 #if BUILT_FOR_270
8268 #endif
8275 decls. */
8279 /* Fall through. */
8283 }
8288 {
8307 /* Fall through. */
8311 }
8316 {
8327 ffecom_tree_blockdata_type);
8350 /* Fall through. */
8354 }
8359 {
8379 /* Fall through. */
8383 }
8388 {
8407 /* Fall through. */
8411 }
8416 {
8436 /* Fall through. */
8440 }
8445 /* Fall through. */
8449 }
8459 }
8461 #endif
8462 /* Transform into ASSIGNable symbol.
8464 Symbol has already been transformed, but for whatever reason, the
8465 resulting decl_tree has been deemed not usable for an ASSIGN target.
8466 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8467 another local symbol of type void * and stuff that in the assign_tree
8468 argument. The F77/F90 standards allow this implementation. */
8470 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8471 static ffesymbol
8473 {
8479 {
8482 }
8483 else
8484 {
8489 }
8499 {
8501 /* Unlike for regular vars, SAVE status is easy to determine for
8502 ASSIGNed vars, since there's no initialization, there's no
8503 effective storage association (so "SAVE J" does not apply to
8504 K even given "EQUIVALENCE (J,K)"), there's no size issue
8505 to worry about, etc. */
8510 else
8519 /* Note that twinning a DUMMY means the caller won't see
8520 the ASSIGNed value. But both F77 and F90 allow implementations
8521 to do this, i.e. disallow Fortran code that would try and
8522 take advantage of actually putting a label into a variable
8523 via a dummy argument (or any other storage association, for
8524 that matter). */
8531 }
8542 }
8544 #endif
8545 /* Implement COMMON area in back end.
8547 Because COMMON-based variables can be referenced in the dimension
8548 expressions of dummy (adjustable) arrays, and because dummies
8549 (in the gcc back end) need to be put in the outer binding level
8550 of a function (which has two binding levels, the outer holding
8551 the dummies and the inner holding the other vars), special care
8552 must be taken to handle COMMON areas.
8554 The current strategy is basically to always tell the back end about
8555 the COMMON area as a top-level external reference to just a block
8556 of storage of the master type of that area (e.g. integer, real,
8557 character, whatever -- not a structure). As a distinct action,
8558 if initial values are provided, tell the back end about the area
8559 as a top-level non-external (initialized) area and remember not to
8560 allow further initialization or expansion of the area. Meanwhile,
8561 if no initialization happens at all, tell the back end about
8562 the largest size we've seen declared so the space does get reserved.
8563 (This function doesn't handle all that stuff, but it does some
8564 of the important things.)
8566 Meanwhile, for COMMON variables themselves, just keep creating
8567 references like *((float *) (&common_area + offset)) each time
8568 we reference the variable. In other words, don't make a VAR_DECL
8569 or any kind of component reference (like we used to do before 0.4),
8570 though we might do that as well just for debugging purposes (and
8571 stuff the rtl with the appropriate offset expression). */
8573 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8574 static void
8576 {
8579 tree cbt;
8580 tree cbtype;
8581 tree init;
8582 tree high;
8591 /* First update the size of the area in global terms. */
8600 /* If we already have declared this common block for a previous program
8601 unit, and either we already initialized it or we don't have new
8602 initialization for it, just return what we have without changing it. */
8605 && (!is_init
8607 {
8610 }
8612 /* Process inits. */
8615 {
8617 {
8618 ffebld sexp;
8620 /* Set the padding for the expression, so ffecom_expr
8621 knows to insert that many zeros. */
8623 {
8639 }
8647 }
8648 }
8649 else
8651 }
8652 else
8655 /* cbtype must be permanently allocated! */
8657 /* Allocate the MAX of the areas so far, seen filewide. */
8665 integer_zero_node,
8666 high));
8667 else
8671 {
8672 cbt
8675 cbtype);
8678 }
8679 else
8680 {
8683 }
8693 /* Make sure that any type can live in COMMON and be referenced
8694 without getting a bus error. We could pick the most restrictive
8695 alignment of all entities actually placed in the COMMON, but
8696 this seems easy enough. */
8710 {
8716 }
8723 }
8725 #endif
8726 /* Make master area for local EQUIVALENCE. */
8728 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8729 static void
8731 {
8732 tree eqt;
8733 tree eqtype;
8734 tree init;
8735 tree high;
8745 /* Process inits. */
8748 {
8750 {
8751 ffebld sexp;
8753 /* Set the padding for the expression, so ffecom_expr
8754 knows to insert that many zeros. */
8756 {
8772 }
8777 }
8778 else
8780 }
8783 else
8789 eqst);
8797 ffecom_integer_zero_node,
8798 high));
8802 ffesymbol_text
8804 eqtype);
8807 || ffecom_member_namelisted_
8808 #ifdef FFECOM_sizeMAXSTACKITEM
8810 #endif
8815 else
8822 else
8827 /* Make sure that any type can live in EQUIVALENCE and be referenced
8828 without getting a bus error. We could pick the most restrictive
8829 alignment of all entities actually placed in the EQUIVALENCE, but
8830 this seems easy enough. */
8844 {
8849 }
8855 eqst);
8856 }
8858 #endif
8859 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8861 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8862 static tree
8864 {
8865 tree nmlt;
8867 tree nmlinits;
8868 tree nameinit;
8869 tree varsinit;
8870 tree nvarsinit;
8871 tree field;
8872 tree high;
8878 mynumber++),
8879 nmltype);
8885 /* Process inits. */
8895 = build_type_variant
8896 (build_array_type
8899 ffecom_f2c_ftnlen_one_node,
8900 high)),
8905 nameinit);
8909 varsinit);
8913 {
8914 ffebld b;
8918 }
8926 varsinit);
8939 }
8941 #endif
8943 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8944 analyzed on the assumption it is calculating a pointer to be
8945 indirected through. It must return the proper decl and offset,
8946 taking into account different units of measurements for offsets. */
8948 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8949 static void
8951 tree t)
8952 {
8954 {
8968 {
8969 /* An offset into COMMON. */
8972 /* Convert offset (presumably in bytes) into canonical units
8973 (presumably bits). */
8978 }
8979 /* Not a COMMON reference, so an unrecognized pattern. */
8990 {
8991 /* A reference to COMMON. */
8995 }
8996 /* Fall through. */
8998 /* Not a COMMON reference, so an unrecognized pattern. */
9001 }
9002 }
9003 #endif
9005 /* Given a tree that is possibly intended for use as an lvalue, return
9006 information representing a canonical view of that tree as a decl, an
9007 offset into that decl, and a size for the lvalue.
9009 If there's no applicable decl, NULL_TREE is returned for the decl,
9010 and the other fields are left undefined.
9012 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9013 is returned for the decl, and the other fields are left undefined.
9015 Otherwise, the decl returned currently is either a VAR_DECL or a
9016 PARM_DECL.
9018 The offset returned is always valid, but of course not necessarily
9019 a constant, and not necessarily converted into the appropriate
9020 type, leaving that up to the caller (so as to avoid that overhead
9021 if the decls being looked at are different anyway).
9023 If the size cannot be determined (e.g. an adjustable array),
9024 an ERROR_MARK node is returned for the size. Otherwise, the
9025 size returned is valid, not necessarily a constant, and not
9026 necessarily converted into the appropriate type as with the
9027 offset.
9029 Note that the offset and size expressions are expressed in the
9030 base storage units (usually bits) rather than in the units of
9031 the type of the decl, because two decls with different types
9032 might overlap but with apparently non-overlapping array offsets,
9033 whereas converting the array offsets to consistant offsets will
9034 reveal the overlap. */
9036 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9037 static void
9040 {
9041 /* The default path is to report a nonexistant decl. */
9048 {
9118 {
9121 tree init_offset;
9125 {
9128 }
9131 array);
9136 /* Calculate ((element - base) * NBBY) + init_offset. */
9138 element,
9150 }
9154 /* Most of this code is to handle references to COMMON. And so
9155 far that is useful only for calling library functions, since
9156 external (user) functions might reference common areas. But
9157 even calling an external function, it's worthwhile to decode
9158 COMMON references because if not storing into COMMON, we don't
9159 want COMMON-based arguments to gratuitously force use of a
9160 temporary. */
9186 }
9187 }
9188 #endif
9190 /* Do divide operation appropriate to type of operands. */
9192 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9193 static tree
9196 tree hook)
9197 {
9203 {
9206 left,
9207 right);
9212 left,
9213 right);
9214 {
9215 ffecomGfrt ix;
9220 else
9225 left);
9229 right);
9236 tree_type,
9237 left,
9240 }
9244 {
9245 ffecomGfrt ix;
9250 else
9255 left);
9259 right);
9266 tree_type,
9267 left,
9270 }
9275 left,
9276 right);
9277 }
9278 }
9280 #endif
9281 /* Build type info for non-dummy variable. */
9283 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9284 static tree
9286 ffeinfoKindtype kt)
9287 {
9288 tree type;
9289 ffebld dl;
9290 ffebld dim;
9291 tree lowt;
9292 tree hight;
9296 {
9300 type
9301 = build_array_type
9304 ffecom_f2c_ftnlen_one_node,
9305 hight));
9307 }
9310 {
9319 else
9335 }
9338 }
9340 #endif
9341 /* Build Namelist type. */
9343 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9344 static tree
9346 {
9350 {
9352 tree vardesctype;
9361 string_type_node);
9364 integer_type_node);
9370 }
9373 }
9375 #endif
9377 /* Build Vardesc type. */
9379 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9380 static tree
9382 {
9387 {
9391 string_type_node);
9393 string_type_node);
9395 ffecom_f2c_ptr_to_ftnlen_type_node);
9397 integer_type_node);
9403 }
9406 }
9408 #endif
9410 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9411 static tree
9413 {
9414 ffesymbol s;
9420 {
9423 tree var;
9424 tree nameinit;
9425 tree dimsinit;
9426 tree addrinit;
9427 tree typeinit;
9428 tree field;
9429 tree varinits;
9434 mynumber++),
9435 vardesctype);
9441 /* Process inits. */
9447 = build_type_variant
9448 (build_array_type
9451 integer_one_node,
9458 nameinit);
9465 {
9472 }
9473 else
9477 nameinit);
9479 addrinit);
9494 }
9497 }
9499 #endif
9500 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9501 static tree
9503 {
9504 ffebld b;
9505 tree list;
9507 tree var;
9514 {
9515 tree t;
9521 else
9522 {
9525 }
9526 }
9530 integer_one_node,
9544 }
9546 #endif
9547 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9548 static tree
9550 {
9553 integer_zero_node);
9555 {
9556 ffebld b;
9557 ffebld e;
9558 tree list;
9559 tree backlist;
9561 tree var;
9562 tree numdim;
9563 tree numelem;
9578 {
9579 tree t;
9580 tree low;
9581 tree back;
9585 else
9586 {
9592 else
9593 {
9596 }
9597 }
9601 else
9608 }
9611 {
9614 else
9618 ffecom_f2c_ftnlen_type_node,
9620 baseoff));
9621 }
9623 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9636 integer_zero_node,
9637 build_int_2
9654 }
9655 }
9657 #endif
9658 /* Essentially does a "fold (build1 (code, type, node))" while checking
9659 for certain housekeeping things.
9661 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9662 ffecom_1_fn instead. */
9664 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9665 tree
9667 {
9668 tree item;
9675 {
9678 }
9681 {
9682 tree realtype;
9695 {
9698 }
9701 item =
9705 node)),
9708 node)));
9714 }
9721 }
9722 #endif
9724 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9725 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9726 does not set TREE_ADDRESSABLE (because calling an inline
9727 function does not mean the function needs to be separately
9728 compiled). */
9730 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9731 tree
9733 {
9734 tree item;
9735 tree type;
9750 }
9751 #endif
9753 /* Essentially does a "fold (build (code, type, node1, node2))" while
9754 checking for certain housekeeping things. */
9756 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9757 tree
9759 tree node2)
9760 {
9761 tree item;
9769 {
9784 {
9787 }
9791 item =
9795 node1),
9797 node2)),
9800 node1),
9802 node2)));
9807 {
9810 }
9814 item =
9818 node1),
9820 node2)),
9823 node1),
9825 node2)));
9830 {
9833 }
9838 node1));
9840 node1));
9842 node2));
9844 node2));
9845 item =
9849 a,
9850 c),
9852 b,
9853 d)),
9856 a,
9857 d),
9859 c,
9860 b)));
9866 {
9869 }
9875 item =
9879 node1),
9881 node2)),
9884 node1),
9886 node2)));
9892 {
9895 }
9901 item =
9905 node1),
9907 node2)),
9910 node1),
9912 node2)));
9918 }
9923 }
9925 #endif
9926 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9928 ffesymbol s; // the ENTRY point itself
9929 if (ffecom_2pass_advise_entrypoint(s))
9930 // the ENTRY point has been accepted
9932 Does whatever compiler needs to do when it learns about the entrypoint,
9933 like determine the return type of the master function, count the
9934 number of entrypoints, etc. Returns FALSE if the return type is
9935 not compatible with the return type(s) of other entrypoint(s).
9937 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9938 later (after _finish_progunit) be called with the same entrypoint(s)
9939 as passed to this fn for which TRUE was returned.
9941 03-Jan-92 JCB 2.0
9942 Return FALSE if the return type conflicts with previous entrypoints. */
9944 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9945 bool
9947 {
9961 arglist's dummies. */
9971 {
9978 else
9981 }
9982 }
9984 /* If necessary, scan entry arglist for alternate returns. Do this scan
9985 apparently redundantly (it's done below to UNIONize the arglists) so
9986 that we don't complain about RETURN 1 if an offending ENTRY is the only
9987 one with an alternate return. */
9990 {
9994 {
9997 {
10000 }
10001 }
10002 }
10004 /* Now check type compatibility. */
10007 {
10013 ok
10024 {
10027 }
10030 {
10033 }
10035 }
10038 {
10043 }
10045 /* Entrypoint type compatible with previous types. */
10049 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10054 {
10063 appending of arg. */
10066 }
10070 /* Append this arg to the master list. */
10075 else
10077 }
10080 }
10082 #endif
10083 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10085 ffesymbol s; // the ENTRY point itself
10086 ffecom_2pass_do_entrypoint(s);
10088 Does whatever compiler needs to do to make the entrypoint actually
10089 happen. Must be called for each entrypoint after
10090 ffecom_finish_progunit is called. */
10092 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10093 void
10095 {
10104 }
10105 else
10111 }
10113 #endif
10115 /* Essentially does a "fold (build (code, type, node1, node2))" while
10116 checking for certain housekeeping things. Always sets
10117 TREE_SIDE_EFFECTS. */
10119 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10120 tree
10122 tree node2)
10123 {
10124 tree item;
10134 }
10136 #endif
10137 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10138 checking for certain housekeeping things. */
10140 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10141 tree
10144 {
10145 tree item;
10158 }
10160 #endif
10161 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10162 checking for certain housekeeping things. Always sets
10163 TREE_SIDE_EFFECTS. */
10165 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10166 tree
10169 {
10170 tree item;
10181 }
10183 #endif
10185 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10187 See use by ffecom_list_expr.
10189 If expression is NULL, returns an integer zero tree. If it is not
10190 a CHARACTER expression, returns whatever ffecom_expr
10191 returns and sets the length return value to NULL_TREE. Otherwise
10192 generates code to evaluate the character expression, returns the proper
10193 pointer to the result, but does NOT set the length return value to a tree
10194 that specifies the length of the result. (In other words, the length
10195 variable is always set to NULL_TREE, because a length is never passed.)
10197 21-Dec-91 JCB 1.1
10198 Don't set returned length, since nobody needs it (yet; someday if
10199 we allow CHARACTER*(*) dummies to statement functions, we'll need
10200 it). */
10202 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10203 tree
10205 {
10206 tree ign;
10217 }
10219 #endif
10220 /* Transform expression into constant argument-pointer-to-expression tree.
10222 If the expression can be transformed into a argument-pointer-to-expression
10223 tree that is constant, that is done, and the tree returned. Else
10224 NULL_TREE is returned.
10226 That way, a caller can attempt to provide compile-time initialization
10227 of a variable and, if that fails, *then* choose to start a new block
10228 and resort to using temporaries, as appropriate. */
10230 tree
10232 {
10237 {
10241 }
10248 {
10249 tree t;
10255 }
10263 }
10265 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10267 See use by ffecom_list_ptr_to_expr.
10269 If expression is NULL, returns an integer zero tree. If it is not
10270 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10271 returns and sets the length return value to NULL_TREE. Otherwise
10272 generates code to evaluate the character expression, returns the proper
10273 pointer to the result, AND sets the length return value to a tree that
10274 specifies the length of the result.
10276 If the length argument is NULL, this is a slightly special
10277 case of building a FORMAT expression, that is, an expression that
10278 will be used at run time without regard to length. For the current
10279 implementation, which uses the libf2c library, this means it is nice
10280 to append a null byte to the end of the expression, where feasible,
10281 to make sure any diagnostic about the FORMAT string terminates at
10282 some useful point.
10284 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10285 length argument. This might even be seen as a feature, if a null
10286 byte can always be appended. */
10288 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10289 tree
10291 {
10292 tree item;
10293 tree ign_length;
10294 ffecomConcatList_ catlist;
10303 {
10307 {
10308 tree temp_exp;
10309 tree temp_length;
10316 temp_exp);
10317 }
10323 {
10326 }
10332 {
10333 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10335 #endif
10344 }
10349 }
10351 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10355 ffetargetHollerith h;
10360 *length
10363 }
10364 #endif
10377 {
10380 {
10383 }
10391 else
10400 }
10402 {
10405 tree lengths;
10406 tree items;
10407 tree length_array;
10408 tree item_array;
10409 tree citem;
10410 tree clength;
10411 tree temporary;
10412 tree num;
10413 tree known_length;
10414 ffetargetCharacterSize sz;
10417 /* ~~Kludge! */
10420 #ifdef HOHO
10421 length_array
10422 = lengths
10425 item_array
10426 = items
10431 #else
10432 {
10433 tree hook;
10442 }
10443 #endif
10448 {
10453 else
10458 {
10462 }
10464 items
10469 item_array,
10471 citem),
10472 items);
10475 known_length
10477 known_length,
10478 clength);
10479 lengths
10484 length_array,
10486 clength),
10487 lengths);
10488 }
10492 temporary);
10499 items));
10504 lengths));
10506 = build_tree_list
10519 item,
10520 temporary);
10524 }
10529 }
10531 #endif
10532 /* Generate call to run-time function.
10534 The first arg is the GNU Fortran Run-Time function index, the second
10535 arg is the list of arguments to pass to it. Returned is the expression
10536 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10537 result (which may be void). */
10539 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10540 tree
10542 {
10548 }
10549 #endif
10551 /* Transform constant-union to tree. */
10553 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10554 tree
10557 {
10558 tree item;
10561 {
10563 {
10567 {
10568 #if FFETARGET_okINTEGER1
10572 #endif
10574 #if FFETARGET_okINTEGER2
10578 #endif
10580 #if FFETARGET_okINTEGER3
10584 #endif
10586 #if FFETARGET_okINTEGER4
10590 #endif
10594 /* Fall through. */
10597 }
10600 }
10604 {
10608 {
10609 #if FFETARGET_okLOGICAL1
10613 #endif
10615 #if FFETARGET_okLOGICAL2
10619 #endif
10621 #if FFETARGET_okLOGICAL3
10625 #endif
10627 #if FFETARGET_okLOGICAL4
10631 #endif
10635 /* Fall through. */
10638 }
10641 }
10645 {
10646 REAL_VALUE_TYPE val;
10649 {
10650 #if FFETARGET_okREAL1
10654 #endif
10656 #if FFETARGET_okREAL2
10660 #endif
10662 #if FFETARGET_okREAL3
10666 #endif
10668 #if FFETARGET_okREAL4
10672 #endif
10676 /* Fall through. */
10679 }
10681 }
10685 {
10686 REAL_VALUE_TYPE real;
10687 REAL_VALUE_TYPE imag;
10691 {
10692 #if FFETARGET_okCOMPLEX1
10697 #endif
10699 #if FFETARGET_okCOMPLEX2
10704 #endif
10706 #if FFETARGET_okCOMPLEX3
10711 #endif
10713 #if FFETARGET_okCOMPLEX4
10718 #endif
10722 /* Fall through. */
10725 }
10729 }
10734 ffetargetCharacter1 val;
10737 {
10738 #if FFETARGET_okCHARACTER1
10742 #endif
10746 /* Fall through. */
10749 }
10754 build_range_type
10756 integer_one_node,
10757 build_int_2
10758 (ffetarget_length_character1
10761 }
10765 {
10766 ffetargetHollerith h;
10770 /* If not at least as wide as default INTEGER, widen it. */
10773 else
10774 {
10779 FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10782 str);
10783 }
10786 build_range_type
10788 integer_one_node,
10789 build_int_2
10792 }
10796 {
10797 ffetargetInteger1 ival;
10798 ffetargetTypeless tless;
10799 ffebad error;
10806 }
10811 /* Fall through. */
10814 }
10819 }
10821 #endif
10823 /* Transform expression into constant tree.
10825 If the expression can be transformed into a tree that is constant,
10826 that is done, and the tree returned. Else NULL_TREE is returned.
10828 That way, a caller can attempt to provide compile-time initialization
10829 of a variable and, if that fails, *then* choose to start a new block
10830 and resort to using temporaries, as appropriate. */
10832 tree
10834 {
10843 #if NEWCOMMON
10844 /* ~~Enable once common/equivalence is handled properly? */
10846 #endif
10849 {
10850 tree t;
10855 }
10858 }
10860 /* Handy way to make a field in a struct/union. */
10862 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10863 tree
10866 {
10867 tree field;
10877 }
10879 #endif
10881 void
10883 {
10884 #if FFECOM_GCC_INCLUDE
10886 #endif
10887 }
10889 int
10891 {
10892 #if FFECOM_GCC_INCLUDE
10894 #else
10896 #endif
10897 }
10899 /* End a compound statement (block). */
10901 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10902 tree
10904 {
10906 }
10909 /* ffecom_end_transition -- Perform end transition on all symbols
10911 ffecom_end_transition();
10913 Calls ffecom_sym_end_transition for each global and local symbol. */
10915 void
10917 {
10918 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10919 ffebld item;
10920 #endif
10925 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10928 #endif
10932 {
10934 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10936 #endif
10937 }
10939 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10945 {
10946 ffebld callee;
10947 ffesymbol s;
10948 tree dt;
10949 tree t;
10950 tree var;
10957 {
10960 }
10966 number++),
10967 dt);
10979 }
10981 /* This handles any COMMON areas that weren't referenced but have, for
10982 example, important initial data. */
10990 #endif
10991 }
10993 /* ffecom_exec_transition -- Perform exec transition on all symbols
10995 ffecom_exec_transition();
10997 Calls ffecom_sym_exec_transition for each global and local symbol.
10998 Make sure error updating not inhibited. */
11000 void
11002 {
11014 {
11016 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11018 #endif
11019 }
11023 }
11025 /* Handle assignment statement.
11027 Convert dest and source using ffecom_expr, then join them
11028 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
11030 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11031 void
11033 {
11034 tree dest_tree;
11035 tree dest_length;
11036 tree source_tree;
11037 tree expr_tree;
11040 {
11042 tree assign_temp;
11044 /* This attempts to replicate the test below, but must not be
11045 true when the test below is false. (Always err on the side
11046 of creating unused temporaries, to avoid ICEs.) */
11051 {
11054 }
11055 else
11056 {
11059 }
11063 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11064 create a temporary through which the assignment is to take place,
11065 since MODIFY_EXPR doesn't handle partial overlap properly. */
11068 {
11070 ffecom_tree_type
11073 FFETARGET_charactersizeNONE,
11075 }
11076 else
11089 else
11090 {
11094 }
11101 {
11102 #ifdef MOVE_EXPR
11103 /* The back end understands a conceptual move (evaluate source;
11104 store into dest), so use that, in case it can determine
11105 that it is going to use, say, two registers as temporaries
11106 anyway. So don't use the temp (and someday avoid generating
11107 it, once this code starts triggering regularly). */
11109 dest_tree,
11110 source_tree);
11111 #else
11113 assign_temp,
11114 source_tree);
11117 dest_tree,
11118 assign_temp);
11119 #endif
11120 }
11121 else
11123 dest_tree,
11124 source_tree);
11128 }
11137 source);
11138 }
11140 #endif
11141 /* ffecom_expr -- Transform expr into gcc tree
11143 tree t;
11144 ffebld expr; // FFE expression.
11145 tree = ffecom_expr(expr);
11147 Recursive descent on expr while making corresponding tree nodes and
11148 attaching type info and such. */
11150 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11151 tree
11153 {
11155 }
11157 #endif
11158 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
11160 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11161 tree
11163 {
11165 }
11167 #endif
11168 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
11170 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11171 tree
11173 {
11175 }
11177 #endif
11178 /* Transform expr for use as into read/write tree and stabilize the
11179 reference. Not for use on CHARACTER expressions.
11181 Recursive descent on expr while making corresponding tree nodes and
11182 attaching type info and such. */
11184 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11185 tree
11187 {
11189 /* Different target types not yet supported. */
11193 }
11195 #endif
11196 /* Transform expr for use as into write tree and stabilize the
11197 reference. Not for use on CHARACTER expressions.
11199 Recursive descent on expr while making corresponding tree nodes and
11200 attaching type info and such. */
11202 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11203 tree
11205 {
11207 /* Different target types not yet supported. */
11211 }
11213 #endif
11214 /* Do global stuff. */
11216 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11217 void
11219 {
11224 }
11226 #endif
11227 /* Public entry point for front end to access finish_decl. */
11229 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11230 void
11232 {
11235 }
11237 #endif
11238 /* Finish a program unit. */
11240 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11241 void
11243 {
11250 }
11252 #endif
11254 /* Wrapper for get_identifier. pattern is sprintf-like. */
11256 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11257 tree
11259 {
11260 tree decl;
11272 }
11274 ffeinfoBasictype
11276 {
11280 {
11318 }
11319 }
11321 ffeinfoKindtype
11323 {
11327 {
11365 }
11366 }
11368 void
11370 {
11371 tree endlink;
11374 tree t;
11375 tree field;
11376 ffetype type;
11377 ffetype base_type;
11378 tree double_ftype_double;
11379 tree float_ftype_float;
11380 tree ldouble_ftype_ldouble;
11381 tree ffecom_tree_ptr_to_fun_type_void;
11383 /* This block of code comes from the now-obsolete cktyps.c. It checks
11384 whether the compiler environment is buggy in known ways, some of which
11385 would, if not explicitly checked here, result in subtle bugs in g77. */
11388 {
11390 =
11399 {
11403 }
11407 {
11411 }
11415 {
11419 }
11420 }
11422 #if FFECOM_GCC_INCLUDE
11424 #endif
11431 /* Make the binding_level structure for global names. */
11438 /* Define `int' and `char' first so that dbx will output them first. */
11440 integer_type_node));
11441 /* CHARACTER*1 is unsigned in ICHAR contexts. */
11444 char_type_node));
11446 long_integer_type_node));
11448 unsigned_type_node));
11450 long_unsigned_type_node));
11452 long_long_integer_type_node));
11454 long_long_unsigned_type_node));
11456 short_integer_type_node));
11458 short_unsigned_type_node));
11460 /* Set the sizetype before we make other types. This *should* be the
11461 first type we create. */
11463 set_sizetype
11465 ffecom_typesize_pointer_
11470 /* Define both `signed char' and `unsigned char'. */
11472 signed_char_type_node));
11475 unsigned_char_type_node));
11478 float_type_node));
11480 double_type_node));
11482 long_double_type_node));
11484 /* For now, override what build_common_tree_nodes has done. */
11488 complex_long_double_type_node
11492 complex_integer_type_node));
11494 complex_float_type_node));
11496 complex_double_type_node));
11498 complex_long_double_type_node));
11501 void_type_node));
11502 /* We are not going to have real types in C with less than byte alignment,
11503 so we might as well not have any types that claim to have it. */
11509 ffecom_tree_fun_type_void
11512 ffecom_tree_ptr_to_fun_type_void
11517 float_ftype_float
11521 double_ftype_double
11525 ldouble_ftype_ldouble
11528 endlink));
11532 {
11537 }
11539 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11540 to size FLOAT_TYPE_SIZE because they have to be the same size as
11541 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11542 Compiler options and other such stuff that change the ways these
11543 types are set should not affect this particular setup. */
11548 t));
11552 type);
11558 type);
11566 t));
11571 t));
11574 type);
11580 type);
11587 t));
11592 t));
11595 type);
11601 type);
11608 t));
11613 t));
11616 type);
11622 type);
11629 t));
11631 #if 0
11637 {
11639 LONG_TYPE_SIZE);
11640 }
11641 #endif
11646 t));
11650 type);
11656 type);
11663 t));
11666 type);
11672 type);
11679 t));
11682 type);
11688 type);
11695 t));
11698 type);
11704 type);
11712 t));
11717 type);
11723 type);
11733 t));
11737 type);
11743 type);
11750 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11752 t));
11756 type);
11762 type);
11769 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11771 t));
11774 type);
11780 type);
11782 type);
11787 /* Make function and ptr-to-function types for non-CHARACTER types. */
11791 {
11793 {
11795 {
11796 /* Figure out the smallest INTEGER type that can hold
11797 a pointer on this machine. */
11800 {
11805 }
11806 }
11809 /* For f2c compatibility, REAL functions are really
11810 implemented as DOUBLE PRECISION. */
11813 t = ffecom_tree_type
11817 NULL_TREE);
11819 }
11820 }
11822 /* Set up pointer types. */
11829 FFEINFO_kindtypeINTEGERDEFAULT),
11832 ffecom_pointer_kind_));
11836 else
11841 ffecom_integer_type_node
11844 integer_zero_node);
11846 integer_one_node);
11848 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11849 Turns out that by TYLONG, runtime/libI77/lio.h really means
11850 "whatever size an ftnint is". For consistency and sanity,
11851 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11852 all are INTEGER, which we also make out of whatever back-end
11853 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11854 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11855 accommodate machines like the Alpha. Note that this suggests
11856 f2c and libf2c are missing a distinction perhaps needed on
11857 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11860 FFETARGET_f2cTYLONG);
11862 FFETARGET_f2cTYSHORT);
11864 FFETARGET_f2cTYINT1);
11866 FFETARGET_f2cTYQUAD);
11868 FFETARGET_f2cTYLOGICAL);
11870 FFETARGET_f2cTYLOGICAL2);
11872 FFETARGET_f2cTYLOGICAL1);
11873 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11875 FFETARGET_f2cTYQUAD);
11877 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11878 loop. CHARACTER items are built as arrays of unsigned char. */
11885 FFEINFO_kindtypeCHARACTER1,
11886 type);
11905 /* Make multi-return-value type and fields. */
11913 {
11930 }
11935 /* Subroutines usually return integer because they might have alternate
11936 returns. */
11938 ffecom_tree_subr_type
11940 ffecom_tree_ptr_to_subr_type
11942 ffecom_tree_blockdata_type
11964 #if BUILT_FOR_270
11966 #endif
11969 FFECOM_f2cINTEGER,
11972 FFECOM_f2cADDRESS,
11975 FFECOM_f2cREAL,
11978 FFECOM_f2cDOUBLEREAL,
11981 FFECOM_f2cCOMPLEX,
11984 FFECOM_f2cDOUBLECOMPLEX,
11987 FFECOM_f2cLONGINT,
11990 FFECOM_f2cLOGICAL,
11993 FFECOM_f2cFLAG,
11996 FFECOM_f2cFTNLEN,
11999 FFECOM_f2cFTNINT,
12002 ffecom_f2c_ftnlen_zero_node
12005 ffecom_f2c_ftnlen_one_node
12011 ffecom_f2c_ptr_to_ftnlen_type_node
12014 ffecom_f2c_ptr_to_ftnint_type_node
12017 ffecom_f2c_ptr_to_integer_type_node
12020 ffecom_f2c_ptr_to_real_type_node
12025 {
12026 REAL_VALUE_TYPE point_5;
12028 #ifdef REAL_ARITHMETIC
12030 #else
12032 #endif
12035 }
12037 /* Do "extern int xargc;". */
12041 integer_type_node);
12051 {
12059 }
12060 #endif
12065 /* I/O will probably crash. */
12069 #endif
12074 /* ASSIGN 10 TO I will crash. */
12079 #endif
12080 }
12082 #endif
12083 /* ffecom_init_2 -- Initialize
12085 ffecom_init_2(); */
12087 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12088 void
12090 {
12101 }
12103 #endif
12104 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12106 tree t;
12107 ffebld expr; // FFE opITEM list.
12108 tree = ffecom_list_expr(expr);
12110 List of actual args is transformed into corresponding gcc backend list. */
12112 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12113 tree
12115 {
12116 tree list;
12120 tree length;
12123 {
12133 {
12136 }
12137 }
12142 }
12144 #endif
12145 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12147 tree t;
12148 ffebld expr; // FFE opITEM list.
12149 tree = ffecom_list_ptr_to_expr(expr);
12151 List of actual args is transformed into corresponding gcc backend list for
12152 use in calling an external procedure (vs. a statement function). */
12154 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12155 tree
12157 {
12158 tree list;
12162 tree length;
12165 {
12175 {
12178 }
12179 }
12184 }
12186 #endif
12187 /* Obtain gcc's LABEL_DECL tree for label. */
12189 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12190 tree
12192 {
12193 tree glabel;
12196 {
12200 {
12206 void_type_node);
12213 ffecom_get_invented_identifier
12217 NULL_TREE),
12238 }
12240 }
12241 else
12242 {
12244 }
12247 }
12249 #endif
12250 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12251 a single source specification (as in the fourth argument of MVBITS).
12252 If the type is NULL_TREE, the type of lhs is used to make the type of
12253 the MODIFY_EXPR. */
12255 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12256 tree
12258 tree rhs)
12259 {
12270 }
12272 #endif
12274 /* Register source file name. */
12276 void
12278 {
12279 #if FFECOM_GCC_INCLUDE
12281 #endif
12282 }
12284 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12286 ffestorag st;
12287 ffecom_notify_init_storage(st);
12289 Gets called when all possible units in an aggregate storage area (a LOCAL
12290 with equivalences or a COMMON) have been initialized. The initialization
12291 info either is in ffestorag_init or, if that is NULL,
12292 ffestorag_accretion:
12294 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12295 even for an array if the array is one element in length!
12297 ffestorag_accretion will contain an opACCTER. It is much like an
12298 opARRTER except it has an ffebit object in it instead of just a size.
12299 The back end can use the info in the ffebit object, if it wants, to
12300 reduce the amount of actual initialization, but in any case it should
12301 kill the ffebit object when done. Also, set accretion to NULL but
12302 init to a non-NULL value.
12304 After performing initialization, DO NOT set init to NULL, because that'll
12305 tell the front end it is ok for more initialization to happen. Instead,
12306 set init to an opANY expression or some such thing that you can use to
12307 tell that you've already initialized the object.
12309 27-Oct-91 JCB 1.1
12310 Support two-pass FFE. */
12312 void
12314 {
12316 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12319 #endif
12322 {
12328 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12329 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12337 #endif
12339 #if FFECOM_TWOPASS
12341 #endif
12342 }
12343 #if FFECOM_ONEPASS
12344 else
12346 #endif
12354 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12355 {
12356 ffesymbol s;
12360 else
12367 }
12368 #endif
12371 }
12373 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12375 ffesymbol s;
12376 ffecom_notify_init_symbol(s);
12378 Gets called when all possible units in a symbol (not placed in COMMON
12379 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12380 have been initialized. The initialization info either is in
12381 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12383 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12384 even for an array if the array is one element in length!
12386 ffesymbol_accretion will contain an opACCTER. It is much like an
12387 opARRTER except it has an ffebit object in it instead of just a size.
12388 The back end can use the info in the ffebit object, if it wants, to
12389 reduce the amount of actual initialization, but in any case it should
12390 kill the ffebit object when done. Also, set accretion to NULL but
12391 init to a non-NULL value.
12393 After performing initialization, DO NOT set init to NULL, because that'll
12394 tell the front end it is ok for more initialization to happen. Instead,
12395 set init to an opANY expression or some such thing that you can use to
12396 tell that you've already initialized the object.
12398 27-Oct-91 JCB 1.1
12399 Support two-pass FFE. */
12401 void
12403 {
12405 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12408 #endif
12412 possibilities checked. */
12416 {
12420 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12421 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12429 #endif
12431 #if FFECOM_TWOPASS
12433 #endif
12434 }
12435 #if FFECOM_ONEPASS
12436 else
12438 #endif
12440 #if FFECOM_ONEPASS
12446 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12450 #endif
12453 }
12455 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12457 ffesymbol s;
12458 ffecom_notify_primary_entry(s);
12460 Gets called when implicit or explicit PROGRAM statement seen or when
12461 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12462 global symbol that serves as the entry point. */
12464 void
12466 {
12473 else
12477 {
12480 else
12482 }
12484 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12486 {
12487 ffebld list;
12488 ffebld arg;
12493 {
12496 {
12499 }
12500 }
12501 }
12502 #endif
12503 }
12507 {
12508 #if FFECOM_GCC_INCLUDE
12510 #else
12512 #endif
12513 }
12515 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12517 tree t;
12518 ffebld expr; // FFE expression.
12519 tree = ffecom_ptr_to_expr(expr);
12521 Like ffecom_expr, but sticks address-of in front of most things. */
12523 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12524 tree
12526 {
12527 tree item;
12528 ffeinfoBasictype bt;
12529 ffeinfoKindtype kt;
12530 ffesymbol s;
12535 {
12539 {
12540 ffecomGfrt ix;
12545 {
12548 }
12549 }
12550 else
12551 {
12554 {
12557 }
12558 }
12564 item);
12581 item);
12595 /* The back end currently optimizes a bit too zealously for us, in that
12596 we fail JCB001 if the following block of code is omitted. It checks
12597 to see if the transformed expression is a symbol or array reference,
12598 and encloses it in a SAVE_EXPR if that is the case. */
12607 #ifdef OFFSET_REF
12609 #endif
12613 {
12615 }
12618 item);
12620 }
12624 }
12626 #endif
12627 /* Obtain a temp var with given data type.
12629 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12630 or >= 0 for a CHARACTER type.
12632 elements is -1 for a scalar or > 0 for an array of type. */
12634 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12635 tree
12638 {
12639 tree t;
12650 ffecom_f2c_ftnlen_one_node,
12655 integer_zero_node,
12660 commentary,
12661 mynumber++),
12662 type);
12668 }
12669 #endif
12671 /* Prepare argument pointer to expression.
12673 Like ffecom_prepare_expr, except for expressions to be evaluated
12674 via ffecom_arg_ptr_to_expr. */
12676 void
12678 {
12679 /* ~~For now, it seems to be the same thing. */
12682 }
12684 /* End of preparations. */
12686 bool
12688 {
12695 }
12697 /* Prepare expression.
12699 This is called before any code is generated for the current block.
12700 It scans the expression, declares any temporaries that might be needed
12701 during evaluation of the expression, and stores those temporaries in
12702 the appropriate "hook" fields of the expression. `dest', if not NULL,
12703 specifies the destination that ffecom_expr_ will see, in case that
12704 helps avoid generating unused temporaries.
12706 ~~Improve to avoid allocating unused temporaries by taking `dest'
12707 into account vis-a-vis aliasing requirements of complex/character
12708 functions. */
12710 void
12712 {
12713 ffeinfoBasictype bt;
12714 ffeinfoKindtype kt;
12715 ffetargetCharacterSize sz;
12727 /* Generate whatever temporaries are needed to represent the result
12728 of the expression. */
12731 {
12734 }
12737 {
12739 /* Don't make temps for SYMTER, CONTER, etc. */
12744 {
12747 {
12748 ffesymbol s;
12760 }
12762 {
12763 /* Requires special treatment. There's no POW_CC function
12764 in libg2c, so POW_ZZ is used, which means we always
12765 need a double-complex temp, not a single-complex. */
12767 }
12769 /* The other ops don't need temps for complex operands. */
12772 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12773 REAL(C). See 19990325-0.f, routine `check', for cases. */
12775 ffecom_tree_type
12777 FFETARGET_charactersizeNONE,
12786 /* ~~Kludge alert! This should someday be fixed. */
12794 }
12797 #ifdef HAHA
12799 {
12814 }
12819 {
12820 /* This gets special handling, because only one set of temps
12821 is needed for a tree of these -- the tree is treated as
12822 a flattened list of concatenations when generating code. */
12824 ffecomConcatList_ catlist;
12833 {
12834 ltmp
12836 ffecom_f2c_ftnlen_type_node,
12838 itmp
12840 ffecom_f2c_address_type_node,
12842 result
12844 char_type_node,
12852 }
12856 i));
12861 {
12864 }
12865 }
12875 }
12878 {
12881 }
12883 /* Prepare subexpressions for this expr. */
12886 {
12901 {
12902 ffebld item;
12909 }
12913 /* Need to handle character conversion specially. */
12915 {
12927 }
12928 }
12931 }
12933 /* Prepare expression for reading and writing.
12935 Like ffecom_prepare_expr, except for expressions to be evaluated
12936 via ffecom_expr_rw. */
12938 void
12940 {
12941 /* This is all we support for now. */
12944 /* ~~For now, it seems to be the same thing. */
12947 }
12949 /* Prepare expression for writing.
12951 Like ffecom_prepare_expr, except for expressions to be evaluated
12952 via ffecom_expr_w. */
12954 void
12956 {
12957 /* This is all we support for now. */
12960 /* ~~For now, it seems to be the same thing. */
12963 }
12965 /* Prepare expression for returning.
12967 Like ffecom_prepare_expr, except for expressions to be evaluated
12968 via ffecom_return_expr. */
12970 void
12972 {
12976 && ffecom_is_altreturning_
12979 }
12981 /* Prepare pointer to expression.
12983 Like ffecom_prepare_expr, except for expressions to be evaluated
12984 via ffecom_ptr_to_expr. */
12986 void
12988 {
12989 /* ~~For now, it seems to be the same thing. */
12992 }
12994 /* Transform expression into constant pointer-to-expression tree.
12996 If the expression can be transformed into a pointer-to-expression tree
12997 that is constant, that is done, and the tree returned. Else NULL_TREE
12998 is returned.
13000 That way, a caller can attempt to provide compile-time initialization
13001 of a variable and, if that fails, *then* choose to start a new block
13002 and resort to using temporaries, as appropriate. */
13004 tree
13006 {
13018 {
13019 tree t;
13024 }
13027 }
13029 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13031 tree rtn; // NULL_TREE means use expand_null_return()
13032 ffebld expr; // NULL if no alt return expr to RETURN stmt
13033 rtn = ffecom_return_expr(expr);
13035 Based on the program unit type and other info (like return function
13036 type, return master function type when alternate ENTRY points,
13037 whether subroutine has any alternate RETURN points, etc), returns the
13038 appropriate expression to be returned to the caller, or NULL_TREE
13039 meaning no return value or the caller expects it to be returned somewhere
13040 else (which is handled by other parts of this module). */
13042 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13043 tree
13045 {
13046 tree rtn;
13049 {
13060 else
13073 into (implicit) dummy. */
13076 }
13078 #if 0
13079 /* Spurious error if RETURN happens before first reference! So elide
13080 this code. In particular, for debugging registry, rtn should always
13081 be non-null after all, but TREE_USED won't be set until we encounter
13082 a reference in the code. Perfectly okay (but weird) code that,
13083 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13084 this diagnostic for no reason. Have people use -O -Wuninitialized
13085 and leave it to the back end to find obviously weird cases. */
13087 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13088 situation; if the return value has never been referenced, it won't
13089 have a tree under 2pass mode. */
13092 {
13099 }
13100 #endif
13108 }
13111 }
13113 #endif
13114 /* Do save_expr only if tree is not error_mark_node. */
13116 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13117 tree
13119 {
13121 }
13122 #endif
13124 /* Start a compound statement (block). */
13126 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13127 void
13129 {
13131 }
13134 /* Public entry point for front end to access start_decl. */
13136 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13137 tree
13139 {
13142 }
13144 #endif
13145 /* ffecom_sym_commit -- Symbol's state being committed to reality
13147 ffesymbol s;
13148 ffecom_sym_commit(s);
13150 Does whatever the backend needs when a symbol is committed after having
13151 been backtrackable for a period of time. */
13153 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13154 void
13156 {
13158 }
13160 #endif
13161 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13163 ffecom_sym_end_transition();
13165 Does backend-specific stuff and also calls ffest_sym_end_transition
13166 to do the necessary FFE stuff.
13168 Backtracking is never enabled when this fn is called, so don't worry
13169 about it. */
13171 ffesymbol
13173 {
13174 ffestorag st;
13180 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13183 {
13184 ffecom_list_blockdata_
13186 FFEINTRIN_specNONE,
13187 FFEINTRIN_impNONE),
13188 ffecom_list_blockdata_);
13189 }
13190 #endif
13192 /* This is where we finally notice that a symbol has partial initialization
13193 and finalize it. */
13196 {
13199 }
13203 {
13206 }
13208 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13212 {
13213 ffecom_list_common_
13215 FFEINTRIN_specNONE,
13216 FFEINTRIN_impNONE),
13217 ffecom_list_common_);
13218 }
13219 #endif
13222 }
13224 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13226 ffecom_sym_exec_transition();
13228 Does backend-specific stuff and also calls ffest_sym_exec_transition
13229 to do the necessary FFE stuff.
13231 See the long-winded description in ffecom_sym_learned for info
13232 on handling the situation where backtracking is inhibited. */
13234 ffesymbol
13236 {
13240 }
13242 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13244 ffesymbol s;
13245 s = ffecom_sym_learned(s);
13247 Called when a new symbol is seen after the exec transition or when more
13248 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
13249 it arrives here is that all its latest info is updated already, so its
13250 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13251 field filled in if its gone through here or exec_transition first, and
13252 so on.
13254 The backend probably wants to check ffesymbol_retractable() to see if
13255 backtracking is in effect. If so, the FFE's changes to the symbol may
13256 be retracted (undone) or committed (ratified), at which time the
13257 appropriate ffecom_sym_retract or _commit function will be called
13258 for that function.
13260 If the backend has its own backtracking mechanism, great, use it so that
13261 committal is a simple operation. Though it doesn't make much difference,
13262 I suppose: the reason for tentative symbol evolution in the FFE is to
13263 enable error detection in weird incorrect statements early and to disable
13264 incorrect error detection on a correct statement. The backend is not
13265 likely to introduce any information that'll get involved in these
13266 considerations, so it is probably just fine that the implementation
13267 model for this fn and for _exec_transition is to not do anything
13268 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13269 and instead wait until ffecom_sym_commit is called (which it never
13270 will be as long as we're using ambiguity-detecting statement analysis in
13271 the FFE, which we are initially to shake out the code, but don't depend
13272 on this), otherwise go ahead and do whatever is needed.
13274 In essence, then, when this fn and _exec_transition get called while
13275 backtracking is enabled, a general mechanism would be to flag which (or
13276 both) of these were called (and in what order? neat question as to what
13277 might happen that I'm too lame to think through right now) and then when
13278 _commit is called reproduce the original calling sequence, if any, for
13279 the two fns (at which point backtracking will, of course, be disabled). */
13281 ffesymbol
13283 {
13287 }
13289 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13291 ffesymbol s;
13292 ffecom_sym_retract(s);
13294 Does whatever the backend needs when a symbol is retracted after having
13295 been backtrackable for a period of time. */
13297 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13298 void
13300 {
13304 so nothing needed here. */
13306 {
13325 }
13326 #endif
13327 }
13329 #endif
13330 /* Create temporary gcc label. */
13332 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13333 tree
13335 {
13336 tree glabel;
13341 mynumber++),
13342 void_type_node);
13347 }
13349 #endif
13350 /* Return an expression that is usable as an arg in a conditional context
13351 (IF, DO WHILE, .NOT., and so on).
13353 Use the one provided for the back end as of >2.6.0. */
13355 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13356 tree
13358 {
13360 }
13362 #endif
13363 /* Return the inversion of a truth value (the inversion of what
13364 ffecom_truth_value builds).
13366 Apparently invert_truthvalue, which is properly in the back end, is
13367 enough for now, so just use it. */
13369 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13370 tree
13372 {
13374 }
13376 #endif
13378 /* Return the tree that is the type of the expression, as would be
13379 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13380 transforming the expression, generating temporaries, etc. */
13382 tree
13384 {
13385 ffeinfoBasictype bt;
13386 ffeinfoKindtype kt;
13387 tree tree_type;
13396 {
13439 /* Fall through. */
13442 }
13443 }
13445 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13447 If the PARM_DECL already exists, return it, else create it. It's an
13448 integer_type_node argument for the master function that implements a
13449 subroutine or function with more than one entrypoint and is bound at
13450 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13451 first ENTRY statement, and so on). */
13453 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13454 tree
13456 {
13460 }
13462 #endif
13463 \f
13464 /* The following sections consists of private and public functions
13465 that have the same names and perform roughly the same functions
13466 as counterparts in the C front end. Changes in the C front end
13467 might affect how things should be done here. Only functions
13468 needed by the back end should be public here; the rest should
13469 be private (static in the C sense). Functions needed by other
13470 g77 front-end modules should be accessed by them via public
13471 ffecom_* names, which should themselves call private versions
13472 in this section so the private versions are easy to recognize
13473 when upgrading to a new gcc and finding interesting changes
13474 in the front end.
13476 Functions named after rule "foo:" in c-parse.y are named
13477 "bison_rule_foo_" so they are easy to find. */
13479 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13481 static void
13483 {
13488 }
13490 static tree
13492 {
13493 tree t;
13496 /* Make the temps go away. */
13505 }
13507 /* Return a definition for a builtin function named NAME and whose data type
13508 is TYPE. TYPE should be a function type with argument types.
13509 FUNCTION_CODE tells later passes how to compile calls to this function.
13510 See tree.h for its possible values.
13512 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13513 the name to be called if we can't opencode the function. */
13515 tree
13519 {
13531 }
13533 /* Handle when a new declaration NEWDECL
13534 has the same name as an old one OLDDECL
13535 in the same binding contour.
13536 Prints an error message if appropriate.
13538 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13539 Otherwise, return 0. */
13541 static int
13543 {
13557 /* New decl is completely inconsistent with the old one =>
13558 tell caller to replace the old one.
13559 This is always an error except in the case of shadowing a builtin. */
13563 /* For real parm decl following a forward decl,
13564 return 1 so old decl will be reused. */
13569 /* The new declaration is the same kind of object as the old one.
13570 The declarations may partially match. Print warnings if they don't
13571 match enough. Ultimately, copy most of the information from the new
13572 decl to the old one, and keep using the old one. */
13576 {
13577 /* A function declaration for a built-in function. */
13581 {
13582 /* Accept the return type of the new declaration if same modes. */
13587 {
13588 /* Function types may be shared, so we can't just modify
13589 the return type of olddecl's function type. */
13590 tree newtype
13597 }
13598 }
13601 }
13604 {
13605 /* A function declaration for a predeclared function
13606 that isn't actually built in. */
13610 {
13611 /* If the types don't match, preserve volatility indication.
13612 Later on, we will discard everything else about the
13613 default declaration. */
13615 }
13616 }
13618 /* Copy all the DECL_... slots specified in the new decl
13619 except for any that we copy here from the old type.
13621 Past this point, we don't change OLDTYPE and NEWTYPE
13622 even if we change the types of NEWDECL and OLDDECL. */
13625 {
13626 /* Merge the data types specified in the two decls. */
13632 /* Lay the type out, unless already done. */
13634 {
13641 }
13642 else
13643 {
13644 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13649 {
13652 }
13653 }
13655 /* Keep the old rtl since we can safely use it. */
13658 /* Merge the type qualifiers. */
13665 {
13669 }
13671 /* Keep source location of definition rather than declaration.
13672 Likewise, keep decl at outer scope. */
13675 {
13682 }
13684 /* Merge the unused-warning information. */
13690 /* Merge the initialization information. */
13694 /* Merge the section attribute.
13695 We want to issue an error if the sections conflict but that must be
13696 done later in decl_attributes since we are called before attributes
13697 are assigned. */
13701 #if BUILT_FOR_270
13703 {
13706 }
13707 #endif
13708 }
13709 /* If cannot merge, then use the new type and qualifiers,
13710 and don't preserve the old rtl. */
13711 else
13712 {
13717 }
13719 /* Merge the storage class information. */
13720 /* For functions, static overrides non-static. */
13722 {
13724 /* This is since we don't automatically
13725 copy the attributes of NEWDECL into OLDDECL. */
13727 /* If this clears `static', clear it in the identifier too. */
13730 }
13732 {
13735 /* An extern decl does not override previous storage class. */
13737 }
13738 else
13739 {
13742 }
13744 /* If either decl says `inline', this fn is inline,
13745 unless its definition was passed already. */
13750 /* Get rid of any built-in function if new arg types don't match it
13751 or if we have a function definition. */
13755 {
13758 }
13760 /* If redeclaring a builtin function, and not a definition,
13761 it stays built in.
13762 Also preserve various other info from the definition. */
13764 {
13766 {
13769 }
13775 }
13777 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13778 But preserve olddecl's DECL_UID. */
13779 {
13786 }
13789 }
13791 /* Finish processing of a declaration;
13792 install its initial value.
13793 If the length of an array type is not known before,
13794 it must be determined now, from the initial value, or it is an error. */
13796 static void
13798 {
13804 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13805 level anyway. */
13810 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13811 overlaps DECL_ARG_TYPE. */
13814 else
13818 {
13821 else
13822 {
13823 /* typedef foo = bar; store the type of bar as the type of foo. */
13826 }
13827 }
13829 /* Deduce size of array from initialization, if not already known */
13834 {
13839 }
13842 {
13849 ?
13850 /* A static variable with an incomplete type is an error if it is
13851 initialized. Also if it is not file scope. Otherwise, let it
13852 through, but if it is not `extern' then it may cause an error
13853 message later. */
13855 :
13856 /* An automatic variable with an incomplete type is an error. */
13858 {
13861 }
13866 {
13869 }
13870 }
13872 /* Output the assembler code and/or RTL code for variables and functions,
13873 unless the type is an undefined structure or union. If not, it will get
13874 done when the type is completed. */
13877 {
13883 {
13884 /* Recompute the RTL of a local array now if it used to be an
13885 incomplete type. */
13888 {
13889 /* If we used it already as memory, it must stay in memory. */
13891 /* If it's still incomplete now, no init will save it. */
13895 }
13896 /* Compute and store the initial value. */
13899 }
13900 }
13902 {
13906 }
13908 /* At the end of a declaration, throw away any variable type sizes of types
13909 defined inside that declaration. There is no use computing them in the
13910 following function definition. */
13913 }
13915 /* Finish up a function declaration and compile that function
13916 all the way to assembler language output. The free the storage
13917 for the function definition.
13919 This is called after parsing the body of the function definition.
13921 NESTED is nonzero if the function being finished is nested in another. */
13923 static void
13925 {
13930 {
13933 else
13935 }
13937 /* TREE_READONLY (fndecl) = 1;
13938 This caused &foo to be of type ptr-to-const-function
13939 which then got a warning when stored in a ptr-to-function variable. */
13944 {
13947 /* Must mark the RESULT_DECL as being in this function. */
13951 /* Obey `register' declarations if `setjmp' is called in this fn. */
13952 /* Generate rtl for function exit. */
13955 /* If this is a nested function, protect the local variables in the stack
13956 above us from being collected while we're compiling this function. */
13960 /* Run the optimizers and output the assembler code for this function. */
13963 /* Undo the GC context switch. */
13966 }
13969 && !nested
13971 {
13972 /* Stop pointing to the local nodes about to be freed. */
13973 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13974 function definition. */
13975 /* For a nested function, this is done in pop_f_function_context. */
13976 /* If rest_of_compilation set this to 0, leave it 0. */
13980 }
13983 {
13984 /* Let the error reporting routines know that we're outside a function.
13985 For a nested function, this value is used in pop_c_function_context
13986 and then reset via pop_function_context. */
13988 }
13989 }
13991 /* Plug-in replacement for identifying the name of a decl and, for a
13992 function, what we call it in diagnostics. For now, "program unit"
13993 should suffice, since it's a bit of a hassle to figure out which
13994 of several kinds of things it is. Note that it could conceivably
13995 be a statement function, which probably isn't really a program unit
13996 per se, but if that comes up, it should be easy to check (being a
13997 nested function and all). */
14001 {
14002 /* Just to keep GCC quiet about the unused variable.
14003 In theory, differing values of V should produce different
14004 output. */
14006 {
14011 }
14012 }
14014 /* g77's function to print out name of current function that caused
14015 an error. */
14017 #if BUILT_FOR_270
14018 static void
14021 {
14024 ffeglobal g;
14025 ffesymbol s;
14030 {
14034 }
14035 else
14036 {
14039 {
14042 {
14062 }
14063 }
14064 else
14065 {
14068 }
14069 }
14072 {
14078 else
14079 {
14083 }
14087 }
14088 }
14089 #endif
14091 /* Similar to `lookup_name' but look only at current binding level. */
14093 static tree
14095 {
14109 }
14111 /* Create a new `struct binding_level'. */
14115 {
14116 /* NOSTRICT */
14118 }
14120 /* Save and restore the variables in this file and elsewhere
14121 that keep track of the progress of compilation of the current function.
14122 Used for nested functions. */
14124 struct f_function
14125 {
14127 tree named_labels;
14128 tree shadowed_labels;
14130 };
14134 /* Restore the variables used during compilation of a C function. */
14136 static void
14138 {
14140 tree link;
14142 /* Bring back all the labels that were shadowed. */
14150 {
14151 /* Stop pointing to the local nodes about to be freed. */
14152 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14153 function definition. */
14156 }
14167 }
14169 /* Save and reinitialize the variables
14170 used during compilation of a C function. */
14172 static void
14174 {
14186 }
14188 static void
14190 {
14193 /* Don't try computing parm sizes now -- wait till fn is called. */
14197 /* Fill in arg stuff. */
14208 }
14210 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
14212 static tree
14214 tree x;
14215 {
14226 }
14228 /* Store the list of declarations of the current level.
14229 This is done for the parameter declarations of a function being defined,
14230 after they are modified in the light of any missing parameters. */
14232 static tree
14234 tree decls;
14235 {
14237 }
14239 /* Store the parameter declarations into the current function declaration.
14240 This is called after parsing the parameter declarations, before
14241 digesting the body of the function.
14243 For an old-style definition, modify the function's type
14244 to specify at least the number of arguments. */
14246 static void
14248 {
14254 /* This is a chain of PARM_DECLs from old-style parm declarations. */
14257 /* Initialize the RTL code for the function. */
14261 /* Set up parameters and prepare for return, for the function. */
14264 }
14266 static tree
14268 {
14273 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14274 level anyway. */
14278 {
14281 }
14285 /* For Fortran, we by default put things in .common when possible. */
14288 /* Add this decl to the current binding level. TEM may equal DECL or it may
14289 be a previous decl of the same name. */
14292 else
14295 /* For a local variable, define the RTL now. */
14297 /* But not if this is a duplicate decl and we preserved the rtl from the
14298 previous one (which may or may not happen). */
14300 {
14306 }
14309 }
14311 /* Create the FUNCTION_DECL for a function definition.
14312 DECLSPECS and DECLARATOR are the parts of the declaration;
14313 they describe the function's name and the type it returns,
14314 but twisted together in a fashion that parallels the syntax of C.
14316 This function creates a binding context for the function body
14317 as well as setting up the FUNCTION_DECL in current_function_decl.
14319 Returns 1 on success. If the DECLARATOR is not suitable for a function
14320 (it defines a datum instead), we return 0, which tells
14321 yyparse to report a parse error.
14323 NESTED is nonzero for a function nested within another function. */
14325 static void
14327 {
14328 tree decl1;
14329 tree restype;
14335 /* Don't expand any sizes in the return type of the function. */
14339 {
14343 }
14344 else
14345 {
14347 }
14351 else
14352 {
14354 name,
14355 type);
14364 /* Make the init_value nonzero so pushdecl knows this is not tentative.
14365 error_mark_node is replaced below (in poplevel) with the BLOCK. */
14368 /* Record the decl so that the function name is defined. If we already have
14369 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
14372 }
14381 {
14387 }
14393 }
14394 \f
14395 /* Here are the public functions the GNU back end needs. */
14397 tree
14400 {
14413 {
14416 }
14422 e);
14436 }
14438 /* integrate_decl_tree calls this function, but since we don't use the
14439 DECL_LANG_SPECIFIC field, this is a no-op. */
14441 void
14443 tree node UNUSED;
14444 {
14445 }
14447 /* Return the list of declarations of the current level.
14448 Note that this list is in reverse order unless/until
14449 you nreverse it; and when you do nreverse it, you must
14450 store the result back using `storedecls' or you will lose. */
14452 tree
14454 {
14456 }
14458 /* Nonzero if we are currently in the global binding level. */
14460 int
14462 {
14464 }
14466 /* Print an error message for invalid use of an incomplete type.
14467 VALUE is the expression that was used (or 0 if that isn't known)
14468 and TYPE is the type that was invalid. */
14470 void
14472 tree value UNUSED;
14473 tree type;
14474 {
14479 }
14481 /* Mark ARG for GC. */
14482 static void
14484 {
14488 {
14493 }
14494 }
14496 void
14498 {
14539 &shadowed_labels
14540 };
14545 /* Record our roots. */
14556 mark_binding_level);
14558 mark_binding_level);
14562 }
14567 {
14568 /* Open input file. */
14570 {
14573 }
14574 else
14579 #ifdef IO_BUFFER_SIZE
14581 #endif
14583 /* Make identifier nodes long enough for the language-specific slots. */
14586 #if BUILT_FOR_270
14588 #endif
14591 }
14593 void
14595 {
14597 }
14599 /* Delete the node BLOCK from the current binding level.
14600 This is used for the block inside a stmt expr ({...})
14601 so that the block can be reinserted where appropriate. */
14603 static void
14605 tree block;
14606 {
14607 tree t;
14611 {
14614 else
14616 }
14618 /* Clear TREE_USED which is always set by poplevel.
14619 The flag is set again if insert_block is called. */
14621 }
14623 void
14625 tree block;
14626 {
14628 current_binding_level->blocks
14630 }
14632 /* Each front end provides its own. */
14638 ffe_finish,
14639 ffe_init_options,
14640 ffe_decode_option,
14643 /* used by print-tree.c */
14645 void
14648 tree node UNUSED;
14650 {
14651 }
14653 static void
14655 {
14660 }
14664 {
14666 }
14668 /* Return the typed-based alias set for T, which may be an expression
14669 or a type. Return -1 if we don't do anything special. */
14671 HOST_WIDE_INT
14673 tree t ATTRIBUTE_UNUSED;
14674 {
14675 /* We do not wish to use alias-set based aliasing at all. Used in the
14676 extreme (every object with its own set, with equivalences recorded)
14677 it might be helpful, but there are problems when it comes to inlining.
14678 We get on ok with flag_argument_noalias, and alias-set aliasing does
14679 currently limit how stack slots can be reused, which is a lose. */
14681 }
14683 static void
14685 {
14686 /* Set default options for Fortran. */
14693 }
14695 static void
14697 {
14698 /* If the file is output from cpp, it should contain a first line
14699 `# 1 "real-filename"', and the current design of gcc (toplev.c
14700 in particular and the way it sets up information relied on by
14701 INCLUDE) requires that we read this now, and store the
14702 "real-filename" info in master_input_filename. Ask the lexer
14703 to try doing this. */
14705 }
14707 int
14709 tree exp;
14710 {
14714 {
14731 {
14733 {
14736 }
14738 }
14740 {
14742 {
14745 }
14747 }
14750 /* drops in */
14756 #endif
14760 }
14761 }
14763 /* If DECL has a cleanup, build and return that cleanup here.
14764 This is a callback called by expand_expr. */
14766 tree
14768 tree decl UNUSED;
14769 {
14770 /* There are no cleanups in Fortran. */
14772 }
14774 /* Exit a binding level.
14775 Pop the level off, and restore the state of the identifier-decl mappings
14776 that were in effect when this level was entered.
14778 If KEEP is nonzero, this level had explicit declarations, so
14779 and create a "block" (a BLOCK node) for the level
14780 to record its declarations and subblocks for symbol table output.
14782 If FUNCTIONBODY is nonzero, this level is the body of a function,
14783 so create a block as if KEEP were set and also clear out all
14784 label names.
14786 If REVERSE is nonzero, reverse the order of decls before putting
14787 them into the BLOCK. */
14789 tree
14794 {
14796 /* The chain of decls was accumulated in reverse order.
14797 Put it into forward order, just for cleanliness. */
14798 tree decls;
14801 tree decl;
14804 /* Get the decls in the order they were written.
14805 Usually current_binding_level->names is in reverse order.
14806 But parameter decls were previously put in forward order. */
14809 current_binding_level->names
14811 else
14814 /* Output any nested inline functions within this block
14815 if they weren't already output. */
14822 {
14823 /* If this decl was copied from a file-scope decl
14824 on account of a block-scope extern decl,
14825 propagate TREE_ADDRESSABLE to the file-scope decl.
14827 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14828 true, since then the decl goes through save_for_inline_copying. */
14833 {
14837 }
14838 }
14840 /* If there were any declarations or structure tags in that level,
14841 or if this level is a function body,
14842 create a BLOCK to record them for the life of this function. */
14851 {
14854 }
14856 /* In each subblock, record that this is its superior. */
14861 /* Clear out the meanings of the local variables of this level. */
14864 {
14866 {
14867 /* If the ident. was used or addressed via a local extern decl,
14868 don't forget that fact. */
14870 {
14875 }
14877 }
14878 }
14880 /* If the level being exited is the top level of a function,
14881 check over all the labels, and clear out the current
14882 (function local) meanings of their names. */
14885 {
14886 /* If this is the top level block of a function,
14887 the vars are the function's parameters.
14888 Don't leave them in the BLOCK because they are
14889 found in the FUNCTION_DECL instead. */
14892 }
14894 /* Pop the current level, and free the structure for reuse. */
14896 {
14902 }
14904 /* Dispose of the block that we just made inside some higher level. */
14909 {
14911 current_binding_level->blocks
14913 }
14914 /* If we did not make a block for the level just exited,
14915 any blocks made for inner levels
14916 (since they cannot be recorded as subblocks in that level)
14917 must be carried forward so they will later become subblocks
14918 of something else. */
14920 current_binding_level->blocks
14926 }
14928 void
14931 tree node UNUSED;
14933 {
14934 }
14936 void
14939 tree node;
14941 {
14944 }
14946 void
14948 {
14949 }
14951 void
14954 tree node UNUSED;
14956 {
14957 }
14959 /* Record a decl-node X as belonging to the current lexical scope.
14960 Check for errors (such as an incompatible declaration for the same
14961 name already seen in the same scope).
14963 Returns either X or an old decl for the same name.
14964 If an old decl is returned, it may have been smashed
14965 to agree with what X says. */
14967 tree
14969 tree x;
14970 {
14979 else
14983 {
14985 {
14986 #if BUILT_FOR_270
14988 #endif
14990 }
14996 /* Don't push non-parms onto list for parms until we understand
14997 why we're doing this and whether it works. */
15000 || !ffecom_transform_only_dummies_
15006 /* If we are processing a typedef statement, generate a whole new
15007 ..._TYPE node (which will be just an variant of the existing
15008 ..._TYPE node with identical properties) and then install the
15009 TYPE_DECL node generated to represent the typedef name as the
15010 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15012 The whole point here is to end up with a situation where each and every
15013 ..._TYPE node the compiler creates will be uniquely associated with
15014 AT MOST one node representing a typedef name. This way, even though
15015 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15016 (i.e. "typedef name") nodes very early on, later parts of the
15017 compiler can always do the reverse translation and get back the
15018 corresponding typedef name. For example, given:
15020 typedef struct S MY_TYPE; MY_TYPE object;
15022 Later parts of the compiler might only know that `object' was of type
15023 `struct S' if it were not for code just below. With this code
15024 however, later parts of the compiler see something like:
15026 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15028 And they can then deduce (from the node for type struct S') that the
15029 original object declaration was:
15031 MY_TYPE object;
15033 Being able to do this is important for proper support of protoize, and
15034 also for generating precise symbolic debugging information which
15035 takes full account of the programmer's (typedef) vocabulary.
15037 Obviously, we don't want to generate a duplicate ..._TYPE node if the
15038 TYPE_DECL node that we are now processing really represents a
15039 standard built-in type.
15041 Since all standard types are effectively declared at line zero in the
15042 source file, we can easily check to see if we are working on a
15043 standard type by checking the current value of lineno. */
15046 {
15048 {
15051 }
15053 {
15059 }
15060 }
15062 /* This name is new in its binding level. Install the new declaration
15063 and return it. */
15066 else
15068 }
15070 /* Put decls on list in reverse order. We will reverse them later if
15071 necessary. */
15076 }
15078 /* Nonzero if the current level needs to have a BLOCK made. */
15080 static int
15082 {
15083 tree decl;
15086 decl;
15088 {
15091 /* Currently, there aren't supposed to be non-artificial names
15092 at other than the top block for a function -- they're
15093 believed to always be temps. But it's wise to check anyway. */
15095 }
15097 }
15099 /* Enter a new binding level.
15100 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15101 not for that of tags. */
15103 void
15106 {
15112 {
15114 }
15116 /* Reuse or create a struct for this binding level. */
15119 {
15122 }
15123 else
15124 {
15126 }
15128 /* Add this level to the front of the chain (stack) of levels that
15129 are active. */
15134 }
15136 /* Set the BLOCK node for the innermost scope
15137 (the one we are currently in). */
15139 void
15142 {
15148 }
15150 /* ~~gcc/tree.h *should* declare this, because toplev.c references it. */
15152 /* Can't 'yydebug' a front end not generated by yacc/bison! */
15154 void
15157 {
15160 }
15162 tree
15165 tree type;
15166 {
15167 tree type2;
15188 }
15190 tree
15192 tree type;
15193 {
15195 ffeinfoKindtype kt;
15196 tree type2;
15217 #endif
15224 {
15229 }
15232 }
15234 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15235 or validate its data type for an `if' or `while' statement or ?..: exp.
15237 This preparation consists of taking the ordinary
15238 representation of an expression expr and producing a valid tree
15239 boolean expression describing whether expr is nonzero. We could
15240 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15241 but we optimize comparisons, &&, ||, and !.
15243 The resulting type should always be `integer_type_node'. */
15245 tree
15247 tree expr;
15248 {
15253 /* These really should return error_mark_node after 2.4 is stable.
15254 But not all callers handle ERROR_MARK properly. */
15256 {
15271 }
15275 {
15276 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15277 or comparison expressions as truth values at this level. */
15278 #if 0
15280 /* A one-bit unsigned bit-field is already acceptable. */
15285 #endif
15288 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15289 or comparison expressions as truth values at this level. */
15290 #if 0
15293 #endif
15316 else
15322 integer_type_node,
15330 /* These don't change whether an object is non-zero or zero. */
15335 /* These don't change whether an object is zero or non-zero, but
15336 we can't ignore them if their second arg has side-effects. */
15340 else
15344 /* Distribute the conversion into the arms of a COND_EXPR. */
15350 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15351 since that affects how `default_conversion' will behave. */
15355 /* fall through... */
15357 /* If this is widening the argument, we can ignore it. */
15364 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15365 this case. */
15369 /* fall through... */
15371 /* This and MINUS_EXPR can be changed into a comparison of the
15372 two objects. */
15393 #endif
15398 }
15404 integer_type_node,
15407 expr)),
15410 expr))));
15413 expr,
15415 }
15417 tree
15421 {
15424 tree t;
15441 #if HOST_BITS_PER_WIDE_INT >= 64
15444 #endif
15460 {
15463 {
15466 else
15468 }
15469 }
15472 }
15474 tree
15478 {
15479 ffeinfoKindtype kt;
15480 tree type_node;
15499 {
15505 }
15508 }
15510 tree
15512 tree type;
15513 {
15515 ffeinfoKindtype kt;
15516 tree type2;
15537 #endif
15544 {
15549 }
15552 }
15554 void
15557 {
15559 {
15564 }
15567 }
15570 \f
15571 #if FFECOM_GCC_INCLUDE
15573 /* From gcc/cccp.c, the code to handle -I. */
15575 /* Skip leading "./" from a directory name.
15576 This may yield the empty string, which represents the current directory. */
15580 {
15585 dir++;
15587 }
15589 /* The file_name_map structure holds a mapping of file names for a
15590 particular directory. This mapping is read from the file named
15591 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15592 map filenames on a file system with severe filename restrictions,
15593 such as DOS. The format of the file name map file is just a series
15594 of lines with two tokens on each line. The first token is the name
15595 to map, and the second token is the actual name to use. */
15597 struct file_name_map
15598 {
15602 };
15606 /* Current maximum length of directory names in the search path
15607 for include files. (Altered as we get more of them.) */
15611 struct file_name_list
15612 {
15615 /* Mapping of file names for this directory. */
15617 /* Non-zero if name_map is valid. */
15619 };
15624 /* I/O buffer structure.
15625 The `fname' field is nonzero for source files and #include files
15626 and for the dummy text used for -D and -U.
15627 It is zero for rescanning results of macro expansion
15628 and for expanding macro arguments. */
15629 #define INPUT_STACK_MAX 400
15632 /* Filename specified with #line command. */
15634 /* Record where in the search path this file was found.
15635 For #include_next. */
15637 ffewhereLine line;
15638 ffewhereColumn column;
15644 /* Current nesting level of input sources.
15645 `instack[indepth]' is the level currently being read. */
15652 /* table to tell if char can be part of a C identifier. */
15654 /* table to tell if char can be first char of a c identifier. */
15656 /* table to tell if c is horizontal space. */
15658 /* table to tell if c is horizontal or vertical space. */
15661 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15662 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15664 /* Nonzero means -I- has been seen,
15665 so don't look for #include "foo" the source-file directory. */
15668 #ifndef INCLUDE_LEN_FUDGE
15669 #define INCLUDE_LEN_FUDGE 0
15670 #endif
15680 /* Append a chain of `struct file_name_list's
15681 to the end of the main include chain.
15682 FIRST is the beginning of the chain to append, and LAST is the end. */
15684 static void
15687 {
15695 else
15704 }
15708 }
15710 /* Try to open include file FILENAME. SEARCHPTR is the directory
15711 being tried from the include file search path. This function maps
15712 filenames on file systems based on information read by
15713 read_name_map. */
15719 {
15725 {
15729 }
15731 /* First check the mapping for the directory we are using. */
15733 {
15738 {
15740 {
15741 /* Found a match. */
15743 }
15744 }
15745 }
15747 /* Try to find a mapping file for the particular directory we are
15748 looking in. Thus #include <sys/types.h> will look up sys/types.h
15749 in /usr/include/header.gcc and look up types.h in
15750 /usr/include/sys/header.gcc. */
15752 #ifdef DIR_SEPARATOR
15757 }
15758 #endif
15765 {
15766 /* FILENAME is in SEARCHPTR, which we've already checked. */
15768 }
15771 {
15774 }
15775 else
15776 {
15783 }
15789 }
15791 /* Print the file names and line numbers of the #include
15792 commands which led to the current file. */
15794 static void
15796 {
15803 /* If stack of files hasn't changed since we last printed
15804 this info, don't repeat it. */
15812 }
15814 /* Give up if we don't find a source file. */
15818 /* Find the other, outer source files. */
15821 {
15824 {
15827 }
15828 else
15829 {
15831 }
15835 else
15844 }
15846 /* Record we have printed the status as of this time. */
15848 }
15850 /* Read a space delimited string of unlimited length from a stdio
15851 file. */
15857 {
15864 {
15867 {
15869 {
15873 }
15875 }
15876 }
15880 }
15882 /* Read the file name map file for DIRNAME. */
15887 {
15888 /* This structure holds a linked list of file name maps, one per
15889 directory. */
15890 struct file_name_map_list
15891 {
15895 };
15925 else
15926 {
15930 {
15938 ;
15945 /* Make the real filename absolute. */
15948 else
15949 {
15955 }
15963 }
15965 }
15971 }
15973 static void
15975 {
15978 /* Do partial setup of input buffer for the sake of generating
15979 early #line directives (when -g is in effect). */
15986 }
15988 /* Initialize syntactic classifications of characters. */
15990 static void
15992 {
15995 /*
15996 * Set up is_idchar and is_idstart tables. These should be
15997 * faster than saying (is_alpha (c) || c == '_'), etc.
15998 * Set up these things before calling any routines tthat
15999 * refer to them.
16000 */
16006 }
16012 /* horizontal space table */
16025 }
16027 static void
16029 {
16032 indepth--;
16033 input_file_stack_tick++;
16037 }
16039 static int
16041 {
16046 else
16047 {
16055 else
16057 }
16059 }
16061 /* Open INCLUDEd file. */
16065 {
16080 /* If -I- was specified, don't search current dir, only spec'd ones. */
16082 {
16084 {
16090 {
16091 /* Found a named file. Figure out dir of the file,
16092 and put it in front of the search list. */
16095 #ifndef VMS
16097 #ifdef DIR_SEPARATOR
16102 }
16103 #endif
16111 {
16118 }
16119 else
16123 }
16124 }
16125 }
16127 /* Allocate this permanently, because it gets stored in the definitions
16128 of macros. */
16130 /* + 2 above for slash and terminating null. */
16131 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16132 for g77 yet). */
16134 /* If specified file name is absolute, just open it. */
16137 #ifdef DIR_SEPARATOR
16139 #endif
16140 )
16141 {
16145 }
16146 else
16147 {
16150 /* Search directory path, trying to open the file.
16151 Copy each filename tried into FNAME. */
16154 {
16156 {
16157 /* The empty string in a search path is ignored.
16158 This makes it possible to turn off entirely
16159 a standard piece of the list. */
16166 }
16167 else
16171 #ifdef VMS
16172 /* Change this 1/2 Unix 1/2 VMS file specification into a
16173 full VMS file specification */
16175 {
16176 /* Fix up the filename */
16178 }
16179 else
16180 {
16181 /* This is a normal VMS filespec, so use it unchanged. */
16185 /* if it's '#include filename', add the missing .h */
16188 #endif
16189 }
16192 #ifdef EACCES
16194 {
16197 FFEBAD_severityWARNING);
16201 }
16202 #endif
16205 }
16206 }
16209 {
16210 /* A file that was not found. */
16219 }
16228 {
16231 FFEBAD_severityFATAL);
16236 }
16246 indepth++;
16247 input_file_stack_tick++;
16250 }
16253 /**INDENT* (Do not reformat this comment even with -fca option.)
16254 Data-gathering files: Given the source file listed below, compiled with
16255 f2c I obtained the output file listed after that, and from the output
16256 file I derived the above code.
16258 -------- (begin input file to f2c)
16259 implicit none
16260 character*10 A1,A2
16261 complex C1,C2
16262 integer I1,I2
16263 real R1,R2
16264 double precision D1,D2
16265 C
16266 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16267 c /
16268 call fooI(I1/I2)
16269 call fooR(R1/I1)
16270 call fooD(D1/I1)
16271 call fooC(C1/I1)
16272 call fooR(R1/R2)
16273 call fooD(R1/D1)
16274 call fooD(D1/D2)
16275 call fooD(D1/R1)
16276 call fooC(C1/C2)
16277 call fooC(C1/R1)
16278 call fooZ(C1/D1)
16279 c **
16280 call fooI(I1**I2)
16281 call fooR(R1**I1)
16282 call fooD(D1**I1)
16283 call fooC(C1**I1)
16284 call fooR(R1**R2)
16285 call fooD(R1**D1)
16286 call fooD(D1**D2)
16287 call fooD(D1**R1)
16288 call fooC(C1**C2)
16289 call fooC(C1**R1)
16290 call fooZ(C1**D1)
16291 c FFEINTRIN_impABS
16292 call fooR(ABS(R1))
16293 c FFEINTRIN_impACOS
16294 call fooR(ACOS(R1))
16295 c FFEINTRIN_impAIMAG
16296 call fooR(AIMAG(C1))
16297 c FFEINTRIN_impAINT
16298 call fooR(AINT(R1))
16299 c FFEINTRIN_impALOG
16300 call fooR(ALOG(R1))
16301 c FFEINTRIN_impALOG10
16302 call fooR(ALOG10(R1))
16303 c FFEINTRIN_impAMAX0
16304 call fooR(AMAX0(I1,I2))
16305 c FFEINTRIN_impAMAX1
16306 call fooR(AMAX1(R1,R2))
16307 c FFEINTRIN_impAMIN0
16308 call fooR(AMIN0(I1,I2))
16309 c FFEINTRIN_impAMIN1
16310 call fooR(AMIN1(R1,R2))
16311 c FFEINTRIN_impAMOD
16312 call fooR(AMOD(R1,R2))
16313 c FFEINTRIN_impANINT
16314 call fooR(ANINT(R1))
16315 c FFEINTRIN_impASIN
16316 call fooR(ASIN(R1))
16317 c FFEINTRIN_impATAN
16318 call fooR(ATAN(R1))
16319 c FFEINTRIN_impATAN2
16320 call fooR(ATAN2(R1,R2))
16321 c FFEINTRIN_impCABS
16322 call fooR(CABS(C1))
16323 c FFEINTRIN_impCCOS
16324 call fooC(CCOS(C1))
16325 c FFEINTRIN_impCEXP
16326 call fooC(CEXP(C1))
16327 c FFEINTRIN_impCHAR
16328 call fooA(CHAR(I1))
16329 c FFEINTRIN_impCLOG
16330 call fooC(CLOG(C1))
16331 c FFEINTRIN_impCONJG
16332 call fooC(CONJG(C1))
16333 c FFEINTRIN_impCOS
16334 call fooR(COS(R1))
16335 c FFEINTRIN_impCOSH
16336 call fooR(COSH(R1))
16337 c FFEINTRIN_impCSIN
16338 call fooC(CSIN(C1))
16339 c FFEINTRIN_impCSQRT
16340 call fooC(CSQRT(C1))
16341 c FFEINTRIN_impDABS
16342 call fooD(DABS(D1))
16343 c FFEINTRIN_impDACOS
16344 call fooD(DACOS(D1))
16345 c FFEINTRIN_impDASIN
16346 call fooD(DASIN(D1))
16347 c FFEINTRIN_impDATAN
16348 call fooD(DATAN(D1))
16349 c FFEINTRIN_impDATAN2
16350 call fooD(DATAN2(D1,D2))
16351 c FFEINTRIN_impDCOS
16352 call fooD(DCOS(D1))
16353 c FFEINTRIN_impDCOSH
16354 call fooD(DCOSH(D1))
16355 c FFEINTRIN_impDDIM
16356 call fooD(DDIM(D1,D2))
16357 c FFEINTRIN_impDEXP
16358 call fooD(DEXP(D1))
16359 c FFEINTRIN_impDIM
16360 call fooR(DIM(R1,R2))
16361 c FFEINTRIN_impDINT
16362 call fooD(DINT(D1))
16363 c FFEINTRIN_impDLOG
16364 call fooD(DLOG(D1))
16365 c FFEINTRIN_impDLOG10
16366 call fooD(DLOG10(D1))
16367 c FFEINTRIN_impDMAX1
16368 call fooD(DMAX1(D1,D2))
16369 c FFEINTRIN_impDMIN1
16370 call fooD(DMIN1(D1,D2))
16371 c FFEINTRIN_impDMOD
16372 call fooD(DMOD(D1,D2))
16373 c FFEINTRIN_impDNINT
16374 call fooD(DNINT(D1))
16375 c FFEINTRIN_impDPROD
16376 call fooD(DPROD(R1,R2))
16377 c FFEINTRIN_impDSIGN
16378 call fooD(DSIGN(D1,D2))
16379 c FFEINTRIN_impDSIN
16380 call fooD(DSIN(D1))
16381 c FFEINTRIN_impDSINH
16382 call fooD(DSINH(D1))
16383 c FFEINTRIN_impDSQRT
16384 call fooD(DSQRT(D1))
16385 c FFEINTRIN_impDTAN
16386 call fooD(DTAN(D1))
16387 c FFEINTRIN_impDTANH
16388 call fooD(DTANH(D1))
16389 c FFEINTRIN_impEXP
16390 call fooR(EXP(R1))
16391 c FFEINTRIN_impIABS
16392 call fooI(IABS(I1))
16393 c FFEINTRIN_impICHAR
16394 call fooI(ICHAR(A1))
16395 c FFEINTRIN_impIDIM
16396 call fooI(IDIM(I1,I2))
16397 c FFEINTRIN_impIDNINT
16398 call fooI(IDNINT(D1))
16399 c FFEINTRIN_impINDEX
16400 call fooI(INDEX(A1,A2))
16401 c FFEINTRIN_impISIGN
16402 call fooI(ISIGN(I1,I2))
16403 c FFEINTRIN_impLEN
16404 call fooI(LEN(A1))
16405 c FFEINTRIN_impLGE
16406 call fooL(LGE(A1,A2))
16407 c FFEINTRIN_impLGT
16408 call fooL(LGT(A1,A2))
16409 c FFEINTRIN_impLLE
16410 call fooL(LLE(A1,A2))
16411 c FFEINTRIN_impLLT
16412 call fooL(LLT(A1,A2))
16413 c FFEINTRIN_impMAX0
16414 call fooI(MAX0(I1,I2))
16415 c FFEINTRIN_impMAX1
16416 call fooI(MAX1(R1,R2))
16417 c FFEINTRIN_impMIN0
16418 call fooI(MIN0(I1,I2))
16419 c FFEINTRIN_impMIN1
16420 call fooI(MIN1(R1,R2))
16421 c FFEINTRIN_impMOD
16422 call fooI(MOD(I1,I2))
16423 c FFEINTRIN_impNINT
16424 call fooI(NINT(R1))
16425 c FFEINTRIN_impSIGN
16426 call fooR(SIGN(R1,R2))
16427 c FFEINTRIN_impSIN
16428 call fooR(SIN(R1))
16429 c FFEINTRIN_impSINH
16430 call fooR(SINH(R1))
16431 c FFEINTRIN_impSQRT
16432 call fooR(SQRT(R1))
16433 c FFEINTRIN_impTAN
16434 call fooR(TAN(R1))
16435 c FFEINTRIN_impTANH
16436 call fooR(TANH(R1))
16437 c FFEINTRIN_imp_CMPLX_C
16438 call fooC(cmplx(C1,C2))
16439 c FFEINTRIN_imp_CMPLX_D
16440 call fooZ(cmplx(D1,D2))
16441 c FFEINTRIN_imp_CMPLX_I
16442 call fooC(cmplx(I1,I2))
16443 c FFEINTRIN_imp_CMPLX_R
16444 call fooC(cmplx(R1,R2))
16445 c FFEINTRIN_imp_DBLE_C
16446 call fooD(dble(C1))
16447 c FFEINTRIN_imp_DBLE_D
16448 call fooD(dble(D1))
16449 c FFEINTRIN_imp_DBLE_I
16450 call fooD(dble(I1))
16451 c FFEINTRIN_imp_DBLE_R
16452 call fooD(dble(R1))
16453 c FFEINTRIN_imp_INT_C
16454 call fooI(int(C1))
16455 c FFEINTRIN_imp_INT_D
16456 call fooI(int(D1))
16457 c FFEINTRIN_imp_INT_I
16458 call fooI(int(I1))
16459 c FFEINTRIN_imp_INT_R
16460 call fooI(int(R1))
16461 c FFEINTRIN_imp_REAL_C
16462 call fooR(real(C1))
16463 c FFEINTRIN_imp_REAL_D
16464 call fooR(real(D1))
16465 c FFEINTRIN_imp_REAL_I
16466 call fooR(real(I1))
16467 c FFEINTRIN_imp_REAL_R
16468 call fooR(real(R1))
16469 c
16470 c FFEINTRIN_imp_INT_D:
16471 c
16472 c FFEINTRIN_specIDINT
16473 call fooI(IDINT(D1))
16474 c
16475 c FFEINTRIN_imp_INT_R:
16476 c
16477 c FFEINTRIN_specIFIX
16478 call fooI(IFIX(R1))
16479 c FFEINTRIN_specINT
16480 call fooI(INT(R1))
16481 c
16482 c FFEINTRIN_imp_REAL_D:
16483 c
16484 c FFEINTRIN_specSNGL
16485 call fooR(SNGL(D1))
16486 c
16487 c FFEINTRIN_imp_REAL_I:
16488 c
16489 c FFEINTRIN_specFLOAT
16490 call fooR(FLOAT(I1))
16491 c FFEINTRIN_specREAL
16492 call fooR(REAL(I1))
16493 c
16494 end
16495 -------- (end input file to f2c)
16497 -------- (begin output from providing above input file as input to:
16498 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16499 -------- -e "s:^#.*$::g"')
16501 // -- translated by f2c (version 19950223).
16502 You must link the resulting object file with the libraries:
16503 -lf2c -lm (in that order)
16504 //
16507 // f2c.h -- Standard Fortran to C header file //
16509 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
16511 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16516 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16517 // we assume short, float are OK //
16518 typedef long int // long int // integer;
16519 typedef char *address;
16520 typedef short int shortint;
16521 typedef float real;
16522 typedef double doublereal;
16523 typedef struct { real r, i; } complex;
16524 typedef struct { doublereal r, i; } doublecomplex;
16525 typedef long int // long int // logical;
16526 typedef short int shortlogical;
16527 typedef char logical1;
16528 typedef char integer1;
16529 // typedef long long longint; // // system-dependent //
16534 // Extern is for use with -E //
16539 // I/O stuff //
16548 typedef long int // int or long int // flag;
16549 typedef long int // int or long int // ftnlen;
16550 typedef long int // int or long int // ftnint;
16553 //external read, write//
16554 typedef struct
16555 { flag cierr;
16556 ftnint ciunit;
16557 flag ciend;
16558 char *cifmt;
16559 ftnint cirec;
16560 } cilist;
16562 //internal read, write//
16563 typedef struct
16564 { flag icierr;
16565 char *iciunit;
16566 flag iciend;
16567 char *icifmt;
16568 ftnint icirlen;
16569 ftnint icirnum;
16570 } icilist;
16572 //open//
16573 typedef struct
16574 { flag oerr;
16575 ftnint ounit;
16576 char *ofnm;
16577 ftnlen ofnmlen;
16578 char *osta;
16579 char *oacc;
16580 char *ofm;
16581 ftnint orl;
16582 char *oblnk;
16583 } olist;
16585 //close//
16586 typedef struct
16587 { flag cerr;
16588 ftnint cunit;
16589 char *csta;
16590 } cllist;
16592 //rewind, backspace, endfile//
16593 typedef struct
16594 { flag aerr;
16595 ftnint aunit;
16596 } alist;
16598 // inquire //
16599 typedef struct
16600 { flag inerr;
16601 ftnint inunit;
16602 char *infile;
16603 ftnlen infilen;
16604 ftnint *inex; //parameters in standard's order//
16605 ftnint *inopen;
16606 ftnint *innum;
16607 ftnint *innamed;
16608 char *inname;
16609 ftnlen innamlen;
16610 char *inacc;
16611 ftnlen inacclen;
16612 char *inseq;
16613 ftnlen inseqlen;
16614 char *indir;
16615 ftnlen indirlen;
16616 char *infmt;
16617 ftnlen infmtlen;
16618 char *inform;
16619 ftnint informlen;
16620 char *inunf;
16621 ftnlen inunflen;
16622 ftnint *inrecl;
16623 ftnint *innrec;
16624 char *inblank;
16625 ftnlen inblanklen;
16626 } inlist;
16630 union Multitype { // for multiple entry points //
16631 integer1 g;
16632 shortint h;
16633 integer i;
16634 // longint j; //
16635 real r;
16636 doublereal d;
16637 complex c;
16638 doublecomplex z;
16639 };
16641 typedef union Multitype Multitype;
16643 typedef long Long; // No longer used; formerly in Namelist //
16645 struct Vardesc { // for Namelist //
16646 char *name;
16647 char *addr;
16648 ftnlen *dims;
16649 int type;
16650 };
16651 typedef struct Vardesc Vardesc;
16653 struct Namelist {
16654 char *name;
16655 Vardesc **vars;
16656 int nvars;
16657 };
16658 typedef struct Namelist Namelist;
16667 // procedure parameter types for -A and -C++ //
16672 typedef int // Unknown procedure type // (*U_fp)();
16673 typedef shortint (*J_fp)();
16674 typedef integer (*I_fp)();
16675 typedef real (*R_fp)();
16676 typedef doublereal (*D_fp)(), (*E_fp)();
16677 typedef // Complex // void (*C_fp)();
16678 typedef // Double Complex // void (*Z_fp)();
16679 typedef logical (*L_fp)();
16680 typedef shortlogical (*K_fp)();
16681 typedef // Character // void (*H_fp)();
16682 typedef // Subroutine // int (*S_fp)();
16684 // E_fp is for real functions when -R is not specified //
16685 typedef void C_f; // complex function //
16686 typedef void H_f; // character function //
16687 typedef void Z_f; // double complex function //
16688 typedef doublereal E_f; // real function with -R not specified //
16690 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16693 // (No such symbols should be defined in a strict ANSI C compiler.
16694 We can avoid trouble with f2c-translated code by using
16695 gcc -ansi [-traditional].) //
16719 // Main program // MAIN__()
16720 {
16721 // System generated locals //
16722 integer i__1;
16723 real r__1, r__2;
16724 doublereal d__1, d__2;
16725 complex q__1;
16726 doublecomplex z__1, z__2, z__3;
16727 logical L__1;
16728 char ch__1[1];
16730 // Builtin functions //
16731 void c_div();
16732 integer pow_ii();
16733 double pow_ri(), pow_di();
16734 void pow_ci();
16735 double pow_dd();
16736 void pow_zz();
16737 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16738 asin(), atan(), atan2(), c_abs();
16739 void c_cos(), c_exp(), c_log(), r_cnjg();
16740 double cos(), cosh();
16741 void c_sin(), c_sqrt();
16742 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16743 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16744 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16745 logical l_ge(), l_gt(), l_le(), l_lt();
16746 integer i_nint();
16747 double r_sign();
16749 // Local variables //
16750 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16751 fool_(), fooz_(), getem_();
16752 static char a1[10], a2[10];
16753 static complex c1, c2;
16754 static doublereal d1, d2;
16755 static integer i1, i2;
16756 static real r1, r2;
16759 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16760 // / //
16761 i__1 = i1 / i2;
16762 fooi_(&i__1);
16763 r__1 = r1 / i1;
16764 foor_(&r__1);
16765 d__1 = d1 / i1;
16766 food_(&d__1);
16767 d__1 = (doublereal) i1;
16768 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16769 fooc_(&q__1);
16770 r__1 = r1 / r2;
16771 foor_(&r__1);
16772 d__1 = r1 / d1;
16773 food_(&d__1);
16774 d__1 = d1 / d2;
16775 food_(&d__1);
16776 d__1 = d1 / r1;
16777 food_(&d__1);
16778 c_div(&q__1, &c1, &c2);
16779 fooc_(&q__1);
16780 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16781 fooc_(&q__1);
16782 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16783 fooz_(&z__1);
16784 // ** //
16785 i__1 = pow_ii(&i1, &i2);
16786 fooi_(&i__1);
16787 r__1 = pow_ri(&r1, &i1);
16788 foor_(&r__1);
16789 d__1 = pow_di(&d1, &i1);
16790 food_(&d__1);
16791 pow_ci(&q__1, &c1, &i1);
16792 fooc_(&q__1);
16793 d__1 = (doublereal) r1;
16794 d__2 = (doublereal) r2;
16795 r__1 = pow_dd(&d__1, &d__2);
16796 foor_(&r__1);
16797 d__2 = (doublereal) r1;
16798 d__1 = pow_dd(&d__2, &d1);
16799 food_(&d__1);
16800 d__1 = pow_dd(&d1, &d2);
16801 food_(&d__1);
16802 d__2 = (doublereal) r1;
16803 d__1 = pow_dd(&d1, &d__2);
16804 food_(&d__1);
16805 z__2.r = c1.r, z__2.i = c1.i;
16806 z__3.r = c2.r, z__3.i = c2.i;
16807 pow_zz(&z__1, &z__2, &z__3);
16808 q__1.r = z__1.r, q__1.i = z__1.i;
16809 fooc_(&q__1);
16810 z__2.r = c1.r, z__2.i = c1.i;
16811 z__3.r = r1, z__3.i = 0.;
16812 pow_zz(&z__1, &z__2, &z__3);
16813 q__1.r = z__1.r, q__1.i = z__1.i;
16814 fooc_(&q__1);
16815 z__2.r = c1.r, z__2.i = c1.i;
16816 z__3.r = d1, z__3.i = 0.;
16817 pow_zz(&z__1, &z__2, &z__3);
16818 fooz_(&z__1);
16819 // FFEINTRIN_impABS //
16820 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16821 foor_(&r__1);
16822 // FFEINTRIN_impACOS //
16823 r__1 = acos(r1);
16824 foor_(&r__1);
16825 // FFEINTRIN_impAIMAG //
16826 r__1 = r_imag(&c1);
16827 foor_(&r__1);
16828 // FFEINTRIN_impAINT //
16829 r__1 = r_int(&r1);
16830 foor_(&r__1);
16831 // FFEINTRIN_impALOG //
16832 r__1 = log(r1);
16833 foor_(&r__1);
16834 // FFEINTRIN_impALOG10 //
16835 r__1 = r_lg10(&r1);
16836 foor_(&r__1);
16837 // FFEINTRIN_impAMAX0 //
16838 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16839 foor_(&r__1);
16840 // FFEINTRIN_impAMAX1 //
16841 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16842 foor_(&r__1);
16843 // FFEINTRIN_impAMIN0 //
16844 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16845 foor_(&r__1);
16846 // FFEINTRIN_impAMIN1 //
16847 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16848 foor_(&r__1);
16849 // FFEINTRIN_impAMOD //
16850 r__1 = r_mod(&r1, &r2);
16851 foor_(&r__1);
16852 // FFEINTRIN_impANINT //
16853 r__1 = r_nint(&r1);
16854 foor_(&r__1);
16855 // FFEINTRIN_impASIN //
16856 r__1 = asin(r1);
16857 foor_(&r__1);
16858 // FFEINTRIN_impATAN //
16859 r__1 = atan(r1);
16860 foor_(&r__1);
16861 // FFEINTRIN_impATAN2 //
16862 r__1 = atan2(r1, r2);
16863 foor_(&r__1);
16864 // FFEINTRIN_impCABS //
16865 r__1 = c_abs(&c1);
16866 foor_(&r__1);
16867 // FFEINTRIN_impCCOS //
16868 c_cos(&q__1, &c1);
16869 fooc_(&q__1);
16870 // FFEINTRIN_impCEXP //
16871 c_exp(&q__1, &c1);
16872 fooc_(&q__1);
16873 // FFEINTRIN_impCHAR //
16874 *(unsigned char *)&ch__1[0] = i1;
16875 fooa_(ch__1, 1L);
16876 // FFEINTRIN_impCLOG //
16877 c_log(&q__1, &c1);
16878 fooc_(&q__1);
16879 // FFEINTRIN_impCONJG //
16880 r_cnjg(&q__1, &c1);
16881 fooc_(&q__1);
16882 // FFEINTRIN_impCOS //
16883 r__1 = cos(r1);
16884 foor_(&r__1);
16885 // FFEINTRIN_impCOSH //
16886 r__1 = cosh(r1);
16887 foor_(&r__1);
16888 // FFEINTRIN_impCSIN //
16889 c_sin(&q__1, &c1);
16890 fooc_(&q__1);
16891 // FFEINTRIN_impCSQRT //
16892 c_sqrt(&q__1, &c1);
16893 fooc_(&q__1);
16894 // FFEINTRIN_impDABS //
16895 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16896 food_(&d__1);
16897 // FFEINTRIN_impDACOS //
16898 d__1 = acos(d1);
16899 food_(&d__1);
16900 // FFEINTRIN_impDASIN //
16901 d__1 = asin(d1);
16902 food_(&d__1);
16903 // FFEINTRIN_impDATAN //
16904 d__1 = atan(d1);
16905 food_(&d__1);
16906 // FFEINTRIN_impDATAN2 //
16907 d__1 = atan2(d1, d2);
16908 food_(&d__1);
16909 // FFEINTRIN_impDCOS //
16910 d__1 = cos(d1);
16911 food_(&d__1);
16912 // FFEINTRIN_impDCOSH //
16913 d__1 = cosh(d1);
16914 food_(&d__1);
16915 // FFEINTRIN_impDDIM //
16916 d__1 = d_dim(&d1, &d2);
16917 food_(&d__1);
16918 // FFEINTRIN_impDEXP //
16919 d__1 = exp(d1);
16920 food_(&d__1);
16921 // FFEINTRIN_impDIM //
16922 r__1 = r_dim(&r1, &r2);
16923 foor_(&r__1);
16924 // FFEINTRIN_impDINT //
16925 d__1 = d_int(&d1);
16926 food_(&d__1);
16927 // FFEINTRIN_impDLOG //
16928 d__1 = log(d1);
16929 food_(&d__1);
16930 // FFEINTRIN_impDLOG10 //
16931 d__1 = d_lg10(&d1);
16932 food_(&d__1);
16933 // FFEINTRIN_impDMAX1 //
16934 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16935 food_(&d__1);
16936 // FFEINTRIN_impDMIN1 //
16937 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16938 food_(&d__1);
16939 // FFEINTRIN_impDMOD //
16940 d__1 = d_mod(&d1, &d2);
16941 food_(&d__1);
16942 // FFEINTRIN_impDNINT //
16943 d__1 = d_nint(&d1);
16944 food_(&d__1);
16945 // FFEINTRIN_impDPROD //
16946 d__1 = (doublereal) r1 * r2;
16947 food_(&d__1);
16948 // FFEINTRIN_impDSIGN //
16949 d__1 = d_sign(&d1, &d2);
16950 food_(&d__1);
16951 // FFEINTRIN_impDSIN //
16952 d__1 = sin(d1);
16953 food_(&d__1);
16954 // FFEINTRIN_impDSINH //
16955 d__1 = sinh(d1);
16956 food_(&d__1);
16957 // FFEINTRIN_impDSQRT //
16958 d__1 = sqrt(d1);
16959 food_(&d__1);
16960 // FFEINTRIN_impDTAN //
16961 d__1 = tan(d1);
16962 food_(&d__1);
16963 // FFEINTRIN_impDTANH //
16964 d__1 = tanh(d1);
16965 food_(&d__1);
16966 // FFEINTRIN_impEXP //
16967 r__1 = exp(r1);
16968 foor_(&r__1);
16969 // FFEINTRIN_impIABS //
16970 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16971 fooi_(&i__1);
16972 // FFEINTRIN_impICHAR //
16973 i__1 = *(unsigned char *)a1;
16974 fooi_(&i__1);
16975 // FFEINTRIN_impIDIM //
16976 i__1 = i_dim(&i1, &i2);
16977 fooi_(&i__1);
16978 // FFEINTRIN_impIDNINT //
16979 i__1 = i_dnnt(&d1);
16980 fooi_(&i__1);
16981 // FFEINTRIN_impINDEX //
16982 i__1 = i_indx(a1, a2, 10L, 10L);
16983 fooi_(&i__1);
16984 // FFEINTRIN_impISIGN //
16985 i__1 = i_sign(&i1, &i2);
16986 fooi_(&i__1);
16987 // FFEINTRIN_impLEN //
16988 i__1 = i_len(a1, 10L);
16989 fooi_(&i__1);
16990 // FFEINTRIN_impLGE //
16991 L__1 = l_ge(a1, a2, 10L, 10L);
16992 fool_(&L__1);
16993 // FFEINTRIN_impLGT //
16994 L__1 = l_gt(a1, a2, 10L, 10L);
16995 fool_(&L__1);
16996 // FFEINTRIN_impLLE //
16997 L__1 = l_le(a1, a2, 10L, 10L);
16998 fool_(&L__1);
16999 // FFEINTRIN_impLLT //
17000 L__1 = l_lt(a1, a2, 10L, 10L);
17001 fool_(&L__1);
17002 // FFEINTRIN_impMAX0 //
17003 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17004 fooi_(&i__1);
17005 // FFEINTRIN_impMAX1 //
17006 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
17007 fooi_(&i__1);
17008 // FFEINTRIN_impMIN0 //
17009 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17010 fooi_(&i__1);
17011 // FFEINTRIN_impMIN1 //
17012 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
17013 fooi_(&i__1);
17014 // FFEINTRIN_impMOD //
17015 i__1 = i1 % i2;
17016 fooi_(&i__1);
17017 // FFEINTRIN_impNINT //
17018 i__1 = i_nint(&r1);
17019 fooi_(&i__1);
17020 // FFEINTRIN_impSIGN //
17021 r__1 = r_sign(&r1, &r2);
17022 foor_(&r__1);
17023 // FFEINTRIN_impSIN //
17024 r__1 = sin(r1);
17025 foor_(&r__1);
17026 // FFEINTRIN_impSINH //
17027 r__1 = sinh(r1);
17028 foor_(&r__1);
17029 // FFEINTRIN_impSQRT //
17030 r__1 = sqrt(r1);
17031 foor_(&r__1);
17032 // FFEINTRIN_impTAN //
17033 r__1 = tan(r1);
17034 foor_(&r__1);
17035 // FFEINTRIN_impTANH //
17036 r__1 = tanh(r1);
17037 foor_(&r__1);
17038 // FFEINTRIN_imp_CMPLX_C //
17039 r__1 = c1.r;
17040 r__2 = c2.r;
17041 q__1.r = r__1, q__1.i = r__2;
17042 fooc_(&q__1);
17043 // FFEINTRIN_imp_CMPLX_D //
17044 z__1.r = d1, z__1.i = d2;
17045 fooz_(&z__1);
17046 // FFEINTRIN_imp_CMPLX_I //
17047 r__1 = (real) i1;
17048 r__2 = (real) i2;
17049 q__1.r = r__1, q__1.i = r__2;
17050 fooc_(&q__1);
17051 // FFEINTRIN_imp_CMPLX_R //
17052 q__1.r = r1, q__1.i = r2;
17053 fooc_(&q__1);
17054 // FFEINTRIN_imp_DBLE_C //
17055 d__1 = (doublereal) c1.r;
17056 food_(&d__1);
17057 // FFEINTRIN_imp_DBLE_D //
17058 d__1 = d1;
17059 food_(&d__1);
17060 // FFEINTRIN_imp_DBLE_I //
17061 d__1 = (doublereal) i1;
17062 food_(&d__1);
17063 // FFEINTRIN_imp_DBLE_R //
17064 d__1 = (doublereal) r1;
17065 food_(&d__1);
17066 // FFEINTRIN_imp_INT_C //
17067 i__1 = (integer) c1.r;
17068 fooi_(&i__1);
17069 // FFEINTRIN_imp_INT_D //
17070 i__1 = (integer) d1;
17071 fooi_(&i__1);
17072 // FFEINTRIN_imp_INT_I //
17073 i__1 = i1;
17074 fooi_(&i__1);
17075 // FFEINTRIN_imp_INT_R //
17076 i__1 = (integer) r1;
17077 fooi_(&i__1);
17078 // FFEINTRIN_imp_REAL_C //
17079 r__1 = c1.r;
17080 foor_(&r__1);
17081 // FFEINTRIN_imp_REAL_D //
17082 r__1 = (real) d1;
17083 foor_(&r__1);
17084 // FFEINTRIN_imp_REAL_I //
17085 r__1 = (real) i1;
17086 foor_(&r__1);
17087 // FFEINTRIN_imp_REAL_R //
17088 r__1 = r1;
17089 foor_(&r__1);
17091 // FFEINTRIN_imp_INT_D: //
17093 // FFEINTRIN_specIDINT //
17094 i__1 = (integer) d1;
17095 fooi_(&i__1);
17097 // FFEINTRIN_imp_INT_R: //
17099 // FFEINTRIN_specIFIX //
17100 i__1 = (integer) r1;
17101 fooi_(&i__1);
17102 // FFEINTRIN_specINT //
17103 i__1 = (integer) r1;
17104 fooi_(&i__1);
17106 // FFEINTRIN_imp_REAL_D: //
17108 // FFEINTRIN_specSNGL //
17109 r__1 = (real) d1;
17110 foor_(&r__1);
17112 // FFEINTRIN_imp_REAL_I: //
17114 // FFEINTRIN_specFLOAT //
17115 r__1 = (real) i1;
17116 foor_(&r__1);
17117 // FFEINTRIN_specREAL //
17118 r__1 = (real) i1;
17119 foor_(&r__1);
17121 } // MAIN__ //
17123 -------- (end output file from f2c)
17125 */