📄 com.c
字号:
static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKINGstatic void ffecom_member_phase2_ (ffestorag mst, ffestorag st);#endifstatic void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source);static void ffecom_push_dummy_decls_ (ffebld dumlist, bool stmtfunc);static void ffecom_start_progunit_ (void);static ffesymbol ffecom_sym_transform_ (ffesymbol s);static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);static void ffecom_transform_common_ (ffesymbol s);static void ffecom_transform_equiv_ (ffestorag st);static tree ffecom_transform_namelist_ (ffesymbol s);static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset, tree t);static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset, tree *size, tree tree);static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right, tree dest_tree, ffebld dest, bool *dest_used, tree hook);static tree ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt);static tree ffecom_type_namelist_ (void);#if 0static tree ffecom_type_permanent_copy_ (tree t);#endifstatic tree ffecom_type_vardesc_ (void);static tree ffecom_vardesc_ (ffebld expr);static tree ffecom_vardesc_array_ (ffesymbol s);static tree ffecom_vardesc_dims_ (ffesymbol s);static tree ffecom_convert_narrow_ (tree type, tree expr);static tree ffecom_convert_widen_ (tree type, tree expr);#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC *//* These are static functions that parallel those found in the C front end and thus have the same names. */#if FFECOM_targetCURRENT == FFECOM_targetGCCstatic 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 tree lookup_name_current_level (tree name);static struct binding_level *make_binding_level (void);static void pop_f_function_context (void);static void push_f_function_context (void);static void push_parm_decl (tree parm);static tree pushdecl_top_level (tree decl);static int kept_level_p (void);static tree storedecls (tree decls);static void store_parm_decls (int is_main_program);static tree start_decl (tree decl, bool is_top_level);static void start_function (tree name, tree type, int nested, int public);#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */#if FFECOM_GCC_INCLUDEstatic void ffecom_file_ (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 FILE *ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c);#endif /* FFECOM_GCC_INCLUDE *//* Static objects accessed by functions in this module. */static ffesymbol ffecom_primary_entry_ = NULL;static ffesymbol ffecom_nested_entry_ = NULL;static ffeinfoKind ffecom_primary_entry_kind_;static bool ffecom_primary_entry_is_proc_;#if FFECOM_targetCURRENT == FFECOM_targetGCCstatic tree ffecom_outer_function_decl_;static tree ffecom_previous_function_decl_;static tree ffecom_which_entrypoint_decl_;static tree ffecom_float_zero_ = NULL_TREE;static tree ffecom_float_half_ = NULL_TREE;static tree ffecom_double_zero_ = NULL_TREE;static tree ffecom_double_half_ = NULL_TREE;static tree ffecom_func_result_;/* For functions. */static tree ffecom_func_length_;/* For CHARACTER fns. */static ffebld ffecom_list_blockdata_;static ffebld ffecom_list_common_;static ffebld ffecom_master_arglist_;static ffeinfoBasictype ffecom_master_bt_;static ffeinfoKindtype ffecom_master_kt_;static ffetargetCharacterSize ffecom_master_size_;static int ffecom_num_fns_ = 0;static int ffecom_num_entrypoints_ = 0;static bool ffecom_is_altreturning_ = FALSE;static tree ffecom_multi_type_node_;static tree ffecom_multi_retval_;static tree ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];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,#include "com-rt.def"#undef DEFGFRT};/* Holds the external names of the functions. */static const char *ffecom_gfrt_name_[FFECOM_gfrt]={#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NAME,#include "com-rt.def"#undef DEFGFRT};/* Whether the function returns. */static bool ffecom_gfrt_volatile_[FFECOM_gfrt]={#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) VOLATILE,#include "com-rt.def"#undef DEFGFRT};/* Whether the function returns type complex. */static bool ffecom_gfrt_complex_[FFECOM_gfrt]={#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) COMPLEX,#include "com-rt.def"#undef DEFGFRT};/* Type code for the function return value. */static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]={#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) TYPE,#include "com-rt.def"#undef DEFGFRT};/* String of codes for the function's arguments. */static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]={#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) ARGS,#include "com-rt.def"#undef DEFGFRT};#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC *//* Internal macros. */#if FFECOM_targetCURRENT == FFECOM_targetGCC/* We let tm.h override the types used here, to handle trivial differences such as the choice of unsigned int or long unsigned int for size_t. When machines start needing nontrivial differences in the size type, it would be best to do something here to figure out automatically from other information what type to use. */#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)])#define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)#define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)#define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)#define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)/* For each binding contour we allocate a binding_level structure * which records the names defined in that contour. * Contours include: * 0) the global one * 1) one for each function definition, * where internal declarations of the parameters appear. * * The current meaning of a name can be found by searching the levels from * the current one out to the global one. *//* Note that the information in the `names' component of the global contour is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */struct binding_level { /* A chain of _DECL nodes for all variables, constants, functions, and typedef types. These are in the reverse of the order supplied. */ tree names; /* For each level (except not the global one), a chain of BLOCK nodes for all the levels that were entered and exited one level down. */ tree blocks; /* The BLOCK node for this level, if one has been preallocated. If 0, the BLOCK is allocated (if needed) when the level is popped. */ tree this_block; /* The binding level which this one is contained in (inherits from). */ struct binding_level *level_chain; /* 0: no ffecom_prepare_* functions called at this level yet; 1: ffecom_prepare* functions called, except not ffecom_prepare_end; 2: ffecom_prepare_end called. */ int prep_state; };#define NULL_BINDING_LEVEL (struct binding_level *) NULL/* The binding level currently in effect. */static struct binding_level *current_binding_level;/* A chain of binding_level structures awaiting reuse. */static struct binding_level *free_binding_level;/* The outermost binding level, for names of file scope. This is created when the compiler is started and exists through the entire run. */static struct binding_level *global_binding_level;/* Binding level structures are initialized by copying this one. */static struct binding_level clear_binding_level={NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};/* Language-dependent contents of an identifier. */struct lang_identifier { struct tree_identifier ignore; tree global_value, local_value, label_value; bool invented; };/* Macros for access to language-specific slots in an identifier. *//* Each of these slots contains a DECL node or null. *//* This represents the value which the identifier has in the file-scope namespace. */#define IDENTIFIER_GLOBAL_VALUE(NODE) \ (((struct lang_identifier *)(NODE))->global_value)/* This represents the value which the identifier has in the current scope. */#define IDENTIFIER_LOCAL_VALUE(NODE) \ (((struct lang_identifier *)(NODE))->local_value)/* This represents the value which the identifier has as a label in the current label scope. */#define IDENTIFIER_LABEL_VALUE(NODE) \ (((struct lang_identifier *)(NODE))->label_value)/* This is nonzero if the identifier was "made up" by g77 code. */#define IDENTIFIER_INVENTED(NODE) \ (((struct lang_identifier *)(NODE))->invented)/* In identifiers, C uses the following fields in a special way: TREE_PUBLIC to record that there was a previous local extern decl. TREE_USED to record that such a decl was used. TREE_ADDRESSABLE to record that the address of such a decl was used. *//* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function that have names. Here so we can clear out their names' definitions at the end of the function. */static tree named_labels;/* A list of LABEL_DECLs from outer contexts that are currently shadowed. */static tree shadowed_labels;#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ /* Return the subscript expression, modified to do range-checking. `array' is the array to be checked against. `element' is the subscript expression to check. `dim' is the dimension number (starting at 0). `total_dims' is the total number of dimensions (0 for CHARACTER substring).*/static treeffecom_subscript_check_ (tree array, tree element, int dim, int total_dims, char *array_name){ tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array)); tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array)); tree cond; tree die; tree args; 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, element); if (high) { cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, cond, ffecom_2 (LE_EXPR, integer_type_node, element, high)); } { int len; char *proc; char *var; tree arg3; tree arg2; tree arg1; tree arg4; switch (total_dims) { case 0: var = xmalloc (strlen (array_name) + 20); sprintf (&var[0], "%s[%s-substring]", array_name, dim ? "end" : "start"); len = strlen (var) + 1; break; case 1: len = strlen (array_name) + 1; var = array_name; break; default: var = xmalloc (strlen (array_name) + 40); sprintf (&var[0], "%s[subscript-%d-of-%d]", array_name, dim + 1, total_dims); len = strlen (var) + 1; 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 (integer_type_node, integer_one_node, build_int_2 (len, 0))), 1, 0); TREE_CONSTANT (arg1) = 1; TREE_STATIC (arg1) = 1; arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)), arg1); /* s_rnge adds one to the element to print it, so bias against that -- want to print a faithful *subscript* value. */ arg2 = convert (ffecom_f2c_ftnint_type_node, ffecom_2 (MINUS_EXPR, TREE_TYPE (element), element, convert (TREE_TYPE (element), integer_one_node))); proc = xmalloc ((len = strlen (input_filename) + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl)) + 2)); sprintf (&proc[0], "%s/%s", input_filename, IDENTIFIER_POINTER (DECL_NAME (current_function_decl))); arg3 = build_string (len, proc); free (proc); TREE_TYPE (arg3) = build_type_variant (build_array_type (char_type_node, build_range_type (integer_type_node, integer_one_node, build_int_2 (len, 0))), 1, 0); TREE_CONSTANT (arg3) = 1; TREE_STATIC (arg3) = 1; arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)), arg3); arg4 = convert (ffecom_f2c_ftnint_type_node, build_int_2 (lineno, 0)); arg1 = build_tree_list (NULL_TREE, arg1); arg2 = build_tree_list (NULL_TREE, arg2); arg3 = build_tree_list (NULL_TREE, arg3); arg4 = build_tree_list (NULL_TREE, arg4); TREE_CHAIN (arg3) = arg4; TREE_CHAIN (arg2) = arg3; TREE_CHAIN (arg1) = arg2; args = arg1; } die = ffecom_call_gfrt (FFECOM_gfrtRANGE, args, NULL_TREE); TREE_SIDE_EFFECTS (die) = 1; element = ffecom_3 (COND_EXPR, TREE_TYPE (element), cond, element, die); return element;}/* Return the computed element of an array reference. `item' is NULL_TREE, or the transformed pointer to the array.⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -