/* com.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995-1998 Free Software Foundation, Inc.
+ Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
+ Free Software Foundation, Inc.
Contributed by James Craig Burley.
This file is part of GNU Fortran.
when it comes to building decls:
Internal Function (one we define, not just declare as extern):
- int yes;
- yes = suspend_momentary ();
if (is_nested) push_f_function_context ();
start_function (get_identifier ("function_name"), function_type,
is_nested, is_public);
ffecom_end_compstmt ();
finish_function (is_nested);
if (is_nested) pop_f_function_context ();
- if (is_nested) resume_momentary (yes);
Everything Else:
- int yes;
tree d;
tree init;
- yes = suspend_momentary ();
// fill in external, public, static, &c for decl, and
// set DECL_INITIAL to error_mark_node if going to initialize
// set is_top_level TRUE only if not at top level and decl
d = start_decl (decl, is_top_level);
init = ...; // if have initializer
finish_decl (d, init, is_top_level);
- resume_momentary (yes);
*/
#include "proj.h"
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#include "flags.j"
-#include "rtl.j"
-#include "toplev.j"
-#include "tree.j"
-#include "output.j" /* Must follow tree.j so TREE_CODE is defined! */
-#include "convert.j"
+#include "flags.h"
+#include "rtl.h"
+#include "toplev.h"
+#include "tree.h"
+#include "output.h" /* Must follow tree.h so TREE_CODE is defined! */
+#include "convert.h"
+#include "ggc.h"
#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
#define FFECOM_GCC_INCLUDE 1 /* Enable -I. */
# endif
#endif
-#ifndef RLIMIT_STACK
-# include <time.h>
-#else
-# if TIME_WITH_SYS_TIME
-# include <sys/time.h>
-# include <time.h>
-# else
-# if HAVE_SYS_TIME_H
-# include <sys/time.h>
-# else
-# include <time.h>
-# endif
-# endif
+#ifdef RLIMIT_STACK
# include <sys/resource.h>
#endif
typedef struct { unsigned :16, :16, :16; } vms_ino_t;
#define ino_t vms_ino_t
#define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */
-#ifdef __GNUC__
-#define BSTRING /* VMS/GCC supplies the bstring routines */
-#endif /* __GNUC__ */
#endif /* VMS */
#ifndef O_RDONLY
/* Externals defined here. */
-#define FFECOM_FASTER_ARRAY_REFS 0 /* Generates faster code? */
-
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-/* tree.h declares a bunch of stuff that it expects the front end to
- define. Here are the definitions, which in the C front end are
- found in the file c-decl.c. */
-
-tree integer_zero_node;
-tree integer_one_node;
-tree null_pointer_node;
-tree error_mark_node;
-tree void_type_node;
-tree integer_type_node;
-tree unsigned_type_node;
-tree char_type_node;
-tree current_function_decl;
-
/* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
reference it. */
-char *language_string = "GNU F77";
+const char * const language_string = "GNU F77";
/* Stream for reading from the input file. */
FILE *finput;
"static") are those that ste.c and such might use (directly
or by using com macros that reference them in their definitions). */
-static tree short_integer_type_node;
-tree long_integer_type_node;
-static tree long_long_integer_type_node;
-
-static tree short_unsigned_type_node;
-static tree long_unsigned_type_node;
-static tree long_long_unsigned_type_node;
-
-static tree unsigned_char_type_node;
-static tree signed_char_type_node;
-
-static tree float_type_node;
-static tree double_type_node;
-static tree complex_float_type_node;
-tree complex_double_type_node;
-static tree long_double_type_node;
-static tree complex_integer_type_node;
-static tree complex_long_double_type_node;
-
tree string_type_node;
-static tree double_ftype_double;
-static tree float_ftype_float;
-static tree ldouble_ftype_ldouble;
-
/* The rest of these are inventions for g77, though there might be
similar things in the C front end. As they are found, these
inventions should be renamed to be canonical. Note that only
the ones currently required to be global are so. */
static tree ffecom_tree_fun_type_void;
-static tree ffecom_tree_ptr_to_fun_type_void;
tree ffecom_integer_type_node; /* Abbrev for _tree_type[blah][blah]. */
tree ffecom_integer_zero_node; /* Like *_*_* with g77's integer type. */
ffebld left, ffebld right,
tree dest_tree, ffebld dest,
bool *dest_used, tree callee_commons,
- bool scalar_args, tree hook);
+ bool scalar_args, bool ref, tree hook);
static void ffecom_char_args_x_ (tree *xitem, tree *length,
ffebld expr, bool with_null);
static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
ffebld source);
static void ffecom_make_gfrt_ (ffecomGfrt ix);
static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
-#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
-#endif
static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
ffebld source);
static void ffecom_push_dummy_decls_ (ffebld dumlist,
ffeinfoBasictype bt,
ffeinfoKindtype kt);
static tree ffecom_type_namelist_ (void);
-#if 0
-static tree ffecom_type_permanent_copy_ (tree t);
-#endif
static tree ffecom_type_vardesc_ (void);
static tree ffecom_vardesc_ (ffebld expr);
static tree ffecom_vardesc_array_ (ffesymbol s);
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree bison_rule_compstmt_ (void);
static void bison_rule_pushlevel_ (void);
-static tree builtin_function (const char *name, tree type,
- enum built_in_function function_code,
- const char *library_name);
static void delete_block (tree block);
static int duplicate_decls (tree newdecl, tree olddecl);
static void finish_decl (tree decl, tree init, bool is_top_level);
static void finish_function (int nested);
-static char *lang_printable_name (tree decl, int v);
+static const char *lang_printable_name (tree decl, int v);
static tree lookup_name_current_level (tree name);
static struct binding_level *make_binding_level (void);
static void pop_f_function_context (void);
static void start_function (tree name, tree type, int nested, int public);
#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
#if FFECOM_GCC_INCLUDE
-static void ffecom_file_ (char *name);
+static void ffecom_file_ (const char *name);
static void ffecom_initialize_char_syntax_ (void);
static void ffecom_close_include_ (FILE *f);
static int ffecom_decode_include_option_ (char *spec);
static bool ffecom_member_namelisted_; /* _member_phase1_ namelisted? */
static bool ffecom_doing_entry_ = FALSE;
static bool ffecom_transform_only_dummies_ = FALSE;
+static int ffecom_typesize_pointer_;
+static int ffecom_typesize_integer1_;
/* Holds pointer-to-function expressions. */
static tree ffecom_gfrt_[FFECOM_gfrt]
=
{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NULL_TREE,
+#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
#include "com-rt.def"
#undef DEFGFRT
};
static const char *ffecom_gfrt_name_[FFECOM_gfrt]
=
{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NAME,
+#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
#include "com-rt.def"
#undef DEFGFRT
};
static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
=
{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) VOLATILE,
+#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
#include "com-rt.def"
#undef DEFGFRT
};
static bool ffecom_gfrt_complex_[FFECOM_gfrt]
=
{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) COMPLEX,
+#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
+#include "com-rt.def"
+#undef DEFGFRT
+};
+
+/* Whether the function is const
+ (i.e., has no side effects and only depends on its arguments). */
+
+static bool ffecom_gfrt_const_[FFECOM_gfrt]
+=
+{
+#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
#include "com-rt.def"
#undef DEFGFRT
};
static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
=
{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) TYPE,
+#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
#include "com-rt.def"
#undef DEFGFRT
};
static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
=
{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) ARGS,
+#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
#include "com-rt.def"
#undef DEFGFRT
};
it would be best to do something here to figure out automatically
from other information what type to use. */
-/* NOTE: g77 currently doesn't use these; see setting of sizetype and
- change that if you need to. -- jcb 09/01/91. */
+#ifndef SIZE_TYPE
+#define SIZE_TYPE "long unsigned int"
+#endif
#define ffecom_concat_list_count_(catlist) ((catlist).count)
#define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
static tree
ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
- char *array_name)
+ const char *array_name)
{
tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
if (element == error_mark_node)
return element;
+ if (TREE_TYPE (low) != TREE_TYPE (element))
+ {
+ if (TYPE_PRECISION (TREE_TYPE (low))
+ > TYPE_PRECISION (TREE_TYPE (element)))
+ element = convert (TREE_TYPE (low), element);
+ else
+ {
+ low = convert (TREE_TYPE (element), low);
+ if (high)
+ high = convert (TREE_TYPE (element), high);
+ }
+ }
+
element = ffecom_save_tree (element);
cond = ffecom_2 (LE_EXPR, integer_type_node,
low,
{
case 0:
var = xmalloc (strlen (array_name) + 20);
- sprintf (&var[0], "%s[%s-substring]",
+ sprintf (var, "%s[%s-substring]",
array_name,
dim ? "end" : "start");
len = strlen (var) + 1;
+ arg1 = build_string (len, var);
+ free (var);
break;
case 1:
len = strlen (array_name) + 1;
- var = array_name;
+ arg1 = build_string (len, array_name);
break;
default:
var = xmalloc (strlen (array_name) + 40);
- sprintf (&var[0], "%s[subscript-%d-of-%d]",
+ sprintf (var, "%s[subscript-%d-of-%d]",
array_name,
dim + 1, total_dims);
len = strlen (var) + 1;
+ arg1 = build_string (len, var);
+ free (var);
break;
}
- arg1 = build_string (len, var);
-
- if (total_dims != 1)
- free (var);
-
TREE_TYPE (arg1)
= build_type_variant (build_array_type (char_type_node,
build_range_type
/* Return the computed element of an array reference.
- `item' is the array or a pointer to the array. It must be a pointer
- to the array if ffe_is_flat_arrays ().
- `expr' is the original opARRAYREF expression.
- `want_ptr' is non-zero if `item' is a pointer to the element, instead of
+ `item' is NULL_TREE, or the transformed pointer to the array.
+ `expr' is the original opARRAYREF expression, which is transformed
+ if `item' is NULL_TREE.
+ `want_ptr' is non-zero if a pointer to the element, instead of
the element itself, is to be returned. */
static tree
ffebld dims[FFECOM_dimensionsMAX];
int i;
int total_dims;
- int flatten = 0 /* ~~~ ffe_is_flat_arrays () */;
- int need_ptr = want_ptr || flatten;
+ int flatten = ffe_is_flatten_arrays ();
+ int need_ptr;
tree array;
tree element;
- char *array_name;
+ tree tree_type;
+ tree tree_type_x;
+ const char *array_name;
+ ffetype type;
+ ffebld list;
if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
/* Build up ARRAY_REFs in reverse order (since we're column major
here in Fortran land). */
- for (i = 0, expr = ffebld_right (expr);
- expr != NULL;
- expr = ffebld_trail (expr))
- dims[i++] = ffebld_head (expr);
+ for (i = 0, list = ffebld_right (expr);
+ list != NULL;
+ ++i, list = ffebld_trail (list))
+ {
+ dims[i] = ffebld_head (list);
+ type = ffeinfo_type (ffebld_basictype (dims[i]),
+ ffebld_kindtype (dims[i]));
+ if (! flatten
+ && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
+ && ffetype_size (type) > ffecom_typesize_integer1_)
+ /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
+ pointers and 32-bit integers. Do the full 64-bit pointer
+ arithmetic, for codes using arrays for nonstandard heap-like
+ work. */
+ flatten = 1;
+ }
total_dims = i;
+ need_ptr = want_ptr || flatten;
+
+ if (! item)
+ {
+ if (need_ptr)
+ item = ffecom_ptr_to_expr (ffebld_left (expr));
+ else
+ item = ffecom_expr (ffebld_left (expr));
+
+ if (item == error_mark_node)
+ return item;
+
+ if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
+ && ! mark_addressable (item))
+ return error_mark_node;
+ }
+
+ if (item == error_mark_node)
+ return item;
+
if (need_ptr)
{
+ tree min;
+
for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
i >= 0;
--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
{
- element = ffecom_expr (dims[i]);
- if (ffe_is_subscript_check ())
+ min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
+ element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
+ if (flag_bounds_check)
element = ffecom_subscript_check_ (array, element, i, total_dims,
array_name);
+ if (element == error_mark_node)
+ return element;
+
+ /* Widen integral arithmetic as desired while preserving
+ signedness. */
+ tree_type = TREE_TYPE (element);
+ tree_type_x = tree_type;
+ if (tree_type
+ && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
+ && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
+ tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
+
+ if (TREE_TYPE (min) != tree_type_x)
+ min = convert (tree_type_x, min);
+ if (TREE_TYPE (element) != tree_type_x)
+ element = convert (tree_type_x, element);
+
item = ffecom_2 (PLUS_EXPR,
build_pointer_type (TREE_TYPE (array)),
item,
size_in_bytes (TREE_TYPE (array)),
convert (sizetype,
fold (build (MINUS_EXPR,
- TREE_TYPE (TYPE_MIN_VALUE (TYPE_DOMAIN (array))),
- element,
- TYPE_MIN_VALUE (TYPE_DOMAIN (array)))))));
+ tree_type_x,
+ element, min)))));
}
if (! want_ptr)
{
array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
- if (ffe_is_subscript_check ())
+ if (flag_bounds_check)
element = ffecom_subscript_check_ (array, element, i, total_dims,
array_name);
+ if (element == error_mark_node)
+ return element;
+
+ /* Widen integral arithmetic as desired while preserving
+ signedness. */
+ tree_type = TREE_TYPE (element);
+ tree_type_x = tree_type;
+ if (tree_type
+ && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
+ && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
+ tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
+
+ element = convert (tree_type_x, element);
+
item = ffecom_2 (ARRAY_REF,
TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
item,
break;
case RTL_EXPR:
- result = build1 (INDIRECT_REF, TREE_TYPE (ref),
- save_expr (build1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (ref)),
- ref)));
- break;
+ abort ();
default:
TREE_READONLY (result) = TREE_READONLY (ref);
TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
- TREE_RAISES (result) = TREE_RAISES (ref);
return result;
}
}
#endif
+/* Check whether a partial overlap between two expressions is possible.
+
+ Can *starting* to write a portion of expr1 change the value
+ computed (perhaps already, *partially*) by expr2?
+
+ Currently, this is a concern only for a COMPLEX expr1. But if it
+ isn't in COMMON or local EQUIVALENCE, since we don't support
+ aliasing of arguments, it isn't a concern. */
+
+static bool
+ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
+{
+ ffesymbol sym;
+ ffestorag st;
+
+ switch (ffebld_op (expr1))
+ {
+ case FFEBLD_opSYMTER:
+ sym = ffebld_symter (expr1);
+ break;
+
+ case FFEBLD_opARRAYREF:
+ if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
+ return FALSE;
+ sym = ffebld_symter (ffebld_left (expr1));
+ break;
+
+ default:
+ return FALSE;
+ }
+
+ if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
+ && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
+ || ! (st = ffesymbol_storage (sym))
+ || ! ffestorag_parent (st)))
+ return FALSE;
+
+ /* It's in COMMON or local EQUIVALENCE. */
+
+ return TRUE;
+}
+
/* Check whether dest and source might overlap. ffebld versions of these
might or might not be passed, will be NULL if not.
return TRUE;
source_decl = source_tree;
- source_offset = size_zero_node;
+ source_offset = bitsize_zero_node;
source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
break;
tmp = &space[0];
for (p = s, q = tmp; *p != '\0'; ++p, ++q)
- *q = ffesrc_toupper (*p);
+ *q = TOUPPER (*p);
*q = '\0';
t = build_string (i, tmp);
ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
tree type, ffebld left, ffebld right,
tree dest_tree, ffebld dest, bool *dest_used,
- tree callee_commons, bool scalar_args, tree hook)
+ tree callee_commons, bool scalar_args, bool ref, tree hook)
{
tree left_tree;
tree right_tree;
tree left_length;
tree right_length;
- left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
- right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
+ if (ref)
+ {
+ /* Pass arguments by reference. */
+ left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
+ right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
+ }
+ else
+ {
+ /* Pass arguments by value. */
+ left_tree = ffecom_arg_expr (left, &left_length);
+ right_tree = ffecom_arg_expr (right, &right_length);
+ }
+
left_tree = build_tree_list (NULL_TREE, left_tree);
right_tree = build_tree_list (NULL_TREE, right_tree);
ffebld thing = ffebld_right (expr);
tree start_tree;
tree end_tree;
- char *char_name;
+ const char *char_name;
ffebld left_symter;
tree array;
array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
+ /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
+
if (start == NULL)
{
if (end == NULL)
else
{
end_tree = ffecom_expr (end);
- if (ffe_is_subscript_check ())
+ if (flag_bounds_check)
end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
char_name);
end_tree = convert (ffecom_f2c_ftnlen_type_node,
else
{
start_tree = ffecom_expr (start);
- if (ffe_is_subscript_check ())
+ if (flag_bounds_check)
start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
char_name);
start_tree = convert (ffecom_f2c_ftnlen_type_node,
else
{
end_tree = ffecom_expr (end);
- if (ffe_is_subscript_check ())
+ if (flag_bounds_check)
end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
char_name);
end_tree = convert (ffecom_f2c_ftnlen_type_node,
{
if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
tlen = ffecom_get_invented_identifier ("__g77_length_%s",
- ffesymbol_text (s), -1);
+ ffesymbol_text (s));
else
- tlen = ffecom_get_invented_identifier ("__g77_%s",
- "length", -1);
+ tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
#if BUILT_FOR_270
DECL_ARTIFICIAL (tlen) = 1;
bool cmplxfunc; /* Use f2c way of returning COMPLEX. */
bool multi; /* Master fn has multiple return types. */
bool altreturning = FALSE; /* This entry point has alternate returns. */
- int yes;
int old_lineno = lineno;
- char *old_input_filename = input_filename;
+ const char *old_input_filename = input_filename;
input_filename = ffesymbol_where_filename (fn);
lineno = ffesymbol_where_filelinenum (fn);
- /* c-parse.y indeed does call suspend_momentary and not only ignores the
- return value, but also never calls resume_momentary, when starting an
- outer function (see "fndef:", "setspecs:", and so on). So g77 does the
- same thing. It shouldn't be a problem since start_function calls
- temporary_allocation, but it might be necessary. If it causes a problem
- here, then maybe there's a bug lurking in gcc. NOTE: This identical
- comment appears twice in thist file. */
-
- suspend_momentary ();
-
ffecom_doing_entry_ = TRUE; /* Don't bother with array dimensions. */
switch (ffecom_primary_entry_kind_)
/* Build dummy arg list for this entry point. */
- yes = suspend_momentary ();
-
if (charfunc || cmplxfunc)
{ /* Prepend arg for where result goes. */
tree type;
else
type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
- result = ffecom_get_invented_identifier ("__g77_%s",
- "result", -1);
+ result = ffecom_get_invented_identifier ("__g77_%s", "result");
/* Make length arg _and_ enhance type info for CHAR arg itself. */
ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
- resume_momentary (yes);
-
store_parm_decls (0);
ffecom_start_compstmt ();
if (multi)
{
- yes = suspend_momentary ();
-
multi_retval = ffecom_get_invented_identifier ("__g77_%s",
- "multi_retval", -1);
+ "multi_retval");
multi_retval = build_decl (VAR_DECL, multi_retval,
ffecom_multi_type_node_);
multi_retval = start_decl (multi_retval, FALSE);
finish_decl (multi_retval, NULL_TREE, FALSE);
-
- resume_momentary (yes);
}
else
multi_retval = NULL_TREE; /* Not actually ref'd if !multi. */
call));
expand_return (result);
}
-
- clear_momentary ();
}
ffecom_end_compstmt ();
return t;
case FFEBLD_opARRAYREF:
- {
- if (0 /* ~~~~~ ffe_is_flat_arrays () */)
- t = ffecom_ptr_to_expr (ffebld_left (expr));
- else
- t = ffecom_expr (ffebld_left (expr));
-
- if (t == error_mark_node)
- return t;
-
- if ((ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING)
- && !mark_addressable (t))
- return error_mark_node; /* Make sure non-const ref is to
- non-reg. */
-
- t = ffecom_arrayref_ (t, expr, 0);
-
- return t;
- }
+ return ffecom_arrayref_ (NULL_TREE, expr, 0);
case FFEBLD_opUPLUS:
left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
ffecomGfrt code;
ffeinfoKindtype rtkt;
ffeinfoKindtype ltkt;
+ bool ref = TRUE;
switch (ffeinfo_basictype (ffebld_info (right)))
{
+
case FFEINFO_basictypeINTEGER:
if (1 || optimize)
{
FFEINFO_kindtypeREALDOUBLE, 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
- code = FFECOM_gfrtPOW_DD;
+ /* We used to call FFECOM_gfrtPOW_DD here,
+ which passes arguments by reference. */
+ code = FFECOM_gfrtL_POW;
+ /* Pass arguments by value. */
+ ref = FALSE;
break;
case FFEINFO_basictypeCOMPLEX:
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
code = FFECOM_gfrtPOW_ZZ; /* Overlapping result okay. */
+ ref = TRUE; /* Pass arguments by reference. */
break;
default:
&& ffecom_gfrt_complex_[code]),
tree_type, left, right,
dest_tree, dest, dest_used,
- NULL_TREE, FALSE,
+ NULL_TREE, FALSE, ref,
ffebld_nonter_hook (expr));
}
break; /* Already picked one, stick with it. */
if (kt == FFEINFO_kindtypeREAL1)
- gfrt = FFECOM_gfrtALOG10;
+ /* We used to call FFECOM_gfrtALOG10 here. */
+ gfrt = FFECOM_gfrtL_LOG10;
else if (kt == FFEINFO_kindtypeREAL2)
- gfrt = FFECOM_gfrtDLOG10;
+ /* We used to call FFECOM_gfrtDLOG10 here. */
+ gfrt = FFECOM_gfrtL_LOG10;
break;
case FFEINTRIN_impMAX:
convert (tree_type, ffecom_expr (arg2)));
if (kt == FFEINFO_kindtypeREAL1)
- gfrt = FFECOM_gfrtAMOD;
+ /* We used to call FFECOM_gfrtAMOD here. */
+ gfrt = FFECOM_gfrtL_FMOD;
else if (kt == FFEINFO_kindtypeREAL2)
- gfrt = FFECOM_gfrtDMOD;
+ /* We used to call FFECOM_gfrtDMOD here. */
+ gfrt = FFECOM_gfrtL_FMOD;
break;
case FFEINTRIN_impNINT:
arg1_tree);
arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
- arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
+ if (arg3 != NULL)
+ arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
+ else
+ arg3_tree = NULL_TREE;
arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
arg1_tree,
NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
ffebld_nonter_hook (expr));
- expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
- convert (TREE_TYPE (arg3_tree),
- expr_tree));
+ if (arg3_tree != NULL_TREE)
+ expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
+ convert (TREE_TYPE (arg3_tree),
+ expr_tree));
}
return expr_tree;
tree arg1_tree;
tree arg2_tree;
- arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
+ arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
- arg2_tree = convert (((gfrt == FFEINTRIN_impCTIME_subr) ?
+ arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
ffecom_f2c_longint_type_node :
ffecom_f2c_integer_type_node),
- ffecom_expr (arg2));
+ ffecom_expr (arg1));
arg2_tree = ffecom_1 (ADDR_EXPR,
build_pointer_type (TREE_TYPE (arg2_tree)),
arg2_tree);
arg1_tree,
NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
ffebld_nonter_hook (expr));
+ TREE_SIDE_EFFECTS (expr_tree) = 1;
}
return expr_tree;
case FFEINTRIN_impETIME_subr:
{
tree arg1_tree;
- tree arg2_tree;
+ tree result_tree;
- arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
+ result_tree = ffecom_expr_w (NULL_TREE, arg2);
- arg2_tree = ffecom_ptr_to_expr (arg2);
+ arg1_tree = ffecom_ptr_to_expr (arg1);
expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
ffecom_gfrt_kindtype (gfrt),
FALSE,
NULL_TREE,
- build_tree_list (NULL_TREE, arg2_tree),
+ build_tree_list (NULL_TREE, arg1_tree),
NULL_TREE, NULL, NULL, NULL_TREE,
TRUE,
ffebld_nonter_hook (expr));
- expr_tree = ffecom_modify (NULL_TREE, arg1_tree,
- convert (TREE_TYPE (arg1_tree),
+ expr_tree = ffecom_modify (NULL_TREE, result_tree,
+ convert (TREE_TYPE (result_tree),
expr_tree));
}
return expr_tree;
}
pushdecl (build_decl (TYPE_DECL,
- ffecom_get_invented_identifier ("__g77_f2c_%s",
- name, -1),
+ ffecom_get_invented_identifier ("__g77_f2c_%s", name),
*type));
}
tree t;
for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
- if (((t = ffecom_tree_type[bt][j]) != NULL_TREE)
- && (TREE_INT_CST_LOW (TYPE_SIZE (t)) == size))
+ if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
+ && compare_tree_int (TYPE_SIZE (t), size) == 0)
{
assert (code != -1);
ffecom_f2c_typecode_[bt][j] = code;
|| !ffeglobal_common_have_size (global))
return global; /* No need to make common, never ref'd. */
- suspend_momentary ();
-
DECL_EXTERNAL (cbt) = 0;
/* Give the array a size now. */
if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
&& (ffesymbol_hook (s).decl_tree != error_mark_node))
{
-#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
- int yes = suspend_momentary ();
-
/* This isn't working, at least for dbxout. The .s file looks
okay to me (burley), but in gdb 4.9 at least, the variables
appear to reside somewhere outside of the common area, so
with EQUIVALENCE, sadly...see similar #if later. */
ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
ffesymbol_storage (s));
-
- resume_momentary (yes);
-#endif
}
return s;
tree result;
bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
static bool recurse = FALSE;
- int yes;
int old_lineno = lineno;
- char *old_input_filename = input_filename;
+ const char *old_input_filename = input_filename;
ffecom_nested_entry_ = s;
assert (!recurse);
recurse = TRUE;
- yes = suspend_momentary ();
-
push_f_function_context ();
if (charfunc)
entirely internal to our code, and gcc has the ability to return COMPLEX
directly as a value. */
- yes = suspend_momentary ();
-
if (charfunc)
{ /* Prepend arg for where result goes. */
tree type;
type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
- result = ffecom_get_invented_identifier ("__g77_%s",
- "result", -1);
+ result = ffecom_get_invented_identifier ("__g77_%s", "result");
ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */
ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
- resume_momentary (yes);
-
store_parm_decls (0);
ffecom_start_compstmt ();
DECL_RESULT (current_function_decl),
ffecom_expr (expr)));
}
-
- clear_momentary ();
}
ffecom_end_compstmt ();
pop_f_function_context ();
- resume_momentary (yes);
-
recurse = FALSE;
lineno = old_lineno;
/* Return initialize-to-zero expression for this VAR_DECL. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
+/* A somewhat evil way to prevent the garbage collector
+ from collecting 'tree' structures. */
+#define NUM_TRACKED_CHUNK 63
+static struct tree_ggc_tracker
+{
+ struct tree_ggc_tracker *next;
+ tree trees[NUM_TRACKED_CHUNK];
+} *tracker_head = NULL;
+
+static void
+mark_tracker_head (void *arg)
+{
+ struct tree_ggc_tracker *head;
+ int i;
+
+ for (head = * (struct tree_ggc_tracker **) arg;
+ head != NULL;
+ head = head->next)
+ {
+ ggc_mark (head);
+ for (i = 0; i < NUM_TRACKED_CHUNK; i++)
+ ggc_mark_tree (head->trees[i]);
+ }
+}
+
+void
+ffecom_save_tree_forever (tree t)
+{
+ int i;
+ if (tracker_head != NULL)
+ for (i = 0; i < NUM_TRACKED_CHUNK; i++)
+ if (tracker_head->trees[i] == NULL)
+ {
+ tracker_head->trees[i] = t;
+ return;
+ }
+
+ {
+ /* Need to allocate a new block. */
+ struct tree_ggc_tracker *old_head = tracker_head;
+
+ tracker_head = ggc_alloc (sizeof (*tracker_head));
+ tracker_head->next = old_head;
+ tracker_head->trees[0] = t;
+ for (i = 1; i < NUM_TRACKED_CHUNK; i++)
+ tracker_head->trees[i] = NULL;
+ }
+}
+
static tree
ffecom_init_zero_ (tree decl)
{
if (incremental)
{
- int momentary = suspend_momentary ();
- push_obstacks_nochange ();
- if (TREE_PERMANENT (decl))
- end_temporary_allocation ();
- make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
+ make_decl_rtl (decl, NULL);
assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
- pop_obstacks ();
- resume_momentary (momentary);
}
- push_momentary ();
-
if ((TREE_CODE (type) != ARRAY_TYPE)
&& (TREE_CODE (type) != RECORD_TYPE)
&& (TREE_CODE (type) != UNION_TYPE)
init = convert (type, integer_zero_node);
else if (!incremental)
{
- int momentary = suspend_momentary ();
-
init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
TREE_CONSTANT (init) = 1;
TREE_STATIC (init) = 1;
-
- resume_momentary (momentary);
}
else
{
- int momentary = suspend_momentary ();
-
assemble_zeros (int_size_in_bytes (type));
init = error_mark_node;
-
- resume_momentary (momentary);
}
- pop_momentary_nofree ();
-
return init;
}
tree t;
tree ttype;
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
switch (ffecom_gfrt_type_[ix])
{
case FFECOM_rttypeVOID_:
get_identifier (ffecom_gfrt_name_[ix]),
ttype);
DECL_EXTERNAL (t) = 1;
+ TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
TREE_PUBLIC (t) = 1;
TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
+ /* Sanity check: A function that's const cannot be volatile. */
+
+ assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
+
+ /* Sanity check: A function that's const cannot return complex. */
+
+ assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
+
t = start_decl (t, TRUE);
finish_decl (t, NULL_TREE, TRUE);
- resume_temporary_allocation ();
- pop_obstacks ();
-
ffecom_gfrt_[ix] = t;
}
referencing the member. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
static void
ffecom_member_phase2_ (ffestorag mst, ffestorag st)
{
TREE_STATIC (t) = TREE_STATIC (mt);
DECL_INITIAL (t) = NULL_TREE;
TREE_ASM_WRITTEN (t) = 1;
+ TREE_USED (t) = 1;
DECL_RTL (t)
= gen_rtx (MEM, TYPE_MODE (type),
}
#endif
-#endif
/* Prepare source expression for assignment into a destination perhaps known
to be of a specific size. */
&& (ffecom_master_bt_ == FFEINFO_basictypeNONE);
bool main_program = FALSE;
int old_lineno = lineno;
- char *old_input_filename = input_filename;
- int yes;
+ const char *old_input_filename = input_filename;
assert (fn != NULL);
assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
input_filename = ffesymbol_where_filename (fn);
lineno = ffesymbol_where_filelinenum (fn);
- /* c-parse.y indeed does call suspend_momentary and not only ignores the
- return value, but also never calls resume_momentary, when starting an
- outer function (see "fndef:", "setspecs:", and so on). So g77 does the
- same thing. It shouldn't be a problem since start_function calls
- temporary_allocation, but it might be necessary. If it causes a problem
- here, then maybe there's a bug lurking in gcc. NOTE: This identical
- comment appears twice in thist file. */
-
- suspend_momentary ();
-
switch (ffecom_primary_entry_kind_)
{
case FFEINFO_kindPROGRAM:
if (altentries)
{
id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
- ffesymbol_text (fn),
- -1);
+ ffesymbol_text (fn));
}
#if FFETARGET_isENFORCED_MAIN
else if (main_program)
ffeglobal_set_hook (g, current_function_decl);
}
- yes = suspend_momentary ();
-
/* Arg handling needs exec-transitioned ffesymbols to work with. But
exec-transitioning needs current_function_decl to be filled in. So we
do these things in two phases. */
ffecom_which_entrypoint_decl_
= build_decl (PARM_DECL,
ffecom_get_invented_identifier ("__g77_%s",
- "which_entrypoint",
- -1),
+ "which_entrypoint"),
integer_type_node);
push_parm_decl (ffecom_which_entrypoint_decl_);
}
else
type = ffecom_multi_type_node_;
- result = ffecom_get_invented_identifier ("__g77_%s",
- "result", -1);
+ result = ffecom_get_invented_identifier ("__g77_%s", "result");
/* Make length arg _and_ enhance type info for CHAR arg itself. */
ffecom_push_dummy_decls_ (arglist, FALSE);
}
- resume_momentary (yes);
-
if (TREE_CODE (current_function_decl) != ERROR_MARK)
store_parm_decls (main_program ? 1 : 0);
ffeinfoBasictype bt;
ffeinfoKindtype kt;
ffeglobal g;
- int yes;
int old_lineno = lineno;
- char *old_input_filename = input_filename;
+ const char *old_input_filename = input_filename;
/* Must ensure special ASSIGN variables are declared at top of outermost
block, else they'll end up in the innermost block when their first
break;
}
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
t = build_decl (FUNCTION_DECL,
ffecom_get_external_identifier_ (s),
ffecom_tree_subr_type); /* Assume subr. */
|| (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
ffeglobal_set_hook (g, t);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ffecom_save_tree_forever (t);
break;
break;
}
- yes = suspend_momentary ();
type = ffecom_type_localvar_ (s, bt, kt);
- resume_momentary (yes);
if (type == error_mark_node)
{
{ /* Child of EQUIVALENCE parent. */
ffestorag est;
tree et;
- int yes;
ffetargetOffset offset;
est = ffestorag_parent (st);
if (! TREE_STATIC (et))
put_var_into_stack (et);
- yes = suspend_momentary ();
-
offset = ffestorag_modulo (est)
+ ffestorag_offset (ffesymbol_storage (s))
- ffestorag_offset (est);
TREE_CONSTANT (t) = staticp (et);
addr = TRUE;
-
- resume_momentary (yes);
}
else
{
tree initexpr;
bool init = ffesymbol_is_init (s);
- yes = suspend_momentary ();
-
t = build_decl (VAR_DECL,
ffecom_get_identifier_ (ffesymbol_text (s)),
type);
finish_decl (t, initexpr, FALSE);
- if ((st != NULL) && (DECL_SIZE (t) != error_mark_node))
+ if (st != NULL && DECL_SIZE (t) != error_mark_node)
{
- tree size_tree;
-
- size_tree = size_binop (CEIL_DIV_EXPR,
- DECL_SIZE (t),
- size_int (BITS_PER_UNIT));
- assert (TREE_INT_CST_HIGH (size_tree) == 0);
- assert (TREE_INT_CST_LOW (size_tree) == ffestorag_size (st));
+ assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
+ assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
+ ffestorag_size (st)));
}
-
- resume_momentary (yes);
}
}
break;
if ((ffecom_num_entrypoints_ != 0)
&& (ffecom_master_bt_ == FFEINFO_basictypeNONE))
{
- yes = suspend_momentary ();
-
assert (ffecom_multi_retval_ != NULL_TREE);
t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
ffecom_multi_retval_);
t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
t, ffecom_multi_fields_[bt][kt]);
- resume_momentary (yes);
break;
}
- yes = suspend_momentary ();
-
t = build_decl (VAR_DECL,
ffecom_get_identifier_ (ffesymbol_text (s)),
ffecom_tree_type[bt][kt]);
ffecom_func_result_ = t;
- resume_momentary (yes);
break;
case FFEINFO_whereDUMMY:
tree ct;
ffestorag st = ffesymbol_storage (s);
tree type;
- int yes;
cs = ffesymbol_common (s); /* The COMMON area itself. */
if (st != NULL) /* Else not laid out. */
st = ffesymbol_storage (s);
}
- yes = suspend_momentary ();
-
type = ffecom_type_localvar_ (s, bt, kt);
cg = ffesymbol_global (cs); /* The global COMMON info. */
addr = TRUE;
}
-
- resume_momentary (yes);
}
break;
break;
}
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
if (ffesymbol_is_f2c (s)
&& (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
t = ffecom_tree_fun_type[bt][kt];
|| (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
ffeglobal_set_hook (g, t);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ffecom_save_tree_forever (t);
break;
break;
}
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
t = build_decl (FUNCTION_DECL,
ffecom_get_external_identifier_ (s),
ffecom_tree_subr_type);
|| (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
ffeglobal_set_hook (g, t);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ffecom_save_tree_forever (t);
break;
case FFEINFO_whereGLOBAL:
assert (!ffecom_transform_only_dummies_);
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
t = build_decl (FUNCTION_DECL,
ffecom_get_external_identifier_ (s),
ffecom_tree_blockdata_type);
t = start_decl (t, FALSE);
finish_decl (t, NULL_TREE, FALSE);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ffecom_save_tree_forever (t);
break;
ffecom_sym_transform_assign_ (ffesymbol s)
{
tree t; /* Transformed thingy. */
- int yes;
int old_lineno = lineno;
- char *old_input_filename = input_filename;
+ const char *old_input_filename = input_filename;
if (ffesymbol_sfdummyparent (s) == NULL)
{
assert (!ffecom_transform_only_dummies_);
- yes = suspend_momentary ();
-
t = build_decl (VAR_DECL,
ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
- ffesymbol_text (s),
- -1),
+ ffesymbol_text (s)),
TREE_TYPE (null_pointer_node));
switch (ffesymbol_where (s))
t = start_decl (t, FALSE);
finish_decl (t, NULL_TREE, FALSE);
- resume_momentary (yes);
-
ffesymbol_hook (s).assign_tree = t;
lineno = old_lineno;
if ((cbt != NULL_TREE)
&& (!is_init
|| !DECL_EXTERNAL (cbt)))
- return;
+ {
+ if (st->hook == NULL) ffestorag_set_hook (st, cbt);
+ return;
+ }
/* Process inits. */
else
init = NULL_TREE;
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
/* cbtype must be permanently allocated! */
/* Allocate the MAX of the areas so far, seen filewide. */
this seems easy enough. */
DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
+ DECL_USER_ALIGN (cbt) = 0;
if (is_init && (ffestorag_init (st) == NULL))
init = ffecom_init_zero_ (cbt);
if (init)
{
- tree size_tree;
-
- assert (DECL_SIZE (cbt) != NULL_TREE);
- assert (TREE_CODE (DECL_SIZE (cbt)) == INTEGER_CST);
- size_tree = size_binop (CEIL_DIV_EXPR,
- DECL_SIZE (cbt),
- size_int (BITS_PER_UNIT));
- assert (TREE_INT_CST_HIGH (size_tree) == 0);
- assert (TREE_INT_CST_LOW (size_tree)
- == ffeglobal_common_size (g) + ffeglobal_common_pad (g));
+ assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
+ assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
+ assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
+ (ffeglobal_common_size (g)
+ + ffeglobal_common_pad (g))));
}
ffeglobal_set_hook (g, cbt);
ffestorag_set_hook (st, cbt);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ffecom_save_tree_forever (cbt);
}
#endif
tree init;
tree high;
bool is_init = ffestorag_is_init (eqst);
- int yes;
assert (eqst != NULL);
&ffecom_member_phase1_,
eqst);
- yes = suspend_momentary ();
-
high = build_int_2 ((ffestorag_size (eqst)
+ ffestorag_modulo (eqst)) - 1, 0);
TREE_TYPE (high) = ffecom_integer_type_node;
eqt = build_decl (VAR_DECL,
ffecom_get_invented_identifier ("__g77_equiv_%s",
ffesymbol_text
- (ffestorag_symbol
- (eqst)),
- -1),
+ (ffestorag_symbol (eqst))),
eqtype);
DECL_EXTERNAL (eqt) = 0;
if (is_init
else
TREE_STATIC (eqt) = 0;
TREE_PUBLIC (eqt) = 0;
+ TREE_ADDRESSABLE (eqt) = 1; /* Ensure non-register allocation */
DECL_CONTEXT (eqt) = current_function_decl;
if (init)
DECL_INITIAL (eqt) = error_mark_node;
this seems easy enough. */
DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
+ DECL_USER_ALIGN (eqt) = 0;
if ((!is_init && ffe_is_init_local_zero ())
|| (is_init && (ffestorag_init (eqst) == NULL)))
ffestorag_set_init (eqst, ffebld_new_any ());
{
- tree size_tree;
-
- size_tree = size_binop (CEIL_DIV_EXPR,
- DECL_SIZE (eqt),
- size_int (BITS_PER_UNIT));
- assert (TREE_INT_CST_HIGH (size_tree) == 0);
- assert (TREE_INT_CST_LOW (size_tree)
- == ffestorag_size (eqst) + ffestorag_modulo (eqst));
+ assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
+ assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
+ (ffestorag_size (eqst)
+ + ffestorag_modulo (eqst))));
}
ffestorag_set_hook (eqst, eqt);
-#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
ffestorag_drive (ffestorag_list_equivs (eqst),
&ffecom_member_phase2_,
eqst);
-#endif
-
- resume_momentary (yes);
}
#endif
tree nvarsinit;
tree field;
tree high;
- int yes;
int i;
static int mynumber = 0;
- yes = suspend_momentary ();
-
nmlt = build_decl (VAR_DECL,
ffecom_get_invented_identifier ("__g77_namelist_%d",
- NULL, mynumber++),
+ mynumber++),
nmltype);
TREE_STATIC (nmlt) = 1;
DECL_INITIAL (nmlt) = error_mark_node;
nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
- resume_momentary (yes);
-
return nmlt;
}
if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
{
/* An offset into COMMON. */
- *offset = size_binop (PLUS_EXPR,
- *offset,
- TREE_OPERAND (t, 1));
+ *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
+ *offset, TREE_OPERAND (t, 1)));
/* Convert offset (presumably in bytes) into canonical units
(presumably bits). */
*offset = size_binop (MULT_EXPR,
- TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))),
- *offset);
+ convert (bitsizetype, *offset),
+ TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
break;
}
/* Not a COMMON reference, so an unrecognized pattern. */
case PARM_DECL:
*decl = t;
- *offset = bitsize_int (0L, 0L);
+ *offset = bitsize_zero_node;
break;
case ADDR_EXPR:
{
/* A reference to COMMON. */
*decl = TREE_OPERAND (t, 0);
- *offset = bitsize_int (0L, 0L);
+ *offset = bitsize_zero_node;
break;
}
/* Fall through. */
case VAR_DECL:
case PARM_DECL:
*decl = t;
- *offset = bitsize_int (0L, 0L);
+ *offset = bitsize_zero_node;
*size = TYPE_SIZE (TREE_TYPE (t));
return;
|| (*decl == error_mark_node))
return;
+ /* Calculate ((element - base) * NBBY) + init_offset. */
+ *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
+ element,
+ TYPE_MIN_VALUE (TYPE_DOMAIN
+ (TREE_TYPE (array)))));
+
*offset = size_binop (MULT_EXPR,
- TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))),
- size_binop (MINUS_EXPR,
- element,
- TYPE_MIN_VALUE
- (TYPE_DOMAIN
- (TREE_TYPE (array)))));
+ convert (bitsizetype, *offset),
+ TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
- *offset = size_binop (PLUS_EXPR,
- init_offset,
- *offset);
+ *offset = size_binop (PLUS_EXPR, init_offset, *offset);
*size = TYPE_SIZE (TREE_TYPE (t));
return;
right);
case COMPLEX_TYPE:
+ if (! optimize_size)
+ return ffecom_2 (RDIV_EXPR, tree_type,
+ left,
+ right);
{
ffecomGfrt ix;
vardesctype = ffecom_type_vardesc_ ();
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
type = make_node (RECORD_TYPE);
vardesctype = build_pointer_type (build_pointer_type (vardesctype));
TYPE_FIELDS (type) = namefield;
layout_type (type);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ggc_add_tree_root (&type, 1);
}
return type;
#endif
-/* Make a copy of a type, assuming caller has switched to the permanent
- obstacks and that the type is for an aggregate (array) initializer. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC && 0 /* Not used now. */
-static tree
-ffecom_type_permanent_copy_ (tree t)
-{
- tree domain;
- tree max;
-
- assert (TREE_TYPE (t) != NULL_TREE);
-
- domain = TYPE_DOMAIN (t);
-
- assert (TREE_CODE (t) == ARRAY_TYPE);
- assert (TREE_PERMANENT (TREE_TYPE (t)));
- assert (TREE_PERMANENT (TREE_TYPE (domain)));
- assert (TREE_PERMANENT (TYPE_MIN_VALUE (domain)));
-
- max = TYPE_MAX_VALUE (domain);
- if (!TREE_PERMANENT (max))
- {
- assert (TREE_CODE (max) == INTEGER_CST);
-
- max = build_int_2 (TREE_INT_CST_LOW (max), TREE_INT_CST_HIGH (max));
- TREE_TYPE (max) = TREE_TYPE (TYPE_MIN_VALUE (domain));
- }
-
- return build_array_type (TREE_TYPE (t),
- build_range_type (TREE_TYPE (domain),
- TYPE_MIN_VALUE (domain),
- max));
-}
-#endif
-
/* Build Vardesc type. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
if (type == NULL_TREE)
{
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
type = make_node (RECORD_TYPE);
namefield = ffecom_decl_field (type, NULL_TREE, "name",
TYPE_FIELDS (type) = namefield;
layout_type (type);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ggc_add_tree_root (&type, 1);
}
return type;
tree typeinit;
tree field;
tree varinits;
- int yes;
static int mynumber = 0;
- yes = suspend_momentary ();
-
var = build_decl (VAR_DECL,
ffecom_get_invented_identifier ("__g77_vardesc_%d",
- NULL, mynumber++),
+ mynumber++),
vardesctype);
TREE_STATIC (var) = 1;
DECL_INITIAL (var) = error_mark_node;
var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
- resume_momentary (yes);
-
ffesymbol_hook (s).vardesc_tree = var;
}
tree item = NULL_TREE;
tree var;
int i;
- int yes;
static int mynumber = 0;
for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
}
}
- yes = suspend_momentary ();
-
item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
build_range_type (integer_type_node,
integer_one_node,
TREE_CONSTANT (list) = 1;
TREE_STATIC (list) = 1;
- var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", NULL,
- mynumber++);
+ var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
var = build_decl (VAR_DECL, var, item);
TREE_STATIC (var) = 1;
DECL_INITIAL (var) = error_mark_node;
var = start_decl (var, FALSE);
finish_decl (var, list, FALSE);
- resume_momentary (yes);
-
return var;
}
tree backlist;
tree item = NULL_TREE;
tree var;
- int yes;
tree numdim;
tree numelem;
tree baseoff = NULL_TREE;
numdim = build_tree_list (NULL_TREE, numdim);
TREE_CHAIN (numdim) = numelem;
- yes = suspend_momentary ();
-
item = build_array_type (ffecom_f2c_ftnlen_type_node,
build_range_type (integer_type_node,
integer_zero_node,
TREE_CONSTANT (list) = 1;
TREE_STATIC (list) = 1;
- var = ffecom_get_invented_identifier ("__g77_dims_%d", NULL,
- mynumber++);
+ var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
var = build_decl (VAR_DECL, var, item);
TREE_STATIC (var) = 1;
DECL_INITIAL (var) = error_mark_node;
var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
- resume_momentary (yes);
-
return var;
}
}
assert (ffeinfo_kindtype (ffebld_info (expr))
== FFEINFO_kindtypeCHARACTER1);
+ while (ffebld_op (expr) == FFEBLD_opPAREN)
+ expr = ffebld_left (expr);
+
catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
switch (ffecom_concat_list_count_ (catlist))
{
field = build_decl (FIELD_DECL, get_identifier (name), type);
DECL_CONTEXT (field) = context;
- DECL_FRAME_SIZE (field) = 0;
+ DECL_ALIGN (field) = 0;
+ DECL_USER_ALIGN (field) = 0;
if (prevfield != NULL_TREE)
TREE_CHAIN (prevfield) = field;
tree dt;
tree t;
tree var;
- int yes;
static int number = 0;
callee = ffebld_head (item);
t = ffesymbol_hook (s).decl_tree;
}
- yes = suspend_momentary ();
-
dt = build_pointer_type (TREE_TYPE (t));
var = build_decl (VAR_DECL,
ffecom_get_invented_identifier ("__g77_forceload_%d",
- NULL, number++),
+ number++),
dt);
DECL_EXTERNAL (var) = 0;
TREE_STATIC (var) = 1;
t = ffecom_1 (ADDR_EXPR, dt, t);
finish_decl (var, t, FALSE);
-
- resume_momentary (yes);
}
/* This handles any COMMON areas that weren't referenced but have, for
if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
{
bool dest_used;
+ tree assign_temp;
/* This attempts to replicate the test below, but must not be
true when the test below is false. (Always err on the side
ffecom_prepare_expr_w (NULL_TREE, dest);
+ /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
+ create a temporary through which the assignment is to take place,
+ since MODIFY_EXPR doesn't handle partial overlap properly. */
+ if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
+ && ffecom_possible_partial_overlap_ (dest, source))
+ {
+ assign_temp = ffecom_make_tempvar ("complex_let",
+ ffecom_tree_type
+ [ffebld_basictype (dest)]
+ [ffebld_kindtype (dest)],
+ FFETARGET_charactersizeNONE,
+ -1);
+ }
+ else
+ assign_temp = NULL_TREE;
+
ffecom_prepare_end ();
dest_tree = ffecom_expr_w (NULL_TREE, dest);
if (dest_used)
expr_tree = source_tree;
+ else if (assign_temp)
+ {
+#ifdef MOVE_EXPR
+ /* The back end understands a conceptual move (evaluate source;
+ store into dest), so use that, in case it can determine
+ that it is going to use, say, two registers as temporaries
+ anyway. So don't use the temp (and someday avoid generating
+ it, once this code starts triggering regularly). */
+ expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
+ dest_tree,
+ source_tree);
+#else
+ expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
+ assign_temp,
+ source_tree);
+ expand_expr_stmt (expr_tree);
+ expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
+ dest_tree,
+ assign_temp);
+#endif
+ }
else
expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
dest_tree,
}
#endif
-/* Wrapper for get_identifier. pattern is sprintf-like, assumed to contain
- one %s if text is not NULL, assumed to contain one %d if number is
- not -1. If both are assumed, the %s is assumed to precede the %d. */
+
+/* Wrapper for get_identifier. pattern is sprintf-like. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_get_invented_identifier (const char *pattern, const char *text,
- int number)
+ffecom_get_invented_identifier (const char *pattern, ...)
{
tree decl;
char *nam;
- mallocSize lenlen;
- char space[66];
-
- lenlen = 0;
- if (text)
- lenlen += strlen (text);
- if (number != -1)
- lenlen += 20;
- if (text || number != -1)
- {
- lenlen += strlen (pattern);
- if (lenlen > ARRAY_SIZE (space))
- nam = malloc_new_ks (malloc_pool_image (), pattern, lenlen);
- else
- nam = &space[0];
- }
- else
- {
- lenlen = 0;
- nam = (char *) pattern;
- }
-
- if (text == NULL)
- {
- if (number != -1)
- sprintf (&nam[0], pattern, number);
- }
- else
- {
- if (number == -1)
- sprintf (&nam[0], pattern, text);
- else
- sprintf (&nam[0], pattern, text, number);
- }
+ va_list ap;
+ va_start (ap, pattern);
+ if (vasprintf (&nam, pattern, ap) == 0)
+ abort ();
+ va_end (ap);
decl = get_identifier (nam);
-
- if (lenlen > ARRAY_SIZE (space))
- malloc_kill_ks (malloc_pool_image (), nam, lenlen);
-
+ free (nam);
IDENTIFIER_INVENTED (decl) = 1;
-
return decl;
}
tree field;
ffetype type;
ffetype base_type;
+ tree double_ftype_double;
+ tree float_ftype_float;
+ tree ldouble_ftype_ldouble;
+ tree ffecom_tree_ptr_to_fun_type_void;
/* This block of code comes from the now-obsolete cktyps.c. It checks
whether the compiler environment is buggy in known ways, some of which
double fl;
name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
- (int (*)()) strcmp);
+ (int (*)(const void *, const void *)) strcmp);
if (name != (char *) &names[2])
{
assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
}
}
- /* Set the sizetype before we do anything else. This _should_ be the
- first type we create. */
-
- t = make_unsigned_type (POINTER_SIZE);
- assert (t == sizetype);
-
#if FFECOM_GCC_INCLUDE
ffecom_initialize_char_syntax_ ();
#endif
global_binding_level = current_binding_level;
current_binding_level->prep_state = 2;
- /* Define `int' and `char' first so that dbx will output them first. */
+ build_common_tree_nodes (1);
- integer_type_node = make_signed_type (INT_TYPE_SIZE);
+ /* Define `int' and `char' first so that dbx will output them first. */
pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
integer_type_node));
-
- char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
char_type_node));
-
- long_integer_type_node = make_signed_type (LONG_TYPE_SIZE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
long_integer_type_node));
-
- unsigned_type_node = make_unsigned_type (INT_TYPE_SIZE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
unsigned_type_node));
-
- long_unsigned_type_node = make_unsigned_type (LONG_TYPE_SIZE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
long_unsigned_type_node));
-
- long_long_integer_type_node = make_signed_type (LONG_LONG_TYPE_SIZE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
long_long_integer_type_node));
-
- long_long_unsigned_type_node = make_unsigned_type (LONG_LONG_TYPE_SIZE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
long_long_unsigned_type_node));
-
- error_mark_node = make_node (ERROR_MARK);
- TREE_TYPE (error_mark_node) = error_mark_node;
-
- short_integer_type_node = make_signed_type (SHORT_TYPE_SIZE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
short_integer_type_node));
-
- short_unsigned_type_node = make_unsigned_type (SHORT_TYPE_SIZE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
short_unsigned_type_node));
+ /* Set the sizetype before we make other types. This *should* be the
+ first type we create. */
+
+ set_sizetype
+ (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
+ ffecom_typesize_pointer_
+ = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
+
+ build_common_tree_nodes_2 (0);
+
/* Define both `signed char' and `unsigned char'. */
- signed_char_type_node = make_signed_type (CHAR_TYPE_SIZE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
signed_char_type_node));
- unsigned_char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
unsigned_char_type_node));
- float_type_node = make_node (REAL_TYPE);
- TYPE_PRECISION (float_type_node) = FLOAT_TYPE_SIZE;
- layout_type (float_type_node);
pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
float_type_node));
-
- double_type_node = make_node (REAL_TYPE);
- TYPE_PRECISION (double_type_node) = DOUBLE_TYPE_SIZE;
- layout_type (double_type_node);
pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
double_type_node));
-
- long_double_type_node = make_node (REAL_TYPE);
- TYPE_PRECISION (long_double_type_node) = LONG_DOUBLE_TYPE_SIZE;
- layout_type (long_double_type_node);
pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
long_double_type_node));
+ /* For now, override what build_common_tree_nodes has done. */
complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
+ complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
+ complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
+ complex_long_double_type_node
+ = ffecom_make_complex_type_ (long_double_type_node);
+
pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
complex_integer_type_node));
-
- complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
complex_float_type_node));
-
- complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
complex_double_type_node));
-
- complex_long_double_type_node = ffecom_make_complex_type_ (long_double_type_node);
pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
complex_long_double_type_node));
- integer_zero_node = build_int_2 (0, 0);
- TREE_TYPE (integer_zero_node) = integer_type_node;
- integer_one_node = build_int_2 (1, 0);
- TREE_TYPE (integer_one_node) = integer_type_node;
-
- size_zero_node = build_int_2 (0, 0);
- TREE_TYPE (size_zero_node) = sizetype;
- size_one_node = build_int_2 (1, 0);
- TREE_TYPE (size_one_node) = sizetype;
-
- void_type_node = make_node (VOID_TYPE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
void_type_node));
- layout_type (void_type_node); /* Uses integer_zero_node */
/* We are not going to have real types in C with less than byte alignment,
so we might as well not have any types that claim to have it. */
TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
-
- null_pointer_node = build_int_2 (0, 0);
- TREE_TYPE (null_pointer_node) = build_pointer_type (void_type_node);
- layout_type (TREE_TYPE (null_pointer_node));
+ TYPE_USER_ALIGN (void_type_node) = 0;
string_type_node = build_pointer_type (char_type_node);
TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
type);
ffetype_set_kind (base_type, 1, type);
+ ffecom_typesize_integer1_ = ffetype_size (type);
assert (ffetype_size (type) == sizeof (ffetargetInteger1));
ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
/* Set up pointer types. */
if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
- fatal ("no INTEGER type can hold a pointer on this configuration");
+ fatal_error ("no INTEGER type can hold a pointer on this configuration");
else if (0 && ffe_is_do_internal_checks ())
fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
ffecom_tree_type[i][j]);
DECL_CONTEXT (ffecom_multi_fields_[i][j])
= ffecom_multi_type_node_;
- DECL_FRAME_SIZE (ffecom_multi_fields_[i][j]) = 0;
+ DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
+ DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
field = ffecom_multi_fields_[i][j];
}
= build_function_type (void_type_node, NULL_TREE);
builtin_function ("__builtin_sqrtf", float_ftype_float,
- BUILT_IN_FSQRT, "sqrtf");
+ BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
builtin_function ("__builtin_fsqrt", double_ftype_double,
- BUILT_IN_FSQRT, "sqrt");
+ BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
- BUILT_IN_FSQRT, "sqrtl");
+ BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
builtin_function ("__builtin_sinf", float_ftype_float,
- BUILT_IN_SIN, "sinf");
+ BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
builtin_function ("__builtin_sin", double_ftype_double,
- BUILT_IN_SIN, "sin");
+ BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
- BUILT_IN_SIN, "sinl");
+ BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
builtin_function ("__builtin_cosf", float_ftype_float,
- BUILT_IN_COS, "cosf");
+ BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
builtin_function ("__builtin_cos", double_ftype_double,
- BUILT_IN_COS, "cos");
+ BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
- BUILT_IN_COS, "cosl");
+ BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
#if BUILT_FOR_270
pedantic_lvalues = FALSE;
break;
case FFELAB_typeFORMAT:
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
glabel = build_decl (VAR_DECL,
ffecom_get_invented_identifier
- ("__g77_format_%d", NULL,
- (int) ffelab_value (label)),
+ ("__g77_format_%d", (int) ffelab_value (label)),
build_type_variant (build_array_type
(char_type_node,
NULL_TREE),
1, 0));
TREE_CONSTANT (glabel) = 1;
TREE_STATIC (glabel) = 1;
- DECL_CONTEXT (glabel) = 0;
+ DECL_CONTEXT (glabel) = current_function_decl;
DECL_INITIAL (glabel) = NULL;
- make_decl_rtl (glabel, NULL, 0);
+ make_decl_rtl (glabel, NULL);
expand_decl (glabel);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ffecom_save_tree_forever (glabel);
break;
/* Register source file name. */
void
-ffecom_file (char *name)
+ffecom_file (const char *name)
{
#if FFECOM_GCC_INCLUDE
ffecom_file_ (name);
return item;
case FFEBLD_opARRAYREF:
- {
- item = ffecom_ptr_to_expr (ffebld_left (expr));
-
- if (item == error_mark_node)
- return item;
-
- if ((ffebld_where (expr) == FFEINFO_whereFLEETING)
- && !mark_addressable (item))
- return error_mark_node; /* Make sure non-const ref is to
- non-reg. */
-
- item = ffecom_arrayref_ (item, expr, 1);
- }
- return item;
+ return ffecom_arrayref_ (NULL_TREE, expr, 1);
case FFEBLD_opCONTER:
ffecom_make_tempvar (const char *commentary, tree type,
ffetargetCharacterSize size, int elements)
{
- int yes;
tree t;
static int mynumber;
if (type == error_mark_node)
return error_mark_node;
- yes = suspend_momentary ();
-
if (size != FFETARGET_charactersizeNONE)
type = build_array_type (type,
build_range_type (ffecom_f2c_ftnlen_type_node,
t = start_decl (t, FALSE);
finish_decl (t, NULL_TREE, FALSE);
- resume_momentary (yes);
-
return t;
}
#endif
/* Generate whatever temporaries are needed to represent the result
of the expression. */
+ if (bt == FFEINFO_basictypeCHARACTER)
+ {
+ while (ffebld_op (expr) == FFEBLD_opPAREN)
+ expr = ffebld_left (expr);
+ }
+
switch (ffebld_op (expr))
{
default:
s = ffebld_symter (ffebld_left (expr));
if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
- || ! ffesymbol_is_f2c (s))
+ || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
+ && ! ffesymbol_is_f2c (s))
+ || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
+ && ! ffe_is_f2c_library ()))
break;
}
else if (ffebld_op (expr) == FFEBLD_opPOWER)
glabel = build_decl (LABEL_DECL,
ffecom_get_invented_identifier ("__g77_label_%d",
- NULL,
mynumber++),
void_type_node);
DECL_CONTEXT (glabel) = current_function_decl;
emit_line_note (input_filename, lineno);
pushlevel (0);
clear_last_expr ();
- push_momentary ();
expand_start_bindings (0);
}
emit_line_note (input_filename, lineno);
expand_end_bindings (getdecls (), keep, 0);
t = poplevel (keep, 1, 0);
- pop_momentary ();
return t;
}
If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
the name to be called if we can't opencode the function. */
-static tree
-builtin_function (const char *name, tree type,
- enum built_in_function function_code,
+tree
+builtin_function (const char *name, tree type, int function_code,
+ enum built_in_class class,
const char *library_name)
{
tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
TREE_PUBLIC (decl) = 1;
if (library_name)
DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
- make_decl_rtl (decl, NULL_PTR, 1);
+ make_decl_rtl (decl, NULL_PTR);
pushdecl (decl);
- if (function_code != NOT_BUILT_IN)
- {
- DECL_BUILT_IN (decl) = 1;
- DECL_FUNCTION_CODE (decl) = function_code;
- }
+ DECL_BUILT_IN_CLASS (decl) = class;
+ DECL_FUNCTION_CODE (decl) = function_code;
return decl;
}
tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
- /* Make sure we put the new type in the same obstack as the old ones.
- If the old types are not both in the same obstack, use the
- permanent one. */
- if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
- push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
- else
- {
- push_obstacks_nochange ();
- end_temporary_allocation ();
- }
-
if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
{
/* Function types may be shared, so we can't just modify
if (types_match)
TREE_TYPE (olddecl) = newtype;
}
-
- pop_obstacks ();
}
if (!types_match)
return 0;
if (types_match)
{
- /* Make sure we put the new type in the same obstack as the old ones.
- If the old types are not both in the same obstack, use the permanent
- one. */
- if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
- push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
- else
- {
- push_obstacks_nochange ();
- end_temporary_allocation ();
- }
-
/* Merge the data types specified in the two decls. */
if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
TREE_TYPE (newdecl)
{
/* Since the type is OLDDECL's, make OLDDECL's size go with. */
DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
+ DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
if (TREE_CODE (olddecl) != FUNCTION_DECL)
if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
- DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
+ {
+ DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
+ DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
+ }
}
/* Keep the old rtl since we can safely use it. */
DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
}
#endif
-
- pop_obstacks ();
}
/* If cannot merge, then use the new type and qualifiers,
and don't preserve the old rtl. */
&& (!types_match || new_is_definition))
{
TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
- DECL_BUILT_IN (olddecl) = 0;
+ DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
}
/* If redeclaring a builtin function, and not a definition,
{
if (DECL_BUILT_IN (olddecl))
{
- DECL_BUILT_IN (newdecl) = 1;
+ DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
}
else
{
register tree type = TREE_TYPE (decl);
int was_incomplete = (DECL_SIZE (decl) == 0);
- int temporary = allocation_temporary_p ();
bool at_top_level = (current_binding_level == global_binding_level);
bool top_level = is_top_level || at_top_level;
}
}
- /* Pop back to the obstack that is current for this binding level. This is
- because MAXINDEX, rtl, etc. to be made below must go in the permanent
- obstack. But don't discard the temporary data yet. */
- pop_obstacks ();
-
/* Deduce size of array from initialization, if not already known */
if (TREE_CODE (type) == ARRAY_TYPE
0);
}
- /* This test used to include TREE_PERMANENT, however, we have the same
- problem with initializers at the function level. Such initializers get
- saved until the end of the function on the momentary_obstack. */
- if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl))
- && temporary
- /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
- DECL_ARG_TYPE. */
- && TREE_CODE (decl) != PARM_DECL)
- {
- /* We need to remember that this array HAD an initialization, but
- discard the actual temporary nodes, since we can't have a permanent
- node keep pointing to them. */
- /* We make an exception for inline functions, since it's normal for a
- local extern redeclaration of an inline function to have a copy of
- the top-level decl's DECL_INLINE. */
- if ((DECL_INITIAL (decl) != 0)
- && (DECL_INITIAL (decl) != error_mark_node))
- {
- /* If this is a const variable, then preserve the
- initializer instead of discarding it so that we can optimize
- references to it. */
- /* This test used to include TREE_STATIC, but this won't be set
- for function level initializers. */
- if (TREE_READONLY (decl))
- {
- preserve_initializer ();
- /* Hack? Set the permanent bit for something that is
- permanent, but not on the permenent obstack, so as to
- convince output_constant_def to make its rtl on the
- permanent obstack. */
- TREE_PERMANENT (DECL_INITIAL (decl)) = 1;
-
- /* The initializer and DECL must have the same (or equivalent
- types), but if the initializer is a STRING_CST, its type
- might not be on the right obstack, so copy the type
- of DECL. */
- TREE_TYPE (DECL_INITIAL (decl)) = type;
- }
- else
- DECL_INITIAL (decl) = error_mark_node;
- }
- }
-
- /* If requested, warn about definitions of large data objects. */
-
- if (warn_larger_than
- && (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL)
- && !DECL_EXTERNAL (decl))
- {
- register tree decl_size = DECL_SIZE (decl);
-
- if (decl_size && TREE_CODE (decl_size) == INTEGER_CST)
- {
- unsigned units = TREE_INT_CST_LOW (decl_size) / BITS_PER_UNIT;
-
- if (units > larger_than_size)
- warning_with_decl (decl, "size of `%s' is %u bytes", units);
- }
- }
-
- /* If we have gone back from temporary to permanent allocation, actually
- free the temporary space that we no longer need. */
- if (temporary && !allocation_temporary_p ())
- permanent_allocation (0);
-
/* At the end of a declaration, throw away any variable type sizes of types
defined inside that declaration. There is no use computing them in the
following function definition. */
/* Generate rtl for function exit. */
expand_function_end (input_filename, lineno, 0);
- /* So we can tell if jump_optimize sets it to 1. */
- can_reach_end = 0;
+ /* If this is a nested function, protect the local variables in the stack
+ above us from being collected while we're compiling this function. */
+ if (nested)
+ ggc_push_context ();
/* Run the optimizers and output the assembler code for this function. */
rest_of_compilation (fndecl);
- }
- /* Free all the tree nodes making up this function. */
- /* Switch back to allocating nodes permanently until we start another
- function. */
- if (!nested)
- permanent_allocation (1);
+ /* Undo the GC context switch. */
+ if (nested)
+ ggc_pop_context ();
+ }
if (TREE_CODE (fndecl) != ERROR_MARK
&& !nested
per se, but if that comes up, it should be easy to check (being a
nested function and all). */
-static char *
+static const char *
lang_printable_name (tree decl, int v)
{
/* Just to keep GCC quiet about the unused variable.
an error. */
#if BUILT_FOR_270
-void
-lang_print_error_function (file)
- char *file;
+static void
+lang_print_error_function (const char *file)
{
static ffeglobal last_g = NULL;
static ffesymbol last_s = NULL;
immediate_size_expand = 0;
- push_obstacks_nochange ();
-
/* Fill in arg stuff. */
DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
level anyway. */
assert (!is_top_level || !at_top_level);
- /* The corresponding pop_obstacks is in finish_decl. */
- push_obstacks_nochange ();
-
if (DECL_INITIAL (decl) != NULL_TREE)
{
assert (DECL_INITIAL (decl) == error_mark_node);
expand_decl (tem);
}
- if (DECL_INITIAL (tem) != NULL_TREE)
- {
- /* When parsing and digesting the initializer, use temporary storage.
- Do this even if we will ignore the value. */
- if (at_top_level)
- temporary_allocation ();
- }
-
return tem;
}
if (TREE_CODE (current_function_decl) != ERROR_MARK)
{
- make_function_rtl (current_function_decl);
+ make_decl_rtl (current_function_decl, NULL);
restype = TREE_TYPE (TREE_TYPE (current_function_decl));
DECL_RESULT (current_function_decl)
= build_decl (RESULT_DECL, NULL_TREE, restype);
}
- if (!nested)
- /* Allocate further tree nodes temporarily during compilation of this
- function only. */
- temporary_allocation ();
-
if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
TREE_ADDRESSABLE (current_function_decl) = 1;
assert ("incomplete type?!?" == NULL);
}
+/* Mark ARG for GC. */
+static void
+mark_binding_level (void *arg)
+{
+ struct binding_level *level = *(struct binding_level **) arg;
+
+ while (level)
+ {
+ ggc_mark_tree (level->names);
+ ggc_mark_tree (level->blocks);
+ ggc_mark_tree (level->this_block);
+ level = level->level_chain;
+ }
+}
+
void
init_decl_processing ()
{
+ static tree *const tree_roots[] = {
+ ¤t_function_decl,
+ &string_type_node,
+ &ffecom_tree_fun_type_void,
+ &ffecom_integer_zero_node,
+ &ffecom_integer_one_node,
+ &ffecom_tree_subr_type,
+ &ffecom_tree_ptr_to_subr_type,
+ &ffecom_tree_blockdata_type,
+ &ffecom_tree_xargc_,
+ &ffecom_f2c_integer_type_node,
+ &ffecom_f2c_ptr_to_integer_type_node,
+ &ffecom_f2c_address_type_node,
+ &ffecom_f2c_real_type_node,
+ &ffecom_f2c_ptr_to_real_type_node,
+ &ffecom_f2c_doublereal_type_node,
+ &ffecom_f2c_complex_type_node,
+ &ffecom_f2c_doublecomplex_type_node,
+ &ffecom_f2c_longint_type_node,
+ &ffecom_f2c_logical_type_node,
+ &ffecom_f2c_flag_type_node,
+ &ffecom_f2c_ftnlen_type_node,
+ &ffecom_f2c_ftnlen_zero_node,
+ &ffecom_f2c_ftnlen_one_node,
+ &ffecom_f2c_ftnlen_two_node,
+ &ffecom_f2c_ptr_to_ftnlen_type_node,
+ &ffecom_f2c_ftnint_type_node,
+ &ffecom_f2c_ptr_to_ftnint_type_node,
+ &ffecom_outer_function_decl_,
+ &ffecom_previous_function_decl_,
+ &ffecom_which_entrypoint_decl_,
+ &ffecom_float_zero_,
+ &ffecom_float_half_,
+ &ffecom_double_zero_,
+ &ffecom_double_half_,
+ &ffecom_func_result_,
+ &ffecom_func_length_,
+ &ffecom_multi_type_node_,
+ &ffecom_multi_retval_,
+ &named_labels,
+ &shadowed_labels
+ };
+ size_t i;
+
malloc_init ();
+
+ /* Record our roots. */
+ for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
+ ggc_add_tree_root (tree_roots[i], 1);
+ ggc_add_tree_root (&ffecom_tree_type[0][0],
+ FFEINFO_basictype*FFEINFO_kindtype);
+ ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
+ FFEINFO_basictype*FFEINFO_kindtype);
+ ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
+ FFEINFO_basictype*FFEINFO_kindtype);
+ ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
+ ggc_add_root (¤t_binding_level, 1, sizeof current_binding_level,
+ mark_binding_level);
+ ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
+ mark_binding_level);
+ ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
+
ffe_init_0 ();
}
-char *
+const char *
init_parse (filename)
- char *filename;
+ const char *filename;
{
-#if BUILT_FOR_270
- extern void (*print_error_function) (char *);
-#endif
-
/* Open input file. */
if (filename == 0 || !strcmp (filename, "-"))
{
else
finput = fopen (filename, "r");
if (finput == 0)
- pfatal_with_name (filename);
+ fatal_io_error ("can't open %s", filename);
#ifdef IO_BUFFER_SIZE
setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
= chainon (current_binding_level->blocks, block);
}
-int
-lang_decode_option (argc, argv)
- int argc;
- char **argv;
-{
- return ffe_decode_option (argc, argv);
-}
+/* Each front end provides its own. */
+static void ffe_init PARAMS ((void));
+static void ffe_finish PARAMS ((void));
+static void ffe_init_options PARAMS ((void));
+
+struct lang_hooks lang_hooks = {ffe_init,
+ ffe_finish,
+ ffe_init_options,
+ ffe_decode_option,
+ NULL /* post_options */};
/* used by print-tree.c */
{
}
-void
-lang_finish ()
+static void
+ffe_finish ()
{
ffe_terminate_0 ();
malloc_pool_display (malloc_pool_image ());
}
-char *
+const char *
lang_identify ()
{
return "f77";
}
-void
-lang_init_options ()
+/* Return the typed-based alias set for T, which may be an expression
+ or a type. Return -1 if we don't do anything special. */
+
+HOST_WIDE_INT
+lang_get_alias_set (t)
+ tree t ATTRIBUTE_UNUSED;
+{
+ /* We do not wish to use alias-set based aliasing at all. Used in the
+ extreme (every object with its own set, with equivalences recorded)
+ it might be helpful, but there are problems when it comes to inlining.
+ We get on ok with flag_argument_noalias, and alias-set aliasing does
+ currently limit how stack slots can be reused, which is a lose. */
+ return 0;
+}
+
+static void
+ffe_init_options ()
{
/* Set default options for Fortran. */
flag_move_all_movables = 1;
flag_reduce_all_givs = 1;
flag_argument_noalias = 2;
+ flag_errno_math = 0;
+ flag_complex_divide_method = 1;
}
-void
-lang_init ()
+static void
+ffe_init ()
{
/* If the file is output from cpp, it should contain a first line
`# 1 "real-filename"', and the current design of gcc (toplev.c
{
BLOCK_VARS (block) = decls;
BLOCK_SUBBLOCKS (block) = subblocks;
- remember_end_note (block);
}
/* In each subblock, record that this is its superior. */
register tree block;
{
current_binding_level->this_block = block;
+ current_binding_level->names = chainon (current_binding_level->names,
+ BLOCK_VARS (block));
+ current_binding_level->blocks = chainon (current_binding_level->blocks,
+ BLOCK_SUBBLOCKS (block));
}
/* ~~gcc/tree.h *should* declare this, because toplev.c references it. */
if (mode == TYPE_MODE (long_long_integer_type_node))
return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
+#if HOST_BITS_PER_WIDE_INT >= 64
+ if (mode == TYPE_MODE (intTI_type_node))
+ return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
+#endif
+
if (mode == TYPE_MODE (float_type_node))
return float_type_node;
return type;
}
+void
+lang_mark_tree (t)
+ union tree_node *t ATTRIBUTE_UNUSED;
+{
+ if (TREE_CODE (t) == IDENTIFIER_NODE)
+ {
+ struct lang_identifier *i = (struct lang_identifier *) t;
+ ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
+ ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
+ ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
+ }
+ else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
+ ggc_mark (TYPE_LANG_SPECIFIC (t));
+}
+
#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
\f
#if FFECOM_GCC_INCLUDE
and for expanding macro arguments. */
#define INPUT_STACK_MAX 400
static struct file_buf {
- char *fname;
+ const char *fname;
/* Filename specified with #line command. */
- char *nominal_fname;
+ const char *nominal_fname;
/* Record where in the search path this file was found.
For #include_next. */
struct file_name_list *dir;
looking in. Thus #include <sys/types.h> will look up sys/types.h
in /usr/include/header.gcc and look up types.h in
/usr/include/sys/header.gcc. */
- p = rindex (filename, '/');
+ p = strrchr (filename, '/');
#ifdef DIR_SEPARATOR
- if (! p) p = rindex (filename, DIR_SEPARATOR);
+ if (! p) p = strrchr (filename, DIR_SEPARATOR);
else {
- char *tmp = rindex (filename, DIR_SEPARATOR);
+ char *tmp = strrchr (filename, DIR_SEPARATOR);
if (tmp != NULL && tmp > p) p = tmp;
}
#endif
}
static void
-ffecom_file_ (char *name)
+ffecom_file_ (const char *name)
{
FILE_BUF *fp;
dirtmp = (struct file_name_list *)
xmalloc (sizeof (struct file_name_list));
dirtmp->next = 0; /* New one goes on the end */
- if (spec[0] != 0)
- dirtmp->fname = spec;
- else
- fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
+ dirtmp->fname = spec;
dirtmp->got_name_map = 0;
- append_include_chain (dirtmp, dirtmp);
+ if (spec[0] == 0)
+ error ("Directory name must immediately follow -I");
+ else
+ append_include_chain (dirtmp, dirtmp);
}
return 1;
}
{
int n;
char *ep;
- char *nam;
+ const char *nam;
if ((nam = fp->nominal_fname) != NULL)
{
dsp[0].next = search_start;
search_start = dsp;
#ifndef VMS
- ep = rindex (nam, '/');
+ ep = strrchr (nam, '/');
#ifdef DIR_SEPARATOR
- if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR);
+ if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
else {
- char *tmp = rindex (nam, DIR_SEPARATOR);
+ char *tmp = strrchr (nam, DIR_SEPARATOR);
if (tmp != NULL && tmp > ep) ep = tmp;
}
#endif
#else /* VMS */
- ep = rindex (nam, ']');
- if (ep == NULL) ep = rindex (nam, '>');
- if (ep == NULL) ep = rindex (nam, ':');
+ ep = strrchr (nam, ']');
+ if (ep == NULL) ep = strrchr (nam, '>');
+ if (ep == NULL) ep = strrchr (nam, ':');
if (ep != NULL) ep++;
#endif /* VMS */
if (ep != NULL)
fname[flen] = 0;
#if 0 /* Not for g77. */
/* if it's '#include filename', add the missing .h */
- if (index (fname, '.') == NULL)
+ if (strchr (fname, '.') == NULL)
strcat (fname, ".h");
#endif
}
OSDN Git Service
