diff options
Diffstat (limited to 'gcc/fortran')
63 files changed, 76893 insertions, 0 deletions
diff --git a/gcc/fortran/.cvsignore b/gcc/fortran/.cvsignore new file mode 100644 index 00000000000..da7ce896169 --- /dev/null +++ b/gcc/fortran/.cvsignore @@ -0,0 +1 @@ +gfortran.info* diff --git a/gcc/fortran/CONTRIB b/gcc/fortran/CONTRIB new file mode 100644 index 00000000000..765dfe62e3b --- /dev/null +++ b/gcc/fortran/CONTRIB @@ -0,0 +1,33 @@ +Contributors to G95 + +If we have left anyone out, please let us know: +<gcc-g95-devel@lists.sourceforge.net> + + +Major code contributors +---------------------------------- +Andy Vaught +Katherine Holcomb +Steven Bosscher +Paul Brook +Arnaud Desitter +Canqun Yang +Xiaoqiang Zhang + + +Small patches (no copyright assignment) +---------------------------------- +Niels Kristian Bech Jensen +Steven G. Johnson +Tobias Schlüter + + +Helpful comments +---------------------------------- +Erik Schnetter +Steven G. Kargl +W. Clodius +Claus Fischer +Toon Moene +Richard T. Henderson + diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog new file mode 100644 index 00000000000..4e927638fee --- /dev/null +++ b/gcc/fortran/ChangeLog @@ -0,0 +1,3068 @@ +2004-05-09 Tobias Schlüter <tobias.schlueter@physik.uni-muenchen.de> + + * array.c (match_subscript, match_array_ref): Add comments + explaining argument 'init'. + * decl.c, f95-lang.c, match.c, resolve.c, trans-array.c, + trans-expr.c, trans.c: Fix some typos in comments. + * dump-parse-tree.c (gfc_show_expr): Remove wrong comment. + * primary.c (match_digits, match_integer_constant): Add comment + explaining signflag. + +2004-05-01 Tobias Schlüter <tobias.schlueter@physik.uni-muenchen.de> + + PR fortran/13940 + * primary.c: Include system.h and flags.h, needed for pedantic. + (match_boz_constant): Allow "x" for hexadecimal constants, warn if + pedantic is set. + +2004-05-01 Tobias Schlüter <tobias.schlueter@physik.uni-muenchen.de> + + PR fortran/13940 + * match.c (match_data_constant): Handle case where + gfc_find_symbol sets sym to NULL + +2004-04-28 Tobias Schlüter <tobias.schlueter@physik.uni-muenchen.de> + + * Make-lang.in (f95-lang.o, trans-intrinsic.o): Add missing + dependency on mathbuiltins.def + +2004-04-24 Victor Leikehman <lei@il.ibm.com> + + * trans-io.c (transfer_expr): Implemented recursive printing + of derived types. + +2004-04-24 Andrew Pinski <pinskia@physics.uc.edu> + + * gfortranspec.c: Do not include multilib.h. + +2004-04-24 Tobias Schlüter <tobias.schlueter@physik.uni-muenchen.de> + + * trans-intrinsic.c: Fix comment, this is not trans-expr.c. Add + 2004 to copyright years. + * trans-expr.c, trans-decl.c: Comment update, we now generate + GENERIC, not SIMPLE. Add 2004 to copyright years. + +2004-04-24 Paul Brook <paul@codesourcery.com> + + * Make-lang.in (gfortranspec.o): Add dependency on $(TM_H). + +2004-04-24 Feng Wang <fengwang@nudt.edu.cn> + + PR 14817 + * arith.c (gfc_arith_divide): Fix complex divide. + +2004-04-23 Andrew Pinski <pinskia@physics.uc.edu> + + * gfortranspec.c: Include the target headers. + +2004-04-18 Feng Wang <fengwang@nudt.edu.cn> + + PR fortran/14921 + PR fortran/14540 + * arith.c (arctangent2): New function. + * arith.h (arctangent2): Add function prototype. + * simplify.c (gfc_simplify_atan2): Use it. + (gfc_simplify_log): Use it. + +2004-04-12 Diego Novillo <dnovillo@redhat.com> + + * fortran/f95-lang.c (gfc_expand_stmt): Remove. + (LANG_HOOKS_RTL_EXPAND_STMT): Remove. + +2004-04-11 Bud Davis <bdavis9659@comcast.net> + + PR fortran/14872 + * trans-io.c (build_dt): Change REC to value. + +2004-04-11 Feng Wang <fengwang@nudt.edu.cn> + + PR 14394 + * trans-const.c (gfc_conv_mpf_to_tree): Loosen the maximum digits of + the real value when converting mpf to string. + +2004-04-11 Feng Wang <fengwang@nudt.edu.cn> + + PR 14395 + * trans-intrinsic.c (gfc_conv_intrinsic_cmplx): Fix the imag part of + the result. + +2004-04-11 Feng Wang <fengwang@nudt.edu.cn> + + PR fortran/14377 + * simplify.c (simplify_min_max): Convert the type of the result. + +2004-04-11 Paul Brook <paul@codesourcery.com> + + * gfortran.texi: Use full target triplet. + +2004-04-11 Paul Brook <paul@codesourcery.com> + + * Make-lang.in (GFORTRAN_TEXI): Set it. + (fortran/dfortran.dvi): Use it. Add fortran to include paths. + (fortran/gfortran.info): Ditto. + * gfortran.texi: Major update. + * invoke.texi: New file. + +2004-04-10 Paul Brook <paul@codesourcery.com> + + * trans-array.c (gfc_trans_allocate_temp_array, + gfc_conv_tmp_array_ref): Don't use GFC_DECL_STRING. + * trans-decl.c (gfc_build_dummy_array_decl, + gfc_get_symbol_decl, gfc_build_function_decl, + gfc_create_module_variable): Ditto. + * trans-expr.c (gfc_conv_variable): Ditto. + * trans-intrinsic.c (gfc_conv_intrinsic_len): Ditto. + * trans.h (GFC_DECL_STRING): Remove. + (GFC_DECL_PACKED_ARRAY, GFC_DECL_PARTIAL_PACKED_ARRAY, + GFC_DECL_ASSIGN): Renumber flags. + +2004-04-05 Paul Brook <paul@codesourcery.com> + + PR 13252 + PR 14081 + * f95-lang.c (gfc_init_builtin_functions): Add stack_alloc, stack_save + and stack_restore. + * gfortran.h (struct gfc_charlen): Add backend_decl. + * trans-array.c (gfc_trans_allocate_temp_array, + gfc_conv_temp_array_ref, gfc_conv_resolve_dependencies, + (gfc_conv_loop_setup, gfc_array_allocate, gfc_conv_array_init_size): + Remove old, broken string handling. + (gfc_trans_auto_array_allocation, gfc_trans_g77_array, + gfc_trans_dummy_array_bias, gfc_conv_expr_descriptor, + gfc_trans_deferred_array): Handle character arrays. + * trans-const.c (gfc_conv_const_charlen): New function. + * trans-const.h (gfc_conv_const_charlen): Add prototype. + * trans-decl.c (gfc_finish_var_decl): Don't mark automatic variables + as static. + (gfc_build_dummy_array_decl): Handle arrays with unknown element size. + (gfc_create_string_length): New function. + (gfc_get_symbol_decl): Create lengths for character variables. + (gfc_get_fake_result_decl): Ditto. + (gfc_build_function_decl): Only set length for assumed length + character arguments. + (gfc_trans_dummy_character): New function. + (gfc_trans_auto_character_variable): Rewrite. + (gfc_trans_deferred_vars): Handle more types of character variable. + (gfc_create_module_variable): String lengths have moved. + (gfc_generate_function_code): Initialize deferred var chain earlier. + * trans-expr.c (gfc_conv_init_string_length): Rename ... + (gfc_trans_init_string_length): ... to this. + (gfc_conv_component_ref, gfc_conv_variable, gfc_conv_concat_op, + gfc_conv_function_call): Update to new format for character variables. + (gfc_conv_string_length): Remove. + (gfc_conv_string_parameter): Update assertion. + * trans-intrinsic.c (gfc_conv_intrinsic_len): Use new location. + * trans-io.c (set_string): Use new macro names. + * trans-stmt.c (gfc_trans_label_assign. gfc_trans_goto): Ditto. + * trans-types.c (gfc_get_character_type): Use existing length expr. + (gfc_is_nodesc_array): Make public. + (gfc_get_dtype_cst): Rename ... + (gfc_get_dtype): ... to this. Handle unknown size arrays. + (gfc_get_nodesc_array_type): Use new name. + (gfc_sym_type): New character variable code. + (gfc_get_derived_type): Ditto. + (gfc_get_function_type): Evaluate character variable lengths. + * trans-types.h (gfc_strlen_kind): Define. + (gfc_is_nodesc_array): Add prototype. + * trans.h: Update prototypes. + (struct lang_type): Update comments. + (GFC_DECL_STRING_LEN): New name for GFC_DECL_STRING_LENGTH. + (GFC_KNOWN_SIZE_STRING_TYPE): Remove. + +2004-04-04 Paul Brook <paul@codesourcery.com> + + * gfortran.h (struct gfc_option_t): Remove flag_g77_calls. + * options.c (gfc_init.options, gfc_handle_option): Ditto. + * trans-expr.c (gfc_conv_function_call): Ditto. + * trans-types.c (gfc_is_nodesc_array): Ditto + * lang.opt (fg77-calls): Remove. + +2004-04-04 Paul Brook <paul@codesourcery.com> + + * trans-array.c (OFFSET_FIELD): Rename from BASE_FIELD. + (gfc_conv_descriptor_base): Rename ... + (gfc_conv_descriptor_offset): ... to this. + (gfc_trans_allocate_array_storage): Set offset to zero. + (gfc_conv_array_base): Rename ... + (gfc_conv_array_offset): ... to this. + (gfc_conv_array_index_ref): Add offset parameter. + (gfc_conv_array_ref): Include offset. + (gfc_trans_preloop_setup): Use existing offset. + (gfc_trans_allocate_temp_array, gfc_array_allocate, + gfc_trans_auto_array_allocation, gfc_trans_g77_array, + gfc_trans_dummy_array_bias, gfc_conv_expr_descriptor, + gfc_conf_ss_descriptor): Set offset. + * trans-array.h: Rename prototypes. + * trans-const.h (gfc_index_zero_node): Define. + * trans-decl.c (gfc_build_qualified_array): Change base to offset. + * trans-types.c (gfc_get_array_type_bounds): Ditto. + (gfc_get_nodesc_array_type): Calculate offset before upper bound. + +2004-03-25 Diego Novillo <dnovillo@redhat.com> + + * convert.c (convert): Don't handle WITH_RECORD_EXPR. + +2004-03-24 Bud Davis <bdavis9659@comcast.net> + + PR 14055 + * arith.c (gfc_convert_integer,gfc_convert_real): Removed leading '+' + before conversion by gmp library call. + +2004-03-24 Bud Davis <bdavis9659@comcast.net> + + PR 12921 + * trans-io.c (gfc_trans_open): Change RECL= to a value parameter. + +2004-02-24 Richard Henderson <rth@redhat.com> + + * trans-array.c (gfc_trans_dummy_array_bias): Fix typo. + +2004-02-19 Loren J. Rittle <ljrittle@acm.org> + + * Make-lang.in ($(srcdir)/fortran/gfortran.info): Move... + (fortran/gfortran.info): ... to here. + (f95.srcinfo): New. + +2004-02-16 Richard Henderson <rth@redhat.com> + + * Make-lang.in (f95-lang.o, trans-decl.o): Depend on cgraph.h. + * f95-lang.c (LANG_HOOKS_EXPAND_DECL): Remove. + (LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION): New. + (gfc_expand_function): Rename from expand_function_body, make static, + don't do anything except invoke tree_rest_of_compilation. + (gfc_be_parse_file): Invoke cgraph. + (gfc_expand_decl): Remove. + (gfc_init_builtin_functions): Add __builtin_init_trampoline and + __builtin_adjust_trampoline. + * trans-decl.c (gfc_get_extern_function_decl): Don't set DECL_CONTEXT. + (gfc_finalize): New. + (gfc_generate_function_code): Use it. Lower nested functions. + * trans-expr.c (gfc_conv_function_call): Add static chain operand + to call_expr. + * trans.c (gfc_build_function_call): Likewise. + * trans.h (expand_function_body): Remove. + +2004-02-15 Victor Leikehman <lei@il.ibm.com> + + PR gfortran/13433 + * trans-decl.c (gfc_build_function_decl) For functions + returning CHARACTER pass an extra length argument, + following g77 calling conventions. + * trans-types.c (gfc_get_function_type) Ditto. + * trans-expr.c (gfc_conv_function_call) Ditto. + +2004-02-14 Paul Brook <paul@codesourcery.com> + + * f95-lang.c (gfc_init_builtin_functions): Build chain properly. + +2004-02-12 Paul Brook <paul@nowt.org> + + * BUGS: Remove. + +2004-02-08 Steve Kargl <sgk@troutmask.apl.washington.edu> + + * gfortran.texi: Fix typos. + +2004-02-07 Bud Davis <bdavis9659@comcast.net> + + PR gfortran/13909 + * intrinsic.c (add_conversions) Use logical conversion instead + of real. + * trans-types.c (gfc_get_logical_type) implemented logical*1 + and logical*2. + +2004-01-17 Paul Brook <paul@codesourcery.com> + + * lang-specs.h: Remove %<fixed-form. + +2004-01-15 Toon Moene <toon@moene.indiv.nluug.nl> + + * lang-specs.h: Enable preprocessing of source files + ending in .F, .fpp, .FPP, .F90 and .F95. + +2004-01-13 Toon Moene <toon@moene.indiv.nluug.nl> + + PR fortran/12912 + * lang-specs.h: Enable compilation of files ending + in .f, .for and .FOR. + +2004-01-11 Paul Brook <paul@codesourcery.com> + + * trans-stmt.c (gfc_trans_if_1): New function. + (gfc_trans_if): Use it. + +2004-01-11 Erik Schnetter <schnetter@uni-tuebingen.de> + + * gfortran.h (GFC_MAX_SYMBOL_LEN): Increase. + (gfc_option_t): Add max_identifier_length. + * lang.opt: Add fmax-identifier-length. + * match.c (parse_name): Use limit. + * options.c (gfc_init_options): Set max_identifier_length. + (gfc_handle_option): Ditto. + +2004-01-11 Feng Wang <fengwang@nudt.edu.cn> + + * intrinsic.c (add_functions): Add resolve function to dcmplx. + * intrinsic.h (gfc_resolve_dcmplx): Add prototype. + * iresolve.c (gfc_resolve_dcmplx): New function. + +2004-01-10 Paul Brook <paul@codesourcery.com> + + * trans-decl.c (gfc_get_symbol_decl): Don't set subroutine attr. + * trans-types.c (gfc_sym_type): Handle external dummy procedures. + (gfc_return_by_reference): Correct condition. + (gfc_get_function_type): Ditto. + +2004-01-10 Paul Brook <paul@codesourcery.com> + + * trans-intrinsic.c (gfc_conv_intrinsic_minmax): Convert mismatched + types. + +2004-01-10 Huang Chun <chunhuang73@hotmail.com> + + * iresolve.c: Use correct kind. + +2004-01-10 Huang Chun <chunhuang73@hotmail.com> + + PR fortran/13467 + * trans-decl.c (gfc_create_module_variable): Output array valued + parameters. + +2004-01-10 Paul Brook <paul@codesourcery.com> + + * resolve.c (resolve_branch): Get error message right way round. + +2004-01-10 Canqun Yang <canqun@nudt.edu.cn> + + * trans-array (gfc_conv_loop_setup): Adjust comment to track + reality. + (gfc_array_allocate): Don't count size of element twice. + +2004-01-04 Paul Brook <paul@codesourcery.com> + + * lang.opt (i8, r8, std=*): Remove RejectNegative. + +2004-01-04 Paul Brook <paul@codesourcery.com> + + * error.c (gfc_notify_std): New function. + * gfortran.h (gfc_notify_std): Declare. + (GFC_STD_*): Define. + (gfc_option_t): Add warn_std and allow_std. + * intrinsic.c (gfc_init_expr_extensions): Fix logic. + (gfc_intrinsic_func_interface): Use gfc_notify_std. + * check.c (check_rest): Use gfc_notify_std. + * match.c (gfc_match_pause): Ditto. + (gfc_match_assign): Ditto. + (gfc_match_goto): Ditto. + * resolve.c (resolve_branch): Ditto. + * lang.opt: Add std=<foo> and w. + * options.c (gfc_init_options): Set allow_std and warn_std. + (gfc_handle_option): Handle OPT_std_* and OPT_w. + +2004-01-01 Paul Brook <paul@codesourcery.com> + + * array.c (gfc_append_constructor): Take constructor, not expression. + * data.c (struct gfc_expr_stack): Remove. + (expr_stack): Remove. + (find_con_by_offset): Rename from find_expr_in_con. + (find_con_by_component): Rename from find_component_in_con. + (gfc_get_expr_stack): Remove. + (gfc_assign_data_value): Rewrite. + (gfc_expr_push): Remove. + (gfc_expr_pop): Remove. + (gfc_advance_section): Rename from + gfc_modify_index_and_calculate_offset. Handle unbounded sections. + (gfc_get_section_index): Handle unbounded sections. + * gfortran.h: Update prototypes. + * resolve.c (check_data_variable): Array section maight not be the + last ref. + +2004-01-01 Paul Brook <paul@codesourcery.com> + + PR fortran/13432 + * resolve.c (resolve_symbol): Allow assumed length function results. + +2004-01-01 Steve Kargl <sgk@troutmask.apl.washington.edu> + + * match.c (gfc_match_pause): Fix spelling. + +2004-01-01 Steven Bosscher <stevenb@suse.de> + + PR fortran/13251 + * trans-expr.c (gfc_conv_variable): Take the type kind of a substring + reference from the expression. + +2003-12-26 Feng Wang <fengwang@nudt.edu.cn> + + * dump-parse-tree.c (gfc_show_code_node): Add ASSIGN and ASSIGNED GOTO + dumping. + * gfortran.h (gfc_statement): New ST_LABEL_ASSIGNMENT. + (gfc_exec_op): New EXEC_LABEL_ASSIGN. + (symbol_attribute):New variable attribute: assign. + * io.c (resolve_tag):Integer variable is allowed. + (match_dt_format): Add ASSIGN statement. Set assign flag. + * match.c (gfc_match_if): Change ST_NONE to ST_LABEL_ASSIGNMENT. + (gfc_match_assign): Add ASSIGN statement. Set assign flag. + (gfc_match_goto): Add ASSIGNED GOTO statement. Set assign flag. + * parse.c (decode_statement): Add ST_LABEL_ASSIGNMENT. + (next_statement): Add ST_LABEL_ASSIGNMENT. + (gfc_ascii_statement): Add ST_LABEL_ASSIGNMENT. + * resolve.c (resolve_code): Resolve ASSIGN and ASSIGNED GOTO statement. + (resolve_blocks): Resolve ASSIGNED GOTO statement label list. + * st.c (gfc_free_statement): Add EXEC_LABEL_ASSIGN. + * trans-decl.c (gfc_get_symbol_decl): Create the shadow variable for + assign. Put them into the stuct lang_decl. + * trans-io.c (set_string): Add the assign statement. + * trans-stmt.c (gfc_trans_label_assign): New function. + (gfc_trans_goto): Translate ASSIGNED GOTO statement. + * trans-stmt.h (gfc_trans_label_assign): Added function prototype. + * trans.c (gfc_trans_code): Add EXEC_LABEL_ASSIGN. + * trans.h (lang_decl):Add shadow variable decl tree needed by assign. + (GFC_DECL_ASSIGN_ADDR(node)): New macro to access this. + (GFC_DECL_ASSIGN(node)): New macro to access flag. + +2003-12-31 Huang Chun <chunhuang73@hotmail.com> + + PR fortran/13434 + * trans-intrinsic.c (gfc_conv_intrinsic_minmaxval): Fixed bug in + minval/maxval. + +2003-12-22 Toon Moene <toon@moene.indiv.nluug.nl> + + * options.c (gfc_init_options): Set flag_argument_noalias to 2, to indicate + that arguments to subroutines/functions can't alias themselves, nor global + memory. + +2003-12-20 Steven Bosscher <stevenb@suse.de> + + * trans-expr.c (gfc_conv_expr_op): Fold the result expression. + * trans.c (gfc_add_modify_expr, gfc_add_expr_to_block): Likewise. + +2003-12-12 Huang Chun <chunhuang73@hotmail.com> + + * primary.c (match_substring): Fix substring bug for start point + or end point is NULL. + * trans-expr.c (gfc_conv_substring): Ditto + * trans-types.c (gfc_sym_type): Get correct type of scalar + character variables. + * trans-intrinsic.c (gfc_conv_intrinsic_len): Handle character in + derived type. + +2003-12-10 Richard Henderson <rth@redhat.com> + + * options.c (gfc_post_options): Don't ever use rtl inlining. + +2003-12-05 Canqun Yang <canqun@nudt.edu.cn> + + * trans-common.c: Re-implement COMMON blocks and EQUIVALENCE lists. + * trans-equivalence.c: Remove. + * trans-decl.c (gfc_get_symbol_decl): Update to match. + (gfc_generate_function_code): Ditto. + * trans-array.c (gfc_conv_array_parameter): Ditto. + * Make-lang.in (F95_OBJS): Remove fortran/trans-equivalence.o + (F95_ADDITIONAL_OBJS): Add stor-layout.o + * trans.h (gfc_trans_equivalence): Remove. + * gfortran.h (struct gfc_equiv): Add used field. + (struct gfc_symbol): Remove addr_base, addr_offset, equiv_ring, + equiv_offset fields. + +2003-12-05 Richard Henderson <rth@redhat.com> + + * trans.c (gfc_build_addr_expr): New. + (gfc_build_indirect_ref, gfc_build_array_ref): New. + * trans.h: Declare them. + * trans-array.c, trans-expr.c, trans-intrinsic.c, trans-io.c, + trans-stmt.c, trans.c (*): Use them. + + * f95-lang.c (gfc_post_options): Remove dead prototype. + * trans-array.c (gfc_trans_deferred_vars): Remove unused variable. + * trans-stmt.c (gfc_evaluate_where_mask): Fix temporary_list + allocation size. + +2003-12-01 Feng Wang <fengwang@nudt.edu.cn> + + * io.c (gfc_match_format): Check for missing format label. + +2003-11-30 Huang Chun <chunhuang73@hotmail.com> + + PR fortran/13155 + * trans-decl.c (gfc_sym_mangled_function_id): Don't mangle symbols + from interfaces in modules. + +2003-11-30 Paul Brook <paul@nowt.org> + + * trans-array.c (gfc_trans_g77_array): Make non-static. + (gfc_trans_assumed_size): Remove. + (gfc_trans_dummy_array_bias): Explicitly free temporary. + * trans-array.h (gfc_trans_g77_array): Add prototype. + (gfc_trans_assumed_size): Remove. + * trans-decls.c (gfor_fndecl_push_context): Remove. + (gfor_fndecl_pop_context): Remove. + (gfc_build_function)decls): Don't create them. + (gfc_trans_deferred_vars): Update to match. Remove dead code. + * trans-stmt.c (gfc_trans_pointer_assign_need_temp): Free temp. + +2003-11-30 Kejia Zhao <kejia_zh@nudt.edu.cn> + + * trans-array.c (gfc_conv_array_parameter): Simplify + array argument passing for array name actual argument. + * trans-expr.c (gfc_conv_function_call): Ditto + * trans-types.c (gfc_is_nodesc_array):Ditto. + +2003-11-30 Paul Brook <paul@nowt.org> + + * f95-lang.c (gfc_post_options): Move ... + * options.c (gfc_post_options): .. to here. Handle inlining options. + * gfortran.h (gfc_post_options): Add prototype. + +2003-11-28 Richard Henderson <rth@redhat.com> + + * trans.c (gfc_create_var_np): Use create_tmp_var_raw. + +2003-11-28 Huang Chun <chunhuang73@hotmail.com> + + * trans.h (has_alternate_specifier): New global variable. + * match.c (gfc_match_call): Handle actual arguments associated with + alternate return indicators. + * trans-expr.c (gfc_conv_function_call): Ditto + * trans-stmt.c (gfc_trans_call): Ditto + (gfc_trans_return): Handle return statement with value. + * trans-decl.c (gfc_generate_function_code): Handle functions with + asterisk dummy. + (gfc_get_fake_result_decl): Ditto + * trans-types.c (gfc_get_function_type): Ditto + * resolve.c (resolve_actual_arglist): Check alternate return indicators. + (resolve_formal_arglist): Check asterisk dummy. + +2003-11-27 Paul Brook <paul@nowt.org> + + * trans-array.c (gfc_tran_allocate_array_storage): Use new memory + allocation interface. + (gfc_conv_ array_parameter): Ditto. + (gfc_trans_auto_array_allocation): Ditto. Also free the memory. + * trans-array.c: Update prototype. + * trans-decl.c (gfc_build_builtin_function_decls): Update prototypes. + (gfc_trans_auto_character_variable): Use new memory alloc interface. + * trans-expr.c (gfc_conv_string_tmp): Ditto. + (gfc_conv_function_call): Use gfc_conv_string_tmp. + * trans-stmt.c (gfc_do_allocate): Use new memory alloc interface. + * trans-intrinsic.c (gfc_conv_intrinsic_trim): Ditto. + * trans.h (gfc_ss_info): Remove unused pdata field. + * trans.c (gfc_create_var_np): Change T to V. + +2003-11-26 Richard Henderson <rth@redhat.com> + + * mathbuiltins.def: Move acos, asin, cosh, log10, sinh, tanh from ... + * trans-intrinsic.c (gfc_intrinsic_map): ... here. Add SCALE, + FRACTION, NEAREST, SET_EXPONENT. + (gfc_intrinsic_map_t): Add libm_name, complex_available, is_constant. + Fix GTY marking. Remove unnecessary const's. + (LIBM_FUNCTION): Rename from I_LIB. + (LIBF_FUNCTION): New. + (gfc_get_intrinsic_lib_fndecl): Handle libm and libgfortran naming + conventions. Assume the expr signature is correct. Mark const. + (gfc_conv_intrinsic_exponent): Use library functions. + (gfc_conv_intrinsic_set_exponent): Remove. + (gfc_conv_intrinsic_scale): Remove. + (gfc_conv_intrinsic_nearest): Remove. + (gfc_conv_intrinsic_fraction): Remove. + (gfc_conv_intrinsic_function): Update. + * trans-decl.c (gfor_fndecl_math_exponent4): New. + (gfor_fndecl_math_exponent8): New. + (gfc_build_intrinsic_function_decls): Set them. + * trans.h: Declare them. + +2003-11-25 Canqun Yang <canqun@nudt.edu.cn> + + * trans-common.c (gfc_layout_global_equiv): Locate the error for + underflow COMMON block. + (gfc_trans_one_common): Fix bug for size of COMMON block containing + EQUIVALENCE object. Also fix typo in an error message. + +2003-11-25 Diego Novillo <dnovillo@redhat.com> + + * Make-lang.in: Add check-gfortran to lang_checks. + (check-f95): Alias for check-gfortran. + +2003-11-25 Jason Merrill <jason@redhat.com> + + * Make-lang.in (f95.tags): Create TAGS.sub files in each + directory and TAGS files that include them for each front end. + +2003-11-24 Paul Brook <paul@nowt.org> + + PR fortran/13154 + * trans-decl.c (gfc_greate_module_variable): Skip COMMON blocks. + +2003-11-24 Paul Brook <paul@nowt.org> + + * expr.c (simplify_const_ref): Return SUCCESS for things we don't + handle. + * resolve.c (gfc_resolve_expr): Resolve contents before rank/shape. + +2003-11-24 Paul Brook <paul@nowt.org> + + PR fortran/13105 + * array.c (gfc_array_ref_shape): Handle elemental dimensions. + * trans-array.c (gfc_trans_preloop_setup): Use correct dim lookup. + +2003-11-20 Richard Henderson <rth@redhat.com> + + * trans-array.c (gfc_trans_allocate_array_storage): Use convert. + (gfc_conv_array_base): Likewise. + * trans-decl.c (gfc_trans_auto_character_variable): Likewise. + * trans-expr.c (gfc_conv_string_tmp): Likewise. + * trans-intrinsic.c (gfc_conv_intrinsic_trim): Likewise. + * trans-stmt.c (gfc_trans_character_select): Likewise. + +2003-11-13 Paul Brook <paul@nowt.org> + + * trans-decl.c (gfc_sym_mangled_function_id): Dont mangle externals. + +2003-11-13 Canqun Yang <canqun@nudt.edu.cn> + + * resolve.c (gfc_resolve): Also resolve EQUIVALENCE objects. + (resolve_equivalence): New function. + (resolve_equivalence_derived): New function. + +2003-11-12 Richard Henderson <rth@redhat.com> + + * trans.c (gfc_trans_code): Use annotate_with_locus instead of + annotate_all_with_locus. + +2003-11-11 Canqun Yang <canqun@nudt.edu.cn> + + * options.c (gfc_init_options): Set flag_max_stack_var_size as 32768. + * trans-decl.c (gfc_finish_var_decl): Modified. + +2003-11-08 Paul Brook <paul@nowt.org> + + PR fortran/12704 + * trans-intrinsic.c (gfc_conv_intrinsics_minmaxloc): Handle zero-size + arrays. + +2003-11-06 Paul Brook <paul@nowt.org> + + * trans-intrinsic.c (gfc_conv_intrinsics_minmaxloc): Initialize pos. + +2003-11-02 Canqun Yang <canqun@nudt.edu.cn> + + * match.c (gfc_match_stopcode): Assign '0' to stop_code. + +2003-10-27 Anthony Green <green@redhat.com> + + * Make-lang.in (f95.stageprofile): Use tabs, not spaces. + (f95.stagefeedback): Ditto. + +2003-10-27 Andrew Pinski <pinskia@physics.uc.edu> + + PR fortran/12682 + * Make-lang.in (f95.stageprofile): Add. + (f95.stagefeedback): Add. + +2003-10-23 Richard Henderson <rth@redhat.com> + + * f96-lang.c (gfc_gimplify_expr): Remove. + (LANG_HOOKS_GIMPLIFY_EXPR): Remove. + (LANG_HOOKS_GIMPLE_BEFORE_INLINING): New. + +2003-10-23 Richard Henderson <rth@redhat.com> + + * f95-lang.c (gfc_gimplify_expr): Return gimplify_status. + +2003-10-20 Paul Brook <paul@nowt.org> + + * trans-expr.c (gfc_conv_integer_power): Use boolean_type_node. + * trans-stmt.c (gfc_trans_do_while): Ditto. + +2003-10-17 Paul Brook <paul@nowt.org> + + * simplify.c (gfc_simplify_shape): Use gfc_array_dimen_size. + +2003-10-17 Paul Brook <paul@nowt.org> + + * trans-io.c (gfc_build_io_library_fndecls): Set TREE_PUBLIC. + +2003-10-17 Feng Wang <wf_cs@yahoo.com> + + * iresolve.c (gfc_resolve_maxloc): Change the result's kind and type. + (gfc_resolve_minloc): Ditto. + * trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc): Use correct types. + Return the value after subtracting the lower bound. + +2003-10-16 Richard Henderson <rth@redhat.com> + + * f95-lang.c (expand_function_body): Don't check flag_disable_gimple. + +2003-10-16 Steven Bosscher <steven@gcc.gnu.org> + + * lang.c: Remove -M option for now, it's in the way for C. + +2003-10-14 Jason Merrill <jason@redhat.com> + + * Make-lang.in (f95.tags): New rule. + +2003-10-13 Richard Henderson <rth@redhat.com> + + * trans.c (gfc_trans_code): Use annotate_all_with_locus. + +2003-10-13 Paul Brook <paul@nowt.org> + + * trans-decl.c (generate_local_decl): Don't create junk variables. + +2003-10-13 Paul Brook <paul@nowt.org> + + * resolve.c (resolve_formal_arglist): Use function result decl in + preference to function decl. + +2003-10-12 Richard Henderson <rth@redhat.com> + + * f95-lang.c (gfc_define_builtin): New const_p argument. Set + TREE_READONLY. Update all callers. + +2003-10-12 Feng Wang <wf_cs@yahoo.com> + + * iresolve.c (gfc_resolve_cshift): Change to match implementation. + * trans-intrinsic.c (gfc_conv_intrinsic_function): Remove CSHIFT. + (gfc_is_intrinsic_libcall): Add CSHIFT. + +2003-10-12 Richard Henderson <rth@redhat.com> + + * trans-array.c (gfc_trans_static_array_pointer): Set TREE_INVARIANT. + (gfc_trans_array_constructor_value): Likewise. + (gfc_conv_array_initializer): Likewise. + * trans-stmt.c (gfc_trans_character_select): Likewise. + +2003-11-12 Kejia Zhao <kejia_zh@yahoo.com.cn> + + * trans-intrinsic.c (integer_kind_info, real_kind_info): Remove. + +2003-10-11 Huang Chun <jiwang@mail.edu.cn> + + * check.c (gfc_check_repeat): Check arguments are scalar. + (gfc_check_trim): New function. + * intrinsic.h (gfc_check_trim): Add prototype. + * intrinsic.c (add_functions): Use it. + * trans.h (gfor_fndecl_string_trim, gfor_fndecl_string_repeat): + Decalare. + * trans-decl.c: Ditto. + (gfc_build_intrinsic_fucntion_decls): Set them. + * trans-intrinsic.c (gfc_conv_intrinsic_len): Handle result vars. + (gfc_conv_intrinsic_trim): New function. + (gfc_conv_intrinsic_repeat): New function. + (gfc_conv_intrinsic_function): Use them. + +2003-10-11 Huang Chun <jiwang@mail.edu.cn> + + * trans-types.c (gfc_sym_type): Handle result variables. + +2003-10-11 Huang Chun <jiwang@mail.edu.cn> + + * trans-intrinsic.c (gfc_conv_intrinsic_char): Don't use + gfc_get_character_type. + +2003-10-11 Feng Wang <wf_cs@yahoo.com> + + * trans-expr.c (gfc_conv_variable): Check sym->ts, not the decl. + +2003-10-11 Paul Brook <paul@nowt.org> + + * iresolve.c (gfc_resolve_dint, gfc_resolve_dnint): New functions. + (gfc_resolve_dprod): New function. + (gfc_resolve_aint, gfc_resolve_anint): Only base name on arg type. + * intrinsic.h (gfc_resolve_dint, gfc_resolve_dnint): Declare. + (gfc_resolve_dprod): Declare. + * intrinsic.c (add_functions): Use them. + * trans-decl.c (gfc_get_extern_function_decl): Only pass one arg. + +2003-10-06 Richard Henderson <rth@redhat.com> + + * f95-lang.c (gfc_init_builtin_functions): Add clzll. + * trans-intrinsic.c (call_builtin_clz): Use it. + +2003-10-05 Paul Brook <paul@nowt.org> + + * f95-lang.c (expand_function_body): Call (push|pop)_function_context. + * trans-decl.c (gfc_generate_function_code): Set + cfun->function_end_locus. + +2003-09-24 Jason Merrill <jason@redhat.com> + + * f95-lang.c, trans-decl.c: Use DECL_SOURCE_LOCATION instead of + TREE_LOCUS. + +2003-09-21 Lifang Zeng <zlf605@hotmail.com> + Paul Brook <paul@nowt.org> + + * Make-lang.in (F95_OBJS): Add fortran/data.o. + * array.c (gfc_inser_constructor): New function. + (gfc_get_constructor): New function. + (gfc_free_constructor): Initialize offset and repeat. + (iterator_stack): Remove. + (expand_info): Add offset, component and repeat fields. + (expand_constructor): Set them. + (expand): Set new fields. + (gfc_copy_constructor): Ditto. Avoid recursion. + * gfortran.h: Add prototypes for new functions. + (gfc_constructor): Add offset, component and repeat. + (iteratio_stack): Move to here. + * resolve.c (check_data_variable): Convert data values into variable + initializers. + (traverse_data_list): Build implicit loop chain. + (gfc_resolve): Ditto. + * trans-array.c (gfc_conv_array_intializer): Handle repeat count. + * trans-decl.c (gfc_get_symbol_decl): Use gfc_conv_structure. + * trans-expr.c (gfc_conv_structure): Handle array initializers. + (gfc_conv_expr): Update to match. + * trans.h (gfc_conv_structure): Declare. + * data.c: New file. + +2003-09-20 Kejia Zhao <kejia_zh@yahoo.com.cn> + + * trans.h: Add declarations for gfor_fndecl_si_kind and + gfor_fndecl_sr_kind. + * trans-decl.c (g95_build_intrinsic_function_decls): Build them. + * trans-intrinsic.c (g95_conv_intrinsic_si_kind): New function. + (g95_conv_intrinsic_sr_kind): New function. + (g95_conv_intrinsic_function): Add SELECTED_INT_KIND and + SELECTED_REAL_KIND. + +2003-09-17 Lars Segerlund <Lars.Segerlund@comsys.se> + + * iresolve.c (gfc_resolve_random_number): Generate _r4 & _r8 + instead of _4 and _8 as postfix for libgfortran calls. + +2003-09-16 Paul Brook <paul@nowt.org> + + * array.c (compare_bounds): New function. + (gfc_compare_array_spec): Use it. + +2003-09-14 Paul Brook <paul@nowt.org> + + * primary.c (gfc_match_rvalue): Make sure sym->result is set. + * trans-expr.c (gfc_conv_string_parameter): Also allow PRAM_DECLs. + +2003-09-14 Paul Brook <paul@nowt.org> + + * check.c (dim_rank_check): Allow assumed bounds if requested. + (gfc_check_lbound): Call it. + (gfc_check_ubound): Ditto. + (gfc_check_size): Change to match. + * simplify.c (gfc_simplify_bound): New function. + (gfc_simplify_lbound): New function. + (gfc_simplify_ubound): New function. + * intrinsic.h: Declare them. + * intrinsic.c (add_functions): Use them. + +2003-09-14 Paul Brook <paul@nowt.org> + + * io.c (format_lex): Initialize negative_flag. + (check_format): Intialize repeat. + * trans-io.c (gfc_new_nml_name_expr): Declare static. + (gfc_new_var_expr): Ditto. + +2003-09-14 Paul Brook <paul@nowt.org> + + * trans-array.c (gfc_conv_array_initializer): Handle derived types. + * trans-decl.c (gfc_get_symbol_decl): Only do local scalar values. + +2003-09-12 Paul Brook <paul@nowt.org> + + * trans-intrinsic.c (gfc_conv_intrinsic_sign): Call fold. + +2003-09-12 Zdenek Dvorak <rakdver@atrey.karlin.mff.cuni.cz> + + * fortran/trans.c (gfc_finish_block): Call rationalize_compound_expr + for a correct expression. + +2003-09-10 Kejia Zhao <kejia_zh@yahoo.com.cn> + + * trans-intrinsic.c (real_compnt_info): New struct. + (prepare_arg_info): New function. + (gfc_conv_intrinsic_set_exponent): New function. + (gfc_conv_intrinsic_scale): New function. + (gfc_conv_intrinsic_nearest): New function. + (gfc_conv_intrinsic_fraction): New function. + (gfc_conv_intrinsic_exponent): New function. + (gfc_conv_intrinsic_spacing): New function. + (gfc_conv_intrinsic_rrspacing): New function. + (gfc_conv_intrinsic_function): Use them. + +2003-08-24 XiaoQiang Zhang (zhangapache@yahoo.com> + + * trans-const.c (gfc_conv_mpz_to_tree): Fix bug, parameter for + build_int_2 changed from (high, low) to (low, high). + * trans-io.c (ioparm_namelist_name, ioparm_namelist_name_len, + ioparm_namelist_read_mode, iocall_set_nml_val_int, + iocall_set_nml_val_float, iocall_set_nml_val_char, + iocall_set_nml_val_complex, iocall_set_nml_val_log): New declaration. + (gfc_build_io_library_fndecls): Add variable initialization. + (gfc_new_nml_name_expr, get_new_var_expr): New function. + (build_dt): Add namelist support. + * io.c (value): New variable. + (check_format): Support FMT_H now. + +2003-09-07 Paul Brook <paul@nowt.org> + + * io.c (gfc_resolve_dt): Error if format label is not defined. + +2003-09-07 Kejia Zhao <kejia_zh@yahoo.com.cn> + + * trans-intrinsic.c (gfc_conv_intrinsic_aint): Fix two bugs. One is + about case_switch's break. The other is about building the condition + statement tree, which judges the argument in the range of the + corresponding integer type. + * trans-intrinsic.c (gfc_conv_intrinsic_mod): MOD and MODULO can work + for the large values. + +2003-09-05 Paul Brook <paul@nowt.org> + + * f95-lang.c (expand_function_body): Gimplify the function. + +2003-09-04 Jeff Law <law@redhat.com> + + * f95-lang.c (DEFINE_MATH_BUILTIN): C arrays start at + index zero! + +2003-09-04 Paul Brook <paul@nowt.org> + + * f95-lang.c (gfc_define_builtin): Also set implicit_built_in_decls. + (gfc_expand_stmt): New function. + (LANG_HOOKS_RTL_EXPAND_STMT): Define. + (expand_function_body): Use tree_rest_of_compilation. + * trans-decl.c (gfc_generate_function_code): Don't free cfun. + +2003-09-03 Jeff Law <law@redhat.com> + + * f95-lang.c (gfc_init_builtin_functions): C arrays start at + index zero! + +2003-08-30 Paul Brook <paul@nowt.org> + + * f95-lang.c (builtin_function): Remove #if 0 code. + (gfc_define_builtin): New function. + (gfc_init_builtin_functions): Use mathbuiltins.def not ../builtins.def. + * mathbuiltins.def: New file. + * trans-intrinsic.c (gfc_intrinsic_map_t): Add builtin code fields. + (gfc_intrinsic_map): Use mathbuiltins.def. + (gfc_intrinsic_builtin_t): Remove. + (gfc_build_intrinsic_lib_fndecls): Update. + * trans-types.c (gfc_init_types): Remove redundant initilaization of + signed_size_type_node. + +2003-08-29 Paul Brook <paul@nowt.org> + + * arith.c (gfc_real_kinds): Use correct minimum exponents. + +2003-08-22 Kejia Zhao <kejia_zh@yahoo.com.cn> + + * trans-instinsic.c (gfc_conv_intrinsic_mod): Also do MODULO. + (gfc_conv_intrinsic_function): Add MODULO. + +2003-08-22 Jason Merrill <jason@redhat.com> + + * trans-array.c (gfc_conv_expr_descriptor): Update use of predicates. + +2003-08-22 Andreas Jaeger <aj@suse.de> + + * Make-lang.in (f95.install-common): Add DESTDIR support. + * (f95.install-info): Likewise. + (f95.uninstall): Likewise. + +2003-08-19 Diego Novillo <dnovillo@redhat.com> + + * trans-types.c (gfc_init_types): Initialize + signed_size_type_node with size_type_node. + +2003-08-18 Paul Brook <paul@nowt.org> + + * dependency.c (gfc_dependency): New enum. + (check_another_array_ref): Remove. + (gfc_get_array_from_component): Remove. + (get_x): Remove. + (get_range): Remove. + (get_no_of_elements): Use mpz_t, not mpf_t. + (transform_sections): New function. + (gfc_check_range_range): Rename ... + (gfc_check_section_vs_section): ... to this. Use new function. + (gfc_is_inside_range): Rewrite to match. + (gfc_check_element_vs_section): Ditto. + (gfc_check_element_vs_element): Ditto. + (get_deps): Ditto. + (gfc_dep_resolver): Ditto. Remove unused parameter. + * Dependency.h (gfc_check_range_range, gfc_check_element_vs_section, + gfc_check_element_vs_element, gfc_is_inside_range, + gfc_get_array_from_component): Remove prototypes for static functions. + (gfc_dep_resolver): Update prototype. + * trans-array.c (gfc_conv_resolve_dependencies): Change to match. + +2003-08-15 Paul Brook <paul@nowt.org> + + * trans-decl.c (gfc_build_qualified_array): Don't add symbols for + return values to parent scope. + (gfc_build_dummy_array_decl): Ditto. + +2003-08-14 Paul Brook <paul@nowt.org> + + * trans-stmt.c (gfc_trans_allocate): Handle NULL refs. Allocate the + size of the type, not the pointer. + * resolve.c (resolve_symbol): Give more accurate error message. + +2003-08-10 Paul Brook <paul@nowt.org> + + * trans-decl.c (gfc_build_function_decl): Only mangle global symbols. + +2003-08-10 Paul Brook <paul@nowt.org> + + * trans-stmt.c (gfc_trans_allocate): Correctly handle non-array derived + type components. + +2003-08-10 Chun Huang <compiler@sohu.com> + + * resolve.c (resolve_formal_arglist): Resolve STATEMENT function. + (resolve_symbol): Ditto. + * trans-expr.c (gfc_conv_statement_function): New function. + (gfc_conv_function_expr): Use it. + +2003-08-10 Paul Brook <paul@nowt.org> + + * trans-array.c (gfc_conv_ss_startstride): Handle functions. + (walk_function_expr): Set section rank. + * trans-intrinsic.c (gfc_walk_intrinsic_libfunc): Ditto. + +2003-08-10 Paul Brook <paul@nowt.org> + + * intrinsic.c (add_sym): Prefix names with correct string. + (add_sym_0s): New function. + (add_subroutines): Register abort. + +2003-08-10 Erik Schnetter <schnetter@uni-tuebingen.de> + + * gfortran.h: Introduce options to control the mangling. + * lang.opt: Likewise. + * options.c (gfc_init_options): Handle the options. + * trans-common.c (gfc_sym_mangled_common_id): New function. + (gfc_build_common_decl): Call it. + * trans-decl.c (gfc_sym_mangled_function_id): New function. + (gfc_get_extern_function_decl, gfc_build_function_decl): Call it. + +2003-08-09 Paul Brook <paul@nowt.org> + + * module.c (mio_symbol): Always ouput a namespace for formal args. + (load_needed): Namespace now belong to their proper symbol. + (gfc_dump_module): Change G95=>GFORTRAN. + +2003-08-05 Paul Brook <paul@nowt.org> + + * options.c: Force -fg77-calls. + +2003-08-02 Paul Brook <paul@nowt.org> + + * Makelang.in: Rename G95_* to GFORTRAN_*. + * All sources: Rename G95_* to GFC_*. + +2003-08-01 Paul Brook <paul@nowt.org> + + * fortran/Make-lang.in: Use GMPLIBS. + * fortran/config-lang.in: Set need_gmp. + * trans-expr.c (gfc_conv_variable): Remove incorrect assertion. + +2003-07-27 Andreas Jaeger <aj@suse.de> + + * trans-decl.c (gfc_generate_constructors): Convert prototype to + ISO C90. + * trans-const.c (gfc_init_constants): Likewise. + * trans-intrinsic.c (gfc_build_intrinsic_lib_fndecls): Likewise. + + * gfortranspec.c: Convert to ISO C90. + (lang_specific_driver): Correct copyright, remove ALT_LIBM usage. + +2003-07-26 Paul Brook <paul@nowt.org> + + * lang.opt: Add -fdump-parse-tree. + * options.c (gfc_handle_option): Ditto. + * resolve.c (resolve_forall_iterators): Convert to proper type. + * trans-stmt.c (gfc_trans_forall_1): Create temp var with correct type. + +2003-07-26 Paul Brook <paul@nowt.org> + + * Makefile.in: Add build dependencies on files common with rest of gcc. + +2003-07-26 Lifang Zeng <zlf605@hotmail.com> + + * trans.h: Declare g95_trans_pointer_assignment. + * trans-expr.c (g95_trans_pointer_assignment): New function. + (g95_trans_pointer_assign): Use it. + * trans-stmt.c (g95_trans_forall_1): Handle pointer assignment. + (g95_trans_pointer_assign_need_temp): New function. + +2003-07-26 Paul Brook <paul@nowt.org> + + * gfortran.texi: Replace references to g95. + +2003-07-26 Paul Brook <paul@nowt.org> + + Rename g95_* to gfc_*. + +2003-07-25 Paul Brook <paul@nowt.org> + + * gfortran.h: Rename from g95.h. + * trans-types.c (boolean_type_node, booelan_true_node, + boolean_false_node): Remove. + * trans-types.h: Ditto. + +2003-07-25 Chun Huang <compiler@sohu.com> + + * parse.c (accept_statement): Implement BLOCK DATA statement. + * trans-expr.c (g95_conv_variable): Fix bug for dereference pointer + variables. + +2003-07-24 Lifang Zeng <zlf605@hotmail.com> + + * trans-stmt.c (temporary_list): Define. + (g95_trans_assign_need_temp): New function. + (g95_trans_forall_1): Modified for WHERE. + (g95_trans_where_assign): Modified. + (g95_trans_where_2): Modified. + (g95_evaluate_where_mask): Modified. + (g95_trans_where): Modified. + (g95_get_temp_expr): Removed. + (g95_add_to_where_stmt_list): Removed. + (compute_overall_iter_number): Modified for WHERE. + * trans.h: Remove where_stmt_list. + +2003-07-24 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * lang.opt: Correct description of options -J and -M. + +2003-07-23 Steven Bosscher <steven@gcc.gnu.org> + + * lang.opt: Move help text to here. + * lang-options.h: Remove. + +2003-07-23 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + * iresolve.c (g95_resolve_transpose): Proper variable in switch. + * simplify.c (g95_simplify_nearest): Fix typo and use a correct test + on kind. + +2003-07-22 Steven Bosscher <steven@gcc.gnu.org> + Paul Brook <paul@nowt.org> + + * check.c (check_rest): Use global pedantic flag. + * io.c (data_desc): Ditto. + * error.c (g95_warning, g95_warning_now): Use global flag. + * f95-lang.c (LANG_HOOKS_HANDLE_OPTION): Rename from DECODE. + (expand_function_body): Update to new prototypes. + (g95_init): Use new option names. + * g95.h (g95_option_t): Standardize names. + (g95_init_options, g95_handle_option): Update prototypes. + * interface.c: Use new option names. + * match.c: Ditto. + * module.c: Ditto. + * parse.c: Ditto. + * primary.c: Ditto. + * resolve.c: Ditto. + * scanner.c: Ditto. + * simplify.c: Ditto. + * symbol.c: Ditto. + * trans-array.c: Ditto. + * trans-expr.c: Ditto. + * trans-types.c: Ditto. + * trans-decl.c: Ditto. + (g95_build_library_function_decl): Remove obsolete VPARAMS. + * trans.h: Ditto. + * options.c (g95_display_help): Remove. + (g95_init_options): Convert to new scheme. + (set_Wall): Ditto + (g95module_option): Ditto, rename from g95_parse_arg. + (g95_handle_module_path_options): New function. + * trans-equivalence.c: Fix error message. + * lang.opt: Corrections. + +2003-07-21 Steven Bosscher <steven@gcc.gnu.org> + + * lang.opt: New file. + +2003-07-21 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * decl.c (match_attr_spec): Set colon_seen. + +2003-07-14 Paul Brook <paul@nowt.org> + + * trans-array.c: Update comment. + (g95_trans_array_constructor_subarray): Cleanup loopinfo data. + * trans-intrinsic.c (g95_conv_intrinsic_anyall,count,arith, + minmaxloc,minmaxval): Ditto. + * trans-io.c (g95_trans_transfer): Ditto. + * trans-stmt.c: Remove unneeded prototypes. + (generate_loop_for_lhs_to_rhs): Rename vars. Add loop post chain. + (generate_loop_for_rhs_to_temp): Rename vars. Don't share loopinfo. + (compute_inner_temp_size): Remove bits of dead code. Add comments. + Don't share loopinfo. + (compute_overall_iter_number): Declare as static. + (allocate_temp_for_forall_nest): Ditto. + (g95_trans_forall_1): Don't pass shared loopinfo. + * trans.c (g95_start_block): Expand comment. + +2003-07-12 Paul Brook <paul@nowt.org> + + * arith.c (g95_index_integer_kind): Remove unused initializer. + * trans-stmt.c (generate_loop_for_temp_to_lhs): Don't multiply array + index by size of element. + (generate_loop_for_rhs_to_temp): Ditto. + (allocate_temp_for_forall_nest): Use element size, not index size. + +2003-07-11 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * arith.c (g95_index_integer_kind): Add a TODO. + * simplify.c (g95_simplify_nearest): Add a TODO. + +2003-07-09 Chun Huang <compiler@sohu.com> + + * trans.h: Add declarations for gfor_fndecl_string_scan and + gfor_fndecl_string_verify. + * trans-decl.c (g95_build_intrinsic_function_decls): Build them. + * trans-intrinsic.c (g95_conv_intrinsic_scan): New function. + (g95_conv_intrinsic_verify): New function. + (g95_conv_intrinsic_function): Add SCAN and VERIFY. + * simplify.c (g95_simplify_scan, g95_simplify_verify): Fix bug in case + of parameter 'BACK=.TRUE.' + +2003-07-05 Lifang Zeng <zlf605@hotmail.com> + + * trans-stmt.c (iter_info, forall_info): Define. + (g95_trans_forall_block): Remove. + (g95_trans_forall_loop): Use forall info blocks. + (g95_trans_nested_forall_loop): New function. + (g95_do_allocate): Handle things other than logical masks. + (generate_loop_for_temp_to_lhs): New function. + (generate_loop_for_rsh_to_temp): New function. + (compute_inner_temp_size): New function. + (compute_overall_iter_number): New function. + (allocate_temp_for_forall_nest): New function. + (g95_trans_forall): Move body ... + (g95_trans_forall_1): ... to here. Handle loops with temporaries. + +2003-07-02 Paul Brook <paul@nowt.org> + + * trans-decl.c (create_index_var, g95_build_qualified_array): Put vars + in correct scope. Change callers to match. + * trans-types.c (g95_get_dtype_cst): Allow rank 7 arrays. + * iresolve.c (g95_resolve_reshape): Only use constant shapes. + +2003-07-02 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_conv_loop_setup): Remove dead var. Use + expression shape for all expressions. + * trans-decl.c (g95_symbol_init): Allow adding at very end of list. + +2003-07-03 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * g95.h (g95_option_t), lang-options.h, options.c (g95_init_options, + g95_parse_arg), intrinsic.c (g95_convert_type): support of + -Wconversion. + * intrinsic.c, g95.h: Add g95_convert_type_warn, + * resolve.c (g95_resolve_index): Call it. + +2003-07-02 Paul Brook <paul@nowt.org> + + * iresolve.c (g95_resolve_reshape): Set expression shape. + (g95_resolve_shape): Ditto. + * simplify.c (g95_simplify_shape): Move common code outside condition. + * trans-array.c (g95_conv_array_initializer): Teach it how to count. + +2003-07-01 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * array.c (g95_array_dimen_size): Deal with EXPR_ARRAY to improve + conformance checks. + +2003-06-29 Paul Brook <paul@nowt.org> + + * array.c (g95_simplify_iterator_var): Don't bother with return value. + * expr.c (find_array_element, find_component_ref): New functions. + (remove_subobject_ref): New function. + (simplify_const_ref): Use them. Rename from simplify_component_ref. + (simplify_ref_chain): New function. + (g95_simplify_expr): Use it. Simplify parameter variable subobjects. + (g95_specification_expr): Simplify the expression. + * resolve.c (resolve_operator): Check simplifications return code. + (g95_resolve_expr): Ditto. + +2003-06-26 Paul Brook <paul@nowt.org> + + * expr.c (simplify_component_ref): New function. + (g95_simplify_expr): Use it. + * resolve.c (resolve_structure_cons): Handle references. + +2003-06-25 Paul Brook <paul@nowt.org> + + * trans-io.c (build_dt): Handle internal units. + +2003-06-25 Canqun Yang <canqun@yahoo.com.cn> + + * trans-common.c (g95_build_common_decl): Array index range starts at 0. + (g95_build_common_decl, g95_layout_global_equiv, g95_trans_one_common): + Use g95_array_index_type instead of integer_type_node. + (g95_build_common_decl, g95_set_common_master_type): Use + g95_character1_type_node instead of char_type_node. + * trans-equivalence.c (g95_layout_local_equiv): As above. + +2003-06-24 Steven G. Kargl <kargls@attbi.com> + + * g95.h (g95_option_t), options.c (g95_init_options, g95_parse_arg): + remove last remains of -fquiet. + +2003-06-22 Paul Brook <paul@nowt.org> + + * resolve.c (resolve_operator): Don't fail if we can't simplify. + (g95_resolve_expr): Ditto. + (resolce_code): Mark as static. + * trans-stmt.c (g95_trans_chaaracter_select): Mark labels because the + gimplifer doesn't (yet). + +2003-06-20 Paul Brook <paul@nowt.org> + + * g95.h: Add ST_PAUSE and EXEC_PAUSE. + * match.c (g95_match_if): Add ST_PAUSE. + (g95_match_stopcode): New function. + (g95_match_pause, g95_match_stop): Use it. + * parse.c (g95_ascii_statement): Handle ST_PAUSE. + (decode_stmt, next_statement, parse_executable): Ditto. + * resolve.c (resolve_code): Ditto. + * st.c (g95_free_statement): Ditto. + * trans-stmt.c (g95_trans_pause): New function. + * trans-stmt.h: Declare it. + * trans.c (g95_trans_code): Use it. + * trans-decl.c (gfor_fndecl_pause_numeric, gfor_fndecl_pause_string): + Declare. + (g95_build_builtin_function_decls): Initialize them. + * trans.h: Ditto. + * dump-parse-tree.c (g95_show_code_node): Handle EXEC_PAUSE. + +2003-06-18 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * io.c (g95_match_open , g95_match_close, g95_match_inquire, + match_filepos): Fix error handling. + +2003-06-18 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * array.c (spec_dimen_size, ref_dimen_size, g95_array_dimen_size): + Add assertions on arguments. + * resolve.c (expression_shape): Remove useless &. + * simplify.c (get_kind, g95_simplify_bit_size, g95_simplify_digits, + g95_simplify_ibclr, g95_simplify_ibits, g95_simplify_ibset, + g95_simplify_ishft,g95_simplify_ishftc, g95_simplify_maxexponent, + g95_simplify_minexponent, g95_simplify_radix, g95_simplify_range + g95_simplify_rrspacing, g95_simplify_scale, g95_simplify_spacing, + g95_simplify_tan, g95_simplify_tiny): Clean predicates and assertions. + (g95_simplify_not, g95_simplify_scale): Add assertions. + +2003-06-15 Paul Brook <paul@nowt.org> + + Clean up stuff to work with the ssa optimizers. + * convert.c (convert): Handle BOOLEAN_TYPEs. + * f95-lang.c (g95_truthvalue_conversion): Implement. + * trans-array.c (g95_trans_array_constructor_value): Group multiple + scalar values. + * trans.h (g95_truthvalue_conversion): Declare. + * trans-intrinsic.c (g95_conv_intrinsic_anyall): Use bool constants. + * trans-stmt.c (g95_trans_character_select): Don't create array + assignments. Mark labels as indirect jump targets. + * trans-types.h (g95_init_types): Use BOOLEAN_TYPE nodes. + (g95_get_dtype_cst): Handle LOGICAL types. + +2003-06-14 Paul Brook <paul@nowt.org> + + * f95-lang.c (g95_gimplify_expr): New function. + * trans-array.c (g95_trans_array_constructor_value): Don't create + array assignments. + (g95_conv_expr_descriptor): Rename simple->gimple. + * trans-expr.c (conv_expr_op): Use proper logical operators. + * trans-intrinsic.c (build_fixbound_expr): New function. + (build_fix_expr): Ditto. + (g95_conv_intinsic_aint): Use them. Use builtin functions. + (g95_conv_intrinsic_function): Add FLOOR and CEILING. + +2003-06-10 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * array.c (g95_compare_array_spec): Remove unreachable code. + * expr.c (g95_copy_expr): Likewise. + * intrinsic.c (g95_convert_type): Likewise. + * misc.c (g95_code2string): Likewise. + * simplify.c (g95_simplify_ishft, g95_simplify_real, + g95_simplify_reshape, g95_simplify_sign, g95_simplify_sqrt): Likewise. + * trans-stmt.c (g95_trans_select): Likewise. + * primary.c (extend_ref): Add an assertion. + * simplify.c (g95_convert_constant): Add const. + * intrinsic.h: Remove g95_check_x_ni. + * f95-lang.c (g95_finish): Call g95_release_include_path. + +2003-06-10 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * resolve.c (resolve_contained_functions): Fix typo introduced on + 2003-01-13. + +2003-06-09 Paul Brook <paul@nowt.org> + + * g95.h: Include system.h not hwint.h. + * many: use safe-ctype.h not ctype.h. Change isalpha -> ISALPHA, etc. + * misc.c (g95_getmem): Use xmalloc/memset instead of calloc. + +2003-06-09 Paul Brook <paul@nowt.org> + + * g95.h (g95_symbol): Add fields for COMMON and EQUIVALENCE variables. + * Make-lang.in (F95_OBJS): Add files for COMMON and EQUIVALENCE. + * trans-decl.c (g95_add_decl_to_functions): Make non-static. + (g95_get_symbol_decl): Handle COMMON and EQUIVALENCE objects. + (g95_generate_function_code): Translate COMMON and EQUIVALENCE + objects. + * trans.h (g95_trans_equivalence, g95_trans_common, + g95_add_decl_to_function): Declare. + * trans-common.c, trans-equivalence.c: New files. + +2003-06-08 Steven Bosscher <steven@gcc.gnu.org> + + * intrinsic.c (g95_intrinsic_extension): Remove. + (add_functions): Substitute g95_check_x for g95_check_x_ni + everywhere. + (g95_init_expr_extensions): New function. + (g95_intrinsic_func_interface): Use it. + * intrinsic.h: Remove extern decl for g95_intrinsic_extension. + * check.c (g95_check_digit, g95_check_huge, g95_check_kind, + g95_check_precision, g95_check_present, g95_check_radix, + g95_check_range, g95_check_selected_real_kind): Do not set + g95_intrinsic_extension. + (g95_check_x_ni): Remove now duplicate of g95_check_x. + + * expr.c (check_inquiry): Add FIXME, fixup some code style. + +2003-06-06 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * g95.h (ref_type): Name this type explicitly. + * module.c (MIO_NAME): Add specialisations of mio_name. + (mio_symbol_attribute, mio_typespec, mio_array_ref, + mio_array_spec, mio_ref, mio_expr, mio_symbol): Use them. + (ab_attribute): Name this type explicitly. + (mio_symbol_attribute, mio_expr): Add cast to call to find_enum. + +2003-06-05 Kejia Zhao <kejia_zh@yahoo.com.cn> + + * trans-intrinsic.c (g95_conv_allocated): New function. + (g95_conv_intrinsic_function): Make G95_ISYM_ALLOCATED work. + +2003-06-05 Steven Bosscher <steven@gcc.gnu.org> + + * f95-lang.c: Don't include g95-support.h + (g95_mark_addressable): Add prototype. + (g95_init_decl_processing): Remove C front end hack. + * f95-tree.c: Remove file. + * support.c: Remove file. + * g95-support.h: Remove file. + * trans-types.c (g95_init_types): Set up boolean + type related tree nodes. + * Make-lang.in: Remove rules for dead files and + dependencies on them. + +2003-06-05 Steven Bosscher <steven@gcc.gnu.org> + + * Make-lang.in (F95_ADDITIONAL_OBJS): Remove the final + C front end dependency. Also, convert.c does not depend on + g95-support.h anymore. + * convert.c: Don't include c-common.h and g95-support.h + * f95-lang.c: Don't inlude c-common.h and c-common.def (3x). + (g95_stmt_tree, g95_scope_stmt_stack, anon_aggr_type_p, + stmts_are_full_exprs_p, current_stmt_tree, + current_scope_stmt_stack): Remove. + * g95-support.h (unsigned_conversion_warning): Kill proto. + (boolean_type_node, boolean_true_node, boolean_false_node): + Don't define here. Instead, make then true tree nodes in + trans-types. + * support.c (c_global_trees): Die, C front end, die!!! + (g95_init_c_decl_hacks): Don't touch intmax_type_node, + uintmax_type_node, string_type_node and const_string_type_node. + (decl_constant_value, overflow_warning): Make static functions. + They are in death row too, though. + (default_conversion, c_expand_asm_operands): Remove. + * trans-array.c, trans-expr.c, trans-intrinsic.c, trans-stmt.c, + trans.c: Don't include c-common.h. + * trans-types.c (boolean_type_node, boolean_true_node, + boolean_false_node): Make them real tree nodes. + * trans-types.h (intmax_type_node, string_type_node, + const_string_type_node): Hack to work around C dependencies + in builtin-types.def. + +2003-06-04 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * decl.c (decl_types): Add some iterators-like sentinels. + * decl.c (match_attr_spec): Use them. + Use "decl_types" instead of "int". + Add cast in call to g95_match_strings. + * dump-parse-tree.c (g95_show_namespace): Use "g95_intrinsic_op" + instead of "int". + * g95.h (g95_intrinsic_op): Add some iterators-like sentinels. + (g95_interface_info): Use "g95_intrinsic_op". + * dump-parse-tree.c (g95_show_namespace): Use them. + * interface.c (g95_check_interfaces): Use them. + * module.c (read_module, write_module): Use them. + * symbol.c (g95_get_namespace, g95_free_namespace): Use them. + Use "g95_intrinsic_op". + * interface.c (check_operator_interface): Use "g95_intrinsic_op". + Add a default case in switch statement. + * intrinsic.h (g95_generic_isym_id): Moved to... + * g95.h (g95_generic_isym_id): here. + (g95_intrinsic_sym): Use "g95_generic_isym_id". + * intrinsic.c (make_generic): Use "g95_generice_isym_id". + * trans-intrinsic.c (g95_intrinsic_map_t, + g95_conv_intrinsic_lib_funtion): Use "g95_generice_isym_id". + * match.c (g95_match_intrinsic_op): Add cast in call to + g95_match_strings. + +2003-06-03 Steven Bosscher <steven@gcc.gnu.org> + + * support.c (skip_evaluation, warn_conversion, lvalue_p, + lvalue_or_else, pedantic_lvalue_warning, warn_for_assignment, + constant_fits_type_p, convert_and_check, + unsigned_conversion_warning): Remove these ugly remnants + we inherited from the C front end. + (function_types_compatible): Remove '#if 0'-edcode. + (build_modify_expr): Likewise. + (convert_for_assignment): Don't use the deceased functions. + The parameter fundecl is now unused. + (decl_constant_value): Always just return decl. In fact + this function is not used at present, but it might be in + the future, when we start using the tree inliner. + (overflow_warning, default_conversion, c_expand_asm_operands): + Abort when these are called, they are part of the C type + checking implementation and therefore poison to Fortran. + +2003-06-04 Steven Bosscher <steven@gcc.gnu.org> + + * Make-lang.in (F95_ADDITIONAL_OBJS): Don't depend on + c-pretty-print.o and c-dump.o. Add a comment on why we + depend on c-semantics.c. + * f95-lang.c (LANG_HOOKS_TREE_DUMP_DUMP_TREE_FN): + Don't use the C front end tree dumper hook to dump the + language specific tree representation -- we don't have + one. So instead, inherit the default langhook. + +2003-06-02 Paul Brook <paul@nowt.org> + + * trans-expr.c (g95_conv_variable): Remove incorrent assertion. + +2003-06-02 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * check.c (g95_check_associated): Use proper types. Remove + extraneous argument in call to g95_error(). + +2003-06-02 Kejia Zhao <kejia_zh@yahoo.com.cn> + + * resolve.c (resolve_operator): Make logical operands convert to the + type with higher kind. + +2003-06-02 Kejia Zhao <kejia_zh@yahoo.com.cn> + + * check.c (g95_check_associated): Make sure both pointer and target has + the same type and rank. Null pointer or array section with vector + subscript as target are not allowed. + * trans.h: Declare gfor_fndecl_associated. + * trans-decl.c: (g95_build_builtin_function_decls): Initialize + gfor_fndecl_associated. + * trans-intrinsic.c (g95_conv_associated): New function. + (g95_conv_intrinsic_function): Make G95_ISYM_ASSOCIATED work. + +2003-06-02 Kejia Zhao <kejia_zh@yahoo.com.cn> + + * trans-array.c (g95_conv_expr_descriptor): Set the base of POINTER + according to POINTER itself rather than TARGET. + (g95_conv_expr_descriptor): Make lbound start at 1. + * trans-expr.c (g95_trans_pointer_assign): Fix a bug for Nullify. + +2003-06-01 Paul Brook <paul@nowt.org> + + * expr.c (g95_type_convert_binary): Make it match the standard. + * g95.texi: Remove dead link. + +2003-06-01 Steven Bosscher <steven@gcc.gnu.org> + + * g95.texi: Cleanup somewhat in preparation for inclusion + in GCC CVS. + +2003-05-23 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + Canqun Yang <canqun@yahoo.com.cn> + + * resolve.c (compare_bound_int, resolve_where_shape): Proper return + type. + (g95_find_forall_index): Return proper value. + (g95_resolve_assign_in_forall, g95_resolve_forall): Use proper type to + compare the return value from g95_find_forall_index. + +2003-05-23 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + * g95.h, io.c (g95_st_label): Remove "length". + (g95_symtree): Remove "link". + (g95_case): Remove "code". + * arith.c, arith.h (g95_compare_string, g95_convert_integer, + g95_convert_real): Make an argument pointer to const. + * decl.c (colon_seen): Add a TODO. + * interface.c (g95_compare_types): Fix typo. + * interface.c (compare_interfaces): Preserve value of "p". + * intrinsic.c (sort_actual): Remove "i". + * match.c (g95_match_assign): Proper type in call to g95_match(). + * parse.c (next_free): Avoid duplicate call due to macro. + * parse.c (check_statement_label): wrong type in call to g95_error. + * primary.c (match_real_constant): Add a TODO. + * resolve.c (resolve_select): Remove useless conditional. + * simplify.c (g95_simplify_repeat): Proper assignment to + "value.character.string". + * simplify.c (g95_simplify_reshape): Wrong variable in call to + g95_error. + +2003-05-20 Canqun Yang <canqun@yahoo.com.cn> + + * trans-stmt.c: Remove unnecessary include file defaults.h. + +2003-05-19 Lifang Zeng <zlf605@hotmail.com> + + * trans-stmt.c (g95_trans_forall_loop): Handle FORALL with negative + stride. + (g95_trans_forall): Allow arbitrary number of FORALL indexes and + actual variables used as FORALL indexes. + +2003-05-15 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_trans_static_array_pointer): Use + null_pointer_node. + (g95_trans_deferred_array): Initialize static array pointers. + * trans-expr.c (g95_conv_function_call): Use formal arglist to + correctly pass POINTER and absent CHARACTER arguments. + +2003-05-14 Lifang Zeng <zlf605@hotmail.com> + + * resolve.c (g95_resolve_forall): Resolve FORALL construct/statement. + (g95_resolve_forall_body): Resolve FORALL body. + (g95_resolve_where_code_in_forall): Resolve WHERE inside FORALL. + (g95_resolve_assign_in_forall): Resolve assignment inside FORALL. + (g95_find_forall_index): Check whether the FORALL index appears in + the expression or not. + (resolve_code): Modified. + +2003-05-14 Paul Brook <paul@nowt.org> + + * iresolve.c (g95_resolve_spread): Convert ncopies to index_type. + +2003-05-13 Paul Brook <paul@nowt.org> + + * trans-types.c (g95_max_array_element_size): Now a tree node. + (g95_init_types): Work out max size properly. + (g95_get_dtype_cst): Modify to match. + +2003-05-11 Paul Brook <paul@nowt.org> + + * trans-io.c (add_case): Create a label decl for case labels. + +2003-05-11 Paul Brook <paul@nowt.org> + + * arith.c (g95_integer_index_kind): New variable. + * f95-lang.c (g95_init): Move frontend initialization here ... + (g95_post_options): ... from here. + * g95.h (g95_index_integer_kind, g95_resolve_index): Declare. + * intrinsic.c (add_functions): Use index kinds. + * iresolve.c: Convert to index_kind where needed. + * resolve.c (g95_resolve_index): Make public, use index_kind. + (resolve_array_ref): Adjust to match. + * trans-array.c: Rename g95_array_index_kind to g95_index_integer_kind. + * trans-stmt.c: Ditto. + * trans-types.c: Ditto. + * trans-types.h (g95_array_index_kind): Remove declaration. + * trans-expr.c (g95_conv_expr_present): Use null_pointer_node. + +2003-05-07 Paul Brook <paul@nowt.org> + + * trans-const.c (g95_conv_mpz_to_tree): Typecast constant. + * trans-intrinsic.c (g95_conv_intrinsic_bound): Convert type + of bound indices. + +2003-05-07 Paul Brook <paul@nowt.org> + + * trans-array.c (trans_static_array_pointer, + g95_trans_array_constructor_value, g95_conv_array_initializer, + g95_conv_structure): CONSTRUCTOR nodes only have one operand. + (g95_add_loop_ss_code): Convert subscripts to the correct type. + * trans-stmt.c (g95_trans_character_select): Ditto. + * trans-types.c (g95_init_types): Ditto. + +2003-05-07 Steven Bosscher <steven@gcc.gnu.org> + + * f95-lang.c (expand_function_body): Use input_line, not lineno. + * trans-decl.c (g95_generate_function_code, + g95_generate_constructors): Likewise. + * trans.c (g95_trans_runtime_check, g95_add_block_to_block, + g95_get_backend_locus, g95_set_backend_locus, g95_trans_code): + Likewise. + +2003-05-07 Kejia Zhao <kejia_zh@yahoo.com.cn> + * trans-types.c (g95_get_derived_type): Fix bug for DERIVED type + with components point to the DERIVED type itself, and two DERIVED + type with components point to each other. + * trans-expr.c (g95_conv_componet_ref): Modified + +2003-05-07 Kejia Zhao <kejia_zh@yahoo.com.cn> + * trans-expr.c (g95_conv_expr): Translate EXPR_NULL into + null_pointer_node. + (g95_trans_pointer_assign): Implement Nullify. + +2003-05-01 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_walk_function_expr): Cope with NULL esym. + * trans-decl.c (g95_get_symbol_decl): Don't mangle dummy functions. + +2003-05-01 Paul Brook <paul@nowr.org> + + * trans-array.c, trans.c, trans-expr.c, trans-intrinsic.c, + trans-stmt.c: Replace empty_stmt_node with build_empty_stmt () and + IS_EMPTY_STMT. + +2003-05-01 Canqun Yang <canqun@yahoo.com.cn> + + * trans-stmt.c (g95_trans_integer_select): Add a parameter to build + CASE_LABEL_EXPR. + +2003-04-28 Paul Brook <paul@nowt.org> + + * iresolve.c (g95_resolve_transpose): COMPLEX types are twice as big + as their kind suggests. + (g95_resolve_reshape): Ditto. + +2003-04-28 Chun Huang <compiler@sohu.com> + + * trans-expr.c (g95_conv_substring_expr): New function. + (g95_conv_expr): Use it. + +2003-04-28 Paul Brook <paul@nowt.org> + + * iresolve.c (g95_resolve_transpose): Make it match the + implementation. + * trans-intrinsic.c (g95_is_intrinsic_libcall): Add TRANSPOSE. + +2003-04-18 Steven Bosscher <steven@gcc.gnu.org> + + * trans-types.c (g95_add_field_to_struct): New function to + add a field to a UNION_TYPE or RECORD_TYPE. + * trans-types.h (g95_add_field_to_struct): Prototype. + (g95_get_derived_type): Use g95_add_field_to_struct to add + components. + * trans-io.c (g95_add_field): Remove. + (ADD_FIELD): Use new g95_add_field_to_struct function. + (ADD_STRING): Likewise. + * trans-stmt.c (g95_trans_select): Likewise. + (g95_add_field): Remove duplicated function. + +2003-04-18 Canqun Yang <canqun@yahoo.com.cn> + + Port implementation for CHARACTER SELECT from Andy's tree. + * trans-stmt.c (g95_trans_character_select): Implement character + select. (g95_add_field): New function. + * trans-decl.c: Declare 'gfor_gndecl_select_string'. + (g95_build_builtin_function_decls): Add 'gfor_fndecl_select_string'. + * g95.h (struct g95_case): Add field 'int n'. + * trans.h: Declare 'gfor_fndecl_select_string'. + +2003-04-18 Steven Bosscher <steven@gcc.gnu.org> + + * bbt.c (duplicate_key, g95_insert_bbt_with_overlap): Remove. + (g95_insert_bbd): Die on duplicates. + * g95.h (g95_insert_bbt_with_overlap): Delete prototype. + +2003-04-14 Steven Bosscher <steven@gcc.gnu.org> + + * g95.texi: Require GMP 4.0 -- like we actually + do. Explain the testsuite and what-goes-where. + Don't use undefined texinfo symbol. Break very + long line. Remove finished item from the list + of open projects. + +2003-04-11 Canqun Yang <canqun@yahoo.com.cn> + + * trans-stmt.c (g95_evaluate_where_mask): Give mask temporaries + LOGICAL type. + +2003-04-10 Canqun Yang <canqun@yahoo.com.cn> + + * trans-stmt.c (g95_trans_forall): Implement WHERE inside FORALL. + (g95_trans_forall_body): New function. + +2003-04-10 Canqun Yang <canqun@yahoo.com.cn> + + * resolve.c (resove_where): New function. + (resolve_where_shape): New function. + (resolve_code): Add call to 'resolve_where' + * trans-stmt.c (g95_trans_where): Modified. + (g95_trans_where_2): New function. + (g95_trans_where_assign): New function. + (g95_evaluate_where_mask): New function. + (g95_add_to_stmt_list): New function. + (g95_get_temp_expr): New function. + * trans.h (where_stmt_list): New structure. + +2003-04-10 Paul Brook <paul@nowt.org> + + * g95spec.c (DEFAULT_SWITCH_TAKES_ARG): Remove. + (DEFAULT_WORD_SWITCH_TAKES_ARG): Ditto. + +2003-04-10 Steven Bosscher <steven@gcc.gnu.org> + + Update after mainline -> tree-ssa-branch merge. + * f95-lang.c (g95_mark_addressable): Update put_var_into_stack + call. + (g95_init): Update for new lang_hooks definition. + (g95_post_options): New langhook. + (LANG_HOOK_POST_OPTIONS): Clear, then define to g95_post_options. + * scanner.c (g95_new_file): Comment update. + +2003-04-09 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * g95.h, lang-options.h: Add -Wimplicit-interface. + * options.c (g95_init_options, g95_parse_arg): Set it. + * interface.c (check_intents): Warn about call with implicit + interface. + * resolve.c (resolve_unknown_f, resolve_unknown_s): Call + g95_procedure_use. + +2003-04-05 Paul Brook <paul@nowt.org> + + * iresolve.c (g95_resolve_spread): Don't resole based on type. + * trans-intrinsic.c (g95_is_intrinsic_libcall): Add G95_ISYM_SPREAD. + +2003-03-29 Paul Brook <paul@nowt.org> + + * iresolve.c (g95_resolve_pack): Don't bother resolving based on type. + (g95_resolve_unpack): Ditto. + * trans-intrinsic.c (g95_conv_intrinsic_merge): New Function. + (g95_conv_intrinsic_function): Use it. Remove PACK and UNPACK. + (g95_is_intrinsic_libcall): Add PACK and UNPACK. + +2003-03-25 Paul Brook <paul@nowt.org> + + * arith.c (g95_unary_user, g95_user): Remove dead functions. + * arith.h: Ditto. + * array.c (g95_free_array_ref): Ditto. + * g95.h: Ditto. + * symbol.c (g95_use_derived_tree): Ditto. + * intrinsic.c (add_functions): Use simplification for SCALE. + * primary.c (g95_match_rvalue): Test sym, not symtree. + +2003-03-25 Paul Brook <paul@nowt.org> + + * trans-decl.c (build_function_decl): Add parameter before it gets + turned into a constant. + * iresolve.c (g95_resolve_eoshift): Resolve to a useful name. + * trans-intrinsic.c (g95_is_intrinsic_libcall): Add G95_ISYM_EOSHIFT. + * trans-decl.c (g95_create_module_variable): Don't pushdecl constants. + +2003-03-22 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_conv_array_initializer): Allow scalar + expressions. + * trans-decl.c (g95_finish_var_decl): Result variables are not + module variables. + * trans-intrinsic.c (g95_conv_intrinsic_transfer): New function. + (g95_conv_intrinsic_function): Use it. + * trans-types.h (g95_type_spec): Remove dead declaration. + +2003-03-21 Paul Brook <paul@nowt.org> + + * trans-decl.c (g95_build_function_decl): Mark string parameters. + +2003-03-20 Paul Brook <paul@nowt.org> + + * trans-decl.c (g95_build_function_decl): Put character length + parameters at the end of the function declaration. + * trans-expr.c (g95_conv_function_call): Ditto. + * trans-types.c (g95_get_function_type): Ditto. + +2003-03-20 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * resolve.c (resolve_formal_arglist): Don't impose intent for + procedure arguments of pure functions. + (resolve_select): Remove redundant assignment. + +2003-03-19 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * arith.c (validate_logical), g95.h, options.c (g95_init_options): + Remove option l1. + * g95.h, intrinsic.c(g95_get_intrinsic_sub_symbol): Add const. + * iresolve.c(g95_resolve_cpu_time, g95_resolve_random_number): Add + const. + * lang-options.h: Remove -finline-repack-arrays. Add -fg77-calls. + Order list. + * symbol.c (g95_add_type): Fix typo in comment. + + +2003-03-16 Paul Brook <paul@nowt.org> + + * dump-parse-tree.c (g95_show_code_node): Print resolved sym name. + * expr.c (g95_build_call): Remove. + * f95-lang.c (puchdecl_top_level): New function. + * g95.h (g95_code): Store resolved symbol, not just the name. + * intrinsic.c (g95_intrinsic_namespace): New global namespace. + (g95_intirinsic_init_1, g95_intrinsic_done_1): Use it. + (g95_get_intrinsic_sub_symbol): New function. + * iresolve.c (g95_resolve_cpu_time): Use it. + (g95_resolve_random_number): Ditto. + * resolve.c: Set code->resolved_sym instead of code->sub_name. + * trans-decl.c (g95_get_extern_function_decl): Give external decls + the correct DECL_CONTEXT. Add global symbold to the global scope. + * trans-stmt.c (g95_trans_code): Remove hacks now the fronted is + fixed. + +2003-03-16 Paul Brook <paul@nowt.org> + + * g95.h (g95_option_t): Add g77_calls. Remove inline_repack_arrays. + * options.c (g95_parse_arg): Ditto. + * module.c (mio_symbol_attribute): Handle the always_explicit bit. + * resolve.c (resolve_formal_arglist): The always_explicit sould be set + for the procedure, not the parameter. + * trans-array.c (g95_trans_g77_array): New function. + (g95_trans_assumed_size): Use it. + (g95_trans_dummy_array_bias): Ditto. + (g95_conv_array_parameter): Handle g77 arrays. Move existing body ... + (g95_conv_expr_descriptor): ... to here. Update callers. + * trans-decl.c (g95_build_dummy_array_decl): Handle g77 arrays. + (g95_get_symbol_decl): Avoid processing g77 arrays multiple times. + * trans-expr.c (g95_conv_function_call): Handle g77 arrays. + * trans-intrinsic.c (g95_get_symbol_for_expr): Never use g77 arrays. + * trans-types.c (g95_is_nodesc_array): Handle g77 arrays. + (g95_sym_type): Ditto. + +2003-03-15 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_walk_elemental_function_args): Don't amputate the + first chain. + * trans-expr.c (g95_conv_function_call): Use the resolved symbol. + +2003-03-14 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_array_is_packed): Remove. + (g95_conv_array_base): Correctly handle all descriptorless cases. + (g95_conv_array_stride): Use descriptorless strides. + (g95_trans_dummy_array_bias): Don't always repack the array. + (g95_build_dummy_array_decl): Automatic dummy arrays are only partial + packed. + * trans-types.c (g95_get_nodesc_array_type): Differentiate between + dummy and non-dummy arrays... + (g95_sym_type, g95_get_derived_type): ... like these. + (g95_get_array_type_bounds): Allow discontiguous arrays. + +2003-03-12 Paul Brook <paul@nowt.org> + + * array.c (g95_resolve_array_spec): Fix comment. + * g95.h (symbol_attributes): New flag always_explicit. + * resolve.c (resolve_formal_arglist): Set it always_explicit. + * iresolve.c (g95_resolve_lbound, g95_resolve_ubound): Simplify. + * trans-array.c (g95_conv_descriptor_dimension): Remove dead assert. + (g95_trans_array_bounds): Allow assumed shape arrays. + (g95_trans_repack_array): Remove. + (g95_trans_dummy_array_bias): Rewite to use descriptorless arrays. + * trans-decl.c (g95_build_qualified_array): Only ignore absent + bounds for assumed size arrays. + (g95_build_dummy_array_decl): Use descriptorless arrays. + * trans-expr.c (g95_conv_expr_present): Allow descriptorless arrays. + (g95_trans_pointer_assign): Fix typo. + * trans-intrinsic.c (g95_conv_intrinsic_function_args): Remove dead + code. + (g95_conv_intrinsic_bound): Rewrite to handle descriptorless arrays. + * trans-types.c (g95_get_nodesc_array_type): Allow non-packed arrays. + Also modify callers. + * trans-types.h (g95_get_nodesc_array_type): Modify prototype. + +2003-03-08 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_walk_elemental_functions): Don't reverse the SS. + (g95_conv_array_ubound): Provide dummy value for assumed size arrays. + * resolve.c (compare_spec_to_ref): Allow full array sections. + +2003-03-08 Paul Brook <paul@nowt.org> + + * expr.c (g95_simplify_expr): Also simplify array index and + substring expressions. + * resolve.c (compare_spec_to_ref): Check for assumed size bounds. + * trans-array.c (g95_trans_array_bounds): New function. + (g95_trans_auto_array_allocation): Use it. + (g95_trans_assumed_size): Rewrite. + * trans-decl.c (gfor_fndecl_in_pack, gfor_fndecl_in_unpack): Declare. + (gfor_fndecl_repack): Remove. + (g95_build_qualified_array): Handle absent upper bounds. + (g95_build_dummy_array_decl): Assumed shape arrays are descriptorless. + (g95_get_symbol_decl): Update. + (g95_build_intrinsic_function_decls): Initialize new decls. + * trans.h (gfor_fndecl_in_pack, gfor_fndecl_in_unpack): Declare. + (gfor_fndecl_repack): Remove. + * trans-io.c (g95_build_io_library_fndecls): Correct prototypes. + * trans-types.c: (g95_build_array_type): Merge duplicated code.. + (g95_get_nodesc_array_type): Handle absent bounds. + * trans-types.h (g95_get_nodesc_array_type): Declare. + +2003-03-04 Paul Brook <paul@nowt.org> + + * f95-lang.c (DEF_FUNCTION_TYPE_VAR_3): Define before including + builtin-types.def. + +2003-03-02 Paul Brook <paul@nowt.org> + + * options.c (g95_init_options): Drfault to 1. + (g95_pasrse_arg): Add -frepack-arrays, use strcmp. + * trans-array.c (g95_conv_array_data, g95_conv_array_base, + g95_conv_array_stride,g95_conv_array_lbound, g95_conv_array_ubound): + Handle non-constant size automatic arrays. + (g95_conv_section_upper_bound, g95_conv_section_startstride): Use + generic bound functions. + (g95_trans_auto_array_allocation): Don't create a descriptor. + (g95_trans_assumed_size): New function (broken). + (g95_trans_dummy_array_bias): Remove unused var. + * trans-array.h (g95_trans_assumed_size): Declare. + * trans-decl.c (create_index_var): New fuction. + (g95_build_qualified_array): New function. + (g95_get_symbol_decl): Use it. + (g95_trans_deferred_vars): Handle assumed shape seperately. + * trans-types.c (get_element_type): Handle heap allocated arrays. + (g95_is_nodesc_array): Include non-const size arrays. + (g95_get_nodesc_array_type): Ditto. + +2003-02-23 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_array_init_size): Should use stride, not size of + last dimension. + +2003-02-18 Paul Brook <paul@nowt.org> + + * trans-expr.c (g95_trans_arrayfunc_assign): Nove elemental check + after intrinsic function check. + +2003-02-18 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * io.c (match_io): Fix missing return value and remove useless + assignment. + * match.c (g95_match): Remove useless assignment. + * module.c (parse_string): Remove useless post increment. + * simplify.c (g95_simplify_verify): Remove useless assignment. + +2003-02-15 Paul Brook <paul@nowt.org> + + * expr.c (restricted_intrinsic): Handle bad values gracefully. + * g95.h (symbol_attribute): Add referenced member. + (g95_symbol): Add dummy_order member. + (g95_set_sym_referenced): Declare. + * match.c (g95_match_assignment, g95_match_call): Use it + * primary.c (match_actual_arg, g95_match_rvalue, + g95_match_variable): Ditto. + * symbol.c (next_dummy_order): New variable. + (g95_set_sym_referenced): New function. + (check_done): New function. + (g95_add_*): Use it. + * trans-decl.c: Make formatting conform to GCC standards. + (g95_defer_symbol_init): Add dummy variables in the right order. + (g95_get_symbol_decl): Only accept referenced variables. + (g95_create_module_variable): Module variables are always required. + (generatr_local_decls): New function. + (generate_local_vars): New function. + (g95_generate_function_code): Use it. + +2003-02-13 Paul Brook <paul@nowt.org> + + * trans-decl.c (g95_conv_struct_cons): Remove. + (g95_get_symbol_decl): Use g95_conv_expr for structure initializers. + * trans-expr.c (g95_conv_structure): New function. + (g95_conv_expr): Use it. + +2003-02-09 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_array_init_size): Don't evaluate the linit + expressions multiple times. + (g95_trans_auto_arry_allocation): Use pointer not tmp. + +2003-02-08 Paul Brook <paul@nowt.org> + + * module.c (mio_symtree_ref): Declare as static. + (mio_expr): Remove dead code. + (read_module): Set the symtree link for fixups. + * trans-intrinsic.c (g95_conv_intrinsic_round): Rename... + (build_round_expr): ... to this. + (g95_conv_intrinsic_aint): New function. + (g95_conv_intrinsic_function): Use it. + +2003-02-08 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_trans_array_constructor_value): Use the acutal + offset after modificaton, not the increment expression. + * dependency.c: Kill excess whitespace. + +2003-02-07 Sanjiv Gupta <sanjivg@noida.hcltech.com> + + * dependency.h: Remove some function declarations. + * dependency.c (get_no_of_elements): Change this function not to + return int. + * other: Add comments for all modified functions. + +2003-02-06 Paul Brook <paul@nowt.org> + + * g95spec.c (lang_specific_functions): Fix initializer warning. + * dump-parse-tree.c (g95_show_expr): Use typespec instead of symtree + for structure type names. + * trans-decl.c (g95_cons_structure_cons): New function. + (g95_get_symbol_decl): Use it. + * trans-expr.c (g95_conv_component_ref): Remove duplicate pointer + referencing code. + +2003-02-06 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * resolve.c (compare_cases): Add const to casts. + +2003-01-30 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * g95.h (g95_check_f): Change a1 to f1m. + * intrinsic.c (add_sym_1m, check_specific, + g95_intrinsic_func_interface): Use it. + + * module.c (init_pi_tree): Remove useless cast. + (fp2): Fix argument type. + + * parse.c (parse_select_block): Add comment. + +2003-02-05 Toon Moene <toon@moene.indiv.nluug.nl> + + * lang-options.h: Fix warning involving C90 concatenated + strings. + +2003-02-06 Steven Bosscher <s.bosscher@student.tudelft.nl> + Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * io.c (format_asterisk): Complete initializer to kill warning. + * arith.c (DEF_G95_INTEGER_KIND, DEF_G95_LOGICAL_KIND, + DEF_G95_REAL_KIND, MPZ_NULL, MPF_NULL): New #defines. + (g95_integer_kinds, g95_logical_kinds, g95_real_kinds): Use the + new defines to complete initializers. Kills all warnings. + + * Make-lang.in: Comment cleanup. + +2003-02-05 Paul Brook <paul@nowt.org> + + * array.c (g95_free_constructor): Handle NULL expressions. + * resolve.c (resolve_structure_cons): Ditto. + * decl.c (g95_match_null): New Function. + (variable_decl): Use it. + * module.c (mio_expr): Don't bother saving symtree for EXPR_STRUCTURE. + * primary.c (g95_match_runtime): Don't use symtree for EXPR_STRUCTURE. + * trans-types.c (g95_set_decl_attributes): Remove empty function. + +2003-02-05 Paul Brook <paul@nowt.org> + + * trans.h (build1_v): New macro. + (build_v): Remove pointless and incorrect prototype. + * various: Use build1_v for GOTO_EXPR and LABEL_EXPRs. + * f95-lang.c (g95_init_builtin_decls): DEF_BUILTIN takes 10 args. + +2003-02-01 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * Make-lang.in (F95_OBJS): Remove one more dead file. + +2003-02-01 Paul Brook <paul@nowt.org> + + * lang-specs.h: Don't pass -ffixed-form to the linker. + * trans-decl.c (g95_generate_function_code): Clear saved decl chain. + +2003-02-01 Paul Brook <paul@nowt.org> + + * Make-lang.in (F95_OBJS): Remove dead files. + * trans-array.c (g95_array_init_size): Do the right thing when + ubound=NULL. + * trans-decl.c (g95_generate_function_code): Initialize deffered + symbol list before translating contained subroutines. + * trans-expr.c (g95_conv_expr, g95_conv_expr_reference): Substitute + scalar invariant values here... + (g95_conv_variable, g95_conv_function_call): ... instead of here ... + * trans-intrinsic.c (g95_conv_intrinsic_function_args): .. and here. + +2003-01-29 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_add_loop_code): Put pre code in the right block. + (g95_walk_elemental_function_args): Reverse chains before adding. + (g95_reverse_ss): Move about a bit. + * trans-expr.c (g95_conv_function_call): Handle scalar intrinsic + function arguments. + +2003-01-28 Paul Brook <paul@nowt.org> + + * intrinsic.c (resolve_intrinsic): Use correct union member. + * trans-array.c (g95_trans_dummy_array_bias): Don't touch absent + parameters. + * trans-decl.c (g95_get_symbol_decl): Don't translate initializers for + use associated variables. + * trans-intrinsic.c (g95_conv_intrinsic_present): Move body ... + * trans-expr.c (g95_conv_expr_present): ... to here. + * trans.h: Declare it. + * trans-types.c (g95_sym_type): Assume subroutine if not specified. + +2003-01-28 Arnaud Desitter <arnaud.desitter@geography.oxford.ac.uk> + + * array.c (expand_iterator): Suppress useless assignment. + * decl.c (match_char_spec): Ditto. + * io.c (match_io_iterator): Ditto. + * primary.c (match_real_constant): Ditto. + * interface.c (fold_unary, g95_free_interface, g95_extend_expr): + Ditto. Also, use g95_intrinsic_op not int for intrinsic operators. + * matchexp.c (match_add_operand, match_level_5): Likewise. + * module.c (parse_atom, find_enum): Likewise. + * resolve.c: move #include <string.h> + (resolve_select): Fix serious typo. + +2003-01-28 Steven Bosscher <s.bosscher@student.tudelft.n> + + * Make-lang.in: Don't build with broken tree-ssa-pre. + +2003-01-28 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * resolve.c (resolve_index): Add a TODO. + * symbol.c: Remove useless "#include <ctype.h>". + +2003-01-27 Paul Brook <paul@nowt.org> + + * check.c (check_rest): Allow different type kinds as an extension. + * g95.h (g95_resolve_f): Add f1m. + * intrinsic.c (add_sym_1m, resolve_intrinsic): Use it. + * intrinsic.h: Chenge prototypes for MIN and MAX. + * iresolve.c (g95_resolve_minmax): New function. + (g95_resolve_min, g95_resolve_max): Use it. + * trans-intrinsic.c (g95_trans_intrinsic_minmax): Only evaluate + arguments once. + (g95_conv_intrinsic_present): Fix logic. + +2003-01-27 Steven Bossche <s.bosscher@student.tudelft.nl> + + * g95.h (g95_case): Don't be a tree, be a double linked list. + * match.c (match_case_selector): Remove redundant semantics check. + Clean up a few goto's to make it a tiny little bit faster. + * resolve.c (case_tree): Die. + (compare_cases): Accept and compare unbounded cases too. + (check_case_overlap): Don't build a tree. Instead, merge-sort the + whole list of g95_cases passed from resolve_select. + (sane_logical_select): Die. + (check_case_expr): Return FAILURE if a CASE label is of the wrong + type kind. + (resolve_select): Fixup case expression for computed GOTOs, put it + in expr, not expr2, for easier handing in the parse tree dumper and + the code generator. Rewrite the rest of the function: Kill + unreachable case labels and unreachable case blocks. + * dump-parse-tree.c (g95_show_code_node): Always dump expr for + an EXEC_SELECT, not case2 anymore. + * trans-const.c (g95_conv_constant_to_tree): New function. + (g95_conv_constant): Use it. + * trans-const.h: Declare prototype for the new function. + * trans-stmt.c (g95_trans_integer_select, g95_trans_logical_select, + g95_trans_character_select): New static functions. + (g95_trans_select): Rewrite. + +2003-01-26 Paul Brook <paul@nowt.org> + + * intrinsic.c (add_fnctions): Properly add dreal. + * trans-intrinsic.c (g95_conv_intrinsic_present): New function. + (g95_conv_intrinsic_function): Use it. + * trans-io.c (build_dt): Abort on internal files (unimplemented). + +2003-01-26 Paul Brook <paul@nowt.org> + + Widespread changes to the handling of symbols in expressions. These + are now linked via g95_symtree nodes. + * parse.c (g95_fixup_sibling symbols): New function. + (parse_contained): Use it. + * g95.h (symbol_attribute): Add contained. Indicates a symbol is a + contained procedure that has bee correctly fixed up. + (g95_code, g95_expr): Point to a g95_symtree, not a g95_symbol. + +2003-01-24 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_walk_expr): Function result attributes are in + sym->result. + * trans-expr.c (g95_conv_function_call, + g95_trans_arrayfunc_assign): Ditto. + * trans-decl.c (g95_get_symbol_for_expr): Set sym->result. + +2003-01-23 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * expr.c (check_restricted): Fix error message. + * symbol.c (free_st_labels): Plug memleak. + +2003-01-22 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * arith.c (reduce_unary, reduce_binary_ac, reduce_binary_ca, + reduce_binary_aa, reduce_binary, eval_intrinsic, + eval_intrinsic_f2): Use typesafe prototypes for eval functions. + * g95.h (g95_check_f, g95_simplify_f, g95_resolve_f): New unions + for typesafe intrinsics helper functions. + (g95_intrinsic_sym): Use them. + * intrinsic.c (do_check, add_sym, add_sym_0, add_sym_1, + add_sym_1s, add_sym_1m, add_sym_2, add_sym_3, add_sym_4, + add_sym_5, add_conv, resolve_intrinsic, do_simplify, + check_specific, g95_intrinsic_func_interface, + g95_intrinsic_sub_interface): Adjust all calls to intrinsics + helper functions. + * trans-decl.c (g95_get_extern_function_decl): Likewise. + * Make-lang.in: Don't disable warnings for strict prototypes + any longer, everything is typesafe now. + +2003-01-22 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * bbt.c (duplicate_node): Make static. + * module.c (module_name): Make static. + * scanner.c (include_dirs): Make static. + +2003-01-20 Steven Bosscher <s.bosscher@student.tudelft.nl> + + Hard coded _gfor_'s should not show up anymore. + * g95.h (PREFIX): New macro. + * iresolve.c (g95_resolve_cpu_time): Use PREFIX, not + hard-coded "_gfor". + (g95_resolve_random_number): Likewise. + * trans-decl.c (g95_build_intrinsic_function_decls): Likewise. + * trans-io.c: Remove 'prefix' macro. Replace all uses with + the new PREFIX macro from g95.h. + +2003-01-20 Steven Bosscher <s.bosscher@student.tudelft.nl> + + The troubles of forking... Andy implemented this just now too. + Let's stick to that and keep the trees close. + * g95.h (g95_st_label): 'format' member is now a g95_expr. + * io.c: Revert previous changes. + (g95_match_format): Match the format string as a character + literal expression. + * match.h (g95_statement_label): Declare external. + * parse.c: Revert previous changes. + * symbol.c (g95_free_st_label): Free a g95_expr instead + if a 'char *'. + * trans-io.c: Revert previous changes. + (build_dt): Use set_string to set the format string. + +2003-01-20 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * io.c (format_string): Make non-static. + (g95_match_format): Remember the format string. + (terminate_io): Add I/O termination for empty I/O lists. + * match.h: Declare external format_string. + * parse.c (check_statement_label): Attack the format string + to a format label for FORMAT statements. + * trans-io.c (g95_add_field): Define prefix macro. Replace + all uses of PREFIX define with a use of this macro. + (build_dt): Implement formatted I/O for format labels. + +2003-01-20 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * lang-options.h: Kill "-std=F". + * options.c: Remove unimplemented "-std=F". Modify + web address. + * misc.c (g95_terminal_width): New function. + * error.c (g95_error_init_1): Use g95_terminal_width. + * g95.h: Add prototype for g95_terminal_width, remove + fmode flag. + +2003-01-19 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * Make-lang.in: Fix typo. + +2003-01-18 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * g95.h (struct g95_case): Remove unused cruft, new member + 'where' to keep track of the locus of the default case. + * match.c (g95_match_case): Add locus to the current case. + (match_case_selector): Likewise. + * parse.c (parse_select_block): Move semantics check for + multiple DEFAULT cases out of here to... + * resolve.c (check_case_overlap): ...here. Return sooner + when possible. + (check_case_expr): Take two g95_cases now, use to sure the + expression kinds are the same. + (resolve_select): Cleanup. + +2003-01-18 Paul Brook <paul@nowt.org> + + * trans-io.c: Fix typos in ported IO work (set_fla[tg]). + * trans-decl.c (g95_set_symbol_decl): Handle non-array result + variables. + (g95_get_extern_function_decl): Put decls in the correct context. + +2003-01-18 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * trans-io.c: Port changes from Andy to set ERR flag. + +2003-01-17 Paul Brook <paul@nowt.org> + + * trans-array.c: Add various comments. + (g95_ss_terminator): Declare as const. + (g95_walk_expr): Remove first parameter and update all callers. + (g95_walk_op_expr): Initialize scalar SS properly. + * trans-array.h (g95_walk_expr): Update prototype. + * trans-expr.c: Update for new g95_walk_expr. + * trans-intrinsic.c: Ditto. + * trans-io.c: Ditto. + * trans.h: Various comments for SS chains. + +2003-01-17 Paul Brook <paul@nowt.org> + + * intrinsic.h (g95_generic_isym_id): Add G95_ISYM_S?_KIND, SPACING + and RRSPACING. + * intrinsic.c (add_functions): Use them. + * trans-intrinsic.c (g95_conv_intrinsic_function): Ditto. + * trans-expr.c (g95_conv_expr_lhs): Abort on impossible error. + +2003-01-17 Steven Bosscher <s.bosscher@student.tudelft.nl> + + Fallout of a small merge conflict: + * intrinsic.c: Un-revert lost patch (G95_ISYM_SCALE). + +2003-01-17 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * initrinsic.c: New add_sym_* functions for strong typing. + (add_conv): Make prototype strict. + * dump-parse-tree.c, dependency.c: Include config.h + * resolve.c, trans-io.c: Fix typos. + +2003-01-17 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * dump-parse-tree.c (g95_show_code_node): Show the + condition for a computed GOTO that was transformed + to a SELECT CASE construct. + * resolve.c (check_case_overlap): Revert previous switch + to treaps, it was too slow and didn't catch all trouble. + (resolve_symbol): Be more flexible about module procedures. + * symbol.c (check_conflict): Point to relevant section in + the standard for dubious conflict. Allow procedure + dummy arguments to be optional again. + * trans-io (add_field): Rename to g95_add_field. Change + all callers. + * trans-stmt (trans_select): Handle unbounded cases for + integer SELECT CASE constructs. Fix/add more comment. + +2003-01-17 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * g95.h: Uses GCC's function attribute macros. + * error.c, module.c, parse.c, g95.h: More function attributes. + +2003-01-16 Steven Bosscher <s.bosscher@student.tudelft.nl> + Forgot a file... + * trans-decl.c (get_label_decl): Use TREE_LINENO instead + of DECL_SOURCE_LINE, and TREE_FILENAME instead of + DECL_SOURCE_FILE. + +2003-01-16 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * f95-lang.c (pushdecl): Use TREE_LINENO instead of + DECL_SOURCE_LINE. + * trans.c (g95_trans_code): Use annotate_all_with_file_line + instead of nowdead wrap_all_with_wfl. + +2003-01-14 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * parse.c (g95_parse_file): In verbose mode, dump the parse tree + before generating code, so we can still see it even if the code + generation phase dies. + +2003-01-14 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * decl.c (build_sym): Split out initialization expression parts... + (add_init_expr_to_sym): ...to here. + (variable_decl): Add the symbol following an attribute list to the + symbol tree before parsing the optional initialization expression + if the symbol is not of a derived type. + * primary.c (g95_match_rvalue): Don't assume a symbol always has + a value if it is a PARAMETER. + +2003-01-14 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * misc.c: Don't #include <mcheck.h> + * module.c: Ditto. Kill uses of mtrace, muntrace. If there + ever was a glibc bug, then either this was never reported to + glibc people, or it has been fixed for so long that there's + no information you can find about it, anywhere. + +2003-01-14 Steven Bosscher <s.bosscher@student.tudelft.nl> + + Fix warnings: + * module.c (attr_bits, bt_types, array_spec_types): + Switch 'const' and 'static'. + * iresolve.c (g95_resolve_reshape): Make __resolve0 non-'const'. + + GNU'ify source code: + * trans-io.c: Numerous fixes, one fixed warning and a few + TODO markers so that we don't forget about them. + +2003-01-13 Paul Brook <paul@nowt.org> + + * intrinsic.c (add_functions): Add G95_ISYM_SCALE. + * intrinsic.h (g95_generic_isym_id): Remove bogus G95_ISYM_ANINIT. + Add G95_ISYM_SCALE. + * trans-intrinsic.c (g95_conv_intrinsic_function): Ditto + * match.c (g95_match_stop): Fix dumb == -> != error. + +2003-01-13 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * dump-parse-tree.c (show_indent): Add line breaks. This + whole dumping process needs cleanups. + * f95-lang.c (g95_mark_addressable): Fix prototype to match + the langhook. Fix 'return's accordingly. + * g95-support.h: Adjust prototype. + * g95.h: Add 'no_backend' member to 'g95_option_t' struct. + * lang-options.h: Add '-fsyntax-only'. + * options.c (g95_init_options): Init 'no_backend'. + (g95_parse_arg): Deal with '-fsyntax-only'. + * parse.c (g95_parse_file): Do not generate code if 'no_backend' + is set. + +2003-01-13 Steven Bosscher <s.bosscher@student.tudelft.nl> + Patch from Arnaud + * resolve.c (resolve_symbol): Assumed shape arrays must be dummy + arguments. Also make sure that if a symbol is marked INTRINSIC, + an intrinsic with the symbol's name actually exists. + (check_conflict): Make EXTERNAL and DIMENSION attributes conflict. + Do not allow PROCEDURES to have the SAVE, POINTER, TARGET, + ALLOCATABLE, RESULT, IN_NAMESPACE, OPTIONAL or FUNCTION attribute. + +2003-01-13 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * resolve.c (resolve_contained_functions): Fix condition, don't + throw internal_error if a child namespace has no name. Apparently + this can be the case? + +2003-01-11 Paul Brook <paul@nowt.org> + + Port changes from Andy's tree: + * g95.h (g95_code): Add stop_code. + * match.c (g95_match_stop): Detter syntax checking. + * resolve.c (resolve_generic_f0): Return match type. + (resolve_generic_f): Remove dead/duplicated code. + (resolve_specific_f): Ditto. + * dump-parse-tree.c (g95_show_code_node): Handle new STOP format. + * trans-decl.c (gfor_fndel_stop_*): New fndecl nodes. + * trans-stmt.c (g95_trans_stop): Handle new STOP format. + +2003-01-11 Paul Brook <paul@nowt.org> + + * trans-array.c: Various documentation/comment changes. + * trans-stmt.c: Ditto. + + +2003-01-10 Paul Brook <paul@nowt.org> + + * options.c/h: Add -fdump-parse-tree as alias of -v. + +2003-01-10 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * dump-parse-tree.c (g95_show_namespace): Fixed another + typo. Sorry, it's Friday... + +2003-01-10 Steven Bosscher <s.bosscher@student.tudelft.nl> + + Spotted by Tobi: + * trans-array.c, trans-array.h, trans.c, trans-const.c, + trans-const.h, trans-decl.c, trans-expr.c, trans.h + trans-intrinsic.c, trans-io.c, trans-stmt.c, trans-stmt.h + trans-types.c: Fix bogus copyright years, add 2003. + * trans-types.h: Give copyright header. + +2003-01-10 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * dump-parse-tree.c (g95_show_namespace): Fixed typo. + * expr.c, options.c, scanner.c: Add some more 'const' markers. + * intrinsic.c: Some constant strings moved to read-only memory. + * io.c (format_asterisk): Move to... + * g95.h: ...here. + +2003-01-10 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * dump-parse-tree.c (g95_show_namespace): Dump implicit + types for ranges instead of per-letter. Indent the + 'CONTAINS' just like everything else. + * resolve.c (resolve_contained_functions): Clarify comment. + Explain non-obvious conditional expression. Improve + diagnostics if tyoe cannot be resolved. + Port semi-fix from Andy's tree: + (was_declared): Move up before first use. + (generic_sym, specific_sym): New functions. Code moved + out if procedure_kind. + (procedure_kind): Simplify using new functions. + (resolve_generic_f): Make sure the functions we find in + a parent namespace is generic. + (resolve_specific_f): Ditto for specific functions. + +2003-01-10 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * trans-stmt.c, trans.c: Fix some code style issues. Add + some more comment (but still not enough!). + +2003-01-10 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * symbol.c (flavors, procedures, intents, acces_types, + access_types, ifsrc_types): Make const. + * misc.c (g95_string2code): Make 'm' param 'const'. + * module.c (find_enum, write_atom, mio_name): Make + 'm' param 'const'. + (attr_bits, bt_types, array_spec_types, array_ref_types, + ref_types, expr_types): Make const. + * g95.h: Adjust external decls. + +2003-01-09 Paul Brook <paul@nowt.org> + + * Testsuite: Add a load of new cases. + +2003-01-08 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * Make-file.in: Add dependency on back end header files; + a parallel build should work now. + * f95-lang-c (lang_identifier): Remove bogus comment. + (g95_be_parse_file): Fix prototype. + (g95_init): Make static. + (g95_finish): Make static. + * error.c (g95_syntax_error): Kill. Make define in... + * g95.h (g95_syntax_error): Define. + (g95.options): Make 'source' member 'const'. + * interface.c (g95_match_interface): Explain + hard-to-read condition. + (g95_match_end_interface): Ditto. + * trans_const.c (g95_build_string_const): Make 's' parameter + 'const'. + * trans_const.h: Adjust protoype accordingly. + * trans-decl.c: Include tree-dump.h + (g95_generate_function_code): Build fixes for recent changes + in the tree-ssa branch. + +2003-01-08 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * format.c: Kill, move code from here... + * io.c: ...to here. + * Make-lang.in: Adjust. + * MANIFEST: Ditto. + * match.h: Ditto. + * BUGS: Mention where to submit bugs. Move old content... + * TODO: ...to here. New file. + +2003-01-08 Steven Bosscher <s.bosscher@student.tudelft.nl> + Fix most warnings, and suppress the ones we can't fix for now. + * Make-lang.in: Suppress warnings about bad proto's in g95.h, + these warnings just clutter the screen and there's not much + we can do about them for now anyway. + * check.c, iresolve.c: Mark unused function parameters. + * dump-parse-tree.c (g95_show_array_spec): Punt on AS_UNKNOWN, + they should be resolved before they get here. + * error.c: Remove unused FILE *status_out. + * f95-lang.c (g95_init): Remove bogus cast. + * Many files: Make things 'const' where required. + * g95.h: Fix prototypes for all modified functions above. + (g95_options): Remove 'object' member. + +2003-01-07 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * Make-file.in: Cleanup bogus targets. Add more comment. + * lang-options.h: New option '-w'. + * g95.h: add no_options field to struct g95_options. + * options.c (g95_init_options): Default no_warnings to off. + (g95_parse_arg): Recognise the '-w' switch and its alias, + '-fno-warnings'. + * error.c (g95_warning, g95_warning_now): Don't emit warning if + no_warning option is set. + * iresolve.c (g95_resolve_shape): Fix warning. + +2003-01-07 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * primary.c (g95_next_string_char): Rename next_string_char, and + make static. Adjust callers accordingly. + * resolve.c (resolve_generic_f0): Return try, not match. Adjust + callers accordingly. + * g95.h: Split out all g95_match* functions to... + * match.h: ...here. New file. + * array.c, decl.c, expr.c, format.c, interface.c, io.c, match.c, + matchexp.c, module.c, parse.c, primary.c: Inlcude match.h + +2003-01-07 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * symbol.c (g95_clear_new_implicit, g95_add_new_implicit_range, + g95_merge_new_implicit): New functions. + (g95_match_implicit_none, g95_match_implicit): Move from here... + * match.c (g95_match_implicit_none, g95_match_implicit): ... to here. + Modify to use the new functions in symbol.c. + * g95.h: Add and move prototypes. + +2003-01-06 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * bbt.c (insert): Use a typedef'ed compare_fn prototype for the + node compare function. + (g95_insert_bbt): Likewise. + (g95_insert_bbt_with_overlap): Likewise. + (g95_delete_bbt): Likewise. + (delete_treap): Likewise. Also fix a potential bug when calling it. + * module.c (compare_pointers): Change proto to compare_fn. + (compare_integers): Likewise. + (compare_true_names): Likewise. + (find_true_name): Adjust call to compare_true_names to match proto. + (require_atom, write_atom, mio_name): Fix 'const' warnings. + (init_pi_tree): Make compare a compare_fn instead of (int *). + * resolve.c (compare_cases): Change proto to compare_fn. + * symbol.c (g95_compare_symtree): Change proto to compare_fn, make + it static, and rename to compare_symtree. + (delete_symtree, g95_undo_symbols, g95_new_symtree): Use renamed + function. + * g95.h: Kill g95_compare_symtree prototype. Adjust prototypes + of g95_insert_bbt, g95_insert_bbt_with_overlap, and g95_delete_bbt. + +2003-01-06 Steven Bosscher <s.bosscher@student.tudelft.nl> + * Make-lang.in: Fix spaces/tabs issues from previous patch. + * patch.options: Blow away Paul's checkin mistake :-) + * io.c (terminate_io): Fix memory leak (Arnaud). + +2003-01-06 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * Make-lang.in: Teach about building DVI, info manual. + * g95.texi: New file. + +2003-01-02 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_reverse_ss): Make static and don't use. + (g95_conv_ss_descriptor): Don't use g95_loopinfo + (g95_conv_array_parameters): Modify for pointer assignments. + (g95_walk_subexpr): New function. + (g95_walk_expr*): Use it. + * trans-array.h (g95_reverse_ss): Remove prototype. + * trans-expr.c (g95_trans_pointer_assign): Implement. + (Many): Set se.want_pointer before calling g95_conv_array_parameter. + * trans-intrinsic.c: Sync with scalarizer changes. + * trans-io.c: Ditto. + +2002-12-29 Paul Brook <paul@nowt.org> + + * trans-array.c: Document calling convention for arrays. + +2002-12-19 Paul Brook <paul@nowt.org> + + * trans-intrinsic.c (g95_conv_intrsinsic_function): Remove incorrect + assertion. Remove intrinsic subroutine G95_ISYM_* cases. Always pass + optional parameters for some intrinsics. + (g95_is_intrinsic_libcall): Add G95_ISYM_RESHAPE. + * trans-expr.c (g95_conv_function_call): Pass NULL for absent + optional parameters. + * trans.h (g95_se): Add ignore_optional flag. + +2002-12-15 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_conv_array_parameter): Fix partial rank sections. + * trans-decl.c (g95_generate_function_code): Use TDI_original. + +2002-12-14 Paul Brook <paul@nowt.org> + + * trans-stmt.c (g95_trans_call): Use resolved symbol name. + +2002-12-12 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_trans_array_constructor_subarray): Fully + initialize the scalarizer. + (various): Update to new format of g95_expr->value.constructor. + +2002-12-08 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_put_offset_into_var): New function. + (g95_trans_array_constructor_subarray): New function. + (g95_trans_array_constructor_value): Use it. + (g95_array_cons_size): Don't abort() on array components. + +2002-12-08 Paul Brook <paul@nowt.org> + + * Make-lang.in (F95_ADDITIONAL_OBJS): Remove tree-dchain.o. + * support.c: Update #includes. + (statement_code_p, c_size_in_bytes, s_size_type_node): Remove. + * trans-array.c: Update #includes. + * trans.c: Ditto. + * trans-const.c: Ditto. + * trans-io.c: Ditto. + * trans-types.c: Ditto. + (g95_init_types): Set size_type_node. + * trans-decl.c: Update #includes. + (gfor_fndecl_adjust{l,r}): Declare and initialize. + * trans-stmt.c: Update #includes. + (g95_trans_do_while): Generate LABEL_EXPR, not GOTO_EXPR. + (g95_trans_select): Fix check for unbounded ranges. + * trans-expr.c: Update #includes. + (g95_conv_string_tmp): New function. + (g95_conv_concat_op): Use it. + * trans.h (g95_conv_string_tmp, gfor_fndecl_adjust{l,r}): Declare. + * Trans-intrisic.c: Update #includes. + (g95_conv_intrinsic_strcmp): New function. + (g95_conv_intrinsic_adjust): Ditto. + (g95_conv_intrinsic_function: Use them. + +2002-11-30 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_walk_function_expr): Handle non-array return by + reference. + * trans-dec.c (g95_build_function_decl): Handle character return + parammeters. + (g95_get_fake_result_decl): Ditto. + (g95_trans_deferred_vars): Ditto. + * trans-expr.c (g95_conv_function_call): Ditto. + (g95_trans_arrayfunc_assign) Limit to array valued functions. + * trans-intrinsic.c (g95_conv_intrinsic_char): New function. + (g95_conv_intrinsic_function): Use it. + * trans-types.c (g95_sym_type): Handle functions returning strings. + (g95_return_by_reference): Ditto. + (g95_get_function_type): Ditto. + +2002-11-18 Paul Brook <paul@nowt.org> + + * trans-stmt.c (g95_trans_if): Fix IF statements when the condition + requires a temporary. + (g95_trans_select): Handle computed gotos. + * trans-types.c (g95_build_array_type): Warn about non-functional + assumed shape arrays. + * trans-expr.c (g95_trans_scalar_assign): Correctly handle post + blocks. + * trans-intrinsic.c (g95_conv_intrinsic_round): New function. + (g95_conv_intrinsic_int): New function. + (g95_conv_intrinsic_mod): New function. + (g95_conv_intrinsic_ichar): New function. + (g95_conv_intrinsic_function): Use them. + (g95_conv_intrinsic_dim): Use g95_evaluate_now. + +2002-11-17 Toon Moene <toon@moene.indiv.nluug.nl> + + * trans-types.c (g95_build_array_type): Assumed + sized arrays can have rank > 1. + * trans.c (g95_trans_code): Remove erroneous + warning about CONTINUE. + * trans-expr.c (g95_conv_variable): Remove + erroneous assert. + +2002-11-15 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_conv_array_parameter): Check for NULL stride. + +2002-10-31 Paul Brook <paul@nowt.org> + + * f95-tree.c: Remove tree copying stuff that's now in gimple.c + * trans-expr.c (g95_conv_component_ref): Handle character string + components. + (g95_conv_string_parameter): Ditto. + * trans-types.c (g95_get_derived_type): Add length decl to caracter + string components. + +2002-10-10 Paul Brook <paul@nowt.org> + + * trans-decl.c (gfor_fndecl_size?): Declare and initialize. + * trans-expr.c (g95_conv_function_call): Remove unreliable return value + check. + * trans-intrinsic.c (g95_conv_intrinsic_size): New function. + (g95_conv_intrinsic_function): Handle size and shape intrinsics. + (g95_is_intrinsic_libcall): Add G95_ISYM_SHAPE. + * trans-types.c (pvoid_type_node): Declare and initialize. + * trans-array.c: Fix typo COMPONENT_REF->REF_COMPONENT + (g95_array_allocate): Fix when base==data. + (g95_conv_array_parameter): Correctly handle reduced rank sections. + * trans-io.c (g95_trans_write): Correctly handle string modifiers. + +2002-10-09 Paul Brook <paul@nowt.org> + + * (g95_conv_expr_reference): Handle character strings correctly. + +2002-10-07 Paul Brook <paul@nowt.org> + + (g95_expand_decl): Rename from f95_expand_decl_stmt and use as + langhook. + * trans-array.c (g95_build_array_initializer): Remove. + (g95_conv_array_initializer): New Function. + (g95_trans_auto_arry_allocation): Cleanup. + (g95_trans_init_character_array): Remove. + * g95spec.c: Link in libgforbegin. + * trans.c (g95_generate_code): Rename main function to MAIN__. + (g95_create_var): New function. + (g95_create_var_np): New function. + (g95_evaluate_now): New function. + (g95_start_block): New function. + (g95_finish_block): New function. + (g95_add_expr_to_block): New function. + (g95_add_block_to_block): New function. + * trans-expr.c (g95_conv_componen_ref): New function. + * Make-lang.in (F95_ADDITIONAL_OBJS): Add gimplify.o. + (F95_OBJS): Add dependency.o. + * f95-lang.c (g95_is_simple_stmt): Remove. + * f95-tree.c (mark_not_simple): New function. + (unshare_all_trees): New function. + (create_tmp_var, create_tmp_alias_var): Remove. + * support.c (declare_tmp_vars, tree_last_decl): Remove. + * trans*: Convert to new IR using GENERIC trees. Don't bother about + SIMPLE/GIMPLE rules, this is now done by Lang-independant code. + +2002-10-01 Paul Brook <paul@nowt.org> + + * trans-array.c: Add support for descriptorless arrays. + (g95_conv_array_data): New function. + (g95_conv_array_base): New function. + * trans-array.h: Declare these here. + * trans-decl.c(g95_create_mopdule_variable): Perform variable + initialization and creation here. + (g95_create_module_vars): Instead of here. + * trans.h (G95_TYPE_ARRAY_*: Rename from G95_TYPE_DESCRIPTOR_*. + * trans-intrinsic.c: Ditto. + * trans-types.c (g95_is_nodesc_array): New function. + (g95_get_nodesc_array_type): New function. + (g95_sym_type, g95_get_derived_type): Use them. + * trans-const.c (g95_conv_mpf_to_tree): Remove workaround. + +2002-09-28 Paul Brook <paul@nowt.org> + + * trans-const.c (g95_conv_mpf_to_tree): Work around backend bug. + * trans-intrinsic.c (g95_conv_intrinsic_abs): Correctly detect complex + parameters. + +2002-09-24 Paul Brook <paul@nowt.org> + + * f95-lang.c (listify): Remove declaration. + (expand_function_body): Use optimize >=1 instead of flag_tree_saa. + (listify) + * f95-tree.c (get_name): New function. + * trans.c (module_namespace): Remove. + * trans-decl.c: Use g95_chainon_list rather than chainon(listify()). + * trans-types.c: Ditto. + +2002-09-19 Paul Brook <paul@nowt.org> + + * trans-array.c (g95_get_array_cons_size): New Function. + (g95_con_ss_startstride): Handle Array constructors. + (g95_conv_loop_setup): Ditto. + (g95_conv_array_parameter): Ditto. + * tras-decl.c (g95_finish_var_decl): Make initializes variables + static. + +2002-09-19 Paul Brook <paul@nowt.org> + + * trans.c (g95_simple_fold_tmp): Detect variables inside + NON_LVALUE_EXPR. + * trans-stmt.c (g95_trans_arithmetic_if): Implement this. + +2002-09-18 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * Make-lang.in (F95_ADDITIONAL_OBJS): Add tree-ssa-dce.o + +2002-09-14 Paul Brook <paul@nowt.org> + + * trans.c (g95_create_module_variable): Move to trans-decl.c. + * trans-const.c (g95_conv_string_init): New Function. + * trans-const.h: Declare it. + * trans-decl.c (g95_get_symbol_decl): Handle initializers for static + variables. Don't bail on intrinsic symbols. + (get_extern_function_decl): Handle specific intrinsic functions. + * trans-types.c (g95_sym_type): Dummy functions don't return + reference types. + * trans-array.c (g95_build_array_initializer): New Function. + (g95_trans_auto_array_allocation): Build initializer for static decls. + Don't use mpz_addmul, it's GMP4 only. + +2002-09-12 Paul Brook <paul@nowt.org> + + * trans-decl.c (g95_generate_code): Fix thinko with return variable. + (g95_get_extern_function_decl, g95_build_function_decl): Mangle + assembler names for module procedures. + +2002-09-11 Tobias Schlueter <Tobias.Schlueter@physik.uni-muenchen.de> + + * trans-array.c,h trans-expr.c, trans-stmt.c: Correct spelling of + dependency/ + +2002-09-10 Paul Brook <paul@nowt.org> + + * trans-array.c: Change format of G95_SS_TEMP strictures. + (g95_check_fncall_dependancy): New function. + (trans_dummy_array_bias): stride[n], not stride[n-1]. for calculating + offsets. + * trans-decl.c (g95_get_symbol_decl): move assertion after handling of + result variables. + (g95_build_function_decl): Don't assume result arrays are packed. + (g95_trans-deferred-vars): Handle array result variables. + (g95_generate_fuction_code): Clear saved_function_decls. + * trans-expr.c (g95_conv_fnction_call): Handle direct array return by + reference. + (g95_trans_arrayfunc_assign): New function. + (g95_trans_assignment): Use it. + * trans.h (g95_ss): Add temp struct for G95_SS_TEMP. + (g95_se): Add direct_byref. + * trans-types.c: Use sym->result rather than sym where appropriate. + * trans-intrinsic.c (g95_conv_intrinsic_funcall): New function. + Update other functions to use this. + (g95_is_intrinsic_libcall): New function. + (g95_conv_intrinsic_function): Add MATMUL and PRODUCT intrinsics. + (g95_walk_intrinsic_function): Ditto. + +2002-09-08 Paul Brook <paul@nowt.org> + + * trans-types.c: Change rank field to dtype field in array descriptor. + * trans-array.c: Implement filling of dtype array descriptor field. + * trans-intrinsic.c: Fix broken LEN intrinsic. + +2002-09-07 Paul Brook <paul@nowt.org> + + * trans-intrinsic.c: Remove outdated todo intrinsic list. + (g95_get_symbol_for_expr): Remove hack for fortran based intrinsics. + (g95_walk_intrinsic_function): Add MINLOC and MAXLOC. + +2002-09-06 Paul Brook <paul@nowt.org> + + * Make-lang.in (F95_ADDITIONAL_OBJS): Add tree_alias_comon.o. + (gt-f95-trans-types.h): Add dependancy information. + * config-lang.in (gtfiles): Add trans-types.c + * f95-lang.c (g95_be_parse_file): Pass error and warning counts + back to top-level code. + * trans-array.c, trans-types.c: Change format of array descriptor. + (g95_conv_descriptor_dimension): New function. + * trans-types.h (g95_conv_descriptor_rank): define. + * trans-intrinsic.c: Implement PRODUCT, COUNT. MINLOC and MAXLOC + intrinsics. + +2002-09-02 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * trans-array.c, trans-types.c: Add rank information to descriptor. + +2002-09-06 Tobias Schlueter <Tobias.Schlueter@physik.uni-muenchen.de> + + * trans-stmt.c (g95_trans_allocate): Fix when ref==NULL. + +2002-09-04 Paul Brook <paul@nowt.org> + + * f95-lang.c (g95_create_decls): New function. + (g95_init): Move initialization of external decls to above, and call + from g95_be_parse_file. + * trans.c (g95_finish_stmt): Don't amputate the decl chain. + * trans-types.c (g95_init_types): Always name integer and char types. + (g95_get_array_type_bounds): TYPE_NAME may be a TYPE_DECL. + +2002-09-02 Steven Bosscher <s.bosscher@student.tudelft.nl> + + * Make-lang.in: Add options.c to F95_PARSER_OBJS + +2002-09-02 Paul Brook <paul@nowt.org> + + * g95_generate_code: Clear the attr for __fortran_main. + * trans-types.c (g95_finish_type): New function. + * g95_init_io_state_type: Use g95_finish_type. + * g95_conv_intrinsic_anyall: Fix thinko in result initialization. + +2002-09-01 Paul Brook <paul@nowt.org> + + * README.backend: Warn about the dangers of extra config.h files. + Remove obsolete libgfor stuff. + * config-lang.in: Add target-libgfor dependancy. + * g95_conv_mpf_to_tree: Use & free allocated buffer p rather than buff. + +2002-09-01 Toon Moene <toon@moene.indiv.nluug.nl> + + * g95_conv_mpz_to_tree: Free storage pointed to by q, + not by buff. + +2002-08-30 Paul Brook <paul@nowt.org> + + * trans-intrinsic.c (g95_conv_intrinsic_function, + g95_walk_intrinsic_function): Added ANY and ALL. + (g95_conv_intrinsic_anyall): New function. + * iresolve.c (g95_resolve_any, g95_resolve_all): Include rank in + mangled name + diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in new file mode 100644 index 00000000000..a38834b4713 --- /dev/null +++ b/gcc/fortran/Make-lang.in @@ -0,0 +1,300 @@ +# -*- makefile -*- +# Top level makefile fragment for GNU gfortran, the GNU Fortran 95 compiler. +# Copyright (C) 2002, 2003 Free Software Foundation, Inc. +# Contributed by Paul Brook <paul@nowt.org +# and Steven Bosscher <s.bosscher@student.tudelft.nl> + +#This file is part of G95. + +#G95 is free software; you can redistribute it and/or modify +#it under the terms of the GNU General Public License as published by +#the Free Software Foundation; either version 2, or (at your option) +#any later version. + +#G95 is distributed in the hope that it will be useful, +#but WITHOUT ANY WARRANTY; without even the implied warranty of +#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +#GNU General Public License for more details. + +#You should have received a copy of the GNU General Public License +#along with G95; see the file COPYING. If not, write to +#the Free Software Foundation, 59 Temple Place - Suite 330, +#Boston, MA 02111-1307, USA. + +# This file provides the language dependent support in the main Makefile. +# Each language makefile fragment must provide the following targets: +# +# foo.all.build, foo.all.cross, foo.start.encap, foo.rest.encap, +# foo.info, foo.dvi, +# foo.install-normal, foo.install-common, foo.install-info, foo.install-man, +# foo.uninstall, foo.distdir, +# foo.mostlyclean, foo.clean, foo.distclean, foo.extraclean, +# foo.maintainer-clean, foo.stage1, foo.stage2, foo.stage3, foo.stage4 +# +# where `foo' is the name of the language. +# +# It should also provide rules for: +# +# - making any compiler driver (eg: gfortran) +# - the compiler proper (eg: f951) +# - define the names for selecting the language in LANGUAGES. +# $(srcdir) must be set to the gcc/ source directory (*not* gcc/fortran/). + +# Actual name to use when installing a native compiler. +GFORTRAN_INSTALL_NAME = `echo gfortran|sed '$(program_transform_name)'` + +# Actual name to use when installing a cross-compiler. +GFORTRAN_CROSS_NAME = `echo gfortran|sed '$(program_transform_cross_name)'` + +#^L + +# This is in addition to the warning flags defined by default. +# You can use it to enable/disable warnings globally or for specific +# files, e.g. +# fortran-warn = -Wno-strict-prototypes +# fortran/arith.o-warn = -Wno-error +# +# We don't need these cheats, everything builds fine with all warnings +# enabled and -Werror. + +# These are the groups of object files we have. The F95_PARSER_OBJS are +# all the front end files, the F95_OBJS are the files for the translation +# from the parse tree to GENERIC, and F95_ADDITIONAL_OBJS are the files +# from the middle end we depend on. + +F95_PARSER_OBJS = fortran/arith.o fortran/array.o fortran/bbt.o fortran/check.o\ + fortran/decl.o fortran/error.o fortran/expr.o fortran/interface.o \ + fortran/intrinsic.o fortran/io.o fortran/iresolve.o fortran/match.o \ + fortran/matchexp.o fortran/misc.o fortran/module.o fortran/parse.o \ + fortran/primary.o fortran/options.o fortran/resolve.o \ + fortran/scanner.o fortran/simplify.o fortran/st.o fortran/symbol.o \ + fortran/dump-parse-tree.o + +F95_OBJS = $(F95_PARSER_OBJS) \ + fortran/f95-lang.o fortran/convert.o fortran/trans.o fortran/trans-decl.o \ + fortran/trans-types.o fortran/trans-const.o fortran/trans-expr.o \ + fortran/trans-stmt.o fortran/trans-io.o fortran/trans-array.o \ + fortran/trans-intrinsic.o fortran/dependency.o fortran/trans-common.o \ + fortran/data.o + +# FIXME: +# We rely on c-semantics to expand from GIMPLE to RTL. +# This should go away once a real GIMPLE expander is available. +F95_ADDITIONAL_OBJS = \ + tree-cfg.o tree-dfa.o tree-optimize.o tree-simple.o \ + tree-ssa.o tree-ssa-ccp.o tree-ssa-dce.o \ + tree-alias-common.o tree-alias-type.o gimplify.o stor-layout.o + +# GFORTRAN uses GMP for its internal arithmetics. +F95_LIBS = $(GMPLIBS) $(LIBS) + +# +# Define the names for selecting gfortran in LANGUAGES. +F95 f95: f951$(exeext) + +# Tell GNU make to ignore files by these names if they exist. +.PHONY: F95 f95 + +gfortranspec.o: $(srcdir)/fortran/gfortranspec.c $(SYSTEM_H) $(TM_H) $(GCC_H) $(CONFIG_H) + (SHLIB_LINK='$(SHLIB_LINK)' \ + SHLIB_MULTILIB='$(SHLIB_MULTILIB)'; \ + $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(DRIVER_DEFINES) \ + $(INCLUDES) $(srcdir)/fortran/gfortranspec.c) + +# Create the compiler driver gfortran. +GFORTRAN_D_OBJS = gcc.o gfortranspec.o version.o prefix.o intl.o +gfortran$(exeext): $(GFORTRAN_D_OBJS) $(EXTRA_GCC_OBJS) $(LIBDEPS) + $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ \ + $(GFORTRAN_D_OBJS) $(EXTRA_GCC_OBJS) $(LIBS) + +# Create a version of the gfortran driver which calls the cross-compiler. +gfortran-cross$(exeext): gfortran$(exeext) + -rm -f gfortran-cross$(exeext) + cp gfortran$(exeext) gfortran-cross$(exeext) + +# The compiler itself is called f951. +f951$(exeext): $(F95_OBJS) $(F95_ADDITIONAL_OBJS) \ + $(BACKEND) $(LIBDEPS) + $(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ \ + $(F95_OBJS) $(F95_ADDITIONAL_OBJS) $(BACKEND) $(F95_LIBS) + +gt-fortran-f95-lang.h gtype-fortran.h : s-gtype; @true +gt-fortran-trans-decl.h gt-fortran-trans.h : s-gtype; @true +gt-fortran-trans-io.h gt-fortran-trans-types.h: s-gtype; @true +gt-fortran-trans-intrinsic.h : s-gtype; @true + +# +# Build hooks: + +f95.all.build: gfortran$(exeext) +f95.all.cross: gfortran-cross$(exeext) + +f95.start.encap: gfortran$(exeext) +f95.rest.encap: + +f95.srcinfo: fortran/gfortran.info + -cp -p $^ $(srcdir)/fortran + +f95.tags: force + cd $(srcdir)/fortran; etags -o TAGS.sub *.c *.h; \ + etags --include TAGS.sub --include ../TAGS.sub + +f95.info: fortran/gfortran.info +f95.dvi: fortran/gfortran.dvi +f95.generated-manpages: + +f95.man: +f95.srcman: + +check-f95 : check-gfortran +lang_checks += check-gfortran + +# GFORTRAN documentation. +GFORTRAN_TEXI = \ + $(srcdir)/fortran/gfortran.texi \ + $(srcdir)/fortran/invoke.texi \ + $(srcdir)/doc/include/fdl.texi \ + $(srcdir)/doc/include/gpl.texi \ + $(srcdir)/doc/include/funding.texi \ + $(srcdir)/doc/include/gcc-common.texi + +fortran/gfortran.info: $(GFORTRAN_TEXI) + if [ x$(BUILD_INFO) = xinfo ]; then \ + rm -f fortran/gfortran.info-*; \ + $(MAKEINFO) -I$(srcdir)/doc/include -I$(srcdir)/fortran \ + -o fortran/gfortran.info $(srcdir)/fortran/gfortran.texi; \ + else true; fi + +fortran/gfortran.dvi: $(GFORTRAN_TEXI) + s=`cd $(srcdir); ${PWD}`; export s; \ + cd fortran && $(TEXI2DVI) -I $$s/doc/include -I $$s/fortran \ + $$s/fortran/gfortran.texi + +# +# Install hooks: +# f951 is installed elsewhere as part of $(COMPILERS). + +# Nothing to do here. +f95.install-normal: + +# Install the driver program as $(target)-gfortran +# and also as either gfortran (if native) or $(tooldir)/bin/gfortran. +f95.install-common: installdirs + -if [ -f f951$(exeext) ] ; then \ + if [ -f gfortran-cross$(exeext) ] ; then \ + rm -f $(DESTDIR)$(bindir)/$(GFORTRAN_CROSS_NAME)$(exeext); \ + $(INSTALL_PROGRAM) gfortran-cross$(exeext) $(DESTDIR)$(bindir)/$(GFORTRAN_CROSS_NAME)$(exeext); \ + chmod a+x $(DESTDIR)$(bindir)/$(GFORTRAN_CROSS_NAME)$(exeext); \ + if [ -d $(DESTDIR)$(gcc_tooldir)/bin/. ] ; then \ + rm -f $(DESTDIR)$(gcc_tooldir)/bin/gfortran$(exeext); \ + $(INSTALL_PROGRAM) gfortran-cross$(exeext) $(DESTDIR)$(gcc_tooldir)/bin/gfortran$(exeext); \ + else true; fi; \ + else \ + rm -f $(DESTDIR)$(bindir)/$(GFORTRAN_INSTALL_NAME)$(exeext); \ + $(INSTALL_PROGRAM) gfortran$(exeext) $(DESTDIR)$(bindir)/$(GFORTRAN_INSTALL_NAME)$(exeext); \ + chmod a+x $(DESTDIR)$(bindir)/$(GFORTRAN_INSTALL_NAME)$(exeext); \ + rm -f $(DESTDIR)$(bindir)/$(GFORTRAN_TARGET_INSTALL_NAME)$(exeext); \ + $(LN) $(DESTDIR)$(bindir)/$(GFORTRAN_INSTALL_NAME)$(exeext) $(DESTDIR)$(bindir)/$(GFORTRAN_TARGET_INSTALL_NAME)$(exeext); \ + fi ; \ + fi + +# Install the info documentation in $(infodir). +# Taken from G77 (but then, what is not...) +f95.install-info: f95.info installdirs + if [ -f fortran/gfortran.info ] ; then \ + rm -f $(DESTDIR)$(infodir)/gfortran.info*; \ + for f in fortran/gfortran.info*; do \ + realfile=`echo $$f | sed -e 's|.*/\([^/]*\)$$|\1|'`; \ + $(INSTALL_DATA) $$f $(DESTDIR)$(infodir)/$$realfile; \ + done; \ + chmod a-x $(DESTDIR)$(infodir)/gfortran.info*; \ + else true; fi + @if [ -f fortran/gfortran.info ] ; then \ + if $(SHELL) -c 'install-info --version | sed 1q | fgrep -s -v -i debian' >/dev/null 2>&1; then \ + echo " install-info --info-dir=$(DESTDIR)$(infodir) $(DESTDIR)$(infodir)/gfortran.info"; \ + install-info --info-dir=$(DESTDIR)$(infodir) $(DESTDIR)$(infodir)/gfortran.info || : ; \ + else : ; fi; \ + else : ; fi + +f95.install-man: installdirs +#TODO: write the gfortran man pages + +f95.uninstall: + if $(SHELL) -c 'install-info --version | sed 1q | fgrep -s -v -i debian' >/dev/null 2>&1; then \ + echo " install-info --delete --info-dir=$(DESTDIR)$(infodir) $(DESTDIR)$(infodir)/gfortran.info"; \ + install-info --delete --info-dir=$(DESTDIR)$(infodir) $(DESTDIR)$(infodir)/gfortran.info || : ; \ + else : ; fi; \ + rm -rf $(DESTDIR)$(bindir)/$(GFORTRAN_INSTALL_NAME)$(exeext); \ + rm -rf $(DESTDIR)$(bindir)/$(GFORTRAN_CROSS_NAME)$(exeext); \ + rm -rf $(DESTDIR)$(infodir)/gfortran.info* + +# +# Clean hooks: +# A lot of the ancillary files are deleted by the main makefile. +# We just have to delete files specific to us. + +f95.mostlyclean: + -rm -f f951$(exeext) + -rm -f fortran/*.o + +f95.clean: +f95.distclean: + -rm -f fortran/config.status fortran/Makefile + +f95.extraclean: +f95.maintainer-clean: + -rm -f fortran/gfortran.info* fortran/gfortran.*aux + +# +# Stage hooks: +# The toplevel makefile has already created stage?/fortran at this point. + +f95.stage1: stage1-start + -mv fortran/*$(objext) stage1/fortran +f95.stage2: stage2-start + -mv fortran/*$(objext) stage2/fortran +f95.stage3: stage3-start + -mv fortran/*$(objext) stage3/fortran +f95.stage4: stage4-start + -mv fortran/*$(objext) stage4/fortran +f95.stageprofile: stageprofile-start + -mv fortran/*$(objext) stageprofile/fortran +f95.stagefeedback: stageprofile-start + -mv fortran/*$(objext) stagefeedback/fortran + +# +# .o: .h dependencies. + +# Everything depends on gfortran.h, but only a few files depend on +# the other headers. So at some point we'll have to split out +# which objects depend on what. FIXME +# TODO: Add dependencies on the backend/tree header files + +$(F95_PARSER_OBJS): fortran/gfortran.h fortran/intrinsic.h fortran/match.h \ + fortran/parse.h \ + $(CONFIG_H) $(SYSTEM_H) $(TM_H) $(TM_P_H) coretypes.h \ + $(RTL_H) $(TREE_H) $(TREE_DUMP_H) $(GGC_H) $(EXPR_H) \ + flags.h output.h diagnostic.h errors.h function.h + +GFORTRAN_TRANS_DEPS = fortran/gfortran.h fortran/intrinsic.h fortran/trans-array.h \ + fortran/trans-const.h fortran/trans-const.h fortran/trans.h \ + fortran/trans-stmt.h fortran/trans-types.h \ + $(CONFIG_H) $(SYSTEM_H) $(TREE_H) $(TM_H) coretypes.h + +fortran/f95-lang.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \ + gt-fortran-f95-lang.h gtype-fortran.h cgraph.h +fortran/convert.o: $(GFORTRAN_TRANS_DEPS) +fortran/trans.o: $(GFORTRAN_TRANS_DEPS) +fortran/trans-decl.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-decl.h cgraph.h +fortran/trans-types.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-types.h +fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS) +fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS) +fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS) +fortran/trans-io.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-io.h +fortran/trans-array.o: $(GFORTRAN_TRANS_DEPS) +fortran/trans-intrinsic.o: $(GFORTRAN_TRANS_DEPS) fortran/mathbuiltins.def \ + gt-fortran-trans-intrinsic.h +fortran/dependency.o: fortran/gfortran.h fortran/dependency.h +fortran/trans-common.o: $(GFORTRAN_TRANS_DEPS) fortran/gfortran.h +fortran/data.c: $(GFORTRAN_TRANS_DEPS) + diff --git a/gcc/fortran/NEWS b/gcc/fortran/NEWS new file mode 100644 index 00000000000..ce466feef81 --- /dev/null +++ b/gcc/fortran/NEWS @@ -0,0 +1,7 @@ +2003-01-06 +This project is a fork of the original G95 project. The fork has the +support of the GCC community. We still persue mostly the same goals +as the original project, but we hope we can attrack more developers +through better cooperation and communication, and we target quicker +inclusion in GCC. + diff --git a/gcc/fortran/README b/gcc/fortran/README new file mode 100644 index 00000000000..fc28c995200 --- /dev/null +++ b/gcc/fortran/README @@ -0,0 +1,18 @@ +The goal of the gcc-g95 project is to create a Free (as +in speech) Fortran 95 compiler. The code has been donated +to the Free Software Foundation for inclusion in GCC, thE +GNU Compiler Collection. + +WARNING: + +G95 is still under development. Perusing the g77 source, we estimate +that about 200,000 lines of code will be necessary to fully implement +g95. Currently, G95 is about 70,000 lines long, making it about +version 0.3. + +The current g95 can generate code for most legal Fortran 77 programs, +and we're getting close to being able to compile most Fortran 95 +programs as well. The generated code may still be quite poor, however. +Part of this is a back-end issue, since we're using the Work-In-Progress +tree-ssa infrastructure. + diff --git a/gcc/fortran/TODO b/gcc/fortran/TODO new file mode 100644 index 00000000000..023ac34b0a0 --- /dev/null +++ b/gcc/fortran/TODO @@ -0,0 +1,56 @@ +TODO + +Parser fixes: +------------ + +In a constant format string given to a data transfer statement, the +locus of any problems in the string isn't guaranteed to come out +right, because there is not a 1:1 correspondence between source +characters and characters in the string. This scheme totally doesn't +work for format strings that are longer than a physical line. + +Fix IMPLICIT to allow forward references of derived types. + +Array issues in expressions and intrinsics. + +Resolve scoping issues. Create symbols in correct namespaces. + +Finish resolution phase. + +Finish compiler side of intrinsic functions. + +Allow init exprs to be numbers raised to integer powers (negative too). + +See about making emacs-parsable error messages. + + +Biggies: +-------- + +Interface to code generator. + +Complete runtime library. + + +Known bugs: +----------- + +Failure to set the expr_locus field in g95_expr structures. + + +And for the really pedantic +--------------------------- + +Fix INCLUDE such that it only appears on a single line. The current +code allows things like: + + 0I + 1NCLUDE "filename" + +or its free form equivalent: + +I& +NCLUDE "filename" + +This is explicitly forbidden by the F95 standard (ref. section 3.4). + diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c new file mode 100644 index 00000000000..bd03fba4046 --- /dev/null +++ b/gcc/fortran/arith.c @@ -0,0 +1,2763 @@ +/* Compiler arithmetic + Copyright (C) 2000, 2001. 2002, 2003 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Since target arithmetic must be done on the host, there has to + be some way of evaluating arithmetic expressions as the host + would evaluate them. We use the GNU MP library to do arithmetic, + and this file provides the interface. */ + +#include "config.h" + +#include <string.h> + +#include "gfortran.h" +#include "arith.h" + +mpf_t pi, half_pi, two_pi, e; + +/* The gfc_(integer|real)_kinds[] structures have everything the front + end needs to know about integers and real numbers on the target. + Other entries of the structure are calculated from these values. + The first entry is the default kind, the second entry of the real + structure is the default double kind. */ + +#define MPZ_NULL {{0,0,0}} +#define MPF_NULL {{0,0,0,0}} + +#define DEF_GFC_INTEGER_KIND(KIND,RADIX,DIGITS,BIT_SIZE) \ + {KIND, RADIX, DIGITS, BIT_SIZE, 0, MPZ_NULL, MPZ_NULL, MPZ_NULL} + +#define DEF_GFC_LOGICAL_KIND(KIND,BIT_SIZE) \ + {KIND, BIT_SIZE} + +#define DEF_GFC_REAL_KIND(KIND,RADIX,DIGITS,MIN_EXP, MAX_EXP) \ + {KIND, RADIX, DIGITS, MIN_EXP, MAX_EXP, \ + 0, 0, MPF_NULL, MPF_NULL, MPF_NULL} + +gfc_integer_info gfc_integer_kinds[] = { + DEF_GFC_INTEGER_KIND (4, 2, 31, 32), + DEF_GFC_INTEGER_KIND (8, 2, 63, 64), + DEF_GFC_INTEGER_KIND (2, 2, 15, 16), + DEF_GFC_INTEGER_KIND (1, 2, 7, 8), + DEF_GFC_INTEGER_KIND (0, 0, 0, 0) +}; + +gfc_logical_info gfc_logical_kinds[] = { + DEF_GFC_LOGICAL_KIND (4, 32), + DEF_GFC_LOGICAL_KIND (8, 64), + DEF_GFC_LOGICAL_KIND (2, 16), + DEF_GFC_LOGICAL_KIND (1, 8), + DEF_GFC_LOGICAL_KIND (0, 0) +}; + +gfc_real_info gfc_real_kinds[] = { + DEF_GFC_REAL_KIND (4, 2, 24, -125, 128), + DEF_GFC_REAL_KIND (8, 2, 53, -1021, 1024), + DEF_GFC_REAL_KIND (0, 0, 0, 0, 0) +}; + + +/* The integer kind to use for array indices. This will be set to the + proper value based on target information from the backend. */ + +int gfc_index_integer_kind; + + +/* Compute the natural log of arg. + + We first get the argument into the range 0.5 to 1.5 by successive + multiplications or divisions by e. Then we use the series: + + ln(x) = (x-1) - (x-1)^/2 + (x-1)^3/3 - (x-1)^4/4 + ... + + Because we are expanding in powers of (x-1), and 0.5 < x < 1.5, we + have -0.5 < (x-1) < 0.5. Ignoring the harmonic term, this means + that each term is at most 1/(2^i), meaning one bit is gained per + iteration. + + Not very efficient, but it doesn't have to be. */ + +void +natural_logarithm (mpf_t * arg, mpf_t * result) +{ + mpf_t x, xp, t, log; + int i, p; + + mpf_init_set (x, *arg); + mpf_init (t); + + p = 0; + + mpf_set_str (t, "0.5", 10); + while (mpf_cmp (x, t) < 0) + { + mpf_mul (x, x, e); + p--; + } + + mpf_set_str (t, "1.5", 10); + while (mpf_cmp (x, t) > 0) + { + mpf_div (x, x, e); + p++; + } + + mpf_sub_ui (x, x, 1); + mpf_init_set_ui (log, 0); + mpf_init_set_ui (xp, 1); + + for (i = 1; i < GFC_REAL_BITS; i++) + { + mpf_mul (xp, xp, x); + mpf_div_ui (t, xp, i); + + if (i % 2 == 0) + mpf_sub (log, log, t); + else + mpf_add (log, log, t); + } + + /* Add in the log (e^p) = p */ + + if (p < 0) + mpf_sub_ui (log, log, -p); + else + mpf_add_ui (log, log, p); + + mpf_clear (x); + mpf_clear (xp); + mpf_clear (t); + + mpf_set (*result, log); + mpf_clear (log); +} + + +/* Calculate the common logarithm of arg. We use the natural + logaritm of arg and of 10: + + log10(arg) = log(arg)/log(10) */ + +void +common_logarithm (mpf_t * arg, mpf_t * result) +{ + mpf_t i10, log10; + + natural_logarithm (arg, result); + + mpf_init_set_ui (i10, 10); + mpf_init (log10); + natural_logarithm (&i10, &log10); + + mpf_div (*result, *result, log10); + mpf_clear (i10); + mpf_clear (log10); +} + +/* Calculate exp(arg). + + We use a reduction of the form + + x = Nln2 + r + + Then we obtain exp(r) from the McLaurin series. + exp(x) is then recovered from the identity + + exp(x) = 2^N*exp(r). */ + +void +exponential (mpf_t * arg, mpf_t * result) +{ + mpf_t two, ln2, power, q, r, num, denom, term, x, xp; + int i; + long n; + unsigned long p, mp; + + + mpf_init_set (x, *arg); + + if (mpf_cmp_ui (x, 0) == 0) + { + mpf_set_ui (*result, 1); + } + else if (mpf_cmp_ui (x, 1) == 0) + { + mpf_set (*result, e); + } + else + { + mpf_init_set_ui (two, 2); + mpf_init (ln2); + mpf_init (q); + mpf_init (r); + mpf_init (power); + mpf_init (term); + + natural_logarithm (&two, &ln2); + + mpf_div (q, x, ln2); + mpf_floor (power, q); + mpf_mul (q, power, ln2); + mpf_sub (r, x, q); + + mpf_init_set_ui (xp, 1); + mpf_init_set_ui (num, 1); + mpf_init_set_ui (denom, 1); + + for (i = 1; i <= GFC_REAL_BITS + 10; i++) + { + mpf_mul (num, num, r); + mpf_mul_ui (denom, denom, i); + mpf_div (term, num, denom); + mpf_add (xp, xp, term); + } + + /* Reconstruction step */ + n = (long) mpf_get_d (power); + + if (n > 0) + { + p = (unsigned int) n; + mpf_mul_2exp (*result, xp, p); + } + else + { + mp = (unsigned int) (-n); + mpf_div_2exp (*result, xp, mp); + } + + mpf_clear (two); + mpf_clear (ln2); + mpf_clear (q); + mpf_clear (r); + mpf_clear (power); + mpf_clear (num); + mpf_clear (denom); + mpf_clear (term); + mpf_clear (xp); + } + + mpf_clear (x); +} + + +/* Calculate sin(arg). + + We use a reduction of the form + + x= N*2pi + r + + Then we obtain sin(r) from the McLaurin series. */ + +void +sine (mpf_t * arg, mpf_t * result) +{ + mpf_t factor, q, r, num, denom, term, x, xp; + int i, sign; + + mpf_init_set (x, *arg); + + /* Special case (we do not treat multiples of pi due to roundoff issues) */ + if (mpf_cmp_ui (x, 0) == 0) + { + mpf_set_ui (*result, 0); + } + else + { + mpf_init (q); + mpf_init (r); + mpf_init (factor); + mpf_init (term); + + mpf_div (q, x, two_pi); + mpf_floor (factor, q); + mpf_mul (q, factor, two_pi); + mpf_sub (r, x, q); + + mpf_init_set_ui (xp, 0); + mpf_init_set_ui (num, 1); + mpf_init_set_ui (denom, 1); + + sign = -1; + for (i = 1; i < GFC_REAL_BITS + 10; i++) + { + mpf_mul (num, num, r); + mpf_mul_ui (denom, denom, i); + if (i % 2 == 0) + continue; + + sign = -sign; + mpf_div (term, num, denom); + if (sign > 0) + mpf_add (xp, xp, term); + else + mpf_sub (xp, xp, term); + } + + mpf_set (*result, xp); + + mpf_clear (q); + mpf_clear (r); + mpf_clear (factor); + mpf_clear (num); + mpf_clear (denom); + mpf_clear (term); + mpf_clear (xp); + } + + mpf_clear (x); +} + + +/* Calculate cos(arg). + + Similar to sine. */ + +void +cosine (mpf_t * arg, mpf_t * result) +{ + mpf_t factor, q, r, num, denom, term, x, xp; + int i, sign; + + mpf_init_set (x, *arg); + + /* Special case (we do not treat multiples of pi due to roundoff issues) */ + if (mpf_cmp_ui (x, 0) == 0) + { + mpf_set_ui (*result, 1); + } + else + { + mpf_init (q); + mpf_init (r); + mpf_init (factor); + mpf_init (term); + + mpf_div (q, x, two_pi); + mpf_floor (factor, q); + mpf_mul (q, factor, two_pi); + mpf_sub (r, x, q); + + mpf_init_set_ui (xp, 1); + mpf_init_set_ui (num, 1); + mpf_init_set_ui (denom, 1); + + sign = 1; + for (i = 1; i < GFC_REAL_BITS + 10; i++) + { + mpf_mul (num, num, r); + mpf_mul_ui (denom, denom, i); + if (i % 2 != 0) + continue; + + sign = -sign; + mpf_div (term, num, denom); + if (sign > 0) + mpf_add (xp, xp, term); + else + mpf_sub (xp, xp, term); + } + mpf_set (*result, xp); + + mpf_clear (q); + mpf_clear (r); + mpf_clear (factor); + mpf_clear (num); + mpf_clear (denom); + mpf_clear (term); + mpf_clear (xp); + } + + mpf_clear (x); +} + + +/* Calculate atan(arg). + + Similar to sine but requires special handling for x near 1. */ + +void +arctangent (mpf_t * arg, mpf_t * result) +{ + mpf_t absval, convgu, convgl, num, term, x, xp; + int i, sign; + + mpf_init_set (x, *arg); + + /* Special cases */ + if (mpf_cmp_ui (x, 0) == 0) + { + mpf_set_ui (*result, 0); + } + else if (mpf_cmp_ui (x, 1) == 0) + { + mpf_init (num); + mpf_div_ui (num, half_pi, 2); + mpf_set (*result, num); + mpf_clear (num); + } + else if (mpf_cmp_si (x, -1) == 0) + { + mpf_init (num); + mpf_div_ui (num, half_pi, 2); + mpf_neg (*result, num); + mpf_clear (num); + } + else + { /* General cases */ + + mpf_init (absval); + mpf_abs (absval, x); + + mpf_init_set_d (convgu, 1.5); + mpf_init_set_d (convgl, 0.5); + mpf_init_set_ui (num, 1); + mpf_init (term); + + if (mpf_cmp (absval, convgl) < 0) + { + mpf_init_set_ui (xp, 0); + sign = -1; + for (i = 1; i < GFC_REAL_BITS + 10; i++) + { + mpf_mul (num, num, absval); + if (i % 2 == 0) + continue; + + sign = -sign; + mpf_div_ui (term, num, i); + if (sign > 0) + mpf_add (xp, xp, term); + else + mpf_sub (xp, xp, term); + } + } + else if (mpf_cmp (absval, convgu) >= 0) + { + mpf_init_set (xp, half_pi); + sign = 1; + for (i = 1; i < GFC_REAL_BITS + 10; i++) + { + mpf_div (num, num, absval); + if (i % 2 == 0) + continue; + + sign = -sign; + mpf_div_ui (term, num, i); + if (sign > 0) + mpf_add (xp, xp, term); + else + mpf_sub (xp, xp, term); + } + } + else + { + mpf_init_set_ui (xp, 0); + + mpf_sub_ui (num, absval, 1); + mpf_add_ui (term, absval, 1); + mpf_div (absval, num, term); + + mpf_set_ui (num, 1); + + sign = -1; + for (i = 1; i < GFC_REAL_BITS + 10; i++) + { + mpf_mul (num, num, absval); + if (i % 2 == 0) + continue; + sign = -sign; + mpf_div_ui (term, num, i); + if (sign > 0) + mpf_add (xp, xp, term); + else + mpf_sub (xp, xp, term); + } + + mpf_div_ui (term, half_pi, 2); + mpf_add (xp, term, xp); + } + + /* This makes sure to preserve the identity arctan(-x) = -arctan(x) + and improves accuracy to boot. */ + + if (mpf_cmp_ui (x, 0) > 0) + mpf_set (*result, xp); + else + mpf_neg (*result, xp); + + mpf_clear (absval); + mpf_clear (convgl); + mpf_clear (convgu); + mpf_clear (num); + mpf_clear (term); + mpf_clear (xp); + } + mpf_clear (x); +} + + +/* Calculate atan2 (y, x) + +atan2(y, x) = atan(y/x) if x > 0, + sign(y)*(pi - atan(|y/x|)) if x < 0, + 0 if x = 0 && y == 0, + sign(y)*pi/2 if x = 0 && y != 0. +*/ + +void +arctangent2 (mpf_t * y, mpf_t * x, mpf_t * result) +{ + mpf_t t; + + mpf_init (t); + + switch (mpf_sgn (*x)) + { + case 1: + mpf_div (t, *y, *x); + arctangent (&t, result); + break; + case -1: + mpf_div (t, *y, *x); + mpf_abs (t, t); + arctangent (&t, &t); + mpf_sub (*result, pi, t); + if (mpf_sgn (*y) == -1) + mpf_neg (*result, *result); + break; + case 0: + if (mpf_sgn (*y) == 0) + mpf_set_ui (*result, 0); + else + { + mpf_set (*result, half_pi); + if (mpf_sgn (*y) == -1) + mpf_neg (*result, *result); + } + break; + } + mpf_clear (t); +} + +/* Calculate cosh(arg). */ + +void +hypercos (mpf_t * arg, mpf_t * result) +{ + mpf_t neg, term1, term2, x, xp; + + mpf_init_set (x, *arg); + + mpf_init (neg); + mpf_init (term1); + mpf_init (term2); + mpf_init (xp); + + mpf_neg (neg, x); + + exponential (&x, &term1); + exponential (&neg, &term2); + + mpf_add (xp, term1, term2); + mpf_div_ui (*result, xp, 2); + + mpf_clear (neg); + mpf_clear (term1); + mpf_clear (term2); + mpf_clear (x); + mpf_clear (xp); +} + + +/* Calculate sinh(arg). */ + +void +hypersine (mpf_t * arg, mpf_t * result) +{ + mpf_t neg, term1, term2, x, xp; + + mpf_init_set (x, *arg); + + mpf_init (neg); + mpf_init (term1); + mpf_init (term2); + mpf_init (xp); + + mpf_neg (neg, x); + + exponential (&x, &term1); + exponential (&neg, &term2); + + mpf_sub (xp, term1, term2); + mpf_div_ui (*result, xp, 2); + + mpf_clear (neg); + mpf_clear (term1); + mpf_clear (term2); + mpf_clear (x); + mpf_clear (xp); +} + + +/* Given an arithmetic error code, return a pointer to a string that + explains the error. */ + +static const char * +gfc_arith_error (arith code) +{ + const char *p; + + switch (code) + { + case ARITH_OK: + p = "Arithmetic OK"; + break; + case ARITH_OVERFLOW: + p = "Arithmetic overflow"; + break; + case ARITH_UNDERFLOW: + p = "Arithmetic underflow"; + break; + case ARITH_DIV0: + p = "Division by zero"; + break; + case ARITH_0TO0: + p = "Indeterminate form 0 ** 0"; + break; + case ARITH_INCOMMENSURATE: + p = "Array operands are incommensurate"; + break; + default: + gfc_internal_error ("gfc_arith_error(): Bad error code"); + } + + return p; +} + + +/* Get things ready to do math. */ + +void +gfc_arith_init_1 (void) +{ + gfc_integer_info *int_info; + gfc_real_info *real_info; + mpf_t a, b; + mpz_t r; + int i, n, limit; + + /* Set the default precision for GMP computations. */ + mpf_set_default_prec (GFC_REAL_BITS + 30); + + /* Calculate e, needed by the natural_logarithm() subroutine. */ + mpf_init (b); + mpf_init_set_ui (e, 0); + mpf_init_set_ui (a, 1); + + for (i = 1; i < 100; i++) + { + mpf_add (e, e, a); + mpf_div_ui (a, a, i); /* 1/(i!) */ + } + + /* Calculate pi, 2pi, pi/2, and -pi/2, needed for trigonometric + functions. + + We use the Bailey, Borwein and Plouffe formula: + + pi = \sum{n=0}^\infty (1/16)^n [4/(8n+1) - 2/(8n+4) - 1/(8n+5) - 1/(8n+6)] + + which gives about four bits per iteration. */ + + mpf_init_set_ui (pi, 0); + + mpf_init (two_pi); + mpf_init (half_pi); + + limit = (GFC_REAL_BITS / 4) + 10; /* (1/16)^n gives 4 bits per iteration */ + + for (n = 0; n < limit; n++) + { + mpf_set_ui (b, 4); + mpf_div_ui (b, b, 8 * n + 1); /* 4/(8n+1) */ + + mpf_set_ui (a, 2); + mpf_div_ui (a, a, 8 * n + 4); /* 2/(8n+4) */ + mpf_sub (b, b, a); + + mpf_set_ui (a, 1); + mpf_div_ui (a, a, 8 * n + 5); /* 1/(8n+5) */ + mpf_sub (b, b, a); + + mpf_set_ui (a, 1); + mpf_div_ui (a, a, 8 * n + 6); /* 1/(8n+6) */ + mpf_sub (b, b, a); + + mpf_set_ui (a, 16); + mpf_pow_ui (a, a, n); /* 16^n */ + + mpf_div (b, b, a); + + mpf_add (pi, pi, b); + } + + mpf_mul_ui (two_pi, pi, 2); + mpf_div_ui (half_pi, pi, 2); + + /* Convert the minimum/maximum values for each kind into their + GNU MP representation. */ + mpz_init (r); + + for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++) + { + /* Huge */ + mpz_set_ui (r, int_info->radix); + mpz_pow_ui (r, r, int_info->digits); + + mpz_init (int_info->huge); + mpz_sub_ui (int_info->huge, r, 1); + + /* These are the numbers that are actually representable by the + target. For bases other than two, this needs to be changed. */ + if (int_info->radix != 2) + gfc_internal_error ("Fix min_int, max_int calculation"); + + mpz_init (int_info->min_int); + mpz_neg (int_info->min_int, int_info->huge); + /* No -1 here, because the representation is symmetric. */ + + mpz_init (int_info->max_int); + mpz_add (int_info->max_int, int_info->huge, int_info->huge); + mpz_add_ui (int_info->max_int, int_info->max_int, 1); + + /* Range */ + mpf_set_z (a, int_info->huge); + common_logarithm (&a, &a); + mpf_trunc (a, a); + mpz_set_f (r, a); + int_info->range = mpz_get_si (r); + } + + /* mpf_set_default_prec(GFC_REAL_BITS); */ + for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++) + { + /* Huge */ + mpf_set_ui (a, real_info->radix); + mpf_set_ui (b, real_info->radix); + + mpf_pow_ui (a, a, real_info->max_exponent); + mpf_pow_ui (b, b, real_info->max_exponent - real_info->digits); + + mpf_init (real_info->huge); + mpf_sub (real_info->huge, a, b); + + /* Tiny */ + mpf_set_ui (b, real_info->radix); + mpf_pow_ui (b, b, 1 - real_info->min_exponent); + + mpf_init (real_info->tiny); + mpf_ui_div (real_info->tiny, 1, b); + + /* Epsilon */ + mpf_set_ui (b, real_info->radix); + mpf_pow_ui (b, b, real_info->digits - 1); + + mpf_init (real_info->epsilon); + mpf_ui_div (real_info->epsilon, 1, b); + + /* Range */ + common_logarithm (&real_info->huge, &a); + common_logarithm (&real_info->tiny, &b); + mpf_neg (b, b); + + if (mpf_cmp (a, b) > 0) + mpf_set (a, b); /* a = min(a, b) */ + + mpf_trunc (a, a); + mpz_set_f (r, a); + real_info->range = mpz_get_si (r); + + /* Precision */ + mpf_set_ui (a, real_info->radix); + common_logarithm (&a, &a); + + mpf_mul_ui (a, a, real_info->digits - 1); + mpf_trunc (a, a); + mpz_set_f (r, a); + real_info->precision = mpz_get_si (r); + + /* If the radix is an integral power of 10, add one to the + precision. */ + for (i = 10; i <= real_info->radix; i *= 10) + if (i == real_info->radix) + real_info->precision++; + } + + mpz_clear (r); + mpf_clear (a); + mpf_clear (b); +} + + +/* Clean up, get rid of numeric constants. */ + +void +gfc_arith_done_1 (void) +{ + gfc_integer_info *ip; + gfc_real_info *rp; + + mpf_clear (e); + + mpf_clear (pi); + mpf_clear (half_pi); + mpf_clear (two_pi); + + for (ip = gfc_integer_kinds; ip->kind; ip++) + { + mpz_clear (ip->min_int); + mpz_clear (ip->max_int); + mpz_clear (ip->huge); + } + + for (rp = gfc_real_kinds; rp->kind; rp++) + { + mpf_clear (rp->epsilon); + mpf_clear (rp->huge); + mpf_clear (rp->tiny); + } +} + + +/* Return default kinds. */ + +int +gfc_default_integer_kind (void) +{ + return gfc_integer_kinds[gfc_option.i8 ? 1 : 0].kind; +} + +int +gfc_default_real_kind (void) +{ + return gfc_real_kinds[gfc_option.r8 ? 1 : 0].kind; +} + +int +gfc_default_double_kind (void) +{ + return gfc_real_kinds[1].kind; +} + +int +gfc_default_character_kind (void) +{ + return 1; +} + +int +gfc_default_logical_kind (void) +{ + return gfc_logical_kinds[gfc_option.i8 ? 1 : 0].kind; +} + +int +gfc_default_complex_kind (void) +{ + return gfc_default_real_kind (); +} + + +/* Make sure that a valid kind is present. Returns an index into the + gfc_integer_kinds array, -1 if the kind is not present. */ + +static int +validate_integer (int kind) +{ + int i; + + for (i = 0;; i++) + { + if (gfc_integer_kinds[i].kind == 0) + { + i = -1; + break; + } + if (gfc_integer_kinds[i].kind == kind) + break; + } + + return i; +} + + +static int +validate_real (int kind) +{ + int i; + + for (i = 0;; i++) + { + if (gfc_real_kinds[i].kind == 0) + { + i = -1; + break; + } + if (gfc_real_kinds[i].kind == kind) + break; + } + + return i; +} + + +static int +validate_logical (int kind) +{ + int i; + + for (i = 0;; i++) + { + if (gfc_logical_kinds[i].kind == 0) + { + i = -1; + break; + } + if (gfc_logical_kinds[i].kind == kind) + break; + } + + return i; +} + + +static int +validate_character (int kind) +{ + + if (kind == gfc_default_character_kind ()) + return 0; + return -1; +} + + +/* Validate a kind given a basic type. The return value is the same + for the child functions, with -1 indicating nonexistence of the + type. */ + +int +gfc_validate_kind (bt type, int kind) +{ + int rc; + + switch (type) + { + case BT_REAL: /* Fall through */ + case BT_COMPLEX: + rc = validate_real (kind); + break; + case BT_INTEGER: + rc = validate_integer (kind); + break; + case BT_LOGICAL: + rc = validate_logical (kind); + break; + case BT_CHARACTER: + rc = validate_character (kind); + break; + + default: + gfc_internal_error ("gfc_validate_kind(): Got bad type"); + } + + return rc; +} + + +/* Given an integer and a kind, make sure that the integer lies within + the range of the kind. Returns ARITH_OK or ARITH_OVERFLOW. */ + +static arith +gfc_check_integer_range (mpz_t p, int kind) +{ + arith result; + int i; + + i = validate_integer (kind); + if (i == -1) + gfc_internal_error ("gfc_check_integer_range(): Bad kind"); + + result = ARITH_OK; + + if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0 + || mpz_cmp (p, gfc_integer_kinds[i].max_int) > 0) + result = ARITH_OVERFLOW; + + return result; +} + + +/* Given a real and a kind, make sure that the real lies within the + range of the kind. Returns ARITH_OK, ARITH_OVERFLOW or + ARITH_UNDERFLOW. */ + +static arith +gfc_check_real_range (mpf_t p, int kind) +{ + arith retval; + mpf_t q; + int i; + + mpf_init (q); + mpf_abs (q, p); + + i = validate_real (kind); + if (i == -1) + gfc_internal_error ("gfc_check_real_range(): Bad kind"); + + retval = ARITH_OK; + if (mpf_sgn (q) == 0) + goto done; + + if (mpf_cmp (q, gfc_real_kinds[i].huge) == 1) + { + retval = ARITH_OVERFLOW; + goto done; + } + + if (mpf_cmp (q, gfc_real_kinds[i].tiny) == -1) + retval = ARITH_UNDERFLOW; + +done: + mpf_clear (q); + + return retval; +} + + +/* Function to return a constant expression node of a given type and + kind. */ + +gfc_expr * +gfc_constant_result (bt type, int kind, locus * where) +{ + gfc_expr *result; + + if (!where) + gfc_internal_error + ("gfc_constant_result(): locus 'where' cannot be NULL"); + + result = gfc_get_expr (); + + result->expr_type = EXPR_CONSTANT; + result->ts.type = type; + result->ts.kind = kind; + result->where = *where; + + switch (type) + { + case BT_INTEGER: + mpz_init (result->value.integer); + break; + + case BT_REAL: + mpf_init (result->value.real); + break; + + case BT_COMPLEX: + mpf_init (result->value.complex.r); + mpf_init (result->value.complex.i); + break; + + default: + break; + } + + return result; +} + + +/* Low-level arithmetic functions. All of these subroutines assume + that all operands are of the same type and return an operand of the + same type. The other thing about these subroutines is that they + can fail in various ways -- overflow, underflow, division by zero, + zero raised to the zero, etc. */ + +static arith +gfc_arith_not (gfc_expr * op1, gfc_expr ** resultp) +{ + gfc_expr *result; + + result = gfc_constant_result (BT_LOGICAL, op1->ts.kind, &op1->where); + result->value.logical = !op1->value.logical; + *resultp = result; + + return ARITH_OK; +} + + +static arith +gfc_arith_and (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) +{ + gfc_expr *result; + + result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2), + &op1->where); + result->value.logical = op1->value.logical && op2->value.logical; + *resultp = result; + + return ARITH_OK; +} + + +static arith +gfc_arith_or (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) +{ + gfc_expr *result; + + result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2), + &op1->where); + result->value.logical = op1->value.logical || op2->value.logical; + *resultp = result; + + return ARITH_OK; +} + + +static arith +gfc_arith_eqv (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) +{ + gfc_expr *result; + + result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2), + &op1->where); + result->value.logical = op1->value.logical == op2->value.logical; + *resultp = result; + + return ARITH_OK; +} + + +static arith +gfc_arith_neqv (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) +{ + gfc_expr *result; + + result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2), + &op1->where); + result->value.logical = op1->value.logical != op2->value.logical; + *resultp = result; + + return ARITH_OK; +} + + +/* Make sure a constant numeric expression is within the range for + it's type and kind. Note that there's also a gfc_check_range(), + but that one deals with the intrinsic RANGE function. */ + +arith +gfc_range_check (gfc_expr * e) +{ + arith rc; + + switch (e->ts.type) + { + case BT_INTEGER: + rc = gfc_check_integer_range (e->value.integer, e->ts.kind); + break; + + case BT_REAL: + rc = gfc_check_real_range (e->value.real, e->ts.kind); + break; + + case BT_COMPLEX: + rc = gfc_check_real_range (e->value.complex.r, e->ts.kind); + if (rc != ARITH_OK) + rc = gfc_check_real_range (e->value.complex.i, e->ts.kind); + + break; + + default: + gfc_internal_error ("gfc_range_check(): Bad type"); + } + + return rc; +} + + +/* It may seem silly to have a subroutine that actually computes the + unary plus of a constant, but it prevents us from making exceptions + in the code elsewhere. */ + +static arith +gfc_arith_uplus (gfc_expr * op1, gfc_expr ** resultp) +{ + + *resultp = gfc_copy_expr (op1); + return ARITH_OK; +} + + +static arith +gfc_arith_uminus (gfc_expr * op1, gfc_expr ** resultp) +{ + gfc_expr *result; + arith rc; + + result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); + + switch (op1->ts.type) + { + case BT_INTEGER: + mpz_neg (result->value.integer, op1->value.integer); + break; + + case BT_REAL: + mpf_neg (result->value.real, op1->value.real); + break; + + case BT_COMPLEX: + mpf_neg (result->value.complex.r, op1->value.complex.r); + mpf_neg (result->value.complex.i, op1->value.complex.i); + break; + + default: + gfc_internal_error ("gfc_arith_uminus(): Bad basic type"); + } + + rc = gfc_range_check (result); + + if (rc != ARITH_OK) + gfc_free_expr (result); + else + *resultp = result; + + return rc; +} + + +static arith +gfc_arith_plus (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) +{ + gfc_expr *result; + arith rc; + + result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); + + switch (op1->ts.type) + { + case BT_INTEGER: + mpz_add (result->value.integer, op1->value.integer, op2->value.integer); + break; + + case BT_REAL: + mpf_add (result->value.real, op1->value.real, op2->value.real); + break; + + case BT_COMPLEX: + mpf_add (result->value.complex.r, op1->value.complex.r, + op2->value.complex.r); + + mpf_add (result->value.complex.i, op1->value.complex.i, + op2->value.complex.i); + break; + + default: + gfc_internal_error ("gfc_arith_plus(): Bad basic type"); + } + + rc = gfc_range_check (result); + + if (rc != ARITH_OK) + gfc_free_expr (result); + else + *resultp = result; + + return rc; +} + + +static arith +gfc_arith_minus (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) +{ + gfc_expr *result; + arith rc; + + result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); + + switch (op1->ts.type) + { + case BT_INTEGER: + mpz_sub (result->value.integer, op1->value.integer, op2->value.integer); + break; + + case BT_REAL: + mpf_sub (result->value.real, op1->value.real, op2->value.real); + break; + + case BT_COMPLEX: + mpf_sub (result->value.complex.r, op1->value.complex.r, + op2->value.complex.r); + + mpf_sub (result->value.complex.i, op1->value.complex.i, + op2->value.complex.i); + + break; + + default: + gfc_internal_error ("gfc_arith_minus(): Bad basic type"); + } + + rc = gfc_range_check (result); + + if (rc != ARITH_OK) + gfc_free_expr (result); + else + *resultp = result; + + return rc; +} + + +static arith +gfc_arith_times (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) +{ + gfc_expr *result; + mpf_t x, y; + arith rc; + + result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); + + switch (op1->ts.type) + { + case BT_INTEGER: + mpz_mul (result->value.integer, op1->value.integer, op2->value.integer); + break; + + case BT_REAL: + mpf_mul (result->value.real, op1->value.real, op2->value.real); + break; + + case BT_COMPLEX: + mpf_init (x); + mpf_init (y); + + mpf_mul (x, op1->value.complex.r, op2->value.complex.r); + mpf_mul (y, op1->value.complex.i, op2->value.complex.i); + mpf_sub (result->value.complex.r, x, y); + + mpf_mul (x, op1->value.complex.r, op2->value.complex.i); + mpf_mul (y, op1->value.complex.i, op2->value.complex.r); + mpf_add (result->value.complex.i, x, y); + + mpf_clear (x); + mpf_clear (y); + + break; + + default: + gfc_internal_error ("gfc_arith_times(): Bad basic type"); + } + + rc = gfc_range_check (result); + + if (rc != ARITH_OK) + gfc_free_expr (result); + else + *resultp = result; + + return rc; +} + + +static arith +gfc_arith_divide (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) +{ + gfc_expr *result; + mpf_t x, y, div; + arith rc; + + rc = ARITH_OK; + + result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); + + switch (op1->ts.type) + { + case BT_INTEGER: + if (mpz_sgn (op2->value.integer) == 0) + { + rc = ARITH_DIV0; + break; + } + + mpz_tdiv_q (result->value.integer, op1->value.integer, + op2->value.integer); + break; + + case BT_REAL: + if (mpf_sgn (op2->value.real) == 0) + { + rc = ARITH_DIV0; + break; + } + + mpf_div (result->value.real, op1->value.real, op2->value.real); + break; + + case BT_COMPLEX: + if (mpf_sgn (op2->value.complex.r) == 0 + && mpf_sgn (op2->value.complex.i) == 0) + { + rc = ARITH_DIV0; + break; + } + + mpf_init (x); + mpf_init (y); + mpf_init (div); + + mpf_mul (x, op2->value.complex.r, op2->value.complex.r); + mpf_mul (y, op2->value.complex.i, op2->value.complex.i); + mpf_add (div, x, y); + + mpf_mul (x, op1->value.complex.r, op2->value.complex.r); + mpf_mul (y, op1->value.complex.i, op2->value.complex.i); + mpf_add (result->value.complex.r, x, y); + mpf_div (result->value.complex.r, result->value.complex.r, div); + + mpf_mul (x, op1->value.complex.i, op2->value.complex.r); + mpf_mul (y, op1->value.complex.r, op2->value.complex.i); + mpf_sub (result->value.complex.i, x, y); + mpf_div (result->value.complex.i, result->value.complex.i, div); + + mpf_clear (x); + mpf_clear (y); + mpf_clear (div); + + break; + + default: + gfc_internal_error ("gfc_arith_divide(): Bad basic type"); + } + + if (rc == ARITH_OK) + rc = gfc_range_check (result); + + if (rc != ARITH_OK) + gfc_free_expr (result); + else + *resultp = result; + + return rc; +} + + +/* Compute the reciprocal of a complex number (guaranteed nonzero). */ + +static void +complex_reciprocal (gfc_expr * op) +{ + mpf_t mod, a, result_r, result_i; + + mpf_init (mod); + mpf_init (a); + + mpf_mul (mod, op->value.complex.r, op->value.complex.r); + mpf_mul (a, op->value.complex.i, op->value.complex.i); + mpf_add (mod, mod, a); + + mpf_init (result_r); + mpf_div (result_r, op->value.complex.r, mod); + + mpf_init (result_i); + mpf_neg (result_i, op->value.complex.i); + mpf_div (result_i, result_i, mod); + + mpf_set (op->value.complex.r, result_r); + mpf_set (op->value.complex.i, result_i); + + mpf_clear (result_r); + mpf_clear (result_i); + + mpf_clear (mod); + mpf_clear (a); +} + + +/* Raise a complex number to positive power. */ + +static void +complex_pow_ui (gfc_expr * base, int power, gfc_expr * result) +{ + mpf_t temp_r, temp_i, a; + + mpf_set_ui (result->value.complex.r, 1); + mpf_set_ui (result->value.complex.i, 0); + + mpf_init (temp_r); + mpf_init (temp_i); + mpf_init (a); + + for (; power > 0; power--) + { + mpf_mul (temp_r, base->value.complex.r, result->value.complex.r); + mpf_mul (a, base->value.complex.i, result->value.complex.i); + mpf_sub (temp_r, temp_r, a); + + mpf_mul (temp_i, base->value.complex.r, result->value.complex.i); + mpf_mul (a, base->value.complex.i, result->value.complex.r); + mpf_add (temp_i, temp_i, a); + + mpf_set (result->value.complex.r, temp_r); + mpf_set (result->value.complex.i, temp_i); + } + + mpf_clear (temp_r); + mpf_clear (temp_i); + mpf_clear (a); +} + + +/* Raise a number to an integer power. */ + +static arith +gfc_arith_power (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) +{ + int power, apower; + gfc_expr *result; + mpz_t unity_z; + mpf_t unity_f; + arith rc; + + rc = ARITH_OK; + + if (gfc_extract_int (op2, &power) != NULL) + gfc_internal_error ("gfc_arith_power(): Bad exponent"); + + result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where); + + if (power == 0) + { /* Handle something to the zeroth power */ + switch (op1->ts.type) + { + case BT_INTEGER: + if (mpz_sgn (op1->value.integer) == 0) + rc = ARITH_0TO0; + else + mpz_set_ui (result->value.integer, 1); + + break; + + case BT_REAL: + if (mpf_sgn (op1->value.real) == 0) + rc = ARITH_0TO0; + else + mpf_set_ui (result->value.real, 1); + + break; + + case BT_COMPLEX: + if (mpf_sgn (op1->value.complex.r) == 0 + && mpf_sgn (op1->value.complex.i) == 0) + rc = ARITH_0TO0; + else + { + mpf_set_ui (result->value.complex.r, 1); + mpf_set_ui (result->value.complex.r, 0); + } + + break; + + default: + gfc_internal_error ("gfc_arith_power(): Bad base"); + } + } + + if (power != 0) + { + apower = power; + if (power < 0) + apower = -power; + + switch (op1->ts.type) + { + case BT_INTEGER: + mpz_pow_ui (result->value.integer, op1->value.integer, apower); + + if (power < 0) + { + mpz_init_set_ui (unity_z, 1); + mpz_tdiv_q (result->value.integer, unity_z, + result->value.integer); + mpz_clear (unity_z); + } + + break; + + case BT_REAL: + mpf_pow_ui (result->value.real, op1->value.real, apower); + + if (power < 0) + { + mpf_init_set_ui (unity_f, 1); + mpf_div (result->value.real, unity_f, result->value.real); + mpf_clear (unity_f); + } + + break; + + case BT_COMPLEX: + complex_pow_ui (op1, apower, result); + if (power < 0) + complex_reciprocal (result); + + break; + + default: + break; + } + } + + if (rc == ARITH_OK) + rc = gfc_range_check (result); + + if (rc != ARITH_OK) + gfc_free_expr (result); + else + *resultp = result; + + return rc; +} + + +/* Concatenate two string constants. */ + +static arith +gfc_arith_concat (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) +{ + gfc_expr *result; + int len; + + result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind (), + &op1->where); + + len = op1->value.character.length + op2->value.character.length; + + result->value.character.string = gfc_getmem (len + 1); + result->value.character.length = len; + + memcpy (result->value.character.string, op1->value.character.string, + op1->value.character.length); + + memcpy (result->value.character.string + op1->value.character.length, + op2->value.character.string, op2->value.character.length); + + result->value.character.string[len] = '\0'; + + *resultp = result; + + return ARITH_OK; +} + + +/* Comparison operators. Assumes that the two expression nodes + contain two constants of the same type. */ + +int +gfc_compare_expr (gfc_expr * op1, gfc_expr * op2) +{ + int rc; + + switch (op1->ts.type) + { + case BT_INTEGER: + rc = mpz_cmp (op1->value.integer, op2->value.integer); + break; + + case BT_REAL: + rc = mpf_cmp (op1->value.real, op2->value.real); + break; + + case BT_CHARACTER: + rc = gfc_compare_string (op1, op2, NULL); + break; + + case BT_LOGICAL: + rc = ((!op1->value.logical && op2->value.logical) + || (op1->value.logical && !op2->value.logical)); + break; + + default: + gfc_internal_error ("gfc_compare_expr(): Bad basic type"); + } + + return rc; +} + + +/* Compare a pair of complex numbers. Naturally, this is only for + equality/nonequality. */ + +static int +compare_complex (gfc_expr * op1, gfc_expr * op2) +{ + + return (mpf_cmp (op1->value.complex.r, op2->value.complex.r) == 0 + && mpf_cmp (op1->value.complex.i, op2->value.complex.i) == 0); +} + + +/* Given two constant strings and the inverse collating sequence, + compare the strings. We return -1 for a<b, 0 for a==b and 1 for + a>b. If the xcoll_table is NULL, we use the processor's default + collating sequence. */ + +int +gfc_compare_string (gfc_expr * a, gfc_expr * b, const int *xcoll_table) +{ + int len, alen, blen, i, ac, bc; + + alen = a->value.character.length; + blen = b->value.character.length; + + len = (alen > blen) ? alen : blen; + + for (i = 0; i < len; i++) + { + ac = (i < alen) ? a->value.character.string[i] : ' '; + bc = (i < blen) ? b->value.character.string[i] : ' '; + + if (xcoll_table != NULL) + { + ac = xcoll_table[ac]; + bc = xcoll_table[bc]; + } + + if (ac < bc) + return -1; + if (ac > bc) + return 1; + } + + /* Strings are equal */ + + return 0; +} + + +/* Specific comparison subroutines. */ + +static arith +gfc_arith_eq (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) +{ + gfc_expr *result; + + result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind (), + &op1->where); + result->value.logical = (op1->ts.type == BT_COMPLEX) ? + compare_complex (op1, op2) : (gfc_compare_expr (op1, op2) == 0); + + *resultp = result; + return ARITH_OK; +} + + +static arith +gfc_arith_ne (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) +{ + gfc_expr *result; + + result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind (), + &op1->where); + result->value.logical = (op1->ts.type == BT_COMPLEX) ? + !compare_complex (op1, op2) : (gfc_compare_expr (op1, op2) != 0); + + *resultp = result; + return ARITH_OK; +} + + +static arith +gfc_arith_gt (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) +{ + gfc_expr *result; + + result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind (), + &op1->where); + result->value.logical = (gfc_compare_expr (op1, op2) > 0); + *resultp = result; + + return ARITH_OK; +} + + +static arith +gfc_arith_ge (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) +{ + gfc_expr *result; + + result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind (), + &op1->where); + result->value.logical = (gfc_compare_expr (op1, op2) >= 0); + *resultp = result; + + return ARITH_OK; +} + + +static arith +gfc_arith_lt (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) +{ + gfc_expr *result; + + result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind (), + &op1->where); + result->value.logical = (gfc_compare_expr (op1, op2) < 0); + *resultp = result; + + return ARITH_OK; +} + + +static arith +gfc_arith_le (gfc_expr * op1, gfc_expr * op2, gfc_expr ** resultp) +{ + gfc_expr *result; + + result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind (), + &op1->where); + result->value.logical = (gfc_compare_expr (op1, op2) <= 0); + *resultp = result; + + return ARITH_OK; +} + + +static arith +reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr * op, + gfc_expr ** result) +{ + gfc_constructor *c, *head; + gfc_expr *r; + arith rc; + + if (op->expr_type == EXPR_CONSTANT) + return eval (op, result); + + rc = ARITH_OK; + head = gfc_copy_constructor (op->value.constructor); + + for (c = head; c; c = c->next) + { + rc = eval (c->expr, &r); + if (rc != ARITH_OK) + break; + + gfc_replace_expr (c->expr, r); + } + + if (rc != ARITH_OK) + gfc_free_constructor (head); + else + { + r = gfc_get_expr (); + r->expr_type = EXPR_ARRAY; + r->value.constructor = head; + r->shape = gfc_copy_shape (op->shape, op->rank); + + r->ts = head->expr->ts; + r->where = op->where; + r->rank = op->rank; + + *result = r; + } + + return rc; +} + + +static arith +reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), + gfc_expr * op1, gfc_expr * op2, + gfc_expr ** result) +{ + gfc_constructor *c, *head; + gfc_expr *r; + arith rc; + + head = gfc_copy_constructor (op1->value.constructor); + rc = ARITH_OK; + + for (c = head; c; c = c->next) + { + rc = eval (c->expr, op2, &r); + if (rc != ARITH_OK) + break; + + gfc_replace_expr (c->expr, r); + } + + if (rc != ARITH_OK) + gfc_free_constructor (head); + else + { + r = gfc_get_expr (); + r->expr_type = EXPR_ARRAY; + r->value.constructor = head; + r->shape = gfc_copy_shape (op1->shape, op1->rank); + + r->ts = head->expr->ts; + r->where = op1->where; + r->rank = op1->rank; + + *result = r; + } + + return rc; +} + + +static arith +reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), + gfc_expr * op1, gfc_expr * op2, + gfc_expr ** result) +{ + gfc_constructor *c, *head; + gfc_expr *r; + arith rc; + + head = gfc_copy_constructor (op2->value.constructor); + rc = ARITH_OK; + + for (c = head; c; c = c->next) + { + rc = eval (op1, c->expr, &r); + if (rc != ARITH_OK) + break; + + gfc_replace_expr (c->expr, r); + } + + if (rc != ARITH_OK) + gfc_free_constructor (head); + else + { + r = gfc_get_expr (); + r->expr_type = EXPR_ARRAY; + r->value.constructor = head; + r->shape = gfc_copy_shape (op2->shape, op2->rank); + + r->ts = head->expr->ts; + r->where = op2->where; + r->rank = op2->rank; + + *result = r; + } + + return rc; +} + + +static arith +reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), + gfc_expr * op1, gfc_expr * op2, + gfc_expr ** result) +{ + gfc_constructor *c, *d, *head; + gfc_expr *r; + arith rc; + + head = gfc_copy_constructor (op1->value.constructor); + + rc = ARITH_OK; + d = op2->value.constructor; + + if (gfc_check_conformance ("Elemental binary operation", op1, op2) + != SUCCESS) + rc = ARITH_INCOMMENSURATE; + else + { + + for (c = head; c; c = c->next, d = d->next) + { + if (d == NULL) + { + rc = ARITH_INCOMMENSURATE; + break; + } + + rc = eval (c->expr, d->expr, &r); + if (rc != ARITH_OK) + break; + + gfc_replace_expr (c->expr, r); + } + + if (d != NULL) + rc = ARITH_INCOMMENSURATE; + } + + if (rc != ARITH_OK) + gfc_free_constructor (head); + else + { + r = gfc_get_expr (); + r->expr_type = EXPR_ARRAY; + r->value.constructor = head; + r->shape = gfc_copy_shape (op1->shape, op1->rank); + + r->ts = head->expr->ts; + r->where = op1->where; + r->rank = op1->rank; + + *result = r; + } + + return rc; +} + + +static arith +reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), + gfc_expr * op1, gfc_expr * op2, + gfc_expr ** result) +{ + + if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT) + return eval (op1, op2, result); + + if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY) + return reduce_binary_ca (eval, op1, op2, result); + + if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT) + return reduce_binary_ac (eval, op1, op2, result); + + return reduce_binary_aa (eval, op1, op2, result); +} + + +typedef union +{ + arith (*f2)(gfc_expr *, gfc_expr **); + arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **); +} +eval_f; + +/* High level arithmetic subroutines. These subroutines go into + eval_intrinsic(), which can do one of several things to its + operands. If the operands are incompatible with the intrinsic + operation, we return a node pointing to the operands and hope that + an operator interface is found during resolution. + + If the operands are compatible and are constants, then we try doing + the arithmetic. We also handle the cases where either or both + operands are array constructors. */ + +static gfc_expr * +eval_intrinsic (gfc_intrinsic_op operator, + eval_f eval, gfc_expr * op1, gfc_expr * op2) +{ + gfc_expr temp, *result; + int unary; + arith rc; + + gfc_clear_ts (&temp.ts); + + switch (operator) + { + case INTRINSIC_NOT: /* Logical unary */ + if (op1->ts.type != BT_LOGICAL) + goto runtime; + + temp.ts.type = BT_LOGICAL; + temp.ts.kind = gfc_default_logical_kind (); + + unary = 1; + break; + + /* Logical binary operators */ + case INTRINSIC_OR: + case INTRINSIC_AND: + case INTRINSIC_NEQV: + case INTRINSIC_EQV: + if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL) + goto runtime; + + temp.ts.type = BT_LOGICAL; + temp.ts.kind = gfc_default_logical_kind (); + + unary = 0; + break; + + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: /* Numeric unary */ + if (!gfc_numeric_ts (&op1->ts)) + goto runtime; + + temp.ts = op1->ts; + + unary = 1; + break; + + case INTRINSIC_GE: + case INTRINSIC_LT: /* Additional restrictions */ + case INTRINSIC_LE: /* for ordering relations. */ + case INTRINSIC_GT: + if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX) + { + temp.ts.type = BT_LOGICAL; + temp.ts.kind = gfc_default_logical_kind(); + goto runtime; + } + + /* else fall through */ + + case INTRINSIC_EQ: + case INTRINSIC_NE: + if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER) + { + unary = 0; + temp.ts.type = BT_LOGICAL; + temp.ts.kind = gfc_default_logical_kind(); + break; + } + + /* else fall through */ + + case INTRINSIC_PLUS: + case INTRINSIC_MINUS: + case INTRINSIC_TIMES: + case INTRINSIC_DIVIDE: + case INTRINSIC_POWER: /* Numeric binary */ + if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts)) + goto runtime; + + /* Insert any necessary type conversions to make the operands compatible. */ + + temp.expr_type = EXPR_OP; + gfc_clear_ts (&temp.ts); + temp.operator = operator; + + temp.op1 = op1; + temp.op2 = op2; + + gfc_type_convert_binary (&temp); + + if (operator == INTRINSIC_EQ || operator == INTRINSIC_NE + || operator == INTRINSIC_GE || operator == INTRINSIC_GT + || operator == INTRINSIC_LE || operator == INTRINSIC_LT) + { + temp.ts.type = BT_LOGICAL; + temp.ts.kind = gfc_default_logical_kind (); + } + + unary = 0; + break; + + case INTRINSIC_CONCAT: /* Character binary */ + if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER) + goto runtime; + + temp.ts.type = BT_CHARACTER; + temp.ts.kind = gfc_default_character_kind (); + + unary = 0; + break; + + case INTRINSIC_USER: + goto runtime; + + default: + gfc_internal_error ("eval_intrinsic(): Bad operator"); + } + + /* Try to combine the operators. */ + if (operator == INTRINSIC_POWER && op2->ts.type != BT_INTEGER) + goto runtime; + + if (op1->expr_type != EXPR_CONSTANT + && (op1->expr_type != EXPR_ARRAY + || !gfc_is_constant_expr (op1) + || !gfc_expanded_ac (op1))) + goto runtime; + + if (op2 != NULL + && op2->expr_type != EXPR_CONSTANT + && (op2->expr_type != EXPR_ARRAY + || !gfc_is_constant_expr (op2) + || !gfc_expanded_ac (op2))) + goto runtime; + + if (unary) + rc = reduce_unary (eval.f2, op1, &result); + else + rc = reduce_binary (eval.f3, op1, op2, &result); + + if (rc != ARITH_OK) + { /* Something went wrong */ + gfc_error ("%s at %L", gfc_arith_error (rc), &op1->where); + return NULL; + } + + gfc_free_expr (op1); + gfc_free_expr (op2); + return result; + +runtime: + /* Create a run-time expression */ + result = gfc_get_expr (); + result->ts = temp.ts; + + result->expr_type = EXPR_OP; + result->operator = operator; + + result->op1 = op1; + result->op2 = op2; + + result->where = op1->where; + + return result; +} + + +/* Modify type of expression for zero size array. */ +static gfc_expr * +eval_type_intrinsic0 (gfc_intrinsic_op operator, gfc_expr *op) +{ + if (op == NULL) + gfc_internal_error("eval_type_intrinsic0(): op NULL"); + + switch(operator) + { + case INTRINSIC_GE: + case INTRINSIC_LT: + case INTRINSIC_LE: + case INTRINSIC_GT: + case INTRINSIC_EQ: + case INTRINSIC_NE: + op->ts.type = BT_LOGICAL; + op->ts.kind = gfc_default_logical_kind(); + break; + + default: + break; + } + + return op; +} + + +/* Return nonzero if the expression is a zero size array. */ + +static int +gfc_zero_size_array (gfc_expr * e) +{ + + if (e->expr_type != EXPR_ARRAY) + return 0; + + return e->value.constructor == NULL; +} + + +/* Reduce a binary expression where at least one of the operands + involves a zero-length array. Returns NULL if neither of the + operands is a zero-length array. */ + +static gfc_expr * +reduce_binary0 (gfc_expr * op1, gfc_expr * op2) +{ + + if (gfc_zero_size_array (op1)) + { + gfc_free_expr (op2); + return op1; + } + + if (gfc_zero_size_array (op2)) + { + gfc_free_expr (op1); + return op2; + } + + return NULL; +} + + +static gfc_expr * +eval_intrinsic_f2 (gfc_intrinsic_op operator, + arith (*eval) (gfc_expr *, gfc_expr **), + gfc_expr * op1, gfc_expr * op2) +{ + gfc_expr *result; + eval_f f; + + if (op2 == NULL) + { + if (gfc_zero_size_array (op1)) + return eval_type_intrinsic0(operator, op1); + } + else + { + result = reduce_binary0 (op1, op2); + if (result != NULL) + return eval_type_intrinsic0(operator, result); + } + + f.f2 = eval; + return eval_intrinsic (operator, f, op1, op2); +} + + +static gfc_expr * +eval_intrinsic_f3 (gfc_intrinsic_op operator, + arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), + gfc_expr * op1, gfc_expr * op2) +{ + gfc_expr *result; + eval_f f; + + result = reduce_binary0 (op1, op2); + if (result != NULL) + return eval_type_intrinsic0(operator, result); + + f.f3 = eval; + return eval_intrinsic (operator, f, op1, op2); +} + + + +gfc_expr * +gfc_uplus (gfc_expr * op) +{ + return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_uplus, op, NULL); +} + +gfc_expr * +gfc_uminus (gfc_expr * op) +{ + return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL); +} + +gfc_expr * +gfc_add (gfc_expr * op1, gfc_expr * op2) +{ + return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2); +} + +gfc_expr * +gfc_subtract (gfc_expr * op1, gfc_expr * op2) +{ + return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2); +} + +gfc_expr * +gfc_multiply (gfc_expr * op1, gfc_expr * op2) +{ + return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2); +} + +gfc_expr * +gfc_divide (gfc_expr * op1, gfc_expr * op2) +{ + return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2); +} + +gfc_expr * +gfc_power (gfc_expr * op1, gfc_expr * op2) +{ + return eval_intrinsic_f3 (INTRINSIC_POWER, gfc_arith_power, op1, op2); +} + +gfc_expr * +gfc_concat (gfc_expr * op1, gfc_expr * op2) +{ + return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2); +} + +gfc_expr * +gfc_and (gfc_expr * op1, gfc_expr * op2) +{ + return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2); +} + +gfc_expr * +gfc_or (gfc_expr * op1, gfc_expr * op2) +{ + return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2); +} + +gfc_expr * +gfc_not (gfc_expr * op1) +{ + return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL); +} + +gfc_expr * +gfc_eqv (gfc_expr * op1, gfc_expr * op2) +{ + return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2); +} + +gfc_expr * +gfc_neqv (gfc_expr * op1, gfc_expr * op2) +{ + return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2); +} + +gfc_expr * +gfc_eq (gfc_expr * op1, gfc_expr * op2) +{ + return eval_intrinsic_f3 (INTRINSIC_EQ, gfc_arith_eq, op1, op2); +} + +gfc_expr * +gfc_ne (gfc_expr * op1, gfc_expr * op2) +{ + return eval_intrinsic_f3 (INTRINSIC_NE, gfc_arith_ne, op1, op2); +} + +gfc_expr * +gfc_gt (gfc_expr * op1, gfc_expr * op2) +{ + return eval_intrinsic_f3 (INTRINSIC_GT, gfc_arith_gt, op1, op2); +} + +gfc_expr * +gfc_ge (gfc_expr * op1, gfc_expr * op2) +{ + return eval_intrinsic_f3 (INTRINSIC_GE, gfc_arith_ge, op1, op2); +} + +gfc_expr * +gfc_lt (gfc_expr * op1, gfc_expr * op2) +{ + return eval_intrinsic_f3 (INTRINSIC_LT, gfc_arith_lt, op1, op2); +} + +gfc_expr * +gfc_le (gfc_expr * op1, gfc_expr * op2) +{ + return eval_intrinsic_f3 (INTRINSIC_LE, gfc_arith_le, op1, op2); +} + + +/* Convert an integer string to an expression node. */ + +gfc_expr * +gfc_convert_integer (const char *buffer, int kind, int radix, locus * where) +{ + gfc_expr *e; + const char *t; + + e = gfc_constant_result (BT_INTEGER, kind, where); + /* a leading plus is allowed, but not by mpz_set_str */ + if (buffer[0] == '+') + t = buffer + 1; + else + t = buffer; + mpz_set_str (e->value.integer, t, radix); + + return e; +} + + +/* Convert a real string to an expression node. */ + +gfc_expr * +gfc_convert_real (const char *buffer, int kind, locus * where) +{ + gfc_expr *e; + const char *t; + + e = gfc_constant_result (BT_REAL, kind, where); + /* a leading plus is allowed, but not by mpf_set_str */ + if (buffer[0] == '+') + t = buffer + 1; + else + t = buffer; + mpf_set_str (e->value.real, t, 10); + + return e; +} + + +/* Convert a pair of real, constant expression nodes to a single + complex expression node. */ + +gfc_expr * +gfc_convert_complex (gfc_expr * real, gfc_expr * imag, int kind) +{ + gfc_expr *e; + + e = gfc_constant_result (BT_COMPLEX, kind, &real->where); + mpf_set (e->value.complex.r, real->value.real); + mpf_set (e->value.complex.i, imag->value.real); + + return e; +} + + +/******* Simplification of intrinsic functions with constant arguments *****/ + + +/* Deal with an arithmetic error. */ + +static void +arith_error (arith rc, gfc_typespec * from, gfc_typespec * to, locus * where) +{ + + gfc_error ("%s converting %s to %s at %L", gfc_arith_error (rc), + gfc_typename (from), gfc_typename (to), where); + + /* TODO: Do something about the error, ie underflow rounds to 0, + throw exception, return NaN, etc. */ +} + +/* Convert integers to integers. */ + +gfc_expr * +gfc_int2int (gfc_expr * src, int kind) +{ + gfc_expr *result; + arith rc; + + result = gfc_constant_result (BT_INTEGER, kind, &src->where); + + mpz_set (result->value.integer, src->value.integer); + + if ((rc = gfc_check_integer_range (result->value.integer, kind)) + != ARITH_OK) + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + return result; +} + + +/* Convert integers to reals. */ + +gfc_expr * +gfc_int2real (gfc_expr * src, int kind) +{ + gfc_expr *result; + arith rc; + + result = gfc_constant_result (BT_REAL, kind, &src->where); + + mpf_set_z (result->value.real, src->value.integer); + + if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK) + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + return result; +} + + +/* Convert default integer to default complex. */ + +gfc_expr * +gfc_int2complex (gfc_expr * src, int kind) +{ + gfc_expr *result; + arith rc; + + result = gfc_constant_result (BT_COMPLEX, kind, &src->where); + + mpf_set_z (result->value.complex.r, src->value.integer); + mpf_set_ui (result->value.complex.i, 0); + + if ((rc = gfc_check_real_range (result->value.complex.i, kind)) != ARITH_OK) + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + return result; +} + + +/* Convert default real to default integer. */ + +gfc_expr * +gfc_real2int (gfc_expr * src, int kind) +{ + gfc_expr *result; + arith rc; + + result = gfc_constant_result (BT_INTEGER, kind, &src->where); + + mpz_set_f (result->value.integer, src->value.real); + + if ((rc = gfc_check_integer_range (result->value.integer, kind)) + != ARITH_OK) + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + return result; +} + + +/* Convert real to real. */ + +gfc_expr * +gfc_real2real (gfc_expr * src, int kind) +{ + gfc_expr *result; + arith rc; + + result = gfc_constant_result (BT_REAL, kind, &src->where); + + mpf_set (result->value.real, src->value.real); + + if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK) + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + return result; +} + + +/* Convert real to complex. */ + +gfc_expr * +gfc_real2complex (gfc_expr * src, int kind) +{ + gfc_expr *result; + arith rc; + + result = gfc_constant_result (BT_COMPLEX, kind, &src->where); + + mpf_set (result->value.complex.r, src->value.real); + mpf_set_ui (result->value.complex.i, 0); + + if ((rc = gfc_check_real_range (result->value.complex.i, kind)) != ARITH_OK) + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + return result; +} + + +/* Convert complex to integer. */ + +gfc_expr * +gfc_complex2int (gfc_expr * src, int kind) +{ + gfc_expr *result; + arith rc; + + result = gfc_constant_result (BT_INTEGER, kind, &src->where); + + mpz_set_f (result->value.integer, src->value.complex.r); + + if ((rc = gfc_check_integer_range (result->value.integer, kind)) + != ARITH_OK) + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + return result; +} + + +/* Convert complex to real. */ + +gfc_expr * +gfc_complex2real (gfc_expr * src, int kind) +{ + gfc_expr *result; + arith rc; + + result = gfc_constant_result (BT_REAL, kind, &src->where); + + mpf_set (result->value.real, src->value.complex.r); + + if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK) + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + return result; +} + + +/* Convert complex to complex. */ + +gfc_expr * +gfc_complex2complex (gfc_expr * src, int kind) +{ + gfc_expr *result; + arith rc; + + result = gfc_constant_result (BT_COMPLEX, kind, &src->where); + + mpf_set (result->value.complex.r, src->value.complex.r); + mpf_set (result->value.complex.i, src->value.complex.i); + + if ((rc = gfc_check_real_range (result->value.complex.r, kind)) != ARITH_OK + || (rc = + gfc_check_real_range (result->value.complex.i, kind)) != ARITH_OK) + { + arith_error (rc, &src->ts, &result->ts, &src->where); + gfc_free_expr (result); + return NULL; + } + + return result; +} + + +/* Logical kind conversion. */ + +gfc_expr * +gfc_log2log (gfc_expr * src, int kind) +{ + gfc_expr *result; + + result = gfc_constant_result (BT_LOGICAL, kind, &src->where); + result->value.logical = src->value.logical; + + return result; +} diff --git a/gcc/fortran/arith.h b/gcc/fortran/arith.h new file mode 100644 index 00000000000..3e629eee57f --- /dev/null +++ b/gcc/fortran/arith.h @@ -0,0 +1,91 @@ +/* Compiler arithmetic header. + Copyright (C) 2000, 2001. 2002 Free Software Foundation, Inc. + Contributed by Steven Bosscher + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#ifndef GFC_ARITH_H +#define GFC_ARITH_H + +#include "gfortran.h" + +/* Constants calculated during initialization. */ +extern mpf_t pi, half_pi, two_pi, e; + +/* Calculate mathematically interesting functions. */ +void natural_logarithm (mpf_t *, mpf_t *); +void common_logarithm (mpf_t *, mpf_t *); +void exponential (mpf_t *, mpf_t *); +void sine (mpf_t *, mpf_t *); +void cosine (mpf_t *, mpf_t *); +void arctangent (mpf_t *, mpf_t *); +void arctangent2 (mpf_t *, mpf_t *, mpf_t *); +void hypercos (mpf_t *, mpf_t *); +void hypersine (mpf_t *, mpf_t *); + +/* Return a constant result of a given type and kind, with locus. */ +gfc_expr *gfc_constant_result (bt, int, locus *); + +/* Make sure a gfc_expr expression is within its allowed range. Checks + for overflow and underflow. */ +arith gfc_range_check (gfc_expr *); + +int gfc_compare_expr (gfc_expr *, gfc_expr *); +int gfc_compare_string (gfc_expr *, gfc_expr *, const int *); + +/* Constant folding for gfc_expr trees. */ +gfc_expr *gfc_uplus (gfc_expr * op); +gfc_expr *gfc_uminus (gfc_expr * op); +gfc_expr *gfc_add (gfc_expr *, gfc_expr *); +gfc_expr *gfc_subtract (gfc_expr *, gfc_expr *); +gfc_expr *gfc_multiply (gfc_expr *, gfc_expr *); +gfc_expr *gfc_divide (gfc_expr *, gfc_expr *); +gfc_expr *gfc_power (gfc_expr *, gfc_expr *); +gfc_expr *gfc_concat (gfc_expr *, gfc_expr *); +gfc_expr *gfc_and (gfc_expr *, gfc_expr *); +gfc_expr *gfc_or (gfc_expr *, gfc_expr *); +gfc_expr *gfc_not (gfc_expr *); +gfc_expr *gfc_eqv (gfc_expr *, gfc_expr *); +gfc_expr *gfc_neqv (gfc_expr *, gfc_expr *); +gfc_expr *gfc_eq (gfc_expr *, gfc_expr *); +gfc_expr *gfc_ne (gfc_expr *, gfc_expr *); +gfc_expr *gfc_gt (gfc_expr *, gfc_expr *); +gfc_expr *gfc_ge (gfc_expr *, gfc_expr *); +gfc_expr *gfc_lt (gfc_expr *, gfc_expr *); +gfc_expr *gfc_le (gfc_expr *, gfc_expr *); + +/* Convert strings to literal constants. */ +gfc_expr *gfc_convert_integer (const char *, int, int, locus *); +gfc_expr *gfc_convert_real (const char *, int, locus *); +gfc_expr *gfc_convert_complex (gfc_expr *, gfc_expr *, int); + +/* Convert a constant of one kind to another kind. */ +gfc_expr *gfc_int2int (gfc_expr *, int); +gfc_expr *gfc_int2real (gfc_expr *, int); +gfc_expr *gfc_int2complex (gfc_expr *, int); +gfc_expr *gfc_real2int (gfc_expr *, int); +gfc_expr *gfc_real2real (gfc_expr *, int); +gfc_expr *gfc_real2complex (gfc_expr *, int); +gfc_expr *gfc_complex2int (gfc_expr *, int); +gfc_expr *gfc_complex2real (gfc_expr *, int); +gfc_expr *gfc_complex2complex (gfc_expr *, int); +gfc_expr *gfc_log2log (gfc_expr *, int); + +#endif /* GFC_ARITH_H */ + diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c new file mode 100644 index 00000000000..6ab5f83b9a3 --- /dev/null +++ b/gcc/fortran/array.c @@ -0,0 +1,1973 @@ +/* Array things + Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include "config.h" +#include "gfortran.h" +#include "match.h" + +#include <string.h> +#include <assert.h> + +/* This parameter is the size of the largest array constructor that we + will expand to an array constructor without iterators. + Constructors larger than this will remain in the iterator form. */ + +#define GFC_MAX_AC_EXPAND 100 + + +/**************** Array reference matching subroutines *****************/ + +/* Copy an array reference structure. */ + +gfc_array_ref * +gfc_copy_array_ref (gfc_array_ref * src) +{ + gfc_array_ref *dest; + int i; + + if (src == NULL) + return NULL; + + dest = gfc_get_array_ref (); + + *dest = *src; + + for (i = 0; i < GFC_MAX_DIMENSIONS; i++) + { + dest->start[i] = gfc_copy_expr (src->start[i]); + dest->end[i] = gfc_copy_expr (src->end[i]); + dest->stride[i] = gfc_copy_expr (src->stride[i]); + } + + dest->offset = gfc_copy_expr (src->offset); + + return dest; +} + + +/* Match a single dimension of an array reference. This can be a + single element or an array section. Any modifications we've made + to the ar structure are cleaned up by the caller. If the init + is set, we require the subscript to be a valid initialization + expression. */ + +static match +match_subscript (gfc_array_ref * ar, int init) +{ + match m; + int i; + + i = ar->dimen; + + ar->c_where[i] = *gfc_current_locus (); + ar->start[i] = ar->end[i] = ar->stride[i] = NULL; + + /* We can't be sure of the difference between DIMEN_ELEMENT and + DIMEN_VECTOR until we know the type of the element itself at + resolution time. */ + + ar->dimen_type[i] = DIMEN_UNKNOWN; + + if (gfc_match_char (':') == MATCH_YES) + goto end_element; + + /* Get start element. */ + if (init) + m = gfc_match_init_expr (&ar->start[i]); + else + m = gfc_match_expr (&ar->start[i]); + + if (m == MATCH_NO) + gfc_error ("Expected array subscript at %C"); + if (m != MATCH_YES) + return MATCH_ERROR; + + if (gfc_match_char (':') == MATCH_NO) + return MATCH_YES; + + /* Get an optional end element. Because we've seen the colon, we + definitely have a range along this dimension. */ +end_element: + ar->dimen_type[i] = DIMEN_RANGE; + + if (init) + m = gfc_match_init_expr (&ar->end[i]); + else + m = gfc_match_expr (&ar->end[i]); + + if (m == MATCH_ERROR) + return MATCH_ERROR; + + /* See if we have an optional stride. */ + if (gfc_match_char (':') == MATCH_YES) + { + m = init ? gfc_match_init_expr (&ar->stride[i]) + : gfc_match_expr (&ar->stride[i]); + + if (m == MATCH_NO) + gfc_error ("Expected array subscript stride at %C"); + if (m != MATCH_YES) + return MATCH_ERROR; + } + + return MATCH_YES; +} + + +/* Match an array reference, whether it is the whole array or a + particular elements or a section. If init is set, the reference has + to consist of init expressions. */ + +match +gfc_match_array_ref (gfc_array_ref * ar, gfc_array_spec * as, int init) +{ + match m; + + memset (ar, '\0', sizeof (ar)); + + ar->where = *gfc_current_locus (); + ar->as = as; + + if (gfc_match_char ('(') != MATCH_YES) + { + ar->type = AR_FULL; + ar->dimen = 0; + return MATCH_YES; + } + + ar->type = AR_UNKNOWN; + + for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++) + { + m = match_subscript (ar, init); + if (m == MATCH_ERROR) + goto error; + + if (gfc_match_char (')') == MATCH_YES) + goto matched; + + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Invalid form of array reference at %C"); + goto error; + } + } + + gfc_error ("Array reference at %C cannot have more than " + stringize (GFC_MAX_DIMENSIONS) " dimensions"); + +error: + return MATCH_ERROR; + +matched: + ar->dimen++; + + return MATCH_YES; +} + + +/************** Array specification matching subroutines ***************/ + +/* Free all of the expressions associated with array bounds + specifications. */ + +void +gfc_free_array_spec (gfc_array_spec * as) +{ + int i; + + if (as == NULL) + return; + + for (i = 0; i < as->rank; i++) + { + gfc_free_expr (as->lower[i]); + gfc_free_expr (as->upper[i]); + } + + gfc_free (as); +} + + +/* Take an array bound, resolves the expression, that make up the + shape and check associated constraints. */ + +static try +resolve_array_bound (gfc_expr * e, int check_constant) +{ + + if (e == NULL) + return SUCCESS; + + if (gfc_resolve_expr (e) == FAILURE + || gfc_specification_expr (e) == FAILURE) + return FAILURE; + + if (check_constant && gfc_is_constant_expr (e) == 0) + { + gfc_error ("Variable '%s' at %L in this context must be constant", + e->symtree->n.sym->name, &e->where); + return FAILURE; + } + + return SUCCESS; +} + + +/* Takes an array specification, resolves the expressions that make up + the shape and make sure everything is integral. */ + +try +gfc_resolve_array_spec (gfc_array_spec * as, int check_constant) +{ + gfc_expr *e; + int i; + + if (as == NULL) + return SUCCESS; + + for (i = 0; i < as->rank; i++) + { + e = as->lower[i]; + if (resolve_array_bound (e, check_constant) == FAILURE) + return FAILURE; + + e = as->upper[i]; + if (resolve_array_bound (e, check_constant) == FAILURE) + return FAILURE; + } + + return SUCCESS; +} + + +/* Match a single array element specification. The return values as + well as the upper and lower bounds of the array spec are filled + in according to what we see on the input. The caller makes sure + individual specifications make sense as a whole. + + + Parsed Lower Upper Returned + ------------------------------------ + : NULL NULL AS_DEFERRED (*) + x 1 x AS_EXPLICIT + x: x NULL AS_ASSUMED_SHAPE + x:y x y AS_EXPLICIT + x:* x NULL AS_ASSUMED_SIZE + * 1 NULL AS_ASSUMED_SIZE + + (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This + is fixed during the resolution of formal interfaces. + + Anything else AS_UNKNOWN. */ + +static array_type +match_array_element_spec (gfc_array_spec * as) +{ + gfc_expr **upper, **lower; + match m; + + lower = &as->lower[as->rank - 1]; + upper = &as->upper[as->rank - 1]; + + if (gfc_match_char ('*') == MATCH_YES) + { + *lower = gfc_int_expr (1); + return AS_ASSUMED_SIZE; + } + + if (gfc_match_char (':') == MATCH_YES) + return AS_DEFERRED; + + m = gfc_match_expr (upper); + if (m == MATCH_NO) + gfc_error ("Expected expression in array specification at %C"); + if (m != MATCH_YES) + return AS_UNKNOWN; + + if (gfc_match_char (':') == MATCH_NO) + { + *lower = gfc_int_expr (1); + return AS_EXPLICIT; + } + + *lower = *upper; + *upper = NULL; + + if (gfc_match_char ('*') == MATCH_YES) + return AS_ASSUMED_SIZE; + + m = gfc_match_expr (upper); + if (m == MATCH_ERROR) + return AS_UNKNOWN; + if (m == MATCH_NO) + return AS_ASSUMED_SHAPE; + + return AS_EXPLICIT; +} + + +/* Matches an array specification, incidentally figuring out what sort + it is. */ + +match +gfc_match_array_spec (gfc_array_spec ** asp) +{ + array_type current_type; + gfc_array_spec *as; + int i; + + if (gfc_match_char ('(') != MATCH_YES) + { + *asp = NULL; + return MATCH_NO; + } + + as = gfc_get_array_spec (); + + for (i = 0; i < GFC_MAX_DIMENSIONS; i++) + { + as->lower[i] = NULL; + as->upper[i] = NULL; + } + + as->rank = 1; + + for (;;) + { + current_type = match_array_element_spec (as); + + if (as->rank == 1) + { + if (current_type == AS_UNKNOWN) + goto cleanup; + as->type = current_type; + } + else + switch (as->type) + { /* See how current spec meshes with the existing */ + case AS_UNKNOWN: + goto cleanup; + + case AS_EXPLICIT: + if (current_type == AS_ASSUMED_SIZE) + { + as->type = AS_ASSUMED_SIZE; + break; + } + + if (current_type == AS_EXPLICIT) + break; + + gfc_error + ("Bad array specification for an explicitly shaped array" + " at %C"); + + goto cleanup; + + case AS_ASSUMED_SHAPE: + if ((current_type == AS_ASSUMED_SHAPE) + || (current_type == AS_DEFERRED)) + break; + + gfc_error + ("Bad array specification for assumed shape array at %C"); + goto cleanup; + + case AS_DEFERRED: + if (current_type == AS_DEFERRED) + break; + + if (current_type == AS_ASSUMED_SHAPE) + { + as->type = AS_ASSUMED_SHAPE; + break; + } + + gfc_error ("Bad specification for deferred shape array at %C"); + goto cleanup; + + case AS_ASSUMED_SIZE: + gfc_error ("Bad specification for assumed size array at %C"); + goto cleanup; + } + + if (gfc_match_char (')') == MATCH_YES) + break; + + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expected another dimension in array declaration at %C"); + goto cleanup; + } + + if (as->rank >= GFC_MAX_DIMENSIONS) + { + gfc_error ("Array specification at %C has more than " + stringize (GFC_MAX_DIMENSIONS) " dimensions"); + goto cleanup; + } + + as->rank++; + } + + /* If a lower bounds of an assumed shape array is blank, put in one. */ + if (as->type == AS_ASSUMED_SHAPE) + { + for (i = 0; i < as->rank; i++) + { + if (as->lower[i] == NULL) + as->lower[i] = gfc_int_expr (1); + } + } + *asp = as; + return MATCH_YES; + +cleanup: + /* Something went wrong. */ + gfc_free_array_spec (as); + return MATCH_ERROR; +} + + +/* Given a symbol and an array specification, modify the symbol to + have that array specification. The error locus is needed in case + something goes wrong. On failure, the caller must free the spec. */ + +try +gfc_set_array_spec (gfc_symbol * sym, gfc_array_spec * as, locus * error_loc) +{ + + if (as == NULL) + return SUCCESS; + + if (gfc_add_dimension (&sym->attr, error_loc) == FAILURE) + return FAILURE; + + sym->as = as; + + return SUCCESS; +} + + +/* Copy an array specification. */ + +gfc_array_spec * +gfc_copy_array_spec (gfc_array_spec * src) +{ + gfc_array_spec *dest; + int i; + + if (src == NULL) + return NULL; + + dest = gfc_get_array_spec (); + + *dest = *src; + + for (i = 0; i < dest->rank; i++) + { + dest->lower[i] = gfc_copy_expr (dest->lower[i]); + dest->upper[i] = gfc_copy_expr (dest->upper[i]); + } + + return dest; +} + +/* Returns nonzero if the two expressions are equal. Only handles integer + constants. */ + +static int +compare_bounds (gfc_expr * bound1, gfc_expr * bound2) +{ + if (bound1 == NULL || bound2 == NULL + || bound1->expr_type != EXPR_CONSTANT + || bound2->expr_type != EXPR_CONSTANT + || bound1->ts.type != BT_INTEGER + || bound2->ts.type != BT_INTEGER) + gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered"); + + if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0) + return 1; + else + return 0; +} + +/* Compares two array specifications. They must be constant or deferred + shape. */ + +int +gfc_compare_array_spec (gfc_array_spec * as1, gfc_array_spec * as2) +{ + int i; + + if (as1 == NULL && as2 == NULL) + return 1; + + if (as1 == NULL || as2 == NULL) + return 0; + + if (as1->rank != as2->rank) + return 0; + + if (as1->rank == 0) + return 1; + + if (as1->type != as2->type) + return 0; + + if (as1->type == AS_EXPLICIT) + for (i = 0; i < as1->rank; i++) + { + if (compare_bounds (as1->lower[i], as2->lower[i]) == 0) + return 0; + + if (compare_bounds (as1->upper[i], as2->upper[i]) == 0) + return 0; + } + + return 1; +} + + +/****************** Array constructor functions ******************/ + +/* Start an array constructor. The constructor starts with zero + elements and should be appended to by gfc_append_constructor(). */ + +gfc_expr * +gfc_start_constructor (bt type, int kind, locus * where) +{ + gfc_expr *result; + + result = gfc_get_expr (); + + result->expr_type = EXPR_ARRAY; + result->rank = 1; + + result->ts.type = type; + result->ts.kind = kind; + result->where = *where; + return result; +} + + +/* Given an array constructor expression, append the new expression + node onto the constructor. */ + +void +gfc_append_constructor (gfc_expr * base, gfc_expr * new) +{ + gfc_constructor *c; + + if (base->value.constructor == NULL) + base->value.constructor = c = gfc_get_constructor (); + else + { + c = base->value.constructor; + while (c->next) + c = c->next; + + c->next = gfc_get_constructor (); + c = c->next; + } + + c->expr = new; + + if (new->ts.type != base->ts.type || new->ts.kind != base->ts.kind) + gfc_internal_error ("gfc_append_constructor(): New node has wrong kind"); +} + + +/* Given an array constructor expression, insert the new expression's + constructor onto the base's one according to the offset. */ + +void +gfc_insert_constructor (gfc_expr * base, gfc_constructor * c1) +{ + gfc_constructor *c, *pre; + expr_t type; + + type = base->expr_type; + + if (base->value.constructor == NULL) + base->value.constructor = c1; + else + { + c = pre = base->value.constructor; + while (c) + { + if (type == EXPR_ARRAY) + { + if (mpz_cmp (c->n.offset, c1->n.offset) < 0) + { + pre = c; + c = c->next; + } + else if (mpz_cmp (c->n.offset, c1->n.offset) == 0) + { + gfc_error ("duplicated initializer"); + break; + } + else + break; + } + else + { + pre = c; + c = c->next; + } + } + + if (pre != c) + { + pre->next = c1; + c1->next = c; + } + else + { + c1->next = c; + base->value.constructor = c1; + } + } +} + + +/* Get a new constructor. */ + +gfc_constructor * +gfc_get_constructor (void) +{ + gfc_constructor *c; + + c = gfc_getmem (sizeof(gfc_constructor)); + c->expr = NULL; + c->iterator = NULL; + c->next = NULL; + mpz_init_set_si (c->n.offset, 0); + mpz_init_set_si (c->repeat, 0); + return c; +} + + +/* Free chains of gfc_constructor structures. */ + +void +gfc_free_constructor (gfc_constructor * p) +{ + gfc_constructor *next; + + if (p == NULL) + return; + + for (; p; p = next) + { + next = p->next; + + if (p->expr) + gfc_free_expr (p->expr); + if (p->iterator != NULL) + gfc_free_iterator (p->iterator, 1); + mpz_clear (p->n.offset); + mpz_clear (p->repeat); + gfc_free (p); + } +} + + +/* Given an expression node that might be an array constructor and a + symbol, make sure that no iterators in this or child constructors + use the symbol as an implied-DO iterator. Returns nonzero if a + duplicate was found. */ + +static int +check_duplicate_iterator (gfc_constructor * c, gfc_symbol * master) +{ + gfc_expr *e; + + for (; c; c = c->next) + { + e = c->expr; + + if (e->expr_type == EXPR_ARRAY + && check_duplicate_iterator (e->value.constructor, master)) + return 1; + + if (c->iterator == NULL) + continue; + + if (c->iterator->var->symtree->n.sym == master) + { + gfc_error + ("DO-iterator '%s' at %L is inside iterator of the same name", + master->name, &c->where); + + return 1; + } + } + + return 0; +} + + +/* Forward declaration because these functions are mutually recursive. */ +static match match_array_cons_element (gfc_constructor **); + +/* Match a list of array elements. */ + +static match +match_array_list (gfc_constructor ** result) +{ + gfc_constructor *p, *head, *tail, *new; + gfc_iterator iter; + locus old_loc; + gfc_expr *e; + match m; + int n; + + old_loc = *gfc_current_locus (); + + if (gfc_match_char ('(') == MATCH_NO) + return MATCH_NO; + + memset (&iter, '\0', sizeof (gfc_iterator)); + head = NULL; + + m = match_array_cons_element (&head); + if (m != MATCH_YES) + goto cleanup; + + tail = head; + + if (gfc_match_char (',') != MATCH_YES) + { + m = MATCH_NO; + goto cleanup; + } + + for (n = 1;; n++) + { + m = gfc_match_iterator (&iter, 0); + if (m == MATCH_YES) + break; + if (m == MATCH_ERROR) + goto cleanup; + + m = match_array_cons_element (&new); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + if (n > 2) + goto syntax; + m = MATCH_NO; + goto cleanup; /* Could be a complex constant */ + } + + tail->next = new; + tail = new; + + if (gfc_match_char (',') != MATCH_YES) + { + if (n > 2) + goto syntax; + m = MATCH_NO; + goto cleanup; + } + } + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + if (check_duplicate_iterator (head, iter.var->symtree->n.sym)) + { + m = MATCH_ERROR; + goto cleanup; + } + + e = gfc_get_expr (); + e->expr_type = EXPR_ARRAY; + e->where = old_loc; + e->value.constructor = head; + + p = gfc_get_constructor (); + p->where = *gfc_current_locus (); + p->iterator = gfc_get_iterator (); + *p->iterator = iter; + + p->expr = e; + *result = p; + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in array constructor at %C"); + m = MATCH_ERROR; + +cleanup: + gfc_free_constructor (head); + gfc_free_iterator (&iter, 0); + gfc_set_locus (&old_loc); + return m; +} + + +/* Match a single element of an array constructor, which can be a + single expression or a list of elements. */ + +static match +match_array_cons_element (gfc_constructor ** result) +{ + gfc_constructor *p; + gfc_expr *expr; + match m; + + m = match_array_list (result); + if (m != MATCH_NO) + return m; + + m = gfc_match_expr (&expr); + if (m != MATCH_YES) + return m; + + p = gfc_get_constructor (); + p->where = *gfc_current_locus (); + p->expr = expr; + + *result = p; + return MATCH_YES; +} + + +/* Match an array constructor. */ + +match +gfc_match_array_constructor (gfc_expr ** result) +{ + gfc_constructor *head, *tail, *new; + gfc_expr *expr; + locus where; + match m; + + if (gfc_match (" (/") == MATCH_NO) + return MATCH_NO; + + where = *gfc_current_locus (); + head = tail = NULL; + + if (gfc_match (" /)") == MATCH_YES) + goto empty; /* Special case */ + + for (;;) + { + m = match_array_cons_element (&new); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + if (head == NULL) + head = new; + else + tail->next = new; + + tail = new; + + if (gfc_match_char (',') == MATCH_NO) + break; + } + + if (gfc_match (" /)") == MATCH_NO) + goto syntax; + +empty: + expr = gfc_get_expr (); + + expr->expr_type = EXPR_ARRAY; + + expr->value.constructor = head; + /* Size must be calculated at resolution time. */ + + expr->where = where; + expr->rank = 1; + + *result = expr; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in array constructor at %C"); + +cleanup: + gfc_free_constructor (head); + return MATCH_ERROR; +} + + + +/************** Check array constructors for correctness **************/ + +/* Given an expression, compare it's type with the type of the current + constructor. Returns nonzero if an error was issued. The + cons_state variable keeps track of whether the type of the + constructor being read or resolved is known to be good, bad or just + starting out. */ + +static gfc_typespec constructor_ts; +static enum +{ CONS_START, CONS_GOOD, CONS_BAD } +cons_state; + +static int +check_element_type (gfc_expr * expr) +{ + + if (cons_state == CONS_BAD) + return 0; /* Supress further errors */ + + if (cons_state == CONS_START) + { + if (expr->ts.type == BT_UNKNOWN) + cons_state = CONS_BAD; + else + { + cons_state = CONS_GOOD; + constructor_ts = expr->ts; + } + + return 0; + } + + if (gfc_compare_types (&constructor_ts, &expr->ts)) + return 0; + + gfc_error ("Element in %s array constructor at %L is %s", + gfc_typename (&constructor_ts), &expr->where, + gfc_typename (&expr->ts)); + + cons_state = CONS_BAD; + return 1; +} + + +/* Recursive work function for gfc_check_constructor_type(). */ + +static try +check_constructor_type (gfc_constructor * c) +{ + gfc_expr *e; + + for (; c; c = c->next) + { + e = c->expr; + + if (e->expr_type == EXPR_ARRAY) + { + if (check_constructor_type (e->value.constructor) == FAILURE) + return FAILURE; + + continue; + } + + if (check_element_type (e)) + return FAILURE; + } + + return SUCCESS; +} + + +/* Check that all elements of an array constructor are the same type. + On FAILURE, an error has been generated. */ + +try +gfc_check_constructor_type (gfc_expr * e) +{ + try t; + + cons_state = CONS_START; + gfc_clear_ts (&constructor_ts); + + t = check_constructor_type (e->value.constructor); + if (t == SUCCESS && e->ts.type == BT_UNKNOWN) + e->ts = constructor_ts; + + return t; +} + + + +typedef struct cons_stack +{ + gfc_iterator *iterator; + struct cons_stack *previous; +} +cons_stack; + +static cons_stack *base; + +static try check_constructor (gfc_constructor *, try (*)(gfc_expr *)); + +/* Check an EXPR_VARIABLE expression in a constructor to make sure + that that variable is an iteration variables. */ + +try +gfc_check_iter_variable (gfc_expr * expr) +{ + + gfc_symbol *sym; + cons_stack *c; + + sym = expr->symtree->n.sym; + + for (c = base; c; c = c->previous) + if (sym == c->iterator->var->symtree->n.sym) + return SUCCESS; + + return FAILURE; +} + + +/* Recursive work function for gfc_check_constructor(). This amounts + to calling the check function for each expression in the + constructor, giving variables with the names of iterators a pass. */ + +static try +check_constructor (gfc_constructor * c, try (*check_function) (gfc_expr *)) +{ + cons_stack element; + gfc_expr *e; + try t; + + for (; c; c = c->next) + { + e = c->expr; + + if (e->expr_type != EXPR_ARRAY) + { + if ((*check_function) (e) == FAILURE) + return FAILURE; + continue; + } + + element.previous = base; + element.iterator = c->iterator; + + base = &element; + t = check_constructor (e->value.constructor, check_function); + base = element.previous; + + if (t == FAILURE) + return FAILURE; + } + + /* Nothing went wrong, so all OK. */ + return SUCCESS; +} + + +/* Checks a constructor to see if it is a particular kind of + expression -- specification, restricted, or initialization as + determined by the check_function. */ + +try +gfc_check_constructor (gfc_expr * expr, try (*check_function) (gfc_expr *)) +{ + cons_stack *base_save; + try t; + + base_save = base; + base = NULL; + + t = check_constructor (expr->value.constructor, check_function); + base = base_save; + + return t; +} + + + +/**************** Simplification of array constructors ****************/ + +iterator_stack *iter_stack; + +typedef struct +{ + gfc_constructor *new_head, *new_tail; + int extract_count, extract_n; + gfc_expr *extracted; + mpz_t *count; + + mpz_t *offset; + gfc_component *component; + mpz_t *repeat; + + try (*expand_work_function) (gfc_expr *); +} +expand_info; + +static expand_info current_expand; + +static try expand_constructor (gfc_constructor *); + + +/* Work function that counts the number of elements present in a + constructor. */ + +static try +count_elements (gfc_expr * e) +{ + mpz_t result; + + if (e->rank == 0) + mpz_add_ui (*current_expand.count, *current_expand.count, 1); + else + { + if (gfc_array_size (e, &result) == FAILURE) + { + gfc_free_expr (e); + return FAILURE; + } + + mpz_add (*current_expand.count, *current_expand.count, result); + mpz_clear (result); + } + + gfc_free_expr (e); + return SUCCESS; +} + + +/* Work function that extracts a particular element from an array + constructor, freeing the rest. */ + +static try +extract_element (gfc_expr * e) +{ + + if (e->rank != 0) + { /* Something unextractable */ + gfc_free_expr (e); + return FAILURE; + } + + if (current_expand.extract_count == current_expand.extract_n) + current_expand.extracted = e; + else + gfc_free_expr (e); + + current_expand.extract_count++; + return SUCCESS; +} + + +/* Work function that constructs a new constructor out of the old one, + stringing new elements together. */ + +static try +expand (gfc_expr * e) +{ + + if (current_expand.new_head == NULL) + current_expand.new_head = current_expand.new_tail = + gfc_get_constructor (); + else + { + current_expand.new_tail->next = gfc_get_constructor (); + current_expand.new_tail = current_expand.new_tail->next; + } + + current_expand.new_tail->where = e->where; + current_expand.new_tail->expr = e; + + mpz_set (current_expand.new_tail->n.offset, *current_expand.offset); + current_expand.new_tail->n.component = current_expand.component; + mpz_set (current_expand.new_tail->repeat, *current_expand.repeat); + return SUCCESS; +} + + +/* Given an initialization expression that is a variable reference, + substitute the current value of the iteration variable. */ + +void +gfc_simplify_iterator_var (gfc_expr * e) +{ + iterator_stack *p; + + for (p = iter_stack; p; p = p->prev) + if (e->symtree == p->variable) + break; + + if (p == NULL) + return; /* Variable not found */ + + gfc_replace_expr (e, gfc_int_expr (0)); + + mpz_set (e->value.integer, p->value); + + return; +} + + +/* Expand an expression with that is inside of a constructor, + recursing into other constructors if present. */ + +static try +expand_expr (gfc_expr * e) +{ + + if (e->expr_type == EXPR_ARRAY) + return expand_constructor (e->value.constructor); + + e = gfc_copy_expr (e); + + if (gfc_simplify_expr (e, 1) == FAILURE) + { + gfc_free_expr (e); + return FAILURE; + } + + return current_expand.expand_work_function (e); +} + + +static try +expand_iterator (gfc_constructor * c) +{ + gfc_expr *start, *end, *step; + iterator_stack frame; + mpz_t trip; + try t; + + end = step = NULL; + + t = FAILURE; + + mpz_init (trip); + mpz_init (frame.value); + + start = gfc_copy_expr (c->iterator->start); + if (gfc_simplify_expr (start, 1) == FAILURE) + goto cleanup; + + if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER) + goto cleanup; + + end = gfc_copy_expr (c->iterator->end); + if (gfc_simplify_expr (end, 1) == FAILURE) + goto cleanup; + + if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER) + goto cleanup; + + step = gfc_copy_expr (c->iterator->step); + if (gfc_simplify_expr (step, 1) == FAILURE) + goto cleanup; + + if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER) + goto cleanup; + + if (mpz_sgn (step->value.integer) == 0) + { + gfc_error ("Iterator step at %L cannot be zero", &step->where); + goto cleanup; + } + + /* Calculate the trip count of the loop. */ + mpz_sub (trip, end->value.integer, start->value.integer); + mpz_add (trip, trip, step->value.integer); + mpz_tdiv_q (trip, trip, step->value.integer); + + mpz_set (frame.value, start->value.integer); + + frame.prev = iter_stack; + frame.variable = c->iterator->var->symtree; + iter_stack = &frame; + + while (mpz_sgn (trip) > 0) + { + if (expand_expr (c->expr) == FAILURE) + goto cleanup; + + mpz_add (frame.value, frame.value, step->value.integer); + mpz_sub_ui (trip, trip, 1); + } + + t = SUCCESS; + +cleanup: + gfc_free_expr (start); + gfc_free_expr (end); + gfc_free_expr (step); + + mpz_clear (trip); + mpz_clear (frame.value); + + iter_stack = frame.prev; + + return t; +} + + +/* Expand a constructor into constant constructors without any + iterators, calling the work function for each of the expanded + expressions. The work function needs to either save or free the + passed expression. */ + +static try +expand_constructor (gfc_constructor * c) +{ + gfc_expr *e; + + for (; c; c = c->next) + { + if (c->iterator != NULL) + { + if (expand_iterator (c) == FAILURE) + return FAILURE; + continue; + } + + e = c->expr; + + if (e->expr_type == EXPR_ARRAY) + { + if (expand_constructor (e->value.constructor) == FAILURE) + return FAILURE; + + continue; + } + + e = gfc_copy_expr (e); + if (gfc_simplify_expr (e, 1) == FAILURE) + { + gfc_free_expr (e); + return FAILURE; + } + current_expand.offset = &c->n.offset; + current_expand.component = c->n.component; + current_expand.repeat = &c->repeat; + if (current_expand.expand_work_function (e) == FAILURE) + return FAILURE; + } + return SUCCESS; +} + + +/* Top level subroutine for expanding constructors. We only expand + constructor if they are small enough. */ + +try +gfc_expand_constructor (gfc_expr * e) +{ + expand_info expand_save; + gfc_expr *f; + try rc; + + f = gfc_get_array_element (e, GFC_MAX_AC_EXPAND); + if (f != NULL) + { + gfc_free_expr (f); + return SUCCESS; + } + + expand_save = current_expand; + current_expand.new_head = current_expand.new_tail = NULL; + + iter_stack = NULL; + + current_expand.expand_work_function = expand; + + if (expand_constructor (e->value.constructor) == FAILURE) + { + gfc_free_constructor (current_expand.new_head); + rc = FAILURE; + goto done; + } + + gfc_free_constructor (e->value.constructor); + e->value.constructor = current_expand.new_head; + + rc = SUCCESS; + +done: + current_expand = expand_save; + + return rc; +} + + +/* Work function for checking that an element of a constructor is a + constant, after removal of any iteration variables. We return + FAILURE if not so. */ + +static try +constant_element (gfc_expr * e) +{ + int rv; + + rv = gfc_is_constant_expr (e); + gfc_free_expr (e); + + return rv ? SUCCESS : FAILURE; +} + + +/* Given an array constructor, determine if the constructor is + constant or not by expanding it and making sure that all elements + are constants. This is a bit of a hack since something like (/ (i, + i=1,100000000) /) will take a while as* opposed to a more clever + function that traverses the expression tree. FIXME. */ + +int +gfc_constant_ac (gfc_expr * e) +{ + expand_info expand_save; + try rc; + + iter_stack = NULL; + expand_save = current_expand; + current_expand.expand_work_function = constant_element; + + rc = expand_constructor (e->value.constructor); + + current_expand = expand_save; + if (rc == FAILURE) + return 0; + + return 1; +} + + +/* Returns nonzero if an array constructor has been completely + expanded (no iterators) and zero if iterators are present. */ + +int +gfc_expanded_ac (gfc_expr * e) +{ + gfc_constructor *p; + + if (e->expr_type == EXPR_ARRAY) + for (p = e->value.constructor; p; p = p->next) + if (p->iterator != NULL || !gfc_expanded_ac (p->expr)) + return 0; + + return 1; +} + + +/*************** Type resolution of array constructors ***************/ + +/* Recursive array list resolution function. All of the elements must + be of the same type. */ + +static try +resolve_array_list (gfc_constructor * p) +{ + try t; + + t = SUCCESS; + + for (; p; p = p->next) + { + if (p->iterator != NULL + && gfc_resolve_iterator (p->iterator) == FAILURE) + t = FAILURE; + + if (gfc_resolve_expr (p->expr) == FAILURE) + t = FAILURE; + } + + return t; +} + + +/* Resolve all of the expressions in an array list. + TODO: String lengths. */ + +try +gfc_resolve_array_constructor (gfc_expr * expr) +{ + try t; + + t = resolve_array_list (expr->value.constructor); + if (t == SUCCESS) + t = gfc_check_constructor_type (expr); + + return t; +} + + +/* Copy an iterator structure. */ + +static gfc_iterator * +copy_iterator (gfc_iterator * src) +{ + gfc_iterator *dest; + + if (src == NULL) + return NULL; + + dest = gfc_get_iterator (); + + dest->var = gfc_copy_expr (src->var); + dest->start = gfc_copy_expr (src->start); + dest->end = gfc_copy_expr (src->end); + dest->step = gfc_copy_expr (src->step); + + return dest; +} + + +/* Copy a constructor structure. */ + +gfc_constructor * +gfc_copy_constructor (gfc_constructor * src) +{ + gfc_constructor *dest; + gfc_constructor *tail; + + if (src == NULL) + return NULL; + + dest = tail = NULL; + while (src) + { + if (dest == NULL) + dest = tail = gfc_get_constructor (); + else + { + tail->next = gfc_get_constructor (); + tail = tail->next; + } + tail->where = src->where; + tail->expr = gfc_copy_expr (src->expr); + tail->iterator = copy_iterator (src->iterator); + mpz_set (tail->n.offset, src->n.offset); + tail->n.component = src->n.component; + mpz_set (tail->repeat, src->repeat); + src = src->next; + } + + return dest; +} + + +/* Given an array expression and an element number (starting at zero), + return a pointer to the array element. NULL is returned if the + size of the array has been exceeded. The expression node returned + remains a part of the array and should not be freed. Access is not + efficient at all, but this is another place where things do not + have to be particularly fast. */ + +gfc_expr * +gfc_get_array_element (gfc_expr * array, int element) +{ + expand_info expand_save; + gfc_expr *e; + try rc; + + expand_save = current_expand; + current_expand.extract_n = element; + current_expand.expand_work_function = extract_element; + current_expand.extracted = NULL; + current_expand.extract_count = 0; + + iter_stack = NULL; + + rc = expand_constructor (array->value.constructor); + e = current_expand.extracted; + current_expand = expand_save; + + if (rc == FAILURE) + return NULL; + + return e; +} + + +/********* Subroutines for determining the size of an array *********/ + +/* These are needed just to accomodate RESHAPE(). There are no + diagnostics here, we just return a negative number if something + goes wrong. */ + + +/* Get the size of single dimension of an array specification. The + array is guaranteed to be one dimensional. */ + +static try +spec_dimen_size (gfc_array_spec * as, int dimen, mpz_t * result) +{ + + if (as == NULL) + return FAILURE; + + if (dimen < 0 || dimen > as->rank - 1) + gfc_internal_error ("spec_dimen_size(): Bad dimension"); + + if (as->type != AS_EXPLICIT + || as->lower[dimen]->expr_type != EXPR_CONSTANT + || as->upper[dimen]->expr_type != EXPR_CONSTANT) + return FAILURE; + + mpz_init (*result); + + mpz_sub (*result, as->upper[dimen]->value.integer, + as->lower[dimen]->value.integer); + + mpz_add_ui (*result, *result, 1); + + return SUCCESS; +} + + +try +spec_size (gfc_array_spec * as, mpz_t * result) +{ + mpz_t size; + int d; + + mpz_init_set_ui (*result, 1); + + for (d = 0; d < as->rank; d++) + { + if (spec_dimen_size (as, d, &size) == FAILURE) + { + mpz_clear (*result); + return FAILURE; + } + + mpz_mul (*result, *result, size); + mpz_clear (size); + } + + return SUCCESS; +} + + +/* Get the number of elements in an array section. */ + +static try +ref_dimen_size (gfc_array_ref * ar, int dimen, mpz_t * result) +{ + mpz_t upper, lower, stride; + try t; + + if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1) + gfc_internal_error ("ref_dimen_size(): Bad dimension"); + + switch (ar->dimen_type[dimen]) + { + case DIMEN_ELEMENT: + mpz_init (*result); + mpz_set_ui (*result, 1); + t = SUCCESS; + break; + + case DIMEN_VECTOR: + t = gfc_array_size (ar->start[dimen], result); /* Recurse! */ + break; + + case DIMEN_RANGE: + mpz_init (upper); + mpz_init (lower); + mpz_init (stride); + t = FAILURE; + + if (ar->start[dimen] == NULL) + { + if (ar->as->lower[dimen] == NULL + || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT) + goto cleanup; + mpz_set (lower, ar->as->lower[dimen]->value.integer); + } + else + { + if (ar->start[dimen]->expr_type != EXPR_CONSTANT) + goto cleanup; + mpz_set (lower, ar->start[dimen]->value.integer); + } + + if (ar->end[dimen] == NULL) + { + if (ar->as->upper[dimen] == NULL + || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT) + goto cleanup; + mpz_set (upper, ar->as->upper[dimen]->value.integer); + } + else + { + if (ar->end[dimen]->expr_type != EXPR_CONSTANT) + goto cleanup; + mpz_set (upper, ar->end[dimen]->value.integer); + } + + if (ar->stride[dimen] == NULL) + mpz_set_ui (stride, 1); + else + { + if (ar->stride[dimen]->expr_type != EXPR_CONSTANT) + goto cleanup; + mpz_set (stride, ar->stride[dimen]->value.integer); + } + + mpz_init (*result); + mpz_sub (*result, upper, lower); + mpz_add (*result, *result, stride); + mpz_div (*result, *result, stride); + + /* Zero stride caught earlier. */ + if (mpz_cmp_ui (*result, 0) < 0) + mpz_set_ui (*result, 0); + t = SUCCESS; + + cleanup: + mpz_clear (upper); + mpz_clear (lower); + mpz_clear (stride); + return t; + + default: + gfc_internal_error ("ref_dimen_size(): Bad dimen_type"); + } + + return t; +} + + +static try +ref_size (gfc_array_ref * ar, mpz_t * result) +{ + mpz_t size; + int d; + + mpz_init_set_ui (*result, 1); + + for (d = 0; d < ar->dimen; d++) + { + if (ref_dimen_size (ar, d, &size) == FAILURE) + { + mpz_clear (*result); + return FAILURE; + } + + mpz_mul (*result, *result, size); + mpz_clear (size); + } + + return SUCCESS; +} + + +/* Given an array expression and a dimension, figure out how many + elements it has along that dimension. Returns SUCCESS if we were + able to return a result in the 'result' variable, FAILURE + otherwise. */ + +try +gfc_array_dimen_size (gfc_expr * array, int dimen, mpz_t * result) +{ + gfc_ref *ref; + int i; + + if (dimen < 0 || array == NULL || dimen > array->rank - 1) + gfc_internal_error ("gfc_array_dimen_size(): Bad dimension"); + + switch (array->expr_type) + { + case EXPR_VARIABLE: + case EXPR_FUNCTION: + for (ref = array->ref; ref; ref = ref->next) + { + if (ref->type != REF_ARRAY) + continue; + + if (ref->u.ar.type == AR_FULL) + return spec_dimen_size (ref->u.ar.as, dimen, result); + + if (ref->u.ar.type == AR_SECTION) + { + for (i = 0; dimen >= 0; i++) + if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT) + dimen--; + + return ref_dimen_size (&ref->u.ar, i - 1, result); + } + } + + if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE) + return FAILURE; + + break; + + case EXPR_ARRAY: + if (array->shape == NULL) { + /* Expressions with rank > 1 should have "shape" properly set */ + if ( array->rank != 1 ) + gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr"); + return gfc_array_size(array, result); + } + + /* Fall through */ + default: + if (array->shape == NULL) + return FAILURE; + + mpz_init_set (*result, array->shape[dimen]); + + break; + } + + return SUCCESS; +} + + +/* Given an array expression, figure out how many elements are in the + array. Returns SUCCESS if this is possible, and sets the 'result' + variable. Otherwise returns FAILURE. */ + +try +gfc_array_size (gfc_expr * array, mpz_t * result) +{ + expand_info expand_save; + gfc_ref *ref; + int i, flag; + try t; + + switch (array->expr_type) + { + case EXPR_ARRAY: + flag = gfc_suppress_error; + gfc_suppress_error = 1; + + expand_save = current_expand; + + current_expand.count = result; + mpz_init_set_ui (*result, 0); + + current_expand.expand_work_function = count_elements; + iter_stack = NULL; + + t = expand_constructor (array->value.constructor); + gfc_suppress_error = flag; + + if (t == FAILURE) + mpz_clear (*result); + current_expand = expand_save; + return t; + + case EXPR_VARIABLE: + for (ref = array->ref; ref; ref = ref->next) + { + if (ref->type != REF_ARRAY) + continue; + + if (ref->u.ar.type == AR_FULL) + return spec_size (ref->u.ar.as, result); + + if (ref->u.ar.type == AR_SECTION) + return ref_size (&ref->u.ar, result); + } + + return spec_size (array->symtree->n.sym->as, result); + + + default: + if (array->rank == 0 || array->shape == NULL) + return FAILURE; + + mpz_init_set_ui (*result, 1); + + for (i = 0; i < array->rank; i++) + mpz_mul (*result, *result, array->shape[i]); + + break; + } + + return SUCCESS; +} + + +/* Given an array reference, return the shape of the reference in an + array of mpz_t integers. */ + +try +gfc_array_ref_shape (gfc_array_ref * ar, mpz_t * shape) +{ + int d; + int i; + + d = 0; + + switch (ar->type) + { + case AR_FULL: + for (; d < ar->as->rank; d++) + if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE) + goto cleanup; + + return SUCCESS; + + case AR_SECTION: + for (i = 0; i < ar->dimen; i++) + { + if (ar->dimen_type[i] != DIMEN_ELEMENT) + { + if (ref_dimen_size (ar, i, &shape[d]) == FAILURE) + goto cleanup; + d++; + } + } + + return SUCCESS; + + default: + break; + } + +cleanup: + for (d--; d >= 0; d--) + mpz_clear (shape[d]); + + return FAILURE; +} + + +/* Given an array expression, find the array reference structure that + characterizes the reference. */ + +gfc_array_ref * +gfc_find_array_ref (gfc_expr * e) +{ + gfc_ref *ref; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY + && (ref->u.ar.type == AR_FULL + || ref->u.ar.type == AR_SECTION)) + break; + + if (ref == NULL) + gfc_internal_error ("gfc_find_array_ref(): No ref found"); + + return &ref->u.ar; +} diff --git a/gcc/fortran/bbt.c b/gcc/fortran/bbt.c new file mode 100644 index 00000000000..5846ccd4d39 --- /dev/null +++ b/gcc/fortran/bbt.c @@ -0,0 +1,201 @@ +/* Balanced binary trees using treaps. + Copyright (C) 2000, 2002, 2003 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* The idea is to balance the tree using pseudorandom numbers. The + main constraint on this implementation is that we have several + distinct structures that have to be arranged in a binary tree. + These structures all contain a BBT_HEADER() in front that gives the + treap-related information. The key and value are assumed to reside + in the rest of the structure. + + When calling, we are also passed a comparison function that + compares two nodes. We don't implement a separate 'find' function + here, but rather use separate functions for each variety of tree. + We are also restricted to not copy treap structures, which most + implementations find convenient, because we otherwise would need to + know how long the structure is. + + This implementation is based on Stefan Nilsson's article in the + July 1997 Doctor Dobb's Journal, "Treaps in Java". */ + +#include "config.h" +#include "gfortran.h" + +typedef struct gfc_treap +{ + BBT_HEADER (gfc_treap); +} +gfc_bbt; + +/* Simple linear congruential pseudorandom number generator. The + period of this generator is 44071, which is plenty for our + purposes. */ + +static int +pseudo_random (void) +{ + static int x0 = 5341; + + x0 = (22611 * x0 + 10) % 44071; + return x0; +} + + +/* Rotate the treap left. */ + +static gfc_bbt * +rotate_left (gfc_bbt * t) +{ + gfc_bbt *temp; + + temp = t->right; + t->right = t->right->left; + temp->left = t; + + return temp; +} + + +/* Rotate the treap right. */ + +static gfc_bbt * +rotate_right (gfc_bbt * t) +{ + gfc_bbt *temp; + + temp = t->left; + t->left = t->left->right; + temp->right = t; + + return temp; +} + + +/* Recursive insertion function. Returns the updated treap, or + aborts if we find a duplicate key. */ + +static gfc_bbt * +insert (gfc_bbt * new, gfc_bbt * t, compare_fn compare) +{ + int c; + + if (t == NULL) + return new; + + c = (*compare) (new, t); + + if (c < 0) + { + t->left = insert (new, t->left, compare); + if (t->priority < t->left->priority) + t = rotate_right (t); + } + + else if (c > 0) + { + t->right = insert (new, t->right, compare); + if (t->priority < t->right->priority) + t = rotate_left (t); + } + + else /* if (c == 0) */ + gfc_internal_error("insert_bbt(): Duplicate key found!"); + + return t; +} + + +/* Given root pointer, a new node and a comparison function, insert + the new node into the treap. It is an error to insert a key that + already exists. */ + +void +gfc_insert_bbt (void *root, void *new, compare_fn compare) +{ + gfc_bbt **r, *n; + + r = (gfc_bbt **) root; + n = (gfc_bbt *) new; + + n->priority = pseudo_random (); + *r = insert (n, *r, compare); +} + +static gfc_bbt * +delete_root (gfc_bbt * t) +{ + gfc_bbt *temp; + + if (t->left == NULL) + return t->right; + if (t->right == NULL) + return t->left; + + if (t->left->priority > t->right->priority) + { + temp = rotate_right (t); + temp->right = delete_root (t); + } + else + { + temp = rotate_left (t); + temp->left = delete_root (t); + } + + return temp; +} + + +/* Delete an element from a tree. The 'old' value does not + necessarily have to point to the element to be deleted, it must + just point to a treap structure with the key to be deleted. + Returns the new root node of the tree. */ + +static gfc_bbt * +delete_treap (gfc_bbt * old, gfc_bbt * t, compare_fn compare) +{ + int c; + + if (t == NULL) + return NULL; + + c = (*compare) (old, t); + + if (c < 0) + t->left = delete_treap (old, t->left, compare); + if (c > 0) + t->right = delete_treap (old, t->right, compare); + if (c == 0) + t = delete_root (t); + + return t; +} + + +void +gfc_delete_bbt (void *root, void *old, compare_fn compare) +{ + gfc_bbt **t; + + t = (gfc_bbt **) root; + + *t = delete_treap ((gfc_bbt *) old, *t, compare); +} diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c new file mode 100644 index 00000000000..e37964df85d --- /dev/null +++ b/gcc/fortran/check.c @@ -0,0 +1,1866 @@ +/* Check functions + Copyright (C) 2002 Free Software Foundation, Inc. + Contributed by Andy Vaught & Katherine Holcomb + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +/* These functions check to see if an argument list is compatible with + a particular intrinsic function or subroutine. Presence of + required arguments has already been established, the argument list + has been sorted into the right order and has NULL arguments in the + correct places for missing optional arguments. */ + + +#include <stdlib.h> +#include <stdarg.h> + +#include "config.h" +#include "system.h" +#include "flags.h" +#include "gfortran.h" +#include "intrinsic.h" + + +/* The fundamental complaint function of this source file. This + function can be called in all kinds of ways. */ + +static void +must_be (gfc_expr * e, int n, const char *thing) +{ + + gfc_error ("'%s' argument of '%s' intrinsic at %L must be %s", + gfc_current_intrinsic_arg[n], gfc_current_intrinsic, &e->where, + thing); +} + + +/* Check the type of an expression. */ + +static try +type_check (gfc_expr * e, int n, bt type) +{ + + if (e->ts.type == type) + return SUCCESS; + + must_be (e, n, gfc_basic_typename (type)); + + return FAILURE; +} + + +/* Check that the expression is a numeric type. */ + +static try +numeric_check (gfc_expr * e, int n) +{ + + if (gfc_numeric_ts (&e->ts)) + return SUCCESS; + + must_be (e, n, "a numeric type"); + + return FAILURE; +} + + +/* Check that an expression is integer or real. */ + +static try +int_or_real_check (gfc_expr * e, int n) +{ + + if (e->ts.type != BT_INTEGER && e->ts.type != BT_REAL) + { + must_be (e, n, "INTEGER or REAL"); + return FAILURE; + } + + return SUCCESS; +} + + +/* Check that the expression is an optional constant integer + and that it specifies a valid kind for that type. */ + +static try +kind_check (gfc_expr * k, int n, bt type) +{ + int kind; + + if (k == NULL) + return SUCCESS; + + if (type_check (k, n, BT_INTEGER) == FAILURE) + return FAILURE; + + if (k->expr_type != EXPR_CONSTANT) + { + must_be (k, n, "a constant"); + return FAILURE; + } + + if (gfc_extract_int (k, &kind) != NULL + || gfc_validate_kind (type, kind) == -1) + { + gfc_error ("Invalid kind for %s at %L", gfc_basic_typename (type), + &k->where); + return FAILURE; + } + + return SUCCESS; +} + + +/* Make sure the expression is a double precision real. */ + +static try +double_check (gfc_expr * d, int n) +{ + + if (type_check (d, n, BT_REAL) == FAILURE) + return FAILURE; + + if (d->ts.kind != gfc_default_double_kind ()) + { + must_be (d, n, "double precision"); + return FAILURE; + } + + return SUCCESS; +} + + +/* Make sure the expression is a logical array. */ + +static try +logical_array_check (gfc_expr * array, int n) +{ + + if (array->ts.type != BT_LOGICAL || array->rank == 0) + { + must_be (array, n, "a logical array"); + return FAILURE; + } + + return SUCCESS; +} + + +/* Make sure an expression is an array. */ + +static try +array_check (gfc_expr * e, int n) +{ + + if (e->rank != 0) + return SUCCESS; + + must_be (e, n, "an array"); + + return FAILURE; +} + + +/* Make sure an expression is a scalar. */ + +static try +scalar_check (gfc_expr * e, int n) +{ + + if (e->rank == 0) + return SUCCESS; + + must_be (e, n, "a scalar"); + + return FAILURE; +} + + +/* Make sure two expression have the same type. */ + +static try +same_type_check (gfc_expr * e, int n, gfc_expr * f, int m) +{ + char message[100]; + + if (gfc_compare_types (&e->ts, &f->ts)) + return SUCCESS; + + sprintf (message, "the same type and kind as '%s'", + gfc_current_intrinsic_arg[n]); + + must_be (f, m, message); + + return FAILURE; +} + + +/* Make sure that an expression has a certain (nonzero) rank. */ + +static try +rank_check (gfc_expr * e, int n, int rank) +{ + char message[100]; + + if (e->rank == rank) + return SUCCESS; + + sprintf (message, "of rank %d", rank); + + must_be (e, n, message); + + return FAILURE; +} + + +/* Make sure a variable expression is not an optional dummy argument. */ + +static try +nonoptional_check (gfc_expr * e, int n) +{ + + if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must not be OPTIONAL", + gfc_current_intrinsic_arg[n], gfc_current_intrinsic, + &e->where); + + } + + /* TODO: Recursive check on nonoptional variables? */ + + return SUCCESS; +} + + +/* Check that an expression has a particular kind. */ + +static try +kind_value_check (gfc_expr * e, int n, int k) +{ + char message[100]; + + if (e->ts.kind == k) + return SUCCESS; + + sprintf (message, "of kind %d", k); + + must_be (e, n, message); + return FAILURE; +} + + +/* Make sure an expression is a variable. */ + +static try +variable_check (gfc_expr * e, int n) +{ + + if ((e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.flavor != FL_PARAMETER) + || (e->expr_type == EXPR_FUNCTION + && e->symtree->n.sym->result == e->symtree->n.sym)) + return SUCCESS; + + if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.intent == INTENT_IN) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)", + gfc_current_intrinsic_arg[n], gfc_current_intrinsic, + &e->where); + return FAILURE; + } + + must_be (e, n, "a variable"); + + return FAILURE; +} + + +/* Check the common DIM parameter for correctness. */ + +static try +dim_check (gfc_expr * dim, int n, int optional) +{ + + if (optional) + { + if (dim == NULL) + return SUCCESS; + + if (nonoptional_check (dim, n) == FAILURE) + return FAILURE; + + return SUCCESS; + } + + if (dim == NULL) + { + gfc_error ("Missing DIM parameter in intrinsic '%s' at %L", + gfc_current_intrinsic, gfc_current_intrinsic_where); + return FAILURE; + } + + if (type_check (dim, n, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (dim, n) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/* If a DIM parameter is a constant, make sure that it is greater than + zero and less than or equal to the rank of the given array. If + allow_assumed is zero then dim must be less than the rank of the array + for assumed size arrays. */ + +static try +dim_rank_check (gfc_expr * dim, gfc_expr * array, int allow_assumed) +{ + gfc_array_ref *ar; + int rank; + + if (dim->expr_type != EXPR_CONSTANT || array->expr_type != EXPR_VARIABLE) + return SUCCESS; + + ar = gfc_find_array_ref (array); + rank = array->rank; + if (ar->as->type == AS_ASSUMED_SIZE && !allow_assumed) + rank--; + + if (mpz_cmp_ui (dim->value.integer, 1) < 0 + || mpz_cmp_ui (dim->value.integer, rank) > 0) + { + gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid " + "dimension index", gfc_current_intrinsic, &dim->where); + + return FAILURE; + } + + return SUCCESS; +} + + +/***** Check functions *****/ + +/* Check subroutine suitable for intrinsics taking a real argument and + a kind argument for the result. */ + +static try +check_a_kind (gfc_expr * a, gfc_expr * kind, bt type) +{ + + if (type_check (a, 0, BT_REAL) == FAILURE) + return FAILURE; + if (kind_check (kind, 1, type) == FAILURE) + return FAILURE; + + return SUCCESS; +} + +/* Check subroutine suitable for ceiling, floor and nint. */ + +try +gfc_check_a_ikind (gfc_expr * a, gfc_expr * kind) +{ + + return check_a_kind (a, kind, BT_INTEGER); +} + +/* Check subroutine suitable for aint, anint. */ + +try +gfc_check_a_xkind (gfc_expr * a, gfc_expr * kind) +{ + + return check_a_kind (a, kind, BT_REAL); +} + +try +gfc_check_abs (gfc_expr * a) +{ + + if (numeric_check (a, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_all_any (gfc_expr * mask, gfc_expr * dim) +{ + + if (logical_array_check (mask, 0) == FAILURE) + return FAILURE; + + if (dim_check (dim, 1, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_allocated (gfc_expr * array) +{ + + if (variable_check (array, 0) == FAILURE) + return FAILURE; + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (!array->symtree->n.sym->attr.allocatable) + { + must_be (array, 0, "ALLOCATABLE"); + return FAILURE; + } + + return SUCCESS; +} + + +/* Common check function where the first argument must be real or + integer and the second argument must be the same as the first. */ + +try +gfc_check_a_p (gfc_expr * a, gfc_expr * p) +{ + + if (int_or_real_check (a, 0) == FAILURE) + return FAILURE; + + if (same_type_check (a, 0, p, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_associated (gfc_expr * pointer, gfc_expr * target) +{ + symbol_attribute attr; + int i; + try t; + + if (variable_check (pointer, 0) == FAILURE) + return FAILURE; + + attr = gfc_variable_attr (pointer, NULL); + if (!attr.pointer) + { + must_be (pointer, 0, "a POINTER"); + return FAILURE; + } + + if (target == NULL) + return SUCCESS; + + /* Target argument is optional. */ + if (target->expr_type == EXPR_NULL) + { + gfc_error ("NULL pointer at %L is not permitted as actual argument " + "of '%s' intrinsic function", + &target->where, gfc_current_intrinsic); + return FAILURE; + } + + attr = gfc_variable_attr (target, NULL); + if (!attr.pointer && !attr.target) + { + must_be (target, 1, "a POINTER or a TARGET"); + return FAILURE; + } + + t = SUCCESS; + if (same_type_check (pointer, 0, target, 1) == FAILURE) + t = FAILURE; + if (rank_check (target, 0, pointer->rank) == FAILURE) + t = FAILURE; + if (target->rank > 0) + { + for (i = 0; i < target->rank; i++) + if (target->ref->u.ar.dimen_type[i] == DIMEN_VECTOR) + { + gfc_error ("Array section with a vector subscript at %L shall not " + "be the target of an pointer", + &target->where); + t = FAILURE; + break; + } + } + return t; +} + + +try +gfc_check_btest (gfc_expr * i, gfc_expr * pos) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; + if (type_check (pos, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_char (gfc_expr * i, gfc_expr * kind) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; + if (kind_check (kind, 1, BT_CHARACTER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind) +{ + + if (numeric_check (x, 0) == FAILURE) + return FAILURE; + + if (y != NULL) + { + if (numeric_check (y, 1) == FAILURE) + return FAILURE; + + if (x->ts.type == BT_COMPLEX) + { + must_be (y, 1, "not be present if 'x' is COMPLEX"); + return FAILURE; + } + } + + if (kind_check (kind, 2, BT_COMPLEX) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_count (gfc_expr * mask, gfc_expr * dim) +{ + + if (logical_array_check (mask, 0) == FAILURE) + return FAILURE; + if (dim_check (dim, 1, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_cshift (gfc_expr * array, gfc_expr * shift, gfc_expr * dim) +{ + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (array->rank == 1) + { + if (scalar_check (shift, 1) == FAILURE) + return FAILURE; + } + else + { + /* TODO: more requirements on shift parameter. */ + } + + if (dim_check (dim, 2, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_dcmplx (gfc_expr * x, gfc_expr * y) +{ + + if (numeric_check (x, 0) == FAILURE) + return FAILURE; + + if (y != NULL) + { + if (numeric_check (y, 1) == FAILURE) + return FAILURE; + + if (x->ts.type == BT_COMPLEX) + { + must_be (y, 1, "not be present if 'x' is COMPLEX"); + return FAILURE; + } + } + + return SUCCESS; +} + + +try +gfc_check_dble (gfc_expr * x) +{ + + if (numeric_check (x, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_digits (gfc_expr * x) +{ + + if (int_or_real_check (x, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b) +{ + + switch (vector_a->ts.type) + { + case BT_LOGICAL: + if (type_check (vector_b, 1, BT_LOGICAL) == FAILURE) + return FAILURE; + break; + + case BT_INTEGER: + case BT_REAL: + case BT_COMPLEX: + if (numeric_check (vector_b, 1) == FAILURE) + return FAILURE; + break; + + default: + must_be (vector_a, 0, "numeric or LOGICAL"); + return FAILURE; + } + + if (rank_check (vector_a, 0, 1) == FAILURE) + return FAILURE; + + if (rank_check (vector_b, 1, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_eoshift (gfc_expr * array, gfc_expr * shift, gfc_expr * boundary, + gfc_expr * dim) +{ + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (type_check (shift, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (array->rank == 1) + { + if (scalar_check (shift, 2) == FAILURE) + return FAILURE; + } + else + { + /* TODO: more weird restrictions on shift. */ + } + + if (boundary != NULL) + { + if (same_type_check (array, 0, boundary, 2) == FAILURE) + return FAILURE; + + /* TODO: more restrictions on boundary. */ + } + + if (dim_check (dim, 1, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + + +try +gfc_check_huge (gfc_expr * x) +{ + + if (int_or_real_check (x, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/* Check that the single argument is an integer. */ + +try +gfc_check_i (gfc_expr * i) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_iand (gfc_expr * i, gfc_expr * j) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE + || type_check (j, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (same_type_check (i, 0, j, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_ibclr (gfc_expr * i, gfc_expr * pos) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE + || type_check (pos, 1, BT_INTEGER) == FAILURE + || kind_value_check (pos, 1, gfc_default_integer_kind ()) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_ibits (gfc_expr * i, gfc_expr * pos, gfc_expr * len) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE + || type_check (pos, 1, BT_INTEGER) == FAILURE + || kind_value_check (pos, 1, gfc_default_integer_kind ()) == FAILURE + || type_check (len, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_ibset (gfc_expr * i, gfc_expr * pos) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE + || type_check (pos, 1, BT_INTEGER) == FAILURE + || kind_value_check (pos, 1, gfc_default_integer_kind ()) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_idnint (gfc_expr * a) +{ + + if (double_check (a, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_ieor (gfc_expr * i, gfc_expr * j) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE + || type_check (j, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (same_type_check (i, 0, j, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_index (gfc_expr * string, gfc_expr * substring, gfc_expr * back) +{ + + if (type_check (string, 0, BT_CHARACTER) == FAILURE + || type_check (substring, 1, BT_CHARACTER) == FAILURE) + return FAILURE; + + + if (back != NULL && type_check (back, 2, BT_LOGICAL) == FAILURE) + return FAILURE; + + if (string->ts.kind != substring->ts.kind) + { + must_be (substring, 1, "the same kind as 'string'"); + return FAILURE; + } + + return SUCCESS; +} + + +try +gfc_check_int (gfc_expr * x, gfc_expr * kind) +{ + + if (numeric_check (x, 0) == FAILURE + || kind_check (kind, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_ior (gfc_expr * i, gfc_expr * j) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE + || type_check (j, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (same_type_check (i, 0, j, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_ishft (gfc_expr * i, gfc_expr * shift) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE + || type_check (shift, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size) +{ + + if (type_check (i, 0, BT_INTEGER) == FAILURE + || type_check (shift, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (size != NULL && type_check (size, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_kind (gfc_expr * x) +{ + + if (x->ts.type == BT_DERIVED) + { + must_be (x, 0, "a non-derived type"); + return FAILURE; + } + + return SUCCESS; +} + + +try +gfc_check_lbound (gfc_expr * array, gfc_expr * dim) +{ + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (dim != NULL) + { + if (dim_check (dim, 1, 1) == FAILURE) + return FAILURE; + + if (dim_rank_check (dim, array, 1) == FAILURE) + return FAILURE; + } + return SUCCESS; +} + + +try +gfc_check_logical (gfc_expr * a, gfc_expr * kind) +{ + + if (type_check (a, 0, BT_LOGICAL) == FAILURE) + return FAILURE; + if (kind_check (kind, 1, BT_LOGICAL) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/* Min/max family. */ + +static try +min_max_args (gfc_actual_arglist * arg) +{ + + if (arg == NULL || arg->next == NULL) + { + gfc_error ("Intrinsic '%s' at %L must have at least two arguments", + gfc_current_intrinsic, gfc_current_intrinsic_where); + return FAILURE; + } + + return SUCCESS; +} + + +static try +check_rest (bt type, int kind, gfc_actual_arglist * arg) +{ + gfc_expr *x; + int n; + + if (min_max_args (arg) == FAILURE) + return FAILURE; + + n = 1; + + for (; arg; arg = arg->next, n++) + { + x = arg->expr; + if (x->ts.type != type || x->ts.kind != kind) + { + if (x->ts.type == type) + { + if (gfc_notify_std (GFC_STD_GNU, + "Extension: Different type kinds at %L", &x->where) + == FAILURE) + return FAILURE; + } + else + { + gfc_error ("'a%d' argument of '%s' intrinsic at %L must be %s(%d)", + n, gfc_current_intrinsic, &x->where, + gfc_basic_typename (type), kind); + return FAILURE; + } + } + } + + return SUCCESS; +} + + +try +gfc_check_min_max (gfc_actual_arglist * arg) +{ + gfc_expr *x; + + if (min_max_args (arg) == FAILURE) + return FAILURE; + + x = arg->expr; + + if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL) + { + gfc_error + ("'a1' argument of '%s' intrinsic at %L must be INTEGER or REAL", + gfc_current_intrinsic, &x->where); + return FAILURE; + } + + return check_rest (x->ts.type, x->ts.kind, arg); +} + + +try +gfc_check_min_max_integer (gfc_actual_arglist * arg) +{ + + return check_rest (BT_INTEGER, gfc_default_integer_kind (), arg); +} + + +try +gfc_check_min_max_real (gfc_actual_arglist * arg) +{ + + return check_rest (BT_REAL, gfc_default_real_kind (), arg); +} + + +try +gfc_check_min_max_double (gfc_actual_arglist * arg) +{ + + return check_rest (BT_REAL, gfc_default_double_kind (), arg); +} + +/* End of min/max family. */ + + +try +gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b) +{ + + if ((matrix_a->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_b->ts)) + { + must_be (matrix_a, 0, "numeric or LOGICAL"); + return FAILURE; + } + + if ((matrix_b->ts.type != BT_LOGICAL) && !gfc_numeric_ts (&matrix_a->ts)) + { + must_be (matrix_b, 0, "numeric or LOGICAL"); + return FAILURE; + } + + switch (matrix_a->rank) + { + case 1: + if (rank_check (matrix_b, 1, 2) == FAILURE) + return FAILURE; + break; + + case 2: + if (matrix_b->rank == 2) + break; + if (rank_check (matrix_b, 1, 1) == FAILURE) + return FAILURE; + break; + + default: + must_be (matrix_a, 0, "of rank 1 or 2"); + return FAILURE; + } + + return SUCCESS; +} + + +/* Whoever came up with this interface was probably on something. + The possibilities for the occupation of the second and third + parameters are: + + Arg #2 Arg #3 + NULL NULL + DIM NULL + MASK NULL + NULL MASK minloc(array, mask=m) + DIM MASK +*/ + +try +gfc_check_minloc_maxloc (gfc_expr * array, gfc_expr * a2, gfc_expr * a3) +{ + + if (int_or_real_check (array, 0) == FAILURE) + return FAILURE; + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (a3 != NULL) + { + if (logical_array_check (a3, 2) == FAILURE) + return FAILURE; + + if (a2 != NULL) + { + if (scalar_check (a2, 1) == FAILURE) + return FAILURE; + if (type_check (a2, 1, BT_INTEGER) == FAILURE) + return FAILURE; + } + } + else + { + if (a2 != NULL) + { + switch (a2->ts.type) + { + case BT_INTEGER: + if (scalar_check (a2, 1) == FAILURE) + return FAILURE; + break; + + case BT_LOGICAL: /* The '2' makes the error message correct */ + if (logical_array_check (a2, 2) == FAILURE) + return FAILURE; + break; + + default: + type_check (a2, 1, BT_INTEGER); /* Guaranteed to fail */ + return FAILURE; + } + } + } + + return SUCCESS; +} + + +try +gfc_check_minval_maxval (gfc_expr * array, gfc_expr * dim, gfc_expr * mask) +{ + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (int_or_real_check (array, 0) == FAILURE) + return FAILURE; + + if (dim_check (dim, 1, 1) == FAILURE) + return FAILURE; + + if (mask != NULL && logical_array_check (mask, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask) +{ + + if (same_type_check (tsource, 0, fsource, 1) == FAILURE) + return FAILURE; + + if (type_check (mask, 2, BT_LOGICAL) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_nearest (gfc_expr * x, gfc_expr * s) +{ + + if (type_check (x, 0, BT_REAL) == FAILURE) + return FAILURE; + + if (type_check (s, 1, BT_REAL) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_null (gfc_expr * mold) +{ + symbol_attribute attr; + + if (mold == NULL) + return SUCCESS; + + if (variable_check (mold, 0) == FAILURE) + return FAILURE; + + attr = gfc_variable_attr (mold, NULL); + + if (!attr.pointer) + { + must_be (mold, 0, "a POINTER"); + return FAILURE; + } + + return SUCCESS; +} + + +try +gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector) +{ + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (type_check (mask, 1, BT_LOGICAL) == FAILURE) + return FAILURE; + + if (mask->rank != 0 && mask->rank != array->rank) + { + must_be (array, 0, "conformable with 'mask' argument"); + return FAILURE; + } + + if (vector != NULL) + { + if (same_type_check (array, 0, vector, 2) == FAILURE) + return FAILURE; + + if (rank_check (vector, 2, 1) == FAILURE) + return FAILURE; + + /* TODO: More constraints here. */ + } + + return SUCCESS; +} + + +try +gfc_check_precision (gfc_expr * x) +{ + + if (x->ts.type != BT_REAL && x->ts.type != BT_COMPLEX) + { + must_be (x, 0, "of type REAL or COMPLEX"); + return FAILURE; + } + + return SUCCESS; +} + + +try +gfc_check_present (gfc_expr * a) +{ + gfc_symbol *sym; + + if (variable_check (a, 0) == FAILURE) + return FAILURE; + + sym = a->symtree->n.sym; + if (!sym->attr.dummy) + { + must_be (a, 0, "a dummy variable"); + return FAILURE; + } + + if (!sym->attr.optional) + { + must_be (a, 0, "an OPTIONAL dummy variable"); + return FAILURE; + } + + return SUCCESS; +} + + +try +gfc_check_product (gfc_expr * array, gfc_expr * dim, gfc_expr * mask) +{ + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (numeric_check (array, 0) == FAILURE) + return FAILURE; + + if (dim_check (dim, 1, 1) == FAILURE) + return FAILURE; + + if (mask != NULL && logical_array_check (mask, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_radix (gfc_expr * x) +{ + + if (int_or_real_check (x, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_range (gfc_expr * x) +{ + + if (numeric_check (x, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/* real, float, sngl. */ +try +gfc_check_real (gfc_expr * a, gfc_expr * kind) +{ + + if (numeric_check (a, 0) == FAILURE) + return FAILURE; + + if (kind_check (kind, 1, BT_REAL) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_repeat (gfc_expr * x, gfc_expr * y) +{ + + if (type_check (x, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (scalar_check (x, 0) == FAILURE) + return FAILURE; + + if (type_check (y, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (y, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_reshape (gfc_expr * source, gfc_expr * shape, + gfc_expr * pad, gfc_expr * order) +{ + mpz_t size; + int m; + + if (array_check (source, 0) == FAILURE) + return FAILURE; + + if (rank_check (shape, 1, 1) == FAILURE) + return FAILURE; + + if (type_check (shape, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (gfc_array_size (shape, &size) != SUCCESS) + { + gfc_error ("'shape' argument of 'reshape' intrinsic at %L must be an " + "array of constant size", &shape->where); + return FAILURE; + } + + m = mpz_cmp_ui (size, GFC_MAX_DIMENSIONS); + mpz_clear (size); + + if (m > 0) + { + gfc_error + ("'shape' argument of 'reshape' intrinsic at %L has more than " + stringize (GFC_MAX_DIMENSIONS) " elements", &shape->where); + return FAILURE; + } + + if (pad != NULL) + { + if (same_type_check (source, 0, pad, 2) == FAILURE) + return FAILURE; + if (array_check (pad, 2) == FAILURE) + return FAILURE; + } + + if (order != NULL && array_check (order, 3) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_scale (gfc_expr * x, gfc_expr * i) +{ + + if (type_check (x, 0, BT_REAL) == FAILURE) + return FAILURE; + + if (type_check (i, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_scan (gfc_expr * x, gfc_expr * y, gfc_expr * z) +{ + + if (type_check (x, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (type_check (y, 1, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE) + return FAILURE; + + if (same_type_check (x, 0, y, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_selected_real_kind (gfc_expr * p, gfc_expr * r) +{ + + if (p == NULL && r == NULL) + { + gfc_error ("Missing arguments to %s intrinsic at %L", + gfc_current_intrinsic, gfc_current_intrinsic_where); + + return FAILURE; + } + + if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_set_exponent (gfc_expr * x, gfc_expr * i) +{ + + if (type_check (x, 0, BT_REAL) == FAILURE) + return FAILURE; + + if (type_check (i, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_shape (gfc_expr * source) +{ + gfc_array_ref *ar; + + if (source->rank == 0 || source->expr_type != EXPR_VARIABLE) + return SUCCESS; + + ar = gfc_find_array_ref (source); + + if (ar->as && ar->as->type == AS_ASSUMED_SIZE) + { + gfc_error ("'source' argument of 'shape' intrinsic at %L must not be " + "an assumed size array", &source->where); + return FAILURE; + } + + return SUCCESS; +} + + +try +gfc_check_size (gfc_expr * array, gfc_expr * dim) +{ + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (dim != NULL) + { + if (type_check (dim, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (kind_value_check (dim, 1, gfc_default_integer_kind ()) == FAILURE) + return FAILURE; + + if (dim_rank_check (dim, array, 0) == FAILURE) + return FAILURE; + } + + return SUCCESS; +} + + +try +gfc_check_sign (gfc_expr * a, gfc_expr * b) +{ + + if (int_or_real_check (a, 0) == FAILURE) + return FAILURE; + + if (same_type_check (a, 0, b, 1) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies) +{ + + if (source->rank >= GFC_MAX_DIMENSIONS) + { + must_be (source, 0, "less than rank " stringize (GFC_MAX_DIMENSIONS)); + return FAILURE; + } + + if (dim_check (dim, 1, 0) == FAILURE) + return FAILURE; + + if (type_check (ncopies, 2, BT_INTEGER) == FAILURE) + return FAILURE; + if (scalar_check (ncopies, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_sum (gfc_expr * array, gfc_expr * dim, gfc_expr * mask) +{ + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (numeric_check (array, 0) == FAILURE) + return FAILURE; + + if (dim_check (dim, 1, 1) == FAILURE) + return FAILURE; + + if (mask != NULL && logical_array_check (mask, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_transfer (gfc_expr * source ATTRIBUTE_UNUSED, + gfc_expr * mold ATTRIBUTE_UNUSED, + gfc_expr * size) +{ + + if (size != NULL) + { + if (type_check (size, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (size, 2) == FAILURE) + return FAILURE; + + if (nonoptional_check (size, 2) == FAILURE) + return FAILURE; + } + + return SUCCESS; +} + + +try +gfc_check_transpose (gfc_expr * matrix) +{ + + if (rank_check (matrix, 0, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_ubound (gfc_expr * array, gfc_expr * dim) +{ + + if (array_check (array, 0) == FAILURE) + return FAILURE; + + if (dim != NULL) + { + if (dim_check (dim, 1, 1) == FAILURE) + return FAILURE; + + if (dim_rank_check (dim, array, 0) == FAILURE) + return FAILURE; + } + return SUCCESS; +} + + +try +gfc_check_unpack (gfc_expr * vector, gfc_expr * mask, gfc_expr * field) +{ + + if (rank_check (vector, 0, 1) == FAILURE) + return FAILURE; + + if (array_check (mask, 1) == FAILURE) + return FAILURE; + + if (type_check (mask, 1, BT_LOGICAL) == FAILURE) + return FAILURE; + + if (same_type_check (vector, 0, field, 2) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_verify (gfc_expr * x, gfc_expr * y, gfc_expr * z) +{ + + if (type_check (x, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (same_type_check (x, 0, y, 1) == FAILURE) + return FAILURE; + + if (z != NULL && type_check (z, 2, BT_LOGICAL) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_trim (gfc_expr * x) +{ + if (type_check (x, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + + if (scalar_check (x, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/* Common check function for the half a dozen intrinsics that have a + single real argument. */ + +try +gfc_check_x (gfc_expr * x) +{ + + if (type_check (x, 0, BT_REAL) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/************* Check functions for intrinsic subroutines *************/ + +try +gfc_check_cpu_time (gfc_expr * time) +{ + + if (scalar_check (time, 0) == FAILURE) + return FAILURE; + + if (type_check (time, 0, BT_REAL) == FAILURE) + return FAILURE; + + if (variable_check (time, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_date_and_time (gfc_expr * date, gfc_expr * time, + gfc_expr * zone, gfc_expr * values) +{ + + if (date != NULL) + { + if (type_check (date, 0, BT_CHARACTER) == FAILURE) + return FAILURE; + if (scalar_check (date, 0) == FAILURE) + return FAILURE; + if (variable_check (date, 0) == FAILURE) + return FAILURE; + } + + if (time != NULL) + { + if (type_check (time, 1, BT_CHARACTER) == FAILURE) + return FAILURE; + if (scalar_check (time, 1) == FAILURE) + return FAILURE; + if (variable_check (time, 1) == FAILURE) + return FAILURE; + } + + if (zone != NULL) + { + if (type_check (zone, 2, BT_CHARACTER) == FAILURE) + return FAILURE; + if (scalar_check (zone, 2) == FAILURE) + return FAILURE; + if (variable_check (zone, 2) == FAILURE) + return FAILURE; + } + + if (values != NULL) + { + if (type_check (values, 3, BT_INTEGER) == FAILURE) + return FAILURE; + if (array_check (values, 3) == FAILURE) + return FAILURE; + if (rank_check (values, 3, 1) == FAILURE) + return FAILURE; + if (variable_check (values, 3) == FAILURE) + return FAILURE; + } + + return SUCCESS; +} + + +try +gfc_check_mvbits (gfc_expr * from, gfc_expr * frompos, gfc_expr * len, + gfc_expr * to, gfc_expr * topos) +{ + + if (type_check (from, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (type_check (frompos, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (type_check (len, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + if (same_type_check (from, 0, to, 3) == FAILURE) + return FAILURE; + + if (variable_check (to, 3) == FAILURE) + return FAILURE; + + if (type_check (topos, 4, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_random_number (gfc_expr * harvest) +{ + + if (type_check (harvest, 0, BT_REAL) == FAILURE) + return FAILURE; + + if (variable_check (harvest, 0) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +try +gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get) +{ + + if (size != NULL) + { + if (scalar_check (size, 0) == FAILURE) + return FAILURE; + + if (type_check (size, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if (variable_check (size, 0) == FAILURE) + return FAILURE; + + if (kind_value_check (size, 0, gfc_default_integer_kind ()) == FAILURE) + return FAILURE; + } + + if (put != NULL) + { + if (array_check (put, 1) == FAILURE) + return FAILURE; + if (rank_check (put, 1, 1) == FAILURE) + return FAILURE; + + if (type_check (put, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (kind_value_check (put, 1, gfc_default_integer_kind ()) == FAILURE) + return FAILURE; + } + + if (get != NULL) + { + if (array_check (get, 2) == FAILURE) + return FAILURE; + if (rank_check (get, 2, 1) == FAILURE) + return FAILURE; + + if (type_check (get, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + if (variable_check (get, 2) == FAILURE) + return FAILURE; + + if (kind_value_check (get, 2, gfc_default_integer_kind ()) == FAILURE) + return FAILURE; + } + + return SUCCESS; +} diff --git a/gcc/fortran/config-lang.in b/gcc/fortran/config-lang.in new file mode 100644 index 00000000000..c638dcbaf48 --- /dev/null +++ b/gcc/fortran/config-lang.in @@ -0,0 +1,22 @@ +# Configure looks for the existence of this file to auto-config each language. +# We define several parameters used by configure: +# +# language - name of language as it would appear in $(LANGUAGES) +# compilers - value to add to $(COMPILERS) +# stagestuff - files to add to $(STAGESTUFF) +# diff_excludes - files to ignore when building diffs between two versions. + +language="f95" + +compilers="f951\$(exeext)" + +stagestuff="gfortran\$(exeext) f951\$(exeext)" + +target_libs=target-libgfortran + +gtfiles="\$(srcdir)/fortran/f95-lang.c \$(srcdir)/fortran/trans-decl.c \$(srcdir)/fortran/trans-intrinsic.c \$(srcdir)/fortran/trans-io.c \$(srcdir)/fortran/trans-types.c \$(srcdir)/fortran/trans-types.h \$(srcdir)/fortran/trans.h \$(srcdir)/fortran/trans-const.h" + +need_gmp="yes" + +#outputs=g95/Makefile + diff --git a/gcc/fortran/convert.c b/gcc/fortran/convert.c new file mode 100644 index 00000000000..9759f057f50 --- /dev/null +++ b/gcc/fortran/convert.c @@ -0,0 +1,124 @@ +/* Language-level data type conversion for GNU C. + Copyright (C) 1987, 1988, 1991, 1998, 2002 Free Software Foundation, Inc. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 2, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING. If not, write to the Free +Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. */ + + +/* This file contains the functions for converting C expressions + to different data types. The only entry point is `convert'. + Every language front end must have a `convert' function + but what kind of conversions it does will depend on the language. */ + +/* copied from the f77 frontend I think */ + +/* copied from c-convert.c without significant modification*/ +/* Change of width--truncation and extension of integers or reals-- + is represented with NOP_EXPR. Proper functioning of many things + assumes that no other conversions can be NOP_EXPRs. +*/ + +/* I've added support for WITH_RECORD_EXPR. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "flags.h" +#include "convert.h" +#include "toplev.h" +#include "gfortran.h" +#include "trans.h" + +/* + Conversion between integer and pointer is represented with CONVERT_EXPR. + Converting integer to real uses FLOAT_EXPR + and real to integer uses FIX_TRUNC_EXPR. + + Here is a list of all the functions that assume that widening and + narrowing is always done with a NOP_EXPR: + In convert.c, convert_to_integer. + In c-typeck.c, build_binary_op (boolean ops), and + c_common_truthvalue_conversion. + In expr.c: expand_expr, for operands of a MULT_EXPR. + In fold-const.c: fold. + In tree.c: get_narrower and get_unwidened. */ + +/* Subroutines of `convert'. */ + + + +/* Create an expression whose value is that of EXPR, + converted to type TYPE. The TREE_TYPE of the value + is always TYPE. This function implements all reasonable + conversions; callers should filter out those that are + not permitted by the language being compiled. */ +/* We are assuming that given a SIMPLE val, the result will be a SIMPLE rhs. + If this is not the case, we will abort with an internal error. */ +tree +convert (tree type, tree expr) +{ + tree e = expr; + enum tree_code code = TREE_CODE (type); + + if (type == TREE_TYPE (expr) + || TREE_CODE (expr) == ERROR_MARK + || code == ERROR_MARK || TREE_CODE (TREE_TYPE (expr)) == ERROR_MARK) + return expr; + + if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (expr))) + return fold (build1 (NOP_EXPR, type, expr)); + if (TREE_CODE (TREE_TYPE (expr)) == ERROR_MARK) + return error_mark_node; + if (TREE_CODE (TREE_TYPE (expr)) == VOID_TYPE) + { + error ("void value not ignored as it ought to be"); + return error_mark_node; + } + if (code == VOID_TYPE) + return build1 (CONVERT_EXPR, type, e); +#if 0 + /* This is incorrect. A truncation can't be stripped this way. + Extensions will be stripped by the use of get_unwidened. */ + if (TREE_CODE (expr) == NOP_EXPR) + return convert (type, TREE_OPERAND (expr, 0)); +#endif + if (code == INTEGER_TYPE || code == ENUMERAL_TYPE) + return fold (convert_to_integer (type, e)); + if (code == BOOLEAN_TYPE) + { + e = gfc_truthvalue_conversion (e); + + /* If we have a NOP_EXPR, we must fold it here to avoid + infinite recursion between fold () and convert (). */ + if (TREE_CODE (e) == NOP_EXPR) + return fold (build1 (NOP_EXPR, type, TREE_OPERAND (e, 0))); + else + return fold (build1 (NOP_EXPR, type, e)); + } + if (code == POINTER_TYPE || code == REFERENCE_TYPE) + return fold (convert_to_pointer (type, e)); + if (code == REAL_TYPE) + return fold (convert_to_real (type, e)); + if (code == COMPLEX_TYPE) + return fold (convert_to_complex (type, e)); + if (code == VECTOR_TYPE) + return fold (convert_to_vector (type, e)); + + error ("conversion to non-scalar type requested"); + return error_mark_node; +} diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c new file mode 100644 index 00000000000..7977b335836 --- /dev/null +++ b/gcc/fortran/data.c @@ -0,0 +1,457 @@ +/* Supporting functions for resolving DATA statement. + Copyright (C) 2002, 2003 Free Software Foundation, Inc. + Contributed by Lifang Zeng <zlf605@hotmail.com> + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +/* Notes for DATA statement implementation: + + We first assign initial value to each symbol by gfc_assign_data_value + during resolveing DATA statement. Refer to check_data_variable and + traverse_data_list in resolve.c. + + The complexity exists in the handleing of array section, implied do + and array of struct appeared in DATA statement. + + We call gfc_conv_structure, gfc_con_array_array_initializer, + etc., to convert the initial value. Refer to trans-expr.c and + trans-array.c. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "toplev.h" +#include "gfortran.h" +#include "assert.h" +#include "trans.h" + +static void formalize_init_expr (gfc_expr *); + +/* Calculate the array element offset. */ + +static void +get_array_index (gfc_array_ref * ar, mpz_t * offset) +{ + gfc_expr *e; + int i; + try re; + mpz_t delta; + mpz_t tmp; + + mpz_init (tmp); + mpz_set_si (*offset, 0); + mpz_init_set_si (delta, 1); + for (i = 0; i < ar->dimen; i++) + { + e = gfc_copy_expr (ar->start[i]); + re = gfc_simplify_expr (e, 1); + + if ((gfc_is_constant_expr (ar->as->lower[i]) == 0) + || (gfc_is_constant_expr (ar->as->upper[i]) == 0) + || (gfc_is_constant_expr (e) == 0)) + gfc_error ("non-constant array in DATA statement %L.", &ar->where); + mpz_set (tmp, e->value.integer); + mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer); + mpz_mul (tmp, tmp, delta); + mpz_add (*offset, tmp, *offset); + + mpz_sub (tmp, ar->as->upper[i]->value.integer, + ar->as->lower[i]->value.integer); + mpz_add_ui (tmp, tmp, 1); + mpz_mul (delta, tmp, delta); + } + mpz_clear (delta); + mpz_clear (tmp); +} + + +/* Find if there is a constructor which offset is equal to OFFSET. */ + +static gfc_constructor * +find_con_by_offset (mpz_t offset, gfc_constructor *con) +{ + for (; con; con = con->next) + { + if (mpz_cmp (offset, con->n.offset) == 0) + return con; + } + return NULL; +} + + +/* Find if there is a constructor which component is equal to COM. */ + +static gfc_constructor * +find_con_by_component (gfc_component *com, gfc_constructor *con) +{ + for (; con; con = con->next) + { + if (com == con->n.component) + return con; + } + return NULL; +} + + +/* Assign the initial value RVALUE to LVALUE's symbol->value. */ +void +gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index) +{ + gfc_ref *ref; + gfc_expr *init; + gfc_expr *expr; + gfc_constructor *con; + gfc_constructor *last_con; + gfc_symbol *symbol; + mpz_t offset; + + ref = lvalue->ref; + symbol = lvalue->symtree->n.sym; + init = symbol->value; + last_con = NULL; + mpz_init_set_si (offset, 0); + + for (ref = lvalue->ref; ref; ref = ref->next) + { + /* Use the existing initializer expression if it exists. Otherwise + create a new one. */ + if (init == NULL) + expr = gfc_get_expr (); + else + expr = init; + + /* Find or create this element. */ + switch (ref->type) + { + case REF_ARRAY: + if (init == NULL) + { + /* Setup the expression to hold the constructor. */ + expr->expr_type = EXPR_ARRAY; + if (ref->next) + { + assert (ref->next->type == REF_COMPONENT); + expr->ts.type = BT_DERIVED; + } + else + expr->ts = rvalue->ts; + expr->rank = ref->u.ar.as->rank; + } + else + assert (expr->expr_type == EXPR_ARRAY); + + if (ref->u.ar.type == AR_ELEMENT) + get_array_index (&ref->u.ar, &offset); + else + mpz_set (offset, index); + + /* Find the same element in the existing constructor. */ + con = expr->value.constructor; + con = find_con_by_offset (offset, con); + + if (con == NULL) + { + /* Create a new constructor. */ + con = gfc_get_constructor(); + mpz_set (con->n.offset, offset); + gfc_insert_constructor (expr, con); + } + break; + + case REF_COMPONENT: + if (init == NULL) + { + /* Setup the expression to hold the constructor. */ + expr->expr_type = EXPR_STRUCTURE; + expr->ts.type = BT_DERIVED; + expr->ts.derived = ref->u.c.sym; + } + else + assert (expr->expr_type == EXPR_STRUCTURE); + + /* Find the same element in the existing constructor. */ + con = expr->value.constructor; + con = find_con_by_component (ref->u.c.component, con); + + if (con == NULL) + { + /* Create a new constructor. */ + con = gfc_get_constructor (); + con->n.component = ref->u.c.component; + con->next = expr->value.constructor; + expr->value.constructor = con; + } + break; + + case REF_SUBSTRING: + gfc_todo_error ("Substring reference in DATA statement"); + + default: + abort (); + } + + if (init == NULL) + { + /* Point the container at the new expression. */ + if (last_con == NULL) + symbol->value = expr; + else + last_con->expr = expr; + } + init = con->expr; + last_con = con; + } + + expr = gfc_copy_expr (rvalue); + if (!gfc_compare_types (&lvalue->ts, &expr->ts)) + gfc_convert_type (expr, &lvalue->ts, 0); + + if (last_con == NULL) + symbol->value = expr; + else + { + assert (!last_con->expr); + last_con->expr = expr; + } +} + + +/* Modify the index of array section and re-calculate the array offset. */ + +void +gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar, + mpz_t *offset_ret) +{ + int i; + mpz_t delta; + mpz_t tmp; + bool forwards; + int cmp; + + for (i = 0; i < ar->dimen; i++) + { + if (ar->dimen_type[i] != DIMEN_RANGE) + continue; + + if (ar->stride[i]) + { + mpz_add (section_index[i], section_index[i], + ar->stride[i]->value.integer); + if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0) + forwards = true; + else + forwards = false; + } + else + { + mpz_add_ui (section_index[i], section_index[i], 1); + forwards = true; + } + + if (ar->end[i]) + cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer); + else + cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer); + + if ((cmp > 0 && forwards) + || (cmp < 0 && ! forwards)) + { + /* Reset index to start, then loop to advance the next index. */ + if (ar->start[i]) + mpz_set (section_index[i], ar->start[i]->value.integer); + else + mpz_set (section_index[i], ar->as->lower[i]->value.integer); + } + else + break; + } + + mpz_set_si (*offset_ret, 0); + mpz_init_set_si (delta, 1); + mpz_init (tmp); + for (i = 0; i < ar->dimen; i++) + { + mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer); + mpz_mul (tmp, tmp, delta); + mpz_add (*offset_ret, tmp, *offset_ret); + + mpz_sub (tmp, ar->as->upper[i]->value.integer, + ar->as->lower[i]->value.integer); + mpz_add_ui (tmp, tmp, 1); + mpz_mul (delta, tmp, delta); + } + mpz_clear (tmp); + mpz_clear (delta); +} + + +/* Rearrange a structure constructor so the elements are in the specified + order. Also insert NULL entries if neccessary. */ + +static void +formalize_structure_cons (gfc_expr * expr) +{ + gfc_constructor *head; + gfc_constructor *tail; + gfc_constructor *cur; + gfc_constructor *last; + gfc_constructor *c; + gfc_component *order; + + c = expr->value.constructor; + + /* Constructor is already fomalized. */ + if (c->n.component == NULL) + return; + + head = tail = NULL; + for (order = expr->ts.derived->components; order; order = order->next) + { + /* Find the next component. */ + last = NULL; + cur = c; + while (cur != NULL && cur->n.component != order) + { + last = cur; + cur = cur->next; + } + + if (cur == NULL) + { + /* Create a new one. */ + cur = gfc_get_constructor (); + } + else + { + /* Remove it from the chain. */ + if (last == NULL) + c = cur->next; + else + last->next = cur->next; + cur->next = NULL; + + formalize_init_expr (cur->expr); + } + + /* Add it to the new constructor. */ + if (head == NULL) + head = tail = cur; + else + { + tail->next = cur; + tail = tail->next; + } + } + assert (c == NULL); + expr->value.constructor = head; +} + + +/* Make sure an initialization expression is in normalized form. Ie. all + elements of the constructors are in the correct order. */ + +static void +formalize_init_expr (gfc_expr * expr) +{ + expr_t type; + gfc_constructor *c; + + if (expr == NULL) + return; + + type = expr->expr_type; + switch (type) + { + case EXPR_ARRAY: + c = expr->value.constructor; + while (c) + { + formalize_init_expr (c->expr); + c = c->next; + } + break; + + case EXPR_STRUCTURE: + formalize_structure_cons (expr); + break; + + default: + break; + } +} + + +/* Resolve symbol's initial value after all data statement. */ + +void +gfc_formalize_init_value (gfc_symbol *sym) +{ + formalize_init_expr (sym->value); +} + + +/* Get the integer value into RET_AS and SECTION from AS and AR, and return + offset. */ + +void +gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset) +{ + int i; + mpz_t delta; + mpz_t tmp; + + mpz_set_si (*offset, 0); + mpz_init (tmp); + mpz_init_set_si (delta, 1); + for (i = 0; i < ar->dimen; i++) + { + mpz_init (section_index[i]); + switch (ar->dimen_type[i]) + { + case DIMEN_ELEMENT: + case DIMEN_RANGE: + if (ar->start[i]) + { + mpz_sub (tmp, ar->start[i]->value.integer, + ar->as->lower[i]->value.integer); + mpz_mul (tmp, tmp, delta); + mpz_add (*offset, tmp, *offset); + mpz_set (section_index[i], ar->start[i]->value.integer); + } + else + mpz_set (section_index[i], ar->as->lower[i]->value.integer); + break; + + case DIMEN_VECTOR: + gfc_todo_error ("Vectors sections in data statements"); + + default: + abort (); + } + + mpz_sub (tmp, ar->as->upper[i]->value.integer, + ar->as->lower[i]->value.integer); + mpz_add_ui (tmp, tmp, 1); + mpz_mul (delta, tmp, delta); + } + + mpz_clear (tmp); + mpz_clear (delta); +} + diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c new file mode 100644 index 00000000000..1bc91c18393 --- /dev/null +++ b/gcc/fortran/decl.c @@ -0,0 +1,2649 @@ +/* Declaration statement matcher + Copyright (C) 2002 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#include "config.h" +#include "gfortran.h" +#include "match.h" +#include "parse.h" +#include <string.h> + + +/* This flag is set if a an old-style length selector is matched + during a type-declaration statement. */ + +static int old_char_selector; + +/* When variables aquire types and attributes from a declaration + statement, they get them from the following static variables. The + first part of a declaration sets these variables and the second + part copies these into symbol structures. */ + +static gfc_typespec current_ts; + +static symbol_attribute current_attr; +static gfc_array_spec *current_as; +static int colon_seen; + +/* gfc_new_block points to the symbol of a newly matched block. */ + +gfc_symbol *gfc_new_block; + + +/* Match an intent specification. Since this can only happen after an + INTENT word, a legal intent-spec must follow. */ + +static sym_intent +match_intent_spec (void) +{ + + if (gfc_match (" ( in out )") == MATCH_YES) + return INTENT_INOUT; + if (gfc_match (" ( in )") == MATCH_YES) + return INTENT_IN; + if (gfc_match (" ( out )") == MATCH_YES) + return INTENT_OUT; + + gfc_error ("Bad INTENT specification at %C"); + return INTENT_UNKNOWN; +} + + +/* Matches a character length specification, which is either a + specification expression or a '*'. */ + +static match +char_len_param_value (gfc_expr ** expr) +{ + + if (gfc_match_char ('*') == MATCH_YES) + { + *expr = NULL; + return MATCH_YES; + } + + return gfc_match_expr (expr); +} + + +/* A character length is a '*' followed by a literal integer or a + char_len_param_value in parenthesis. */ + +static match +match_char_length (gfc_expr ** expr) +{ + int length; + match m; + + m = gfc_match_char ('*'); + if (m != MATCH_YES) + return m; + + m = gfc_match_small_literal_int (&length); + if (m == MATCH_ERROR) + return m; + + if (m == MATCH_YES) + { + *expr = gfc_int_expr (length); + return m; + } + + if (gfc_match_char ('(') == MATCH_NO) + goto syntax; + + m = char_len_param_value (expr); + if (m == MATCH_ERROR) + return m; + if (m == MATCH_NO) + goto syntax; + + if (gfc_match_char (')') == MATCH_NO) + { + gfc_free_expr (*expr); + *expr = NULL; + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in character length specification at %C"); + return MATCH_ERROR; +} + + +/* Special subroutine for finding a symbol. If we're compiling a + function or subroutine and the parent compilation unit is an + interface, then check to see if the name we've been given is the + name of the interface (located in another namespace). If so, + return that symbol. If not, use gfc_get_symbol(). */ + +static int +find_special (const char *name, gfc_symbol ** result) +{ + gfc_state_data *s; + + if (gfc_current_state () != COMP_SUBROUTINE + && gfc_current_state () != COMP_FUNCTION) + goto normal; + + s = gfc_state_stack->previous; + if (s == NULL) + goto normal; + + if (s->state != COMP_INTERFACE) + goto normal; + if (s->sym == NULL) + goto normal; /* Nameless interface */ + + if (strcmp (name, s->sym->name) == 0) + { + *result = s->sym; + return 0; + } + +normal: + return gfc_get_symbol (name, NULL, result); +} + + +/* Special subroutine for getting a symbol node associated with a + procedure name, used in SUBROUTINE and FUNCTION statements. The + symbol is created in the parent using with symtree node in the + child unit pointing to the symbol. If the current namespace has no + parent, then the symbol is just created in the current unit. */ + +static int +get_proc_name (const char *name, gfc_symbol ** result) +{ + gfc_symtree *st; + gfc_symbol *sym; + int rc; + + if (gfc_current_ns->parent == NULL) + return gfc_get_symbol (name, NULL, result); + + rc = gfc_get_symbol (name, gfc_current_ns->parent, result); + if (*result == NULL) + return rc; + + /* Deal with ENTRY problem */ + + st = gfc_new_symtree (&gfc_current_ns->sym_root, name); + + sym = *result; + st->n.sym = sym; + sym->refs++; + + /* See if the procedure should be a module procedure */ + + if (sym->ns->proc_name != NULL + && sym->ns->proc_name->attr.flavor == FL_MODULE + && sym->attr.proc != PROC_MODULE + && gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE) + rc = 2; + + return rc; +} + + +/* Function called by variable_decl() that adds a name to the symbol + table. */ + +static try +build_sym (const char *name, gfc_charlen * cl, + gfc_array_spec ** as, locus * var_locus) +{ + symbol_attribute attr; + gfc_symbol *sym; + + if (find_special (name, &sym)) + return FAILURE; + + /* Start updating the symbol table. Add basic type attribute + if present. */ + if (current_ts.type != BT_UNKNOWN + &&(sym->attr.implicit_type == 0 + || !gfc_compare_types (&sym->ts, ¤t_ts)) + && gfc_add_type (sym, ¤t_ts, var_locus) == FAILURE) + return FAILURE; + + if (sym->ts.type == BT_CHARACTER) + sym->ts.cl = cl; + + /* Add dimension attribute if present. */ + if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE) + return FAILURE; + *as = NULL; + + /* Add attribute to symbol. The copy is so that we can reset the + dimension attribute. */ + attr = current_attr; + attr.dimension = 0; + + if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/* Function called by variable_decl() that adds an initialization + expression to a symbol. */ + +static try +add_init_expr_to_sym (const char *name, gfc_expr ** initp, + locus * var_locus) +{ + symbol_attribute attr; + gfc_symbol *sym; + gfc_expr *init; + + init = *initp; + if (find_special (name, &sym)) + return FAILURE; + + attr = sym->attr; + + /* If this symbol is confirming an implicit parameter type, + then an initialization expression is not allowed. */ + if (attr.flavor == FL_PARAMETER + && sym->value != NULL + && *initp != NULL) + { + gfc_error ("Initializer not allowed for PARAMETER '%s' at %C", + sym->name); + return FAILURE; + } + + if (init == NULL) + { + /* An initializer is required for PARAMETER declarations. */ + if (attr.flavor == FL_PARAMETER) + { + gfc_error ("PARAMETER at %L is missing an initializer", var_locus); + return FAILURE; + } + } + else + { + /* If a variable appears in a DATA block, it cannot have an + initializer. */ + if (sym->attr.data) + { + gfc_error + ("Variable '%s' at %C with an initializer already appears " + "in a DATA statement", sym->name); + return FAILURE; + } + + /* Checking a derived type parameter has to be put off until later. */ + if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED + && gfc_check_assign_symbol (sym, init) == FAILURE) + return FAILURE; + + /* Add initializer. Make sure we keep the ranks sane. */ + if (sym->attr.dimension && init->rank == 0) + init->rank = sym->as->rank; + + sym->value = init; + *initp = NULL; + } + + return SUCCESS; +} + + +/* Function called by variable_decl() that adds a name to a structure + being built. */ + +static try +build_struct (const char *name, gfc_charlen * cl, gfc_expr ** init, + gfc_array_spec ** as) +{ + gfc_component *c; + + /* If the current symbol is of the same derived type that we're + constructing, it must have the pointer attribute. */ + if (current_ts.type == BT_DERIVED + && current_ts.derived == gfc_current_block () + && current_attr.pointer == 0) + { + gfc_error ("Component at %C must have the POINTER attribute"); + return FAILURE; + } + + if (gfc_current_block ()->attr.pointer + && (*as)->rank != 0) + { + if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT) + { + gfc_error ("Array component of structure at %C must have explicit " + "or deferred shape"); + return FAILURE; + } + } + + if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE) + return FAILURE; + + c->ts = current_ts; + c->ts.cl = cl; + gfc_set_component_attr (c, ¤t_attr); + + c->initializer = *init; + *init = NULL; + + c->as = *as; + if (c->as != NULL) + c->dimension = 1; + *as = NULL; + + /* Check array components. */ + if (!c->dimension) + return SUCCESS; + + if (c->pointer) + { + if (c->as->type != AS_DEFERRED) + { + gfc_error ("Pointer array component of structure at %C " + "must have a deferred shape"); + return FAILURE; + } + } + else + { + if (c->as->type != AS_EXPLICIT) + { + gfc_error + ("Array component of structure at %C must have an explicit " + "shape"); + return FAILURE; + } + } + + return SUCCESS; +} + + +/* Match a 'NULL()', and possibly take care of some side effects. */ + +match +gfc_match_null (gfc_expr ** result) +{ + gfc_symbol *sym; + gfc_expr *e; + match m; + + m = gfc_match (" null ( )"); + if (m != MATCH_YES) + return m; + + /* The NULL symbol now has to be/become an intrinsic function. */ + if (gfc_get_symbol ("null", NULL, &sym)) + { + gfc_error ("NULL() initialization at %C is ambiguous"); + return MATCH_ERROR; + } + + gfc_intrinsic_symbol (sym); + + if (sym->attr.proc != PROC_INTRINSIC + && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC, NULL) == FAILURE + || gfc_add_function (&sym->attr, NULL) == FAILURE)) + return MATCH_ERROR; + + e = gfc_get_expr (); + e->where = *gfc_current_locus (); + e->expr_type = EXPR_NULL; + e->ts.type = BT_UNKNOWN; + + *result = e; + + return MATCH_YES; +} + + +/* Get an expression for a default initializer. */ +static gfc_expr * +default_initializer (void) +{ + gfc_constructor *tail; + gfc_expr *init; + gfc_component *c; + + init = NULL; + + /* First see if we have a default initializer. */ + for (c = current_ts.derived->components; c; c = c->next) + { + if (c->initializer && init == NULL) + init = gfc_get_expr (); + } + + if (init == NULL) + return NULL; + + init->expr_type = EXPR_STRUCTURE; + init->ts = current_ts; + init->where = current_ts.derived->declared_at; + tail = NULL; + for (c = current_ts.derived->components; c; c = c->next) + { + if (tail == NULL) + init->value.constructor = tail = gfc_get_constructor (); + else + { + tail->next = gfc_get_constructor (); + tail = tail->next; + } + + if (c->initializer) + tail->expr = gfc_copy_expr (c->initializer); + } + return init; +} + + +/* Match a variable name with an optional initializer. When this + subroutine is called, a variable is expected to be parsed next. + Depending on what is happening at the moment, updates either the + symbol table or the current interface. */ + +static match +variable_decl (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_expr *initializer, *char_len; + gfc_array_spec *as; + gfc_charlen *cl; + locus var_locus; + match m; + try t; + + initializer = NULL; + as = NULL; + + /* When we get here, we've just matched a list of attributes and + maybe a type and a double colon. The next thing we expect to see + is the name of the symbol. */ + m = gfc_match_name (name); + if (m != MATCH_YES) + goto cleanup; + + var_locus = *gfc_current_locus (); + + /* Now we could see the optional array spec. or character length. */ + m = gfc_match_array_spec (&as); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + as = gfc_copy_array_spec (current_as); + + char_len = NULL; + cl = NULL; + + if (current_ts.type == BT_CHARACTER) + { + switch (match_char_length (&char_len)) + { + case MATCH_YES: + cl = gfc_get_charlen (); + cl->next = gfc_current_ns->cl_list; + gfc_current_ns->cl_list = cl; + + cl->length = char_len; + break; + + case MATCH_NO: + cl = current_ts.cl; + break; + + case MATCH_ERROR: + goto cleanup; + } + } + + /* OK, we've successfully matched the declaration. Now put the + symbol in the current namespace, because it might be used in the + optional intialization expression for this symbol, e.g. this is + perfectly legal: + + integer, parameter :: i = huge(i) + + This is only true for parameters or variables of a basic type. + For components of derived types, it is not true, so we don't + create a symbol for those yet. If we fail to create the symbol, + bail out. */ + if (gfc_current_state () != COMP_DERIVED + && build_sym (name, cl, &as, &var_locus) == FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } + + /* In functions that have a RESULT variable defined, the function + name always refers to function calls. Therefore, the name is + not allowed to appear in specification statements. */ + if (gfc_current_state () == COMP_FUNCTION + && gfc_current_block () != NULL + && gfc_current_block ()->result != NULL + && gfc_current_block ()->result != gfc_current_block () + && strcmp (gfc_current_block ()->name, name) == 0) + { + gfc_error ("Function name '%s' not allowed at %C", name); + m = MATCH_ERROR; + goto cleanup; + } + + /* The double colon must be present in order to have initializers. + Otherwise the statement is ambiguous with an assignment statement. */ + if (colon_seen) + { + if (gfc_match (" =>") == MATCH_YES) + { + + if (!current_attr.pointer) + { + gfc_error ("Initialization at %C isn't for a pointer variable"); + m = MATCH_ERROR; + goto cleanup; + } + + m = gfc_match_null (&initializer); + if (m == MATCH_NO) + { + gfc_error ("Pointer initialization requires a NULL at %C"); + m = MATCH_ERROR; + } + + if (gfc_pure (NULL)) + { + gfc_error + ("Initialization of pointer at %C is not allowed in a " + "PURE procedure"); + m = MATCH_ERROR; + } + + if (m != MATCH_YES) + goto cleanup; + + initializer->ts = current_ts; + + } + else if (gfc_match_char ('=') == MATCH_YES) + { + if (current_attr.pointer) + { + gfc_error + ("Pointer initialization at %C requires '=>', not '='"); + m = MATCH_ERROR; + goto cleanup; + } + + m = gfc_match_init_expr (&initializer); + if (m == MATCH_NO) + { + gfc_error ("Expected an initialization expression at %C"); + m = MATCH_ERROR; + } + + if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)) + { + gfc_error + ("Initialization of variable at %C is not allowed in a " + "PURE procedure"); + m = MATCH_ERROR; + } + + if (m != MATCH_YES) + goto cleanup; + } + else if (current_ts.type == BT_DERIVED) + { + initializer = default_initializer (); + } + } + + /* Add the initializer. Note that it is fine if &initializer is + NULL here, because we sometimes also need to check if a + declaration *must* have an initialization expression. */ + if (gfc_current_state () != COMP_DERIVED) + t = add_init_expr_to_sym (name, &initializer, &var_locus); + else + t = build_struct (name, cl, &initializer, &as); + + m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR; + +cleanup: + /* Free stuff up and return. */ + gfc_free_expr (initializer); + gfc_free_array_spec (as); + + return m; +} + + +/* Match an extended-f77 kind specification. */ + +match +gfc_match_old_kind_spec (gfc_typespec * ts) +{ + match m; + + if (gfc_match_char ('*') != MATCH_YES) + return MATCH_NO; + + m = gfc_match_small_literal_int (&ts->kind); + if (m != MATCH_YES) + return MATCH_ERROR; + + /* Massage the kind numbers for complex types. */ + if (ts->type == BT_COMPLEX && ts->kind == 8) + ts->kind = 4; + if (ts->type == BT_COMPLEX && ts->kind == 16) + ts->kind = 8; + + if (gfc_validate_kind (ts->type, ts->kind) == -1) + { + gfc_error ("Old-style kind %d not supported for type %s at %C", + ts->kind, gfc_basic_typename (ts->type)); + + return MATCH_ERROR; + } + + return MATCH_YES; +} + + +/* Match a kind specification. Since kinds are generally optional, we + usually return MATCH_NO if something goes wrong. If a "kind=" + string is found, then we know we have an error. */ + +match +gfc_match_kind_spec (gfc_typespec * ts) +{ + locus where; + gfc_expr *e; + match m, n; + const char *msg; + + m = MATCH_NO; + e = NULL; + + where = *gfc_current_locus (); + + if (gfc_match_char ('(') == MATCH_NO) + return MATCH_NO; + + /* Also gobbles optional text. */ + if (gfc_match (" kind = ") == MATCH_YES) + m = MATCH_ERROR; + + n = gfc_match_init_expr (&e); + if (n == MATCH_NO) + gfc_error ("Expected initialization expression at %C"); + if (n != MATCH_YES) + return MATCH_ERROR; + + if (e->rank != 0) + { + gfc_error ("Expected scalar initialization expression at %C"); + m = MATCH_ERROR; + goto no_match; + } + + msg = gfc_extract_int (e, &ts->kind); + if (msg != NULL) + { + gfc_error (msg); + m = MATCH_ERROR; + goto no_match; + } + + gfc_free_expr (e); + e = NULL; + + if (gfc_validate_kind (ts->type, ts->kind) == -1) + { + gfc_error ("Kind %d not supported for type %s at %C", ts->kind, + gfc_basic_typename (ts->type)); + + m = MATCH_ERROR; + goto no_match; + } + + if (gfc_match_char (')') != MATCH_YES) + { + gfc_error ("Missing right paren at %C"); + goto no_match; + } + + return MATCH_YES; + +no_match: + gfc_free_expr (e); + gfc_set_locus (&where); + return m; +} + + +/* Match the various kind/length specifications in a CHARACTER + declaration. We don't return MATCH_NO. */ + +static match +match_char_spec (gfc_typespec * ts) +{ + int i, kind, seen_length; + gfc_charlen *cl; + gfc_expr *len; + match m; + + kind = gfc_default_character_kind (); + len = NULL; + seen_length = 0; + + /* Try the old-style specification first. */ + old_char_selector = 0; + + m = match_char_length (&len); + if (m != MATCH_NO) + { + if (m == MATCH_YES) + old_char_selector = 1; + seen_length = 1; + goto done; + } + + m = gfc_match_char ('('); + if (m != MATCH_YES) + { + m = MATCH_YES; /* character without length is a single char */ + goto done; + } + + /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ) */ + if (gfc_match (" kind =") == MATCH_YES) + { + m = gfc_match_small_int (&kind); + if (m == MATCH_ERROR) + goto done; + if (m == MATCH_NO) + goto syntax; + + if (gfc_match (" , len =") == MATCH_NO) + goto rparen; + + m = char_len_param_value (&len); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto done; + seen_length = 1; + + goto rparen; + } + + /* Try to match ( LEN = <len-param> ) or ( LEN = <len-param>, KIND = <int> ) */ + if (gfc_match (" len =") == MATCH_YES) + { + m = char_len_param_value (&len); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto done; + seen_length = 1; + + if (gfc_match_char (')') == MATCH_YES) + goto done; + + if (gfc_match (" , kind =") != MATCH_YES) + goto syntax; + + gfc_match_small_int (&kind); + + if (gfc_validate_kind (BT_CHARACTER, kind) == -1) + { + gfc_error ("Kind %d is not a CHARACTER kind at %C", kind); + return MATCH_YES; + } + + goto rparen; + } + + /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ) */ + m = char_len_param_value (&len); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto done; + seen_length = 1; + + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + gfc_match (" kind ="); /* Gobble optional text */ + + m = gfc_match_small_int (&kind); + if (m == MATCH_ERROR) + goto done; + if (m == MATCH_NO) + goto syntax; + +rparen: + /* Require a right-paren at this point. */ + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + +syntax: + gfc_error ("Syntax error in CHARACTER declaration at %C"); + m = MATCH_ERROR; + +done: + if (m == MATCH_YES && gfc_validate_kind (BT_CHARACTER, kind) == -1) + { + gfc_error ("Kind %d is not a CHARACTER kind at %C", kind); + m = MATCH_ERROR; + } + + if (m != MATCH_YES) + { + gfc_free_expr (len); + return m; + } + + /* Do some final massaging of the length values. */ + cl = gfc_get_charlen (); + cl->next = gfc_current_ns->cl_list; + gfc_current_ns->cl_list = cl; + + if (seen_length == 0) + cl->length = gfc_int_expr (1); + else + { + if (len == NULL || gfc_extract_int (len, &i) != NULL || i >= 0) + cl->length = len; + else + { + gfc_free_expr (len); + cl->length = gfc_int_expr (0); + } + } + + ts->cl = cl; + ts->kind = kind; + + return MATCH_YES; +} + + +/* Matches a type specification. If successful, sets the ts structure + to the matched specification. This is necessary for FUNCTION and + IMPLICIT statements. + + If kind_flag is nonzero, then we check for the optional kind + specification. Not doing so is needed for matching an IMPLICIT + statement correctly. */ + +match +gfc_match_type_spec (gfc_typespec * ts, int kind_flag) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + match m; + + gfc_clear_ts (ts); + + if (gfc_match (" integer") == MATCH_YES) + { + ts->type = BT_INTEGER; + ts->kind = gfc_default_integer_kind (); + goto get_kind; + } + + if (gfc_match (" character") == MATCH_YES) + { + ts->type = BT_CHARACTER; + return match_char_spec (ts); + } + + if (gfc_match (" real") == MATCH_YES) + { + ts->type = BT_REAL; + ts->kind = gfc_default_real_kind (); + goto get_kind; + } + + if (gfc_match (" double precision") == MATCH_YES) + { + ts->type = BT_REAL; + ts->kind = gfc_default_double_kind (); + return MATCH_YES; + } + + if (gfc_match (" complex") == MATCH_YES) + { + ts->type = BT_COMPLEX; + ts->kind = gfc_default_complex_kind (); + goto get_kind; + } + + if (gfc_match (" double complex") == MATCH_YES) + { + ts->type = BT_COMPLEX; + ts->kind = gfc_default_double_kind (); + return MATCH_YES; + } + + if (gfc_match (" logical") == MATCH_YES) + { + ts->type = BT_LOGICAL; + ts->kind = gfc_default_logical_kind (); + goto get_kind; + } + + m = gfc_match (" type ( %n )", name); + if (m != MATCH_YES) + return m; + + /* Search for the name but allow the components to be defined later. */ + if (gfc_get_ha_symbol (name, &sym)) + { + gfc_error ("Type name '%s' at %C is ambiguous", name); + return MATCH_ERROR; + } + + if (sym->attr.flavor != FL_DERIVED + && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE) + return MATCH_ERROR; + + ts->type = BT_DERIVED; + ts->kind = 0; + ts->derived = sym; + + return MATCH_YES; + +get_kind: + /* For all types except double, derived and character, look for an + optional kind specifier. MATCH_NO is actually OK at this point. */ + if (kind_flag == 0) + return MATCH_YES; + + m = gfc_match_kind_spec (ts); + if (m == MATCH_NO && ts->type != BT_CHARACTER) + m = gfc_match_old_kind_spec (ts); + + if (m == MATCH_NO) + m = MATCH_YES; /* No kind specifier found. */ + + return m; +} + + +/* Matches an attribute specification including array specs. If + successful, leaves the variables current_attr and current_as + holding the specification. Also sets the colon_seen variable for + later use by matchers associated with initializations. + + This subroutine is a little tricky in the sense that we don't know + if we really have an attr-spec until we hit the double colon. + Until that time, we can only return MATCH_NO. This forces us to + check for duplicate specification at this level. */ + +static match +match_attr_spec (void) +{ + + /* Modifiers that can exist in a type statement. */ + typedef enum + { GFC_DECL_BEGIN = 0, + DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL, + DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL, + DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE, + DECL_TARGET, DECL_COLON, DECL_NONE, + GFC_DECL_END /* Sentinel */ + } + decl_types; + +/* GFC_DECL_END is the sentinel, index starts at 0. */ +#define NUM_DECL GFC_DECL_END + + static mstring decls[] = { + minit (", allocatable", DECL_ALLOCATABLE), + minit (", dimension", DECL_DIMENSION), + minit (", external", DECL_EXTERNAL), + minit (", intent ( in )", DECL_IN), + minit (", intent ( out )", DECL_OUT), + minit (", intent ( in out )", DECL_INOUT), + minit (", intrinsic", DECL_INTRINSIC), + minit (", optional", DECL_OPTIONAL), + minit (", parameter", DECL_PARAMETER), + minit (", pointer", DECL_POINTER), + minit (", private", DECL_PRIVATE), + minit (", public", DECL_PUBLIC), + minit (", save", DECL_SAVE), + minit (", target", DECL_TARGET), + minit ("::", DECL_COLON), + minit (NULL, DECL_NONE) + }; + + locus start, seen_at[NUM_DECL]; + int seen[NUM_DECL]; + decl_types d; + const char *attr; + match m; + try t; + + gfc_clear_attr (¤t_attr); + start = *gfc_current_locus (); + + current_as = NULL; + colon_seen = 0; + + /* See if we get all of the keywords up to the final double colon. */ + for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++) + seen[d] = 0; + + for (;;) + { + d = (decl_types) gfc_match_strings (decls); + if (d == DECL_NONE || d == DECL_COLON) + break; + + seen[d]++; + seen_at[d] = *gfc_current_locus (); + + if (d == DECL_DIMENSION) + { + m = gfc_match_array_spec (¤t_as); + + if (m == MATCH_NO) + { + gfc_error ("Missing dimension specification at %C"); + m = MATCH_ERROR; + } + + if (m == MATCH_ERROR) + goto cleanup; + } + } + + /* No double colon, so assume that we've been looking at something + else the whole time. */ + if (d == DECL_NONE) + { + m = MATCH_NO; + goto cleanup; + } + + /* Since we've seen a double colon, we have to be looking at an + attr-spec. This means that we can now issue errors. */ + for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++) + if (seen[d] > 1) + { + switch (d) + { + case DECL_ALLOCATABLE: + attr = "ALLOCATABLE"; + break; + case DECL_DIMENSION: + attr = "DIMENSION"; + break; + case DECL_EXTERNAL: + attr = "EXTERNAL"; + break; + case DECL_IN: + attr = "INTENT (IN)"; + break; + case DECL_OUT: + attr = "INTENT (OUT)"; + break; + case DECL_INOUT: + attr = "INTENT (IN OUT)"; + break; + case DECL_INTRINSIC: + attr = "INTRINSIC"; + break; + case DECL_OPTIONAL: + attr = "OPTIONAL"; + break; + case DECL_PARAMETER: + attr = "PARAMETER"; + break; + case DECL_POINTER: + attr = "POINTER"; + break; + case DECL_PRIVATE: + attr = "PRIVATE"; + break; + case DECL_PUBLIC: + attr = "PUBLIC"; + break; + case DECL_SAVE: + attr = "SAVE"; + break; + case DECL_TARGET: + attr = "TARGET"; + break; + default: + attr = NULL; /* This shouldn't happen */ + } + + gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]); + m = MATCH_ERROR; + goto cleanup; + } + + /* Now that we've dealt with duplicate attributes, add the attributes + to the current attribute. */ + for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++) + { + if (seen[d] == 0) + continue; + + if (gfc_current_state () == COMP_DERIVED + && d != DECL_DIMENSION && d != DECL_POINTER + && d != DECL_COLON && d != DECL_NONE) + { + + gfc_error ("Attribute at %L is not allowed in a TYPE definition", + &seen_at[d]); + m = MATCH_ERROR; + goto cleanup; + } + + switch (d) + { + case DECL_ALLOCATABLE: + t = gfc_add_allocatable (¤t_attr, &seen_at[d]); + break; + + case DECL_DIMENSION: + t = gfc_add_dimension (¤t_attr, &seen_at[d]); + break; + + case DECL_EXTERNAL: + t = gfc_add_external (¤t_attr, &seen_at[d]); + break; + + case DECL_IN: + t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]); + break; + + case DECL_OUT: + t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]); + break; + + case DECL_INOUT: + t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]); + break; + + case DECL_INTRINSIC: + t = gfc_add_intrinsic (¤t_attr, &seen_at[d]); + break; + + case DECL_OPTIONAL: + t = gfc_add_optional (¤t_attr, &seen_at[d]); + break; + + case DECL_PARAMETER: + t = gfc_add_flavor (¤t_attr, FL_PARAMETER, &seen_at[d]); + break; + + case DECL_POINTER: + t = gfc_add_pointer (¤t_attr, &seen_at[d]); + break; + + case DECL_PRIVATE: + t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, &seen_at[d]); + break; + + case DECL_PUBLIC: + t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, &seen_at[d]); + break; + + case DECL_SAVE: + t = gfc_add_save (¤t_attr, &seen_at[d]); + break; + + case DECL_TARGET: + t = gfc_add_target (¤t_attr, &seen_at[d]); + break; + + default: + gfc_internal_error ("match_attr_spec(): Bad attribute"); + } + + if (t == FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } + } + + colon_seen = 1; + return MATCH_YES; + +cleanup: + gfc_set_locus (&start); + gfc_free_array_spec (current_as); + current_as = NULL; + return m; +} + + +/* Match a data declaration statement. */ + +match +gfc_match_data_decl (void) +{ + gfc_symbol *sym; + match m; + + m = gfc_match_type_spec (¤t_ts, 1); + if (m != MATCH_YES) + return m; + + if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED) + { + sym = gfc_use_derived (current_ts.derived); + + if (sym == NULL) + { + m = MATCH_ERROR; + goto cleanup; + } + + current_ts.derived = sym; + } + + m = match_attr_spec (); + if (m == MATCH_ERROR) + { + m = MATCH_NO; + goto cleanup; + } + + if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL) + { + + if (current_attr.pointer && gfc_current_state () == COMP_DERIVED) + goto ok; + + if (gfc_find_symbol (current_ts.derived->name, + current_ts.derived->ns->parent, 1, &sym) == 0) + goto ok; + + /* Hope that an ambiguous symbol is itself masked by a type definition. */ + if (sym != NULL && sym->attr.flavor == FL_DERIVED) + goto ok; + + gfc_error ("Derived type at %C has not been previously defined"); + m = MATCH_ERROR; + goto cleanup; + } + +ok: + /* If we have an old-style character declaration, and no new-style + attribute specifications, then there a comma is optional between + the type specification and the variable list. */ + if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector) + gfc_match_char (','); + + /* Give the types/attributes to symbols that follow. */ + for (;;) + { + m = variable_decl (); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + break; + + if (gfc_match_eos () == MATCH_YES) + goto cleanup; + if (gfc_match_char (',') != MATCH_YES) + break; + } + + gfc_error ("Syntax error in data declaration at %C"); + m = MATCH_ERROR; + +cleanup: + gfc_free_array_spec (current_as); + current_as = NULL; + return m; +} + + +/* Match a prefix associated with a function or subroutine + declaration. If the typespec pointer is nonnull, then a typespec + can be matched. Note that if nothing matches, MATCH_YES is + returned (the null string was matched). */ + +static match +match_prefix (gfc_typespec * ts) +{ + int seen_type; + + gfc_clear_attr (¤t_attr); + seen_type = 0; + +loop: + if (!seen_type && ts != NULL + && gfc_match_type_spec (ts, 1) == MATCH_YES + && gfc_match_space () == MATCH_YES) + { + + seen_type = 1; + goto loop; + } + + if (gfc_match ("elemental% ") == MATCH_YES) + { + if (gfc_add_elemental (¤t_attr, NULL) == FAILURE) + return MATCH_ERROR; + + goto loop; + } + + if (gfc_match ("pure% ") == MATCH_YES) + { + if (gfc_add_pure (¤t_attr, NULL) == FAILURE) + return MATCH_ERROR; + + goto loop; + } + + if (gfc_match ("recursive% ") == MATCH_YES) + { + if (gfc_add_recursive (¤t_attr, NULL) == FAILURE) + return MATCH_ERROR; + + goto loop; + } + + /* At this point, the next item is not a prefix. */ + return MATCH_YES; +} + + +/* Copy attributes matched by match_prefix() to attributes on a symbol. */ + +static try +copy_prefix (symbol_attribute * dest, locus * where) +{ + + if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE) + return FAILURE; + + if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE) + return FAILURE; + + if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/* Match a formal argument list. */ + +match +gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag) +{ + gfc_formal_arglist *head, *tail, *p, *q; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + match m; + + head = tail = NULL; + + if (gfc_match_char ('(') != MATCH_YES) + { + if (null_flag) + goto ok; + return MATCH_NO; + } + + if (gfc_match_char (')') == MATCH_YES) + goto ok; + + for (;;) + { + if (gfc_match_char ('*') == MATCH_YES) + sym = NULL; + else + { + m = gfc_match_name (name); + if (m != MATCH_YES) + goto cleanup; + + if (gfc_get_symbol (name, NULL, &sym)) + goto cleanup; + } + + p = gfc_get_formal_arglist (); + + if (head == NULL) + head = tail = p; + else + { + tail->next = p; + tail = p; + } + + tail->sym = sym; + + /* We don't add the VARIABLE flavor because the name could be a + dummy procedure. We don't apply these attributes to formal + arguments of statement functions. */ + if (sym != NULL && !st_flag + && (gfc_add_dummy (&sym->attr, NULL) == FAILURE + || gfc_missing_attr (&sym->attr, NULL) == FAILURE)) + { + m = MATCH_ERROR; + goto cleanup; + } + + /* The name of a program unit can be in a different namespace, + so check for it explicitly. After the statement is accepted, + the name is checked for especially in gfc_get_symbol(). */ + if (gfc_new_block != NULL && sym != NULL + && strcmp (sym->name, gfc_new_block->name) == 0) + { + gfc_error ("Name '%s' at %C is the name of the procedure", + sym->name); + m = MATCH_ERROR; + goto cleanup; + } + + if (gfc_match_char (')') == MATCH_YES) + goto ok; + + m = gfc_match_char (','); + if (m != MATCH_YES) + { + gfc_error ("Unexpected junk in formal argument list at %C"); + goto cleanup; + } + } + +ok: + /* Check for duplicate symbols in the formal argument list. */ + if (head != NULL) + { + for (p = head; p->next; p = p->next) + { + if (p->sym == NULL) + continue; + + for (q = p->next; q; q = q->next) + if (p->sym == q->sym) + { + gfc_error + ("Duplicate symbol '%s' in formal argument list at %C", + p->sym->name); + + m = MATCH_ERROR; + goto cleanup; + } + } + } + + if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL) == + FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } + + return MATCH_YES; + +cleanup: + gfc_free_formal_arglist (head); + return m; +} + + +/* Match a RESULT specification following a function declaration or + ENTRY statement. Also matches the end-of-statement. */ + +static match +match_result (gfc_symbol * function, gfc_symbol ** result) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *r; + match m; + + if (gfc_match (" result (") != MATCH_YES) + return MATCH_NO; + + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; + + if (gfc_match (" )%t") != MATCH_YES) + { + gfc_error ("Unexpected junk following RESULT variable at %C"); + return MATCH_ERROR; + } + + if (strcmp (function->name, name) == 0) + { + gfc_error + ("RESULT variable at %C must be different than function name"); + return MATCH_ERROR; + } + + if (gfc_get_symbol (name, NULL, &r)) + return MATCH_ERROR; + + if (gfc_add_flavor (&r->attr, FL_VARIABLE, NULL) == FAILURE + || gfc_add_result (&r->attr, NULL) == FAILURE) + return MATCH_ERROR; + + *result = r; + + return MATCH_YES; +} + + +/* Match a function declaration. */ + +match +gfc_match_function_decl (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym, *result; + locus old_loc; + match m; + + if (gfc_current_state () != COMP_NONE + && gfc_current_state () != COMP_INTERFACE + && gfc_current_state () != COMP_CONTAINS) + return MATCH_NO; + + gfc_clear_ts (¤t_ts); + + old_loc = *gfc_current_locus (); + + m = match_prefix (¤t_ts); + if (m != MATCH_YES) + { + gfc_set_locus (&old_loc); + return m; + } + + if (gfc_match ("function% %n", name) != MATCH_YES) + { + gfc_set_locus (&old_loc); + return MATCH_NO; + } + + if (get_proc_name (name, &sym)) + return MATCH_ERROR; + gfc_new_block = sym; + + m = gfc_match_formal_arglist (sym, 0, 0); + if (m == MATCH_NO) + gfc_error ("Expected formal argument list in function definition at %C"); + else if (m == MATCH_ERROR) + goto cleanup; + + result = NULL; + + if (gfc_match_eos () != MATCH_YES) + { + /* See if a result variable is present. */ + m = match_result (sym, &result); + if (m == MATCH_NO) + gfc_error ("Unexpected junk after function declaration at %C"); + + if (m != MATCH_YES) + { + m = MATCH_ERROR; + goto cleanup; + } + } + + /* Make changes to the symbol. */ + m = MATCH_ERROR; + + if (gfc_add_function (&sym->attr, NULL) == FAILURE) + goto cleanup; + + if (gfc_missing_attr (&sym->attr, NULL) == FAILURE + || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE) + goto cleanup; + + if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN) + { + gfc_error ("Function '%s' at %C already has a type of %s", name, + gfc_basic_typename (sym->ts.type)); + goto cleanup; + } + + if (result == NULL) + { + sym->ts = current_ts; + sym->result = sym; + } + else + { + result->ts = current_ts; + sym->result = result; + } + + return MATCH_YES; + +cleanup: + gfc_set_locus (&old_loc); + return m; +} + + +/* Match an ENTRY statement. */ + +match +gfc_match_entry (void) +{ + gfc_symbol *function, *result, *entry; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_compile_state state; + match m; + + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; + + if (get_proc_name (name, &entry)) + return MATCH_ERROR; + + gfc_enclosing_unit (&state); + switch (state) + { + case COMP_SUBROUTINE: + m = gfc_match_formal_arglist (entry, 0, 1); + if (m != MATCH_YES) + return MATCH_ERROR; + + if (gfc_current_state () != COMP_SUBROUTINE) + goto exec_construct; + + if (gfc_add_entry (&entry->attr, NULL) == FAILURE + || gfc_add_subroutine (&entry->attr, NULL) == FAILURE) + return MATCH_ERROR; + + break; + + case COMP_FUNCTION: + m = gfc_match_formal_arglist (entry, 0, 0); + if (m != MATCH_YES) + return MATCH_ERROR; + + if (gfc_current_state () != COMP_FUNCTION) + goto exec_construct; + function = gfc_state_stack->sym; + + result = NULL; + + if (gfc_match_eos () == MATCH_YES) + { + if (gfc_add_entry (&entry->attr, NULL) == FAILURE + || gfc_add_function (&entry->attr, NULL) == FAILURE) + return MATCH_ERROR; + + entry->result = function->result; + + } + else + { + m = match_result (function, &result); + if (m == MATCH_NO) + gfc_syntax_error (ST_ENTRY); + if (m != MATCH_YES) + return MATCH_ERROR; + + if (gfc_add_result (&result->attr, NULL) == FAILURE + || gfc_add_entry (&entry->attr, NULL) == FAILURE + || gfc_add_function (&entry->attr, NULL) == FAILURE) + return MATCH_ERROR; + } + + if (function->attr.recursive && result == NULL) + { + gfc_error ("RESULT attribute required in ENTRY statement at %C"); + return MATCH_ERROR; + } + + break; + + default: + goto exec_construct; + } + + if (gfc_match_eos () != MATCH_YES) + { + gfc_syntax_error (ST_ENTRY); + return MATCH_ERROR; + } + + return MATCH_YES; + +exec_construct: + gfc_error ("ENTRY statement at %C cannot appear within %s", + gfc_state_name (gfc_current_state ())); + + return MATCH_ERROR; +} + + +/* Match a subroutine statement, including optional prefixes. */ + +match +gfc_match_subroutine (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + match m; + + if (gfc_current_state () != COMP_NONE + && gfc_current_state () != COMP_INTERFACE + && gfc_current_state () != COMP_CONTAINS) + return MATCH_NO; + + m = match_prefix (NULL); + if (m != MATCH_YES) + return m; + + m = gfc_match ("subroutine% %n", name); + if (m != MATCH_YES) + return m; + + if (get_proc_name (name, &sym)) + return MATCH_ERROR; + gfc_new_block = sym; + + if (gfc_add_subroutine (&sym->attr, NULL) == FAILURE) + return MATCH_ERROR; + + if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES) + return MATCH_ERROR; + + if (gfc_match_eos () != MATCH_YES) + { + gfc_syntax_error (ST_SUBROUTINE); + return MATCH_ERROR; + } + + if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE) + return MATCH_ERROR; + + return MATCH_YES; +} + + +/* Match any of the various end-block statements. Returns the type of + END to the caller. The END INTERFACE, END IF, END DO and END + SELECT statements cannot be replaced by a single END statement. */ + +match +gfc_match_end (gfc_statement * st) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_compile_state state; + locus old_loc; + const char *block_name; + const char *target; + match m; + + old_loc = *gfc_current_locus (); + if (gfc_match ("end") != MATCH_YES) + return MATCH_NO; + + state = gfc_current_state (); + block_name = + gfc_current_block () == NULL ? NULL : gfc_current_block ()->name; + + if (state == COMP_CONTAINS) + { + state = gfc_state_stack->previous->state; + block_name = gfc_state_stack->previous->sym == NULL ? NULL + : gfc_state_stack->previous->sym->name; + } + + switch (state) + { + case COMP_NONE: + case COMP_PROGRAM: + *st = ST_END_PROGRAM; + target = " program"; + break; + + case COMP_SUBROUTINE: + *st = ST_END_SUBROUTINE; + target = " subroutine"; + break; + + case COMP_FUNCTION: + *st = ST_END_FUNCTION; + target = " function"; + break; + + case COMP_BLOCK_DATA: + *st = ST_END_BLOCK_DATA; + target = " block data"; + break; + + case COMP_MODULE: + *st = ST_END_MODULE; + target = " module"; + break; + + case COMP_INTERFACE: + *st = ST_END_INTERFACE; + target = " interface"; + break; + + case COMP_DERIVED: + *st = ST_END_TYPE; + target = " type"; + break; + + case COMP_IF: + *st = ST_ENDIF; + target = " if"; + break; + + case COMP_DO: + *st = ST_ENDDO; + target = " do"; + break; + + case COMP_SELECT: + *st = ST_END_SELECT; + target = " select"; + break; + + case COMP_FORALL: + *st = ST_END_FORALL; + target = " forall"; + break; + + case COMP_WHERE: + *st = ST_END_WHERE; + target = " where"; + break; + + default: + gfc_error ("Unexpected END statement at %C"); + goto cleanup; + } + + if (gfc_match_eos () == MATCH_YES) + { + + if (*st == ST_ENDIF || *st == ST_ENDDO || *st == ST_END_SELECT + || *st == ST_END_INTERFACE || *st == ST_END_FORALL + || *st == ST_END_WHERE) + { + + gfc_error ("%s statement expected at %C", + gfc_ascii_statement (*st)); + goto cleanup; + } + + return MATCH_YES; + } + + /* Verify that we've got the sort of end-block that we're expecting. */ + if (gfc_match (target) != MATCH_YES) + { + gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st)); + goto cleanup; + } + + /* If we're at the end, make sure a block name wasn't required. */ + if (gfc_match_eos () == MATCH_YES) + { + + if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT) + return MATCH_YES; + + if (gfc_current_block () == NULL) + return MATCH_YES; + + gfc_error ("Expected block name of '%s' in %s statement at %C", + block_name, gfc_ascii_statement (*st)); + + return MATCH_ERROR; + } + + /* END INTERFACE has a special handler for its several possible endings. */ + if (*st == ST_END_INTERFACE) + return gfc_match_end_interface (); + + /* We haven't hit the end of statement, so what is left must be an end-name. */ + m = gfc_match_space (); + if (m == MATCH_YES) + m = gfc_match_name (name); + + if (m == MATCH_NO) + gfc_error ("Expected terminating name at %C"); + if (m != MATCH_YES) + goto cleanup; + + if (block_name == NULL) + goto syntax; + + if (strcmp (name, block_name) != 0) + { + gfc_error ("Expected label '%s' for %s statement at %C", block_name, + gfc_ascii_statement (*st)); + goto cleanup; + } + + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + +syntax: + gfc_syntax_error (*st); + +cleanup: + gfc_set_locus (&old_loc); + return MATCH_ERROR; +} + + + +/***************** Attribute declaration statements ****************/ + +/* Set the attribute of a single variable. */ + +static match +attr_decl1 (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_array_spec *as; + gfc_symbol *sym; + locus var_locus; + match m; + + as = NULL; + + m = gfc_match_name (name); + if (m != MATCH_YES) + goto cleanup; + + if (find_special (name, &sym)) + return MATCH_ERROR; + + var_locus = *gfc_current_locus (); + + /* Deal with possible array specification for certain attributes. */ + if (current_attr.dimension + || current_attr.allocatable + || current_attr.pointer + || current_attr.target) + { + m = gfc_match_array_spec (&as); + if (m == MATCH_ERROR) + goto cleanup; + + if (current_attr.dimension && m == MATCH_NO) + { + gfc_error + ("Missing array specification at %L in DIMENSION statement", + &var_locus); + m = MATCH_ERROR; + goto cleanup; + } + + if ((current_attr.allocatable || current_attr.pointer) + && (m == MATCH_YES) && (as->type != AS_DEFERRED)) + { + gfc_error ("Array specification must be deferred at %L", + &var_locus); + m = MATCH_ERROR; + goto cleanup; + } + } + + /* Update symbol table. DIMENSION attribute is set in gfc_set_array_spec(). */ + if (current_attr.dimension == 0 + && gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } + + if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } + + if ((current_attr.external || current_attr.intrinsic) + && sym->attr.flavor != FL_PROCEDURE + && gfc_add_flavor (&sym->attr, FL_PROCEDURE, NULL) == FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } + + return MATCH_YES; + +cleanup: + gfc_free_array_spec (as); + return m; +} + + +/* Generic attribute declaration subroutine. Used for attributes that + just have a list of names. */ + +static match +attr_decl (void) +{ + match m; + + /* Gobble the optional double colon, by simply ignoring the result + of gfc_match(). */ + gfc_match (" ::"); + + for (;;) + { + m = attr_decl1 (); + if (m != MATCH_YES) + break; + + if (gfc_match_eos () == MATCH_YES) + { + m = MATCH_YES; + break; + } + + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Unexpected character in variable list at %C"); + m = MATCH_ERROR; + break; + } + } + + return m; +} + + +match +gfc_match_external (void) +{ + + gfc_clear_attr (¤t_attr); + gfc_add_external (¤t_attr, NULL); + + return attr_decl (); +} + + + +match +gfc_match_intent (void) +{ + sym_intent intent; + + intent = match_intent_spec (); + if (intent == INTENT_UNKNOWN) + return MATCH_ERROR; + + gfc_clear_attr (¤t_attr); + gfc_add_intent (¤t_attr, intent, NULL); /* Can't fail */ + + return attr_decl (); +} + + +match +gfc_match_intrinsic (void) +{ + + gfc_clear_attr (¤t_attr); + gfc_add_intrinsic (¤t_attr, NULL); + + return attr_decl (); +} + + +match +gfc_match_optional (void) +{ + + gfc_clear_attr (¤t_attr); + gfc_add_optional (¤t_attr, NULL); + + return attr_decl (); +} + + +match +gfc_match_pointer (void) +{ + + gfc_clear_attr (¤t_attr); + gfc_add_pointer (¤t_attr, NULL); + + return attr_decl (); +} + + +match +gfc_match_allocatable (void) +{ + + gfc_clear_attr (¤t_attr); + gfc_add_allocatable (¤t_attr, NULL); + + return attr_decl (); +} + + +match +gfc_match_dimension (void) +{ + + gfc_clear_attr (¤t_attr); + gfc_add_dimension (¤t_attr, NULL); + + return attr_decl (); +} + + +match +gfc_match_target (void) +{ + + gfc_clear_attr (¤t_attr); + gfc_add_target (¤t_attr, NULL); + + return attr_decl (); +} + + +/* Match the list of entities being specified in a PUBLIC or PRIVATE + statement. */ + +static match +access_attr_decl (gfc_statement st) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + interface_type type; + gfc_user_op *uop; + gfc_symbol *sym; + gfc_intrinsic_op operator; + match m; + + if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) + goto done; + + for (;;) + { + m = gfc_match_generic_spec (&type, name, &operator); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + return MATCH_ERROR; + + switch (type) + { + case INTERFACE_NAMELESS: + goto syntax; + + case INTERFACE_GENERIC: + if (gfc_get_symbol (name, NULL, &sym)) + goto done; + + if (gfc_add_access (&sym->attr, + (st == + ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE, + NULL) == FAILURE) + return MATCH_ERROR; + + break; + + case INTERFACE_INTRINSIC_OP: + if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN) + { + gfc_current_ns->operator_access[operator] = + (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE; + } + else + { + gfc_error ("Access specification of the %s operator at %C has " + "already been specified", gfc_op2string (operator)); + goto done; + } + + break; + + case INTERFACE_USER_OP: + uop = gfc_get_uop (name); + + if (uop->access == ACCESS_UNKNOWN) + { + uop->access = + (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE; + } + else + { + gfc_error + ("Access specification of the .%s. operator at %C has " + "already been specified", sym->name); + goto done; + } + + break; + } + + if (gfc_match_char (',') == MATCH_NO) + break; + } + + if (gfc_match_eos () != MATCH_YES) + goto syntax; + return MATCH_YES; + +syntax: + gfc_syntax_error (st); + +done: + return MATCH_ERROR; +} + + +/* The PRIVATE statement is a bit weird in that it can be a attribute + declaration, but also works as a standlone statement inside of a + type declaration or a module. */ + +match +gfc_match_private (gfc_statement * st) +{ + + if (gfc_match ("private") != MATCH_YES) + return MATCH_NO; + + if (gfc_current_state () == COMP_DERIVED) + { + if (gfc_match_eos () == MATCH_YES) + { + *st = ST_PRIVATE; + return MATCH_YES; + } + + gfc_syntax_error (ST_PRIVATE); + return MATCH_ERROR; + } + + if (gfc_match_eos () == MATCH_YES) + { + *st = ST_PRIVATE; + return MATCH_YES; + } + + *st = ST_ATTR_DECL; + return access_attr_decl (ST_PRIVATE); +} + + +match +gfc_match_public (gfc_statement * st) +{ + + if (gfc_match ("public") != MATCH_YES) + return MATCH_NO; + + if (gfc_match_eos () == MATCH_YES) + { + *st = ST_PUBLIC; + return MATCH_YES; + } + + *st = ST_ATTR_DECL; + return access_attr_decl (ST_PUBLIC); +} + + +/* Workhorse for gfc_match_parameter. */ + +static match +do_parm (void) +{ + gfc_symbol *sym; + gfc_expr *init; + match m; + + m = gfc_match_symbol (&sym, 0); + if (m == MATCH_NO) + gfc_error ("Expected variable name at %C in PARAMETER statement"); + + if (m != MATCH_YES) + return m; + + if (gfc_match_char ('=') == MATCH_NO) + { + gfc_error ("Expected = sign in PARAMETER statement at %C"); + return MATCH_ERROR; + } + + m = gfc_match_init_expr (&init); + if (m == MATCH_NO) + gfc_error ("Expected expression at %C in PARAMETER statement"); + if (m != MATCH_YES) + return m; + + if (sym->ts.type == BT_UNKNOWN + && gfc_set_default_type (sym, 1, NULL) == FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } + + if (gfc_check_assign_symbol (sym, init) == FAILURE + || gfc_add_flavor (&sym->attr, FL_PARAMETER, NULL) == FAILURE) + { + m = MATCH_ERROR; + goto cleanup; + } + + sym->value = init; + return MATCH_YES; + +cleanup: + gfc_free_expr (init); + return m; +} + + +/* Match a parameter statement, with the weird syntax that these have. */ + +match +gfc_match_parameter (void) +{ + match m; + + if (gfc_match_char ('(') == MATCH_NO) + return MATCH_NO; + + for (;;) + { + m = do_parm (); + if (m != MATCH_YES) + break; + + if (gfc_match (" )%t") == MATCH_YES) + break; + + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Unexpected characters in PARAMETER statement at %C"); + m = MATCH_ERROR; + break; + } + } + + return m; +} + + +/* Save statements have a special syntax. */ + +match +gfc_match_save (void) +{ + gfc_symbol *sym; + match m; + + if (gfc_match_eos () == MATCH_YES) + { + if (gfc_current_ns->seen_save) + { + gfc_error ("Blanket SAVE statement at %C follows previous " + "SAVE statement"); + + return MATCH_ERROR; + } + + gfc_current_ns->save_all = gfc_current_ns->seen_save = 1; + return MATCH_YES; + } + + if (gfc_current_ns->save_all) + { + gfc_error ("SAVE statement at %C follows blanket SAVE statement"); + return MATCH_ERROR; + } + + gfc_match (" ::"); + + for (;;) + { + m = gfc_match_symbol (&sym, 0); + switch (m) + { + case MATCH_YES: + if (gfc_add_save (&sym->attr, gfc_current_locus ()) == FAILURE) + return MATCH_ERROR; + goto next_item; + + case MATCH_NO: + break; + + case MATCH_ERROR: + return MATCH_ERROR; + } + + m = gfc_match (" / %s /", &sym); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + goto syntax; + + if (gfc_add_saved_common (&sym->attr, NULL) == FAILURE) + return MATCH_ERROR; + gfc_current_ns->seen_save = 1; + + next_item: + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in SAVE statement at %C"); + return MATCH_ERROR; +} + + +/* Match a module procedure statement. Note that we have to modify + symbols in the parent's namespace because the current one was there + to receive symbols that are in a interface's formal argument list. */ + +match +gfc_match_modproc (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + match m; + + if (gfc_state_stack->state != COMP_INTERFACE + || gfc_state_stack->previous == NULL + || current_interface.type == INTERFACE_NAMELESS) + { + gfc_error + ("MODULE PROCEDURE at %C must be in a generic module interface"); + return MATCH_ERROR; + } + + for (;;) + { + m = gfc_match_name (name); + if (m == MATCH_NO) + goto syntax; + if (m != MATCH_YES) + return MATCH_ERROR; + + if (gfc_get_symbol (name, gfc_current_ns->parent, &sym)) + return MATCH_ERROR; + + if (sym->attr.proc != PROC_MODULE + && gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE) + return MATCH_ERROR; + + if (gfc_add_interface (sym) == FAILURE) + return MATCH_ERROR; + + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_MODULE_PROC); + return MATCH_ERROR; +} + + +/* Match the beginning of a derived type declaration. If a type name + was the result of a function, then it is possible to have a symbol + already to be known as a derived type yet have no components. */ + +match +gfc_match_derived_decl (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + symbol_attribute attr; + gfc_symbol *sym; + match m; + + if (gfc_current_state () == COMP_DERIVED) + return MATCH_NO; + + gfc_clear_attr (&attr); + +loop: + if (gfc_match (" , private") == MATCH_YES) + { + if (gfc_find_state (COMP_MODULE) == FAILURE) + { + gfc_error + ("Derived type at %C can only be PRIVATE within a MODULE"); + return MATCH_ERROR; + } + + if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL) == FAILURE) + return MATCH_ERROR; + goto loop; + } + + if (gfc_match (" , public") == MATCH_YES) + { + if (gfc_find_state (COMP_MODULE) == FAILURE) + { + gfc_error ("Derived type at %C can only be PUBLIC within a MODULE"); + return MATCH_ERROR; + } + + if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL) == FAILURE) + return MATCH_ERROR; + goto loop; + } + + if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN) + { + gfc_error ("Expected :: in TYPE definition at %C"); + return MATCH_ERROR; + } + + m = gfc_match (" %n%t", name); + if (m != MATCH_YES) + return m; + + /* Make sure the name isn't the name of an intrinsic type. The + 'double precision' type doesn't get past the name matcher. */ + if (strcmp (name, "integer") == 0 + || strcmp (name, "real") == 0 + || strcmp (name, "character") == 0 + || strcmp (name, "logical") == 0 + || strcmp (name, "complex") == 0) + { + gfc_error + ("Type name '%s' at %C cannot be the same as an intrinsic type", + name); + return MATCH_ERROR; + } + + if (gfc_get_symbol (name, NULL, &sym)) + return MATCH_ERROR; + + if (sym->ts.type != BT_UNKNOWN) + { + gfc_error ("Derived type name '%s' at %C already has a basic type " + "of %s", sym->name, gfc_typename (&sym->ts)); + return MATCH_ERROR; + } + + /* The symbol may already have the derived attribute without the + components. The ways this can happen is via a function + definition, an INTRINSIC statement or a subtype in another + derived type that is a pointer. The first part of the AND clause + is true if a the symbol is not the return value of a function. */ + if (sym->attr.flavor != FL_DERIVED + && gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE) + return MATCH_ERROR; + + if (sym->components != NULL) + { + gfc_error + ("Derived type definition of '%s' at %C has already been defined", + sym->name); + return MATCH_ERROR; + } + + if (attr.access != ACCESS_UNKNOWN + && gfc_add_access (&sym->attr, attr.access, NULL) == FAILURE) + return MATCH_ERROR; + + gfc_new_block = sym; + + return MATCH_YES; +} diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c new file mode 100644 index 00000000000..03edb8f169f --- /dev/null +++ b/gcc/fortran/dependency.c @@ -0,0 +1,679 @@ +/* Dependency analysis + Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* dependency.c -- Expression dependency analysis code. */ +/* There's probably quite a bit of duplication in this file. We currently + have different dependency checking functions for different types + if dependencies. Ideally these would probably be merged. */ + + +#include "config.h" +#include "gfortran.h" +#include "dependency.h" +#include <assert.h> + +/* static declarations */ +/* Enums */ +enum range {LHS, RHS, MID}; + +/* Dependency types. These must be in reverse order of priority. */ +typedef enum +{ + GFC_DEP_ERROR, + GFC_DEP_EQUAL, /* Identical Ranges. */ + GFC_DEP_FORWARD, /* eg. a(1:3), a(2:4). */ + GFC_DEP_OVERLAP, /* May overlap in some other way. */ + GFC_DEP_NODEP /* Distinct ranges. */ +} +gfc_dependency; + +/* Macros */ +#define IS_ARRAY_EXPLICIT(as) ((as->type == AS_EXPLICIT ? 1 : 0)) + + +/* Returns 1 if the expr is an integer constant value 1, 0 if it is not or + def if the value could not be determined. */ + +int +gfc_expr_is_one (gfc_expr * expr, int def) +{ + assert (expr != NULL); + + if (expr->expr_type != EXPR_CONSTANT) + return def; + + if (expr->ts.type != BT_INTEGER) + return def; + + return mpz_cmp_si (expr->value.integer, 1) == 0; +} + + +/* Compare two values. Returns 0 if e1 == e2, -1 if e1 < e2, +1 if e1 > e2, + and -2 if the relationship could not be determined. */ + +int +gfc_dep_compare_expr (gfc_expr * e1, gfc_expr * e2) +{ + int i; + + if (e1->expr_type != e2->expr_type) + return -2; + + switch (e1->expr_type) + { + case EXPR_CONSTANT: + if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER) + return -2; + + i = mpz_cmp (e1->value.integer, e2->value.integer); + if (i == 0) + return 0; + else if (i < 0) + return -1; + return 1; + + case EXPR_VARIABLE: + if (e1->ref || e2->ref) + return -2; + if (e1->symtree->n.sym == e2->symtree->n.sym) + return 0; + return -2; + + default: + return -2; + } +} + + +/* Returns 1 if the two ranges are the same, 0 if they are not, and def + if the results are indeterminate. N is the dimension to compare. */ + +int +gfc_is_same_range (gfc_array_ref * ar1, gfc_array_ref * ar2, int n, int def) +{ + gfc_expr *e1; + gfc_expr *e2; + int i; + + /* TODO: More sophisticated range comparison. */ + assert (ar1 && ar2); + + assert (ar1->dimen_type[n] == ar2->dimen_type[n]); + + e1 = ar1->stride[n]; + e2 = ar2->stride[n]; + /* Check for mismatching strides. A NULL stride means a stride of 1. */ + if (e1 && !e2) + { + i = gfc_expr_is_one (e1, -1); + if (i == -1) + return def; + else if (i == 0) + return 0; + } + else if (e2 && !e1) + { + i = gfc_expr_is_one (e2, -1); + if (i == -1) + return def; + else if (i == 0) + return 0; + } + else if (e1 && e2) + { + i = gfc_dep_compare_expr (e1, e2); + if (i == -2) + return def; + else if (i != 0) + return 0; + } + /* The strides match. */ + + /* Check the range start. */ + e1 = ar1->start[n]; + e2 = ar2->start[n]; + + if (!(e1 || e2)) + return 1; + + /* Use the bound of the array if no bound is specified. */ + if (ar1->as && !e1) + e1 = ar1->as->lower[n]; + + if (ar2->as && !e2) + e2 = ar2->as->upper[n]; + + /* Check we have values for both. */ + if (!(e1 && e2)) + return def; + + i = gfc_dep_compare_expr (e1, e2); + + if (i == -2) + return def; + else if (i == 0) + return 1; + return 0; +} + + +/* Dependency checking for direct function return by reference. + Returns true if the arguments of the function depend on the + destination. This is considerably less conservative than other + dependencies because many function arguments will already be + copied into a temporary. */ + +int +gfc_check_fncall_dependency (gfc_expr * dest, gfc_expr * fncall) +{ + gfc_actual_arglist *actual; + gfc_ref *ref; + gfc_expr *expr; + int n; + + assert (dest->expr_type == EXPR_VARIABLE + && fncall->expr_type == EXPR_FUNCTION); + assert (fncall->rank > 0); + + for (actual = fncall->value.function.actual; actual; actual = actual->next) + { + expr = actual->expr; + + /* Skip args which are not present. */ + if (!expr) + continue; + + /* Non-variable expressions will be allocated temporaries anyway. */ + switch (expr->expr_type) + { + case EXPR_VARIABLE: + if (expr->rank > 1) + { + /* This is an array section. */ + for (ref = expr->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) + break; + } + assert (ref); + /* AR_FULL can't contain vector subscripts. */ + if (ref->u.ar.type == AR_SECTION) + { + for (n = 0; n < ref->u.ar.dimen; n++) + { + if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR) + break; + } + /* Vector subscript array sections will be copied to a + temporary. */ + if (n != ref->u.ar.dimen) + continue; + } + } + + if (gfc_check_dependency (dest, actual->expr, NULL, 0)) + return 1; + break; + + case EXPR_ARRAY: + if (gfc_check_dependency (dest, expr, NULL, 0)) + return 1; + break; + + default: + break; + } + } + + return 0; +} + + +/* Return true if the statement body redefines the condition. Returns + true if expr2 depends on expr1. expr1 should be a single term + suitable for the lhs of an assignment. The symbols listed in VARS + must be considered to have all possible values. All other scalar + variables may be considered constant. Used for forall and where + statements. Also used with functions returning arrays without a + temporary. */ + +int +gfc_check_dependency (gfc_expr * expr1, gfc_expr * expr2, gfc_expr ** vars, + int nvars) +{ + gfc_ref *ref; + int n; + gfc_actual_arglist *actual; + + assert (expr1->expr_type == EXPR_VARIABLE); + + /* TODO: -fassume-no-pointer-aliasing */ + if (expr1->symtree->n.sym->attr.pointer) + return 1; + for (ref = expr1->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT && ref->u.c.component->pointer) + return 1; + } + + switch (expr2->expr_type) + { + case EXPR_OP: + n = gfc_check_dependency (expr1, expr2->op1, vars, nvars); + if (n) + return n; + if (expr2->op2) + return gfc_check_dependency (expr1, expr2->op2, vars, nvars); + return 0; + + case EXPR_VARIABLE: + if (expr2->symtree->n.sym->attr.pointer) + return 1; + + for (ref = expr2->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT && ref->u.c.component->pointer) + return 1; + } + + if (expr1->symtree->n.sym != expr2->symtree->n.sym) + return 0; + + for (ref = expr2->ref; ref; ref = ref->next) + { + /* Identical ranges return 0, overlapping ranges return 1. */ + if (ref->type == REF_ARRAY) + return 1; + } + return 1; + + case EXPR_FUNCTION: + /* Remember possible differences betweeen elemental and + transformational functions. All functions inside a FORALL + will be pure. */ + for (actual = expr2->value.function.actual; + actual; actual = actual->next) + { + if (!actual->expr) + continue; + n = gfc_check_dependency (expr1, actual->expr, vars, nvars); + if (n) + return n; + } + return 0; + + case EXPR_CONSTANT: + return 0; + + case EXPR_ARRAY: + /* Probably ok in the majority of (constant) cases. */ + return 1; + + default: + return 1; + } +} + + +/* Calculates size of the array reference using lower bound, upper bound + and stride. */ + +static void +get_no_of_elements(mpz_t ele, gfc_expr * u1, gfc_expr * l1, gfc_expr * s1) +{ + /* nNoOfEle = (u1-l1)/s1 */ + + mpz_sub (ele, u1->value.integer, l1->value.integer); + + if (s1 != NULL) + mpz_tdiv_q (ele, ele, s1->value.integer); +} + + +/* Returns if the ranges ((0..Y), (X1..X2)) overlap. */ + +static gfc_dependency +get_deps (mpz_t x1, mpz_t x2, mpz_t y) +{ + int start; + int end; + + start = mpz_cmp_ui (x1, 0); + end = mpz_cmp (x2, y); + + /* Both ranges the same. */ + if (start == 0 && end == 0) + return GFC_DEP_EQUAL; + + /* Distinct ranges. */ + if ((start < 0 && mpz_cmp_ui (x2, 0) < 0) + || (mpz_cmp (x1, y) > 0 && end > 0)) + return GFC_DEP_NODEP; + + /* Overlapping, but with corresponding elements of the second range + greater than the first. */ + if (start > 0 && end > 0) + return GFC_DEP_FORWARD; + + /* Overlapping in some other way. */ + return GFC_DEP_OVERLAP; +} + + +/* Transforms a sections l and r such that + (l_start:l_end:l_stride) -> (0:no_of_elements) + (r_start:r_end:r_stride) -> (X1:X2) + Where r_end is implicit as both sections must have the same number of + elelments. + Returns 0 on success, 1 of the transformation failed. */ +/* TODO: Should this be (0:no_of_elements-1) */ + +static int +transform_sections (mpz_t X1, mpz_t X2, mpz_t no_of_elements, + gfc_expr * l_start, gfc_expr * l_end, gfc_expr * l_stride, + gfc_expr * r_start, gfc_expr * r_stride) +{ + if (NULL == l_start || NULL == l_end || NULL == r_start) + return 1; + + /* TODO : Currently we check the dependency only when start, end and stride + are constant. We could also check for equal (variable) values, and + common subexpressions, eg. x vs. x+1. */ + + if (l_end->expr_type != EXPR_CONSTANT + || l_start->expr_type != EXPR_CONSTANT + || r_start->expr_type != EXPR_CONSTANT + || ((NULL != l_stride) && (l_stride->expr_type != EXPR_CONSTANT)) + || ((NULL != r_stride) && (r_stride->expr_type != EXPR_CONSTANT))) + { + return 1; + } + + + get_no_of_elements (no_of_elements, l_end, l_start, l_stride); + + mpz_sub (X1, r_start->value.integer, l_start->value.integer); + if (l_stride != NULL) + mpz_cdiv_q (X1, X1, l_stride->value.integer); + + if (r_stride == NULL) + mpz_set (X2, no_of_elements); + else + mpz_mul (X2, no_of_elements, r_stride->value.integer); + + if (l_stride != NULL) + mpz_cdiv_q (X2, X2, r_stride->value.integer); + mpz_add (X2, X2, X1); + + return 0; +} + + +/* Determines overlapping for two array sections. */ + +static gfc_dependency +gfc_check_section_vs_section (gfc_ref * lref, gfc_ref * rref, int n) +{ + gfc_expr *l_start; + gfc_expr *l_end; + gfc_expr *l_stride; + + gfc_expr *r_start; + gfc_expr *r_stride; + + gfc_array_ref l_ar; + gfc_array_ref r_ar; + + mpz_t no_of_elements; + mpz_t X1, X2; + gfc_dependency dep; + + l_ar = lref->u.ar; + r_ar = rref->u.ar; + + l_start = l_ar.start[n]; + l_end = l_ar.end[n]; + l_stride = l_ar.stride[n]; + r_start = r_ar.start[n]; + r_stride = r_ar.stride[n]; + + /* if l_start is NULL take it from array specifier */ + if (NULL == l_start && IS_ARRAY_EXPLICIT(l_ar.as)) + l_start = l_ar.as->lower[n]; + + /* if l_end is NULL take it from array specifier */ + if (NULL == l_end && IS_ARRAY_EXPLICIT(l_ar.as)) + l_end = l_ar.as->upper[n]; + + /* if r_start is NULL take it from array specifier */ + if (NULL == r_start && IS_ARRAY_EXPLICIT(r_ar.as)) + r_start = r_ar.as->lower[n]; + + mpz_init (X1); + mpz_init (X2); + mpz_init (no_of_elements); + + if (transform_sections (X1, X2, no_of_elements, + l_start, l_end, l_stride, + r_start, r_stride)) + dep = GFC_DEP_OVERLAP; + else + dep = get_deps (X1, X2, no_of_elements); + + mpz_clear (no_of_elements); + mpz_clear (X1); + mpz_clear (X2); + return dep; +} + + +/* Checks if the expr chk is inside the range left-right. + Returns GFC_DEP_NODEP if chk is outside the range, + GFC_DEP_OVERLAP otherwise. + Assumes left<=right. */ + +static gfc_dependency +gfc_is_inside_range (gfc_expr * chk, gfc_expr * left, gfc_expr * right) +{ + int l; + int r; + int s; + + s = gfc_dep_compare_expr (left, right); + if (s == -2) + return GFC_DEP_OVERLAP; + + l = gfc_dep_compare_expr (chk, left); + r = gfc_dep_compare_expr (chk, right); + + /* Check for indeterminate relationships. */ + if (l == -2 || r == -2 || s == -2) + return GFC_DEP_OVERLAP; + + if (s == 1) + { + /* When left>right we want to check for right <= chk <= left. */ + if (l <= 0 || r >= 0) + return GFC_DEP_OVERLAP; + } + else + { + /* Otherwise check for left <= chk <= right. */ + if (l >= 0 || r <= 0) + return GFC_DEP_OVERLAP; + } + + return GFC_DEP_NODEP; +} + + +/* Determines overlapping for a single element and a section. */ + +static gfc_dependency +gfc_check_element_vs_section( gfc_ref * lref, gfc_ref * rref, int n) +{ + gfc_array_ref l_ar; + gfc_array_ref r_ar; + gfc_expr *l_start; + gfc_expr *r_start; + gfc_expr *r_end; + + l_ar = lref->u.ar; + r_ar = rref->u.ar; + l_start = l_ar.start[n] ; + r_start = r_ar.start[n] ; + r_end = r_ar.end[n] ; + if (NULL == r_start && IS_ARRAY_EXPLICIT (r_ar.as)) + r_start = r_ar.as->lower[n]; + if (NULL == r_end && IS_ARRAY_EXPLICIT (r_ar.as)) + r_end = r_ar.as->upper[n]; + if (NULL == r_start || NULL == r_end || l_start == NULL) + return GFC_DEP_OVERLAP; + + return gfc_is_inside_range (l_start, r_end, r_start); +} + + +/* Determines overlapping for two single element array references. */ + +static gfc_dependency +gfc_check_element_vs_element (gfc_ref * lref, gfc_ref * rref, int n) +{ + gfc_array_ref l_ar; + gfc_array_ref r_ar; + gfc_expr *l_start; + gfc_expr *r_start; + gfc_dependency nIsDep; + + if (lref->type == REF_ARRAY && rref->type == REF_ARRAY) + { + l_ar = lref->u.ar; + r_ar = rref->u.ar; + l_start = l_ar.start[n] ; + r_start = r_ar.start[n] ; + if (gfc_dep_compare_expr (r_start, l_start) == 0) + nIsDep = GFC_DEP_EQUAL; + else + nIsDep = GFC_DEP_NODEP; + } + else + nIsDep = GFC_DEP_NODEP; + + return nIsDep; +} + + +/* Finds if two array references are overlapping or not. + Return value + 1 : array references are overlapping. + 0 : array references are not overlapping. */ + +int +gfc_dep_resolver (gfc_ref * lref, gfc_ref * rref) +{ + int n; + gfc_dependency fin_dep; + gfc_dependency this_dep; + + + fin_dep = GFC_DEP_ERROR; + /* Dependencies due to pointers should already have been identified. + We only need to check for overlapping array references. */ + + while (lref && rref) + { + /* We're resolving from the same base symbol, so both refs should be + the same type. We traverse the reference chain intil we find ranges + that are not equal. */ + assert (lref->type == rref->type); + switch (lref->type) + { + case REF_COMPONENT: + /* The two ranges can't overlap if they are from different + components. */ + if (lref->u.c.component != rref->u.c.component) + return 0; + break; + + case REF_SUBSTRING: + /* Substring overlaps are handled by the string assignment code. */ + return 0; + + case REF_ARRAY: + + for (n=0; n < lref->u.ar.dimen; n++) + { + /* Assume dependency when either of array reference is vector + subscript. */ + if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR + || rref->u.ar.dimen_type[n] == DIMEN_VECTOR) + return 1; + if (lref->u.ar.dimen_type[n] == DIMEN_RANGE + && rref->u.ar.dimen_type[n] == DIMEN_RANGE) + this_dep = gfc_check_section_vs_section (lref, rref, n); + else if (lref->u.ar.dimen_type[n] == DIMEN_ELEMENT + && rref->u.ar.dimen_type[n] == DIMEN_RANGE) + this_dep = gfc_check_element_vs_section (lref, rref, n); + else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT + && lref->u.ar.dimen_type[n] == DIMEN_RANGE) + this_dep = gfc_check_element_vs_section (rref, lref, n); + else + { + assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT + && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT); + this_dep = gfc_check_element_vs_element (rref, lref, n); + } + + /* If any dimension doesn't overlap, we have no dependency. */ + if (this_dep == GFC_DEP_NODEP) + return 0; + + /* Overlap codes are in order of priority. We only need to + know the worst one.*/ + if (this_dep > fin_dep) + fin_dep = this_dep; + } + /* Exactly matching and forward overlapping ranges don't cause a + dependency. */ + if (fin_dep < GFC_DEP_OVERLAP) + return 0; + + /* Keep checking. We only have a dependency if + subsequent references also overlap. */ + break; + + default: + abort(); + } + lref = lref->next; + rref = rref->next; + } + + /* If we haven't seen any array refs then something went wrong. */ + assert (fin_dep != GFC_DEP_ERROR); + + if (fin_dep < GFC_DEP_OVERLAP) + return 0; + else + return 1; +} + diff --git a/gcc/fortran/dependency.h b/gcc/fortran/dependency.h new file mode 100644 index 00000000000..42a33947505 --- /dev/null +++ b/gcc/fortran/dependency.h @@ -0,0 +1,30 @@ +/* Header for dependency analysis + Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + + +int gfc_check_fncall_dependency (gfc_expr *, gfc_expr *); +int gfc_check_dependency (gfc_expr *, gfc_expr *, gfc_expr **, int); +int gfc_is_same_range (gfc_array_ref *, gfc_array_ref *, int, int); +int gfc_dep_compare_expr (gfc_expr *, gfc_expr *); +int gfc_expr_is_one (gfc_expr *, int); + +int gfc_dep_resolver(gfc_ref *, gfc_ref *); diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c new file mode 100644 index 00000000000..1083c6474bf --- /dev/null +++ b/gcc/fortran/dump-parse-tree.c @@ -0,0 +1,1459 @@ +/* Parse tree dumper + Copyright (C) 2003 Free Software Foundation, Inc. + Contributed by Steven Bosscher + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +/* Actually this is just a collection of routines that used to be + scattered around the sources. Now that they are all in a single + file, almost all of them can be static, and the other files don't + have this mess in them. + + As a nice side-effect, this file can act as documentation of the + gfc_code and gfc_expr structures and all their friends and + relatives. + + TODO: Dump DATA. */ + +#include "config.h" +#include "gfortran.h" + +/* Keep track of indentation for symbol tree dumps. */ +static int show_level = 0; + + +/* Forward declaration because this one needs all, and all need + this one. */ +static void gfc_show_expr (gfc_expr *); + +/* Do indentation for a specific level. */ + +static inline void +code_indent (int level, gfc_st_label * label) +{ + int i; + + if (label != NULL) + gfc_status ("%-5d ", label->value); + else + gfc_status (" "); + + for (i = 0; i < 2 * level; i++) + gfc_status_char (' '); +} + + +/* Simple indentation at the current level. This one + is used to show symbols. */ +static inline void +show_indent (void) +{ + gfc_status ("\n"); + code_indent (show_level, NULL); +} + + +/* Show type-specific information. */ +static void +gfc_show_typespec (gfc_typespec * ts) +{ + + gfc_status ("(%s ", gfc_basic_typename (ts->type)); + + switch (ts->type) + { + case BT_DERIVED: + gfc_status ("%s", ts->derived->name); + break; + + case BT_CHARACTER: + gfc_show_expr (ts->cl->length); + break; + + default: + gfc_status ("%d", ts->kind); + break; + } + + gfc_status (")"); +} + + +/* Show an actual argument list. */ + +static void +gfc_show_actual_arglist (gfc_actual_arglist * a) +{ + + gfc_status ("("); + + for (; a; a = a->next) + { + gfc_status_char ('('); + if (a->name[0] != '\0') + gfc_status ("%s = ", a->name); + if (a->expr != NULL) + gfc_show_expr (a->expr); + else + gfc_status ("(arg not-present)"); + + gfc_status_char (')'); + if (a->next != NULL) + gfc_status (" "); + } + + gfc_status (")"); +} + + +/* Show an gfc_array_spec array specification structure. */ + +static void +gfc_show_array_spec (gfc_array_spec * as) +{ + const char *c; + int i; + + if (as == NULL) + { + gfc_status ("()"); + return; + } + + gfc_status ("(%d", as->rank); + + if (as->rank != 0) + { + switch (as->type) + { + case AS_EXPLICIT: c = "AS_EXPLICIT"; break; + case AS_DEFERRED: c = "AS_DEFERRED"; break; + case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break; + case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break; + default: + gfc_internal_error + ("gfc_show_array_spec(): Unhandled array shape type."); + } + gfc_status (" %s ", c); + + for (i = 0; i < as->rank; i++) + { + gfc_show_expr (as->lower[i]); + gfc_status_char (' '); + gfc_show_expr (as->upper[i]); + gfc_status_char (' '); + } + } + + gfc_status (")"); +} + + +/* Show an gfc_array_ref array reference structure. */ + +static void +gfc_show_array_ref (gfc_array_ref * ar) +{ + int i; + + gfc_status_char ('('); + + switch (ar->type) + { + case AR_FULL: + gfc_status ("FULL"); + break; + + case AR_SECTION: + for (i = 0; i < ar->dimen; i++) + { + if (ar->start[i] != NULL) + gfc_show_expr (ar->start[i]); + + gfc_status_char (':'); + + if (ar->end[i] != NULL) + gfc_show_expr (ar->end[i]); + + if (ar->stride[i] != NULL) + { + gfc_status_char (':'); + gfc_show_expr (ar->stride[i]); + } + + if (i != ar->dimen - 1) + gfc_status (" , "); + } + break; + + case AR_ELEMENT: + for (i = 0; i < ar->dimen; i++) + { + gfc_show_expr (ar->start[i]); + if (i != ar->dimen - 1) + gfc_status (" , "); + } + break; + + case AR_UNKNOWN: + gfc_status ("UNKNOWN"); + break; + + default: + gfc_internal_error ("gfc_show_array_ref(): Unknown array reference"); + } + + gfc_status_char (')'); +} + + +/* Show a list of gfc_ref structures. */ + +static void +gfc_show_ref (gfc_ref * p) +{ + + for (; p; p = p->next) + switch (p->type) + { + case REF_ARRAY: + gfc_show_array_ref (&p->u.ar); + break; + + case REF_COMPONENT: + gfc_status (" %% %s", p->u.c.component->name); + break; + + case REF_SUBSTRING: + gfc_status_char ('('); + gfc_show_expr (p->u.ss.start); + gfc_status_char (':'); + gfc_show_expr (p->u.ss.end); + gfc_status_char (')'); + break; + + default: + gfc_internal_error ("gfc_show_ref(): Bad component code"); + } +} + + +/* Display a constructor. Works recursively for array constructors. */ + +static void +gfc_show_constructor (gfc_constructor * c) +{ + + for (; c; c = c->next) + { + if (c->iterator == NULL) + gfc_show_expr (c->expr); + else + { + gfc_status_char ('('); + gfc_show_expr (c->expr); + + gfc_status_char (' '); + gfc_show_expr (c->iterator->var); + gfc_status_char ('='); + gfc_show_expr (c->iterator->start); + gfc_status_char (','); + gfc_show_expr (c->iterator->end); + gfc_status_char (','); + gfc_show_expr (c->iterator->step); + + gfc_status_char (')'); + } + + if (c->next != NULL) + gfc_status (" , "); + } +} + + +/* Show an expression. */ + +static void +gfc_show_expr (gfc_expr * p) +{ + const char *c; + int i; + + if (p == NULL) + { + gfc_status ("()"); + return; + } + + switch (p->expr_type) + { + case EXPR_SUBSTRING: + c = p->value.character.string; + + for (i = 0; i < p->value.character.length; i++, c++) + { + if (*c == '\'') + gfc_status ("''"); + else + gfc_status ("%c", *c); + } + + gfc_show_ref (p->ref); + break; + + case EXPR_STRUCTURE: + gfc_status ("%s(", p->ts.derived->name); + gfc_show_constructor (p->value.constructor); + gfc_status_char (')'); + break; + + case EXPR_ARRAY: + gfc_status ("(/ "); + gfc_show_constructor (p->value.constructor); + gfc_status (" /)"); + + gfc_show_ref (p->ref); + break; + + case EXPR_NULL: + gfc_status ("NULL()"); + break; + + case EXPR_CONSTANT: + switch (p->ts.type) + { + case BT_INTEGER: + mpz_out_str (stdout, 10, p->value.integer); + + if (p->ts.kind != gfc_default_integer_kind ()) + gfc_status ("_%d", p->ts.kind); + break; + + case BT_LOGICAL: + if (p->value.logical) + gfc_status (".true."); + else + gfc_status (".false."); + break; + + case BT_REAL: + mpf_out_str (stdout, 10, 0, p->value.real); + if (p->ts.kind != gfc_default_real_kind ()) + gfc_status ("_%d", p->ts.kind); + break; + + case BT_CHARACTER: + c = p->value.character.string; + + gfc_status_char ('\''); + + for (i = 0; i < p->value.character.length; i++, c++) + { + if (*c == '\'') + gfc_status ("''"); + else + gfc_status_char (*c); + } + + gfc_status_char ('\''); + + break; + + case BT_COMPLEX: + gfc_status ("(complex "); + + mpf_out_str (stdout, 10, 0, p->value.complex.r); + if (p->ts.kind != gfc_default_complex_kind ()) + gfc_status ("_%d", p->ts.kind); + + gfc_status (" "); + + mpf_out_str (stdout, 10, 0, p->value.complex.i); + if (p->ts.kind != gfc_default_complex_kind ()) + gfc_status ("_%d", p->ts.kind); + + gfc_status (")"); + break; + + default: + gfc_status ("???"); + break; + } + + break; + + case EXPR_VARIABLE: + gfc_status ("%s", p->symtree->n.sym->name); + gfc_show_ref (p->ref); + break; + + case EXPR_OP: + gfc_status ("("); + switch (p->operator) + { + case INTRINSIC_UPLUS: + gfc_status ("U+ "); + break; + case INTRINSIC_UMINUS: + gfc_status ("U- "); + break; + case INTRINSIC_PLUS: + gfc_status ("+ "); + break; + case INTRINSIC_MINUS: + gfc_status ("- "); + break; + case INTRINSIC_TIMES: + gfc_status ("* "); + break; + case INTRINSIC_DIVIDE: + gfc_status ("/ "); + break; + case INTRINSIC_POWER: + gfc_status ("** "); + break; + case INTRINSIC_CONCAT: + gfc_status ("// "); + break; + case INTRINSIC_AND: + gfc_status ("AND "); + break; + case INTRINSIC_OR: + gfc_status ("OR "); + break; + case INTRINSIC_EQV: + gfc_status ("EQV "); + break; + case INTRINSIC_NEQV: + gfc_status ("NEQV "); + break; + case INTRINSIC_EQ: + gfc_status ("= "); + break; + case INTRINSIC_NE: + gfc_status ("<> "); + break; + case INTRINSIC_GT: + gfc_status ("> "); + break; + case INTRINSIC_GE: + gfc_status (">= "); + break; + case INTRINSIC_LT: + gfc_status ("< "); + break; + case INTRINSIC_LE: + gfc_status ("<= "); + break; + case INTRINSIC_NOT: + gfc_status ("NOT "); + break; + + default: + gfc_internal_error + ("gfc_show_expr(): Bad intrinsic in expression!"); + } + + gfc_show_expr (p->op1); + + if (p->op2) + { + gfc_status (" "); + gfc_show_expr (p->op2); + } + + gfc_status (")"); + break; + + case EXPR_FUNCTION: + if (p->value.function.name == NULL) + { + gfc_status ("%s[", p->symtree->n.sym->name); + gfc_show_actual_arglist (p->value.function.actual); + gfc_status_char (']'); + } + else + { + gfc_status ("%s[[", p->value.function.name); + gfc_show_actual_arglist (p->value.function.actual); + gfc_status_char (']'); + gfc_status_char (']'); + } + + break; + + default: + gfc_internal_error ("gfc_show_expr(): Don't know how to show expr"); + } +} + + +/* Show symbol attributes. The flavor and intent are followed by + whatever single bit attributes are present. */ + +static void +gfc_show_attr (symbol_attribute * attr) +{ + + gfc_status ("(%s %s %s %s", gfc_code2string (flavors, attr->flavor), + gfc_intent_string (attr->intent), + gfc_code2string (access_types, attr->access), + gfc_code2string (procedures, attr->proc)); + + if (attr->allocatable) + gfc_status (" ALLOCATABLE"); + if (attr->dimension) + gfc_status (" DIMENSION"); + if (attr->external) + gfc_status (" EXTERNAL"); + if (attr->intrinsic) + gfc_status (" INTRINSIC"); + if (attr->optional) + gfc_status (" OPTIONAL"); + if (attr->pointer) + gfc_status (" POINTER"); + if (attr->save) + gfc_status (" SAVE"); + if (attr->target) + gfc_status (" TARGET"); + if (attr->dummy) + gfc_status (" DUMMY"); + if (attr->common) + gfc_status (" COMMON"); + if (attr->result) + gfc_status (" RESULT"); + if (attr->entry) + gfc_status (" ENTRY"); + + if (attr->data) + gfc_status (" DATA"); + if (attr->use_assoc) + gfc_status (" USE-ASSOC"); + if (attr->in_namelist) + gfc_status (" IN-NAMELIST"); + if (attr->in_common) + gfc_status (" IN-COMMON"); + if (attr->saved_common) + gfc_status (" SAVED-COMMON"); + + if (attr->function) + gfc_status (" FUNCTION"); + if (attr->subroutine) + gfc_status (" SUBROUTINE"); + if (attr->implicit_type) + gfc_status (" IMPLICIT-TYPE"); + + if (attr->sequence) + gfc_status (" SEQUENCE"); + if (attr->elemental) + gfc_status (" ELEMENTAL"); + if (attr->pure) + gfc_status (" PURE"); + if (attr->recursive) + gfc_status (" RECURSIVE"); + + gfc_status (")"); +} + + +/* Show components of a derived type. */ + +static void +gfc_show_components (gfc_symbol * sym) +{ + gfc_component *c; + + for (c = sym->components; c; c = c->next) + { + gfc_status ("(%s ", c->name); + gfc_show_typespec (&c->ts); + if (c->pointer) + gfc_status (" POINTER"); + if (c->dimension) + gfc_status (" DIMENSION"); + gfc_status_char (' '); + gfc_show_array_spec (c->as); + gfc_status (")"); + if (c->next != NULL) + gfc_status_char (' '); + } +} + + +/* Show a symbol. If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we + show the interface. Information needed to reconstruct the list of + specific interfaces associated with a generic symbol is done within + that symbol. */ + +static void +gfc_show_symbol (gfc_symbol * sym) +{ + gfc_formal_arglist *formal; + gfc_interface *intr; + gfc_symbol *s; + + if (sym == NULL) + return; + + show_indent (); + + gfc_status ("symbol %s ", sym->name); + gfc_show_typespec (&sym->ts); + gfc_show_attr (&sym->attr); + + if (sym->value) + { + show_indent (); + gfc_status ("value: "); + gfc_show_expr (sym->value); + } + + if (sym->as) + { + show_indent (); + gfc_status ("Array spec:"); + gfc_show_array_spec (sym->as); + } + + if (sym->generic) + { + show_indent (); + gfc_status ("Generic interfaces:"); + for (intr = sym->generic; intr; intr = intr->next) + gfc_status (" %s", intr->sym->name); + } + + if (sym->common_head) + { + show_indent (); + gfc_status ("Common members:"); + for (s = sym->common_head; s; s = s->common_next) + gfc_status (" %s", s->name); + } + + if (sym->result) + { + show_indent (); + gfc_status ("result: %s", sym->result->name); + } + + if (sym->components) + { + show_indent (); + gfc_status ("components: "); + gfc_show_components (sym); + } + + if (sym->formal) + { + show_indent (); + gfc_status ("Formal arglist:"); + + for (formal = sym->formal; formal; formal = formal->next) + gfc_status (" %s", formal->sym->name); + } + + if (sym->formal_ns) + { + show_indent (); + gfc_status ("Formal namespace"); + gfc_show_namespace (sym->formal_ns); + } + + gfc_status_char ('\n'); +} + + +/* Show a user-defined operator. Just prints an operator + and the name of the associated subroutine, really. */ +static void +show_uop (gfc_user_op * uop) +{ + gfc_interface *intr; + + show_indent (); + gfc_status ("%s:", uop->name); + + for (intr = uop->operator; intr; intr = intr->next) + gfc_status (" %s", intr->sym->name); +} + + +/* Workhorse function for traversing the user operator symtree. */ + +static void +traverse_uop (gfc_symtree * st, void (*func) (gfc_user_op *)) +{ + + if (st == NULL) + return; + + (*func) (st->n.uop); + + traverse_uop (st->left, func); + traverse_uop (st->right, func); +} + + +/* Traverse the tree of user operator nodes. */ + +void +gfc_traverse_user_op (gfc_namespace * ns, void (*func) (gfc_user_op *)) +{ + + traverse_uop (ns->uop_root, func); +} + + +/* Worker function to display the symbol tree. */ + +static void +show_symtree (gfc_symtree * st) +{ + + show_indent (); + gfc_status ("symtree: %s Ambig %d", st->name, st->ambiguous); + + if (st->n.sym->ns != gfc_current_ns) + gfc_status (" from namespace %s", st->n.sym->ns->proc_name->name); + else + gfc_show_symbol (st->n.sym); +} + + +/******************* Show gfc_code structures **************/ + + + +static void gfc_show_code_node (int level, gfc_code * c); + +/* Show a list of code structures. Mutually recursive with + gfc_show_code_node(). */ + +static void +gfc_show_code (int level, gfc_code * c) +{ + + for (; c; c = c->next) + gfc_show_code_node (level, c); +} + + +/* Show a single code node and everything underneath it if necessary. */ + +static void +gfc_show_code_node (int level, gfc_code * c) +{ + gfc_forall_iterator *fa; + gfc_open *open; + gfc_case *cp; + gfc_alloc *a; + gfc_code *d; + gfc_close *close; + gfc_filepos *fp; + gfc_inquire *i; + gfc_dt *dt; + + code_indent (level, c->here); + + switch (c->op) + { + case EXEC_NOP: + gfc_status ("NOP"); + break; + + case EXEC_CONTINUE: + gfc_status ("CONTINUE"); + break; + + case EXEC_ASSIGN: + gfc_status ("ASSIGN "); + gfc_show_expr (c->expr); + gfc_status_char (' '); + gfc_show_expr (c->expr2); + break; + case EXEC_LABEL_ASSIGN: + gfc_status ("LABEL ASSIGN "); + gfc_show_expr (c->expr); + gfc_status (" %d", c->label->value); + break; + + case EXEC_POINTER_ASSIGN: + gfc_status ("POINTER ASSIGN "); + gfc_show_expr (c->expr); + gfc_status_char (' '); + gfc_show_expr (c->expr2); + break; + + case EXEC_GOTO: + gfc_status ("GOTO "); + if (c->label) + gfc_status ("%d", c->label->value); + else + { + gfc_show_expr (c->expr); + d = c->block; + if (d != NULL) + { + gfc_status (", ("); + for (; d; d = d ->block) + { + code_indent (level, d->label); + if (d->block != NULL) + gfc_status_char (','); + else + gfc_status_char (')'); + } + } + } + break; + + case EXEC_CALL: + gfc_status ("CALL %s ", c->resolved_sym->name); + gfc_show_actual_arglist (c->ext.actual); + break; + + case EXEC_RETURN: + gfc_status ("RETURN "); + if (c->expr) + gfc_show_expr (c->expr); + break; + + case EXEC_PAUSE: + gfc_status ("PAUSE "); + + if (c->expr != NULL) + gfc_show_expr (c->expr); + else + gfc_status ("%d", c->ext.stop_code); + + break; + + case EXEC_STOP: + gfc_status ("STOP "); + + if (c->expr != NULL) + gfc_show_expr (c->expr); + else + gfc_status ("%d", c->ext.stop_code); + + break; + + case EXEC_ARITHMETIC_IF: + gfc_status ("IF "); + gfc_show_expr (c->expr); + gfc_status (" %d, %d, %d", + c->label->value, c->label2->value, c->label3->value); + break; + + case EXEC_IF: + d = c->block; + gfc_status ("IF "); + gfc_show_expr (d->expr); + gfc_status_char ('\n'); + gfc_show_code (level + 1, d->next); + + d = d->block; + for (; d; d = d->block) + { + code_indent (level, 0); + + if (d->expr == NULL) + gfc_status ("ELSE\n"); + else + { + gfc_status ("ELSE IF "); + gfc_show_expr (d->expr); + gfc_status_char ('\n'); + } + + gfc_show_code (level + 1, d->next); + } + + code_indent (level, c->label); + + gfc_status ("ENDIF"); + break; + + case EXEC_SELECT: + d = c->block; + gfc_status ("SELECT CASE "); + gfc_show_expr (c->expr); + gfc_status_char ('\n'); + + for (; d; d = d->block) + { + code_indent (level, 0); + + gfc_status ("CASE "); + for (cp = d->ext.case_list; cp; cp = cp->next) + { + gfc_status_char ('('); + gfc_show_expr (cp->low); + gfc_status_char (' '); + gfc_show_expr (cp->high); + gfc_status_char (')'); + gfc_status_char (' '); + } + gfc_status_char ('\n'); + + gfc_show_code (level + 1, d->next); + } + + code_indent (level, c->label); + gfc_status ("END SELECT"); + break; + + case EXEC_WHERE: + gfc_status ("WHERE "); + + d = c->block; + gfc_show_expr (d->expr); + gfc_status_char ('\n'); + + gfc_show_code (level + 1, d->next); + + for (d = d->block; d; d = d->block) + { + code_indent (level, 0); + gfc_status ("ELSE WHERE "); + gfc_show_expr (d->expr); + gfc_status_char ('\n'); + gfc_show_code (level + 1, d->next); + } + + code_indent (level, 0); + gfc_status ("END WHERE"); + break; + + + case EXEC_FORALL: + gfc_status ("FORALL "); + for (fa = c->ext.forall_iterator; fa; fa = fa->next) + { + gfc_show_expr (fa->var); + gfc_status_char (' '); + gfc_show_expr (fa->start); + gfc_status_char (':'); + gfc_show_expr (fa->end); + gfc_status_char (':'); + gfc_show_expr (fa->stride); + + if (fa->next != NULL) + gfc_status_char (','); + } + + if (c->expr != NULL) + { + gfc_status_char (','); + gfc_show_expr (c->expr); + } + gfc_status_char ('\n'); + + gfc_show_code (level + 1, c->block->next); + + code_indent (level, 0); + gfc_status ("END FORALL"); + break; + + case EXEC_DO: + gfc_status ("DO "); + + gfc_show_expr (c->ext.iterator->var); + gfc_status_char ('='); + gfc_show_expr (c->ext.iterator->start); + gfc_status_char (' '); + gfc_show_expr (c->ext.iterator->end); + gfc_status_char (' '); + gfc_show_expr (c->ext.iterator->step); + gfc_status_char ('\n'); + + gfc_show_code (level + 1, c->block->next); + + code_indent (level, 0); + gfc_status ("END DO"); + break; + + case EXEC_DO_WHILE: + gfc_status ("DO WHILE "); + gfc_show_expr (c->expr); + gfc_status_char ('\n'); + + gfc_show_code (level + 1, c->block->next); + + code_indent (level, c->label); + gfc_status ("END DO"); + break; + + case EXEC_CYCLE: + gfc_status ("CYCLE"); + if (c->symtree) + gfc_status (" %s", c->symtree->n.sym->name); + break; + + case EXEC_EXIT: + gfc_status ("EXIT"); + if (c->symtree) + gfc_status (" %s", c->symtree->n.sym->name); + break; + + case EXEC_ALLOCATE: + gfc_status ("ALLOCATE "); + if (c->expr) + { + gfc_status (" STAT="); + gfc_show_expr (c->expr); + } + + for (a = c->ext.alloc_list; a; a = a->next) + { + gfc_status_char (' '); + gfc_show_expr (a->expr); + } + + break; + + case EXEC_DEALLOCATE: + gfc_status ("DEALLOCATE "); + if (c->expr) + { + gfc_status (" STAT="); + gfc_show_expr (c->expr); + } + + for (a = c->ext.alloc_list; a; a = a->next) + { + gfc_status_char (' '); + gfc_show_expr (a->expr); + } + + break; + + case EXEC_OPEN: + gfc_status ("OPEN"); + open = c->ext.open; + + if (open->unit) + { + gfc_status (" UNIT="); + gfc_show_expr (open->unit); + } + if (open->iostat) + { + gfc_status (" IOSTAT="); + gfc_show_expr (open->iostat); + } + if (open->file) + { + gfc_status (" FILE="); + gfc_show_expr (open->file); + } + if (open->status) + { + gfc_status (" STATUS="); + gfc_show_expr (open->status); + } + if (open->access) + { + gfc_status (" ACCESS="); + gfc_show_expr (open->access); + } + if (open->form) + { + gfc_status (" FORM="); + gfc_show_expr (open->form); + } + if (open->recl) + { + gfc_status (" RECL="); + gfc_show_expr (open->recl); + } + if (open->blank) + { + gfc_status (" BLANK="); + gfc_show_expr (open->blank); + } + if (open->position) + { + gfc_status (" POSITION="); + gfc_show_expr (open->position); + } + if (open->action) + { + gfc_status (" ACTION="); + gfc_show_expr (open->action); + } + if (open->delim) + { + gfc_status (" DELIM="); + gfc_show_expr (open->delim); + } + if (open->pad) + { + gfc_status (" PAD="); + gfc_show_expr (open->pad); + } + if (open->err != NULL) + gfc_status (" ERR=%d", open->err->value); + + break; + + case EXEC_CLOSE: + gfc_status ("CLOSE"); + close = c->ext.close; + + if (close->unit) + { + gfc_status (" UNIT="); + gfc_show_expr (close->unit); + } + if (close->iostat) + { + gfc_status (" IOSTAT="); + gfc_show_expr (close->iostat); + } + if (close->status) + { + gfc_status (" STATUS="); + gfc_show_expr (close->status); + } + if (close->err != NULL) + gfc_status (" ERR=%d", close->err->value); + break; + + case EXEC_BACKSPACE: + gfc_status ("BACKSPACE"); + goto show_filepos; + + case EXEC_ENDFILE: + gfc_status ("ENDFILE"); + goto show_filepos; + + case EXEC_REWIND: + gfc_status ("REWIND"); + + show_filepos: + fp = c->ext.filepos; + + if (fp->unit) + { + gfc_status (" UNIT="); + gfc_show_expr (fp->unit); + } + if (fp->iostat) + { + gfc_status (" IOSTAT="); + gfc_show_expr (fp->iostat); + } + if (fp->err != NULL) + gfc_status (" ERR=%d", fp->err->value); + break; + + case EXEC_INQUIRE: + gfc_status ("INQUIRE"); + i = c->ext.inquire; + + if (i->unit) + { + gfc_status (" UNIT="); + gfc_show_expr (i->unit); + } + if (i->file) + { + gfc_status (" FILE="); + gfc_show_expr (i->file); + } + + if (i->iostat) + { + gfc_status (" IOSTAT="); + gfc_show_expr (i->iostat); + } + if (i->exist) + { + gfc_status (" EXIST="); + gfc_show_expr (i->exist); + } + if (i->opened) + { + gfc_status (" OPENED="); + gfc_show_expr (i->opened); + } + if (i->number) + { + gfc_status (" NUMBER="); + gfc_show_expr (i->number); + } + if (i->named) + { + gfc_status (" NAMED="); + gfc_show_expr (i->named); + } + if (i->name) + { + gfc_status (" NAME="); + gfc_show_expr (i->name); + } + if (i->access) + { + gfc_status (" ACCESS="); + gfc_show_expr (i->access); + } + if (i->sequential) + { + gfc_status (" SEQUENTIAL="); + gfc_show_expr (i->sequential); + } + + if (i->direct) + { + gfc_status (" DIRECT="); + gfc_show_expr (i->direct); + } + if (i->form) + { + gfc_status (" FORM="); + gfc_show_expr (i->form); + } + if (i->formatted) + { + gfc_status (" FORMATTED"); + gfc_show_expr (i->formatted); + } + if (i->unformatted) + { + gfc_status (" UNFORMATTED="); + gfc_show_expr (i->unformatted); + } + if (i->recl) + { + gfc_status (" RECL="); + gfc_show_expr (i->recl); + } + if (i->nextrec) + { + gfc_status (" NEXTREC="); + gfc_show_expr (i->nextrec); + } + if (i->blank) + { + gfc_status (" BLANK="); + gfc_show_expr (i->blank); + } + if (i->position) + { + gfc_status (" POSITION="); + gfc_show_expr (i->position); + } + if (i->action) + { + gfc_status (" ACTION="); + gfc_show_expr (i->action); + } + if (i->read) + { + gfc_status (" READ="); + gfc_show_expr (i->read); + } + if (i->write) + { + gfc_status (" WRITE="); + gfc_show_expr (i->write); + } + if (i->readwrite) + { + gfc_status (" READWRITE="); + gfc_show_expr (i->readwrite); + } + if (i->delim) + { + gfc_status (" DELIM="); + gfc_show_expr (i->delim); + } + if (i->pad) + { + gfc_status (" PAD="); + gfc_show_expr (i->pad); + } + + if (i->err != NULL) + gfc_status (" ERR=%d", i->err->value); + break; + + case EXEC_IOLENGTH: + gfc_status ("IOLENGTH "); + gfc_show_expr (c->expr); + break; + + case EXEC_READ: + gfc_status ("READ"); + goto show_dt; + + case EXEC_WRITE: + gfc_status ("WRITE"); + + show_dt: + dt = c->ext.dt; + if (dt->io_unit) + { + gfc_status (" UNIT="); + gfc_show_expr (dt->io_unit); + } + + if (dt->format_expr) + { + gfc_status (" FMT="); + gfc_show_expr (dt->format_expr); + } + + if (dt->format_label != NULL) + gfc_status (" FMT=%d", dt->format_label->value); + if (dt->namelist) + gfc_status (" NML=%s", dt->namelist->name); + if (dt->iostat) + { + gfc_status (" IOSTAT="); + gfc_show_expr (dt->iostat); + } + if (dt->size) + { + gfc_status (" SIZE="); + gfc_show_expr (dt->size); + } + if (dt->rec) + { + gfc_status (" REC="); + gfc_show_expr (dt->rec); + } + if (dt->advance) + { + gfc_status (" ADVANCE="); + gfc_show_expr (dt->advance); + } + + break; + + case EXEC_TRANSFER: + gfc_status ("TRANSFER "); + gfc_show_expr (c->expr); + break; + + case EXEC_DT_END: + gfc_status ("DT_END"); + dt = c->ext.dt; + + if (dt->err != NULL) + gfc_status (" ERR=%d", dt->err->value); + if (dt->end != NULL) + gfc_status (" END=%d", dt->end->value); + if (dt->eor != NULL) + gfc_status (" EOR=%d", dt->eor->value); + break; + + default: + gfc_internal_error ("gfc_show_code_node(): Bad statement code"); + } + + gfc_status_char ('\n'); +} + + +/* Show a freakin' whole namespace. */ + +void +gfc_show_namespace (gfc_namespace * ns) +{ + gfc_interface *intr; + gfc_namespace *save; + gfc_intrinsic_op op; + int i; + + save = gfc_current_ns; + show_level++; + + show_indent (); + gfc_status ("Namespace:"); + + if (ns != NULL) + { + i = 0; + do + { + int l = i; + while (i < GFC_LETTERS - 1 + && gfc_compare_types(&ns->default_type[i+1], + &ns->default_type[l])) + i++; + + if (i > l) + gfc_status(" %c-%c: ", l+'A', i+'A'); + else + gfc_status(" %c: ", l+'A'); + + gfc_show_typespec(&ns->default_type[l]); + i++; + } while (i < GFC_LETTERS); + + if (ns->proc_name != NULL) + { + show_indent (); + gfc_status ("procedure name = %s", ns->proc_name->name); + } + + gfc_current_ns = ns; + gfc_traverse_symtree (ns, show_symtree); + + for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++) + { + /* User operator interfaces */ + intr = ns->operator[op]; + if (intr == NULL) + continue; + + show_indent (); + gfc_status ("Operator interfaces for %s:", gfc_op2string (op)); + + for (; intr; intr = intr->next) + gfc_status (" %s", intr->sym->name); + } + + if (ns->uop_root != NULL) + { + show_indent (); + gfc_status ("User operators:\n"); + gfc_traverse_user_op (ns, show_uop); + } + } + + gfc_status_char ('\n'); + gfc_status_char ('\n'); + + gfc_show_code (0, ns->code); + + for (ns = ns->contained; ns; ns = ns->sibling) + { + show_indent (); + gfc_status ("CONTAINS\n"); + gfc_show_namespace (ns); + } + + show_level--; + gfc_status_char ('\n'); + gfc_current_ns = save; +} diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c new file mode 100644 index 00000000000..be3d991f55d --- /dev/null +++ b/gcc/fortran/error.c @@ -0,0 +1,750 @@ +/* Handle errors. + Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. + Contributed by Andy Vaught & Niels Kristian Bech Jensen + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Handle the inevitable errors. A major catch here is that things + flagged as errors in one match subroutine can conceivably be legal + elsewhere. This means that error messages are recorded and saved + for possible use later. If a line does not match a legal + construction, then the saved error message is reported. */ + +#include "config.h" +#include "system.h" + +#include <string.h> +#include <stdarg.h> +#include <stdio.h> +#include <stdlib.h> + +#include "flags.h" +#include "gfortran.h" + +int gfc_suppress_error = 0; + +static int terminal_width, buffer_flag, errors, + use_warning_buffer, warnings; + +static char *error_ptr, *warning_ptr; + +static gfc_error_buf error_buffer, warning_buffer; + + +/* Per-file error initialization. */ + +void +gfc_error_init_1 (void) +{ + + terminal_width = gfc_terminal_width(); + errors = 0; + warnings = 0; + buffer_flag = 0; +} + + +/* Set the flag for buffering errors or not. */ + +void +gfc_buffer_error (int flag) +{ + + buffer_flag = flag; +} + + +/* Add a single character to the error buffer or output depending on + buffer_flag. */ + +static void +error_char (char c) +{ + + if (buffer_flag) + { + if (use_warning_buffer) + { + *warning_ptr++ = c; + if (warning_ptr - warning_buffer.message >= MAX_ERROR_MESSAGE) + gfc_internal_error ("error_char(): Warning buffer overflow"); + } + else + { + *error_ptr++ = c; + if (error_ptr - error_buffer.message >= MAX_ERROR_MESSAGE) + gfc_internal_error ("error_char(): Error buffer overflow"); + } + } + else + { + if (c != 0) + fputc (c, stderr); + } +} + + +/* Copy a string to wherever it needs to go. */ + +static void +error_string (const char *p) +{ + + while (*p) + error_char (*p++); +} + + +/* Show the file, where it was included and the source line give a + locus. Calls error_printf() recursively, but the recursion is at + most one level deep. */ + +static void error_printf (const char *, ...) ATTRIBUTE_PRINTF_1; + +static void +show_locus (int offset, locus * l) +{ + gfc_file *f; + char c, *p; + int i, m; + + /* TODO: Either limit the total length and number of included files + displayed or add buffering of arbitrary number of characters in + error messages. */ + f = l->file; + error_printf ("In file %s:%d\n", f->filename, l->lp->start_line + l->line); + + f = f->included_by; + while (f != NULL) + { + error_printf (" Included at %s:%d\n", f->filename, + f->loc.lp->start_line + f->loc.line); + f = f->included_by; + } + + /* Show the line itself, taking care not to print more than what can + show up on the terminal. Tabs are converted to spaces. */ + p = l->lp->line[l->line] + offset; + i = strlen (p); + if (i > terminal_width) + i = terminal_width - 1; + + for (; i > 0; i--) + { + c = *p++; + if (c == '\t') + c = ' '; + + if (ISPRINT (c)) + error_char (c); + else + { + error_char ('\\'); + error_char ('x'); + + m = ((c >> 4) & 0x0F) + '0'; + if (m > '9') + m += 'A' - '9' - 1; + error_char (m); + + m = (c & 0x0F) + '0'; + if (m > '9') + m += 'A' - '9' - 1; + error_char (m); + } + } + + error_char ('\n'); +} + + +/* As part of printing an error, we show the source lines that caused + the problem. We show at least one, possibly two loci. If we're + showing two loci and they both refer to the same file and line, we + only print the line once. */ + +static void +show_loci (locus * l1, locus * l2) +{ + int offset, flag, i, m, c1, c2, cmax; + + if (l1 == NULL) + { + error_printf ("<During initialization>\n"); + return; + } + + c1 = l1->nextc - l1->lp->line[l1->line]; + c2 = 0; + if (l2 == NULL) + goto separate; + + c2 = l2->nextc - l2->lp->line[l2->line]; + + if (c1 < c2) + m = c2 - c1; + else + m = c1 - c2; + + + if (l1->lp != l2->lp || l1->line != l2->line || m > terminal_width - 10) + goto separate; + + offset = 0; + cmax = (c1 < c2) ? c2 : c1; + if (cmax > terminal_width - 5) + offset = cmax - terminal_width + 5; + + if (offset < 0) + offset = 0; + + c1 -= offset; + c2 -= offset; + + show_locus (offset, l1); + + /* Arrange that '1' and '2' will show up even if the two columns are equal. */ + for (i = 1; i <= cmax; i++) + { + flag = 0; + if (i == c1) + { + error_char ('1'); + flag = 1; + } + if (i == c2) + { + error_char ('2'); + flag = 1; + } + if (flag == 0) + error_char (' '); + } + + error_char ('\n'); + + return; + +separate: + offset = 0; + + if (c1 > terminal_width - 5) + { + offset = c1 - 5; + if (offset < 0) + offset = 0; + c1 = c1 - offset; + } + + show_locus (offset, l1); + for (i = 1; i < c1; i++) + error_char (' '); + + error_char ('1'); + error_char ('\n'); + + if (l2 != NULL) + { + offset = 0; + + if (c2 > terminal_width - 20) + { + offset = c2 - 20; + if (offset < 0) + offset = 0; + c2 = c2 - offset; + } + + show_locus (offset, l2); + + for (i = 1; i < c2; i++) + error_char (' '); + + error_char ('2'); + error_char ('\n'); + } +} + + +/* Workhorse for the error printing subroutines. This subroutine is + inspired by g77's error handling and is similar to printf() with + the following %-codes: + + %c Character, %d Integer, %s String, %% Percent + %L Takes locus argument + %C Current locus (no argument) + + If a locus pointer is given, the actual source line is printed out + and the column is indicated. Since we want the error message at + the bottom of any source file information, we must scan the + argument list twice. A maximum of two locus arguments are + permitted. */ + +#define IBUF_LEN 30 +#define MAX_ARGS 10 + +static void +error_print (const char *type, const char *format0, va_list argp) +{ + char c, *p, int_buf[IBUF_LEN], c_arg[MAX_ARGS], *cp_arg[MAX_ARGS]; + int i, n, have_l1, i_arg[MAX_ARGS]; + locus *l1, *l2, *loc; + const char *format; + + l1 = l2 = loc = NULL; + + have_l1 = 0; + + n = 0; + format = format0; + + while (*format) + { + c = *format++; + if (c == '%') + { + c = *format++; + + switch (c) + { + case '%': + break; + + case 'L': + loc = va_arg (argp, locus *); + /* Fall through */ + + case 'C': + if (c == 'C') + loc = gfc_current_locus (); + + if (have_l1) + { + l2 = loc; + } + else + { + l1 = loc; + have_l1 = 1; + } + break; + + case 'd': + case 'i': + i_arg[n++] = va_arg (argp, int); + break; + + case 'c': + c_arg[n++] = va_arg (argp, int); + break; + + case 's': + cp_arg[n++] = va_arg (argp, char *); + break; + } + } + } + + /* Show the current loci if we have to. */ + if (have_l1) + show_loci (l1, l2); + error_string (type); + error_char (' '); + + have_l1 = 0; + format = format0; + n = 0; + + for (; *format; format++) + { + if (*format != '%') + { + error_char (*format); + continue; + } + + format++; + switch (*format) + { + case '%': + error_char ('%'); + break; + + case 'c': + error_char (c_arg[n++]); + break; + + case 's': + error_string (cp_arg[n++]); + break; + + case 'i': + case 'd': + i = i_arg[n++]; + + if (i < 0) + { + i = -i; + error_char ('-'); + } + + p = int_buf + IBUF_LEN - 1; + *p-- = '\0'; + + if (i == 0) + *p-- = '0'; + + while (i > 0) + { + *p-- = i % 10 + '0'; + i = i / 10; + } + + error_string (p + 1); + break; + + case 'C': /* Current locus */ + case 'L': /* Specified locus */ + error_string (have_l1 ? "(2)" : "(1)"); + have_l1 = 1; + break; + } + } + + error_char ('\n'); +} + + +/* Wrapper for error_print(). */ + +static void +error_printf (const char *format, ...) +{ + va_list argp; + + va_start (argp, format); + error_print ("", format, argp); + va_end (argp); +} + + +/* Issue a warning. */ + +void +gfc_warning (const char *format, ...) +{ + va_list argp; + + if (inhibit_warnings) + return; + + warning_buffer.flag = 1; + warning_ptr = warning_buffer.message; + use_warning_buffer = 1; + + va_start (argp, format); + if (buffer_flag == 0) + warnings++; + error_print ("Warning:", format, argp); + va_end (argp); + + error_char ('\0'); +} + + +/* Possibly issue a warning/error about use of a nonstandard (or deleted) + feature. An error/warning will be issued if the currently selected + standard does not contain the requested bits. Return FAILURE if + and error is generated. */ + +try +gfc_notify_std (int std, const char *format, ...) +{ + va_list argp; + bool warning; + + warning = ((gfc_option.warn_std & std) != 0) + && !inhibit_warnings; + if ((gfc_option.allow_std & std) != 0 + && !warning) + return SUCCESS; + + if (gfc_suppress_error) + return warning ? SUCCESS : FAILURE; + + if (warning) + { + warning_buffer.flag = 1; + warning_ptr = warning_buffer.message; + use_warning_buffer = 1; + } + else + { + error_buffer.flag = 1; + error_ptr = error_buffer.message; + use_warning_buffer = 0; + } + + if (buffer_flag == 0) + { + if (warning) + warnings++; + else + errors++; + } + va_start (argp, format); + if (warning) + error_print ("Warning:", format, argp); + else + error_print ("Error:", format, argp); + va_end (argp); + + error_char ('\0'); + return warning ? SUCCESS : FAILURE; +} + + +/* Immediate warning (i.e. do not buffer the warning). */ + +void +gfc_warning_now (const char *format, ...) +{ + va_list argp; + int i; + + if (inhibit_warnings) + return; + + i = buffer_flag; + buffer_flag = 0; + warnings++; + + va_start (argp, format); + error_print ("Warning:", format, argp); + va_end (argp); + + error_char ('\0'); + buffer_flag = i; +} + + +/* Clear the warning flag. */ + +void +gfc_clear_warning (void) +{ + + warning_buffer.flag = 0; +} + + +/* Check to see if any warnings have been saved. + If so, print the warning. */ + +void +gfc_warning_check (void) +{ + + if (warning_buffer.flag) + { + warnings++; + fputs (warning_buffer.message, stderr); + warning_buffer.flag = 0; + } +} + + +/* Issue an error. */ + +void +gfc_error (const char *format, ...) +{ + va_list argp; + + if (gfc_suppress_error) + return; + + error_buffer.flag = 1; + error_ptr = error_buffer.message; + use_warning_buffer = 0; + + va_start (argp, format); + if (buffer_flag == 0) + errors++; + error_print ("Error:", format, argp); + va_end (argp); + + error_char ('\0'); +} + + +/* Immediate error. */ + +void +gfc_error_now (const char *format, ...) +{ + va_list argp; + int i; + + error_buffer.flag = 1; + error_ptr = error_buffer.message; + + i = buffer_flag; + buffer_flag = 0; + errors++; + + va_start (argp, format); + error_print ("Error:", format, argp); + va_end (argp); + + error_char ('\0'); + buffer_flag = i; +} + + +/* Fatal error, never returns. */ + +void +gfc_fatal_error (const char *format, ...) +{ + va_list argp; + + buffer_flag = 0; + + va_start (argp, format); + error_print ("Fatal Error:", format, argp); + va_end (argp); + + exit (3); +} + + +/* This shouldn't happen... but sometimes does. */ + +void +gfc_internal_error (const char *format, ...) +{ + va_list argp; + + buffer_flag = 0; + + va_start (argp, format); + + show_loci (gfc_current_locus (), NULL); + error_printf ("Internal Error at (1):"); + + error_print ("", format, argp); + va_end (argp); + + exit (4); +} + + +/* Clear the error flag when we start to compile a source line. */ + +void +gfc_clear_error (void) +{ + + error_buffer.flag = 0; +} + + +/* Check to see if any errors have been saved. + If so, print the error. Returns the state of error_flag. */ + +int +gfc_error_check (void) +{ + int rc; + + rc = error_buffer.flag; + + if (error_buffer.flag) + { + errors++; + fputs (error_buffer.message, stderr); + error_buffer.flag = 0; + } + + return rc; +} + + +/* Save the existing error state. */ + +void +gfc_push_error (gfc_error_buf * err) +{ + + err->flag = error_buffer.flag; + if (error_buffer.flag) + strcpy (err->message, error_buffer.message); + + error_buffer.flag = 0; +} + + +/* Restore a previous pushed error state. */ + +void +gfc_pop_error (gfc_error_buf * err) +{ + + error_buffer.flag = err->flag; + if (error_buffer.flag) + strcpy (error_buffer.message, err->message); +} + + +/* Debug wrapper for printf. */ + +void +gfc_status (const char *format, ...) +{ + va_list argp; + + va_start (argp, format); + + vprintf (format, argp); + + va_end (argp); +} + + +/* Subroutine for outputting a single char so that we don't have to go + around creating a lot of 1-character strings. */ + +void +gfc_status_char (char c) +{ + putchar (c); +} + + +/* Report the number of warnings and errors that occored to the caller. */ + +void +gfc_get_errors (int *w, int *e) +{ + + if (w != NULL) + *w = warnings; + if (e != NULL) + *e = errors; +} diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c new file mode 100644 index 00000000000..78a8dc29998 --- /dev/null +++ b/gcc/fortran/expr.c @@ -0,0 +1,1954 @@ +/* Routines for manipulation of expression nodes. + Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include "config.h" +#include <stdarg.h> +#include <stdio.h> +#include <string.h> + +#include "gfortran.h" +#include "arith.h" +#include "match.h" + +/* Get a new expr node. */ + +gfc_expr * +gfc_get_expr (void) +{ + gfc_expr *e; + + e = gfc_getmem (sizeof (gfc_expr)); + + gfc_clear_ts (&e->ts); + e->op1 = NULL; + e->op2 = NULL; + e->shape = NULL; + e->ref = NULL; + e->symtree = NULL; + e->uop = NULL; + + return e; +} + + +/* Free an argument list and everything below it. */ + +void +gfc_free_actual_arglist (gfc_actual_arglist * a1) +{ + gfc_actual_arglist *a2; + + while (a1) + { + a2 = a1->next; + gfc_free_expr (a1->expr); + gfc_free (a1); + a1 = a2; + } +} + + +/* Copy an arglist structure and all of the arguments. */ + +gfc_actual_arglist * +gfc_copy_actual_arglist (gfc_actual_arglist * p) +{ + gfc_actual_arglist *head, *tail, *new; + + head = tail = NULL; + + for (; p; p = p->next) + { + new = gfc_get_actual_arglist (); + *new = *p; + + new->expr = gfc_copy_expr (p->expr); + new->next = NULL; + + if (head == NULL) + head = new; + else + tail->next = new; + + tail = new; + } + + return head; +} + + +/* Free a list of reference structures. */ + +void +gfc_free_ref_list (gfc_ref * p) +{ + gfc_ref *q; + int i; + + for (; p; p = q) + { + q = p->next; + + switch (p->type) + { + case REF_ARRAY: + for (i = 0; i < GFC_MAX_DIMENSIONS; i++) + { + gfc_free_expr (p->u.ar.start[i]); + gfc_free_expr (p->u.ar.end[i]); + gfc_free_expr (p->u.ar.stride[i]); + } + + break; + + case REF_SUBSTRING: + gfc_free_expr (p->u.ss.start); + gfc_free_expr (p->u.ss.end); + break; + + case REF_COMPONENT: + break; + } + + gfc_free (p); + } +} + + +/* Workhorse function for gfc_free_expr() that frees everything + beneath an expression node, but not the node itself. This is + useful when we want to simplify a node and replace it with + something else or the expression node belongs to another structure. */ + +static void +free_expr0 (gfc_expr * e) +{ + int n; + + switch (e->expr_type) + { + case EXPR_CONSTANT: + switch (e->ts.type) + { + case BT_INTEGER: + mpz_clear (e->value.integer); + break; + + case BT_REAL: + mpf_clear (e->value.real); + break; + + case BT_CHARACTER: + gfc_free (e->value.character.string); + break; + + case BT_COMPLEX: + mpf_clear (e->value.complex.r); + mpf_clear (e->value.complex.i); + break; + + default: + break; + } + + break; + + case EXPR_OP: + if (e->op1 != NULL) + gfc_free_expr (e->op1); + if (e->op2 != NULL) + gfc_free_expr (e->op2); + break; + + case EXPR_FUNCTION: + gfc_free_actual_arglist (e->value.function.actual); + break; + + case EXPR_VARIABLE: + break; + + case EXPR_ARRAY: + case EXPR_STRUCTURE: + gfc_free_constructor (e->value.constructor); + break; + + case EXPR_SUBSTRING: + gfc_free (e->value.character.string); + break; + + case EXPR_NULL: + break; + + default: + gfc_internal_error ("free_expr0(): Bad expr type"); + } + + /* Free a shape array. */ + if (e->shape != NULL) + { + for (n = 0; n < e->rank; n++) + mpz_clear (e->shape[n]); + + gfc_free (e->shape); + } + + gfc_free_ref_list (e->ref); + + memset (e, '\0', sizeof (gfc_expr)); +} + + +/* Free an expression node and everything beneath it. */ + +void +gfc_free_expr (gfc_expr * e) +{ + + if (e == NULL) + return; + + free_expr0 (e); + gfc_free (e); +} + + +/* Graft the *src expression onto the *dest subexpression. */ + +void +gfc_replace_expr (gfc_expr * dest, gfc_expr * src) +{ + + free_expr0 (dest); + *dest = *src; + + gfc_free (src); +} + + +/* Try to extract an integer constant from the passed expression node. + Returns an error message or NULL if the result is set. It is + tempting to generate an error and return SUCCESS or FAILURE, but + failure is OK for some callers. */ + +const char * +gfc_extract_int (gfc_expr * expr, int *result) +{ + + if (expr->expr_type != EXPR_CONSTANT) + return "Constant expression required at %C"; + + if (expr->ts.type != BT_INTEGER) + return "Integer expression required at %C"; + + if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0) + || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0)) + { + return "Integer value too large in expression at %C"; + } + + *result = (int) mpz_get_si (expr->value.integer); + + return NULL; +} + + +/* Recursively copy a list of reference structures. */ + +static gfc_ref * +copy_ref (gfc_ref * src) +{ + gfc_array_ref *ar; + gfc_ref *dest; + + if (src == NULL) + return NULL; + + dest = gfc_get_ref (); + dest->type = src->type; + + switch (src->type) + { + case REF_ARRAY: + ar = gfc_copy_array_ref (&src->u.ar); + dest->u.ar = *ar; + gfc_free (ar); + break; + + case REF_COMPONENT: + dest->u.c = src->u.c; + break; + + case REF_SUBSTRING: + dest->u.ss = src->u.ss; + dest->u.ss.start = gfc_copy_expr (src->u.ss.start); + dest->u.ss.end = gfc_copy_expr (src->u.ss.end); + break; + } + + dest->next = copy_ref (src->next); + + return dest; +} + + +/* Copy a shape array. */ + +mpz_t * +gfc_copy_shape (mpz_t * shape, int rank) +{ + mpz_t *new_shape; + int n; + + if (shape == NULL) + return NULL; + + new_shape = gfc_get_shape (rank); + + for (n = 0; n < rank; n++) + mpz_init_set (new_shape[n], shape[n]); + + return new_shape; +} + + +/* Given an expression pointer, return a copy of the expression. This + subroutine is recursive. */ + +gfc_expr * +gfc_copy_expr (gfc_expr * p) +{ + gfc_expr *q; + char *s; + + if (p == NULL) + return NULL; + + q = gfc_get_expr (); + *q = *p; + + switch (q->expr_type) + { + case EXPR_SUBSTRING: + s = gfc_getmem (p->value.character.length + 1); + q->value.character.string = s; + + memcpy (s, p->value.character.string, p->value.character.length + 1); + + q->op1 = gfc_copy_expr (p->op1); + q->op2 = gfc_copy_expr (p->op2); + break; + + case EXPR_CONSTANT: + switch (q->ts.type) + { + case BT_INTEGER: + mpz_init_set (q->value.integer, p->value.integer); + break; + + case BT_REAL: + mpf_init_set (q->value.real, p->value.real); + break; + + case BT_COMPLEX: + mpf_init_set (q->value.complex.r, p->value.complex.r); + mpf_init_set (q->value.complex.i, p->value.complex.i); + break; + + case BT_CHARACTER: + s = gfc_getmem (p->value.character.length + 1); + q->value.character.string = s; + + memcpy (s, p->value.character.string, + p->value.character.length + 1); + break; + + case BT_LOGICAL: + case BT_DERIVED: + break; /* Already done */ + + case BT_PROCEDURE: + case BT_UNKNOWN: + gfc_internal_error ("gfc_copy_expr(): Bad expr node"); + /* Not reached */ + } + + break; + + case EXPR_OP: + switch (q->operator) + { + case INTRINSIC_NOT: + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + q->op1 = gfc_copy_expr (p->op1); + break; + + default: /* Binary operators */ + q->op1 = gfc_copy_expr (p->op1); + q->op2 = gfc_copy_expr (p->op2); + break; + } + + break; + + case EXPR_FUNCTION: + q->value.function.actual = + gfc_copy_actual_arglist (p->value.function.actual); + break; + + case EXPR_STRUCTURE: + case EXPR_ARRAY: + q->value.constructor = gfc_copy_constructor (p->value.constructor); + break; + + case EXPR_VARIABLE: + case EXPR_NULL: + break; + } + + q->shape = gfc_copy_shape (p->shape, p->rank); + + q->ref = copy_ref (p->ref); + + return q; +} + + +/* Return the maximum kind of two expressions. In general, higher + kind numbers mean more precision for numeric types. */ + +int +gfc_kind_max (gfc_expr * e1, gfc_expr * e2) +{ + + return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind; +} + + +/* Returns nonzero if the type is numeric, zero otherwise. */ + +static int +numeric_type (bt type) +{ + + return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER; +} + + +/* Returns nonzero if the typespec is a numeric type, zero otherwise. */ + +int +gfc_numeric_ts (gfc_typespec * ts) +{ + + return numeric_type (ts->type); +} + + +/* Returns an expression node that is an integer constant. */ + +gfc_expr * +gfc_int_expr (int i) +{ + gfc_expr *p; + + p = gfc_get_expr (); + + p->expr_type = EXPR_CONSTANT; + p->ts.type = BT_INTEGER; + p->ts.kind = gfc_default_integer_kind (); + + p->where = *gfc_current_locus (); + mpz_init_set_si (p->value.integer, i); + + return p; +} + + +/* Returns an expression node that is a logical constant. */ + +gfc_expr * +gfc_logical_expr (int i, locus * where) +{ + gfc_expr *p; + + p = gfc_get_expr (); + + p->expr_type = EXPR_CONSTANT; + p->ts.type = BT_LOGICAL; + p->ts.kind = gfc_default_logical_kind (); + + if (where == NULL) + where = gfc_current_locus (); + p->where = *where; + p->value.logical = i; + + return p; +} + + +/* Return an expression node with an optional argument list attached. + A variable number of gfc_expr pointers are strung together in an + argument list with a NULL pointer terminating the list. */ + +gfc_expr * +gfc_build_conversion (gfc_expr * e) +{ + gfc_expr *p; + + p = gfc_get_expr (); + p->expr_type = EXPR_FUNCTION; + p->symtree = NULL; + p->value.function.actual = NULL; + + p->value.function.actual = gfc_get_actual_arglist (); + p->value.function.actual->expr = e; + + return p; +} + + +/* Given an expression node with some sort of numeric binary + expression, insert type conversions required to make the operands + have the same type. + + The exception is that the operands of an exponential don't have to + have the same type. If possible, the base is promoted to the type + of the exponent. For example, 1**2.3 becomes 1.0**2.3, but + 1.0**2 stays as it is. */ + +void +gfc_type_convert_binary (gfc_expr * e) +{ + gfc_expr *op1, *op2; + + op1 = e->op1; + op2 = e->op2; + + if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN) + { + gfc_clear_ts (&e->ts); + return; + } + + /* Kind conversions of same type. */ + if (op1->ts.type == op2->ts.type) + { + + if (op1->ts.kind == op2->ts.kind) + { + /* No type conversions. */ + e->ts = op1->ts; + goto done; + } + + if (op1->ts.kind > op2->ts.kind) + gfc_convert_type (op2, &op1->ts, 2); + else + gfc_convert_type (op1, &op2->ts, 2); + + e->ts = op1->ts; + goto done; + } + + /* Integer combined with real or complex. */ + if (op2->ts.type == BT_INTEGER) + { + e->ts = op1->ts; + + /* Special cose for ** operator. */ + if (e->operator == INTRINSIC_POWER) + goto done; + + gfc_convert_type (e->op2, &e->ts, 2); + goto done; + } + + if (op1->ts.type == BT_INTEGER) + { + e->ts = op2->ts; + gfc_convert_type (e->op1, &e->ts, 2); + goto done; + } + + /* Real combined with complex. */ + e->ts.type = BT_COMPLEX; + if (op1->ts.kind > op2->ts.kind) + e->ts.kind = op1->ts.kind; + else + e->ts.kind = op2->ts.kind; + if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind) + gfc_convert_type (e->op1, &e->ts, 2); + if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind) + gfc_convert_type (e->op2, &e->ts, 2); + +done: + return; +} + + +/* Function to determine if an expression is constant or not. This + function expects that the expression has already been simplified. */ + +int +gfc_is_constant_expr (gfc_expr * e) +{ + gfc_constructor *c; + gfc_actual_arglist *arg; + int rv; + + if (e == NULL) + return 1; + + switch (e->expr_type) + { + case EXPR_OP: + rv = (gfc_is_constant_expr (e->op1) + && (e->op2 == NULL + || gfc_is_constant_expr (e->op2))); + + break; + + case EXPR_VARIABLE: + rv = 0; + break; + + case EXPR_FUNCTION: + /* Call to intrinsic with at least one argument. */ + rv = 0; + if (e->value.function.isym && e->value.function.actual) + { + for (arg = e->value.function.actual; arg; arg = arg->next) + { + if (!gfc_is_constant_expr (arg->expr)) + break; + } + if (arg == NULL) + rv = 1; + } + break; + + case EXPR_CONSTANT: + case EXPR_NULL: + rv = 1; + break; + + case EXPR_SUBSTRING: + rv = gfc_is_constant_expr (e->op1) && gfc_is_constant_expr (e->op2); + break; + + case EXPR_STRUCTURE: + rv = 0; + for (c = e->value.constructor; c; c = c->next) + if (!gfc_is_constant_expr (c->expr)) + break; + + if (c == NULL) + rv = 1; + break; + + case EXPR_ARRAY: + rv = gfc_constant_ac (e); + break; + + default: + gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type"); + } + + return rv; +} + + +/* Try to collapse intrinsic expressions. */ + +static try +simplify_intrinsic_op (gfc_expr * p, int type) +{ + gfc_expr *op1, *op2, *result; + + if (p->operator == INTRINSIC_USER) + return SUCCESS; + + op1 = p->op1; + op2 = p->op2; + + if (gfc_simplify_expr (op1, type) == FAILURE) + return FAILURE; + if (gfc_simplify_expr (op2, type) == FAILURE) + return FAILURE; + + if (!gfc_is_constant_expr (op1) + || (op2 != NULL && !gfc_is_constant_expr (op2))) + return SUCCESS; + + /* Rip p apart */ + p->op1 = NULL; + p->op2 = NULL; + + switch (p->operator) + { + case INTRINSIC_UPLUS: + result = gfc_uplus (op1); + break; + + case INTRINSIC_UMINUS: + result = gfc_uminus (op1); + break; + + case INTRINSIC_PLUS: + result = gfc_add (op1, op2); + break; + + case INTRINSIC_MINUS: + result = gfc_subtract (op1, op2); + break; + + case INTRINSIC_TIMES: + result = gfc_multiply (op1, op2); + break; + + case INTRINSIC_DIVIDE: + result = gfc_divide (op1, op2); + break; + + case INTRINSIC_POWER: + result = gfc_power (op1, op2); + break; + + case INTRINSIC_CONCAT: + result = gfc_concat (op1, op2); + break; + + case INTRINSIC_EQ: + result = gfc_eq (op1, op2); + break; + + case INTRINSIC_NE: + result = gfc_ne (op1, op2); + break; + + case INTRINSIC_GT: + result = gfc_gt (op1, op2); + break; + + case INTRINSIC_GE: + result = gfc_ge (op1, op2); + break; + + case INTRINSIC_LT: + result = gfc_lt (op1, op2); + break; + + case INTRINSIC_LE: + result = gfc_le (op1, op2); + break; + + case INTRINSIC_NOT: + result = gfc_not (op1); + break; + + case INTRINSIC_AND: + result = gfc_and (op1, op2); + break; + + case INTRINSIC_OR: + result = gfc_or (op1, op2); + break; + + case INTRINSIC_EQV: + result = gfc_eqv (op1, op2); + break; + + case INTRINSIC_NEQV: + result = gfc_neqv (op1, op2); + break; + + default: + gfc_internal_error ("simplify_intrinsic_op(): Bad operator"); + } + + if (result == NULL) + { + gfc_free_expr (op1); + gfc_free_expr (op2); + return FAILURE; + } + + gfc_replace_expr (p, result); + + return SUCCESS; +} + + +/* Subroutine to simplify constructor expressions. Mutually recursive + with gfc_simplify_expr(). */ + +static try +simplify_constructor (gfc_constructor * c, int type) +{ + + for (; c; c = c->next) + { + if (c->iterator + && (gfc_simplify_expr (c->iterator->start, type) == FAILURE + || gfc_simplify_expr (c->iterator->end, type) == FAILURE + || gfc_simplify_expr (c->iterator->step, type) == FAILURE)) + return FAILURE; + + if (c->expr && gfc_simplify_expr (c->expr, type) == FAILURE) + return FAILURE; + } + + return SUCCESS; +} + + +/* Pull a single array element out of an array constructor. */ + +static gfc_constructor * +find_array_element (gfc_constructor * cons, gfc_array_ref * ar) +{ + unsigned long nelemen; + int i; + mpz_t delta; + mpz_t offset; + + mpz_init_set_ui (offset, 0); + mpz_init (delta); + for (i = 0; i < ar->dimen; i++) + { + if (ar->start[i]->expr_type != EXPR_CONSTANT) + { + cons = NULL; + break; + } + mpz_sub (delta, ar->start[i]->value.integer, + ar->as->lower[i]->value.integer); + mpz_add (offset, offset, delta); + } + + if (cons) + { + if (mpz_fits_ulong_p (offset)) + { + for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--) + { + if (cons->iterator) + { + cons = NULL; + break; + } + cons = cons->next; + } + } + else + cons = NULL; + } + + mpz_clear (delta); + mpz_clear (offset); + + return cons; +} + + +/* Find a component of a structure constructor. */ + +static gfc_constructor * +find_component_ref (gfc_constructor * cons, gfc_ref * ref) +{ + gfc_component *comp; + gfc_component *pick; + + comp = ref->u.c.sym->components; + pick = ref->u.c.component; + while (comp != pick) + { + comp = comp->next; + cons = cons->next; + } + + return cons; +} + + +/* Replace an expression with the contents of a constructor, removing + the subobject reference in the process. */ + +static void +remove_subobject_ref (gfc_expr * p, gfc_constructor * cons) +{ + gfc_expr *e; + + e = cons->expr; + cons->expr = NULL; + e->ref = p->ref->next; + p->ref->next = NULL; + gfc_replace_expr (p, e); +} + + +/* Simplify a subobject reference of a constructor. This occurs when + parameter variable values are substituted. */ + +static try +simplify_const_ref (gfc_expr * p) +{ + gfc_constructor *cons; + + while (p->ref) + { + switch (p->ref->type) + { + case REF_ARRAY: + switch (p->ref->u.ar.type) + { + case AR_ELEMENT: + cons = find_array_element (p->value.constructor, &p->ref->u.ar); + if (!cons) + return SUCCESS; + remove_subobject_ref (p, cons); + break; + + case AR_FULL: + if (p->ref->next != NULL) + { + /* TODO: Simplify array subobject references. */ + return SUCCESS; + } + gfc_free_ref_list (p->ref); + p->ref = NULL; + break; + + default: + /* TODO: Simplify array subsections. */ + return SUCCESS; + } + + break; + + case REF_COMPONENT: + cons = find_component_ref (p->value.constructor, p->ref); + remove_subobject_ref (p, cons); + break; + + case REF_SUBSTRING: + /* TODO: Constant substrings. */ + return SUCCESS; + } + } + + return SUCCESS; +} + + +/* Simplify a chain of references. */ + +static try +simplify_ref_chain (gfc_ref * ref, int type) +{ + int n; + + for (; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_ARRAY: + for (n = 0; n < ref->u.ar.dimen; n++) + { + if (gfc_simplify_expr (ref->u.ar.start[n], type) + == FAILURE) + return FAILURE; + if (gfc_simplify_expr (ref->u.ar.end[n], type) + == FAILURE) + return FAILURE; + if (gfc_simplify_expr (ref->u.ar.stride[n], type) + == FAILURE) + return FAILURE; + } + break; + + case REF_SUBSTRING: + if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE) + return FAILURE; + if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE) + return FAILURE; + break; + + default: + break; + } + } + return SUCCESS; +} + + +/* Try to substitute the value of a parameter variable. */ +static try +simplify_parameter_variable (gfc_expr * p, int type) +{ + gfc_expr *e; + try t; + + e = gfc_copy_expr (p->symtree->n.sym->value); + if (p->ref) + e->ref = copy_ref (p->ref); + t = gfc_simplify_expr (e, type); + + /* Only use the simplification if it eliminated all subobject + references. */ + if (t == SUCCESS && ! e->ref) + gfc_replace_expr (p, e); + else + gfc_free_expr (e); + + return t; +} + +/* Given an expression, simplify it by collapsing constant + expressions. Most simplification takes place when the expression + tree is being constructed. If an intrinsic function is simplified + at some point, we get called again to collapse the result against + other constants. + + We work by recursively simplifying expression nodes, simplifying + intrinsic functions where possible, which can lead to further + constant collapsing. If an operator has constant operand(s), we + rip the expression apart, and rebuild it, hoping that it becomes + something simpler. + + The expression type is defined for: + 0 Basic expression parsing + 1 Simplifying array constructors -- will substitute + iterator values. + Returns FAILURE on error, SUCCESS otherwise. + NOTE: Will return SUCCESS even if the expression can not be simplified. */ + +try +gfc_simplify_expr (gfc_expr * p, int type) +{ + gfc_actual_arglist *ap; + + if (p == NULL) + return SUCCESS; + + switch (p->expr_type) + { + case EXPR_CONSTANT: + case EXPR_NULL: + break; + + case EXPR_FUNCTION: + for (ap = p->value.function.actual; ap; ap = ap->next) + if (gfc_simplify_expr (ap->expr, type) == FAILURE) + return FAILURE; + + if (p->value.function.isym != NULL + && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR) + return FAILURE; + + break; + + case EXPR_SUBSTRING: + if (gfc_simplify_expr (p->op1, type) == FAILURE + || gfc_simplify_expr (p->op2, type) == FAILURE) + return FAILURE; + + /* TODO: evaluate constant substrings. */ + + break; + + case EXPR_OP: + if (simplify_intrinsic_op (p, type) == FAILURE) + return FAILURE; + break; + + case EXPR_VARIABLE: + /* Only substitute array parameter variables if we are in an + initialization expression, or we want a subsection. */ + if (p->symtree->n.sym->attr.flavor == FL_PARAMETER + && (gfc_init_expr || p->ref + || p->symtree->n.sym->value->expr_type != EXPR_ARRAY)) + { + if (simplify_parameter_variable (p, type) == FAILURE) + return FAILURE; + break; + } + + if (type == 1) + { + gfc_simplify_iterator_var (p); + } + + /* Simplify subcomponent references. */ + if (simplify_ref_chain (p->ref, type) == FAILURE) + return FAILURE; + + break; + + case EXPR_STRUCTURE: + case EXPR_ARRAY: + if (simplify_ref_chain (p->ref, type) == FAILURE) + return FAILURE; + + if (simplify_constructor (p->value.constructor, type) == FAILURE) + return FAILURE; + + if (p->expr_type == EXPR_ARRAY) + gfc_expand_constructor (p); + + if (simplify_const_ref (p) == FAILURE) + return FAILURE; + + break; + } + + return SUCCESS; +} + + +/* Returns the type of an expression with the exception that iterator + variables are automatically integers no matter what else they may + be declared as. */ + +static bt +et0 (gfc_expr * e) +{ + + if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS) + return BT_INTEGER; + + return e->ts.type; +} + + +/* Check an intrinsic arithmetic operation to see if it is consistent + with some type of expression. */ + +static try check_init_expr (gfc_expr *); + +static try +check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *)) +{ + + if ((*check_function) (e->op1) == FAILURE) + return FAILURE; + + switch (e->operator) + { + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + if (!numeric_type (et0 (e->op1))) + goto not_numeric; + break; + + case INTRINSIC_EQ: + case INTRINSIC_NE: + case INTRINSIC_GT: + case INTRINSIC_GE: + case INTRINSIC_LT: + case INTRINSIC_LE: + + case INTRINSIC_PLUS: + case INTRINSIC_MINUS: + case INTRINSIC_TIMES: + case INTRINSIC_DIVIDE: + case INTRINSIC_POWER: + if ((*check_function) (e->op2) == FAILURE) + return FAILURE; + + if (!numeric_type (et0 (e->op1)) || !numeric_type (et0 (e->op2))) + goto not_numeric; + + if (e->operator != INTRINSIC_POWER) + break; + + if (check_function == check_init_expr && et0 (e->op2) != BT_INTEGER) + { + gfc_error ("Exponent at %L must be INTEGER for an initialization " + "expression", &e->op2->where); + return FAILURE; + } + + break; + + case INTRINSIC_CONCAT: + if ((*check_function) (e->op2) == FAILURE) + return FAILURE; + + if (et0 (e->op1) != BT_CHARACTER || et0 (e->op2) != BT_CHARACTER) + { + gfc_error ("Concatenation operator in expression at %L " + "must have two CHARACTER operands", &e->op1->where); + return FAILURE; + } + + if (e->op1->ts.kind != e->op2->ts.kind) + { + gfc_error ("Concat operator at %L must concatenate strings of the " + "same kind", &e->where); + return FAILURE; + } + + break; + + case INTRINSIC_NOT: + if (et0 (e->op1) != BT_LOGICAL) + { + gfc_error (".NOT. operator in expression at %L must have a LOGICAL " + "operand", &e->op1->where); + return FAILURE; + } + + break; + + case INTRINSIC_AND: + case INTRINSIC_OR: + case INTRINSIC_EQV: + case INTRINSIC_NEQV: + if ((*check_function) (e->op2) == FAILURE) + return FAILURE; + + if (et0 (e->op1) != BT_LOGICAL || et0 (e->op2) != BT_LOGICAL) + { + gfc_error ("LOGICAL operands are required in expression at %L", + &e->where); + return FAILURE; + } + + break; + + default: + gfc_error ("Only intrinsic operators can be used in expression at %L", + &e->where); + return FAILURE; + } + + return SUCCESS; + +not_numeric: + gfc_error ("Numeric operands are required in expression at %L", &e->where); + + return FAILURE; +} + + + +/* Certain inquiry functions are specifically allowed to have variable + arguments, which is an exception to the normal requirement that an + initialization function have initialization arguments. We head off + this problem here. */ + +static try +check_inquiry (gfc_expr * e) +{ + const char *name; + + /* FIXME: This should be moved into the intrinsic definitions, + to eliminate this ugly hack. */ + static const char * const inquiry_function[] = { + "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent", + "precision", "radix", "range", "tiny", "bit_size", "size", "shape", + "lbound", "ubound", NULL + }; + + int i; + + /* These functions must have exactly one argument. */ + if (e->value.function.actual == NULL + || e->value.function.actual->next != NULL) + return FAILURE; + + if (e->value.function.name != NULL + && e->value.function.name[0] != '\0') + return FAILURE; + + name = e->symtree->n.sym->name; + + for (i = 0; inquiry_function[i]; i++) + if (strcmp (inquiry_function[i], name) == 0) + break; + + if (inquiry_function[i] == NULL) + return FAILURE; + + e = e->value.function.actual->expr; + + if (e == NULL || e->expr_type != EXPR_VARIABLE) + return FAILURE; + + /* At this point we have a numeric inquiry function with a variable + argument. The type of the variable might be undefined, but we + need it now, because the arguments of these functions are allowed + to be undefined. */ + + if (e->ts.type == BT_UNKNOWN) + { + if (e->symtree->n.sym->ts.type == BT_UNKNOWN + && gfc_set_default_type (e->symtree->n.sym, 0, gfc_current_ns) + == FAILURE) + return FAILURE; + + e->ts = e->symtree->n.sym->ts; + } + + return SUCCESS; +} + + +/* Verify that an expression is an initialization expression. A side + effect is that the expression tree is reduced to a single constant + node if all goes well. This would normally happen when the + expression is constructed but function references are assumed to be + intrinsics in the context of initialization expressions. If + FAILURE is returned an error message has been generated. */ + +static try +check_init_expr (gfc_expr * e) +{ + gfc_actual_arglist *ap; + match m; + try t; + + if (e == NULL) + return SUCCESS; + + switch (e->expr_type) + { + case EXPR_OP: + t = check_intrinsic_op (e, check_init_expr); + if (t == SUCCESS) + t = gfc_simplify_expr (e, 0); + + break; + + case EXPR_FUNCTION: + t = SUCCESS; + + if (check_inquiry (e) != SUCCESS) + { + t = SUCCESS; + for (ap = e->value.function.actual; ap; ap = ap->next) + if (check_init_expr (ap->expr) == FAILURE) + { + t = FAILURE; + break; + } + } + + if (t == SUCCESS) + { + m = gfc_intrinsic_func_interface (e, 0); + + if (m == MATCH_NO) + gfc_error ("Function '%s' in initialization expression at %L " + "must be an intrinsic function", + e->symtree->n.sym->name, &e->where); + + if (m != MATCH_YES) + t = FAILURE; + } + + break; + + case EXPR_VARIABLE: + t = SUCCESS; + + if (gfc_check_iter_variable (e) == SUCCESS) + break; + + if (e->symtree->n.sym->attr.flavor == FL_PARAMETER) + { + t = simplify_parameter_variable (e, 0); + break; + } + + gfc_error ("Variable '%s' at %L cannot appear in an initialization " + "expression", e->symtree->n.sym->name, &e->where); + t = FAILURE; + break; + + case EXPR_CONSTANT: + case EXPR_NULL: + t = SUCCESS; + break; + + case EXPR_SUBSTRING: + t = check_init_expr (e->op1); + if (t == FAILURE) + break; + + t = check_init_expr (e->op2); + if (t == SUCCESS) + t = gfc_simplify_expr (e, 0); + + break; + + case EXPR_STRUCTURE: + t = gfc_check_constructor (e, check_init_expr); + break; + + case EXPR_ARRAY: + t = gfc_check_constructor (e, check_init_expr); + if (t == FAILURE) + break; + + t = gfc_expand_constructor (e); + if (t == FAILURE) + break; + + t = gfc_check_constructor_type (e); + break; + + default: + gfc_internal_error ("check_init_expr(): Unknown expression type"); + } + + return t; +} + + +/* Match an initialization expression. We work by first matching an + expression, then reducing it to a constant. */ + +match +gfc_match_init_expr (gfc_expr ** result) +{ + gfc_expr *expr; + match m; + try t; + + m = gfc_match_expr (&expr); + if (m != MATCH_YES) + return m; + + gfc_init_expr = 1; + t = gfc_resolve_expr (expr); + if (t == SUCCESS) + t = check_init_expr (expr); + gfc_init_expr = 0; + + if (t == FAILURE) + { + gfc_free_expr (expr); + return MATCH_ERROR; + } + + if (expr->expr_type == EXPR_ARRAY + && (gfc_check_constructor_type (expr) == FAILURE + || gfc_expand_constructor (expr) == FAILURE)) + { + gfc_free_expr (expr); + return MATCH_ERROR; + } + + if (!gfc_is_constant_expr (expr)) + gfc_internal_error ("Initialization expression didn't reduce %C"); + + *result = expr; + + return MATCH_YES; +} + + + +static try check_restricted (gfc_expr *); + +/* Given an actual argument list, test to see that each argument is a + restricted expression and optionally if the expression type is + integer or character. */ + +static try +restricted_args (gfc_actual_arglist * a, int check_type) +{ + bt type; + + for (; a; a = a->next) + { + if (check_restricted (a->expr) == FAILURE) + return FAILURE; + + if (!check_type) + continue; + + type = a->expr->ts.type; + if (type != BT_CHARACTER && type != BT_INTEGER) + { + gfc_error + ("Function argument at %L must be of type INTEGER or CHARACTER", + &a->expr->where); + return FAILURE; + } + } + + return SUCCESS; +} + + +/************* Restricted/specification expressions *************/ + + +/* Make sure a non-intrinsic function is a specification function. */ + +static try +external_spec_function (gfc_expr * e) +{ + gfc_symbol *f; + + f = e->value.function.esym; + + if (f->attr.proc == PROC_ST_FUNCTION) + { + gfc_error ("Specification function '%s' at %L cannot be a statement " + "function", f->name, &e->where); + return FAILURE; + } + + if (f->attr.proc == PROC_INTERNAL) + { + gfc_error ("Specification function '%s' at %L cannot be an internal " + "function", f->name, &e->where); + return FAILURE; + } + + if (!f->attr.pure) + { + gfc_error ("Specification function '%s' at %L must be PURE", f->name, + &e->where); + return FAILURE; + } + + if (f->attr.recursive) + { + gfc_error ("Specification function '%s' at %L cannot be RECURSIVE", + f->name, &e->where); + return FAILURE; + } + + return restricted_args (e->value.function.actual, 0); +} + + +/* Check to see that a function reference to an intrinsic is a + restricted expression. Some functions required by the standard are + omitted because references to them have already been simplified. + Strictly speaking, a lot of these checks are redundant with other + checks. If a function is indeed a particular intrinsic, then the + type of its argument have already been checked and passed. */ + +static try +restricted_intrinsic (gfc_expr * e) +{ + gfc_intrinsic_sym *sym; + + static struct + { + const char *name; + int case_number; + } + const *cp, cases[] = + { + {"repeat", 0}, + {"reshape", 0}, + {"selected_int_kind", 0}, + {"selected_real_kind", 0}, + {"transfer", 0}, + {"trim", 0}, + {"null", 1}, + {"lbound", 2}, + {"shape", 2}, + {"size", 2}, + {"ubound", 2}, + /* bit_size() has already been reduced */ + {"len", 0}, + /* kind() has already been reduced */ + /* Numeric inquiry functions have been reduced */ + { NULL, 0} + }; + + try t; + + sym = e->value.function.isym; + if (!sym) + return FAILURE; + + if (sym->elemental) + return restricted_args (e->value.function.actual, 1); + + for (cp = cases; cp->name; cp++) + if (strcmp (cp->name, sym->name) == 0) + break; + + if (cp->name == NULL) + { + gfc_error ("Intrinsic function '%s' at %L is not a restricted function", + sym->name, &e->where); + return FAILURE; + } + + switch (cp->case_number) + { + case 0: + /* Functions that are restricted if they have character/integer args. */ + t = restricted_args (e->value.function.actual, 1); + break; + + case 1: /* NULL() */ + t = SUCCESS; + break; + + case 2: + /* Functions that could be checking the bounds of an assumed-size array. */ + t = SUCCESS; + /* TODO: implement checks from 7.1.6.2 (10) */ + break; + + default: + gfc_internal_error ("restricted_intrinsic(): Bad case"); + } + + return t; +} + + +/* Verify that an expression is a restricted expression. Like its + cousin check_init_expr(), an error message is generated if we + return FAILURE. */ + +static try +check_restricted (gfc_expr * e) +{ + gfc_symbol *sym; + try t; + + if (e == NULL) + return SUCCESS; + + switch (e->expr_type) + { + case EXPR_OP: + t = check_intrinsic_op (e, check_restricted); + if (t == SUCCESS) + t = gfc_simplify_expr (e, 0); + + break; + + case EXPR_FUNCTION: + t = e->value.function.esym ? + external_spec_function (e) : restricted_intrinsic (e); + + break; + + case EXPR_VARIABLE: + sym = e->symtree->n.sym; + t = FAILURE; + + if (sym->attr.optional) + { + gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL", + sym->name, &e->where); + break; + } + + if (sym->attr.intent == INTENT_OUT) + { + gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)", + sym->name, &e->where); + break; + } + + if (sym->attr.in_common + || sym->attr.use_assoc + || sym->attr.dummy + || sym->ns != gfc_current_ns + || (sym->ns->proc_name != NULL + && sym->ns->proc_name->attr.flavor == FL_MODULE)) + { + t = SUCCESS; + break; + } + + gfc_error ("Variable '%s' cannot appear in the expression at %L", + sym->name, &e->where); + + break; + + case EXPR_NULL: + case EXPR_CONSTANT: + t = SUCCESS; + break; + + case EXPR_SUBSTRING: + t = gfc_specification_expr (e->op1); + if (t == FAILURE) + break; + + t = gfc_specification_expr (e->op2); + if (t == SUCCESS) + t = gfc_simplify_expr (e, 0); + + break; + + case EXPR_STRUCTURE: + t = gfc_check_constructor (e, check_restricted); + break; + + case EXPR_ARRAY: + t = gfc_check_constructor (e, check_restricted); + break; + + default: + gfc_internal_error ("check_restricted(): Unknown expression type"); + } + + return t; +} + + +/* Check to see that an expression is a specification expression. If + we return FAILURE, an error has been generated. */ + +try +gfc_specification_expr (gfc_expr * e) +{ + + if (e->ts.type != BT_INTEGER) + { + gfc_error ("Expression at %L must be of INTEGER type", &e->where); + return FAILURE; + } + + if (e->rank != 0) + { + gfc_error ("Expression at %L must be scalar", &e->where); + return FAILURE; + } + + if (gfc_simplify_expr (e, 0) == FAILURE) + return FAILURE; + + return check_restricted (e); +} + + +/************** Expression conformance checks. *************/ + +/* Given two expressions, make sure that the arrays are conformable. */ + +try +gfc_check_conformance (const char *optype, gfc_expr * op1, gfc_expr * op2) +{ + int op1_flag, op2_flag, d; + mpz_t op1_size, op2_size; + try t; + + if (op1->rank == 0 || op2->rank == 0) + return SUCCESS; + + if (op1->rank != op2->rank) + { + gfc_error ("Incompatible ranks in %s at %L", optype, &op1->where); + return FAILURE; + } + + t = SUCCESS; + + for (d = 0; d < op1->rank; d++) + { + op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS; + op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS; + + if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0) + { + gfc_error ("%s at %L has different shape on dimension %d (%d/%d)", + optype, &op1->where, d + 1, (int) mpz_get_si (op1_size), + (int) mpz_get_si (op2_size)); + + t = FAILURE; + } + + if (op1_flag) + mpz_clear (op1_size); + if (op2_flag) + mpz_clear (op2_size); + + if (t == FAILURE) + return FAILURE; + } + + return SUCCESS; +} + + +/* Given an assignable expression and an arbitrary expression, make + sure that the assignment can take place. */ + +try +gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform) +{ + gfc_symbol *sym; + + sym = lvalue->symtree->n.sym; + + if (sym->attr.intent == INTENT_IN) + { + gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L", + sym->name, &lvalue->where); + return FAILURE; + } + + if (rvalue->rank != 0 && lvalue->rank != rvalue->rank) + { + gfc_error ("Incompatible ranks in assignment at %L", &lvalue->where); + return FAILURE; + } + + if (lvalue->ts.type == BT_UNKNOWN) + { + gfc_error ("Variable type is UNKNOWN in assignment at %L", + &lvalue->where); + return FAILURE; + } + + /* Check size of array assignments. */ + if (lvalue->rank != 0 && rvalue->rank != 0 + && gfc_check_conformance ("Array assignment", lvalue, rvalue) != SUCCESS) + return FAILURE; + + if (gfc_compare_types (&lvalue->ts, &rvalue->ts)) + return SUCCESS; + + if (!conform) + { + if (gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts)) + return SUCCESS; + + gfc_error ("Incompatible types in assignment at %L, %s to %s", + &rvalue->where, gfc_typename (&rvalue->ts), + gfc_typename (&lvalue->ts)); + + return FAILURE; + } + + return gfc_convert_type (rvalue, &lvalue->ts, 1); +} + + +/* Check that a pointer assignment is OK. We first check lvalue, and + we only check rvalue if it's not an assignment to NULL() or a + NULLIFY statement. */ + +try +gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue) +{ + symbol_attribute attr; + int is_pure; + + if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN) + { + gfc_error ("Pointer assignment target is not a POINTER at %L", + &lvalue->where); + return FAILURE; + } + + attr = gfc_variable_attr (lvalue, NULL); + if (!attr.pointer) + { + gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where); + return FAILURE; + } + + is_pure = gfc_pure (NULL); + + if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)) + { + gfc_error ("Bad pointer object in PURE procedure at %L", + &lvalue->where); + return FAILURE; + } + + /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type, + kind, etc for lvalue and rvalue must match, and rvalue must be a + pure variable if we're in a pure function. */ + if (rvalue->expr_type != EXPR_NULL) + { + + if (!gfc_compare_types (&lvalue->ts, &rvalue->ts)) + { + gfc_error ("Different types in pointer assignment at %L", + &lvalue->where); + return FAILURE; + } + + if (lvalue->ts.kind != rvalue->ts.kind) + { + gfc_error + ("Different kind type parameters in pointer assignment at %L", + &lvalue->where); + return FAILURE; + } + + attr = gfc_expr_attr (rvalue); + if (!attr.target && !attr.pointer) + { + gfc_error + ("Pointer assignment target is neither TARGET nor POINTER at " + "%L", &rvalue->where); + return FAILURE; + } + + if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym)) + { + gfc_error + ("Bad target in pointer assignment in PURE procedure at %L", + &rvalue->where); + } + } + + return SUCCESS; +} + + +/* Relative of gfc_check_assign() except that the lvalue is a single + symbol. */ + +try +gfc_check_assign_symbol (gfc_symbol * sym, gfc_expr * rvalue) +{ + gfc_expr lvalue; + try r; + + memset (&lvalue, '\0', sizeof (gfc_expr)); + + lvalue.expr_type = EXPR_VARIABLE; + lvalue.ts = sym->ts; + if (sym->as) + lvalue.rank = sym->as->rank; + lvalue.symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree)); + lvalue.symtree->n.sym = sym; + lvalue.where = sym->declared_at; + + r = gfc_check_assign (&lvalue, rvalue, 1); + + gfc_free (lvalue.symtree); + + return r; +} diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c new file mode 100644 index 00000000000..51ce3c4e530 --- /dev/null +++ b/gcc/fortran/f95-lang.c @@ -0,0 +1,838 @@ +/* G95 Backend interface + Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. + Contributed by Paul Brook. + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* f95-lang.c-- GCC backend interface stuff */ + +/* declare required prototypes: */ + +#include "config.h" +#include "ansidecl.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "tree-simple.h" +#include "flags.h" +#include "langhooks.h" +#include "langhooks-def.h" +#include "timevar.h" +#include "tm.h" +#include "function.h" +#include "ggc.h" +#include "toplev.h" +#include "target.h" +#include "debug.h" +#include "diagnostic.h" +#include "tree-dump.h" +#include "cgraph.h" + +#include "gfortran.h" +#include "trans.h" +#include "trans-types.h" +#include "trans-const.h" + +#include <assert.h> +#include <stdio.h> + +/* Language-dependent contents of an identifier. */ + +struct lang_identifier +GTY(()) +{ + struct tree_identifier common; +}; + +/* The resulting tree type. */ + +union lang_tree_node +GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"))) +{ + union tree_node GTY((tag ("0"), + desc ("tree_node_structure (&%h)"))) generic; + struct lang_identifier GTY((tag ("1"))) identifier; +}; + +/* Save and restore the variables in this file and elsewhere + that keep track of the progress of compilation of the current function. + Used for nested functions. */ + +struct language_function +GTY(()) +{ + /* struct gfc_language_function base; */ + tree named_labels; + tree shadowed_labels; + int returns_value; + int returns_abnormally; + int warn_about_return_type; + int extern_inline; + struct binding_level *binding_level; +}; + +/* We don't have a lex/yacc lexer/parser, but toplev expects these to + exist anyway. */ +void yyerror (const char *str); +int yylex (void); + +static void gfc_init_decl_processing (void); +static void gfc_init_builtin_functions (void); + +/* Each front end provides its own. */ +static bool gfc_init (void); +static void gfc_finish (void); +static void gfc_print_identifier (FILE *, tree, int); +static bool gfc_mark_addressable (tree); +void do_function_end (void); +int global_bindings_p (void); +void insert_block (tree); +void set_block (tree); +static void gfc_be_parse_file (int); +static void gfc_expand_function (tree); + +#undef LANG_HOOKS_NAME +#undef LANG_HOOKS_INIT +#undef LANG_HOOKS_FINISH +#undef LANG_HOOKS_INIT_OPTIONS +#undef LANG_HOOKS_HANDLE_OPTION +#undef LANG_HOOKS_POST_OPTIONS +#undef LANG_HOOKS_PRINT_IDENTIFIER +#undef LANG_HOOKS_PARSE_FILE +#undef LANG_HOOKS_TRUTHVALUE_CONVERSION +#undef LANG_HOOKS_MARK_ADDRESSABLE +#undef LANG_HOOKS_TYPE_FOR_MODE +#undef LANG_HOOKS_TYPE_FOR_SIZE +#undef LANG_HOOKS_UNSIGNED_TYPE +#undef LANG_HOOKS_SIGNED_TYPE +#undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE +#undef LANG_HOOKS_GIMPLE_BEFORE_INLINING +#undef LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION + +/* Define lang hooks. */ +#define LANG_HOOKS_NAME "GNU F95" +#define LANG_HOOKS_INIT gfc_init +#define LANG_HOOKS_FINISH gfc_finish +#define LANG_HOOKS_INIT_OPTIONS gfc_init_options +#define LANG_HOOKS_HANDLE_OPTION gfc_handle_option +#define LANG_HOOKS_POST_OPTIONS gfc_post_options +#define LANG_HOOKS_PRINT_IDENTIFIER gfc_print_identifier +#define LANG_HOOKS_PARSE_FILE gfc_be_parse_file +#define LANG_HOOKS_TRUTHVALUE_CONVERSION gfc_truthvalue_conversion +#define LANG_HOOKS_MARK_ADDRESSABLE gfc_mark_addressable +#define LANG_HOOKS_TYPE_FOR_MODE gfc_type_for_mode +#define LANG_HOOKS_TYPE_FOR_SIZE gfc_type_for_size +#define LANG_HOOKS_UNSIGNED_TYPE gfc_unsigned_type +#define LANG_HOOKS_SIGNED_TYPE gfc_signed_type +#define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE gfc_signed_or_unsigned_type +#define LANG_HOOKS_GIMPLE_BEFORE_INLINING false +#define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION gfc_expand_function + +const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; + +/* 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. */ + +/* Tree code classes. */ + +#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE, + +const char tree_code_type[] = { +#include "tree.def" +}; +#undef DEFTREECODE + +/* Table indexed by tree code giving number of expression + operands beyond the fixed part of the node structure. + Not used for types or decls. */ + +#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH, + +const unsigned char tree_code_length[] = { +#include "tree.def" +}; +#undef DEFTREECODE + +/* Names of tree components. + Used for printing out the tree and error messages. */ +#define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME, + +const char *const tree_code_name[] = { +#include "tree.def" +}; +#undef DEFTREECODE + +static tree named_labels; + +#define NULL_BINDING_LEVEL (struct binding_level *) NULL + +/* A chain of binding_level structures awaiting reuse. */ + +static GTY(()) struct binding_level *free_binding_level; + +/* The elements of `ridpointers' are identifier nodes + for the reserved type names and storage classes. + It is indexed by a RID_... value. */ +tree *ridpointers = NULL; + +/* language-specific flags. */ + +static void +gfc_expand_function (tree fndecl) +{ + tree_rest_of_compilation (fndecl, 0); +} + + +/* Prepare expr to be an argument of a TRUTH_NOT_EXPR, + or validate its data type for an `if' or `while' statement or ?..: exp. + + This preparation consists of taking the ordinary + representation of an expression expr and producing a valid tree + boolean expression describing whether expr is nonzero. We could + simply always do build_binary_op (NE_EXPR, expr, boolean_false_node, 1), + but we optimize comparisons, &&, ||, and !. + + The resulting type should always be `boolean_type_node'. + This is much simpler than the corresponding C version because we have a + distinct boolean type. */ + +tree +gfc_truthvalue_conversion (tree expr) +{ + switch (TREE_CODE (TREE_TYPE (expr))) + { + case BOOLEAN_TYPE: + if (TREE_TYPE (expr) == boolean_type_node) + return expr; + else if (TREE_CODE_CLASS (TREE_CODE (expr)) == '<') + { + TREE_TYPE (expr) = boolean_type_node; + return expr; + } + else if (TREE_CODE (expr) == NOP_EXPR) + return build1 (NOP_EXPR, boolean_type_node, + TREE_OPERAND (expr, 0)); + else + return build1 (NOP_EXPR, boolean_type_node, expr); + + case INTEGER_TYPE: + if (TREE_CODE (expr) == INTEGER_CST) + return integer_zerop (expr) ? boolean_false_node : boolean_true_node; + else + return build (NE_EXPR, boolean_type_node, expr, integer_zero_node); + + default: + internal_error ("Unexpected type in truthvalue_conversion"); + } +} + +static void +gfc_create_decls (void) +{ + /* GCC builtins. */ + gfc_init_builtin_functions (); + + /* Runtime/IO library functions. */ + gfc_build_builtin_function_decls (); + + gfc_init_constants (); +} + +static void +gfc_be_parse_file (int set_yydebug ATTRIBUTE_UNUSED) +{ + int errors; + int warnings; + + gfc_create_decls (); + gfc_parse_file (); + gfc_generate_constructors (); + + cgraph_finalize_compilation_unit (); + cgraph_optimize (); + + /* Tell the frontent about any errors. */ + gfc_get_errors (&warnings, &errors); + errorcount += errors; + warningcount += warnings; +} + +/* Initialize everything. */ + +static bool +gfc_init (void) +{ + /* First initialize the backend. */ + gfc_init_decl_processing (); + gfc_static_ctors = NULL_TREE; + + /* Then the frontend. */ + gfc_init_1 (); + + if (gfc_new_file (gfc_option.source, gfc_option.source_form) != SUCCESS) + fatal_error ("can't open input file: %s", gfc_option.source); + return true; +} + + +static void +gfc_finish (void) +{ + gfc_done_1 (); + gfc_release_include_path (); + return; +} + +static void +gfc_print_identifier (FILE * file ATTRIBUTE_UNUSED, + tree node ATTRIBUTE_UNUSED, + int indent ATTRIBUTE_UNUSED) +{ + return; +} + + +/* These functions and variables deal with binding contours. We only + need these functions for the list of PARM_DECLs, but we leave the + functions more general; these are a simplified version of the + functions from GNAT. */ + +/* For each binding contour we allocate a binding_level structure which records + the entities defined or declared in that contour. Contours include: + + the global one + one for each subprogram definition + one for each compound statement (declare block) + + Binding contours are used to create GCC tree BLOCK nodes. */ + +struct binding_level +GTY(()) +{ + /* A chain of ..._DECL nodes for all variables, constants, functions, + parameters and type declarations. These ..._DECL nodes are chained + through the TREE_CHAIN field. Note that these ..._DECL nodes are stored + in the reverse of the order supplied to be compatible with the + back-end. */ + tree names; + /* For each level (except the global one), a chain of BLOCK nodes for all + the levels that were entered and exited one level down from this one. */ + tree blocks; + /* The back end may need, for its own internal processing, to create a BLOCK + node. This field is set aside for this purpose. If this field is non-null + when the level is popped, i.e. when poplevel is invoked, we will use such + block instead of creating a new one from the 'names' field, that is the + ..._DECL nodes accumulated so far. Typically the routine 'pushlevel' + will be called before setting this field, so that if the front-end had + inserted ..._DECL nodes in the current block they will not be lost. */ + tree block_created_by_back_end; + /* The binding level containing this one (the enclosing binding level). */ + struct binding_level *level_chain; +}; + +/* The binding level currently in effect. */ +static GTY(()) struct binding_level *current_binding_level = NULL; + +/* The outermost binding level. This binding level is created when the + compiler is started and it will exist through the entire compilation. */ +static GTY(()) 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 }; + +/* Return non-zero if we are currently in the global binding level. */ + +int +global_bindings_p (void) +{ + return current_binding_level == global_binding_level ? -1 : 0; +} + +tree +getdecls (void) +{ + return current_binding_level->names; +} + +/* Enter a new binding level. The input parameter is ignored, but has to be + specified for back-end compatibility. */ + +void +pushlevel (int ignore ATTRIBUTE_UNUSED) +{ + struct binding_level *newlevel + = (struct binding_level *) ggc_alloc (sizeof (struct binding_level)); + + *newlevel = clear_binding_level; + + /* Add this level to the front of the chain (stack) of levels that are + active. */ + newlevel->level_chain = current_binding_level; + current_binding_level = newlevel; +} + +/* Exit a binding level. + Pop the level off, and restore the state of the identifier-decl mappings + that were in effect when this level was entered. + + If KEEP is nonzero, this level had explicit declarations, so + and create a "block" (a BLOCK node) for the level + to record its declarations and subblocks for symbol table output. + + If FUNCTIONBODY is nonzero, this level is the body of a function, + so create a block as if KEEP were set and also clear out all + label names. + + If REVERSE is nonzero, reverse the order of decls before putting + them into the BLOCK. */ + +tree +poplevel (int keep, int reverse, int functionbody) +{ + /* Points to a BLOCK tree node. This is the BLOCK node construted for the + binding level that we are about to exit and which is returned by this + routine. */ + tree block_node = NULL_TREE; + tree decl_chain; + tree subblock_chain = current_binding_level->blocks; + tree subblock_node; + tree block_created_by_back_end; + + /* Reverse the list of XXXX_DECL nodes if desired. Note that the ..._DECL + nodes chained through the `names' field of current_binding_level are in + reverse order except for PARM_DECL node, which are explicitely stored in + the right order. */ + decl_chain = (reverse) ? nreverse (current_binding_level->names) + : current_binding_level->names; + + block_created_by_back_end = + current_binding_level->block_created_by_back_end; + if (block_created_by_back_end != 0) + { + block_node = block_created_by_back_end; + + /* Check if we are about to discard some information that was gathered + by the front-end. Nameley check if the back-end created a new block + without calling pushlevel first. To understand why things are lost + just look at the next case (i.e. no block created by back-end. */ + if ((keep || functionbody) && (decl_chain || subblock_chain)) + abort (); + } + + /* If there were any declarations in the current binding level, or if this + binding level is a function body, or if there are any nested blocks then + create a BLOCK node to record them for the life of this function. */ + else if (keep || functionbody) + block_node = build_block (keep ? decl_chain : 0, 0, subblock_chain, 0, 0); + + /* Record the BLOCK node just built as the subblock its enclosing scope. */ + for (subblock_node = subblock_chain; subblock_node; + subblock_node = TREE_CHAIN (subblock_node)) + BLOCK_SUPERCONTEXT (subblock_node) = block_node; + + /* Clear out the meanings of the local variables of this level. */ + + for (subblock_node = decl_chain; subblock_node; + subblock_node = TREE_CHAIN (subblock_node)) + if (DECL_NAME (subblock_node) != 0) + /* If the identifier was used or addressed via a local extern decl, + don't forget that fact. */ + if (DECL_EXTERNAL (subblock_node)) + { + if (TREE_USED (subblock_node)) + TREE_USED (DECL_NAME (subblock_node)) = 1; + if (TREE_ADDRESSABLE (subblock_node)) + TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1; + } + + /* Pop the current level. */ + current_binding_level = current_binding_level->level_chain; + + if (functionbody) + { + /* This is the top level block of a function. The ..._DECL chain stored + in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't + leave them in the BLOCK because they are found in the FUNCTION_DECL + instead. */ + DECL_INITIAL (current_function_decl) = block_node; + BLOCK_VARS (block_node) = 0; + } + else if (block_node) + { + if (block_created_by_back_end == NULL) + current_binding_level->blocks + = chainon (current_binding_level->blocks, block_node); + } + + /* If we did not make a block for the level just exited, any blocks made for + inner levels (since they cannot be recorded as subblocks in that level) + must be carried forward so they will later become subblocks of something + else. */ + else if (subblock_chain) + current_binding_level->blocks + = chainon (current_binding_level->blocks, subblock_chain); + if (block_node) + TREE_USED (block_node) = 1; + + return block_node; +} + +/* Insert BLOCK at the end of the list of subblocks of the + current binding level. This is used when a BIND_EXPR is expanded, + to handle the BLOCK node inside the BIND_EXPR. */ + +void +insert_block (tree block) +{ + TREE_USED (block) = 1; + current_binding_level->blocks + = chainon (current_binding_level->blocks, block); +} + +/* Set the BLOCK node for the innermost scope + (the one we are currently in). */ + +void +set_block (tree block) +{ + current_binding_level->block_created_by_back_end = block; +} + +/* Records a ..._DECL node DECL as belonging to the current lexical scope. + Returns the ..._DECL node. */ + +tree +pushdecl (tree decl) +{ + /* External objects aren't nested, other objects may be. */ + if ((DECL_EXTERNAL (decl)) || (decl == current_function_decl)) + DECL_CONTEXT (decl) = 0; + else + DECL_CONTEXT (decl) = current_function_decl; + + /* Put the declaration on the list. The list of declarations is in reverse + order. The list will be reversed later if necessary. This needs to be + this way for compatibility with the back-end. */ + + TREE_CHAIN (decl) = current_binding_level->names; + current_binding_level->names = decl; + + /* For the declartion of a type, set its name if it is not already set. */ + + if (TREE_CODE (decl) == TYPE_DECL && TYPE_NAME (TREE_TYPE (decl)) == 0) + { + if (DECL_SOURCE_LINE (decl) == 0) + TYPE_NAME (TREE_TYPE (decl)) = decl; + else + TYPE_NAME (TREE_TYPE (decl)) = DECL_NAME (decl); + } + + return decl; +} + + +/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL. */ + +tree +pushdecl_top_level (tree x) +{ + tree t; + struct binding_level *b = current_binding_level; + + current_binding_level = global_binding_level; + t = pushdecl (x); + current_binding_level = b; + return t; +} + + +#ifndef CHAR_TYPE_SIZE +#define CHAR_TYPE_SIZE BITS_PER_UNIT +#endif + +#ifndef INT_TYPE_SIZE +#define INT_TYPE_SIZE BITS_PER_WORD +#endif + +#undef SIZE_TYPE +#define SIZE_TYPE "long unsigned int" + +/* Create tree nodes for the basic scalar types of Fortran 95, + and some nodes representing standard constants (0, 1, (void *) 0). + Initialize the global binding level. + Make definitions for built-in primitive functions. */ +static void +gfc_init_decl_processing (void) +{ + current_function_decl = NULL; + named_labels = NULL; + current_binding_level = NULL_BINDING_LEVEL; + free_binding_level = NULL_BINDING_LEVEL; + + /* Make the binding_level structure for global names. We move all + variables that are in a COMMON block to this binding level. */ + pushlevel (0); + global_binding_level = current_binding_level; + + /* Build common tree nodes. char_type_node is unsigned because we + only use it for actual characters, not for INTEGER(1). Also, we + want double_type_node to actually have double precision. */ + build_common_tree_nodes (0); + set_sizetype (long_unsigned_type_node); + build_common_tree_nodes_2 (0); + + /* Set up F95 type nodes. */ + gfc_init_types (); +} + +/* Mark EXP saying that we need to be able to take the + address of it; it should not be allocated in a register. + In Fortran 95 this is only the case for variables with + the TARGET attribute, but we implement it here for a + likely future Cray pointer extension. + Value is 1 if successful. */ +/* TODO: Check/fix mark_addressable. */ +bool +gfc_mark_addressable (tree exp) +{ + register tree x = exp; + while (1) + switch (TREE_CODE (x)) + { + case COMPONENT_REF: + case ADDR_EXPR: + case ARRAY_REF: + case REALPART_EXPR: + case IMAGPART_EXPR: + x = TREE_OPERAND (x, 0); + break; + + case CONSTRUCTOR: + TREE_ADDRESSABLE (x) = 1; + return true; + + case VAR_DECL: + case CONST_DECL: + case PARM_DECL: + case RESULT_DECL: + if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) && DECL_NONLOCAL (x)) + { + if (TREE_PUBLIC (x)) + { + error + ("global register variable `%s' used in nested function", + IDENTIFIER_POINTER (DECL_NAME (x))); + return false; + } + pedwarn ("register variable `%s' used in nested function", + IDENTIFIER_POINTER (DECL_NAME (x))); + } + else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)) + { + if (TREE_PUBLIC (x)) + { + error ("address of global register variable `%s' requested", + IDENTIFIER_POINTER (DECL_NAME (x))); + return true; + } + +#if 0 + /* If we are making this addressable due to its having + volatile components, give a different error message. Also + handle the case of an unnamed parameter by not trying + to give the name. */ + + else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x))) + { + error ("cannot put object with volatile field into register"); + return false; + } +#endif + + pedwarn ("address of register variable `%s' requested", + IDENTIFIER_POINTER (DECL_NAME (x))); + } + put_var_into_stack (x, /*rescan=*/true); + + /* drops in */ + case FUNCTION_DECL: + TREE_ADDRESSABLE (x) = 1; + + default: + return true; + } +} + +/* press the big red button - garbage (ggc) collection is on */ + +int ggc_p = 1; + +/* Builtin function initialisation. */ + +/* Return a definition for a builtin function named NAME and whose data type + is TYPE. TYPE should be a function type with argument types. + FUNCTION_CODE tells later passes how to compile calls to this function. + See tree.h for its possible values. + + If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME, + the name to be called if we can't opencode the function. If + ATTRS is nonzero, use that for the function's attribute list. */ + +tree +builtin_function (const char *name, + tree type, + int function_code, + enum built_in_class class, + const char *library_name, + tree attrs ATTRIBUTE_UNUSED) +{ + tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type); + DECL_EXTERNAL (decl) = 1; + TREE_PUBLIC (decl) = 1; + if (library_name) + SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name)); + make_decl_rtl (decl, NULL); + pushdecl (decl); + DECL_BUILT_IN_CLASS (decl) = class; + DECL_FUNCTION_CODE (decl) = function_code; + return decl; +} + + +static void +gfc_define_builtin (const char * name, + tree type, + int code, + const char * library_name, + bool const_p) +{ + tree decl; + + decl = builtin_function (name, type, code, BUILT_IN_NORMAL, + library_name, NULL_TREE); + if (const_p) + TREE_READONLY (decl) = 1; + + built_in_decls[code] = decl; + implicit_built_in_decls[code] = decl; +} + + +#define DEFINE_MATH_BUILTIN(code, name, nargs) \ + gfc_define_builtin ("__builtin_" name, mfunc_double[nargs-1], \ + BUILT_IN_ ## code, name, true); \ + gfc_define_builtin ("__builtin_" name "f", mfunc_float[nargs-1], \ + BUILT_IN_ ## code ## F, name "f", true); + +/* Initialisation of builtin function nodes. */ +static void +gfc_init_builtin_functions (void) +{ + tree mfunc_float[2]; + tree mfunc_double[2]; + tree ftype; + tree tmp; + tree voidchain; + + voidchain = tree_cons (NULL_TREE, void_type_node, NULL_TREE); + + tmp = tree_cons (NULL_TREE, float_type_node, voidchain); + mfunc_float[0] = build_function_type (float_type_node, tmp); + tmp = tree_cons (NULL_TREE, float_type_node, tmp); + mfunc_float[1] = build_function_type (float_type_node, tmp); + + tmp = tree_cons (NULL_TREE, double_type_node, voidchain); + mfunc_double[0] = build_function_type (double_type_node, tmp); + tmp = tree_cons (NULL_TREE, double_type_node, tmp); + mfunc_double[1] = build_function_type (double_type_node, tmp); + +#include "mathbuiltins.def" + + /* We define these seperately as the fortran versions have different + semantics (they return an integer type) */ + gfc_define_builtin ("__builtin_floor", mfunc_double[0], + BUILT_IN_FLOOR, "floor", true); + gfc_define_builtin ("__builtin_floorf", mfunc_float[0], + BUILT_IN_FLOORF, "floorf", true); + gfc_define_builtin ("__builtin_round", mfunc_double[0], + BUILT_IN_ROUND, "round", true); + gfc_define_builtin ("__builtin_roundf", mfunc_float[0], + BUILT_IN_ROUNDF, "roundf", true); + + /* Other builtin functions we use. */ + + tmp = tree_cons (NULL_TREE, long_integer_type_node, voidchain); + tmp = tree_cons (NULL_TREE, long_integer_type_node, tmp); + ftype = build_function_type (long_integer_type_node, tmp); + gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT, + "__builtin_expect", true); + + tmp = tree_cons (NULL_TREE, size_type_node, voidchain); + tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp); + tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp); + ftype = build_function_type (pvoid_type_node, tmp); + gfc_define_builtin ("__builtin_memcpy", ftype, BUILT_IN_MEMCPY, + "memcpy", false); + + tmp = tree_cons (NULL_TREE, integer_type_node, voidchain); + ftype = build_function_type (integer_type_node, tmp); + gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ, "clz", true); + + tmp = tree_cons (NULL_TREE, long_integer_type_node, voidchain); + ftype = build_function_type (integer_type_node, tmp); + gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL, "clzl", true); + + tmp = tree_cons (NULL_TREE, long_long_integer_type_node, voidchain); + ftype = build_function_type (integer_type_node, tmp); + gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL, "clzll", true); + + tmp = tree_cons (NULL_TREE, pvoid_type_node, voidchain); + tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp); + tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp); + ftype = build_function_type (void_type_node, tmp); + gfc_define_builtin ("__builtin_init_trampoline", ftype, + BUILT_IN_INIT_TRAMPOLINE, "init_trampoline", false); + + tmp = tree_cons (NULL_TREE, pvoid_type_node, voidchain); + ftype = build_function_type (pvoid_type_node, tmp); + gfc_define_builtin ("__builtin_adjust_trampoline", ftype, + BUILT_IN_ADJUST_TRAMPOLINE, "adjust_trampoline", true); + + tmp = tree_cons (NULL_TREE, pvoid_type_node, voidchain); + tmp = tree_cons (NULL_TREE, size_type_node, voidchain); + ftype = build_function_type (pvoid_type_node, tmp); + gfc_define_builtin ("__builtin_stack_alloc", ftype, BUILT_IN_STACK_ALLOC, + "stack_alloc", false); + + /* The stack_save and stack_restore builtins aren't used directly. They + are inserted during gimplification to implement stack_alloc calls. */ + ftype = build_function_type (pvoid_type_node, voidchain); + gfc_define_builtin ("__builtin_stack_save", ftype, BUILT_IN_STACK_SAVE, + "stack_save", false); + tmp = tree_cons (NULL_TREE, pvoid_type_node, voidchain); + ftype = build_function_type (void_type_node, tmp); + gfc_define_builtin ("__builtin_stack_restore", ftype, BUILT_IN_STACK_RESTORE, + "stack_restore", false); +} + +#undef DEFINE_MATH_BUILTIN + +#include "gt-fortran-f95-lang.h" +#include "gtype-fortran.h" diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h new file mode 100644 index 00000000000..71665dd6d07 --- /dev/null +++ b/gcc/fortran/gfortran.h @@ -0,0 +1,1652 @@ +/* gfortran header file + Copyright (C) 2000, 2001, 2002, 2003 + Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifndef GCC_GFORTRAN_H +#define GCC_GFORTRAN_H + +/* It's probably insane to have this large of a header file, but it + seemed like everything had to be recompiled anyway when a change + was made to a header file, and there were ordering issues with + multiple header files. Besides, Microsoft's winnt.h was 250k last + time I looked, so by comparison this is perfectly reasonable. */ + +/* We need system.h for HOST_WIDE_INT. Including hwint.h by itself doesn't + seem to be sufficient on some systems. */ +#include "system.h" +#include "coretypes.h" + +/* The following ifdefs are recommended by the autoconf documentation + for any code using alloca. */ + +/* AIX requires this to be the first thing in the file. */ +#ifdef __GNUC__ +#else /* not __GNUC__ */ +#ifdef HAVE_ALLOCA_H +#include <alloca.h> +#else /* do not HAVE_ALLOCA_H */ +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif /* not predefined */ +#endif /* not _AIX */ +#endif /* do not HAVE_ALLOCA_H */ +#endif /* not __GNUC__ */ + + +#include <stdio.h> /* need FILE * here */ + +/* Major control parameters. */ + +#define GFC_VERSION "0.23" +#define GFC_MAX_SYMBOL_LEN 63 +#define GFC_REAL_BITS 100 /* Number of bits in g95's floating point numbers. */ +#define GFC_MAX_LINE 132 /* Characters beyond this are not seen. */ +#define GFC_MAX_DIMENSIONS 7 /* Maximum dimensions in an array. */ +#define GFC_LETTERS 26 /* Number of letters in the alphabet. */ +#define MAX_ERROR_MESSAGE 1000 /* Maximum length of an error message. */ + +#define free(x) Use_gfc_free_instead_of_free() +#define gfc_is_whitespace(c) ((c==' ') || (c=='\t')) + +#ifndef NULL +#define NULL ((void *) 0) +#endif + +/* Stringization. */ +#define stringize(x) expand_macro(x) +#define expand_macro(x) # x + +/* For a the runtime library, a standard prefix is a requirement to + avoid cluttering the namespace with things nobody asked for. It's + ugly to look at and a pain to type when you add the prefix by hand, + so we hide it behind a macro. */ +#define PREFIX(x) "_gfortran_" x + +/* Macro to initialize an mstring structure. */ +#define minit(s, t) { s, NULL, t } + +/* Structure for storing strings to be matched by gfc_match_string. */ +typedef struct +{ + const char *string; + const char *mp; + int tag; +} +mstring; + + +/* Flags to specify which standardi/extension contains a feature. */ +#define GFC_STD_GNU (1<<5) /* GNU Fortran extension. */ +#define GFC_STD_F2003 (1<<4) /* New in F2003. */ +#define GFC_STD_F2003_DEL (1<<3) /* Deleted in F2003. */ +#define GFC_STD_F2003_OBS (1<<2) /* Obsoleted in F2003. */ +#define GFC_STD_F95_DEL (1<<1) /* Deleted in F95. */ +#define GFC_STD_F95_OBS (1<<0) /* Obsoleted in F95. */ + +/*************************** Enums *****************************/ + +/* The author remains confused to this day about the convention of + returning '0' for 'SUCCESS'... or was it the other way around? The + following enum makes things much more readable. We also start + values off at one instead of zero. */ + +typedef enum +{ SUCCESS = 1, FAILURE } +try; + +/* Matchers return one of these three values. The difference between + MATCH_NO and MATCH_ERROR is that MATCH_ERROR means that a match was + successful, but that something non-syntactic is wrong and an error + has already been issued. */ + +typedef enum +{ MATCH_NO = 1, MATCH_YES, MATCH_ERROR } +match; + +typedef enum +{ FORM_FREE, FORM_FIXED, FORM_UNKNOWN } +gfc_source_form; + +typedef enum +{ BT_UNKNOWN = 1, BT_INTEGER, BT_REAL, BT_COMPLEX, + BT_LOGICAL, BT_CHARACTER, BT_DERIVED, BT_PROCEDURE +} +bt; + +/* Expression node types. */ +typedef enum +{ EXPR_OP = 1, EXPR_FUNCTION, EXPR_CONSTANT, EXPR_VARIABLE, + EXPR_SUBSTRING, EXPR_STRUCTURE, EXPR_ARRAY, EXPR_NULL +} +expr_t; + +/* Array types. */ +typedef enum +{ AS_EXPLICIT = 1, AS_ASSUMED_SHAPE, AS_DEFERRED, + AS_ASSUMED_SIZE, AS_UNKNOWN +} +array_type; + +typedef enum +{ AR_FULL = 1, AR_ELEMENT, AR_SECTION, AR_UNKNOWN } +ar_type; + +/* Statement label types. */ +typedef enum +{ ST_LABEL_UNKNOWN = 1, ST_LABEL_TARGET, + ST_LABEL_BAD_TARGET, ST_LABEL_FORMAT +} +gfc_sl_type; + +/* Intrinsic operators. */ +typedef enum +{ GFC_INTRINSIC_BEGIN = 0, + INTRINSIC_NONE = -1, INTRINSIC_UPLUS = GFC_INTRINSIC_BEGIN, + INTRINSIC_UMINUS, INTRINSIC_PLUS, INTRINSIC_MINUS, INTRINSIC_TIMES, + INTRINSIC_DIVIDE, INTRINSIC_POWER, INTRINSIC_CONCAT, + INTRINSIC_AND, INTRINSIC_OR, INTRINSIC_EQV, INTRINSIC_NEQV, + INTRINSIC_EQ, INTRINSIC_NE, INTRINSIC_GT, INTRINSIC_GE, + INTRINSIC_LT, INTRINSIC_LE, INTRINSIC_NOT, INTRINSIC_USER, + INTRINSIC_ASSIGN, + GFC_INTRINSIC_END /* Sentinel */ +} +gfc_intrinsic_op; + + +/* Strings for all intrinsic operators. */ +extern mstring intrinsic_operators[]; + + +/* This macro is the number of intrinsic operators that exist. + Assumptions are made about the numbering of the interface_op enums. */ +#define GFC_INTRINSIC_OPS GFC_INTRINSIC_END + +/* Arithmetic results. */ +typedef enum +{ ARITH_OK = 1, ARITH_OVERFLOW, ARITH_UNDERFLOW, + ARITH_DIV0, ARITH_0TO0, ARITH_INCOMMENSURATE +} +arith; + +/* Statements. */ +typedef enum +{ + ST_ARITHMETIC_IF, ST_ALLOCATE, ST_ATTR_DECL, ST_BACKSPACE, ST_BLOCK_DATA, + ST_CALL, ST_CASE, ST_CLOSE, ST_COMMON, ST_CONTINUE, ST_CONTAINS, ST_CYCLE, + ST_DATA, ST_DATA_DECL, ST_DEALLOCATE, ST_DO, ST_ELSE, ST_ELSEIF, + ST_ELSEWHERE, ST_END_BLOCK_DATA, ST_ENDDO, ST_IMPLIED_ENDDO, + ST_END_FILE, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF, ST_END_INTERFACE, + ST_END_MODULE, ST_END_PROGRAM, ST_END_SELECT, ST_END_SUBROUTINE, + ST_END_WHERE, ST_END_TYPE, ST_ENTRY, ST_EQUIVALENCE, ST_EXIT, ST_FORALL, + ST_FORALL_BLOCK, ST_FORMAT, ST_FUNCTION, ST_GOTO, ST_IF_BLOCK, ST_IMPLICIT, + ST_IMPLICIT_NONE, ST_INQUIRE, ST_INTERFACE, ST_PARAMETER, ST_MODULE, + ST_MODULE_PROC, ST_NAMELIST, ST_NULLIFY, ST_OPEN, ST_PAUSE, ST_PRIVATE, + ST_PROGRAM, ST_PUBLIC, ST_READ, ST_RETURN, ST_REWIND, ST_STOP, + ST_SUBROUTINE, + ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WRITE, ST_ASSIGNMENT, + ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE, ST_SIMPLE_IF, + ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT, ST_NONE +} +gfc_statement; + + +/* Types of interfaces that we can have. Assignment interfaces are + considered to be intrinsic operators. */ +typedef enum +{ + INTERFACE_NAMELESS = 1, INTERFACE_GENERIC, + INTERFACE_INTRINSIC_OP, INTERFACE_USER_OP +} +interface_type; + +/* Symbol flavors: these are all mutually exclusive. + 10 elements = 4 bits. */ +typedef enum +{ + FL_UNKNOWN = 0, FL_PROGRAM, FL_BLOCK_DATA, FL_MODULE, FL_VARIABLE, + FL_PARAMETER, FL_LABEL, FL_PROCEDURE, FL_DERIVED, FL_NAMELIST +} +sym_flavor; + +/* Procedure types. 7 elements = 3 bits. */ +typedef enum +{ PROC_UNKNOWN, PROC_MODULE, PROC_INTERNAL, PROC_DUMMY, + PROC_INTRINSIC, PROC_ST_FUNCTION, PROC_EXTERNAL +} +procedure_type; + +/* Intent types. */ +typedef enum +{ INTENT_UNKNOWN = 0, INTENT_IN, INTENT_OUT, INTENT_INOUT +} +sym_intent; + +/* Access types. */ +typedef enum +{ ACCESS_PUBLIC = 1, ACCESS_PRIVATE, ACCESS_UNKNOWN +} +gfc_access; + +/* Flags to keep track of where an interface came from. + 4 elements = 2 bits. */ +typedef enum +{ IFSRC_UNKNOWN = 0, IFSRC_DECL, IFSRC_IFBODY, IFSRC_USAGE +} +ifsrc; + +/* Strings for all symbol attributes. We use these for dumping the + parse tree, in error messages, and also when reading and writing + modules. In symbol.c. */ +extern const mstring flavors[]; +extern const mstring procedures[]; +extern const mstring intents[]; +extern const mstring access_types[]; +extern const mstring ifsrc_types[]; + +/* Enumeration of all the generic intrinsic functions. Used by the + backend for identification of a function. */ + +enum gfc_generic_isym_id +{ + /* GFC_ISYM_NONE is used for intrinsics which will never be seen by + the backend (eg. KIND). */ + GFC_ISYM_NONE = 0, + GFC_ISYM_ABS, + GFC_ISYM_ACHAR, + GFC_ISYM_ACOS, + GFC_ISYM_ADJUSTL, + GFC_ISYM_ADJUSTR, + GFC_ISYM_AIMAG, + GFC_ISYM_AINT, + GFC_ISYM_ALL, + GFC_ISYM_ALLOCATED, + GFC_ISYM_ANINT, + GFC_ISYM_ANY, + GFC_ISYM_ASIN, + GFC_ISYM_ASSOCIATED, + GFC_ISYM_ATAN, + GFC_ISYM_ATAN2, + GFC_ISYM_BTEST, + GFC_ISYM_CEILING, + GFC_ISYM_CHAR, + GFC_ISYM_CMPLX, + GFC_ISYM_CONJG, + GFC_ISYM_COS, + GFC_ISYM_COSH, + GFC_ISYM_COUNT, + GFC_ISYM_CSHIFT, + GFC_ISYM_DBLE, + GFC_ISYM_DIM, + GFC_ISYM_DOT_PRODUCT, + GFC_ISYM_DPROD, + GFC_ISYM_EOSHIFT, + GFC_ISYM_EXP, + GFC_ISYM_EXPONENT, + GFC_ISYM_FLOOR, + GFC_ISYM_FRACTION, + GFC_ISYM_IACHAR, + GFC_ISYM_IAND, + GFC_ISYM_IBCLR, + GFC_ISYM_IBITS, + GFC_ISYM_IBSET, + GFC_ISYM_ICHAR, + GFC_ISYM_IEOR, + GFC_ISYM_INDEX, + GFC_ISYM_INT, + GFC_ISYM_IOR, + GFC_ISYM_ISHFT, + GFC_ISYM_ISHFTC, + GFC_ISYM_LBOUND, + GFC_ISYM_LEN, + GFC_ISYM_LEN_TRIM, + GFC_ISYM_LGE, + GFC_ISYM_LGT, + GFC_ISYM_LLE, + GFC_ISYM_LLT, + GFC_ISYM_LOG, + GFC_ISYM_LOG10, + GFC_ISYM_LOGICAL, + GFC_ISYM_MATMUL, + GFC_ISYM_MAX, + GFC_ISYM_MAXLOC, + GFC_ISYM_MAXVAL, + GFC_ISYM_MERGE, + GFC_ISYM_MIN, + GFC_ISYM_MINLOC, + GFC_ISYM_MINVAL, + GFC_ISYM_MOD, + GFC_ISYM_MODULO, + GFC_ISYM_NEAREST, + GFC_ISYM_NINT, + GFC_ISYM_NOT, + GFC_ISYM_PACK, + GFC_ISYM_PRESENT, + GFC_ISYM_PRODUCT, + GFC_ISYM_REAL, + GFC_ISYM_REPEAT, + GFC_ISYM_RESHAPE, + GFC_ISYM_RRSPACING, + GFC_ISYM_SCALE, + GFC_ISYM_SCAN, + GFC_ISYM_SET_EXPONENT, + GFC_ISYM_SHAPE, + GFC_ISYM_SI_KIND, + GFC_ISYM_SIGN, + GFC_ISYM_SIN, + GFC_ISYM_SINH, + GFC_ISYM_SIZE, + GFC_ISYM_SPACING, + GFC_ISYM_SPREAD, + GFC_ISYM_SQRT, + GFC_ISYM_SR_KIND, + GFC_ISYM_SUM, + GFC_ISYM_TAN, + GFC_ISYM_TANH, + GFC_ISYM_TRANSFER, + GFC_ISYM_TRANSPOSE, + GFC_ISYM_TRIM, + GFC_ISYM_UBOUND, + GFC_ISYM_UNPACK, + GFC_ISYM_VERIFY, + GFC_ISYM_CONVERSION +}; +typedef enum gfc_generic_isym_id gfc_generic_isym_id; + +/************************* Structures *****************************/ + +/* Symbol attribute structure. */ +typedef struct +{ + /* Variable attributes. */ + unsigned allocatable:1, dimension:1, external:1, intrinsic:1, + optional:1, pointer:1, save:1, target:1, + dummy:1, common:1, result:1, entry:1, assign:1; + + unsigned data:1, /* Symbol is named in a DATA statement. */ + use_assoc:1; /* Symbol has been use-associated. */ + + unsigned in_namelist:1, in_common:1, saved_common:1; + unsigned function:1, subroutine:1, generic:1; + unsigned implicit_type:1; /* Type defined via implicit rules */ + + /* Function/subroutine attributes */ + unsigned sequence:1, elemental:1, pure:1, recursive:1; + unsigned unmaskable:1, masked:1, contained:1; + + /* Set if a function must always be referenced by an explicit interface. */ + unsigned always_explicit:1; + + /* Set if the symbol has been referenced in an expression. No further + modification of type or type parameters is permitted. */ + unsigned referenced:1; + + /* Mutually exclusive multibit attributes. */ + gfc_access access:2; + sym_intent intent:2; + sym_flavor flavor:4; + ifsrc if_source:2; + + procedure_type proc:3; + +} +symbol_attribute; + + +typedef struct +{ + char *nextc; + int line; /* line within the lp structure */ + struct linebuf *lp; + struct gfc_file *file; +} +locus; + +/* The linebuf structure deserves some explanation. This is the + primary structure for holding lines. A source file is stored in a + singly linked list of these structures. Each structure holds an + integer number of lines. The line[] member is actually an array of + pointers that point to the NULL-terminated lines. This list grows + upwards, and the actual lines are stored at the top of the + structure and grow downward. Each structure is packed with as many + lines as it can hold, then another linebuf is allocated. */ + +/* Chosen so that sizeof(linebuf) = 4096 on most machines */ +#define LINEBUF_SIZE 4080 + +typedef struct linebuf +{ + int start_line, lines; + struct linebuf *next; + char *line[1]; + char buf[LINEBUF_SIZE]; +} +linebuf; + + +#include <limits.h> +#ifndef PATH_MAX +# include <sys/param.h> +# define PATH_MAX MAXPATHLEN +#endif + + +typedef struct gfc_file +{ + char filename[PATH_MAX + 1]; + gfc_source_form form; + struct gfc_file *included_by, *next; + locus loc; + struct linebuf *start; +} +gfc_file; + + +extern int gfc_suppress_error; + + +/* Character length structures hold the expression that gives the + length of a character variable. We avoid putting these into + gfc_typespec because doing so prevents us from doing structure + copies and forces us to deallocate any typespecs we create, as well + as structures that contain typespecs. They also can have multiple + character typespecs pointing to them. + + These structures form a singly linked list within the current + namespace and are deallocated with the namespace. It is possible to + end up with gfc_charlen structures that have nothing pointing to them. */ + +typedef struct gfc_charlen +{ + struct gfc_expr *length; + struct gfc_charlen *next; + tree backend_decl; +} +gfc_charlen; + +#define gfc_get_charlen() gfc_getmem(sizeof(gfc_charlen)) + +/* Type specification structure. FIXME: derived and cl could be union??? */ +typedef struct +{ + bt type; + int kind; + struct gfc_symbol *derived; + gfc_charlen *cl; /* For character types only. */ +} +gfc_typespec; + +/* Array specification. */ +typedef struct +{ + int rank; /* A rank of zero means that a variable is a scalar. */ + array_type type; + struct gfc_expr *lower[GFC_MAX_DIMENSIONS], *upper[GFC_MAX_DIMENSIONS]; +} +gfc_array_spec; + +#define gfc_get_array_spec() gfc_getmem(sizeof(gfc_array_spec)) + + +/* Components of derived types. */ +typedef struct gfc_component +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_typespec ts; + + int pointer, dimension; + gfc_array_spec *as; + + tree backend_decl; + locus loc; + struct gfc_expr *initializer; + struct gfc_component *next; +} +gfc_component; + +#define gfc_get_component() gfc_getmem(sizeof(gfc_component)) + +/* Formal argument lists are lists of symbols. */ +typedef struct gfc_formal_arglist +{ + struct gfc_symbol *sym; + struct gfc_formal_arglist *next; +} +gfc_formal_arglist; + +#define gfc_get_formal_arglist() gfc_getmem(sizeof(gfc_formal_arglist)) + + +/* The gfc_actual_arglist structure is for actual arguments. */ +typedef struct gfc_actual_arglist +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + /* Alternate return label when the expr member is null. */ + struct gfc_st_label *label; + + struct gfc_expr *expr; + struct gfc_actual_arglist *next; +} +gfc_actual_arglist; + +#define gfc_get_actual_arglist() gfc_getmem(sizeof(gfc_actual_arglist)) + + +/* Because a symbol can belong to multiple namelists, they must be + linked externally to the symbol itself. */ +typedef struct gfc_namelist +{ + struct gfc_symbol *sym; + struct gfc_namelist *next; +} +gfc_namelist; + +#define gfc_get_namelist() gfc_getmem(sizeof(gfc_namelist)) + + +/* The gfc_st_label structure is a doubly linked list attached to a + namespace that records the usage of statement labels within that + space. */ +/* TODO: Make format/statement specifics a union. */ +typedef struct gfc_st_label +{ + int value; + + gfc_sl_type defined, referenced; + + struct gfc_expr *format; + + tree backend_decl; + + locus where; + + struct gfc_st_label *prev, *next; +} +gfc_st_label; + + +/* gfc_interface()-- Interfaces are lists of symbols strung together. */ +typedef struct gfc_interface +{ + struct gfc_symbol *sym; + locus where; + struct gfc_interface *next; +} +gfc_interface; + +#define gfc_get_interface() gfc_getmem(sizeof(gfc_interface)) + + +/* User operator nodes. These are like stripped down symbols. */ +typedef struct +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + + gfc_interface *operator; + struct gfc_namespace *ns; + gfc_access access; +} +gfc_user_op; + +/* Symbol nodes. These are important things. They are what the + standard refers to as "entities". The possibly multiple names that + refer to the same entity are accomplished by a binary tree of + symtree structures that is balanced by the red-black method-- more + than one symtree node can point to any given symbol. */ + +typedef struct gfc_symbol +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; /* Primary name, before renaming */ + char module[GFC_MAX_SYMBOL_LEN + 1]; /* Module this symbol came from */ + locus declared_at; + + gfc_typespec ts; + symbol_attribute attr; + + /* The interface member points to the formal argument list if the + symbol is a function or subroutine name. If the symbol is a + generic name, the generic member points to the list of + interfaces. */ + + gfc_interface *generic; + gfc_access component_access; + + gfc_formal_arglist *formal; + struct gfc_namespace *formal_ns; + + struct gfc_expr *value; /* Parameter/Initializer value */ + gfc_array_spec *as; + struct gfc_symbol *result; /* function result symbol */ + gfc_component *components; /* Derived type components */ + + /* TODO: These three fields are mutually exclusive. */ + struct gfc_symbol *common_head, *common_next; /* Links for COMMON syms */ + /* Make sure setup code for dummy arguments is generated in the correct + order. */ + int dummy_order; + + gfc_namelist *namelist, *namelist_tail; + + /* Change management fields. Symbols that might be modified by the + current statement have the mark member nonzero and are kept in a + singly linked list through the tlink field. Of these symbols, + symbols with old_symbol equal to NULL are symbols created within + the current statement. Otherwise, old_symbol points to a copy of + the old symbol. */ + + struct gfc_symbol *old_symbol, *tlink; + unsigned mark:1, new:1; + int refs; + struct gfc_namespace *ns; /* namespace containing this symbol */ + + tree backend_decl; + +} +gfc_symbol; + + +/* Within a namespace, symbols are pointed to by symtree nodes that + are linked together in a balanced binary tree. There can be + several symtrees pointing to the same symbol node via USE + statements. */ + +#define BBT_HEADER(self) int priority; struct self *left, *right + +typedef struct gfc_symtree +{ + BBT_HEADER (gfc_symtree); + char name[GFC_MAX_SYMBOL_LEN + 1]; + int ambiguous; + union + { + gfc_symbol *sym; /* Symbol associated with this node */ + gfc_user_op *uop; + } + n; + +} +gfc_symtree; + + +typedef struct gfc_namespace +{ + gfc_symtree *sym_root, *uop_root; /* Roots of the red/black symbol trees */ + + int set_flag[GFC_LETTERS]; + gfc_typespec default_type[GFC_LETTERS]; /* IMPLICIT typespecs */ + + struct gfc_symbol *proc_name; + gfc_interface *operator[GFC_INTRINSIC_OPS]; + struct gfc_namespace *parent, *contained, *sibling; + struct gfc_code *code; + gfc_symbol *blank_common; + struct gfc_equiv *equiv; + gfc_access default_access, operator_access[GFC_INTRINSIC_OPS]; + + gfc_st_label *st_labels; + struct gfc_data *data; + + gfc_charlen *cl_list; + + int save_all, seen_save; +} +gfc_namespace; + +extern gfc_namespace *gfc_current_ns; + + +/* Information on interfaces being built. */ +typedef struct +{ + interface_type type; + gfc_symbol *sym; + gfc_namespace *ns; + gfc_user_op *uop; + gfc_intrinsic_op op; +} +gfc_interface_info; + +extern gfc_interface_info current_interface; + + +/* Array reference. */ +typedef struct gfc_array_ref +{ + ar_type type; + int dimen; /* # of components in the reference */ + locus where; + gfc_array_spec *as; + + locus c_where[GFC_MAX_DIMENSIONS]; /* All expressions can be NULL */ + struct gfc_expr *start[GFC_MAX_DIMENSIONS], *end[GFC_MAX_DIMENSIONS], + *stride[GFC_MAX_DIMENSIONS]; + + enum + { DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_UNKNOWN } + dimen_type[GFC_MAX_DIMENSIONS]; + + struct gfc_expr *offset; +} +gfc_array_ref; + +#define gfc_get_array_ref() gfc_getmem(sizeof(gfc_array_ref)) + + +/* Component reference nodes. A variable is stored as an expression + node that points to the base symbol. After that, a singly linked + list of component reference nodes gives the variable's complete + resolution. The array_ref component may be present and comes + before the component component. */ + +typedef enum + { REF_ARRAY, REF_COMPONENT, REF_SUBSTRING } +ref_type; + +typedef struct gfc_ref +{ + ref_type type; + + union + { + struct gfc_array_ref ar; + + struct + { + gfc_component *component; + gfc_symbol *sym; + } + c; + + struct + { + struct gfc_expr *start, *end; /* Substring */ + gfc_charlen *length; + } + ss; + + } + u; + + struct gfc_ref *next; +} +gfc_ref; + +#define gfc_get_ref() gfc_getmem(sizeof(gfc_ref)) + + +/* Structures representing intrinsic symbols and their arguments lists. */ +typedef struct gfc_intrinsic_arg +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + + gfc_typespec ts; + int optional; + gfc_actual_arglist *actual; + + struct gfc_intrinsic_arg *next; + +} +gfc_intrinsic_arg; + + +typedef union +{ + try (*f1)(struct gfc_expr *); + try (*f1m)(gfc_actual_arglist *); + try (*f2)(struct gfc_expr *, struct gfc_expr *); + try (*f3)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *); + try (*f4)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *, + struct gfc_expr *); + try (*f5)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *, + struct gfc_expr *, struct gfc_expr *); +} +gfc_check_f; + + +typedef union +{ + struct gfc_expr *(*f1)(struct gfc_expr *); + struct gfc_expr *(*f2)(struct gfc_expr *, struct gfc_expr *); + struct gfc_expr *(*f3)(struct gfc_expr *, struct gfc_expr *, + struct gfc_expr *); + struct gfc_expr *(*f4)(struct gfc_expr *, struct gfc_expr *, + struct gfc_expr *, struct gfc_expr *); + struct gfc_expr *(*f5)(struct gfc_expr *, struct gfc_expr *, + struct gfc_expr *, struct gfc_expr *, + struct gfc_expr *); + struct gfc_expr *(*cc)(struct gfc_expr *, bt, int); +} +gfc_simplify_f; + + +typedef union +{ + void (*f0)(struct gfc_expr *); + void (*f1)(struct gfc_expr *, struct gfc_expr *); + void (*f1m)(struct gfc_expr *, struct gfc_actual_arglist *); + void (*f2)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *); + void (*f3)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *, + struct gfc_expr *); + void (*f4)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *, + struct gfc_expr *, struct gfc_expr *); + void (*f5)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *, + struct gfc_expr *, struct gfc_expr *, struct gfc_expr *); + void (*s1)(struct gfc_code *); +} +gfc_resolve_f; + + +typedef struct gfc_intrinsic_sym +{ + char name[GFC_MAX_SYMBOL_LEN + 1], lib_name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_intrinsic_arg *formal; + gfc_typespec ts; + int elemental, pure, generic, specific, actual_ok; + + gfc_simplify_f simplify; + gfc_check_f check; + gfc_resolve_f resolve; + struct gfc_intrinsic_sym *specific_head, *next; + gfc_generic_isym_id generic_id; + +} +gfc_intrinsic_sym; + + +/* Expression nodes. The expression node types deserve explanations, + since the last couple can be easily misconstrued: + + EXPR_OP Operator node pointing to one or two other nodes + EXPR_FUNCTION Function call, symbol points to function's name + EXPR_CONSTANT A scalar constant: Logical, String, Real, Int or Complex + EXPR_VARIABLE An Lvalue with a root symbol and possible reference list + which expresses structure, array and substring refs. + EXPR_NULL The NULL pointer value (which also has a basic type). + EXPR_SUBSTRING A substring of a constant string + EXPR_STRUCTURE A structure constructor + EXPR_ARRAY An array constructor. */ + +#include <gmp.h> + +typedef struct gfc_expr +{ + expr_t expr_type; + + gfc_typespec ts; /* These two refer to the overall expression */ + + int rank; + mpz_t *shape; /* Can be NULL if shape is unknown at compile time */ + + gfc_intrinsic_op operator; + + /* Nonnull for functions and structure constructors */ + gfc_symtree *symtree; + + gfc_user_op *uop; + gfc_ref *ref; + + struct gfc_expr *op1, *op2; + locus where; + + union + { + mpz_t integer; + mpf_t real; + int logical; + + struct + { + mpf_t r, i; + } + complex; + + struct + { + gfc_actual_arglist *actual; + char *name; /* Points to the ultimate name of the function */ + gfc_intrinsic_sym *isym; + gfc_symbol *esym; + } + function; + + struct + { + int length; + char *string; + } + character; + + struct gfc_constructor *constructor; + } + value; + +} +gfc_expr; + + +#define gfc_get_shape(rank) ((mpz_t *) gfc_getmem(rank*sizeof(mpz_t))) + +/* Structures for information associated with different kinds of + numbers. The first set of integer parameters define all there is + to know about a particular kind. The rest of the elements are + computed from the first elements. */ + +typedef struct +{ + int kind, radix, digits, bit_size; + + int range; + mpz_t huge; + + mpz_t min_int, max_int; /* Values really representable by the target */ +} +gfc_integer_info; + +extern gfc_integer_info gfc_integer_kinds[]; + + +typedef struct +{ + int kind, bit_size; + +} +gfc_logical_info; + +extern gfc_logical_info gfc_logical_kinds[]; + + +typedef struct +{ + int kind, radix, digits, min_exponent, max_exponent; + + int range, precision; + mpf_t epsilon, huge, tiny; +} +gfc_real_info; + +extern gfc_real_info gfc_real_kinds[]; + + +/* Equivalence structures. Equivalent lvalues are linked along the + *eq pointer, equivalence sets are strung along the *next node. */ +typedef struct gfc_equiv +{ + struct gfc_equiv *next, *eq; + gfc_expr *expr; + int used; +} +gfc_equiv; + +#define gfc_get_equiv() gfc_getmem(sizeof(gfc_equiv)) + + +/* gfc_case stores the selector list of a case statement. The *low + and *high pointers can point to the same expression in the case of + a single value. If *high is NULL, the selection is from *low + upwards, if *low is NULL the selection is *high downwards. + + This structure has separate fields to allow singe and double linked + lists of CASEs the same time. The singe linked list along the NEXT + field is a list of cases for a single CASE label. The double linked + list along the LEFT/RIGHT fields is used to detect overlap and to + build a table of the cases for SELECT constructs with a CHARACTER + case expression. */ + +typedef struct gfc_case +{ + /* Where we saw this case. */ + locus where; + int n; + + /* Case range values. If (low == high), it's a single value. If one of + the labels is NULL, it's an unbounded case. If both are NULL, this + represents the default case. */ + gfc_expr *low, *high; + + /* Next case label in the list of cases for a single CASE label. */ + struct gfc_case *next; + + /* Used for detecting overlap, and for code generation. */ + struct gfc_case *left, *right; + + /* True if this case label can never be matched. */ + int unreachable; +} +gfc_case; + +#define gfc_get_case() gfc_getmem(sizeof(gfc_case)) + + +typedef struct +{ + gfc_expr *var, *start, *end, *step; +} +gfc_iterator; + +#define gfc_get_iterator() gfc_getmem(sizeof(gfc_iterator)) + + +/* Allocation structure for ALLOCATE, DEALLOCATE and NULLIFY statements. */ + +typedef struct gfc_alloc +{ + gfc_expr *expr; + struct gfc_alloc *next; +} +gfc_alloc; + +#define gfc_get_alloc() gfc_getmem(sizeof(gfc_alloc)) + + +typedef struct +{ + gfc_expr *unit, *file, *status, *access, *form, *recl, + *blank, *position, *action, *delim, *pad, *iostat; + gfc_st_label *err; +} +gfc_open; + + +typedef struct +{ + gfc_expr *unit, *status, *iostat; + gfc_st_label *err; +} +gfc_close; + + +typedef struct +{ + gfc_expr *unit, *iostat; + gfc_st_label *err; +} +gfc_filepos; + + +typedef struct +{ + gfc_expr *unit, *file, *iostat, *exist, *opened, *number, *named, + *name, *access, *sequential, *direct, *form, *formatted, + *unformatted, *recl, *nextrec, *blank, *position, *action, *read, + *write, *readwrite, *delim, *pad, *iolength; + + gfc_st_label *err; + +} +gfc_inquire; + + +typedef struct +{ + gfc_expr *io_unit, *format_expr, *rec, *advance, *iostat, *size; + + gfc_symbol *namelist; + /* A format_label of `format_asterisk' indicates the "*" format */ + gfc_st_label *format_label; + gfc_st_label *err, *end, *eor; + + locus eor_where, end_where; +} +gfc_dt; + + +typedef struct gfc_forall_iterator +{ + gfc_expr *var, *start, *end, *stride; + struct gfc_forall_iterator *next; +} +gfc_forall_iterator; + + +/* Executable statements that fill gfc_code structures. */ +typedef enum +{ + EXEC_NOP = 1, EXEC_ASSIGN, EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN, + EXEC_GOTO, EXEC_CALL, EXEC_RETURN, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, + EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT, + EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, + EXEC_ALLOCATE, EXEC_DEALLOCATE, + EXEC_OPEN, EXEC_CLOSE, + EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END, + EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND +} +gfc_exec_op; + +typedef struct gfc_code +{ + gfc_exec_op op; + + struct gfc_code *block, *next; + locus loc; + + gfc_st_label *here, *label, *label2, *label3; + gfc_symtree *symtree; + gfc_expr *expr, *expr2; + /* A name isn't sufficient to identify a subroutine, we need the actual + symbol for the interface definition. + const char *sub_name; */ + gfc_symbol *resolved_sym; + + union + { + gfc_actual_arglist *actual; + gfc_case *case_list; + gfc_iterator *iterator; + gfc_alloc *alloc_list; + gfc_open *open; + gfc_close *close; + gfc_filepos *filepos; + gfc_inquire *inquire; + gfc_dt *dt; + gfc_forall_iterator *forall_iterator; + struct gfc_code *whichloop; + int stop_code; + } + ext; /* Points to additional structures required by statement */ + + /* Backend_decl is used for cycle and break labels in do loops, and + * probably for other constructs as well, once we translate them. */ + tree backend_decl; +} +gfc_code; + + +/* Storage for DATA statements. */ +typedef struct gfc_data_variable +{ + gfc_expr *expr; + gfc_iterator iter; + struct gfc_data_variable *list, *next; +} +gfc_data_variable; + + +typedef struct gfc_data_value +{ + int repeat; + gfc_expr *expr; + + struct gfc_data_value *next; +} +gfc_data_value; + + +typedef struct gfc_data +{ + gfc_data_variable *var; + gfc_data_value *value; + locus where; + + struct gfc_data *next; +} +gfc_data; + +#define gfc_get_data_variable() gfc_getmem(sizeof(gfc_data_variable)) +#define gfc_get_data_value() gfc_getmem(sizeof(gfc_data_value)) +#define gfc_get_data() gfc_getmem(sizeof(gfc_data)) + + +/* Structure for holding compile options */ +typedef struct +{ + const char *source; + char *module_dir; + gfc_source_form source_form; + int fixed_line_length; + int max_identifier_length; + int verbose; + + int warn_aliasing; + int warn_conversion; + int warn_implicit_interface; + int warn_line_truncation; + int warn_surprising; + int warn_unused_labels; + + int flag_dollar_ok; + int flag_underscoring; + int flag_second_underscore; + int flag_implicit_none; + int flag_max_stack_var_size; + int flag_module_access_private; + int flag_no_backend; + int flag_pack_derived; + int flag_repack_arrays; + + int q_kind; + int r8; + int i8; + int d8; + int warn_std; + int allow_std; +} +gfc_option_t; + +extern gfc_option_t gfc_option; + + +/* Constructor nodes for array and structure constructors. */ +typedef struct gfc_constructor +{ + gfc_expr *expr; + gfc_iterator *iterator; + locus where; + struct gfc_constructor *next; + struct + { + mpz_t offset; /* Record the offset of array element which appears in + data statement like "data a(5)/4/". */ + gfc_component *component; /* Record the component being initialized. */ + } + n; + mpz_t repeat; /* Record the repeat number of initial values in data + statement like "data a/5*10/". */ +} +gfc_constructor; + + +typedef struct iterator_stack +{ + gfc_symtree *variable; + mpz_t value; + struct iterator_stack *prev; +} +iterator_stack; +extern iterator_stack *iter_stack; + +/************************ Function prototypes *************************/ + +/* data.c */ +void gfc_formalize_init_value (gfc_symbol *); +void gfc_get_section_index (gfc_array_ref *, mpz_t *, mpz_t *); +void gfc_assign_data_value (gfc_expr *, gfc_expr *, mpz_t); +void gfc_advance_section (mpz_t *, gfc_array_ref *, mpz_t *); + +/* scanner.c */ +void gfc_scanner_done_1 (void); +void gfc_scanner_init_1 (void); + +void gfc_add_include_path (const char *); +void gfc_release_include_path (void); +FILE *gfc_open_included_file (const char *); + +locus *gfc_current_locus (void); +void gfc_set_locus (locus *); + +int gfc_at_end (void); +int gfc_at_eof (void); +int gfc_at_bol (void); +int gfc_at_eol (void); +void gfc_advance_line (void); +int gfc_check_include (void); + +void gfc_skip_comments (void); +int gfc_next_char_literal (int); +int gfc_next_char (void); +int gfc_peek_char (void); +void gfc_error_recovery (void); +void gfc_gobble_whitespace (void); +try gfc_new_file (const char *, gfc_source_form); + +extern gfc_file *gfc_current_file; + +/* misc.c */ +void *gfc_getmem (size_t) ATTRIBUTE_MALLOC; +void gfc_free (void *); +int gfc_terminal_width(void); +void gfc_clear_ts (gfc_typespec *); +FILE *gfc_open_file (const char *); +const char *gfc_article (const char *); +const char *gfc_basic_typename (bt); +const char *gfc_typename (gfc_typespec *); + +#define gfc_op2string(OP) (OP == INTRINSIC_ASSIGN ? \ + "=" : gfc_code2string (intrinsic_operators, OP)) + +const char *gfc_code2string (const mstring *, int); +int gfc_string2code (const mstring *, const char *); +const char *gfc_intent_string (sym_intent); + +void gfc_init_1 (void); +void gfc_init_2 (void); +void gfc_done_1 (void); +void gfc_done_2 (void); + +/* options.c */ +unsigned int gfc_init_options (unsigned int, const char **); +int gfc_handle_option (size_t, const char *, int); +bool gfc_post_options (const char **); + +/* iresolve.c */ +char * gfc_get_string (const char *, ...) ATTRIBUTE_PRINTF_1; +void gfc_iresolve_init_1 (void); +void gfc_iresolve_done_1 (void); + +/* error.c */ + +typedef struct gfc_error_buf +{ + int flag; + char message[MAX_ERROR_MESSAGE]; +} gfc_error_buf; + +void gfc_error_init_1 (void); +void gfc_buffer_error (int); + +void gfc_warning (const char *, ...); +void gfc_warning_now (const char *, ...); +void gfc_clear_warning (void); +void gfc_warning_check (void); + +void gfc_error (const char *, ...); +void gfc_error_now (const char *, ...); +void gfc_fatal_error (const char *, ...) ATTRIBUTE_NORETURN; +void gfc_internal_error (const char *, ...) ATTRIBUTE_NORETURN; +void gfc_clear_error (void); +int gfc_error_check (void); + +try gfc_notify_std (int, const char *, ...); + +/* A general purpose syntax error. */ +#define gfc_syntax_error(ST) \ + gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST)); + +void gfc_push_error (gfc_error_buf *); +void gfc_pop_error (gfc_error_buf *); + +void gfc_status (const char *, ...) ATTRIBUTE_PRINTF_1; +void gfc_status_char (char); + +void gfc_get_errors (int *, int *); + +/* arith.c */ +void gfc_arith_init_1 (void); +void gfc_arith_done_1 (void); + +/* FIXME: These should go to symbol.c, really... */ +int gfc_default_integer_kind (void); +int gfc_default_real_kind (void); +int gfc_default_double_kind (void); +int gfc_default_character_kind (void); +int gfc_default_logical_kind (void); +int gfc_default_complex_kind (void); +int gfc_validate_kind (bt, int); +extern int gfc_index_integer_kind; + +/* symbol.c */ +void gfc_clear_new_implicit (void); +try gfc_add_new_implicit_range (int, int, gfc_typespec *); +try gfc_merge_new_implicit (void); +void gfc_set_implicit_none (void); +void gfc_set_implicit (void); + +gfc_typespec *gfc_get_default_type (gfc_symbol *, gfc_namespace *); +try gfc_set_default_type (gfc_symbol *, int, gfc_namespace *); + +void gfc_set_component_attr (gfc_component *, symbol_attribute *); +void gfc_get_component_attr (symbol_attribute *, gfc_component *); + +void gfc_set_sym_referenced (gfc_symbol * sym); + +try gfc_add_allocatable (symbol_attribute *, locus *); +try gfc_add_dimension (symbol_attribute *, locus *); +try gfc_add_external (symbol_attribute *, locus *); +try gfc_add_intrinsic (symbol_attribute *, locus *); +try gfc_add_optional (symbol_attribute *, locus *); +try gfc_add_pointer (symbol_attribute *, locus *); +try gfc_add_result (symbol_attribute *, locus *); +try gfc_add_save (symbol_attribute *, locus *); +try gfc_add_saved_common (symbol_attribute *, locus *); +try gfc_add_target (symbol_attribute *, locus *); +try gfc_add_dummy (symbol_attribute *, locus *); +try gfc_add_generic (symbol_attribute *, locus *); +try gfc_add_common (symbol_attribute *, locus *); +try gfc_add_in_common (symbol_attribute *, locus *); +try gfc_add_in_namelist (symbol_attribute *, locus *); +try gfc_add_sequence (symbol_attribute *, locus *); +try gfc_add_elemental (symbol_attribute *, locus *); +try gfc_add_pure (symbol_attribute *, locus *); +try gfc_add_recursive (symbol_attribute *, locus *); +try gfc_add_function (symbol_attribute *, locus *); +try gfc_add_subroutine (symbol_attribute *, locus *); + +try gfc_add_access (symbol_attribute *, gfc_access, locus *); +try gfc_add_flavor (symbol_attribute *, sym_flavor, locus *); +try gfc_add_entry (symbol_attribute *, locus *); +try gfc_add_procedure (symbol_attribute *, procedure_type, locus *); +try gfc_add_intent (symbol_attribute *, sym_intent, locus *); +try gfc_add_explicit_interface (gfc_symbol *, ifsrc, + gfc_formal_arglist *, locus *); +try gfc_add_type (gfc_symbol *, gfc_typespec *, locus *); + +void gfc_clear_attr (symbol_attribute *); +try gfc_missing_attr (symbol_attribute *, locus *); +try gfc_copy_attr (symbol_attribute *, symbol_attribute *, locus *); + +try gfc_add_component (gfc_symbol *, const char *, gfc_component **); +gfc_symbol *gfc_use_derived (gfc_symbol *); +gfc_symtree *gfc_use_derived_tree (gfc_symtree *); +gfc_component *gfc_find_component (gfc_symbol *, const char *); + +gfc_st_label *gfc_get_st_label (int); +void gfc_free_st_label (gfc_st_label *); +void gfc_define_st_label (gfc_st_label *, gfc_sl_type, locus *); +try gfc_reference_st_label (gfc_st_label *, gfc_sl_type); + +gfc_namespace *gfc_get_namespace (gfc_namespace *); +gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *); +gfc_symtree *gfc_find_symtree (gfc_symtree *, const char *); +gfc_user_op *gfc_get_uop (const char *); +gfc_user_op *gfc_find_uop (const char *, gfc_namespace *); +void gfc_free_symbol (gfc_symbol *); +gfc_symbol *gfc_new_symbol (const char *, gfc_namespace *); +int gfc_find_symbol (const char *, gfc_namespace *, int, gfc_symbol **); +int gfc_find_sym_tree (const char *, gfc_namespace *, int, gfc_symtree **); +int gfc_get_symbol (const char *, gfc_namespace *, gfc_symbol **); +int gfc_get_sym_tree (const char *, gfc_namespace *, gfc_symtree **); +int gfc_get_ha_symbol (const char *, gfc_symbol **); +int gfc_get_ha_sym_tree (const char *, gfc_symtree **); + +int gfc_symbols_could_alias (gfc_symbol *, gfc_symbol *); + +void gfc_undo_symbols (void); +void gfc_commit_symbols (void); +void gfc_free_namespace (gfc_namespace *); + +void gfc_symbol_init_2 (void); +void gfc_symbol_done_2 (void); + +void gfc_traverse_symtree (gfc_namespace *, void (*)(gfc_symtree *)); +void gfc_traverse_ns (gfc_namespace *, void (*)(gfc_symbol *)); +void gfc_traverse_user_op (gfc_namespace *, void (*)(gfc_user_op *)); +void gfc_save_all (gfc_namespace *); + +void gfc_symbol_state (void); + +/* intrinsic.c */ +extern int gfc_init_expr; + +/* Given a symbol that we have decided is intrinsic, mark it as such + by placing it into a special module that is otherwise impossible to + read or write. */ + +#define gfc_intrinsic_symbol(SYM) strcpy (SYM->module, "(intrinsic)") + +void gfc_intrinsic_init_1 (void); +void gfc_intrinsic_done_1 (void); + +char gfc_type_letter (bt); +gfc_symbol * gfc_get_intrinsic_sub_symbol (const char *); +try gfc_convert_type (gfc_expr *, gfc_typespec *, int); +try gfc_convert_type_warn (gfc_expr *, gfc_typespec *, int, int); +int gfc_generic_intrinsic (const char *); +int gfc_specific_intrinsic (const char *); +int gfc_intrinsic_name (const char *, int); +gfc_intrinsic_sym *gfc_find_function (const char *); + +match gfc_intrinsic_func_interface (gfc_expr *, int); +match gfc_intrinsic_sub_interface (gfc_code *, int); + +/* simplify.c */ +void gfc_simplify_init_1 (void); +void gfc_simplify_done_1 (void); + +/* match.c -- FIXME */ +void gfc_free_iterator (gfc_iterator *, int); +void gfc_free_forall_iterator (gfc_forall_iterator *); +void gfc_free_alloc_list (gfc_alloc *); +void gfc_free_namelist (gfc_namelist *); +void gfc_free_equiv (gfc_equiv *); +void gfc_free_data (gfc_data *); +void gfc_free_case_list (gfc_case *); + +/* expr.c */ +void gfc_free_actual_arglist (gfc_actual_arglist *); +gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *); +const char *gfc_extract_int (gfc_expr *, int *); + +gfc_expr *gfc_build_conversion (gfc_expr *); +void gfc_free_ref_list (gfc_ref *); +void gfc_type_convert_binary (gfc_expr *); +int gfc_is_constant_expr (gfc_expr *); +try gfc_simplify_expr (gfc_expr *, int); + +gfc_expr *gfc_get_expr (void); +void gfc_free_expr (gfc_expr *); +void gfc_replace_expr (gfc_expr *, gfc_expr *); +gfc_expr *gfc_int_expr (int); +gfc_expr *gfc_logical_expr (int, locus *); +mpz_t *gfc_copy_shape (mpz_t *, int); +gfc_expr *gfc_copy_expr (gfc_expr *); + +try gfc_specification_expr (gfc_expr *); + +int gfc_numeric_ts (gfc_typespec *); +int gfc_kind_max (gfc_expr *, gfc_expr *); + +try gfc_check_conformance (const char *, gfc_expr *, gfc_expr *); +try gfc_check_assign (gfc_expr *, gfc_expr *, int); +try gfc_check_pointer_assign (gfc_expr *, gfc_expr *); +try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *); + +/* st.c */ +extern gfc_code new_st; + +void gfc_clear_new_st (void); +gfc_code *gfc_get_code (void); +gfc_code *gfc_append_code (gfc_code *, gfc_code *); +void gfc_free_statement (gfc_code *); +void gfc_free_statements (gfc_code *); + +/* resolve.c */ +try gfc_resolve_expr (gfc_expr *); +void gfc_resolve (gfc_namespace *); +int gfc_impure_variable (gfc_symbol *); +int gfc_pure (gfc_symbol *); +int gfc_elemental (gfc_symbol *); +try gfc_resolve_iterator (gfc_iterator *); +try gfc_resolve_index (gfc_expr *, int); + +/* array.c */ +void gfc_free_array_spec (gfc_array_spec *); +gfc_array_ref *gfc_copy_array_ref (gfc_array_ref *); + +try gfc_set_array_spec (gfc_symbol *, gfc_array_spec *, locus *); +gfc_array_spec *gfc_copy_array_spec (gfc_array_spec *); +try gfc_resolve_array_spec (gfc_array_spec *, int); + +int gfc_compare_array_spec (gfc_array_spec *, gfc_array_spec *); + +gfc_expr *gfc_start_constructor (bt, int, locus *); +void gfc_append_constructor (gfc_expr *, gfc_expr *); +void gfc_free_constructor (gfc_constructor *); +void gfc_simplify_iterator_var (gfc_expr *); +try gfc_expand_constructor (gfc_expr *); +int gfc_constant_ac (gfc_expr *); +int gfc_expanded_ac (gfc_expr *); +try gfc_resolve_array_constructor (gfc_expr *); +try gfc_check_constructor_type (gfc_expr *); +try gfc_check_iter_variable (gfc_expr *); +try gfc_check_constructor (gfc_expr *, try (*)(gfc_expr *)); +gfc_constructor *gfc_copy_constructor (gfc_constructor * src); +gfc_expr *gfc_get_array_element (gfc_expr *, int); +try gfc_array_size (gfc_expr *, mpz_t *); +try gfc_array_dimen_size (gfc_expr *, int, mpz_t *); +try gfc_array_ref_shape (gfc_array_ref *, mpz_t *); +gfc_array_ref *gfc_find_array_ref (gfc_expr *); +void gfc_insert_constructor (gfc_expr *, gfc_constructor *); +gfc_constructor *gfc_get_constructor (void); +tree gfc_conv_array_initializer (tree type, gfc_expr * expr); +try spec_size (gfc_array_spec *, mpz_t *); + +/* interface.c -- FIXME: some of these should be in symbol.c */ +void gfc_free_interface (gfc_interface *); +int gfc_compare_types (gfc_typespec *, gfc_typespec *); +void gfc_check_interfaces (gfc_namespace *); +void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *); +gfc_symbol *gfc_search_interface (gfc_interface *, int, + gfc_actual_arglist **); +try gfc_extend_expr (gfc_expr *); +void gfc_free_formal_arglist (gfc_formal_arglist *); +try gfc_extend_assign (gfc_code *, gfc_namespace *); +try gfc_add_interface (gfc_symbol * sym); + +/* io.c */ +extern gfc_st_label format_asterisk; + +void gfc_free_open (gfc_open *); +try gfc_resolve_open (gfc_open *); +void gfc_free_close (gfc_close *); +try gfc_resolve_close (gfc_close *); +void gfc_free_filepos (gfc_filepos *); +try gfc_resolve_filepos (gfc_filepos *); +void gfc_free_inquire (gfc_inquire *); +try gfc_resolve_inquire (gfc_inquire *); +void gfc_free_dt (gfc_dt *); +try gfc_resolve_dt (gfc_dt *); + +/* module.c */ +void gfc_module_init_2 (void); +void gfc_module_done_2 (void); +void gfc_dump_module (const char *, int); + +/* primary.c */ +symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *); +symbol_attribute gfc_expr_attr (gfc_expr *); + +/* trans.c */ +void gfc_generate_code (gfc_namespace *); +void gfc_generate_module_code (gfc_namespace *); + +/* bbt.c */ +typedef int (*compare_fn) (void *, void *); +void gfc_insert_bbt (void *, void *, compare_fn); +void gfc_delete_bbt (void *, void *, compare_fn); + +/* dump-parse-tree.c */ +void gfc_show_namespace (gfc_namespace *); + +/* parse.c */ +try gfc_parse_file (void); + +#endif /* GFC_GFC_H */ diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi new file mode 100644 index 00000000000..9b6477e8e4b --- /dev/null +++ b/gcc/fortran/gfortran.texi @@ -0,0 +1,829 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename gfortran.info +@set last-update March 10, 2004 +@set copyrights-gfortran 1999-2004 +@set version-gfortran 0.235 + +@include gcc-common.texi + +@c This indicates that this documentation is still under development. +@c For example, if this option is set, overfull boxes are marked with +@c an ugly black square. +set DEVELOPMENT + +@settitle The GNU Fortran 95 Compiler + +@c Create a separate index for command line options +@defcodeindex op +@c Merge the standard indexes into a single one. +@syncodeindex fn cp +@syncodeindex vr cp +@syncodeindex ky cp +@syncodeindex pg cp +@syncodeindex tp cp + +@c %**end of header + +@c Use with @@smallbook. + +@c %** start of document + +@c Cause even numbered pages to be printed on the left hand side of +@c the page and odd numbered pages to be printed on the right hand +@c side of the page. Using this, you can print on both sides of a +@c sheet of paper and have the text on the same part of the sheet. + +@c The text on right hand pages is pushed towards the right hand +@c margin and the text on left hand pages is pushed toward the left +@c hand margin. +@c (To provide the reverse effect, set bindingoffset to -0.75in.) + +@c @tex +@c \global\bindingoffset=0.75in +@c \global\normaloffset =0.75in +@c @end tex + +@copying +Copyright @copyright{} @value{copyrights-gfortran} Free Software Foundation, Inc. + +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.1 or +any later version published by the Free Software Foundation; with the +Invariant Sections being ``GNU General Public License'' and ``Funding +Free Software'', the Front-Cover +texts being (a) (see below), and with the Back-Cover Texts being (b) +(see below). A copy of the license is included in the section entitled +``GNU Free Documentation License''. + +(a) The FSF's Front-Cover Text is: + + A GNU Manual + +(b) The FSF's Back-Cover Text is: + + You have freedom to copy and modify this GNU Manual, like GNU + software. Copies published by the Free Software Foundation raise + funds for GNU development. +@end copying + +@ifinfo +@dircategory Programming +@direntry +* gfortran: (gfortran). The GNU Fortran 95 Compiler. +@end direntry +This file documents the use and the internals of +the GNU Fortran 95 compiler, (@command{gfortran}). + +Published by the Free Software Foundation +59 Temple Place - Suite 330 +Boston, MA 02111-1307 USA + +@insertcopying +@end ifinfo + +Contributed by Steven Bosscher (@email{s.bosscher@@gcc.gnu.org}). + +@setchapternewpage odd +@titlepage +@title Using GNU Fortran 95 +@sp 2 +@center Steven Bosscher +@sp 3 +@center Last updated @value{last-update} +@sp 1 +@center for version @value {version-gfortran} +@page +@vskip 0pt plus 1filll +For the @value{version-gfortran} Version* +@sp 1 +Published by the Free Software Foundation @* +59 Temple Place - Suite 330@* +Boston, MA 02111-1307, USA@* +@c Last printed ??ber, 19??.@* +@c Printed copies are available for $? each.@* +@c ISBN ??? +@sp 1 +@insertcopying +@end titlepage +@summarycontents +@contents +@page + +@node Top, Copying,, (DIR) +@top Introduction +@cindex Introduction + +This manual documents the use of @command{gfortran}, +the GNU Fortran 95 compiler. You can find in this manual how to invoke +@command{gfortran}, as well as its features and incompatibilities, +and how to report bugs. + +@ifset DEVELOPMENT +@emph{Warning:} This document, and the compiler it describes, are still +under development. While efforts are made too keep it up-to-date it might +not accurately reflect the status of the most recent @command{gfortran}. +@end ifset + +@menu +* Copying:: GNU General Public License says + how you can copy and share GNU Fortran. +* GNU Free Documentation License:: + How you can copy and share this manual. +* Funding:: How to help assure continued work for free software. +* Getting Started:: What you should know about @command{gfortran}. +* GFORTRAN and GCC:: You can compile Fortran, C, or other programs. +* GFORTRAN and G77:: Why we choose to start from scratch. +* Invoking GFORTRAN:: Command options supported by @command{gfortran}. +* Compiling and Testing:: + Need-to-knows about compiling and testing. +* Project Status:: Status of GFORTRAN, Roadmap, proposed extensions. +* Contributing:: Helping you can help. +* Standards:: Standards supported by GFORTRAN. +* Index:: Index of this documentation. +@end menu + + + +@c --------------------------------------------------------------------- +@c GNU General Public License +@c --------------------------------------------------------------------- + +@include gpl.texi + + + +@c --------------------------------------------------------------------- +@c GNU Free Documentation License +@c --------------------------------------------------------------------- + +@include fdl.texi + + + +@c --------------------------------------------------------------------- +@c Funding Free Software +@c --------------------------------------------------------------------- + +@include funding.texi + + + +@c --------------------------------------------------------------------- +@c Getting Started +@c --------------------------------------------------------------------- + +@node Getting Started +@chapter Getting Started + +Gfortran is the GNU Fortran 95 compiler front end, +designed initially as a free replacement for, +or alternative to, the unix @command{f95} command; +@command{gfortran} is command you'll use to invoke the compiler. + +Gfortran is still in an early state of development. +@command{gfortran} can generate code for most constructs and expressions, +but much work remains to be done. + +When @command{gfortran} is finished, +it will do everything you expect from any decent compiler: + +@itemize @bullet +@item +Read a user's program, +stored in a file and containing instructions written +in Fortran 77, Fortran 90 or Fortran 95. +This file contains @dfn{source code}. + +@item +Translate the user's program into instructions a computer +can carry out more quickly than it takes to translate the +instructions in the first +place. The result after compilation of a program is +@dfn{machine code}, +code designed to be efficiently translated and processed +by a machine such as your computer. +Humans usually aren't as good writing machine code +as they are at writing Fortran (or C++, Ada, or Java), +because is easy to make tiny mistakes writing machine code. + +@item +Provide the user with information about the reasons why +the compiler is unable to create a binary from the source code. +Usually this will be the case if the source code is flawed. +When writing Fortran, it is easy to make big mistakes. +The Fortran 90 requires that the compiler can point out +mistakes to the user. +An incorrect usage of the language causes an @dfn{error message}. + +The compiler will also attempt to diagnose cases where the +user's program contains a correct usage of the language, +but instructs the computer to do something questionable. +This kind of diagnostics message is called a @dfn{warning message}. + +@item +Provide optional information about the translation passes +from the source code to machine code. +This can help a user of the compiler to find the cause of +certain bugs which may not be obvious in the source code, +but may be more easily found at a lower level compiler output. +It also helps developers to find bugs in the compiler itself. + +@item +Provide information in the generated machine code that can +make it easier to find bugs in the program (using a debugging tool, +called a @dfn{debugger}, such as the GNU Debugger @command{gdb}). + +@item +Locate and gather machine code already generated to +perform actions requested by statements in the user's program. +This machine code is organized into @dfn{modules} and is located +and @dfn{linked} to the user program. +@end itemize + +Gfortran consists of several components: + +@itemize @bullet +@item +A version of the @command{gcc} command +(which also might be installed as the system's @command{cc} command) +that also understands and accepts Fortran source code. +The @command{gcc} command is the @dfn{driver} program for +all the languages in the GNU Compiler Collection (GCC); +With @command{gcc}, +you can compiler the source code of any language for +which a front end is available in GCC. + +@item +The @command{gfortran} command itself, +which also might be installed as the +system's @command{f95} command. +@command{gfortran} is just another driver program, +but specifically for the Fortran 95 compiler only. +The difference with @command{gcc} is that @command{gfortran} +will automatically link the correct libraries to your program. + +@item +A collection of run-time libraries. +These libraries contains the machine code needed to support +capabilities of the Fortran language that are not directly +provided by the machine code generated by the +@command{gfortran} compilation phase, +such as intrinsic functions and subroutines, +and routines for interaction with files and the operating system. +@c and mechanisms to spawn, +@c unleash and pause threads in parallelized code. + +@item +The Fortran compiler itself, (@command{f951}). +This is the gfortran parser and code generator, +linked to and interfaced with the GCC backend library. +@command{f951} ``translates'' the source code to +assembler code. You would typically not use this +program directly; +instead, the @command{gcc} or @command{gfortran} driver +programs will call it for you. +@end itemize + + + +@c --------------------------------------------------------------------- +@c GFORTRAN and GCC +@c --------------------------------------------------------------------- + +@node GFORTRAN and GCC +@chapter GFORTRAN and GCC +@cindex GNU Compiler Collection + +GCC used to be the GNU ``C'' Compiler, +but is now known as the @dfn{GNU Compiler Collection}. +GCC provides the GNU system with a very versatile +compiler middle end (shared optimization passes), +and with back ends (code generators) for many different +computer architectures and operating systems. +The code of the middle end and back end are shared by all +compiler front ends that are in the GNU Compiler Collection. + +A GCC front end is essentially a source code parser +and a pass to generate a representation of the semantics +of the program in the source code in the GCC language +independent intermediate language, +called @dfn{GENERIC}. + +The parser takes a source file written in a +particular computer language, reads and parses it, +and tries to make sure that the source code conforms to +the language rules. +Once the correctness of a program has been established, +the compiler will build a data structure known as the +@dfn{Abstract Syntax tree}, +or just @dfn{AST} or ``tree'' for short. +This data structure represents the whole program +or a subroutine or a function. +The ``tree'' is passed to the GCC middle end, +which will perform optimization passes on it, +pass the optimized AST and generate assembly +for the program unit. + +Different phases in this translation process can be, +and in fact @emph{are} merged in many compiler front ends. +GNU Fortran 95 has a strict separation between the +parser and code generator. + +The goal of the gfortran project is to build a new front end for GCC: +A Fortran 95 front end. +In a non-gfortran installation, +@command{gcc} will not be able to compile Fortran 95 source code +(only the ``C'' front end has to be compiled if you want to build GCC, +all other languages are optional). +If you build GCC with gfortran, @command{gcc} will recognize +@file{.f/.f90/.f95} source files and accepts Fortran 95 specific +command line options. + + + +@c --------------------------------------------------------------------- +@c GFORTRAN and G77 +@c --------------------------------------------------------------------- + +@node GFORTRAN and G77 +@chapter GFORTRAN and G77 +@cindex Fortran 77 +@cindex G77 + +Why do we write a compiler front end from scratch? +There's a fine Fortran 77 compiler in the +GNU Compiler Collection that accepts some features +of the Fortran 90 standard as extensions. +Why not start from there and revamp it? + +One of the reasons is that Craig Burley, the author of G77, +has decided to stop working on the G77 front end. +On @uref{http://world.std.com/~burley/g77-why.html, +Craig explains the reasons for his decision to stop working on G77} +in one of the pages in his homepage. +Among the reasons is a lack of interest in improvements to +@command{g77}. +Users appear to be quite satisfied with @command{g77} as it is. +While @command{g77} is still being maintained (by Toon Moene), +it is unlikely that sufficient people will be willing +to completely rewrite the existing code. + +But there are other reasons to start from scratch. +Many people, including Craig Burley, +no longer agreed with certain design decisions in the G77 front end. +Also, the interface of @command{g77} to the back end is written in +a style which is confusing and not up to date on recommended practice. +In fact, a full rewrite had already been planned for GCC 3.0. + +When Craig decided to stop, +it just seemed to be a better idea to start a new project from scratch, +because it was expected to be easier to maintain code we +develop ourselves than to do a major overhaul of @command{g77} first, +and then build a Fortran 95 compiler out of it. + + +@include invoke.texi + +@c --------------------------------------------------------------------- +@c Compiling and Testing +@c --------------------------------------------------------------------- + +@node Compiling and Testing +@chapter Compiling and Testing + +@command{gfortran} is not yet part of an official GCC release, so it is +unlikley that OS distributor will provide it. + +@menu +* Precompiled Binaries:: +* General notes about compiling GFORTRAN:: +* Compiling GFORTRAN:: +* Testing:: +@end menu + +@node Precompiled Binaries +@section Precompiled Binaries + +Precompiled binaries for i686-pc-linux-gnu in rpm format are available from +@uref{http://people.redhat.com/dnovillo/pub/tree-ssa/snapshot/} + +@node General notes about compiling GFORTRAN +@section General notes about compiling GFORTRAN +@cindex GMP +@cindex Multiple Precision Library + +Compiling gfortran requires the presence of GMP, +the GNU Multiple Precision library version 4.0 +or better in order to do its arithmetic. +Download @code{gmp} from your favorite GNU mirror, +configure and compile it. If your OS distributor provides prepackaged +GMP libraries, you may also need the developent pacakges. + +If you do not have GMP installed in a standard system location, you may +need to configure GCC with @option{--with-gmp} or @option{--with-gmp-dir}. + +Note: GMP is only required for the compiler itself. Compiled fortran programs +do not depend on the GMP library. + +@node Compiling GFORTRAN +@section Compiling GFORTRAN +@cindex Make-lang.in + +To build gfortran, you first need to get a copy of the GCC source tree. +gfortran uses the new @dfn{GENERIC} intermediate representation +to communicate with the back end. +This new IR has not been merged yet with the GCC mainline, +so you'll need to get a snapshot of the +@emph{tree-ssa-20020619-branch} from the GCC CVS repository. +This branch also contains the latest version +You can check out this branch from the GNU Subversions server: + +@example +$ export CVS_RSH=ssh +$ cvs -z9 -d :ext:anoncvs@@subversions.gnu.org:/cvsroot/gcc co -r tree-ssa-20020619-branch gcc +@end example + +You can now build GCC following the instructions on the +@uref{htpp://gcc.gnu.org/,GCC homepage}, +(configure with @option{--enable-languages=f95}). + + +@node Testing +@section Testing +@cindex Test suite +@cindex Testing + +The number of possible Fortran 95 programs is unlimited, +and this means that gfortran has to correctly handle lots of possible inputs. +Whenever you make any changes to the compiler, +you should first test your change on a test program, +then test your change against the gfortran test suite. +In this way, we can be assured that once your fix has been made, +the problem isn't re-introduced at some later time. + +The gfortran test suite is included in the gcc source distribution. + +We also encourage you to test gfortran on your own Fortran codes. + +@c --------------------------------------------------------------------- +@c Project Status +@c --------------------------------------------------------------------- + +@node Project Status +@chapter Project Status + +@quotation +As soon as gfortran can parse all of the statements correctly, +it will be in the ``larva'' state. +When we generate code, the ``puppa'' state. +When gfortran is done, +we'll see if it will be a beautiful butterfly, +or just a big bug.... + +--Andy Vaught, April 2000 +@end quotation + +The start of the GNU Fortran 95 project was announced on +the GCC homepage in March 18, 2000 +(even though Andy had already been working on it for a while, +or course). + +Gfortran is currently reaching the stage where is is able to compile real +world programs. However it is still under development and has many rough +edges. + +@menu +* Compiler Status:: +* Library Status:: +* Proposed Extensions:: +@end menu + +@node Compiler Status +@section Compiler Status + +@itemize @emph +@item Front end +This is the part of gfortran which parses a source file, verifies that it +is valid Fortran 95, performs compile time replacement of constants +(PARAMETER variables) and reads and generate module files. This is +almost complete. Every Fortran 95 source should be accepted, and most +none-Fortran 95 source should be rejected. If you find a source file where +this is not true, please tell us. You can use the -fsyntax-only switch to +make gfortran quit after running the front end, effectively reducing it to +a syntax checker. + +@item Middle end interface +These are the parts of gfortran that take the parse tree generated by the +front end and translate it to the GENERIC form required by the GCC back +end. Work is ongoing in these parts of gfortran, but a large part has +already been completed. +@end itemize + +@node Library Status +@section Library Status + +Some intrinsic functions map directly to library functions, and in most +cases the name of the library function used depends on the type of the +arguments. For some intrinsics we generate inline code, and for others, +such as sin, cos and sqrt, we rely on the backend to use special +instructions in the floating point unit of the CPU if available, or to +fall back to a call to libm if these are not available. + +Implementation of some non-elemental intrinsic functions (eg. DOT_PRODUCT, +AVERAGE) is not yet optimal. This is hard because we have to make decisions +whether to use inline code (good for small arrays as no function call +overhead occurs) or generate function calls (good for large arrays as it +allows use of hand-optimized assembly routines, SIMD instructions, etc.) + +The IO library is still under development. The following features should be +usable for real programs: + +@itemize @minus +@item List directed +@item Unformatted sequential +@end itemize + +Usable with bugs: + +@itemize @minus +@item Formatted sequential ('T' edit descriptor, and others) +@item Namelist (can read a namelist that it writes, but not free-form) +@end itemize + +Not recommended: + +@itemize @minus +@item Unformatted direct access +@item Formatted direct access +@end itemize + +Many Fortran programs only use a small subset of the available IO +capabilities, so your milage may vary. + +@node Proposed Extensions +@section Proposed Extensions + +Here's a list of proposed extensions for @command{gfortran}, in no particular +order. Most of these are necessary to be fully compatible with +existing Fortran compilers, but they are not part of the official +J3 Fortran 95 standard. + +@subsection Compiler extensions: +@itemize @bullet +@item +Flag for defining the kind number for default logicals. + +@item +User-specified alignment rules for structures. +@item +Flag to generate a @code{Makefile} info. + +@item +Automatically extend single precision constants to double. + +@item +Cray pointers (this was high on the @command{g77} wishlist). + +@item +Compile code that conserves memory by dynamically allocating common and +module storage either on stack or heap. + +@item +Flag to cause the compiler to distinguish between upper and lower case +names. The Fortran 95 standard does not distinguish them. + +@item +Compile switch for changing the interpretation of a backslash from a +character to ``C''-style escape characters. + +@item +Compile flag to generate code for array conformance checking (suggest -CC). + +@item +User control of symbol names (underscores, etc). + +@item +Compile setting for maximum size of stack frame size before spilling +parts to static or heap. + +@item +Flag to force local variables into static space. + +@item +Flag to force local variables onto stack. + +@item +Flag to compile lines beginning with ``D''. + +@item +Flag to ignore lines beginning with ``D''. + +@item +Flag for maximum errors before ending compile. + +@item +Generate code to check for null pointer dereferences -- prints locus of +dereference instead of segfaulting. There was some discussion about this +option in the g95 development mailing list. + +@item +Allow setting default unit number. + +@item +Option to initialize of otherwise uninitialized integer and floating +point variables. + +@item +Support for OpenMP directives. This also requires support from the runtime +library and the rest of the compiler. + +@item +Support for Fortran 200x. This includes several new features including +floating point exceptions, extended use of allocatable arrays, C +interoperability, Parameterizer data types and function pointers. +@end itemize + + +@subsection Environment Options +@itemize @bullet +@item +Pluggable library modules for random numbers, linear algebra. +LA should use BLAS calling conventions. + +@item +Environment variables controlling actions on arithmetic exceptions like +overflow, underflow, precision loss -- Generate NaN, abort, default. +action. + +@item +Set precision for fp units that support it (i387). + +@item +Variables for setting fp rounding mode. + +@item +Support old style namelists ending in $end or &end. + +@item +Variable to fill uninitialized variables with a user-defined bit +pattern. + +@item +Environment variable controlling filename that is opened for that unit +number. + +@item +Environment variable to clear/trash memory being freed. + +@item +Environment variable to control tracing of allocations and frees. + +@item +Environment variable to display allocated memory at normal program end. + +@item +Environment variable for filename for * IO-unit. + +@item +Environment variable for temporary file directory. + +@item +Environment variable forcing standard output to be line buffered (unix). + +@item +Variable for swapping endianness during unformatted read. + +@item +Variable for swapping Endianness during unformatted write. +@end itemize + + + +@c --------------------------------------------------------------------- +@c Contributing +@c --------------------------------------------------------------------- + +@node Contributing +@chapter Contributing +@cindex Contributing + +Free software is only possible if people contribute to efforts +to create it. +We're always in need of more people helping out with ideas +and comments, writing documentation and contributing code. + +If you want to contribute to GNU Fortran 95, +have a look at the long lists of projects you can take on. +Some of these projects are small, +some of them are large; +some are completely orthogonal to the rest of what is +happening on @command{gfortran}, +but others are ``mainstream'' projects in need of enthusiastic hackers. +All of these projects are important! +We'll eventually get around to the things here, +but they are also things doable by someone who is willing and able. + +@menu +* Contributors:: +* Projects:: +@end menu + + +@node Contributors +@section Contributors to GNU Fortran 95 +@cindex Contributors +@cindex Credits +@cindex Authors + +Most of the parser was hand-crafted by @emph{Andy Vaught}, who is +also the initiator of the whole project. Thanks Andy! +Most of the interface with GCC was written by @emph{Paul Brook}. + +The following individuals have contributed code and/or +ideas and significant help to the gfortran project +(in no particular order): + +@itemize @minus +@item Andy Vaught +@item Katherine Holcomb +@item Tobias Schlüter +@item Steven Bosscher +@item Toon Moene +@item Tim Prince +@item Niels Kristian Bech Jensen +@item Steven Johnson +@item Paul Brook +@item Feng Wang +@item Bud Davis +@end itemize + +The following people have contributed bug reports, +smaller or larger patches, +and much needed feedback and encouragement for the +@command{gfortran} project: + +@itemize @minus +@item Erik Schnetter +@item Bill Clodius +@item Kate Hedstrom +@end itemize + +Many other individuals have helped debug, +test and improve @command{gfortran} over the past two years, +and we welcome you to do the same! +If you already have done so, +and you would like to see your name listed in the +list above, please contact us. + + +@node Projects +@section Projects + +@table @emph + +@item Help build the test suite +Solicit more code for donation to the test suite. +We can keep code private on request. + +@item Bug hunting/squishing +Find bugs and write more test cases! +Test cases are especially very welcome, +because it allows us to concentrate on fixing bugs +instead of isolating them. + +@item Smaller projects (``bug'' fixes): + @itemize @minus + @item Allow init exprs to be numbers raised to integer powers. + @item Implement correct rounding. + @item Implement F restrictions on Fortran 95 syntax. + @item See about making Emacs-parsable error messages. + @end itemize +@end table + +If you wish to work on the runtime libraries, +please contact a project maintainer. +@c TODO: email! + + +@c --------------------------------------------------------------------- +@c Standards +@c --------------------------------------------------------------------- + +@node Standards +@chapter Standards +@cindex Standards + +The GNU Fortran 95 Compiler aims to be a conforming implementation of +ISO/IEC 1539:1997 (Fortran 95). + +In the future it may also support other variants and extensions to the Fortran +language. This includes ANSI Fortran 77, Fortran 90, Fortran 2000 (not yet +finalized), and OpenMP. + +@node Index +@unnumbered Index + +@printindex cp + +@bye diff --git a/gcc/fortran/gfortranspec.c b/gcc/fortran/gfortranspec.c new file mode 100644 index 00000000000..bbf9fa372eb --- /dev/null +++ b/gcc/fortran/gfortranspec.c @@ -0,0 +1,548 @@ +/* Specific flags and argument handling of the Fortran front-end. + Copyright (C) 1997, 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc. + +This file is part of GNU CC. + +GNU CC is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU CC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU CC; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ +/* This file is copied more or less verbatim from g77. */ +/* This file contains a filter for the main `gcc' driver, which is + replicated for the `gfortran' driver by adding this filter. The purpose + of this filter is to be basically identical to gcc (in that + it faithfully passes all of the original arguments to gcc) but, + unless explicitly overridden by the user in certain ways, ensure + that the needs of the language supported by this wrapper are met. + + For GNU Fortran 95(gfortran), we do the following to the argument list + before passing it to `gcc': + + 1. Make sure `-lgfortran -lm' is at the end of the list. + + 2. Make sure each time `-lgfortran' or `-lm' is seen, it forms + part of the series `-lgfortran -lm'. + + #1 and #2 are not done if `-nostdlib' or any option that disables + the linking phase is present, or if `-xfoo' is in effect. Note that + a lack of source files or -l options disables linking. + + This program was originally made out of gcc/cp/g++spec.c, but the + way it builds the new argument list was rewritten so it is much + easier to maintain, improve the way it decides to add or not add + extra arguments, etc. And several improvements were made in the + handling of arguments, primarily to make it more consistent with + `gcc' itself. */ + +#include "config.h" +#include "system.h" +#include "gcc.h" + +#include "coretypes.h" +#include "tm.h" + +#ifndef MATH_LIBRARY +#define MATH_LIBRARY "-lm" +#endif + +#ifndef FORTRAN_INIT +#define FORTRAN_INIT "-lgfortranbegin" +#endif + +#ifndef FORTRAN_LIBRARY +#define FORTRAN_LIBRARY "-lgfortran" +#endif + +/* Options this driver needs to recognize, not just know how to + skip over. */ +typedef enum +{ + OPTION_b, /* Aka --prefix. */ + OPTION_B, /* Aka --target. */ + OPTION_c, /* Aka --compile. */ + OPTION_E, /* Aka --preprocess. */ + OPTION_help, /* --help. */ + OPTION_i, /* -imacros, -include, -include-*. */ + OPTION_l, + OPTION_L, /* Aka --library-directory. */ + OPTION_nostdlib, /* Aka --no-standard-libraries, or + -nodefaultlibs. */ + OPTION_o, /* Aka --output. */ + OPTION_S, /* Aka --assemble. */ + OPTION_syntax_only, /* -fsyntax-only. */ + OPTION_v, /* Aka --verbose. */ + OPTION_version, /* --version. */ + OPTION_V, /* Aka --use-version. */ + OPTION_x, /* Aka --language. */ + OPTION_ /* Unrecognized or unimportant. */ +} +Option; + +/* The original argument list and related info is copied here. */ +static int g77_xargc; +static const char *const *g77_xargv; +static void lookup_option (Option *, int *, const char **, const char *); +static void append_arg (const char *); + +/* The new argument list will be built here. */ +static int g77_newargc; +static const char **g77_newargv; + +const struct spec_function lang_specific_spec_functions[] = {{0,0}}; + +/* --- This comes from gcc.c (2.8.1) verbatim: */ + +/* This defines which switch letters take arguments. */ + +#ifndef SWITCH_TAKES_ARG +#define SWITCH_TAKES_ARG(CHAR) DEFAULT_SWITCH_TAKES_ARG(CHAR) +#endif + +/* This defines which multi-letter switches take arguments. */ + +#ifndef WORD_SWITCH_TAKES_ARG +#define WORD_SWITCH_TAKES_ARG(STR) DEFAULT_WORD_SWITCH_TAKES_ARG (STR) +#endif + +/* --- End of verbatim. */ + +/* Assumes text[0] == '-'. Returns number of argv items that belong to + (and follow) this one, an option id for options important to the + caller, and a pointer to the first char of the arg, if embedded (else + returns NULL, meaning no arg or it's the next argv). + + Note that this also assumes gcc.c's pass converting long options + to short ones, where available, has already been run. */ + +static void +lookup_option (Option *xopt, int *xskip, const char **xarg, const char *text) +{ + Option opt = OPTION_; + int skip; + const char *arg = NULL; + + if ((skip = SWITCH_TAKES_ARG (text[1]))) + skip -= (text[2] != '\0'); /* See gcc.c. */ + + if (text[1] == 'B') + opt = OPTION_B, skip = (text[2] == '\0'), arg = text + 2; + else if (text[1] == 'b') + opt = OPTION_b, skip = (text[2] == '\0'), arg = text + 2; + else if ((text[1] == 'c') && (text[2] == '\0')) + opt = OPTION_c, skip = 0; + else if ((text[1] == 'E') && (text[2] == '\0')) + opt = OPTION_E, skip = 0; + else if (text[1] == 'i') + opt = OPTION_i, skip = 0; + else if (text[1] == 'l') + opt = OPTION_l; + else if (text[1] == 'L') + opt = OPTION_L, arg = text + 2; + else if (text[1] == 'o') + opt = OPTION_o; + else if ((text[1] == 'S') && (text[2] == '\0')) + opt = OPTION_S, skip = 0; + else if (text[1] == 'V') + opt = OPTION_V, skip = (text[2] == '\0'); + else if ((text[1] == 'v') && (text[2] == '\0')) + opt = OPTION_v, skip = 0; + else if (text[1] == 'x') + opt = OPTION_x, arg = text + 2; + else + { + if ((skip = WORD_SWITCH_TAKES_ARG (text + 1)) != 0) /* See gcc.c. */ + ; + else if (!strcmp (text, "-fhelp")) /* Really --help!! */ + opt = OPTION_help; + else if (!strcmp (text, "-nostdlib") + || !strcmp (text, "-nodefaultlibs")) + opt = OPTION_nostdlib; + else if (!strcmp (text, "-fsyntax-only")) + opt = OPTION_syntax_only; + else if (!strcmp (text, "-dumpversion")) + opt = OPTION_version; + else if (!strcmp (text, "-fversion")) /* Really --version!! */ + opt = OPTION_version; + else if (!strcmp (text, "-Xlinker") || !strcmp (text, "-specs")) + skip = 1; + else + skip = 0; + } + + if (xopt != NULL) + *xopt = opt; + if (xskip != NULL) + *xskip = skip; + if (xarg != NULL) + { + if ((arg != NULL) && (arg[0] == '\0')) + *xarg = NULL; + else + *xarg = arg; + } +} + +/* Append another argument to the list being built. As long as it is + identical to the corresponding arg in the original list, just increment + the new arg count. Otherwise allocate a new list, etc. */ + +static void +append_arg (const char *arg) +{ + static int newargsize; + +#if 0 + fprintf (stderr, "`%s'\n", arg); +#endif + + if (g77_newargv == g77_xargv + && g77_newargc < g77_xargc + && (arg == g77_xargv[g77_newargc] + || !strcmp (arg, g77_xargv[g77_newargc]))) + { + ++g77_newargc; + return; /* Nothing new here. */ + } + + if (g77_newargv == g77_xargv) + { /* Make new arglist. */ + int i; + + newargsize = (g77_xargc << 2) + 20; /* This should handle all. */ + g77_newargv = (const char **) xmalloc (newargsize * sizeof (char *)); + + /* Copy what has been done so far. */ + for (i = 0; i < g77_newargc; ++i) + g77_newargv[i] = g77_xargv[i]; + } + + if (g77_newargc == newargsize) + fatal ("overflowed output arg list for `%s'", arg); + + g77_newargv[g77_newargc++] = arg; +} + +void +lang_specific_driver (int *in_argc, const char *const **in_argv, + int *in_added_libraries ATTRIBUTE_UNUSED) +{ + int argc = *in_argc; + const char *const *argv = *in_argv; + int i; + int verbose = 0; + Option opt; + int skip; + const char *arg; + + /* This will be NULL if we encounter a situation where we should not + link in libf2c. */ + const char *library = FORTRAN_LIBRARY; + + /* 0 => -xnone in effect. + 1 => -xfoo in effect. */ + int saw_speclang = 0; + + /* 0 => initial/reset state + 1 => last arg was -l<library> + 2 => last two args were -l<library> -lm. */ + int saw_library = 0; + + /* 0 => initial/reset state + 1 => FORTRAN_INIT linked in */ + int use_init = 0; + + /* By default, we throw on the math library if we have one. */ + int need_math = (MATH_LIBRARY[0] != '\0'); + + /* The number of input and output files in the incoming arg list. */ + int n_infiles = 0; + int n_outfiles = 0; + +#if 0 + fprintf (stderr, "Incoming:"); + for (i = 0; i < argc; i++) + fprintf (stderr, " %s", argv[i]); + fprintf (stderr, "\n"); +#endif + + g77_xargc = argc; + g77_xargv = argv; + g77_newargc = 0; + g77_newargv = (const char **) argv; + + /* First pass through arglist. + + If -nostdlib or a "turn-off-linking" option is anywhere in the + command line, don't do any library-option processing (except + relating to -x). Also, if -v is specified, but no other options + that do anything special (allowing -V version, etc.), remember + to add special stuff to make gcc command actually invoke all + the different phases of the compilation process so all the version + numbers can be seen. + + Also, here is where all problems with missing arguments to options + are caught. If this loop is exited normally, it means all options + have the appropriate number of arguments as far as the rest of this + program is concerned. */ + + for (i = 1; i < argc; ++i) + { + if ((argv[i][0] == '+') && (argv[i][1] == 'e')) + { + continue; + } + + if ((argv[i][0] != '-') || (argv[i][1] == '\0')) + { + ++n_infiles; + continue; + } + + lookup_option (&opt, &skip, NULL, argv[i]); + + switch (opt) + { + case OPTION_nostdlib: + case OPTION_c: + case OPTION_S: + case OPTION_syntax_only: + case OPTION_E: + /* These options disable linking entirely or linking of the + standard libraries. */ + library = 0; + break; + + case OPTION_l: + ++n_infiles; + break; + + case OPTION_o: + ++n_outfiles; + break; + + case OPTION_v: + verbose = 1; + break; + + case OPTION_b: + case OPTION_B: + case OPTION_L: + case OPTION_i: + case OPTION_V: + /* These options are useful in conjunction with -v to get + appropriate version info. */ + break; + + case OPTION_version: + printf ("\ +GNU Fortran 95 (GCC %s)\n\ +Copyright (C) 2003 Free Software Foundation, Inc.\n\ +\n\ +GNU Fortran comes with NO WARRANTY, to the extent permitted by law.\n\ +You may redistribute copies of GNU Fortran\n\ +under the terms of the GNU General Public License.\n\ +For more information about these matters, see the file named COPYING\n\ +", version_string); + exit (0); + break; + + case OPTION_help: + /* Let gcc.c handle this, as it has a really + cool facility for handling --help and --verbose --help. */ + return; + + default: + break; + } + + /* This is the one place we check for missing arguments in the + program. */ + + if (i + skip < argc) + i += skip; + else + fatal ("argument to `%s' missing", argv[i]); + } + + if ((n_outfiles != 0) && (n_infiles == 0)) + fatal ("no input files; unwilling to write output files"); + + /* If there are no input files, no need for the library. */ + if (n_infiles == 0) + library = 0; + + /* Second pass through arglist, transforming arguments as appropriate. */ + + append_arg (argv[0]); /* Start with command name, of course. */ + + for (i = 1; i < argc; ++i) + { + if (argv[i][0] == '\0') + { + append_arg (argv[i]); /* Interesting. Just append as is. */ + continue; + } + + if ((argv[i][0] == '-') && (argv[i][1] == 'M')) + { + char *p; + + if (argv[i][2] == '\0') + { + p = xmalloc (strlen (argv[i + 1]) + 2); + p[0] = '-'; + p[1] = 'J'; + strcpy (&p[2], argv[i + 1]); + i++; + } + else + { + p = xmalloc (strlen (argv[i]) + 1); + strcpy (p, argv[i]); + } + append_arg (p); + continue; + } + + if ((argv[i][0] == '-') && (argv[i][1] != 'l')) + { + /* Not a filename or library. */ + + if (saw_library == 1 && need_math) /* -l<library>. */ + append_arg (MATH_LIBRARY); + + saw_library = 0; + + lookup_option (&opt, &skip, &arg, argv[i]); + + if (argv[i][1] == '\0') + { + append_arg (argv[i]); /* "-" == Standard input. */ + continue; + } + + if (opt == OPTION_x) + { + /* Track input language. */ + const char *lang; + + if (arg == NULL) + lang = argv[i + 1]; + else + lang = arg; + + saw_speclang = (strcmp (lang, "none") != 0); + } + + append_arg (argv[i]); + + for (; skip != 0; --skip) + append_arg (argv[++i]); + + continue; + } + + /* A filename/library, not an option. */ + + if (saw_speclang) + saw_library = 0; /* -xfoo currently active. */ + else + { /* -lfoo or filename. */ + if (strcmp (argv[i], MATH_LIBRARY) == 0) + { + if (saw_library == 1) + saw_library = 2; /* -l<library> -lm. */ + else + { + if (0 == use_init) + { + append_arg (FORTRAN_INIT); + use_init = 1; + } + append_arg (FORTRAN_LIBRARY); + } + } + else if (strcmp (argv[i], FORTRAN_LIBRARY) == 0) + saw_library = 1; /* -l<library>. */ + else + { /* Other library, or filename. */ + if (saw_library == 1 && need_math) + append_arg (MATH_LIBRARY); + saw_library = 0; + } + } + append_arg (argv[i]); + } + + /* Append `-lg2c -lm' as necessary. */ + + if (library) + { /* Doing a link and no -nostdlib. */ + if (saw_speclang) + append_arg ("-xnone"); + + switch (saw_library) + { + case 0: + if (0 == use_init) + { + append_arg (FORTRAN_INIT); + use_init = 1; + } + append_arg (library); + case 1: + if (need_math) + append_arg (MATH_LIBRARY); + default: + break; + } + } + +#ifdef ENABLE_SHARED_LIBGCC + if (library) + { + int i; + + for (i = 1; i < g77_newargc; i++) + if (g77_newargv[i][0] == '-') + if (strcmp (g77_newargv[i], "-static-libgcc") == 0 + || strcmp (g77_newargv[i], "-static") == 0) + break; + + if (i == g77_newargc) + append_arg ("-shared-libgcc"); + } + +#endif + + if (verbose && g77_newargv != g77_xargv) + { + fprintf (stderr, "Driving:"); + for (i = 0; i < g77_newargc; i++) + fprintf (stderr, " %s", g77_newargv[i]); + fprintf (stderr, "\n"); + } + + *in_argc = g77_newargc; + *in_argv = g77_newargv; +} + +/* Called before linking. Returns 0 on success and -1 on failure. */ +int +lang_specific_pre_link (void) /* Not used for F77. */ +{ + return 0; +} + +/* Number of extra output files that lang_specific_pre_link may generate. */ +int lang_specific_extra_outfiles = 0; /* Not used for F77. */ diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c new file mode 100644 index 00000000000..aa31985c7ec --- /dev/null +++ b/gcc/fortran/interface.c @@ -0,0 +1,1858 @@ +/* Deal with interfaces. + Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +/* Deal with interfaces. An explicit interface is represented as a + singly linked list of formal argument structures attached to the + relevant symbols. For an implicit interface, the arguments don't + point to symbols. Explicit interfaces point to namespaces that + contain the symbols within that interface. + + Implicit interfaces are linked together in a singly linked list + along the next_if member of symbol nodes. Since a particular + symbol can only have a single explicit interface, the symbol cannot + be part of multiple lists and a single next-member suffices. + + This is not the case for general classes, though. An operator + definition is independent of just about all other uses and has it's + own head pointer. + + Nameless interfaces: + Nameless interfaces create symbols with explicit interfaces within + the current namespace. They are otherwise unlinked. + + Generic interfaces: + The generic name points to a linked list of symbols. Each symbol + has an explicit interface. Each explicit interface has it's own + namespace containing the arguments. Module procedures are symbols in + which the interface is added later when the module procedure is parsed. + + User operators: + User-defined operators are stored in a their own set of symtrees + separate from regular symbols. The symtrees point to gfc_user_op + structures which in turn head up a list of relevant interfaces. + + Extended intrinsics and assignment: + The head of these interface lists are stored in the containing namespace. + + Implicit interfaces: + An implicit interface is represented as a singly linked list of + formal argument list structures that don't point to any symbol + nodes -- they just contain types. + + + When a subprogram is defined, the program unit's name points to an + interface as usual, but the link to the namespace is NULL and the + formal argument list points to symbols within the same namespace as + the program unit name. */ + +#include "config.h" +#include <string.h> +#include <stdlib.h> + +#include "gfortran.h" +#include "match.h" + + +/* The current_interface structure holds information about the + interface currently being parsed. This structure is saved and + restored during recursive interfaces. */ + +gfc_interface_info current_interface; + + +/* Free a singly linked list of gfc_interface structures. */ + +void +gfc_free_interface (gfc_interface * intr) +{ + gfc_interface *next; + + for (; intr; intr = next) + { + next = intr->next; + gfc_free (intr); + } +} + + +/* Change the operators unary plus and minus into binary plus and + minus respectively, leaving the rest unchanged. */ + +static gfc_intrinsic_op +fold_unary (gfc_intrinsic_op operator) +{ + + switch (operator) + { + case INTRINSIC_UPLUS: + operator = INTRINSIC_PLUS; + break; + case INTRINSIC_UMINUS: + operator = INTRINSIC_MINUS; + break; + default: + break; + } + + return operator; +} + + +/* Match a generic specification. Depending on which type of + interface is found, the 'name' or 'operator' pointers may be set. + This subroutine doesn't return MATCH_NO. */ + +match +gfc_match_generic_spec (interface_type * type, + char *name, + gfc_intrinsic_op *operator) +{ + char buffer[GFC_MAX_SYMBOL_LEN + 1]; + match m; + gfc_intrinsic_op i; + + if (gfc_match (" assignment ( = )") == MATCH_YES) + { + *type = INTERFACE_INTRINSIC_OP; + *operator = INTRINSIC_ASSIGN; + return MATCH_YES; + } + + if (gfc_match (" operator ( %o )", &i) == MATCH_YES) + { /* Operator i/f */ + *type = INTERFACE_INTRINSIC_OP; + *operator = fold_unary (i); + return MATCH_YES; + } + + if (gfc_match (" operator ( ") == MATCH_YES) + { + m = gfc_match_defined_op_name (buffer, 1); + if (m == MATCH_NO) + goto syntax; + if (m != MATCH_YES) + return MATCH_ERROR; + + m = gfc_match_char (')'); + if (m == MATCH_NO) + goto syntax; + if (m != MATCH_YES) + return MATCH_ERROR; + + strcpy (name, buffer); + *type = INTERFACE_USER_OP; + return MATCH_YES; + } + + if (gfc_match_name (buffer) == MATCH_YES) + { + strcpy (name, buffer); + *type = INTERFACE_GENERIC; + return MATCH_YES; + } + + *type = INTERFACE_NAMELESS; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in generic specification at %C"); + return MATCH_ERROR; +} + + +/* Match one of the five forms of an interface statement. */ + +match +gfc_match_interface (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + interface_type type; + gfc_symbol *sym; + gfc_intrinsic_op operator; + match m; + + m = gfc_match_space (); + + if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR) + return MATCH_ERROR; + + + /* If we're not looking at the end of the statement now, or if this + is not a nameless interface but we did not see a space, punt. */ + if (gfc_match_eos () != MATCH_YES + || (type != INTERFACE_NAMELESS + && m != MATCH_YES)) + { + gfc_error + ("Syntax error: Trailing garbage in INTERFACE statement at %C"); + return MATCH_ERROR; + } + + current_interface.type = type; + + switch (type) + { + case INTERFACE_GENERIC: + if (gfc_get_symbol (name, NULL, &sym)) + return MATCH_ERROR; + + if (!sym->attr.generic && gfc_add_generic (&sym->attr, NULL) == FAILURE) + return MATCH_ERROR; + + current_interface.sym = gfc_new_block = sym; + break; + + case INTERFACE_USER_OP: + current_interface.uop = gfc_get_uop (name); + break; + + case INTERFACE_INTRINSIC_OP: + current_interface.op = operator; + break; + + case INTERFACE_NAMELESS: + break; + } + + return MATCH_YES; +} + + +/* Match the different sort of generic-specs that can be present after + the END INTERFACE itself. */ + +match +gfc_match_end_interface (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + interface_type type; + gfc_intrinsic_op operator; + match m; + + m = gfc_match_space (); + + if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR) + return MATCH_ERROR; + + /* If we're not looking at the end of the statement now, or if this + is not a nameless interface but we did not see a space, punt. */ + if (gfc_match_eos () != MATCH_YES + || (type != INTERFACE_NAMELESS + && m != MATCH_YES)) + { + gfc_error + ("Syntax error: Trailing garbage in END INTERFACE statement at %C"); + return MATCH_ERROR; + } + + m = MATCH_YES; + + switch (current_interface.type) + { + case INTERFACE_NAMELESS: + if (type != current_interface.type) + { + gfc_error ("Expected a nameless interface at %C"); + m = MATCH_ERROR; + } + + break; + + case INTERFACE_INTRINSIC_OP: + if (type != current_interface.type || operator != current_interface.op) + { + + if (current_interface.op == INTRINSIC_ASSIGN) + gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C"); + else + gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C", + gfc_op2string (current_interface.op)); + + m = MATCH_ERROR; + } + + break; + + case INTERFACE_USER_OP: + /* Comparing the symbol node names is OK because only use-associated + symbols can be renamed. */ + if (type != current_interface.type + || strcmp (current_interface.sym->name, name) != 0) + { + gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C", + current_interface.sym->name); + m = MATCH_ERROR; + } + + break; + + case INTERFACE_GENERIC: + if (type != current_interface.type + || strcmp (current_interface.sym->name, name) != 0) + { + gfc_error ("Expecting 'END INTERFACE %s' at %C", + current_interface.sym->name); + m = MATCH_ERROR; + } + + break; + } + + return m; +} + + +/* Compare two typespecs, recursively if necessary. */ + +int +gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2) +{ + gfc_component *dt1, *dt2; + + if (ts1->type != ts2->type) + return 0; + if (ts1->type != BT_DERIVED) + return (ts1->kind == ts2->kind); + + /* Compare derived types. */ + if (ts1->derived == ts2->derived) + return 1; + + /* Special case for comparing derived types across namespaces. If the + true names and module names are the same and the module name is + nonnull, then they are equal. */ + if (strcmp (ts1->derived->name, ts2->derived->name) == 0 + && ts1->derived->module[0] != '\0' + && strcmp (ts1->derived->module, ts2->derived->module) == 0) + return 1; + + /* Compare type via the rules of the standard. Both types must have + the SEQUENCE attribute to be equal. */ + + if (strcmp (ts1->derived->name, ts2->derived->name)) + return 0; + + dt1 = ts1->derived->components; + dt2 = ts2->derived->components; + + if (ts1->derived->attr.sequence == 0 || ts2->derived->attr.sequence == 0) + return 0; + + /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a + simple test can speed things up. Otherwise, lots of things have to + match. */ + for (;;) + { + if (strcmp (dt1->name, dt2->name) != 0) + return 0; + + if (dt1->pointer != dt2->pointer) + return 0; + + if (dt1->dimension != dt2->dimension) + return 0; + + if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0) + return 0; + + if (gfc_compare_types (&dt1->ts, &dt2->ts) == 0) + return 0; + + dt1 = dt1->next; + dt2 = dt2->next; + + if (dt1 == NULL && dt2 == NULL) + break; + if (dt1 == NULL || dt2 == NULL) + return 0; + } + + return 1; +} + + +/* Given two symbols that are formal arguments, compare their ranks + and types. Returns nonzero if they have the same rank and type, + zero otherwise. */ + +static int +compare_type_rank (gfc_symbol * s1, gfc_symbol * s2) +{ + int r1, r2; + + r1 = (s1->as != NULL) ? s1->as->rank : 0; + r2 = (s2->as != NULL) ? s2->as->rank : 0; + + if (r1 != r2) + return 0; /* Ranks differ */ + + return gfc_compare_types (&s1->ts, &s2->ts); +} + + +static int compare_interfaces (gfc_symbol *, gfc_symbol *, int); + +/* Given two symbols that are formal arguments, compare their types + and rank and their formal interfaces if they are both dummy + procedures. Returns nonzero if the same, zero if different. */ + +static int +compare_type_rank_if (gfc_symbol * s1, gfc_symbol * s2) +{ + + if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE) + return compare_type_rank (s1, s2); + + if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE) + return 0; + + /* At this point, both symbols are procedures. */ + if ((s1->attr.function == 0 && s1->attr.subroutine == 0) + || (s2->attr.function == 0 && s2->attr.subroutine == 0)) + return 0; + + if (s1->attr.function != s2->attr.function + || s1->attr.subroutine != s2->attr.subroutine) + return 0; + + if (s1->attr.function && compare_type_rank (s1, s2) == 0) + return 0; + + return compare_interfaces (s1, s2, 0); /* Recurse! */ +} + + +/* Given a formal argument list and a keyword name, search the list + for that keyword. Returns the correct symbol node if found, NULL + if not found. */ + +static gfc_symbol * +find_keyword_arg (const char *name, gfc_formal_arglist * f) +{ + + for (; f; f = f->next) + if (strcmp (f->sym->name, name) == 0) + return f->sym; + + return NULL; +} + + +/******** Interface checking subroutines **********/ + + +/* Given an operator interface and the operator, make sure that all + interfaces for that operator are legal. */ + +static void +check_operator_interface (gfc_interface * intr, gfc_intrinsic_op operator) +{ + gfc_formal_arglist *formal; + sym_intent i1, i2; + gfc_symbol *sym; + bt t1, t2; + int args; + + if (intr == NULL) + return; + + args = 0; + t1 = t2 = BT_UNKNOWN; + i1 = i2 = INTENT_UNKNOWN; + + for (formal = intr->sym->formal; formal; formal = formal->next) + { + sym = formal->sym; + + if (args == 0) + { + t1 = sym->ts.type; + i1 = sym->attr.intent; + } + if (args == 1) + { + t2 = sym->ts.type; + i2 = sym->attr.intent; + } + args++; + } + + if (args == 0 || args > 2) + goto num_args; + + sym = intr->sym; + + if (operator == INTRINSIC_ASSIGN) + { + if (!sym->attr.subroutine) + { + gfc_error + ("Assignment operator interface at %L must be a SUBROUTINE", + &intr->where); + return; + } + } + else + { + if (!sym->attr.function) + { + gfc_error ("Intrinsic operator interface at %L must be a FUNCTION", + &intr->where); + return; + } + } + + switch (operator) + { + case INTRINSIC_PLUS: /* Numeric unary or binary */ + case INTRINSIC_MINUS: + if ((args == 1) + && (t1 == BT_INTEGER + || t1 == BT_REAL + || t1 == BT_COMPLEX)) + goto bad_repl; + + if ((args == 2) + && (t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX) + && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX)) + goto bad_repl; + + break; + + case INTRINSIC_POWER: /* Binary numeric */ + case INTRINSIC_TIMES: + case INTRINSIC_DIVIDE: + + case INTRINSIC_EQ: + case INTRINSIC_NE: + if (args == 1) + goto num_args; + + if ((t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX) + && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX)) + goto bad_repl; + + break; + + case INTRINSIC_GE: /* Binary numeric operators that do not support */ + case INTRINSIC_LE: /* complex numbers */ + case INTRINSIC_LT: + case INTRINSIC_GT: + if (args == 1) + goto num_args; + + if ((t1 == BT_INTEGER || t1 == BT_REAL) + && (t2 == BT_INTEGER || t2 == BT_REAL)) + goto bad_repl; + + break; + + case INTRINSIC_OR: /* Binary logical */ + case INTRINSIC_AND: + case INTRINSIC_EQV: + case INTRINSIC_NEQV: + if (args == 1) + goto num_args; + if (t1 == BT_LOGICAL && t2 == BT_LOGICAL) + goto bad_repl; + break; + + case INTRINSIC_NOT: /* Unary logical */ + if (args != 1) + goto num_args; + if (t1 == BT_LOGICAL) + goto bad_repl; + break; + + case INTRINSIC_CONCAT: /* Binary string */ + if (args != 2) + goto num_args; + if (t1 == BT_CHARACTER && t2 == BT_CHARACTER) + goto bad_repl; + break; + + case INTRINSIC_ASSIGN: /* Class by itself */ + if (args != 2) + goto num_args; + break; + default: + gfc_internal_error ("check_operator_interface(): Bad operator"); + } + + /* Check intents on operator interfaces. */ + if (operator == INTRINSIC_ASSIGN) + { + if (i1 != INTENT_OUT && i1 != INTENT_INOUT) + gfc_error ("First argument of defined assignment at %L must be " + "INTENT(IN) or INTENT(INOUT)", &intr->where); + + if (i2 != INTENT_IN) + gfc_error ("Second argument of defined assignment at %L must be " + "INTENT(IN)", &intr->where); + } + else + { + if (i1 != INTENT_IN) + gfc_error ("First argument of operator interface at %L must be " + "INTENT(IN)", &intr->where); + + if (args == 2 && i2 != INTENT_IN) + gfc_error ("Second argument of operator interface at %L must be " + "INTENT(IN)", &intr->where); + } + + return; + +bad_repl: + gfc_error ("Operator interface at %L conflicts with intrinsic interface", + &intr->where); + return; + +num_args: + gfc_error ("Operator interface at %L has the wrong number of arguments", + &intr->where); + return; +} + + +/* Given a pair of formal argument lists, we see if the two lists can + be distinguished by counting the number of nonoptional arguments of + a given type/rank in f1 and seeing if there are less then that + number of those arguments in f2 (including optional arguments). + Since this test is asymmetric, it has to be called twice to make it + symmetric. Returns nonzero if the argument lists are incompatible + by this test. This subroutine implements rule 1 of section + 14.1.2.3. */ + +static int +count_types_test (gfc_formal_arglist * f1, gfc_formal_arglist * f2) +{ + int rc, ac1, ac2, i, j, k, n1; + gfc_formal_arglist *f; + + typedef struct + { + int flag; + gfc_symbol *sym; + } + arginfo; + + arginfo *arg; + + n1 = 0; + + for (f = f1; f; f = f->next) + n1++; + + /* Build an array of integers that gives the same integer to + arguments of the same type/rank. */ + arg = gfc_getmem (n1 * sizeof (arginfo)); + + f = f1; + for (i = 0; i < n1; i++, f = f->next) + { + arg[i].flag = -1; + arg[i].sym = f->sym; + } + + k = 0; + + for (i = 0; i < n1; i++) + { + if (arg[i].flag != -1) + continue; + + if (arg[i].sym->attr.optional) + continue; /* Skip optional arguments */ + + arg[i].flag = k; + + /* Find other nonoptional arguments of the same type/rank. */ + for (j = i + 1; j < n1; j++) + if (!arg[j].sym->attr.optional + && compare_type_rank_if (arg[i].sym, arg[j].sym)) + arg[j].flag = k; + + k++; + } + + /* Now loop over each distinct type found in f1. */ + k = 0; + rc = 0; + + for (i = 0; i < n1; i++) + { + if (arg[i].flag != k) + continue; + + ac1 = 1; + for (j = i + 1; j < n1; j++) + if (arg[j].flag == k) + ac1++; + + /* Count the number of arguments in f2 with that type, including + those that are optional. */ + ac2 = 0; + + for (f = f2; f; f = f->next) + if (compare_type_rank_if (arg[i].sym, f->sym)) + ac2++; + + if (ac1 > ac2) + { + rc = 1; + break; + } + + k++; + } + + gfc_free (arg); + + return rc; +} + + +/* Perform the abbreviated correspondence test for operators. The + arguments cannot be optional and are always ordered correctly, + which makes this test much easier than that for generic tests. + + This subroutine is also used when comparing a formal and actual + argument list when an actual parameter is a dummy procedure. At + that point, two formal interfaces must be compared for equality + which is what happens here. */ + +static int +operator_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2) +{ + for (;;) + { + if (f1 == NULL && f2 == NULL) + break; + if (f1 == NULL || f2 == NULL) + return 1; + + if (!compare_type_rank (f1->sym, f2->sym)) + return 1; + + f1 = f1->next; + f2 = f2->next; + } + + return 0; +} + + +/* Perform the correspondence test in rule 2 of section 14.1.2.3. + Returns zero if no argument is found that satisifes rule 2, nonzero + otherwise. + + This test is also not symmetric in f1 and f2 and must be called + twice. This test finds problems caused by sorting the actual + argument list with keywords. For example: + + INTERFACE FOO + SUBROUTINE F1(A, B) + INTEGER :: A ; REAL :: B + END SUBROUTINE F1 + + SUBROUTINE F2(B, A) + INTEGER :: A ; REAL :: B + END SUBROUTINE F1 + END INTERFACE FOO + + At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */ + +static int +generic_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2) +{ + + gfc_formal_arglist *f2_save, *g; + gfc_symbol *sym; + + f2_save = f2; + + while (f1) + { + if (f1->sym->attr.optional) + goto next; + + if (f2 != NULL && compare_type_rank (f1->sym, f2->sym)) + goto next; + + /* Now search for a disambiguating keyword argument starting at + the current non-match. */ + for (g = f1; g; g = g->next) + { + if (g->sym->attr.optional) + continue; + + sym = find_keyword_arg (g->sym->name, f2_save); + if (sym == NULL || !compare_type_rank (g->sym, sym)) + return 1; + } + + next: + f1 = f1->next; + if (f2 != NULL) + f2 = f2->next; + } + + return 0; +} + + +/* 'Compare' two formal interfaces associated with a pair of symbols. + We return nonzero if there exists an actual argument list that + would be ambiguous between the two interfaces, zero otherwise. */ + +static int +compare_interfaces (gfc_symbol * s1, gfc_symbol * s2, int generic_flag) +{ + gfc_formal_arglist *f1, *f2; + + if (s1->attr.function != s2->attr.function + && s1->attr.subroutine != s2->attr.subroutine) + return 0; /* disagreement between function/subroutine */ + + f1 = s1->formal; + f2 = s2->formal; + + if (f1 == NULL && f2 == NULL) + return 1; /* Special case */ + + if (count_types_test (f1, f2)) + return 0; + if (count_types_test (f2, f1)) + return 0; + + if (generic_flag) + { + if (generic_correspondence (f1, f2)) + return 0; + if (generic_correspondence (f2, f1)) + return 0; + } + else + { + if (operator_correspondence (f1, f2)) + return 0; + } + + return 1; +} + + +/* Given a pointer to an interface pointer, remove duplicate + interfaces and make sure that all symbols are either functions or + subroutines. Returns nonzero if something goes wrong. */ + +static int +check_interface0 (gfc_interface * p, const char *interface_name) +{ + gfc_interface *psave, *q, *qlast; + + psave = p; + /* Make sure all symbols in the interface have been defined as + functions or subroutines. */ + for (; p; p = p->next) + if (!p->sym->attr.function && !p->sym->attr.subroutine) + { + gfc_error ("Procedure '%s' in %s at %L is neither function nor " + "subroutine", p->sym->name, interface_name, + &p->sym->declared_at); + return 1; + } + p = psave; + + /* Remove duplicate interfaces in this interface list. */ + for (; p; p = p->next) + { + qlast = p; + + for (q = p->next; q;) + { + if (p->sym != q->sym) + { + qlast = q; + q = q->next; + + } + else + { + /* Duplicate interface */ + qlast->next = q->next; + gfc_free (q); + q = qlast->next; + } + } + } + + return 0; +} + + +/* Check lists of interfaces to make sure that no two interfaces are + ambiguous. Duplicate interfaces (from the same symbol) are OK + here. */ + +static int +check_interface1 (gfc_interface * p, gfc_interface * q, + int generic_flag, const char *interface_name) +{ + + for (; p; p = p->next) + for (; q; q = q->next) + { + if (p->sym == q->sym) + continue; /* Duplicates OK here */ + + if (strcmp (p->sym->name, q->sym->name) == 0 + && strcmp (p->sym->module, q->sym->module) == 0) + continue; + + if (compare_interfaces (p->sym, q->sym, generic_flag)) + { + gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L", + p->sym->name, q->sym->name, interface_name, &p->where); + return 1; + } + } + + return 0; +} + + +/* Check the generic and operator interfaces of symbols to make sure + that none of the interfaces conflict. The check has to be done + after all of the symbols are actually loaded. */ + +static void +check_sym_interfaces (gfc_symbol * sym) +{ + char interface_name[100]; + gfc_symbol *s2; + + if (sym->ns != gfc_current_ns) + return; + + if (sym->generic != NULL) + { + sprintf (interface_name, "generic interface '%s'", sym->name); + if (check_interface0 (sym->generic, interface_name)) + return; + + s2 = sym; + while (s2 != NULL) + { + if (check_interface1 (sym->generic, s2->generic, 1, interface_name)) + return; + + if (s2->ns->parent == NULL) + break; + if (gfc_find_symbol (sym->name, s2->ns->parent, 1, &s2)) + break; + } + } +} + + +static void +check_uop_interfaces (gfc_user_op * uop) +{ + char interface_name[100]; + gfc_user_op *uop2; + gfc_namespace *ns; + + sprintf (interface_name, "operator interface '%s'", uop->name); + if (check_interface0 (uop->operator, interface_name)) + return; + + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + uop2 = gfc_find_uop (uop->name, ns); + if (uop2 == NULL) + continue; + + check_interface1 (uop->operator, uop2->operator, 0, interface_name); + } +} + + +/* For the namespace, check generic, user operator and intrinsic + operator interfaces for consistency and to remove duplicate + interfaces. We traverse the whole namespace, counting on the fact + that most symbols will not have generic or operator interfaces. */ + +void +gfc_check_interfaces (gfc_namespace * ns) +{ + gfc_namespace *old_ns, *ns2; + char interface_name[100]; + gfc_intrinsic_op i; + + old_ns = gfc_current_ns; + gfc_current_ns = ns; + + gfc_traverse_ns (ns, check_sym_interfaces); + + gfc_traverse_user_op (ns, check_uop_interfaces); + + for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) + { + if (i == INTRINSIC_USER) + continue; + + if (i == INTRINSIC_ASSIGN) + strcpy (interface_name, "intrinsic assignment operator"); + else + sprintf (interface_name, "intrinsic '%s' operator", + gfc_op2string (i)); + + if (check_interface0 (ns->operator[i], interface_name)) + continue; + + check_operator_interface (ns->operator[i], i); + + for (ns2 = ns->parent; ns2; ns2 = ns2->parent) + if (check_interface1 (ns->operator[i], ns2->operator[i], 0, + interface_name)) + break; + } + + gfc_current_ns = old_ns; +} + + +static int +symbol_rank (gfc_symbol * sym) +{ + + return (sym->as == NULL) ? 0 : sym->as->rank; +} + + +/* Given a symbol of a formal argument list and an expression, if the + formal argument is a pointer, see if the actual argument is a + pointer. Returns nonzero if compatible, zero if not compatible. */ + +static int +compare_pointer (gfc_symbol * formal, gfc_expr * actual) +{ + symbol_attribute attr; + + if (formal->attr.pointer) + { + attr = gfc_expr_attr (actual); + if (!attr.pointer) + return 0; + } + + return 1; +} + + +/* Given a symbol of a formal argument list and an expression, see if + the two are compatible as arguments. Returns nonzero if + compatible, zero if not compatible. */ + +static int +compare_parameter (gfc_symbol * formal, gfc_expr * actual, + int ranks_must_agree, int is_elemental) +{ + gfc_ref *ref; + + if (actual->ts.type == BT_PROCEDURE) + { + if (formal->attr.flavor != FL_PROCEDURE) + return 0; + + if (formal->attr.function + && !compare_type_rank (formal, actual->symtree->n.sym)) + return 0; + + if (formal->attr.if_source == IFSRC_UNKNOWN) + return 1; /* Assume match */ + + return compare_interfaces (formal, actual->symtree->n.sym, 0); + } + + if (!gfc_compare_types (&formal->ts, &actual->ts)) + return 0; + + if (symbol_rank (formal) == actual->rank) + return 1; + + /* At this point the ranks didn't agree. */ + if (ranks_must_agree || formal->attr.pointer) + return 0; + + if (actual->rank != 0) + return is_elemental || formal->attr.dimension; + + /* At this point, we are considering a scalar passed to an array. + This is legal if the scalar is an array element of the right sort. */ + if (formal->as->type == AS_ASSUMED_SHAPE) + return 0; + + for (ref = actual->ref; ref; ref = ref->next) + if (ref->type == REF_SUBSTRING) + return 0; + + for (ref = actual->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT) + break; + + if (ref == NULL) + return 0; /* Not an array element */ + + return 1; +} + + +/* Given formal and actual argument lists, see if they are compatible. + If they are compatible, the actual argument list is sorted to + correspond with the formal list, and elements for missing optional + arguments are inserted. If WHERE pointer is nonnull, then we issue + errors when things don't match instead of just returning the status + code. */ + +static int +compare_actual_formal (gfc_actual_arglist ** ap, + gfc_formal_arglist * formal, + int ranks_must_agree, int is_elemental, locus * where) +{ + gfc_actual_arglist **new, *a, *actual, temp; + gfc_formal_arglist *f; + int i, n, na; + + actual = *ap; + + if (actual == NULL && formal == NULL) + return 1; + + n = 0; + for (f = formal; f; f = f->next) + n++; + + new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *)); + + for (i = 0; i < n; i++) + new[i] = NULL; + + na = 0; + f = formal; + i = 0; + + for (a = actual; a; a = a->next, f = f->next) + { + if (a->name[0] != '\0') + { + i = 0; + for (f = formal; f; f = f->next, i++) + { + if (f->sym == NULL) + continue; + if (strcmp (f->sym->name, a->name) == 0) + break; + } + + if (f == NULL) + { + if (where) + gfc_error + ("Keyword argument '%s' at %L is not in the procedure", + a->name, &a->expr->where); + return 0; + } + + if (new[i] != NULL) + { + if (where) + gfc_error + ("Keyword argument '%s' at %L is already associated " + "with another actual argument", a->name, &a->expr->where); + return 0; + } + } + + if (f == NULL) + { + if (where) + gfc_error + ("More actual than formal arguments in procedure call at %L", + where); + + return 0; + } + + if (f->sym == NULL && a->expr == NULL) + goto match; + + if (f->sym == NULL) + { + if (where) + gfc_error + ("Missing alternate return spec in subroutine call at %L", + where); + return 0; + } + + if (a->expr == NULL) + { + if (where) + gfc_error + ("Unexpected alternate return spec in subroutine call at %L", + where); + return 0; + } + + if (!compare_parameter + (f->sym, a->expr, ranks_must_agree, is_elemental)) + { + if (where) + gfc_error ("Type/rank mismatch in argument '%s' at %L", + f->sym->name, &a->expr->where); + return 0; + } + + if (compare_pointer (f->sym, a->expr) == 0) + { + if (where) + gfc_error ("Actual argument for '%s' must be a pointer at %L", + f->sym->name, &a->expr->where); + return 0; + } + + match: + if (a == actual) + na = i; + + new[i++] = a; + } + + /* Make sure missing actual arguments are optional. */ + i = 0; + for (f = formal; f; f = f->next, i++) + { + if (new[i] != NULL) + continue; + if (!f->sym->attr.optional) + { + if (where) + gfc_error ("Missing actual argument for argument '%s' at %L", + f->sym->name, where); + return 0; + } + } + + /* The argument lists are compatible. We now relink a new actual + argument list with null arguments in the right places. The head + of the list remains the head. */ + for (i = 0; i < n; i++) + if (new[i] == NULL) + new[i] = gfc_get_actual_arglist (); + + if (na != 0) + { + temp = *new[0]; + *new[0] = *actual; + *actual = temp; + + a = new[0]; + new[0] = new[na]; + new[na] = a; + } + + for (i = 0; i < n - 1; i++) + new[i]->next = new[i + 1]; + + new[i]->next = NULL; + + if (*ap == NULL && n > 0) + *ap = new[0]; + + return 1; +} + + +typedef struct +{ + gfc_formal_arglist *f; + gfc_actual_arglist *a; +} +argpair; + +/* qsort comparison function for argument pairs, with the following + order: + - p->a->expr == NULL + - p->a->expr->expr_type != EXPR_VARIABLE + - growing p->a->expr->symbol. */ + +static int +pair_cmp (const void *p1, const void *p2) +{ + const gfc_actual_arglist *a1, *a2; + + /* *p1 and *p2 are elements of the to-be-sorted array. */ + a1 = ((const argpair *) p1)->a; + a2 = ((const argpair *) p2)->a; + if (!a1->expr) + { + if (!a2->expr) + return 0; + return -1; + } + if (!a2->expr) + return 1; + if (a1->expr->expr_type != EXPR_VARIABLE) + { + if (a2->expr->expr_type != EXPR_VARIABLE) + return 0; + return -1; + } + if (a2->expr->expr_type != EXPR_VARIABLE) + return 1; + return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym; +} + + +/* Given two expressions from some actual arguments, test whether they + refer to the same expression. The analysis is conservative. + Returning FAILURE will produce no warning. */ + +static try +compare_actual_expr (gfc_expr * e1, gfc_expr * e2) +{ + const gfc_ref *r1, *r2; + + if (!e1 || !e2 + || e1->expr_type != EXPR_VARIABLE + || e2->expr_type != EXPR_VARIABLE + || e1->symtree->n.sym != e2->symtree->n.sym) + return FAILURE; + + /* TODO: improve comparison, see expr.c:show_ref(). */ + for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next) + { + if (r1->type != r2->type) + return FAILURE; + switch (r1->type) + { + case REF_ARRAY: + if (r1->u.ar.type != r2->u.ar.type) + return FAILURE; + /* TODO: At the moment, consider only full arrays; + we could do better. */ + if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL) + return FAILURE; + break; + + case REF_COMPONENT: + if (r1->u.c.component != r2->u.c.component) + return FAILURE; + break; + + case REF_SUBSTRING: + return FAILURE; + + default: + gfc_internal_error ("compare_actual_expr(): Bad component code"); + } + } + if (!r1 && !r2) + return SUCCESS; + return FAILURE; +} + +/* Given formal and actual argument lists that correspond to one + another, check that identical actual arguments aren't not + associated with some incompatible INTENTs. */ + +static try +check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a) +{ + sym_intent f1_intent, f2_intent; + gfc_formal_arglist *f1; + gfc_actual_arglist *a1; + size_t n, i, j; + argpair *p; + try t = SUCCESS; + + n = 0; + for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next) + { + if (f1 == NULL && a1 == NULL) + break; + if (f1 == NULL || a1 == NULL) + gfc_internal_error ("check_some_aliasing(): List mismatch"); + n++; + } + if (n == 0) + return t; + p = (argpair *) alloca (n * sizeof (argpair)); + + for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next) + { + p[i].f = f1; + p[i].a = a1; + } + + qsort (p, n, sizeof (argpair), pair_cmp); + + for (i = 0; i < n; i++) + { + if (!p[i].a->expr + || p[i].a->expr->expr_type != EXPR_VARIABLE + || p[i].a->expr->ts.type == BT_PROCEDURE) + continue; + f1_intent = p[i].f->sym->attr.intent; + for (j = i + 1; j < n; j++) + { + /* Expected order after the sort. */ + if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE) + gfc_internal_error ("check_some_aliasing(): corrupted data"); + + /* Are the expression the same? */ + if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE) + break; + f2_intent = p[j].f->sym->attr.intent; + if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT) + || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN)) + { + gfc_warning ("Same actual argument associated with INTENT(%s) " + "argument '%s' and INTENT(%s) argument '%s' at %L", + gfc_intent_string (f1_intent), p[i].f->sym->name, + gfc_intent_string (f2_intent), p[j].f->sym->name, + &p[i].a->expr->where); + t = FAILURE; + } + } + } + + return t; +} + + +/* Given formal and actual argument lists that correspond to one + another, check that they are compatible in the sense that intents + are not mismatched. */ + +static try +check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a) +{ + sym_intent a_intent, f_intent; + + for (;; f = f->next, a = a->next) + { + if (f == NULL && a == NULL) + break; + if (f == NULL || a == NULL) + gfc_internal_error ("check_intents(): List mismatch"); + + if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE) + continue; + + a_intent = a->expr->symtree->n.sym->attr.intent; + f_intent = f->sym->attr.intent; + + if (a_intent == INTENT_IN + && (f_intent == INTENT_INOUT + || f_intent == INTENT_OUT)) + { + + gfc_error ("Procedure argument at %L is INTENT(IN) while interface " + "specifies INTENT(%s)", &a->expr->where, + gfc_intent_string (f_intent)); + return FAILURE; + } + + if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym)) + { + if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT) + { + gfc_error + ("Procedure argument at %L is local to a PURE procedure and " + "is passed to an INTENT(%s) argument", &a->expr->where, + gfc_intent_string (f_intent)); + return FAILURE; + } + + if (a->expr->symtree->n.sym->attr.pointer) + { + gfc_error + ("Procedure argument at %L is local to a PURE procedure and " + "has the POINTER attribute", &a->expr->where); + return FAILURE; + } + } + } + + return SUCCESS; +} + + +/* Check how a procedure is used against its interface. If all goes + well, the actual argument list will also end up being properly + sorted. */ + +void +gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where) +{ + /* Warn about calls with an implicit interface. */ + if (gfc_option.warn_implicit_interface + && sym->attr.if_source == IFSRC_UNKNOWN) + gfc_warning ("Procedure '%s' called with an implicit interface at %L", + sym->name, where); + + if (sym->attr.if_source == IFSRC_UNKNOWN + || !compare_actual_formal (ap, sym->formal, 0, + sym->attr.elemental, where)) + return; + + check_intents (sym->formal, *ap); + if (gfc_option.warn_aliasing) + check_some_aliasing (sym->formal, *ap); +} + + +/* Given an interface pointer and an actual argument list, search for + a formal argument list that matches the actual. If found, returns + a pointer to the symbol of the correct interface. Returns NULL if + not found. */ + +gfc_symbol * +gfc_search_interface (gfc_interface * intr, int sub_flag, + gfc_actual_arglist ** ap) +{ + int r; + + for (; intr; intr = intr->next) + { + if (sub_flag && intr->sym->attr.function) + continue; + if (!sub_flag && intr->sym->attr.subroutine) + continue; + + r = !intr->sym->attr.elemental; + + if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL)) + { + check_intents (intr->sym->formal, *ap); + if (gfc_option.warn_aliasing) + check_some_aliasing (intr->sym->formal, *ap); + return intr->sym; + } + } + + return NULL; +} + + +/* Do a brute force recursive search for a symbol. */ + +static gfc_symtree * +find_symtree0 (gfc_symtree * root, gfc_symbol * sym) +{ + gfc_symtree * st; + + if (root->n.sym == sym) + return root; + + st = NULL; + if (root->left) + st = find_symtree0 (root->left, sym); + if (root->right && ! st) + st = find_symtree0 (root->right, sym); + return st; +} + + +/* Find a symtree for a symbol. */ + +static gfc_symtree * +find_sym_in_symtree (gfc_symbol * sym) +{ + gfc_symtree *st; + gfc_namespace *ns; + + /* First try to find it by name. */ + gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st); + if (st && st->n.sym == sym) + return st; + + /* if it's been renamed, resort to a brute-force search. */ + /* TODO: avoid having to do this search. If the symbol doesn't exist + in the symtree for the current namespace, it should probably be added. */ + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + st = find_symtree0 (ns->sym_root, sym); + if (st) + return st; + } + gfc_internal_error ("Unable to find symbol %s", sym->name); + /* Not reached */ +} + + +/* This subroutine is called when an expression is being resolved. + The expression node in question is either a user defined operator + or an instrinsic operator with arguments that aren't compatible + with the operator. This subroutine builds an actual argument list + corresponding to the operands, then searches for a compatible + interface. If one is found, the expression node is replaced with + the appropriate function call. */ + +try +gfc_extend_expr (gfc_expr * e) +{ + gfc_actual_arglist *actual; + gfc_symbol *sym; + gfc_namespace *ns; + gfc_user_op *uop; + gfc_intrinsic_op i; + + sym = NULL; + + actual = gfc_get_actual_arglist (); + actual->expr = e->op1; + + if (e->op2 != NULL) + { + actual->next = gfc_get_actual_arglist (); + actual->next->expr = e->op2; + } + + i = fold_unary (e->operator); + + if (i == INTRINSIC_USER) + { + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + uop = gfc_find_uop (e->uop->name, ns); + if (uop == NULL) + continue; + + sym = gfc_search_interface (uop->operator, 0, &actual); + if (sym != NULL) + break; + } + } + else + { + for (ns = gfc_current_ns; ns; ns = ns->parent) + { + sym = gfc_search_interface (ns->operator[i], 0, &actual); + if (sym != NULL) + break; + } + } + + if (sym == NULL) + { + /* Don't use gfc_free_actual_arglist() */ + if (actual->next != NULL) + gfc_free (actual->next); + gfc_free (actual); + + return FAILURE; + } + + /* Change the expression node to a function call. */ + e->expr_type = EXPR_FUNCTION; + e->symtree = find_sym_in_symtree (sym); + e->value.function.actual = actual; + + if (gfc_pure (NULL) && !gfc_pure (sym)) + { + gfc_error + ("Function '%s' called in lieu of an operator at %L must be PURE", + sym->name, &e->where); + return FAILURE; + } + + if (gfc_resolve_expr (e) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/* Tries to replace an assignment code node with a subroutine call to + the subroutine associated with the assignment operator. Return + SUCCESS if the node was replaced. On FAILURE, no error is + generated. */ + +try +gfc_extend_assign (gfc_code * c, gfc_namespace * ns) +{ + gfc_actual_arglist *actual; + gfc_expr *lhs, *rhs; + gfc_symbol *sym; + + lhs = c->expr; + rhs = c->expr2; + + /* Don't allow an intrinsic assignment to be replaced. */ + if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED + && (lhs->ts.type == rhs->ts.type + || (gfc_numeric_ts (&lhs->ts) + && gfc_numeric_ts (&rhs->ts)))) + return FAILURE; + + actual = gfc_get_actual_arglist (); + actual->expr = lhs; + + actual->next = gfc_get_actual_arglist (); + actual->next->expr = rhs; + + sym = NULL; + + for (; ns; ns = ns->parent) + { + sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual); + if (sym != NULL) + break; + } + + if (sym == NULL) + { + gfc_free (actual->next); + gfc_free (actual); + return FAILURE; + } + + /* Replace the assignment with the call. */ + c->op = EXEC_CALL; + c->symtree = find_sym_in_symtree (sym); + c->expr = NULL; + c->expr2 = NULL; + c->ext.actual = actual; + + if (gfc_pure (NULL) && !gfc_pure (sym)) + { + gfc_error ("Subroutine '%s' called in lieu of assignment at %L must be " + "PURE", sym->name, &c->loc); + return FAILURE; + } + + return SUCCESS; +} + + +/* Make sure that the interface just parsed is not already present in + the given interface list. Ambiguity isn't checked yet since module + procedures can be present without interfaces. */ + +static try +check_new_interface (gfc_interface * base, gfc_symbol * new) +{ + gfc_interface *ip; + + for (ip = base; ip; ip = ip->next) + { + if (ip->sym == new) + { + gfc_error ("Entity '%s' at %C is already present in the interface", + new->name); + return FAILURE; + } + } + + return SUCCESS; +} + + +/* Add a symbol to the current interface. */ + +try +gfc_add_interface (gfc_symbol * new) +{ + gfc_interface **head, *intr; + gfc_namespace *ns; + gfc_symbol *sym; + + switch (current_interface.type) + { + case INTERFACE_NAMELESS: + return SUCCESS; + + case INTERFACE_INTRINSIC_OP: + for (ns = current_interface.ns; ns; ns = ns->parent) + if (check_new_interface (ns->operator[current_interface.op], new) + == FAILURE) + return FAILURE; + + head = ¤t_interface.ns->operator[current_interface.op]; + break; + + case INTERFACE_GENERIC: + for (ns = current_interface.ns; ns; ns = ns->parent) + { + gfc_find_symbol (current_interface.sym->name, ns, 0, &sym); + if (sym == NULL) + continue; + + if (check_new_interface (sym->generic, new) == FAILURE) + return FAILURE; + } + + head = ¤t_interface.sym->generic; + break; + + case INTERFACE_USER_OP: + if (check_new_interface (current_interface.uop->operator, new) == + FAILURE) + return FAILURE; + + head = ¤t_interface.uop->operator; + break; + + default: + gfc_internal_error ("gfc_add_interface(): Bad interface type"); + } + + intr = gfc_get_interface (); + intr->sym = new; + intr->where = *gfc_current_locus (); + + intr->next = *head; + *head = intr; + + return SUCCESS; +} + + +/* Gets rid of a formal argument list. We do not free symbols. + Symbols are freed when a namespace is freed. */ + +void +gfc_free_formal_arglist (gfc_formal_arglist * p) +{ + gfc_formal_arglist *q; + + for (; p; p = q) + { + q = p->next; + gfc_free (p); + } +} diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c new file mode 100644 index 00000000000..3d05b72ca04 --- /dev/null +++ b/gcc/fortran/intrinsic.c @@ -0,0 +1,2560 @@ +/* Build up a list of intrinsic subroutines and functions for the + name-resolution stage. + Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc. + Contributed by Andy Vaught & Katherine Holcomb + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#include "config.h" +#include "system.h" +#include "flags.h" + +#include <stdio.h> +#include <stdarg.h> +#include <string.h> +#include <gmp.h> + +#include "gfortran.h" +#include "intrinsic.h" + + +/* Nanespace to hold the resolved symbols for intrinsic subroutines. */ +static gfc_namespace *gfc_intrinsic_namespace; + +int gfc_init_expr = 0; + +/* Pointers to a intrinsic function and its argument names being + checked. */ + +char *gfc_current_intrinsic, *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; +locus *gfc_current_intrinsic_where; + +static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym; +static gfc_intrinsic_arg *next_arg; + +static int nfunc, nsub, nargs, nconv; + +static enum +{ SZ_NOTHING = 0, SZ_SUBS, SZ_FUNCS, SZ_CONVS } +sizing; + + +/* Return a letter based on the passed type. Used to construct the + name of a type-dependent subroutine. */ + +char +gfc_type_letter (bt type) +{ + char c; + + switch (type) + { + case BT_LOGICAL: + c = 'l'; + break; + case BT_CHARACTER: + c = 's'; + break; + case BT_INTEGER: + c = 'i'; + break; + case BT_REAL: + c = 'r'; + break; + case BT_COMPLEX: + c = 'c'; + break; + + default: + c = 'u'; + break; + } + + return c; +} + + +/* Get a symbol for a resolved name. */ + +gfc_symbol * +gfc_get_intrinsic_sub_symbol (const char * name) +{ + gfc_symbol *sym; + + gfc_get_symbol (name, gfc_intrinsic_namespace, &sym); + sym->attr.always_explicit = 1; + sym->attr.subroutine = 1; + sym->attr.flavor = FL_PROCEDURE; + sym->attr.proc = PROC_INTRINSIC; + + return sym; +} + + +/* Return a pointer to the name of a conversion function given two + typespecs. */ + +static char * +conv_name (gfc_typespec * from, gfc_typespec * to) +{ + static char name[30]; + + sprintf (name, "__convert_%c%d_%c%d", gfc_type_letter (from->type), + from->kind, gfc_type_letter (to->type), to->kind); + + return name; +} + + +/* Given a pair of typespecs, find the gfc_intrinsic_sym node that + corresponds to the conversion. Returns NULL if the conversion + isn't found. */ + +static gfc_intrinsic_sym * +find_conv (gfc_typespec * from, gfc_typespec * to) +{ + gfc_intrinsic_sym *sym; + char *target; + int i; + + target = conv_name (from, to); + sym = conversion; + + for (i = 0; i < nconv; i++, sym++) + if (strcmp (target, sym->name) == 0) + return sym; + + return NULL; +} + + +/* Interface to the check functions. We break apart an argument list + and call the proper check function rather than forcing each + function to manipulate the argument list. */ + +static try +do_check (gfc_intrinsic_sym * specific, gfc_actual_arglist * arg) +{ + gfc_expr *a1, *a2, *a3, *a4, *a5; + try t; + + a1 = arg->expr; + arg = arg->next; + + if (arg == NULL) + t = (*specific->check.f1) (a1); + else + { + a2 = arg->expr; + arg = arg->next; + + if (arg == NULL) + t = (*specific->check.f2) (a1, a2); + else + { + a3 = arg->expr; + arg = arg->next; + + if (arg == NULL) + t = (*specific->check.f3) (a1, a2, a3); + else + { + a4 = arg->expr; + arg = arg->next; + + if (arg == NULL) + t = (*specific->check.f4) (a1, a2, a3, a4); + else + { + a5 = arg->expr; + arg = arg->next; + + if (arg == NULL) + t = (*specific->check.f5) (a1, a2, a3, a4, a5); + else + { + gfc_internal_error ("do_check(): too many args"); + } + } + } + } + } + + return t; +} + + +/*********** Subroutines to build the intrinsic list ****************/ + +/* Add a single intrinsic symbol to the current list. + + Argument list: + char * name of function + int whether function is elemental + int If the function can be used as an actual argument + bt return type of function + int kind of return type of function + check pointer to check function + simplify pointer to simplification function + resolve pointer to resolution function + + Optional arguments come in multiples of four: + char * name of argument + bt type of argument + int kind of argument + int arg optional flag (1=optional, 0=required) + + The sequence is terminated by a NULL name. + + TODO: Are checks on actual_ok implemented elsewhere, or is that just + missing here? */ + +static void +add_sym (const char *name, int elemental, int actual_ok ATTRIBUTE_UNUSED, + bt type, int kind, gfc_check_f check, gfc_simplify_f simplify, + gfc_resolve_f resolve, ...) +{ + + int optional, first_flag; + va_list argp; + + switch (sizing) + { + case SZ_SUBS: + nsub++; + break; + + case SZ_FUNCS: + nfunc++; + break; + + case SZ_NOTHING: + strcpy (next_sym->name, name); + + strcpy (next_sym->lib_name, "_gfortran_"); + strcat (next_sym->lib_name, name); + + next_sym->elemental = elemental; + next_sym->ts.type = type; + next_sym->ts.kind = kind; + next_sym->simplify = simplify; + next_sym->check = check; + next_sym->resolve = resolve; + next_sym->specific = 0; + next_sym->generic = 0; + break; + + default: + gfc_internal_error ("add_sym(): Bad sizing mode"); + } + + va_start (argp, resolve); + + first_flag = 1; + + for (;;) + { + name = va_arg (argp, char *); + if (name == NULL) + break; + + type = (bt) va_arg (argp, int); + kind = va_arg (argp, int); + optional = va_arg (argp, int); + + if (sizing != SZ_NOTHING) + nargs++; + else + { + next_arg++; + + if (first_flag) + next_sym->formal = next_arg; + else + (next_arg - 1)->next = next_arg; + + first_flag = 0; + + strcpy (next_arg->name, name); + next_arg->ts.type = type; + next_arg->ts.kind = kind; + next_arg->optional = optional; + } + } + + va_end (argp); + + next_sym++; +} + + +static void add_sym_0 (const char *name, int elemental, int actual_ok, bt type, + int kind, + try (*check)(gfc_expr *), + gfc_expr *(*simplify)(gfc_expr *), + void (*resolve)(gfc_expr *,gfc_expr *) + ) { + gfc_simplify_f sf; + gfc_check_f cf; + gfc_resolve_f rf; + + cf.f1 = check; + sf.f1 = simplify; + rf.f1 = resolve; + + add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf, + (void*)0); +} + + +static void add_sym_1 (const char *name, int elemental, int actual_ok, bt type, + int kind, + try (*check)(gfc_expr *), + gfc_expr *(*simplify)(gfc_expr *), + void (*resolve)(gfc_expr *,gfc_expr *), + const char* a1, bt type1, int kind1, int optional1 + ) { + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f1 = check; + sf.f1 = simplify; + rf.f1 = resolve; + + add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf, + a1, type1, kind1, optional1, + (void*)0); +} + + +static void +add_sym_0s (const char * name, int actual_ok, + void (*resolve)(gfc_code *)) +{ + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f1 = NULL; + sf.f1 = NULL; + rf.s1 = resolve; + + add_sym (name, 1, actual_ok, BT_UNKNOWN, 0, cf, sf, rf, + (void*)0); +} + + +static void add_sym_1s (const char *name, int elemental, int actual_ok, bt type, + int kind, + try (*check)(gfc_expr *), + gfc_expr *(*simplify)(gfc_expr *), + void (*resolve)(gfc_code *), + const char* a1, bt type1, int kind1, int optional1 + ) { + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f1 = check; + sf.f1 = simplify; + rf.s1 = resolve; + + add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf, + a1, type1, kind1, optional1, + (void*)0); +} + + +static void add_sym_1m (const char *name, int elemental, int actual_ok, bt type, + int kind, + try (*check)(gfc_actual_arglist *), + gfc_expr *(*simplify)(gfc_expr *), + void (*resolve)(gfc_expr *,gfc_actual_arglist *), + const char* a1, bt type1, int kind1, int optional1, + const char* a2, bt type2, int kind2, int optional2 + ) { + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f1m = check; + sf.f1 = simplify; + rf.f1m = resolve; + + add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf, + a1, type1, kind1, optional1, + a2, type2, kind2, optional2, + (void*)0); +} + + +static void add_sym_2 (const char *name, int elemental, int actual_ok, bt type, + int kind, + try (*check)(gfc_expr *,gfc_expr *), + gfc_expr *(*simplify)(gfc_expr *,gfc_expr *), + void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *), + const char* a1, bt type1, int kind1, int optional1, + const char* a2, bt type2, int kind2, int optional2 + ) { + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f2 = check; + sf.f2 = simplify; + rf.f2 = resolve; + + add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf, + a1, type1, kind1, optional1, + a2, type2, kind2, optional2, + (void*)0); +} + + +static void add_sym_3 (const char *name, int elemental, int actual_ok, bt type, + int kind, + try (*check)(gfc_expr *,gfc_expr *,gfc_expr *), + gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *), + void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *), + const char* a1, bt type1, int kind1, int optional1, + const char* a2, bt type2, int kind2, int optional2, + const char* a3, bt type3, int kind3, int optional3 + ) { + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f3 = check; + sf.f3 = simplify; + rf.f3 = resolve; + + add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf, + a1, type1, kind1, optional1, + a2, type2, kind2, optional2, + a3, type3, kind3, optional3, + (void*)0); +} + + +static void add_sym_4 (const char *name, int elemental, int actual_ok, bt type, + int kind, + try (*check)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *), + gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *), + void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *), + const char* a1, bt type1, int kind1, int optional1, + const char* a2, bt type2, int kind2, int optional2, + const char* a3, bt type3, int kind3, int optional3, + const char* a4, bt type4, int kind4, int optional4 + ) { + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f4 = check; + sf.f4 = simplify; + rf.f4 = resolve; + + add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf, + a1, type1, kind1, optional1, + a2, type2, kind2, optional2, + a3, type3, kind3, optional3, + a4, type4, kind4, optional4, + (void*)0); +} + + +static void add_sym_5 (const char *name, int elemental, int actual_ok, bt type, + int kind, + try (*check)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *), + gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *), + void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *), + const char* a1, bt type1, int kind1, int optional1, + const char* a2, bt type2, int kind2, int optional2, + const char* a3, bt type3, int kind3, int optional3, + const char* a4, bt type4, int kind4, int optional4, + const char* a5, bt type5, int kind5, int optional5 + ) { + gfc_check_f cf; + gfc_simplify_f sf; + gfc_resolve_f rf; + + cf.f5 = check; + sf.f5 = simplify; + rf.f5 = resolve; + + add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf, + a1, type1, kind1, optional1, + a2, type2, kind2, optional2, + a3, type3, kind3, optional3, + a4, type4, kind4, optional4, + a5, type5, kind5, optional5, + (void*)0); +} + + +/* Locate an intrinsic symbol given a base pointer, number of elements + in the table and a pointer to a name. Returns the NULL pointer if + a name is not found. */ + +static gfc_intrinsic_sym * +find_sym (gfc_intrinsic_sym * start, int n, const char *name) +{ + + while (n > 0) + { + if (strcmp (name, start->name) == 0) + return start; + + start++; + n--; + } + + return NULL; +} + + +/* Given a name, find a function in the intrinsic function table. + Returns NULL if not found. */ + +gfc_intrinsic_sym * +gfc_find_function (const char *name) +{ + + return find_sym (functions, nfunc, name); +} + + +/* Given a name, find a function in the intrinsic subroutine table. + Returns NULL if not found. */ + +static gfc_intrinsic_sym * +find_subroutine (const char *name) +{ + + return find_sym (subroutines, nsub, name); +} + + +/* Given a string, figure out if it is the name of a generic intrinsic + function or not. */ + +int +gfc_generic_intrinsic (const char *name) +{ + gfc_intrinsic_sym *sym; + + sym = gfc_find_function (name); + return (sym == NULL) ? 0 : sym->generic; +} + + +/* Given a string, figure out if it is the name of a specific + intrinsic function or not. */ + +int +gfc_specific_intrinsic (const char *name) +{ + gfc_intrinsic_sym *sym; + + sym = gfc_find_function (name); + return (sym == NULL) ? 0 : sym->specific; +} + + +/* Given a string, figure out if it is the name of an intrinsic + subroutine or function. There are no generic intrinsic + subroutines, they are all specific. */ + +int +gfc_intrinsic_name (const char *name, int subroutine_flag) +{ + + return subroutine_flag ? + find_subroutine (name) != NULL : gfc_find_function (name) != NULL; +} + + +/* Collect a set of intrinsic functions into a generic collection. + The first argument is the name of the generic function, which is + also the name of a specific function. The rest of the specifics + currently in the table are placed into the list of specific + functions associated with that generic. */ + +static void +make_generic (const char *name, gfc_generic_isym_id generic_id) +{ + gfc_intrinsic_sym *g; + + if (sizing != SZ_NOTHING) + return; + + g = gfc_find_function (name); + if (g == NULL) + gfc_internal_error ("make_generic(): Can't find generic symbol '%s'", + name); + + g->generic = 1; + g->specific = 1; + g->generic_id = generic_id; + if ((g + 1)->name[0] != '\0') + g->specific_head = g + 1; + g++; + + while (g->name[0] != '\0') + { + g->next = g + 1; + g->specific = 1; + g->generic_id = generic_id; + g++; + } + + g--; + g->next = NULL; +} + + +/* Create a duplicate intrinsic function entry for the current + function, the only difference being the alternate name. Note that + we use argument lists more than once, but all argument lists are + freed as a single block. */ + +static void +make_alias (const char *name) +{ + + switch (sizing) + { + case SZ_FUNCS: + nfunc++; + break; + + case SZ_SUBS: + nsub++; + break; + + case SZ_NOTHING: + next_sym[0] = next_sym[-1]; + strcpy (next_sym->name, name); + next_sym++; + break; + + default: + break; + } +} + + +/* Add intrinsic functions. */ + +static void +add_functions (void) +{ + + /* Argument names as in the standard (to be used as argument keywords). */ + const char + *a = "a", *f = "field", *pt = "pointer", *tg = "target", + *b = "b", *m = "matrix", *ma = "matrix_a", *mb = "matrix_b", + *c = "c", *n = "ncopies", *pos = "pos", *bck = "back", + *i = "i", *v = "vector", *va = "vector_a", *vb = "vector_b", + *j = "j", *a1 = "a1", *fs = "fsource", *ts = "tsource", + *l = "l", *a2 = "a2", *mo = "mold", *ord = "order", + *p = "p", *ar = "array", *shp = "shape", *src = "source", + *r = "r", *bd = "boundary", *pad = "pad", *set = "set", + *s = "s", *dm = "dim", *kind = "kind", *msk = "mask", + *x = "x", *sh = "shift", *stg = "string", *ssg = "substring", + *y = "y", *sz = "size", *sta = "string_a", *stb = "string_b", + *z = "z", *ln = "len"; + + int di, dr, dd, dl, dc, dz, ii; + + di = gfc_default_integer_kind (); + dr = gfc_default_real_kind (); + dd = gfc_default_double_kind (); + dl = gfc_default_logical_kind (); + dc = gfc_default_character_kind (); + dz = gfc_default_complex_kind (); + ii = gfc_index_integer_kind; + + add_sym_1 ("abs", 1, 1, BT_REAL, dr, + gfc_check_abs, gfc_simplify_abs, gfc_resolve_abs, + a, BT_REAL, dr, 0); + + add_sym_1 ("iabs", 1, 1, BT_INTEGER, di, + NULL, gfc_simplify_abs, gfc_resolve_abs, + a, BT_INTEGER, di, 0); + + add_sym_1 ("dabs", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_abs, gfc_resolve_abs, a, BT_REAL, dd, 0); + + add_sym_1 ("cabs", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_abs, gfc_resolve_abs, + a, BT_COMPLEX, dz, 0); + + add_sym_1 ("zabs", 1, 1, BT_REAL, dd, NULL, gfc_simplify_abs, gfc_resolve_abs, a, BT_COMPLEX, dd, 0); /* Extension */ + + make_alias ("cdabs"); + + make_generic ("abs", GFC_ISYM_ABS); + + add_sym_1 ("achar", 1, 1, BT_CHARACTER, dc, + NULL, gfc_simplify_achar, NULL, i, BT_INTEGER, di, 0); + + make_generic ("achar", GFC_ISYM_ACHAR); + + add_sym_1 ("acos", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_acos, gfc_resolve_acos, + x, BT_REAL, dr, 0); + + add_sym_1 ("dacos", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_acos, gfc_resolve_acos, + x, BT_REAL, dd, 0); + + make_generic ("acos", GFC_ISYM_ACOS); + + add_sym_1 ("adjustl", 1, 1, BT_CHARACTER, dc, + NULL, gfc_simplify_adjustl, NULL, stg, BT_CHARACTER, dc, 0); + + make_generic ("adjustl", GFC_ISYM_ADJUSTL); + + add_sym_1 ("adjustr", 1, 1, BT_CHARACTER, dc, + NULL, gfc_simplify_adjustr, NULL, stg, BT_CHARACTER, dc, 0); + + make_generic ("adjustr", GFC_ISYM_ADJUSTR); + + add_sym_1 ("aimag", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_aimag, gfc_resolve_aimag, + z, BT_COMPLEX, dz, 0); + + add_sym_1 ("dimag", 1, 1, BT_REAL, dd, NULL, gfc_simplify_aimag, gfc_resolve_aimag, z, BT_COMPLEX, dd, 0); /* Extension */ + + make_generic ("aimag", GFC_ISYM_AIMAG); + + add_sym_2 ("aint", 1, 1, BT_REAL, dr, + gfc_check_a_xkind, gfc_simplify_aint, gfc_resolve_aint, + a, BT_REAL, dr, 0, kind, BT_INTEGER, di, 1); + + add_sym_1 ("dint", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_dint, gfc_resolve_dint, + a, BT_REAL, dd, 0); + + make_generic ("aint", GFC_ISYM_AINT); + + add_sym_2 ("all", 0, 1, BT_UNKNOWN, 0, + gfc_check_all_any, NULL, gfc_resolve_all, + msk, BT_LOGICAL, dl, 0, dm, BT_INTEGER, ii, 1); + + make_generic ("all", GFC_ISYM_ALL); + + add_sym_1 ("allocated", 0, 1, BT_LOGICAL, dl, + gfc_check_allocated, NULL, NULL, ar, BT_UNKNOWN, 0, 0); + + make_generic ("allocated", GFC_ISYM_ALLOCATED); + + add_sym_2 ("anint", 1, 1, BT_REAL, dr, + gfc_check_a_xkind, gfc_simplify_anint, gfc_resolve_anint, + a, BT_REAL, dr, 0, kind, BT_INTEGER, di, 1); + + add_sym_1 ("dnint", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_dnint, gfc_resolve_dnint, + a, BT_REAL, dd, 0); + + make_generic ("anint", GFC_ISYM_ANINT); + + add_sym_2 ("any", 0, 1, BT_UNKNOWN, 0, + gfc_check_all_any, NULL, gfc_resolve_any, + msk, BT_LOGICAL, dl, 0, dm, BT_INTEGER, ii, 1); + + make_generic ("any", GFC_ISYM_ANY); + + add_sym_1 ("asin", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_asin, gfc_resolve_asin, + x, BT_REAL, dr, 0); + + add_sym_1 ("dasin", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_asin, gfc_resolve_asin, + x, BT_REAL, dd, 0); + + make_generic ("asin", GFC_ISYM_ASIN); + + add_sym_2 ("associated", 0, 1, BT_LOGICAL, dl, + gfc_check_associated, NULL, NULL, + pt, BT_UNKNOWN, 0, 0, tg, BT_UNKNOWN, 0, 1); + + make_generic ("associated", GFC_ISYM_ASSOCIATED); + + add_sym_1 ("atan", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_atan, gfc_resolve_atan, + x, BT_REAL, dr, 0); + + add_sym_1 ("datan", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_atan, gfc_resolve_atan, + x, BT_REAL, dd, 0); + + make_generic ("atan", GFC_ISYM_ATAN); + + add_sym_2 ("atan2", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_atan2, gfc_resolve_atan2, + y, BT_REAL, dr, 0, x, BT_REAL, dr, 0); + + add_sym_2 ("datan2", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_atan2, gfc_resolve_atan2, + y, BT_REAL, dd, 0, x, BT_REAL, dd, 0); + + make_generic ("atan2", GFC_ISYM_ATAN2); + + add_sym_1 ("bit_size", 0, 1, BT_INTEGER, di, + gfc_check_i, gfc_simplify_bit_size, NULL, + i, BT_INTEGER, di, 0); + + make_generic ("bit_size", GFC_ISYM_NONE); + + add_sym_2 ("btest", 1, 1, BT_LOGICAL, dl, + gfc_check_btest, gfc_simplify_btest, gfc_resolve_btest, + i, BT_INTEGER, di, 0, pos, BT_INTEGER, di, 0); + + make_generic ("btest", GFC_ISYM_BTEST); + + add_sym_2 ("ceiling", 1, 1, BT_INTEGER, di, + gfc_check_a_ikind, gfc_simplify_ceiling, gfc_resolve_ceiling, + a, BT_REAL, dr, 0, kind, BT_INTEGER, di, 1); + + make_generic ("ceiling", GFC_ISYM_CEILING); + + add_sym_2 ("char", 1, 0, BT_CHARACTER, dc, + gfc_check_char, gfc_simplify_char, gfc_resolve_char, + i, BT_INTEGER, di, 0, kind, BT_INTEGER, di, 1); + + make_generic ("char", GFC_ISYM_CHAR); + + add_sym_3 ("cmplx", 1, 1, BT_COMPLEX, dz, + gfc_check_cmplx, gfc_simplify_cmplx, gfc_resolve_cmplx, + x, BT_UNKNOWN, dr, 0, y, BT_UNKNOWN, dr, 1, + kind, BT_INTEGER, di, 1); + + make_generic ("cmplx", GFC_ISYM_CMPLX); + + /* Making dcmplx a specific of cmplx causes cmplx to return a double + complex instead of the default complex. */ + + add_sym_2 ("dcmplx", 1, 1, BT_COMPLEX, dd, + gfc_check_dcmplx, gfc_simplify_dcmplx, gfc_resolve_dcmplx, + x, BT_REAL, dd, 0, y, BT_REAL, dd, 1); /* Extension */ + + make_generic ("dcmplx", GFC_ISYM_CMPLX); + + add_sym_1 ("conjg", 1, 1, BT_COMPLEX, dz, + NULL, gfc_simplify_conjg, gfc_resolve_conjg, + z, BT_COMPLEX, dz, 0); + + add_sym_1 ("dconjg", 1, 1, BT_COMPLEX, dd, NULL, gfc_simplify_conjg, gfc_resolve_conjg, z, BT_COMPLEX, dd, 0); /* Extension */ + + make_generic ("conjg", GFC_ISYM_CONJG); + + add_sym_1 ("cos", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_cos, gfc_resolve_cos, x, BT_REAL, dr, 0); + + add_sym_1 ("dcos", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_cos, gfc_resolve_cos, x, BT_REAL, dd, 0); + + add_sym_1 ("ccos", 1, 1, BT_COMPLEX, dz, + NULL, gfc_simplify_cos, gfc_resolve_cos, + x, BT_COMPLEX, dz, 0); + + add_sym_1 ("zcos", 1, 1, BT_COMPLEX, dd, NULL, gfc_simplify_cos, gfc_resolve_cos, x, BT_COMPLEX, dd, 0); /* Extension */ + + make_alias ("cdcos"); + + make_generic ("cos", GFC_ISYM_COS); + + add_sym_1 ("cosh", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_cosh, gfc_resolve_cosh, + x, BT_REAL, dr, 0); + + add_sym_1 ("dcosh", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_cosh, gfc_resolve_cosh, + x, BT_REAL, dd, 0); + + make_generic ("cosh", GFC_ISYM_COSH); + + add_sym_2 ("count", 0, 1, BT_INTEGER, di, + gfc_check_count, NULL, gfc_resolve_count, + msk, BT_LOGICAL, dl, 0, dm, BT_INTEGER, ii, 1); + + make_generic ("count", GFC_ISYM_COUNT); + + add_sym_3 ("cshift", 0, 1, BT_REAL, dr, + gfc_check_cshift, NULL, gfc_resolve_cshift, + ar, BT_REAL, dr, 0, sh, BT_INTEGER, di, 0, + dm, BT_INTEGER, ii, 1); + + make_generic ("cshift", GFC_ISYM_CSHIFT); + + add_sym_1 ("dble", 1, 1, BT_REAL, dd, + gfc_check_dble, gfc_simplify_dble, gfc_resolve_dble, + a, BT_REAL, dr, 0); + + make_generic ("dble", GFC_ISYM_DBLE); + + add_sym_1 ("digits", 0, 1, BT_INTEGER, di, + gfc_check_digits, gfc_simplify_digits, NULL, + x, BT_UNKNOWN, dr, 0); + + make_generic ("digits", GFC_ISYM_NONE); + + add_sym_2 ("dim", 1, 1, BT_REAL, dr, + gfc_check_a_p, gfc_simplify_dim, gfc_resolve_dim, + x, BT_UNKNOWN, dr, 0, y, BT_UNKNOWN, dr, 0); + + add_sym_2 ("idim", 1, 1, BT_INTEGER, di, + NULL, gfc_simplify_dim, gfc_resolve_dim, + x, BT_INTEGER, di, 0, y, BT_INTEGER, di, 0); + + add_sym_2 ("ddim", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_dim, gfc_resolve_dim, + x, BT_REAL, dd, 0, y, BT_REAL, dd, 0); + + make_generic ("dim", GFC_ISYM_DIM); + + add_sym_2 ("dot_product", 0, 1, BT_UNKNOWN, 0, + gfc_check_dot_product, NULL, gfc_resolve_dot_product, + va, BT_REAL, dr, 0, vb, BT_REAL, dr, 0); + + make_generic ("dot_product", GFC_ISYM_DOT_PRODUCT); + + add_sym_2 ("dprod", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_dprod, gfc_resolve_dprod, + x, BT_REAL, dr, 0, y, BT_REAL, dr, 0); + + make_generic ("dprod", GFC_ISYM_DPROD); + + add_sym_1 ("dreal", 1, 0, BT_REAL, dd, NULL, NULL, NULL, a, BT_COMPLEX, dd, 0); /* Extension */ + + make_generic ("dreal", GFC_ISYM_REAL); + + add_sym_4 ("eoshift", 0, 1, BT_REAL, dr, + gfc_check_eoshift, NULL, gfc_resolve_eoshift, + ar, BT_REAL, dr, 0, sh, BT_INTEGER, ii, 0, + bd, BT_REAL, dr, 1, dm, BT_INTEGER, ii, 1); + + make_generic ("eoshift", GFC_ISYM_EOSHIFT); + + add_sym_1 ("epsilon", 0, 1, BT_REAL, dr, + gfc_check_x, gfc_simplify_epsilon, NULL, + x, BT_REAL, dr, 0); + + make_generic ("epsilon", GFC_ISYM_NONE); + + add_sym_1 ("exp", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_exp, gfc_resolve_exp, x, BT_REAL, dr, 0); + + add_sym_1 ("dexp", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_exp, gfc_resolve_exp, x, BT_REAL, dd, 0); + + add_sym_1 ("cexp", 1, 1, BT_COMPLEX, dz, + NULL, gfc_simplify_exp, gfc_resolve_exp, + x, BT_COMPLEX, dz, 0); + + add_sym_1 ("zexp", 1, 1, BT_COMPLEX, dd, NULL, gfc_simplify_exp, gfc_resolve_exp, x, BT_COMPLEX, dd, 0); /* Extension */ + + make_alias ("cdexp"); + + make_generic ("exp", GFC_ISYM_EXP); + + add_sym_1 ("exponent", 1, 1, BT_INTEGER, di, + gfc_check_x, gfc_simplify_exponent, gfc_resolve_exponent, + x, BT_REAL, dr, 0); + + make_generic ("exponent", GFC_ISYM_EXPONENT); + + add_sym_2 ("floor", 1, 1, BT_INTEGER, di, + gfc_check_a_ikind, gfc_simplify_floor, gfc_resolve_floor, + a, BT_REAL, dr, 0, kind, BT_INTEGER, di, 1); + + make_generic ("floor", GFC_ISYM_FLOOR); + + add_sym_1 ("fraction", 1, 1, BT_REAL, dr, + gfc_check_x, gfc_simplify_fraction, gfc_resolve_fraction, + x, BT_REAL, dr, 0); + + make_generic ("fraction", GFC_ISYM_FRACTION); + + add_sym_1 ("huge", 0, 1, BT_REAL, dr, + gfc_check_huge, gfc_simplify_huge, NULL, + x, BT_UNKNOWN, dr, 0); + + make_generic ("huge", GFC_ISYM_NONE); + + add_sym_1 ("iachar", 1, 1, BT_INTEGER, di, + NULL, gfc_simplify_iachar, NULL, c, BT_CHARACTER, dc, 0); + + make_generic ("iachar", GFC_ISYM_IACHAR); + + add_sym_2 ("iand", 1, 1, BT_INTEGER, di, + gfc_check_iand, gfc_simplify_iand, gfc_resolve_iand, + i, BT_INTEGER, di, 0, j, BT_INTEGER, di, 0); + + make_generic ("iand", GFC_ISYM_IAND); + + add_sym_0 ("iargc", 1, 1, BT_INTEGER, di, NULL, NULL, NULL); /* Extension, takes no arguments */ + + add_sym_2 ("ibclr", 1, 1, BT_INTEGER, di, + gfc_check_ibclr, gfc_simplify_ibclr, gfc_resolve_ibclr, + i, BT_INTEGER, di, 0, pos, BT_INTEGER, di, 0); + + make_generic ("ibclr", GFC_ISYM_IBCLR); + + add_sym_3 ("ibits", 1, 1, BT_INTEGER, di, + gfc_check_ibits, gfc_simplify_ibits, gfc_resolve_ibits, + i, BT_INTEGER, di, 0, pos, BT_INTEGER, di, 0, + ln, BT_INTEGER, di, 0); + + make_generic ("ibits", GFC_ISYM_IBITS); + + add_sym_2 ("ibset", 1, 1, BT_INTEGER, di, + gfc_check_ibset, gfc_simplify_ibset, gfc_resolve_ibset, + i, BT_INTEGER, di, 0, pos, BT_INTEGER, di, 0); + + make_generic ("ibset", GFC_ISYM_IBSET); + + add_sym_1 ("ichar", 1, 0, BT_INTEGER, di, + NULL, gfc_simplify_ichar, gfc_resolve_ichar, + c, BT_CHARACTER, dc, 0); + + make_generic ("ichar", GFC_ISYM_ICHAR); + + add_sym_2 ("ieor", 1, 1, BT_INTEGER, di, + gfc_check_ieor, gfc_simplify_ieor, gfc_resolve_ieor, + i, BT_INTEGER, di, 0, j, BT_INTEGER, di, 0); + + make_generic ("ieor", GFC_ISYM_IEOR); + + add_sym_3 ("index", 1, 1, BT_INTEGER, di, + gfc_check_index, gfc_simplify_index, NULL, + stg, BT_CHARACTER, dc, 0, ssg, BT_CHARACTER, dc, 0, + bck, BT_LOGICAL, dl, 1); + + make_generic ("index", GFC_ISYM_INDEX); + + add_sym_2 ("int", 1, 1, BT_INTEGER, di, + gfc_check_int, gfc_simplify_int, gfc_resolve_int, + a, BT_REAL, dr, 0, kind, BT_INTEGER, di, 1); + + add_sym_1 ("ifix", 1, 0, BT_INTEGER, di, + NULL, gfc_simplify_ifix, NULL, a, BT_REAL, dr, 0); + + add_sym_1 ("idint", 1, 0, BT_INTEGER, di, + NULL, gfc_simplify_idint, NULL, a, BT_REAL, dd, 0); + + make_generic ("int", GFC_ISYM_INT); + + add_sym_2 ("ior", 1, 1, BT_INTEGER, di, + gfc_check_ior, gfc_simplify_ior, gfc_resolve_ior, + i, BT_INTEGER, di, 0, j, BT_INTEGER, di, 0); + + make_generic ("ior", GFC_ISYM_IOR); + + add_sym_2 ("ishft", 1, 1, BT_INTEGER, di, + gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft, + i, BT_INTEGER, di, 0, sh, BT_INTEGER, di, 0); + + make_generic ("ishft", GFC_ISYM_ISHFT); + + add_sym_3 ("ishftc", 1, 1, BT_INTEGER, di, + gfc_check_ishftc, gfc_simplify_ishftc, gfc_resolve_ishftc, + i, BT_INTEGER, di, 0, sh, BT_INTEGER, di, 0, + sz, BT_INTEGER, di, 1); + + make_generic ("ishftc", GFC_ISYM_ISHFTC); + + add_sym_1 ("kind", 0, 1, BT_INTEGER, di, + gfc_check_kind, gfc_simplify_kind, NULL, x, BT_REAL, dr, 0); + + make_generic ("kind", GFC_ISYM_NONE); + + add_sym_2 ("lbound", 0, 1, BT_INTEGER, di, + gfc_check_lbound, gfc_simplify_lbound, gfc_resolve_lbound, + ar, BT_REAL, dr, 0, dm, BT_INTEGER, di, 1); + + make_generic ("lbound", GFC_ISYM_LBOUND); + + add_sym_1 ("len", 0, 1, BT_INTEGER, di, + NULL, gfc_simplify_len, gfc_resolve_len, + stg, BT_CHARACTER, dc, 0); + + make_generic ("len", GFC_ISYM_LEN); + + add_sym_1 ("len_trim", 1, 1, BT_INTEGER, di, + NULL, gfc_simplify_len_trim, gfc_resolve_len_trim, + stg, BT_CHARACTER, dc, 0); + + make_generic ("len_trim", GFC_ISYM_LEN_TRIM); + + add_sym_2 ("lge", 1, 0, BT_LOGICAL, dl, + NULL, gfc_simplify_lge, NULL, + sta, BT_CHARACTER, dc, 0, stb, BT_CHARACTER, dc, 0); + + make_generic ("lge", GFC_ISYM_LGE); + + add_sym_2 ("lgt", 1, 0, BT_LOGICAL, dl, + NULL, gfc_simplify_lgt, NULL, + sta, BT_CHARACTER, dc, 0, stb, BT_CHARACTER, dc, 0); + + make_generic ("lgt", GFC_ISYM_LGT); + + add_sym_2 ("lle", 1, 0, BT_LOGICAL, dl, + NULL, gfc_simplify_lle, NULL, + sta, BT_CHARACTER, dc, 0, stb, BT_CHARACTER, dc, 0); + + make_generic ("lle", GFC_ISYM_LLE); + + add_sym_2 ("llt", 1, 0, BT_LOGICAL, dl, + NULL, gfc_simplify_llt, NULL, + sta, BT_CHARACTER, dc, 0, stb, BT_CHARACTER, dc, 0); + + make_generic ("llt", GFC_ISYM_LLT); + + add_sym_1 ("log", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_log, gfc_resolve_log, x, BT_REAL, dr, 0); + + add_sym_1 ("alog", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_log, gfc_resolve_log, x, BT_REAL, dr, 0); + + add_sym_1 ("dlog", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_log, gfc_resolve_log, x, BT_REAL, dd, 0); + + add_sym_1 ("clog", 1, 1, BT_COMPLEX, dz, + NULL, gfc_simplify_log, gfc_resolve_log, + x, BT_COMPLEX, dz, 0); + + add_sym_1 ("zlog", 1, 1, BT_COMPLEX, dd, NULL, gfc_simplify_log, gfc_resolve_log, x, BT_COMPLEX, dd, 0); /* Extension */ + + make_alias ("cdlog"); + + make_generic ("log", GFC_ISYM_LOG); + + add_sym_1 ("log10", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_log10, gfc_resolve_log10, + x, BT_REAL, dr, 0); + + add_sym_1 ("alog10", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_log10, gfc_resolve_log10, + x, BT_REAL, dr, 0); + + add_sym_1 ("dlog10", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_log10, gfc_resolve_log10, + x, BT_REAL, dd, 0); + + make_generic ("log10", GFC_ISYM_LOG10); + + add_sym_2 ("logical", 0, 1, BT_LOGICAL, dl, + gfc_check_logical, gfc_simplify_logical, gfc_resolve_logical, + l, BT_LOGICAL, dl, 0, kind, BT_INTEGER, di, 1); + + make_generic ("logical", GFC_ISYM_LOGICAL); + + add_sym_2 ("matmul", 0, 1, BT_REAL, dr, + gfc_check_matmul, NULL, gfc_resolve_matmul, + ma, BT_REAL, dr, 0, mb, BT_REAL, dr, 0); + + make_generic ("matmul", GFC_ISYM_MATMUL); + + /* Note: amax0 is equivalent to real(max), max1 is equivalent to + int(max). The max function must take at least two arguments. */ + + add_sym_1m ("max", 1, 0, BT_UNKNOWN, 0, + gfc_check_min_max, gfc_simplify_max, gfc_resolve_max, + a1, BT_UNKNOWN, dr, 0, a2, BT_UNKNOWN, dr, 0); + + add_sym_1m ("max0", 1, 0, BT_INTEGER, di, + gfc_check_min_max_integer, gfc_simplify_max, NULL, + a1, BT_INTEGER, di, 0, a2, BT_INTEGER, di, 0); + + add_sym_1m ("amax0", 1, 0, BT_REAL, dr, + gfc_check_min_max_integer, gfc_simplify_max, NULL, + a1, BT_INTEGER, di, 0, a2, BT_INTEGER, di, 0); + + add_sym_1m ("amax1", 1, 0, BT_REAL, dr, + gfc_check_min_max_real, gfc_simplify_max, NULL, + a1, BT_REAL, dr, 0, a2, BT_REAL, dr, 0); + + add_sym_1m ("max1", 1, 0, BT_INTEGER, di, + gfc_check_min_max_real, gfc_simplify_max, NULL, + a1, BT_REAL, dr, 0, a2, BT_REAL, dr, 0); + + add_sym_1m ("dmax1", 1, 0, BT_REAL, dd, + gfc_check_min_max_double, gfc_simplify_max, NULL, + a1, BT_REAL, dd, 0, a2, BT_REAL, dd, 0); + + make_generic ("max", GFC_ISYM_MAX); + + add_sym_1 ("maxexponent", 0, 1, BT_INTEGER, di, + gfc_check_x, gfc_simplify_maxexponent, NULL, + x, BT_UNKNOWN, dr, 0); + + make_generic ("maxexponent", GFC_ISYM_NONE); + + add_sym_3 ("maxloc", 0, 1, BT_INTEGER, di, + gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc, + ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1, + msk, BT_LOGICAL, dl, 1); + + make_generic ("maxloc", GFC_ISYM_MAXLOC); + + add_sym_3 ("maxval", 0, 1, BT_REAL, dr, + gfc_check_minval_maxval, NULL, gfc_resolve_maxval, + ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1, + msk, BT_LOGICAL, dl, 1); + + make_generic ("maxval", GFC_ISYM_MAXVAL); + + add_sym_3 ("merge", 1, 1, BT_REAL, dr, + gfc_check_merge, NULL, gfc_resolve_merge, + ts, BT_REAL, dr, 0, fs, BT_REAL, dr, 0, + msk, BT_LOGICAL, dl, 0); + + make_generic ("merge", GFC_ISYM_MERGE); + + /* Note: amin0 is equivalent to real(min), min1 is equivalent to int(min). */ + + add_sym_1m ("min", 1, 0, BT_UNKNOWN, 0, + gfc_check_min_max, gfc_simplify_min, gfc_resolve_min, + a1, BT_REAL, dr, 0, a2, BT_REAL, dr, 0); + + add_sym_1m ("min0", 1, 0, BT_INTEGER, di, + gfc_check_min_max_integer, gfc_simplify_min, NULL, + a1, BT_INTEGER, di, 0, a2, BT_INTEGER, di, 0); + + add_sym_1m ("amin0", 1, 0, BT_REAL, dr, + gfc_check_min_max_integer, gfc_simplify_min, NULL, + a1, BT_INTEGER, di, 0, a2, BT_INTEGER, di, 0); + + add_sym_1m ("amin1", 1, 0, BT_REAL, dr, + gfc_check_min_max_real, gfc_simplify_min, NULL, + a1, BT_REAL, dr, 0, a2, BT_REAL, dr, 0); + + add_sym_1m ("min1", 1, 0, BT_INTEGER, di, + gfc_check_min_max_real, gfc_simplify_min, NULL, + a1, BT_REAL, dr, 0, a2, BT_REAL, dr, 0); + + add_sym_1m ("dmin1", 1, 0, BT_REAL, dd, + gfc_check_min_max_double, gfc_simplify_min, NULL, + a1, BT_REAL, dd, 0, a2, BT_REAL, dd, 0); + + make_generic ("min", GFC_ISYM_MIN); + + add_sym_1 ("minexponent", 0, 1, BT_INTEGER, di, + gfc_check_x, gfc_simplify_minexponent, NULL, + x, BT_UNKNOWN, dr, 0); + + make_generic ("minexponent", GFC_ISYM_NONE); + + add_sym_3 ("minloc", 0, 1, BT_INTEGER, di, + gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc, + ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1, + msk, BT_LOGICAL, dl, 1); + + make_generic ("minloc", GFC_ISYM_MINLOC); + + add_sym_3 ("minval", 0, 1, BT_REAL, dr, + gfc_check_minval_maxval, NULL, gfc_resolve_minval, + ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1, + msk, BT_LOGICAL, dl, 1); + + make_generic ("minval", GFC_ISYM_MINVAL); + + add_sym_2 ("mod", 1, 1, BT_INTEGER, di, + gfc_check_a_p, gfc_simplify_mod, gfc_resolve_mod, + a, BT_INTEGER, di, 0, p, BT_INTEGER, di, 0); + + add_sym_2 ("amod", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_mod, gfc_resolve_mod, + a, BT_REAL, dr, 0, p, BT_REAL, dr, 0); + + add_sym_2 ("dmod", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_mod, gfc_resolve_mod, + a, BT_REAL, dd, 0, p, BT_REAL, dd, 0); + + make_generic ("mod", GFC_ISYM_MOD); + + add_sym_2 ("modulo", 1, 1, BT_REAL, di, + gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo, + a, BT_REAL, di, 0, p, BT_REAL, di, 0); + + make_generic ("modulo", GFC_ISYM_MODULO); + + add_sym_2 ("nearest", 1, 1, BT_REAL, dr, + gfc_check_nearest, gfc_simplify_nearest, NULL, + x, BT_REAL, dr, 0, s, BT_REAL, dr, 0); + + make_generic ("nearest", GFC_ISYM_NEAREST); + + add_sym_2 ("nint", 1, 1, BT_INTEGER, di, + gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint, + a, BT_REAL, dr, 0, kind, BT_INTEGER, di, 1); + + add_sym_1 ("idnint", 1, 1, BT_INTEGER, di, + gfc_check_idnint, gfc_simplify_idnint, gfc_resolve_idnint, + a, BT_REAL, dd, 0); + + make_generic ("nint", GFC_ISYM_NINT); + + add_sym_1 ("not", 1, 1, BT_INTEGER, di, + gfc_check_i, gfc_simplify_not, gfc_resolve_not, + i, BT_INTEGER, di, 0); + + make_generic ("not", GFC_ISYM_NOT); + + add_sym_1 ("null", 0, 1, BT_INTEGER, di, + gfc_check_null, gfc_simplify_null, NULL, + mo, BT_INTEGER, di, 1); + + make_generic ("null", GFC_ISYM_NONE); + + add_sym_3 ("pack", 0, 1, BT_REAL, dr, + gfc_check_pack, NULL, gfc_resolve_pack, + ar, BT_REAL, dr, 0, msk, BT_LOGICAL, dl, 0, + v, BT_REAL, dr, 1); + + make_generic ("pack", GFC_ISYM_PACK); + + add_sym_1 ("precision", 0, 1, BT_INTEGER, di, + gfc_check_precision, gfc_simplify_precision, NULL, + x, BT_UNKNOWN, 0, 0); + + make_generic ("precision", GFC_ISYM_NONE); + + add_sym_1 ("present", 0, 1, BT_LOGICAL, dl, + gfc_check_present, NULL, NULL, a, BT_REAL, dr, 0); + + make_generic ("present", GFC_ISYM_PRESENT); + + add_sym_3 ("product", 0, 1, BT_REAL, dr, + gfc_check_product, NULL, gfc_resolve_product, + ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1, + msk, BT_LOGICAL, dl, 1); + + make_generic ("product", GFC_ISYM_PRODUCT); + + add_sym_1 ("radix", 0, 1, BT_INTEGER, di, + gfc_check_radix, gfc_simplify_radix, NULL, + x, BT_UNKNOWN, 0, 0); + + make_generic ("radix", GFC_ISYM_NONE); + + add_sym_1 ("range", 0, 1, BT_INTEGER, di, + gfc_check_range, gfc_simplify_range, NULL, + x, BT_REAL, dr, 0); + + make_generic ("range", GFC_ISYM_NONE); + + add_sym_2 ("real", 1, 0, BT_REAL, dr, + gfc_check_real, gfc_simplify_real, gfc_resolve_real, + a, BT_UNKNOWN, dr, 0, kind, BT_INTEGER, di, 1); + + add_sym_1 ("float", 1, 0, BT_REAL, dr, + NULL, gfc_simplify_float, NULL, a, BT_INTEGER, di, 0); + + add_sym_1 ("sngl", 1, 0, BT_REAL, dr, + NULL, gfc_simplify_sngl, NULL, a, BT_REAL, dd, 0); + + make_generic ("real", GFC_ISYM_REAL); + + add_sym_2 ("repeat", 0, 1, BT_CHARACTER, dc, + gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat, + stg, BT_CHARACTER, dc, 0, n, BT_INTEGER, di, 0); + + make_generic ("repeat", GFC_ISYM_REPEAT); + + add_sym_4 ("reshape", 0, 1, BT_REAL, dr, + gfc_check_reshape, gfc_simplify_reshape, gfc_resolve_reshape, + src, BT_REAL, dr, 0, shp, BT_INTEGER, ii, 0, + pad, BT_REAL, dr, 1, ord, BT_INTEGER, ii, 1); + + make_generic ("reshape", GFC_ISYM_RESHAPE); + + add_sym_1 ("rrspacing", 1, 1, BT_REAL, dr, + gfc_check_x, gfc_simplify_rrspacing, gfc_resolve_rrspacing, + x, BT_REAL, dr, 0); + + make_generic ("rrspacing", GFC_ISYM_RRSPACING); + + add_sym_2 ("scale", 1, 1, BT_REAL, dr, + gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale, + x, BT_REAL, dr, 0, i, BT_INTEGER, di, 0); + + make_generic ("scale", GFC_ISYM_SCALE); + + add_sym_3 ("scan", 1, 1, BT_INTEGER, di, + gfc_check_scan, gfc_simplify_scan, gfc_resolve_scan, + stg, BT_CHARACTER, dc, 0, set, BT_CHARACTER, dc, 0, + bck, BT_LOGICAL, dl, 1); + + make_generic ("scan", GFC_ISYM_SCAN); + + add_sym_1 ("selected_int_kind", 0, 1, BT_INTEGER, di, + NULL, gfc_simplify_selected_int_kind, NULL, + r, BT_INTEGER, di, 0); + + make_generic ("selected_int_kind", GFC_ISYM_SI_KIND); + + add_sym_2 ("selected_real_kind", 0, 1, BT_INTEGER, di, + gfc_check_selected_real_kind, gfc_simplify_selected_real_kind, + NULL, p, BT_INTEGER, di, 1, r, BT_INTEGER, di, 1); + + make_generic ("selected_real_kind", GFC_ISYM_SR_KIND); + + add_sym_2 ("set_exponent", 1, 1, BT_REAL, dr, + gfc_check_set_exponent, gfc_simplify_set_exponent, + gfc_resolve_set_exponent, + x, BT_REAL, dr, 0, i, BT_INTEGER, di, 0); + + make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT); + + add_sym_1 ("shape", 0, 1, BT_INTEGER, di, + gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape, + src, BT_REAL, dr, 0); + + make_generic ("shape", GFC_ISYM_SHAPE); + + add_sym_2 ("sign", 1, 1, BT_REAL, dr, + gfc_check_sign, gfc_simplify_sign, gfc_resolve_sign, + a, BT_REAL, dr, 0, b, BT_REAL, dr, 0); + + add_sym_2 ("isign", 1, 1, BT_INTEGER, di, + NULL, gfc_simplify_sign, gfc_resolve_sign, + a, BT_INTEGER, di, 0, b, BT_INTEGER, di, 0); + + add_sym_2 ("dsign", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_sign, gfc_resolve_sign, + a, BT_REAL, dd, 0, b, BT_REAL, dd, 0); + + make_generic ("sign", GFC_ISYM_SIGN); + + add_sym_1 ("sin", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_sin, gfc_resolve_sin, x, BT_REAL, dr, 0); + + add_sym_1 ("dsin", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_sin, gfc_resolve_sin, x, BT_REAL, dd, 0); + + add_sym_1 ("csin", 1, 1, BT_COMPLEX, dz, + NULL, gfc_simplify_sin, gfc_resolve_sin, + x, BT_COMPLEX, dz, 0); + + add_sym_1 ("zsin", 1, 1, BT_COMPLEX, dd, NULL, gfc_simplify_sin, gfc_resolve_sin, x, BT_COMPLEX, dd, 0); /* Extension */ + + make_alias ("cdsin"); + + make_generic ("sin", GFC_ISYM_SIN); + + add_sym_1 ("sinh", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_sinh, gfc_resolve_sinh, + x, BT_REAL, dr, 0); + + add_sym_1 ("dsinh", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_sinh, gfc_resolve_sinh, + x, BT_REAL, dd, 0); + + make_generic ("sinh", GFC_ISYM_SINH); + + add_sym_2 ("size", 0, 1, BT_INTEGER, di, + gfc_check_size, gfc_simplify_size, NULL, + ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1); + + make_generic ("size", GFC_ISYM_SIZE); + + add_sym_1 ("spacing", 1, 1, BT_REAL, dr, + gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing, + x, BT_REAL, dr, 0); + + make_generic ("spacing", GFC_ISYM_SPACING); + + add_sym_3 ("spread", 0, 1, BT_REAL, dr, + gfc_check_spread, NULL, gfc_resolve_spread, + src, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 0, + n, BT_INTEGER, di, 0); + + make_generic ("spread", GFC_ISYM_SPREAD); + + add_sym_1 ("sqrt", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_sqrt, gfc_resolve_sqrt, + x, BT_REAL, dr, 0); + + add_sym_1 ("dsqrt", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_sqrt, gfc_resolve_sqrt, + x, BT_REAL, dd, 0); + + add_sym_1 ("csqrt", 1, 1, BT_COMPLEX, dz, + NULL, gfc_simplify_sqrt, gfc_resolve_sqrt, + x, BT_COMPLEX, dz, 0); + + add_sym_1 ("zsqrt", 1, 1, BT_COMPLEX, dd, NULL, gfc_simplify_sqrt, gfc_resolve_sqrt, x, BT_COMPLEX, dd, 0); /* Extension */ + + make_alias ("cdsqrt"); + + make_generic ("sqrt", GFC_ISYM_SQRT); + + add_sym_3 ("sum", 0, 1, BT_UNKNOWN, 0, + gfc_check_sum, NULL, gfc_resolve_sum, + ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1, + msk, BT_LOGICAL, dl, 1); + + make_generic ("sum", GFC_ISYM_SUM); + + add_sym_1 ("tan", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_tan, gfc_resolve_tan, x, BT_REAL, dr, 0); + + add_sym_1 ("dtan", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_tan, gfc_resolve_tan, x, BT_REAL, dd, 0); + + make_generic ("tan", GFC_ISYM_TAN); + + add_sym_1 ("tanh", 1, 1, BT_REAL, dr, + NULL, gfc_simplify_tanh, gfc_resolve_tanh, + x, BT_REAL, dr, 0); + + add_sym_1 ("dtanh", 1, 1, BT_REAL, dd, + NULL, gfc_simplify_tanh, gfc_resolve_tanh, + x, BT_REAL, dd, 0); + + make_generic ("tanh", GFC_ISYM_TANH); + + add_sym_1 ("tiny", 0, 1, BT_REAL, dr, + gfc_check_x, gfc_simplify_tiny, NULL, x, BT_REAL, dr, 0); + + make_generic ("tiny", GFC_ISYM_NONE); + + add_sym_3 ("transfer", 0, 1, BT_REAL, dr, + gfc_check_transfer, NULL, gfc_resolve_transfer, + src, BT_REAL, dr, 0, mo, BT_REAL, dr, 0, + sz, BT_INTEGER, di, 1); + + make_generic ("transfer", GFC_ISYM_TRANSFER); + + add_sym_1 ("transpose", 0, 1, BT_REAL, dr, + gfc_check_transpose, NULL, gfc_resolve_transpose, + m, BT_REAL, dr, 0); + + make_generic ("transpose", GFC_ISYM_TRANSPOSE); + + add_sym_1 ("trim", 0, 1, BT_CHARACTER, dc, + gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim, + stg, BT_CHARACTER, dc, 0); + + make_generic ("trim", GFC_ISYM_TRIM); + + add_sym_2 ("ubound", 0, 1, BT_INTEGER, di, + gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound, + ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1); + + make_generic ("ubound", GFC_ISYM_UBOUND); + + add_sym_3 ("unpack", 0, 1, BT_REAL, dr, + gfc_check_unpack, NULL, gfc_resolve_unpack, + v, BT_REAL, dr, 0, msk, BT_LOGICAL, dl, 0, + f, BT_REAL, dr, 0); + + make_generic ("unpack", GFC_ISYM_UNPACK); + + add_sym_3 ("verify", 1, 1, BT_INTEGER, di, + gfc_check_verify, gfc_simplify_verify, gfc_resolve_verify, + stg, BT_CHARACTER, dc, 0, set, BT_CHARACTER, dc, 0, + bck, BT_LOGICAL, dl, 1); + + make_generic ("verify", GFC_ISYM_VERIFY); +} + + + +/* Add intrinsic subroutines. */ + +static void +add_subroutines (void) +{ + /* Argument names as in the standard (to be used as argument keywords). */ + const char + *h = "harvest", *dt = "date", *vl = "values", *pt = "put", + *c = "count", *tm = "time", *tp = "topos", *gt = "get", + *t = "to", *zn = "zone", *fp = "frompos", *cm = "count_max", + *f = "from", *sz = "size", *ln = "len", *cr = "count_rate"; + + int di, dr, dc; + + di = gfc_default_integer_kind (); + dr = gfc_default_real_kind (); + dc = gfc_default_character_kind (); + + add_sym_0s ("abort", 1, NULL); + + add_sym_1s ("cpu_time", 0, 1, BT_UNKNOWN, 0, + gfc_check_cpu_time, NULL, gfc_resolve_cpu_time, + tm, BT_REAL, dr, 0); + + add_sym_4 ("date_and_time", 0, 1, BT_UNKNOWN, 0, + gfc_check_date_and_time, NULL, NULL, + dt, BT_CHARACTER, dc, 1, tm, BT_CHARACTER, dc, 1, + zn, BT_CHARACTER, dc, 1, vl, BT_INTEGER, di, 1); + + add_sym_2 ("getarg", 0, 1, BT_UNKNOWN, 0, + NULL, NULL, NULL, + c, BT_INTEGER, di, 0, vl, BT_CHARACTER, dc, 0); + /* Extension */ + + add_sym_5 ("mvbits", 1, 1, BT_UNKNOWN, 0, + gfc_check_mvbits, gfc_simplify_mvbits, NULL, + f, BT_INTEGER, di, 0, fp, BT_INTEGER, di, 0, + ln, BT_INTEGER, di, 0, t, BT_INTEGER, di, 0, + tp, BT_INTEGER, di, 0); + + add_sym_1s ("random_number", 0, 1, BT_UNKNOWN, 0, + gfc_check_random_number, NULL, gfc_resolve_random_number, + h, BT_REAL, dr, 0); + + add_sym_3 ("random_seed", 0, 1, BT_UNKNOWN, 0, + gfc_check_random_seed, NULL, NULL, + sz, BT_INTEGER, di, 1, pt, BT_INTEGER, di, 1, + gt, BT_INTEGER, di, 1); + + add_sym_3 ("system_clock", 0, 1, BT_UNKNOWN, 0, + NULL, NULL, NULL, + c, BT_INTEGER, di, 1, cr, BT_INTEGER, di, 1, + cm, BT_INTEGER, di, 1); +} + + +/* Add a function to the list of conversion symbols. */ + +static void +add_conv (bt from_type, int from_kind, bt to_type, int to_kind, + gfc_expr * (*simplify) (gfc_expr *, bt, int)) +{ + + gfc_typespec from, to; + gfc_intrinsic_sym *sym; + + if (sizing == SZ_CONVS) + { + nconv++; + return; + } + + gfc_clear_ts (&from); + from.type = from_type; + from.kind = from_kind; + + gfc_clear_ts (&to); + to.type = to_type; + to.kind = to_kind; + + sym = conversion + nconv; + + strcpy (sym->name, conv_name (&from, &to)); + strcpy (sym->lib_name, sym->name); + sym->simplify.cc = simplify; + sym->elemental = 1; + sym->ts = to; + sym->generic_id = GFC_ISYM_CONVERSION; + + nconv++; +} + + +/* Create gfc_intrinsic_sym nodes for all intrinsic conversion + functions by looping over the kind tables. */ + +static void +add_conversions (void) +{ + int i, j; + + /* Integer-Integer conversions. */ + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + for (j = 0; gfc_integer_kinds[j].kind != 0; j++) + { + if (i == j) + continue; + + add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, + BT_INTEGER, gfc_integer_kinds[j].kind, gfc_convert_constant); + } + + /* Integer-Real/Complex conversions. */ + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + for (j = 0; gfc_real_kinds[j].kind != 0; j++) + { + add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, + BT_REAL, gfc_real_kinds[j].kind, gfc_convert_constant); + + add_conv (BT_REAL, gfc_real_kinds[j].kind, + BT_INTEGER, gfc_integer_kinds[i].kind, gfc_convert_constant); + + add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, + BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant); + + add_conv (BT_COMPLEX, gfc_real_kinds[j].kind, + BT_INTEGER, gfc_integer_kinds[i].kind, gfc_convert_constant); + } + + /* Real/Complex - Real/Complex conversions. */ + for (i = 0; gfc_real_kinds[i].kind != 0; i++) + for (j = 0; gfc_real_kinds[j].kind != 0; j++) + { + if (i != j) + { + add_conv (BT_REAL, gfc_real_kinds[i].kind, + BT_REAL, gfc_real_kinds[j].kind, gfc_convert_constant); + + add_conv (BT_COMPLEX, gfc_real_kinds[i].kind, + BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant); + } + + add_conv (BT_REAL, gfc_real_kinds[i].kind, + BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant); + + add_conv (BT_COMPLEX, gfc_real_kinds[i].kind, + BT_REAL, gfc_real_kinds[j].kind, gfc_convert_constant); + } + + /* Logical/Logical kind conversion. */ + for (i = 0; gfc_logical_kinds[i].kind; i++) + for (j = 0; gfc_logical_kinds[j].kind; j++) + { + if (i == j) + continue; + + add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind, + BT_LOGICAL, gfc_logical_kinds[j].kind, gfc_convert_constant); + } +} + + +/* Initialize the table of intrinsics. */ +void +gfc_intrinsic_init_1 (void) +{ + int i; + + nargs = nfunc = nsub = nconv = 0; + + /* Create a namespace to hold the resolved intrinsic symbols. */ + gfc_intrinsic_namespace = gfc_get_namespace (NULL); + + sizing = SZ_FUNCS; + add_functions (); + sizing = SZ_SUBS; + add_subroutines (); + sizing = SZ_CONVS; + add_conversions (); + + functions = gfc_getmem (sizeof (gfc_intrinsic_sym) * (nfunc + nsub) + + sizeof (gfc_intrinsic_arg) * nargs); + + next_sym = functions; + subroutines = functions + nfunc; + + conversion = gfc_getmem (sizeof (gfc_intrinsic_sym) * nconv); + + next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1; + + sizing = SZ_NOTHING; + nconv = 0; + + add_functions (); + add_subroutines (); + add_conversions (); + + /* Set the pure flag. All intrinsic functions are pure, and + intrinsic subroutines are pure if they are elemental. */ + + for (i = 0; i < nfunc; i++) + functions[i].pure = 1; + + for (i = 0; i < nsub; i++) + subroutines[i].pure = subroutines[i].elemental; +} + + +void +gfc_intrinsic_done_1 (void) +{ + gfc_free (functions); + gfc_free (conversion); + gfc_free_namespace (gfc_intrinsic_namespace); +} + + +/******** Subroutines to check intrinsic interfaces ***********/ + +/* Given a formal argument list, remove any NULL arguments that may + have been left behind by a sort against some formal argument list. */ + +static void +remove_nullargs (gfc_actual_arglist ** ap) +{ + gfc_actual_arglist *head, *tail, *next; + + tail = NULL; + + for (head = *ap; head; head = next) + { + next = head->next; + + if (head->expr == NULL) + { + head->next = NULL; + gfc_free_actual_arglist (head); + } + else + { + if (tail == NULL) + *ap = head; + else + tail->next = head; + + tail = head; + tail->next = NULL; + } + } + + if (tail == NULL) + *ap = NULL; +} + + +/* Given an actual arglist and a formal arglist, sort the actual + arglist so that its arguments are in a one-to-one correspondence + with the format arglist. Arguments that are not present are given + a blank gfc_actual_arglist structure. If something is obviously + wrong (say, a missing required argument) we abort sorting and + return FAILURE. */ + +static try +sort_actual (const char *name, gfc_actual_arglist ** ap, + gfc_intrinsic_arg * formal, locus * where) +{ + + gfc_actual_arglist *actual, *a; + gfc_intrinsic_arg *f; + + remove_nullargs (ap); + actual = *ap; + + for (f = formal; f; f = f->next) + f->actual = NULL; + + f = formal; + a = actual; + + if (f == NULL && a == NULL) /* No arguments */ + return SUCCESS; + + for (;;) + { /* Put the nonkeyword arguments in a 1:1 correspondence */ + if (f == NULL) + break; + if (a == NULL) + goto optional; + + if (a->name[0] != '\0') + goto keywords; + + f->actual = a; + + f = f->next; + a = a->next; + } + + if (a == NULL) + goto do_sort; + + gfc_error ("Too many arguments in call to '%s' at %L", name, where); + return FAILURE; + +keywords: + /* Associate the remaining actual arguments, all of which have + to be keyword arguments. */ + for (; a; a = a->next) + { + for (f = formal; f; f = f->next) + if (strcmp (a->name, f->name) == 0) + break; + + if (f == NULL) + { + gfc_error ("Can't find keyword named '%s' in call to '%s' at %L", + a->name, name, where); + return FAILURE; + } + + if (f->actual != NULL) + { + gfc_error ("Argument '%s' is appears twice in call to '%s' at %L", + f->name, name, where); + return FAILURE; + } + + f->actual = a; + } + +optional: + /* At this point, all unmatched formal args must be optional. */ + for (f = formal; f; f = f->next) + { + if (f->actual == NULL && f->optional == 0) + { + gfc_error ("Missing actual argument '%s' in call to '%s' at %L", + f->name, name, where); + return FAILURE; + } + } + +do_sort: + /* Using the formal argument list, string the actual argument list + together in a way that corresponds with the formal list. */ + actual = NULL; + + for (f = formal; f; f = f->next) + { + a = (f->actual == NULL) ? gfc_get_actual_arglist () : f->actual; + + if (actual == NULL) + *ap = a; + else + actual->next = a; + + actual = a; + } + actual->next = NULL; /* End the sorted argument list. */ + + return SUCCESS; +} + + +/* Compare an actual argument list with an intrinsic's formal argument + list. The lists are checked for agreement of type. We don't check + for arrayness here. */ + +static try +check_arglist (gfc_actual_arglist ** ap, gfc_intrinsic_sym * sym, + int error_flag) +{ + gfc_actual_arglist *actual; + gfc_intrinsic_arg *formal; + int i; + + formal = sym->formal; + actual = *ap; + + i = 0; + for (; formal; formal = formal->next, actual = actual->next, i++) + { + if (actual->expr == NULL) + continue; + + if (!gfc_compare_types (&formal->ts, &actual->expr->ts)) + { + if (error_flag) + gfc_error + ("Type of argument '%s' in call to '%s' at %L should be " + "%s, not %s", gfc_current_intrinsic_arg[i], + gfc_current_intrinsic, &actual->expr->where, + gfc_typename (&formal->ts), gfc_typename (&actual->expr->ts)); + return FAILURE; + } + } + + return SUCCESS; +} + + +/* Given a pointer to an intrinsic symbol and an expression node that + represent the function call to that subroutine, figure out the type + of the result. This may involve calling a resolution subroutine. */ + +static void +resolve_intrinsic (gfc_intrinsic_sym * specific, gfc_expr * e) +{ + gfc_expr *a1, *a2, *a3, *a4, *a5; + gfc_actual_arglist *arg; + + if (specific->resolve.f1 == NULL) + { + if (e->value.function.name == NULL) + e->value.function.name = specific->lib_name; + + if (e->ts.type == BT_UNKNOWN) + e->ts = specific->ts; + return; + } + + arg = e->value.function.actual; + + /* At present only the iargc extension intrinsic takes no arguments, + and it doesn't need a resolution function, but this is here for + generality. */ + if (arg == NULL) + { + (*specific->resolve.f0) (e); + return; + } + + /* Special case hacks for MIN and MAX. */ + if (specific->resolve.f1m == gfc_resolve_max + || specific->resolve.f1m == gfc_resolve_min) + { + (*specific->resolve.f1m) (e, arg); + return; + } + + a1 = arg->expr; + arg = arg->next; + + if (arg == NULL) + { + (*specific->resolve.f1) (e, a1); + return; + } + + a2 = arg->expr; + arg = arg->next; + + if (arg == NULL) + { + (*specific->resolve.f2) (e, a1, a2); + return; + } + + a3 = arg->expr; + arg = arg->next; + + if (arg == NULL) + { + (*specific->resolve.f3) (e, a1, a2, a3); + return; + } + + a4 = arg->expr; + arg = arg->next; + + if (arg == NULL) + { + (*specific->resolve.f4) (e, a1, a2, a3, a4); + return; + } + + a5 = arg->expr; + arg = arg->next; + + if (arg == NULL) + { + (*specific->resolve.f5) (e, a1, a2, a3, a4, a5); + return; + } + + gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic"); +} + + +/* Given an intrinsic symbol node and an expression node, call the + simplification function (if there is one), perhaps replacing the + expression with something simpler. We return FAILURE on an error + of the simplification, SUCCESS if the simplification worked, even + if nothing has changed in the expression itself. */ + +static try +do_simplify (gfc_intrinsic_sym * specific, gfc_expr * e) +{ + gfc_expr *result, *a1, *a2, *a3, *a4, *a5; + gfc_actual_arglist *arg; + + /* Max and min require special handling due to the variable number + of args. */ + if (specific->simplify.f1 == gfc_simplify_min) + { + result = gfc_simplify_min (e); + goto finish; + } + + if (specific->simplify.f1 == gfc_simplify_max) + { + result = gfc_simplify_max (e); + goto finish; + } + + if (specific->simplify.f1 == NULL) + { + result = NULL; + goto finish; + } + + arg = e->value.function.actual; + + a1 = arg->expr; + arg = arg->next; + + if (specific->simplify.cc == gfc_convert_constant) + { + result = gfc_convert_constant (a1, specific->ts.type, specific->ts.kind); + goto finish; + } + + /* TODO: Warn if -pedantic and initialization expression and arg + types not integer or character */ + + if (arg == NULL) + result = (*specific->simplify.f1) (a1); + else + { + a2 = arg->expr; + arg = arg->next; + + if (arg == NULL) + result = (*specific->simplify.f2) (a1, a2); + else + { + a3 = arg->expr; + arg = arg->next; + + if (arg == NULL) + result = (*specific->simplify.f3) (a1, a2, a3); + else + { + a4 = arg->expr; + arg = arg->next; + + if (arg == NULL) + result = (*specific->simplify.f4) (a1, a2, a3, a4); + else + { + a5 = arg->expr; + arg = arg->next; + + if (arg == NULL) + result = (*specific->simplify.f5) (a1, a2, a3, a4, a5); + else + gfc_internal_error + ("do_simplify(): Too many args for intrinsic"); + } + } + } + } + +finish: + if (result == &gfc_bad_expr) + return FAILURE; + + if (result == NULL) + resolve_intrinsic (specific, e); /* Must call at run-time */ + else + { + result->where = e->where; + gfc_replace_expr (e, result); + } + + return SUCCESS; +} + + +/* Initialize the gfc_current_intrinsic_arg[] array for the benefit of + error messages. This subroutine returns FAILURE if a subroutine + has more than MAX_INTRINSIC_ARGS, in which case the actual argument + list cannot match any intrinsic. */ + +static void +init_arglist (gfc_intrinsic_sym * isym) +{ + gfc_intrinsic_arg *formal; + int i; + + gfc_current_intrinsic = isym->name; + + i = 0; + for (formal = isym->formal; formal; formal = formal->next) + { + if (i >= MAX_INTRINSIC_ARGS) + gfc_internal_error ("init_arglist(): too many arguments"); + gfc_current_intrinsic_arg[i++] = formal->name; + } +} + + +/* Given a pointer to an intrinsic symbol and an expression consisting + of a function call, see if the function call is consistent with the + intrinsic's formal argument list. Return SUCCESS if the expression + and intrinsic match, FAILURE otherwise. */ + +static try +check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag) +{ + gfc_actual_arglist *arg, **ap; + int r; + try t; + + ap = &expr->value.function.actual; + + init_arglist (specific); + + /* Don't attempt to sort the argument list for min or max. */ + if (specific->check.f1m == gfc_check_min_max + || specific->check.f1m == gfc_check_min_max_integer + || specific->check.f1m == gfc_check_min_max_real + || specific->check.f1m == gfc_check_min_max_double) + return (*specific->check.f1m) (*ap); + + if (sort_actual (specific->name, ap, specific->formal, + &expr->where) == FAILURE) + return FAILURE; + + if (specific->check.f1 == NULL) + { + t = check_arglist (ap, specific, error_flag); + if (t == SUCCESS) + expr->ts = specific->ts; + } + else + t = do_check (specific, *ap); + + /* Check ranks for elemental intrinsics. */ + if (t == SUCCESS && specific->elemental) + { + r = 0; + for (arg = expr->value.function.actual; arg; arg = arg->next) + { + if (arg->expr == NULL || arg->expr->rank == 0) + continue; + if (r == 0) + { + r = arg->expr->rank; + continue; + } + + if (arg->expr->rank != r) + { + gfc_error + ("Ranks of arguments to elemental intrinsic '%s' differ " + "at %L", specific->name, &arg->expr->where); + return FAILURE; + } + } + } + + if (t == FAILURE) + remove_nullargs (ap); + + return t; +} + + +/* See if an intrinsic is one of the intrinsics we evaluate + as an extension. */ + +static int +gfc_init_expr_extensions (gfc_intrinsic_sym *isym) +{ + /* FIXME: This should be moved into the intrinsic definitions. */ + static const char * const init_expr_extensions[] = { + "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent", + "precision", "present", "radix", "range", "selected_real_kind", + "tiny", NULL + }; + + int i; + + for (i = 0; init_expr_extensions[i]; i++) + if (strcmp (init_expr_extensions[i], isym->name) == 0) + return 0; + + return 1; +} + + +/* See if a function call corresponds to an intrinsic function call. + We return: + + MATCH_YES if the call corresponds to an intrinsic, simplification + is done if possible. + + MATCH_NO if the call does not correspond to an intrinsic + + MATCH_ERROR if the call corresponds to an intrinsic but there was an + error during the simplification process. + + The error_flag parameter enables an error reporting. */ + +match +gfc_intrinsic_func_interface (gfc_expr * expr, int error_flag) +{ + gfc_intrinsic_sym *isym, *specific; + gfc_actual_arglist *actual; + const char *name; + int flag; + + if (expr->value.function.isym != NULL) + return (do_simplify (expr->value.function.isym, expr) == FAILURE) + ? MATCH_ERROR : MATCH_YES; + + gfc_suppress_error = !error_flag; + flag = 0; + + for (actual = expr->value.function.actual; actual; actual = actual->next) + if (actual->expr != NULL) + flag |= (actual->expr->ts.type != BT_INTEGER + && actual->expr->ts.type != BT_CHARACTER); + + name = expr->symtree->n.sym->name; + + isym = specific = gfc_find_function (name); + if (isym == NULL) + { + gfc_suppress_error = 0; + return MATCH_NO; + } + + gfc_current_intrinsic_where = &expr->where; + + /* Bypass the generic list for min and max. */ + if (isym->check.f1m == gfc_check_min_max) + { + init_arglist (isym); + + if (gfc_check_min_max (expr->value.function.actual) == SUCCESS) + goto got_specific; + + gfc_suppress_error = 0; + return MATCH_NO; + } + + /* If the function is generic, check all of its specific + incarnations. If the generic name is also a specific, we check + that name last, so that any error message will correspond to the + specific. */ + gfc_suppress_error = 1; + + if (isym->generic) + { + for (specific = isym->specific_head; specific; + specific = specific->next) + { + if (specific == isym) + continue; + if (check_specific (specific, expr, 0) == SUCCESS) + goto got_specific; + } + } + + gfc_suppress_error = !error_flag; + + if (check_specific (isym, expr, error_flag) == FAILURE) + { + gfc_suppress_error = 0; + return MATCH_NO; + } + + specific = isym; + +got_specific: + expr->value.function.isym = specific; + gfc_intrinsic_symbol (expr->symtree->n.sym); + + if (do_simplify (specific, expr) == FAILURE) + { + gfc_suppress_error = 0; + return MATCH_ERROR; + } + + /* TODO: We should probably only allow elemental functions here. */ + flag |= (expr->ts.type != BT_INTEGER && expr->ts.type != BT_CHARACTER); + + gfc_suppress_error = 0; + if (pedantic && gfc_init_expr + && flag && gfc_init_expr_extensions (specific)) + { + if (gfc_notify_std (GFC_STD_GNU, "Extension: Evaluation of " + "nonstandard initialization expression at %L", &expr->where) + == FAILURE) + { + return MATCH_ERROR; + } + } + + return MATCH_YES; +} + + +/* See if a CALL statement corresponds to an intrinsic subroutine. + Returns MATCH_YES if the subroutine corresponds to an intrinsic, + MATCH_NO if not, and MATCH_ERROR if there was an error (but did + correspond). */ + +match +gfc_intrinsic_sub_interface (gfc_code * c, int error_flag) +{ + gfc_intrinsic_sym *isym; + const char *name; + + name = c->symtree->n.sym->name; + + isym = find_subroutine (name); + if (isym == NULL) + return MATCH_NO; + + gfc_suppress_error = !error_flag; + + init_arglist (isym); + + if (sort_actual (name, &c->ext.actual, isym->formal, &c->loc) == FAILURE) + goto fail; + + if (isym->check.f1 != NULL) + { + if (do_check (isym, c->ext.actual) == FAILURE) + goto fail; + } + else + { + if (check_arglist (&c->ext.actual, isym, 1) == FAILURE) + goto fail; + } + + /* The subroutine corresponds to an intrinsic. Allow errors to be + seen at this point. */ + gfc_suppress_error = 0; + + if (isym->resolve.s1 != NULL) + isym->resolve.s1 (c); + else + c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name); + + if (gfc_pure (NULL) && !isym->elemental) + { + gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name, + &c->loc); + return MATCH_ERROR; + } + + return MATCH_YES; + +fail: + gfc_suppress_error = 0; + return MATCH_NO; +} + + +/* Call gfc_convert_type() with warning enabled. */ + +try +gfc_convert_type (gfc_expr * expr, gfc_typespec * ts, int eflag) +{ + return gfc_convert_type_warn (expr, ts, eflag, 1); +} + + +/* Try to convert an expression (in place) from one type to another. + 'eflag' controls the behavior on error. + + The possible values are: + + 1 Generate a gfc_error() + 2 Generate a gfc_internal_error(). + + 'wflag' controls the warning related to conversion. */ + +try +gfc_convert_type_warn (gfc_expr * expr, gfc_typespec * ts, int eflag, + int wflag) +{ + gfc_intrinsic_sym *sym; + gfc_typespec from_ts; + locus old_where; + gfc_expr *new; + int rank; + + from_ts = expr->ts; /* expr->ts gets clobbered */ + + if (ts->type == BT_UNKNOWN) + goto bad; + + /* NULL and zero size arrays get their type here. */ + if (expr->expr_type == EXPR_NULL + || (expr->expr_type == EXPR_ARRAY + && expr->value.constructor == NULL)) + { + /* Sometimes the RHS acquire the type. */ + expr->ts = *ts; + return SUCCESS; + } + + if (expr->ts.type == BT_UNKNOWN) + goto bad; + + if (expr->ts.type == BT_DERIVED + && ts->type == BT_DERIVED + && gfc_compare_types (&expr->ts, ts)) + return SUCCESS; + + sym = find_conv (&expr->ts, ts); + if (sym == NULL) + goto bad; + + /* At this point, a conversion is necessary. A warning may be needed. */ + if (wflag && gfc_option.warn_conversion) + gfc_warning_now ("Conversion from %s to %s at %L", + gfc_typename (&from_ts), gfc_typename (ts), &expr->where); + + /* Insert a pre-resolved function call to the right function. */ + old_where = expr->where; + rank = expr->rank; + new = gfc_get_expr (); + *new = *expr; + + new = gfc_build_conversion (new); + new->value.function.name = sym->lib_name; + new->value.function.isym = sym; + new->where = old_where; + new->rank = rank; + + *expr = *new; + + gfc_free (new); + expr->ts = *ts; + + if (gfc_is_constant_expr (expr->value.function.actual->expr) + && do_simplify (sym, expr) == FAILURE) + { + + if (eflag == 2) + goto bad; + return FAILURE; /* Error already generated in do_simplify() */ + } + + return SUCCESS; + +bad: + if (eflag == 1) + { + gfc_error ("Can't convert %s to %s at %L", + gfc_typename (&from_ts), gfc_typename (ts), &expr->where); + return FAILURE; + } + + gfc_internal_error ("Can't convert %s to %s at %L", + gfc_typename (&from_ts), gfc_typename (ts), + &expr->where); + /* Not reached */ +} diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h new file mode 100644 index 00000000000..723d1051db1 --- /dev/null +++ b/gcc/fortran/intrinsic.h @@ -0,0 +1,314 @@ +/* Header file for intrinsics check, resolve and simplify function + prototypes. + Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. + Contributed by Andy Vaught & Katherine Holcomb + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Expression returned when simplification fails. */ + +extern gfc_expr gfc_bad_expr; + + +/* Check functions. */ +try gfc_check_a_ikind (gfc_expr *, gfc_expr *); +try gfc_check_a_xkind (gfc_expr *, gfc_expr *); +try gfc_check_a_p (gfc_expr *, gfc_expr *); + +try gfc_check_abs (gfc_expr *); +try gfc_check_all_any (gfc_expr *, gfc_expr *); +try gfc_check_allocated (gfc_expr *); +try gfc_check_associated (gfc_expr *, gfc_expr *); +try gfc_check_btest (gfc_expr *, gfc_expr *); +try gfc_check_char (gfc_expr *, gfc_expr *); +try gfc_check_cmplx (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_count (gfc_expr *, gfc_expr *); +try gfc_check_cshift (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_dcmplx (gfc_expr *, gfc_expr *); +try gfc_check_dble (gfc_expr *); +try gfc_check_digits (gfc_expr *); +try gfc_check_dot_product (gfc_expr *, gfc_expr *); +try gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_huge (gfc_expr *); +try gfc_check_i (gfc_expr *); +try gfc_check_iand (gfc_expr *, gfc_expr *); +try gfc_check_ibclr (gfc_expr *, gfc_expr *); +try gfc_check_ibits (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_ibset (gfc_expr *, gfc_expr *); +try gfc_check_idnint (gfc_expr *); +try gfc_check_ieor (gfc_expr *, gfc_expr *); +try gfc_check_index (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_int (gfc_expr *, gfc_expr *); +try gfc_check_ior (gfc_expr *, gfc_expr *); +try gfc_check_ishft (gfc_expr *, gfc_expr *); +try gfc_check_ishftc (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_kind (gfc_expr *); +try gfc_check_lbound (gfc_expr *, gfc_expr *); +try gfc_check_logical (gfc_expr *, gfc_expr *); +try gfc_check_min_max (gfc_actual_arglist *); +try gfc_check_min_max_integer (gfc_actual_arglist *); +try gfc_check_min_max_real (gfc_actual_arglist *); +try gfc_check_min_max_double (gfc_actual_arglist *); +try gfc_check_matmul (gfc_expr *, gfc_expr *); +try gfc_check_merge (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_minloc_maxloc (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_minval_maxval (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_nearest (gfc_expr *, gfc_expr *); +try gfc_check_null (gfc_expr *); +try gfc_check_pack (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_precision (gfc_expr *); +try gfc_check_present (gfc_expr *); +try gfc_check_product (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_radix (gfc_expr *); +try gfc_check_range (gfc_expr *); +try gfc_check_real (gfc_expr *, gfc_expr *); +try gfc_check_repeat (gfc_expr *, gfc_expr *); +try gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_scale (gfc_expr *, gfc_expr *); +try gfc_check_scan (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_selected_real_kind (gfc_expr *, gfc_expr *); +try gfc_check_set_exponent (gfc_expr *, gfc_expr *); +try gfc_check_shape (gfc_expr *); +try gfc_check_size (gfc_expr *, gfc_expr *); +try gfc_check_sign (gfc_expr *, gfc_expr *); +try gfc_check_spread (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_sum (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_transpose (gfc_expr *); +try gfc_check_trim (gfc_expr *); +try gfc_check_ubound (gfc_expr *, gfc_expr *); +try gfc_check_unpack (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_verify (gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_x (gfc_expr *); + + +/* Intrinsic subroutines. */ +try gfc_check_cpu_time (gfc_expr *); +try gfc_check_date_and_time (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *); +try gfc_check_random_number (gfc_expr *); +try gfc_check_random_seed (gfc_expr *, gfc_expr *, gfc_expr *); + + +/* Simplification functions. */ +gfc_expr *gfc_simplify_abs (gfc_expr *); +gfc_expr *gfc_simplify_achar (gfc_expr *); +gfc_expr *gfc_simplify_acos (gfc_expr *); +gfc_expr *gfc_simplify_adjustl (gfc_expr *); +gfc_expr *gfc_simplify_adjustr (gfc_expr *); +gfc_expr *gfc_simplify_aimag (gfc_expr *); +gfc_expr *gfc_simplify_aint (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_dint (gfc_expr *); +gfc_expr *gfc_simplify_anint (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_dnint (gfc_expr *); +gfc_expr *gfc_simplify_asin (gfc_expr *); +gfc_expr *gfc_simplify_atan (gfc_expr *); +gfc_expr *gfc_simplify_atan2 (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_bit_size (gfc_expr *); +gfc_expr *gfc_simplify_btest (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_ceiling (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_char (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_cmplx (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_conjg (gfc_expr *); +gfc_expr *gfc_simplify_cos (gfc_expr *); +gfc_expr *gfc_simplify_cosh (gfc_expr *); +gfc_expr *gfc_simplify_dcmplx (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_dble (gfc_expr *); +gfc_expr *gfc_simplify_digits (gfc_expr *); +gfc_expr *gfc_simplify_dim (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_dprod (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_epsilon (gfc_expr *); +gfc_expr *gfc_simplify_exp (gfc_expr *); +gfc_expr *gfc_simplify_exponent (gfc_expr *); +gfc_expr *gfc_simplify_float (gfc_expr *); +gfc_expr *gfc_simplify_floor (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_fraction (gfc_expr *); +gfc_expr *gfc_simplify_huge (gfc_expr *); +gfc_expr *gfc_simplify_iachar (gfc_expr *); +gfc_expr *gfc_simplify_iand (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_ibclr (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_ibits (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_ibset (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_ichar (gfc_expr *); +gfc_expr *gfc_simplify_ieor (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_index (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_int (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_ifix (gfc_expr *); +gfc_expr *gfc_simplify_idint (gfc_expr *); +gfc_expr *gfc_simplify_ior (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_ishft (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_ishftc (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_kind (gfc_expr *); +gfc_expr *gfc_simplify_lbound (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_len (gfc_expr *); +gfc_expr *gfc_simplify_len_trim (gfc_expr *); +gfc_expr *gfc_simplify_lge (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_lgt (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_lle (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_llt (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_log (gfc_expr *); +gfc_expr *gfc_simplify_log10 (gfc_expr *); +gfc_expr *gfc_simplify_logical (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_min (gfc_expr *); +gfc_expr *gfc_simplify_max (gfc_expr *); +gfc_expr *gfc_simplify_maxexponent (gfc_expr *); +gfc_expr *gfc_simplify_minexponent (gfc_expr *); +gfc_expr *gfc_simplify_mod (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_modulo (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *); +gfc_expr *gfc_simplify_nearest (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_nint (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_null (gfc_expr *); +gfc_expr *gfc_simplify_idnint (gfc_expr *); +gfc_expr *gfc_simplify_not (gfc_expr *); +gfc_expr *gfc_simplify_precision (gfc_expr *); +gfc_expr *gfc_simplify_radix (gfc_expr *); +gfc_expr *gfc_simplify_range (gfc_expr *); +gfc_expr *gfc_simplify_real (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_repeat (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_reshape (gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *); +gfc_expr *gfc_simplify_rrspacing (gfc_expr *); +gfc_expr *gfc_simplify_scale (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_scan (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_selected_int_kind (gfc_expr *); +gfc_expr *gfc_simplify_selected_real_kind (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_set_exponent (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_sign (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_shape (gfc_expr *); +gfc_expr *gfc_simplify_sin (gfc_expr *); +gfc_expr *gfc_simplify_sinh (gfc_expr *); +gfc_expr *gfc_simplify_size (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_sngl (gfc_expr *); +gfc_expr *gfc_simplify_spacing (gfc_expr *); +gfc_expr *gfc_simplify_sqrt (gfc_expr *); +gfc_expr *gfc_simplify_tan (gfc_expr *); +gfc_expr *gfc_simplify_tanh (gfc_expr *); +gfc_expr *gfc_simplify_tiny (gfc_expr *); +gfc_expr *gfc_simplify_trim (gfc_expr *); +gfc_expr *gfc_simplify_ubound (gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_verify (gfc_expr *, gfc_expr *, gfc_expr *); + +/* Constant conversion simplification. */ +gfc_expr *gfc_convert_constant (gfc_expr *, bt, int); + + +/* Resolution functions. */ +void gfc_resolve_abs (gfc_expr *, gfc_expr *); +void gfc_resolve_acos (gfc_expr *, gfc_expr *); +void gfc_resolve_aimag (gfc_expr *, gfc_expr *); +void gfc_resolve_aint (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_dint (gfc_expr *, gfc_expr *); +void gfc_resolve_all (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_anint (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_dnint (gfc_expr *, gfc_expr *); +void gfc_resolve_any (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_asin (gfc_expr *, gfc_expr *); +void gfc_resolve_atan (gfc_expr *, gfc_expr *); +void gfc_resolve_atan2 (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_btest (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_ceiling (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_char (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_cmplx (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_dcmplx (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_conjg (gfc_expr *, gfc_expr *); +void gfc_resolve_cos (gfc_expr *, gfc_expr *); +void gfc_resolve_cosh (gfc_expr *, gfc_expr *); +void gfc_resolve_count (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_cshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_dble (gfc_expr *, gfc_expr *); +void gfc_resolve_dim (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_dot_product (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_dprod (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *); +void gfc_resolve_exp (gfc_expr *, gfc_expr *); +void gfc_resolve_exponent (gfc_expr *, gfc_expr *); +void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_fraction (gfc_expr *, gfc_expr *); +void gfc_resolve_iand (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_ibclr (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_ieor (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_ichar (gfc_expr *, gfc_expr *); +void gfc_resolve_idnint (gfc_expr *, gfc_expr *); +void gfc_resolve_int (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_ior (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_ishft (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_ishftc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_lbound (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_len (gfc_expr *, gfc_expr *); +void gfc_resolve_len_trim (gfc_expr *, gfc_expr *); +void gfc_resolve_log (gfc_expr *, gfc_expr *); +void gfc_resolve_log10 (gfc_expr *, gfc_expr *); +void gfc_resolve_logical (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_matmul (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_max (gfc_expr *, gfc_actual_arglist *); +void gfc_resolve_maxloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_maxval (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_merge (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_min (gfc_expr *, gfc_actual_arglist *); +void gfc_resolve_minloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_minval (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_mod (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_modulo (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_nint (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_not (gfc_expr *, gfc_expr *); +void gfc_resolve_pack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_product (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_real (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_repeat (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, + gfc_expr *); +void gfc_resolve_rrspacing (gfc_expr *, gfc_expr *); +void gfc_resolve_scale (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_set_exponent (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_shape (gfc_expr *, gfc_expr *); +void gfc_resolve_sign (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_sin (gfc_expr *, gfc_expr *); +void gfc_resolve_sinh (gfc_expr *, gfc_expr *); +void gfc_resolve_spacing (gfc_expr *, gfc_expr *); +void gfc_resolve_spread (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_sqrt (gfc_expr *, gfc_expr *); +void gfc_resolve_sum (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_tan (gfc_expr *, gfc_expr *); +void gfc_resolve_tanh (gfc_expr *, gfc_expr *); +void gfc_resolve_transfer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_transpose (gfc_expr *, gfc_expr *); +void gfc_resolve_trim (gfc_expr *, gfc_expr *); +void gfc_resolve_ubound (gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_unpack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); + + +/* Intrinsic subroutine resolution. */ +void gfc_resolve_cpu_time (gfc_code *); +void gfc_resolve_random_number (gfc_code *); + + +/* The mvbits() subroutine requires the most arguments: five. */ + +#define MAX_INTRINSIC_ARGS 5 + +extern char *gfc_current_intrinsic, + *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; +extern locus *gfc_current_intrinsic_where; diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi new file mode 100644 index 00000000000..88330e1bda0 --- /dev/null +++ b/gcc/fortran/invoke.texi @@ -0,0 +1,656 @@ +@c Copyright (C) 2004 +@c Free Software Foundation, Inc. +@c This is part of the GFORTRAN manual. +@c For copying conditions, see the file gfortran.texi. + +@ignore +@c man begin COPYRIGHT +Copyright @copyright{} 2004 +Free Software Foundation, Inc. + +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.2 or +any later version published by the Free Software Foundation; with the +Invariant Sections being ``GNU General Public License'' and ``Funding +Free Software'', the Front-Cover texts being (a) (see below), and with +the Back-Cover Texts being (b) (see below). A copy of the license is +included in the gfdl(7) man page. + +(a) The FSF's Front-Cover Text is: + + A GNU Manual + +(b) The FSF's Back-Cover Text is: + + You have freedom to copy and modify this GNU Manual, like GNU + software. Copies published by the Free Software Foundation raise + funds for GNU development. +@c man end +@c Set file name and title for the man page. +@setfilename gfortran +@settitle GNU Fortran 95 compiler. +@c man begin SYNOPSIS +gfortran [@option{-c}|@option{-S}|@option{-E}] + [@option{-g}] [@option{-pg}] [@option{-O}@var{level}] + [@option{-W}@var{warn}@dots{}] [@option{-pedantic}] + [@option{-I}@var{dir}@dots{}] [@option{-L}@var{dir}@dots{}] + [@option{-D}@var{macro}[=@var{defn}]@dots{}] [@option{-U}@var{macro}] + [@option{-f}@var{option}@dots{}] + [@option{-m}@var{machine-option}@dots{}] + [@option{-o} @var{outfile}] @var{infile}@dots{} + +Only the most useful options are listed here; see below for the +remainder. +@c man end +@c man begin SEEALSO +gpl(7), gfdl(7), fsf-funding(7), +cpp(1), gcov(1), gcc(1), as(1), ld(1), gdb(1), adb(1), dbx(1), sdb(1) +and the Info entries for @file{gcc}, @file{cpp}, @file{gfortran}, @file{as}, +@file{ld}, @file{binutils} and @file{gdb}. +@c man end +@c man begin BUGS +For instructions on reporting bugs, see +@w{@uref{http://gcc.gnu.org/bugs.html}}. +@c man end +@c man begin AUTHOR +See the Info entry for @command{gfortran} for contributors to GCC and +GFORTRAN@. +@c man end +@end ignore + +@node Invoking GFORTRAN +@chapter GNU Fortran 95 Command Options +@cindex GNU Fortran 95 command options +@cindex command options +@cindex options, GNU Fortran 95 command + +@c man begin DESCRIPTION + +The @command{gfortran} command supports all the options supported by the +@command{gcc} command. Only options specific to gfortran are documented here. + +@xref{Invoking GCC,,GCC Command Options,gcc,Using the GNU Compiler +Collection (GCC)}, for information +on the non-Fortran-specific aspects of the @command{gcc} command (and, +therefore, the @command{gfortran} command). + +@cindex options, negative forms +@cindex negative forms of options +All @command{gcc} and @command{gfortran} options +are accepted both by @command{gfortran} and by @command{gcc} +(as well as any other drivers built at the same time, +such as @command{g++}), +since adding @command{gfortran} to the @command{gcc} distribution +enables acceptance of @command{gfortran} options +by all of the relevant drivers. + +In some cases, options have positive and negative forms; +the negative form of @option{-ffoo} would be @option{-fno-foo}. +This manual documents only one of these two forms, whichever +one is not the default. +@c man end + +@menu +* Option Summary:: Brief list of all @command{gfortran} options, + without explanations. +* Fortran Dialect Options:: Controlling the variant of Fortran language + compiled. +* Warning Options:: How picky should the compiler be? +* Debugging Options:: Symbol tables, measurements, and debugging dumps. +* Directory Options:: Where to find module files +* Code Gen Options:: Specifying conventions for function calls, data layout + and register usage. +* Environment Variables:: Env vars that affect GNU Fortran. +@end menu + +@node Option Summary +@section Option Summary + +@c man begin OPTIONS + +Here is a summary of all the options specific to GNU Fortran, grouped +by type. Explanations are in the following sections. + +@table @emph +@item Fortran Language Options +@xref{Fortran Dialect Options,,Options Controlling Fortran Dialect}. +@gccoptlist{ +-ffree-form -fno-fixed-form @gol +-fdollar-ok -fimplicit-none -fmax-identifier-length @gol +-std=@var{std} +-ffixed-line-length-@var{n} -ffixed-line-length-none @gol +-i8 -r8 -d8} + +@item Warning Options +@xref{Warning Options,,Options to Request or Suppress Warnings}. +@gccoptlist{ +-fsyntax-only -pedantic -pedantic-errors @gol +-w -Wall -Waliasing -Wconversion @gol +-Wimplicit-interface -Wsurprising -Wunused-labels @gol +-Wline-truncation @gol +-Werror -W} + +@item Debugging Options +@xref{Debugging Options,,Options for Debugging Your Program or GCC}. +@gccoptlist{ +-fdump-parse-tree} + +@item Directory Options +@xref{Directory Options,,Options for Directory Search}. +@gccoptlist{ +-I@var{dir} -M@var{dir}} + +@item Code Generation Options +@xref{Code Gen Options,,Options for Code Generation Conventions}. +@gccoptlist{ +-fno-underscoring -fno-second-underscore @gol +-fbounds-check -fmax-stack-var-size=@var{n} @gol +-fpackderived -frepack-arrays} +@end table + +@c man end + +@menu +* Fortran Dialect Options:: Controlling the variant of Fortran language + compiled. +* Warning Options:: How picky should the compiler be? +* Debugging Options:: Symbol tables, measurements, and debugging dumps. +* Directory Options:: Where to find module files +* Code Gen Options:: Specifying conventions for function calls, data layout + and register usage. +@end menu + +@node Fortran Dialect Options +@section Options Controlling Fortran Dialect +@cindex dialect options +@cindex language, dialect options +@cindex options, dialect + +The following options control the dialect of Fortran +that the compiler accepts: + +@table @gcctabopt +@cindex -ffree-form option +@cindex options, -ffree-form +@cindex -fno-fixed-form option +@cindex options, -fno-fixed-form +@cindex source file format +@cindex free form +@cindex fixed form +@cindex Source Form +@cindex Fortran 90, features +@item -ffree-form +@item -ffixed-form +Specify the layout used by the the source file. The tree form layout +was introduced in Fortran 90. Fixed form was traditionally used in +older Fortran programs. + +@cindex -fdollar-ok option +@cindex options, -fdollar-ok +@item -fdollar-ok +@cindex dollar sign +@cindex symbol names +@cindex character set +Allow @samp{$} as a valid character in a symbol name. + +@cindex -ffixed-line-length-@var{n} option +@cindex options, -ffixed-line-length-@var{n} +@item -ffixed-line-length-@var{n} +@cindex source file format +@cindex lines, length +@cindex length of source lines +@cindex fixed form +@cindex limits, lengths of source lines +Set column after which characters are ignored in typical fixed-form +lines in the source file, and through which spaces are assumed (as +if padded to that length) after the ends of short fixed-form lines. + +@cindex card image +@cindex extended-source option +Popular values for @var{n} include 72 (the +standard and the default), 80 (card image), and 132 (corresponds +to ``extended-source'' options in some popular compilers). +@var{n} may be @samp{none}, meaning that the entire line is meaningful +and that continued character constants never have implicit spaces appended +to them to fill out the line. +@option{-ffixed-line-length-0} means the same thing as +@option{-ffixed-line-length-none}. + +@cindex -fmax-identifier-length=@var{n} option +@cindex option -fmax-identifier-length=@var{n} +@item -fmax-identifier-length=@var{n} +Specify the maximum allowed identifier length. Typical values are +31 (Fortran 95) and 63 (Fortran 200x). + +@cindex -fimpicit-none option +@cindex options, -fimplicit-none +@item -fimplicit-none +Specify that no implicit typing is allowed, unless overridden by explicit +@samp{IMPLICIT} statements. This is the equivalent of adding +@samp{implicit none} to the start of every procedure. + +@cindex -std=@var{std} option +@cindex option, -std=@var{std} +@item -std=@var{std} +Conform to the specified standard. Allowed values for @var{std} are +@samp{gnu}, @samp{f95} and @samp{f90}. + +@cindex option, -i8 +@cindex -i8, option +@cindex option, -r8 +@cindex -r8, option +@cindex option, -d8 +@cindex -d8, option +@item -i8 +@item -r8 +@item -d8 +The @option{-i8} and @option{-j8} options set the default INTEGER and REAL +kinds to KIND=8. The @option{-d8} option is equivalent to specifying +both @option{-i8} and @option{-r8}. + +@end table + +@node Warning Options +@section Options to Request or Suppress Warnings +@cindex options, warnings +@cindex warnings, suppressing +@cindex messages, warning +@cindex suppressing warnings + +Warnings are diagnostic messages that report constructions which +are not inherently erroneous but which are risky or suggest there +might have been an error. + +You can request many specific warnings with options beginning @option{-W}, +for example @option{-Wimplicit} to request warnings on implicit +declarations. Each of these specific warning options also has a +negative form beginning @option{-Wno-} to turn off warnings; +for example, @option{-Wno-implicit}. This manual lists only one of the +two forms, whichever is not the default. + +These options control the amount and kinds of warnings produced by GNU +Fortran: + +@table @gcctabopt +@cindex syntax checking +@cindex -fsyntax-only option +@cindex options, -fsyntax-only +@item -fsyntax-only +Check the code for syntax errors, but don't do anything beyond that. + +@cindex -pedantic option +@cindex options, -pedantic +@item -pedantic +Issue warnings for uses of extensions to FORTRAN 95. +@option{-pedantic} also applies to C-language constructs where they +occur in GNU Fortran source files, such as use of @samp{\e} in a +character constant within a directive like @samp{#include}. + +Valid FORTRAN 95 programs should compile properly with or without +this option. +However, without this option, certain GNU extensions and traditional +Fortran features are supported as well. +With this option, many of them are rejected. + +Some users try to use @option{-pedantic} to check programs for conformance. +They soon find that it does not do quite what they want---it finds some +nonstandard practices, but not all. +However, improvements to @command{gfortran} in this area are welcome. + +This should be used in conjunction with -std=@var{std}. + +@cindex -pedantic-errors option +@cindex options, -pedantic-errors +@item -pedantic-errors +Like @option{-pedantic}, except that errors are produced rather than +warnings. + +@cindex -w option +@cindex options, -w +@item -w +Inhibit all warning messages. + + +@cindex -Wall option +@cindex options, -Wall +@item -Wall +@cindex all warnings +@cindex warnings, all +Enables commonly used warning options that which pertain to usage that +we recommend avoiding and that we believe is easy to avoid. +This currenly includes @option{-Wunused-labels}, @option{-Waliasing}, +@option{-Wsurprising} and @option{-Wline-truncation}. + + +@cindex -Waliasing option +@cindex options, -Waliasing +@item -Waliasing +@cindex aliasing +Warn about possible aliasing of dummy arguments. The following example +witll trigger teh warhing as it would be illegal to @code{bar} to +modify either parameter. +@smallexample + INTEGER A + CALL BAR(A,A) +@end smallexample + + +@cindex -Wconversion option +@cindex options, -Wconversion +@item -Wconversion +@cindex conversion +Warn about implicit conversions between different types. + + +@cindex -Wimplicit-interface option +@cindex options, -Wimplicit-interface +@item -Wimplicit-interface +Warn about when procedure are called without an explicit interface. +Note this only checks that an explicit interface is present. It does not +check that the declared interfaces are consistent across program units. + + +@cindex -Wsurprising +@cindex options, -Wsurprising +@item -Wsurprising +@cindex Suspicious +Produce a warning when ``suspicous'' code constructs are encountered. +While techically legal these usually indicate that an error has been made. + +This currently produces a warning under the following circumstances: + +@itemize @bullet +@item +An INTEGER SELECT construct has a CASE the can never be matched as it's +lower value that is greater than its upper value. + +@item +A LOGICAL SELECT construct has three CASE statements. +@end itemize + +@cindex -Wunused-labels option +@cindex options, -Wunused-labels +@item -Wunused-labels +@cindex unused labels +@cindex labels, unused +Warn whenever a label is defined but never referenced. + + +@cindex -Werror +@cindex options, -Werror +@item -Werror +Turns all warnings into errors. + + +@cindex -W option +@cindex options, -W +@item -W +@cindex extra warnings +@cindex warnings, extra +Turns on ``extra warnings'' and, if optimization is specified +via @option{-O}, the @option{-Wuninitialized} option. +(This might change in future versions of @command{gfortran} +@end table + +@xref{Warning Options,,Options to Request or Suppress Warnings, +gcc,Using the GNU Compiler Collection (GCC)}, for information on more +options offered by the GBE shared by @command{gfortran}, @command{gcc} and +other GNU compilers. + +Some of these have no effect when compiling programs written in Fortran. + +@node Debugging Options +@section Options for Debugging Your Program or GNU Fortran +@cindex options, debugging +@cindex debugging information options + +GNU Fortran has various special options that are used for debugging +either your program or @command{gfortran} + +@table @gcctabopt +@cindex -fdump-parse-tree option +@cindex option, -fdump-parse-tree +@item -fdump-parse-tree +Output the internal parse tree before starting code generation. Only +really usedful for debugging gfortran itself. +@end table + +@xref{Debugging Options,,Options for Debugging Your Program or GCC, +gcc,Using the GNU Compiler Collection (GCC)}, for more information on +debugging options. + +@node Directory Options +@section Options for Directory Search +@cindex directory, options +@cindex options, directory search +@cindex search path + +@cindex INCLUDE directive +@cindex directive, INCLUDE +There options affect how affect how @command{gfortran} searches +for files specified via the @code{INCLUDE} directive, and where it searches +for previously compiled modules. + +It also affects the search paths used by @command{cpp} when used to preprocess +fortran source. + +@table @gcctabopt +@cindex -Idir option +@cindex options, -Idir +@item -I@var{dir} +@cindex directory, search paths for inclusion +@cindex inclusion, directory search paths for +@cindex search paths, for included files +@cindex paths, search +@cindex module search path +These affect interpretation of the @code{INCLUDE} directive +(as well as of the @code{#include} directive of the @command{cpp} +preprocessor). + +Also note that the general behavior of @option{-I} and +@code{INCLUDE} is pretty much the same as of @option{-I} with +@code{#include} in the @command{cpp} preprocessor, with regard to +looking for @file{header.gcc} files and other such things. + +This path is also used to search for @samp{.mod} files when previously +compiled modules are required by a @code{USE} statement. + +@xref{Directory Options,,Options for Directory Search, +gcc,Using the GNU Compiler Collection (GCC)}, for information on the +@option{-I} option. + +@cindex -Mdir option +@cindex option, -Mdir +@item -M@var{dir} +@item -J@var{dir} +This option specifies where to put @samp{.mod} files for compiled modiles. +It is also added to the list of directories to searhed by an @code{USE} +statement. + +The default is the current directory. + +@option{-J} is an alias for @option{-M} to avoid conflicts with existing +GCC options. +@end table + +@node Code Gen Options +@section Options for Code Generation Conventions +@cindex code generation, conventions +@cindex options, code generation +@cindex run-time, options + +These machine-independent options control the interface conventions +used in code generation. + +Most of them have both positive and negative forms; the negative form +of @option{-ffoo} would be @option{-fno-foo}. In the table below, only +one of the forms is listed---the one which is not the default. You +can figure out the other form by either removing @option{no-} or adding +it. + + +@table @gcctabopt +@cindex -fno-underscoring option +@cindex options, -fno-underscoring +@item -fno-underscoring +@cindex underscore +@cindex symbol names, underscores +@cindex transforming symbol names +@cindex symbol names, transforming +Do not transform names of entities specified in the Fortran +source file by appending underscores to them. + +With @option{-funderscoring} in effect, @command{gfortran} appends two +underscores to names with underscores and one underscore to external names +with no underscores. (@command{gfortran} also appends two underscores to +internal names with underscores to avoid naming collisions with external +names. The @option{-fno-second-underscore} option disables appending of the +second underscore in all cases.) + +This is done to ensure compatibility with code produced by many +UNIX Fortran compilers, including @command{f2c} which perform the +same transformations. + +Use of @option{-fno-underscoring} is not recommended unless you are +experimenting with issues such as integration of (GNU) Fortran into +existing system environments (vis-a-vis existing libraries, tools, and +so on). + +For example, with @option{-funderscoring}, and assuming other defaults like +@option{-fcase-lower} and that @samp{j()} and @samp{max_count()} are +external functions while @samp{my_var} and @samp{lvar} are local variables, +a statement like + +@smallexample +I = J() + MAX_COUNT (MY_VAR, LVAR) +@end smallexample + +@noindent +is implemented as something akin to: + +@smallexample +i = j_() + max_count__(&my_var__, &lvar); +@end smallexample + +With @option{-fno-underscoring}, the same statement is implemented as: + +@smallexample +i = j() + max_count(&my_var, &lvar); +@end smallexample + +Use of @option{-fno-underscoring} allows direct specification of +user-defined names while debugging and when interfacing @command{gfortran} +code with other languages. + +Note that just because the names match does @emph{not} mean that the +interface implemented by @command{gfortran} for an external name matches the +interface implemented by some other language for that same name. +That is, getting code produced by @command{gfortran} to link to code produced +by some other compiler using this or any other method can be only a +small part of the overall solution---getting the code generated by +both compilers to agree on issues other than naming can require +significant effort, and, unlike naming disagreements, linkers normally +cannot detect disagreements in these other areas. + +Also, note that with @option{-fno-underscoring}, the lack of appended +underscores introduces the very real possibility that a user-defined +external name will conflict with a name in a system library, which +could make finding unresolved-reference bugs quite difficult in some +cases---they might occur at program run time, and show up only as +buggy behavior at run time. + +In future versions of @command{gfortran} we hope to improve naming and linking +issues so that debugging always involves using the names as they appear +in the source, even if the names as seen by the linker are mangled to +prevent accidental linking between procedures with incompatible +interfaces. + +@cindex -fno-second-underscore option +@cindex options, -fno-second-underscore +@item -fno-second-underscore +@cindex underscore +@cindex symbol names, underscores +@cindex transforming symbol names +@cindex symbol names, transforming +Do not append a second underscore to names of entities specified +in the Fortran source file. + +This option has no effect if @option{-fno-underscoring} is +in effect. + +Otherwise, with this option, an external name such as @samp{MAX_COUNT} +is implemented as a reference to the link-time external symbol +@samp{max_count_}, instead of @samp{max_count__}. + + +@cindex -fbounds-check option +@cindex -ffortran-bounds-check option +@item -fbounds-check +@cindex bounds checking +@cindex range checking +@cindex array bounds checking +@cindex subscript checking +@cindex checking subscripts +Enable generation of run-time checks for array subscripts +and against the declared minimum and maximum values. It also +checks array indices for assumed and deferred +shape arrays against the actual allocated bounds. + +In the future this may also include other forms of checking, eg. checing +substring references. + + +@cindex -fmax-stack-var-size option +@item -fmax-stack-var-size=@var{n} +This option specifies the size in bytes of the largest array that will be put +on the stack. + +This option currently only affects local arrays declared with constant +bounds, and may not apply to all character variables. +Future versions of @command{gfortran} may improve this behavior. + +The default value for @var{n} is 32768. + +@cindex -fpackderived +@item -fpackderived +@cindex Structure packing +This option tells gfortran to pack derived type members as closely as +possible. Code compiled with this option is likley to be incompatible +with code compiled without this option, and may execute slower. + +@cindex -frepack-arrays option +@item -frepack-arrays +@cindex Repacking arrays +In some circumstances @command{gfortran} may pass assumed shape array +sections via a descriptor describing a discontiguous area of memory. +This option adds code to the function prologue to repack the data into +a contiguous block at runtime. + +This should result in faster accesses to the array. However it can introduce +significant overhead to the function call, especially when the passed data +is discontiguous. +@end table + +@xref{Code Gen Options,,Options for Code Generation Conventions, +gcc,Using the GNU Compiler Collection (GCC)}, for information on more options +offered by the GBE +shared by @command{gfortran} @command{gcc} and other GNU compilers. + + +@c man end + +@node Environment Variables +@section Environment Variables Affecting GNU Fortran +@cindex environment variables + +@c man begin ENVIRONMENT + +GNU Fortran 95 currently does not make use of any environment +variables to control its operation above and beyond those +that affect the operation of @command{gcc}. + +@xref{Environment Variables,,Environment Variables Affecting GCC, +gcc,Using the GNU Compiler Collection (GCC)}, for information on environment +variables. + +@c man end diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c new file mode 100644 index 00000000000..5e7240d1622 --- /dev/null +++ b/gcc/fortran/io.c @@ -0,0 +1,2409 @@ +/* Deal with I/O statements & related stuff. + Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include "config.h" +#include "system.h" +#include "flags.h" + +#include <string.h> + +#include "gfortran.h" +#include "match.h" +#include "parse.h" + +gfc_st_label format_asterisk = + { -1, ST_LABEL_FORMAT, ST_LABEL_FORMAT, NULL, 0, + {NULL, 0, NULL, NULL}, NULL, NULL}; + +typedef struct +{ + const char *name, *spec; + bt type; +} +io_tag; + +static const io_tag + tag_file = { "FILE", " file = %e", BT_CHARACTER }, + tag_status = { "STATUS", " status = %e", BT_CHARACTER}, + tag_e_access = {"ACCESS", " access = %e", BT_CHARACTER}, + tag_e_form = {"FORM", " form = %e", BT_CHARACTER}, + tag_e_recl = {"RECL", " recl = %e", BT_INTEGER}, + tag_e_blank = {"BLANK", " blank = %e", BT_CHARACTER}, + tag_e_position = {"POSITION", " position = %e", BT_CHARACTER}, + tag_e_action = {"ACTION", " action = %e", BT_CHARACTER}, + tag_e_delim = {"DELIM", " delim = %e", BT_CHARACTER}, + tag_e_pad = {"PAD", " pad = %e", BT_CHARACTER}, + tag_unit = {"UNIT", " unit = %e", BT_INTEGER}, + tag_advance = {"ADVANCE", " advance = %e", BT_CHARACTER}, + tag_rec = {"REC", " rec = %e", BT_INTEGER}, + tag_format = {"FORMAT", NULL, BT_CHARACTER}, + tag_iostat = {"IOSTAT", " iostat = %v", BT_INTEGER}, + tag_size = {"SIZE", " size = %v", BT_INTEGER}, + tag_exist = {"EXIST", " exist = %v", BT_LOGICAL}, + tag_opened = {"OPENED", " opened = %v", BT_LOGICAL}, + tag_named = {"NAMED", " named = %v", BT_LOGICAL}, + tag_name = {"NAME", " name = %v", BT_CHARACTER}, + tag_number = {"NUMBER", " number = %v", BT_INTEGER}, + tag_s_access = {"ACCESS", " access = %v", BT_CHARACTER}, + tag_sequential = {"SEQUENTIAL", " sequential = %v", BT_CHARACTER}, + tag_direct = {"DIRECT", " direct = %v", BT_CHARACTER}, + tag_s_form = {"FORM", " form = %v", BT_CHARACTER}, + tag_formatted = {"FORMATTED", " formatted = %v", BT_CHARACTER}, + tag_unformatted = {"UNFORMATTED", " unformatted = %v", BT_CHARACTER}, + tag_s_recl = {"RECL", " recl = %v", BT_INTEGER}, + tag_nextrec = {"NEXTREC", " nextrec = %v", BT_INTEGER}, + tag_s_blank = {"BLANK", " blank = %v", BT_CHARACTER}, + tag_s_position = {"POSITION", " position = %v", BT_CHARACTER}, + tag_s_action = {"ACTION", " action = %v", BT_CHARACTER}, + tag_read = {"READ", " read = %v", BT_CHARACTER}, + tag_write = {"WRITE", " write = %v", BT_CHARACTER}, + tag_readwrite = {"READWRITE", " readwrite = %v", BT_CHARACTER}, + tag_s_delim = {"DELIM", " delim = %v", BT_CHARACTER}, + tag_s_pad = {"PAD", " pad = %v", BT_CHARACTER}, + tag_iolength = {"IOLENGTH", " iolength = %v", BT_INTEGER}, + tag_err = {"ERR", " err = %l", BT_UNKNOWN}, + tag_end = {"END", " end = %l", BT_UNKNOWN}, + tag_eor = {"EOR", " eor = %l", BT_UNKNOWN}; + +static gfc_dt *current_dt; + +#define RESOLVE_TAG(x, y) if (resolve_tag(x, y) == FAILURE) return FAILURE; + + +/**************** Fortran 95 FORMAT parser *****************/ + +/* FORMAT tokens returned by format_lex(). */ +typedef enum +{ + FMT_NONE, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD, + FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_POS, FMT_LPAREN, + FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F, + FMT_E, FMT_EXT, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END +} +format_token; + +/* Local variables for checking format strings. The saved_token is + used to back up by a single format token during the parsing + process. */ +static char *format_string; +static int format_length, use_last_char; + +static format_token saved_token; + +static enum +{ MODE_STRING, MODE_FORMAT, MODE_COPY } +mode; + + +/* Return the next character in the format string. */ + +static char +next_char (int in_string) +{ + static char c; + + if (use_last_char) + { + use_last_char = 0; + return c; + } + + format_length++; + + if (mode == MODE_STRING) + c = *format_string++; + else + { + c = gfc_next_char_literal (in_string); + if (c == '\n') + c = '\0'; + + if (mode == MODE_COPY) + *format_string++ = c; + } + + c = TOUPPER (c); + return c; +} + + +/* Back up one character position. Only works once. */ + +static void +unget_char (void) +{ + + use_last_char = 1; +} + +static int value = 0; + +/* Simple lexical analyzer for getting the next token in a FORMAT + statement. */ + +static format_token +format_lex (void) +{ + format_token token; + char c, delim; + int zflag; + int negative_flag; + + if (saved_token != FMT_NONE) + { + token = saved_token; + saved_token = FMT_NONE; + return token; + } + + do + { + c = next_char (0); + } + while (gfc_is_whitespace (c)); + + negative_flag = 0; + switch (c) + { + case '-': + negative_flag = 1; + case '+': + c = next_char (0); + if (!ISDIGIT (c)) + { + token = FMT_UNKNOWN; + break; + } + + value = c - '0'; + + do + { + c = next_char (0); + if(ISDIGIT (c)) + value = 10 * value + c - '0'; + } + while (ISDIGIT (c)); + + unget_char (); + + if (negative_flag) + value = -value; + + token = FMT_SIGNED_INT; + break; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + zflag = (c == '0'); + + value = c - '0'; + + do + { + c = next_char (0); + if (c != '0') + zflag = 0; + if (ISDIGIT (c)) + value = 10 * value + c - '0'; + } + while (ISDIGIT (c)); + + unget_char (); + token = zflag ? FMT_ZERO : FMT_POSINT; + break; + + case '.': + token = FMT_PERIOD; + break; + + case ',': + token = FMT_COMMA; + break; + + case ':': + token = FMT_COLON; + break; + + case '/': + token = FMT_SLASH; + break; + + case '$': + token = FMT_DOLLAR; + break; + + case 'T': + c = next_char (0); + if (c != 'L' && c != 'R') + unget_char (); + + token = FMT_POS; + break; + + case '(': + token = FMT_LPAREN; + break; + + case ')': + token = FMT_RPAREN; + break; + + case 'X': + token = FMT_X; + break; + + case 'S': + c = next_char (0); + if (c != 'P' && c != 'S') + unget_char (); + + token = FMT_SIGN; + break; + + case 'B': + c = next_char (0); + if (c == 'N' || c == 'Z') + token = FMT_BLANK; + else + { + unget_char (); + token = FMT_IBOZ; + } + + break; + + case '\'': + case '"': + delim = c; + + value = 0; + + for (;;) + { + c = next_char (1); + if (c == '\0') + { + token = FMT_END; + break; + } + + if (c == delim) + { + c = next_char (1); + + if (c == '\0') + { + token = FMT_END; + break; + } + + if (c != delim) + { + unget_char (); + token = FMT_CHAR; + break; + } + } + value++; + } + break; + + case 'P': + token = FMT_P; + break; + + case 'I': + case 'O': + case 'Z': + token = FMT_IBOZ; + break; + + case 'F': + token = FMT_F; + break; + + case 'E': + c = next_char (0); + if (c == 'N' || c == 'S') + token = FMT_EXT; + else + { + token = FMT_E; + unget_char (); + } + + break; + + case 'G': + token = FMT_G; + break; + + case 'H': + token = FMT_H; + break; + + case 'L': + token = FMT_L; + break; + + case 'A': + token = FMT_A; + break; + + case 'D': + token = FMT_D; + break; + + case '\0': + token = FMT_END; + break; + + default: + token = FMT_UNKNOWN; + break; + } + + return token; +} + + +/* Check a format statement. The format string, either from a FORMAT + statement or a constant in an I/O statement has already been parsed + by itself, and we are checking it for validity. The dual origin + means that the warning message is a little less than great. */ + +static try +check_format (void) +{ + const char *posint_required = "Positive width required"; + const char *period_required = "Period required"; + const char *nonneg_required = "Nonnegative width required"; + const char *unexpected_element = "Unexpected element"; + const char *unexpected_end = "Unexpected end of format string"; + + const char *error; + format_token t, u; + int level; + int repeat; + try rv; + + use_last_char = 0; + saved_token = FMT_NONE; + level = 0; + repeat = 0; + rv = SUCCESS; + + t = format_lex (); + if (t != FMT_LPAREN) + { + error = "Missing leading left parenthesis"; + goto syntax; + } + + t = format_lex (); + if (t == FMT_RPAREN) + goto finished; /* Empty format is legal */ + saved_token = t; + +format_item: + /* In this state, the next thing has to be a format item. */ + t = format_lex (); + switch (t) + { + case FMT_POSINT: + repeat = value; + t = format_lex (); + if (t == FMT_LPAREN) + { + level++; + goto format_item; + } + + if (t == FMT_SLASH) + goto optional_comma; + + goto data_desc; + + case FMT_LPAREN: + level++; + goto format_item; + + case FMT_SIGNED_INT: + /* Signed integer can only precede a P format. */ + t = format_lex (); + if (t != FMT_P) + { + error = "Expected P edit descriptor"; + goto syntax; + } + + goto data_desc; + + case FMT_P: + /* P and X require a prior number. */ + error = "P descriptor requires leading scale factor"; + goto syntax; + + case FMT_X: + error = "X descriptor requires leading space count"; + goto syntax; + + case FMT_SIGN: + case FMT_BLANK: + case FMT_CHAR: + goto between_desc; + + case FMT_COLON: + case FMT_SLASH: + goto optional_comma; + + case FMT_DOLLAR: + t = format_lex (); + if (t != FMT_RPAREN || level > 0) + { + error = "$ must the last specifier"; + goto syntax; + } + + goto finished; + + case FMT_POS: + case FMT_IBOZ: + case FMT_F: + case FMT_E: + case FMT_EXT: + case FMT_G: + case FMT_L: + case FMT_A: + case FMT_D: + goto data_desc; + + case FMT_H: + goto data_desc; + + case FMT_END: + error = unexpected_end; + goto syntax; + + default: + error = unexpected_element; + goto syntax; + } + +data_desc: + /* In this state, t must currently be a data descriptor. + Deal with things that can/must follow the descriptor. */ + switch (t) + { + case FMT_SIGN: + case FMT_BLANK: + case FMT_X: + break; + + case FMT_P: + if (pedantic) + { + t = format_lex (); + if (t == FMT_POSINT) + { + error = "Repeat count cannot follow P descriptor"; + goto syntax; + } + + saved_token = t; + } + + goto optional_comma; + + case FMT_POS: + case FMT_L: + t = format_lex (); + if (t == FMT_POSINT) + break; + + error = posint_required; + goto syntax; + + case FMT_A: + t = format_lex (); + if (t != FMT_POSINT) + saved_token = t; + break; + + case FMT_D: + case FMT_E: + case FMT_G: + case FMT_EXT: + u = format_lex (); + if (u != FMT_POSINT) + { + error = posint_required; + goto syntax; + } + + u = format_lex (); + if (u != FMT_PERIOD) + { + error = period_required; + goto syntax; + } + + u = format_lex (); + if (u != FMT_ZERO && u != FMT_POSINT) + { + error = nonneg_required; + goto syntax; + } + + if (t == FMT_D) + break; + + /* Look for optional exponent. */ + u = format_lex (); + if (u != FMT_E) + { + saved_token = u; + } + else + { + u = format_lex (); + if (u != FMT_POSINT) + { + error = "Positive exponent width required"; + goto syntax; + } + } + + break; + + case FMT_F: + t = format_lex (); + if (t != FMT_ZERO && t != FMT_POSINT) + { + error = nonneg_required; + goto syntax; + } + + t = format_lex (); + if (t != FMT_PERIOD) + { + error = period_required; + goto syntax; + } + + t = format_lex (); + if (t != FMT_ZERO && t != FMT_POSINT) + { + error = nonneg_required; + goto syntax; + } + + break; + + case FMT_H: + if(mode == MODE_STRING) + { + format_string += value; + format_length -= value; + } + else + { + while(repeat >0) + { + next_char(0); + repeat -- ; + } + } + break; + + case FMT_IBOZ: + t = format_lex (); + if (t != FMT_ZERO && t != FMT_POSINT) + { + error = nonneg_required; + goto syntax; + } + + t = format_lex (); + if (t != FMT_PERIOD) + { + saved_token = t; + } + else + { + t = format_lex (); + if (t != FMT_ZERO && t != FMT_POSINT) + { + error = nonneg_required; + goto syntax; + } + } + + break; + + default: + error = unexpected_element; + goto syntax; + } + +between_desc: + /* Between a descriptor and what comes next. */ + t = format_lex (); + switch (t) + { + + case FMT_COMMA: + goto format_item; + + case FMT_RPAREN: + level--; + if (level < 0) + goto finished; + goto between_desc; + + case FMT_COLON: + case FMT_SLASH: + goto optional_comma; + + case FMT_END: + error = unexpected_end; + goto syntax; + + default: + error = "Missing comma"; + goto syntax; + } + +optional_comma: + /* Optional comma is a weird between state where we've just finished + reading a colon, slash or P descriptor. */ + t = format_lex (); + switch (t) + { + case FMT_COMMA: + break; + + case FMT_RPAREN: + level--; + if (level < 0) + goto finished; + goto between_desc; + + default: + /* Assume that we have another format item. */ + saved_token = t; + break; + } + + goto format_item; + +syntax: + /* Something went wrong. If the format we're checking is a string, + generate a warning, since the program is correct. If the format + is in a FORMAT statement, this messes up parsing, which is an + error. */ + if (mode != MODE_STRING) + gfc_error ("%s in format string at %C", error); + else + { + gfc_warning ("%s in format string at %C", error); + + /* TODO: More elaborate measures are needed to show where a problem + is within a format string that has been calculated. */ + } + + rv = FAILURE; + +finished: + return rv; +} + + +/* Given an expression node that is a constant string, see if it looks + like a format string. */ + +static void +check_format_string (gfc_expr * e) +{ + + mode = MODE_STRING; + format_string = e->value.character.string; + check_format (); +} + + +/************ Fortran 95 I/O statement matchers *************/ + +/* Match a FORMAT statement. This amounts to actually parsing the + format descriptors in order to correctly locate the end of the + format string. */ + +match +gfc_match_format (void) +{ + gfc_expr *e; + locus start; + + if (gfc_statement_label == NULL) + { + gfc_error ("Missing format label at %C"); + return MATCH_ERROR; + } + gfc_gobble_whitespace (); + + mode = MODE_FORMAT; + format_length = 0; + + start = *gfc_current_locus (); + + if (check_format () == FAILURE) + return MATCH_ERROR; + + if (gfc_match_eos () != MATCH_YES) + { + gfc_syntax_error (ST_FORMAT); + return MATCH_ERROR; + } + + /* The label doesn't get created until after the statement is done + being matched, so we have to leave the string for later. */ + + gfc_set_locus (&start); /* Back to the beginning */ + + new_st.loc = start; + new_st.op = EXEC_NOP; + + e = gfc_get_expr(); + e->expr_type = EXPR_CONSTANT; + e->ts.type = BT_CHARACTER; + e->ts.kind = gfc_default_character_kind(); + e->where = start; + e->value.character.string = format_string = gfc_getmem(format_length+1); + e->value.character.length = format_length; + gfc_statement_label->format = e; + + mode = MODE_COPY; + check_format (); /* Guaranteed to succeed */ + gfc_match_eos (); /* Guaranteed to succeed */ + + return MATCH_YES; +} + + +/* Match an expression I/O tag of some sort. */ + +static match +match_etag (const io_tag * tag, gfc_expr ** v) +{ + gfc_expr *result; + match m; + + m = gfc_match (tag->spec, &result); + if (m != MATCH_YES) + return m; + + if (*v != NULL) + { + gfc_error ("Duplicate %s specification at %C", tag->name); + gfc_free_expr (result); + return MATCH_ERROR; + } + + *v = result; + return MATCH_YES; +} + + +/* Match a variable I/O tag of some sort. */ + +static match +match_vtag (const io_tag * tag, gfc_expr ** v) +{ + gfc_expr *result; + match m; + + m = gfc_match (tag->spec, &result); + if (m != MATCH_YES) + return m; + + if (*v != NULL) + { + gfc_error ("Duplicate %s specification at %C", tag->name); + gfc_free_expr (result); + return MATCH_ERROR; + } + + if (result->symtree->n.sym->attr.intent == INTENT_IN) + { + gfc_error ("Variable tag cannot be INTENT(IN) at %C"); + gfc_free_expr (result); + return MATCH_ERROR; + } + + if (gfc_pure (NULL) && gfc_impure_variable (result->symtree->n.sym)) + { + gfc_error ("Variable tag cannot be assigned in PURE procedure at %C"); + gfc_free_expr (result); + return MATCH_ERROR; + } + + *v = result; + return MATCH_YES; +} + + +/* Match a label I/O tag. */ + +static match +match_ltag (const io_tag * tag, gfc_st_label ** label) +{ + match m; + gfc_st_label *old; + + old = *label; + m = gfc_match (tag->spec, label); + if (m == MATCH_YES && old != 0) + { + gfc_error ("Duplicate %s label specification at %C", tag->name); + return MATCH_ERROR; + } + + return m; +} + + +/* Do expression resolution and type-checking on an expression tag. */ + +static try +resolve_tag (const io_tag * tag, gfc_expr * e) +{ + + if (e == NULL) + return SUCCESS; + + if (gfc_resolve_expr (e) == FAILURE) + return FAILURE; + + if (e->ts.type != tag->type) + { + /* Format label can be integer varibale. */ + if (tag != &tag_format) + { + gfc_error ("%s tag at %L must be of type %s", tag->name, &e->where, + gfc_basic_typename (tag->type)); + return FAILURE; + } + } + + if (tag == &tag_format) + { + if (e->rank != 1 && e->rank != 0) + { + gfc_error ("FORMAT tag at %L cannot be array of strings", + &e->where); + return FAILURE; + } + } + else + { + if (e->rank != 0) + { + gfc_error ("%s tag at %L must be scalar", tag->name, &e->where); + return FAILURE; + } + } + + return SUCCESS; +} + + +/* Match a single tag of an OPEN statement. */ + +static match +match_open_element (gfc_open * open) +{ + match m; + + m = match_etag (&tag_unit, &open->unit); + if (m != MATCH_NO) + return m; + m = match_vtag (&tag_iostat, &open->iostat); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_file, &open->file); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_status, &open->status); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_access, &open->access); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_form, &open->form); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_recl, &open->recl); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_blank, &open->blank); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_position, &open->position); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_action, &open->action); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_delim, &open->delim); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_e_pad, &open->pad); + if (m != MATCH_NO) + return m; + m = match_ltag (&tag_err, &open->err); + if (m != MATCH_NO) + return m; + + return MATCH_NO; +} + + +/* Free the gfc_open structure and all the expressions it contains. */ + +void +gfc_free_open (gfc_open * open) +{ + + if (open == NULL) + return; + + gfc_free_expr (open->unit); + gfc_free_expr (open->iostat); + gfc_free_expr (open->file); + gfc_free_expr (open->status); + gfc_free_expr (open->access); + gfc_free_expr (open->form); + gfc_free_expr (open->recl); + gfc_free_expr (open->blank); + gfc_free_expr (open->position); + gfc_free_expr (open->action); + gfc_free_expr (open->delim); + gfc_free_expr (open->pad); + + gfc_free (open); +} + + +/* Resolve everything in a gfc_open structure. */ + +try +gfc_resolve_open (gfc_open * open) +{ + + RESOLVE_TAG (&tag_unit, open->unit); + RESOLVE_TAG (&tag_iostat, open->iostat); + RESOLVE_TAG (&tag_file, open->file); + RESOLVE_TAG (&tag_status, open->status); + RESOLVE_TAG (&tag_e_form, open->form); + RESOLVE_TAG (&tag_e_recl, open->recl); + + RESOLVE_TAG (&tag_e_blank, open->blank); + RESOLVE_TAG (&tag_e_position, open->position); + RESOLVE_TAG (&tag_e_action, open->action); + RESOLVE_TAG (&tag_e_delim, open->delim); + RESOLVE_TAG (&tag_e_pad, open->pad); + + if (gfc_reference_st_label (open->err, ST_LABEL_TARGET) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/* Match an OPEN statmement. */ + +match +gfc_match_open (void) +{ + gfc_open *open; + match m; + + m = gfc_match_char ('('); + if (m == MATCH_NO) + return m; + + open = gfc_getmem (sizeof (gfc_open)); + + m = match_open_element (open); + + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + m = gfc_match_expr (&open->unit); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + } + + for (;;) + { + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = match_open_element (open); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + + if (gfc_match_eos () == MATCH_NO) + goto syntax; + + if (gfc_pure (NULL)) + { + gfc_error ("OPEN statement not allowed in PURE procedure at %C"); + goto cleanup; + } + + new_st.op = EXEC_OPEN; + new_st.ext.open = open; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_OPEN); + +cleanup: + gfc_free_open (open); + return MATCH_ERROR; +} + + +/* Free a gfc_close structure an all its expressions. */ + +void +gfc_free_close (gfc_close * close) +{ + + if (close == NULL) + return; + + gfc_free_expr (close->unit); + gfc_free_expr (close->iostat); + gfc_free_expr (close->status); + + gfc_free (close); +} + + +/* Match elements of a CLOSE statment. */ + +static match +match_close_element (gfc_close * close) +{ + match m; + + m = match_etag (&tag_unit, &close->unit); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_status, &close->status); + if (m != MATCH_NO) + return m; + m = match_vtag (&tag_iostat, &close->iostat); + if (m != MATCH_NO) + return m; + m = match_ltag (&tag_err, &close->err); + if (m != MATCH_NO) + return m; + + return MATCH_NO; +} + + +/* Match a CLOSE statement. */ + +match +gfc_match_close (void) +{ + gfc_close *close; + match m; + + m = gfc_match_char ('('); + if (m == MATCH_NO) + return m; + + close = gfc_getmem (sizeof (gfc_close)); + + m = match_close_element (close); + + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + m = gfc_match_expr (&close->unit); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + } + + for (;;) + { + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = match_close_element (close); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + + if (gfc_match_eos () == MATCH_NO) + goto syntax; + + if (gfc_pure (NULL)) + { + gfc_error ("CLOSE statement not allowed in PURE procedure at %C"); + goto cleanup; + } + + new_st.op = EXEC_CLOSE; + new_st.ext.close = close; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_CLOSE); + +cleanup: + gfc_free_close (close); + return MATCH_ERROR; +} + + +/* Resolve everything in a gfc_close structure. */ + +try +gfc_resolve_close (gfc_close * close) +{ + + RESOLVE_TAG (&tag_unit, close->unit); + RESOLVE_TAG (&tag_iostat, close->iostat); + RESOLVE_TAG (&tag_status, close->status); + + if (gfc_reference_st_label (close->err, ST_LABEL_TARGET) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/* Free a gfc_filepos structure. */ + +void +gfc_free_filepos (gfc_filepos * fp) +{ + + gfc_free_expr (fp->unit); + gfc_free_expr (fp->iostat); + gfc_free (fp); +} + + +/* Match elements of a REWIND, BACKSPACE or ENDFILE statement. */ + +static match +match_file_element (gfc_filepos * fp) +{ + match m; + + m = match_etag (&tag_unit, &fp->unit); + if (m != MATCH_NO) + return m; + m = match_vtag (&tag_iostat, &fp->iostat); + if (m != MATCH_NO) + return m; + m = match_ltag (&tag_err, &fp->err); + if (m != MATCH_NO) + return m; + + return MATCH_NO; +} + + +/* Match the second half of the file-positioning statements, REWIND, + BACKSPACE or ENDFILE. */ + +static match +match_filepos (gfc_statement st, gfc_exec_op op) +{ + gfc_filepos *fp; + match m; + + fp = gfc_getmem (sizeof (gfc_filepos)); + + if (gfc_match_char ('(') == MATCH_NO) + { + m = gfc_match_expr (&fp->unit); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + goto done; + } + + m = match_file_element (fp); + if (m == MATCH_ERROR) + goto done; + if (m == MATCH_NO) + { + m = gfc_match_expr (&fp->unit); + if (m == MATCH_ERROR) + goto done; + if (m == MATCH_NO) + goto syntax; + } + + for (;;) + { + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = match_file_element (fp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + +done: + if (gfc_match_eos () != MATCH_YES) + goto syntax; + + if (gfc_pure (NULL)) + { + gfc_error ("%s statement not allowed in PURE procedure at %C", + gfc_ascii_statement (st)); + + goto cleanup; + } + + new_st.op = op; + new_st.ext.filepos = fp; + return MATCH_YES; + +syntax: + gfc_syntax_error (st); + +cleanup: + gfc_free_filepos (fp); + return MATCH_ERROR; +} + + +try +gfc_resolve_filepos (gfc_filepos * fp) +{ + + RESOLVE_TAG (&tag_unit, fp->unit); + if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/* Match the file positioning statements: ENDFILE, BACKSPACE or + REWIND. */ + +match +gfc_match_endfile (void) +{ + + return match_filepos (ST_END_FILE, EXEC_ENDFILE); +} + +match +gfc_match_backspace (void) +{ + + return match_filepos (ST_BACKSPACE, EXEC_BACKSPACE); +} + +match +gfc_match_rewind (void) +{ + + return match_filepos (ST_REWIND, EXEC_REWIND); +} + + +/******************** Data Transfer Statments *********************/ + +typedef enum +{ M_READ, M_WRITE, M_PRINT, M_INQUIRE } +io_kind; + + +/* Return a default unit number. */ + +static gfc_expr * +default_unit (io_kind k) +{ + int unit; + + if (k == M_READ) + unit = 5; + else + unit = 6; + + return gfc_int_expr (unit); +} + + +/* Match a unit specification for a data transfer statement. */ + +static match +match_dt_unit (io_kind k, gfc_dt * dt) +{ + gfc_expr *e; + + if (gfc_match_char ('*') == MATCH_YES) + { + if (dt->io_unit != NULL) + goto conflict; + + dt->io_unit = default_unit (k); + return MATCH_YES; + } + + if (gfc_match_expr (&e) == MATCH_YES) + { + if (dt->io_unit != NULL) + { + gfc_free_expr (e); + goto conflict; + } + + dt->io_unit = e; + return MATCH_YES; + } + + return MATCH_NO; + +conflict: + gfc_error ("Duplicate UNIT specification at %C"); + return MATCH_ERROR; +} + + +/* Match a format specification. */ + +static match +match_dt_format (gfc_dt * dt) +{ + locus where; + gfc_expr *e; + gfc_st_label *label; + + where = *gfc_current_locus (); + + if (gfc_match_char ('*') == MATCH_YES) + { + if (dt->format_expr != NULL || dt->format_label != NULL) + goto conflict; + + dt->format_label = &format_asterisk; + return MATCH_YES; + } + + if (gfc_match_st_label (&label, 0) == MATCH_YES) + { + if (dt->format_expr != NULL || dt->format_label != NULL) + { + gfc_free_st_label (label); + goto conflict; + } + + if (gfc_reference_st_label (label, ST_LABEL_FORMAT) == FAILURE) + return MATCH_ERROR; + + dt->format_label = label; + return MATCH_YES; + } + + if (gfc_match_expr (&e) == MATCH_YES) + { + if (dt->format_expr != NULL || dt->format_label != NULL) + { + gfc_free_expr (e); + goto conflict; + } + if (e->ts.type == BT_INTEGER && e->rank == 0) + e->symtree->n.sym->attr.assign = 1; + + dt->format_expr = e; + return MATCH_YES; + } + + gfc_set_locus (&where); /* The only case where we have to restore */ + + return MATCH_NO; + +conflict: + gfc_error ("Duplicate format specification at %C"); + return MATCH_ERROR; +} + + +/* Traverse a namelist that is part of a READ statement to make sure + that none of the variables in the namelist are INTENT(IN). Returns + nonzero if we find such a variable. */ + +static int +check_namelist (gfc_symbol * sym) +{ + gfc_namelist *p; + + for (p = sym->namelist; p; p = p->next) + if (p->sym->attr.intent == INTENT_IN) + { + gfc_error ("Symbol '%s' in namelist '%s' is INTENT(IN) at %C", + p->sym->name, sym->name); + return 1; + } + + return 0; +} + + +/* Match a single data transfer element. */ + +static match +match_dt_element (io_kind k, gfc_dt * dt) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + match m; + + if (gfc_match (" unit =") == MATCH_YES) + { + m = match_dt_unit (k, dt); + if (m != MATCH_NO) + return m; + } + + if (gfc_match (" fmt =") == MATCH_YES) + { + m = match_dt_format (dt); + if (m != MATCH_NO) + return m; + } + + if (gfc_match (" nml = %n", name) == MATCH_YES) + { + if (dt->namelist != NULL) + { + gfc_error ("Duplicate NML specification at %C"); + return MATCH_ERROR; + } + + if (gfc_find_symbol (name, NULL, 1, &sym)) + return MATCH_ERROR; + + if (sym == NULL || sym->attr.flavor != FL_NAMELIST) + { + gfc_error ("Symbol '%s' at %C must be a NAMELIST group name", + sym != NULL ? sym->name : name); + return MATCH_ERROR; + } + + dt->namelist = sym; + if (k == M_READ && check_namelist (sym)) + return MATCH_ERROR; + + return MATCH_YES; + } + + m = match_etag (&tag_rec, &dt->rec); + if (m != MATCH_NO) + return m; + m = match_vtag (&tag_iostat, &dt->iostat); + if (m != MATCH_NO) + return m; + m = match_ltag (&tag_err, &dt->err); + if (m != MATCH_NO) + return m; + m = match_etag (&tag_advance, &dt->advance); + if (m != MATCH_NO) + return m; + m = match_vtag (&tag_size, &dt->size); + if (m != MATCH_NO) + return m; + + m = match_ltag (&tag_end, &dt->end); + if (m == MATCH_YES) + dt->end_where = *gfc_current_locus (); + if (m != MATCH_NO) + return m; + + m = match_ltag (&tag_eor, &dt->eor); + if (m == MATCH_YES) + dt->eor_where = *gfc_current_locus (); + if (m != MATCH_NO) + return m; + + return MATCH_NO; +} + + +/* Free a data transfer structure and everything below it. */ + +void +gfc_free_dt (gfc_dt * dt) +{ + + if (dt == NULL) + return; + + gfc_free_expr (dt->io_unit); + gfc_free_expr (dt->format_expr); + gfc_free_expr (dt->rec); + gfc_free_expr (dt->advance); + gfc_free_expr (dt->iostat); + gfc_free_expr (dt->size); + + gfc_free (dt); +} + + +/* Resolve everything in a gfc_dt structure. */ + +try +gfc_resolve_dt (gfc_dt * dt) +{ + gfc_expr *e; + + RESOLVE_TAG (&tag_format, dt->format_expr); + RESOLVE_TAG (&tag_rec, dt->rec); + RESOLVE_TAG (&tag_advance, dt->advance); + RESOLVE_TAG (&tag_iostat, dt->iostat); + RESOLVE_TAG (&tag_size, dt->size); + + e = dt->io_unit; + if (gfc_resolve_expr (e) == SUCCESS + && (e->ts.type != BT_INTEGER + && (e->ts.type != BT_CHARACTER + || e->expr_type != EXPR_VARIABLE))) + { + gfc_error + ("UNIT specification at %L must be an INTEGER expression or a " + "CHARACTER variable", &e->where); + return FAILURE; + } + + /* Sanity checks on data transfer statements. */ + if (e->ts.type == BT_CHARACTER) + { + if (dt->rec != NULL) + { + gfc_error ("REC tag at %L is incompatible with internal file", + &dt->rec->where); + return FAILURE; + } + + if (dt->namelist != NULL) + { + gfc_error ("Internal file at %L is incompatible with namelist", + &dt->io_unit->where); + return FAILURE; + } + + if (dt->advance != NULL) + { + gfc_error ("ADVANCE tag at %L is incompatible with internal file", + &dt->advance->where); + return FAILURE; + } + } + + if (dt->rec != NULL) + { + if (dt->end != NULL) + { + gfc_error ("REC tag at %L is incompatible with END tag", + &dt->rec->where); + return FAILURE; + } + + if (dt->format_label == &format_asterisk) + { + gfc_error + ("END tag at %L is incompatible with list directed format (*)", + &dt->end_where); + return FAILURE; + } + + if (dt->namelist != NULL) + { + gfc_error ("REC tag at %L is incompatible with namelist", + &dt->rec->where); + return FAILURE; + } + } + + if (dt->advance != NULL && dt->format_label == &format_asterisk) + { + gfc_error ("ADVANCE tag at %L is incompatible with list directed " + "format (*)", &dt->advance->where); + return FAILURE; + } + + if (dt->eor != 0 && dt->advance == NULL) + { + gfc_error ("EOR tag at %L requires an ADVANCE tag", &dt->eor_where); + return FAILURE; + } + + if (dt->size != NULL && dt->advance == NULL) + { + gfc_error ("SIZE tag at %L requires an ADVANCE tag", &dt->size->where); + return FAILURE; + } + + /* TODO: Make sure the ADVANCE tag is 'yes' or 'no' if it is a string + constant. */ + + if (gfc_reference_st_label (dt->err, ST_LABEL_TARGET) == FAILURE) + return FAILURE; + + if (gfc_reference_st_label (dt->end, ST_LABEL_TARGET) == FAILURE) + return FAILURE; + + if (gfc_reference_st_label (dt->eor, ST_LABEL_TARGET) == FAILURE) + return FAILURE; + + /* Check the format label ectually exists. */ + if (dt->format_label && dt->format_label != &format_asterisk + && dt->format_label->defined == ST_LABEL_UNKNOWN) + { + gfc_error ("FORMAT label %d at %L not defined", dt->format_label->value, + &dt->format_label->where); + return FAILURE; + } + return SUCCESS; +} + + +/* Given an io_kind, return its name. */ + +static const char * +io_kind_name (io_kind k) +{ + const char *name; + + switch (k) + { + case M_READ: + name = "READ"; + break; + case M_WRITE: + name = "WRITE"; + break; + case M_PRINT: + name = "PRINT"; + break; + case M_INQUIRE: + name = "INQUIRE"; + break; + default: + gfc_internal_error ("io_kind_name(): bad I/O-kind"); + } + + return name; +} + + +/* Match an IO iteration statement of the form: + + ( [<IO element> ,] <IO element>, I = <expr>, <expr> [, <expr> ] ) + + which is equivalent to a single IO element. This function is + mutually recursive with match_io_element(). */ + +static match match_io_element (io_kind k, gfc_code **); + +static match +match_io_iterator (io_kind k, gfc_code ** result) +{ + gfc_code *head, *tail, *new; + gfc_iterator *iter; + locus old_loc; + match m; + int n; + + iter = NULL; + head = NULL; + old_loc = *gfc_current_locus (); + + if (gfc_match_char ('(') != MATCH_YES) + return MATCH_NO; + + m = match_io_element (k, &head); + tail = head; + + if (m != MATCH_YES || gfc_match_char (',') != MATCH_YES) + { + m = MATCH_NO; + goto cleanup; + } + + /* Can't be anything but an IO iterator. Build a list. */ + iter = gfc_get_iterator (); + + for (n = 1;; n++) + { + m = gfc_match_iterator (iter, 0); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + break; + + m = match_io_element (k, &new); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + if (n > 2) + goto syntax; + goto cleanup; + } + + tail = gfc_append_code (tail, new); + + if (gfc_match_char (',') != MATCH_YES) + { + if (n > 2) + goto syntax; + m = MATCH_NO; + goto cleanup; + } + } + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + new = gfc_get_code (); + new->op = EXEC_DO; + new->ext.iterator = iter; + + new->block = gfc_get_code (); + new->block->op = EXEC_DO; + new->block->next = head; + + *result = new; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in I/O iterator at %C"); + m = MATCH_ERROR; + +cleanup: + gfc_free_iterator (iter, 1); + gfc_free_statements (head); + gfc_set_locus (&old_loc); + return m; +} + + +/* Match a single element of an IO list, which is either a single + expression or an IO Iterator. */ + +static match +match_io_element (io_kind k, gfc_code ** cpp) +{ + gfc_expr *expr; + gfc_code *cp; + match m; + + expr = NULL; + + m = match_io_iterator (k, cpp); + if (m == MATCH_YES) + return MATCH_YES; + + if (k == M_READ) + { + m = gfc_match_variable (&expr, 0); + if (m == MATCH_NO) + gfc_error ("Expected variable in READ statement at %C"); + } + else + { + m = gfc_match_expr (&expr); + if (m == MATCH_NO) + gfc_error ("Expected expression in %s statement at %C", + io_kind_name (k)); + } + + if (m == MATCH_YES) + switch (k) + { + case M_READ: + if (expr->symtree->n.sym->attr.intent == INTENT_IN) + { + gfc_error + ("Variable '%s' in input list at %C cannot be INTENT(IN)", + expr->symtree->n.sym->name); + m = MATCH_ERROR; + } + + if (gfc_pure (NULL) + && gfc_impure_variable (expr->symtree->n.sym) + && current_dt->io_unit->ts.type == BT_CHARACTER) + { + gfc_error ("Cannot read to variable '%s' in PURE procedure at %C", + expr->symtree->n.sym->name); + m = MATCH_ERROR; + } + + break; + + case M_WRITE: + if (current_dt->io_unit->ts.type == BT_CHARACTER + && gfc_pure (NULL) + && current_dt->io_unit->expr_type == EXPR_VARIABLE + && gfc_impure_variable (current_dt->io_unit->symtree->n.sym)) + { + gfc_error + ("Cannot write to internal file unit '%s' at %C inside a " + "PURE procedure", current_dt->io_unit->symtree->n.sym->name); + m = MATCH_ERROR; + } + + break; + + default: + break; + } + + if (m != MATCH_YES) + { + gfc_free_expr (expr); + return MATCH_ERROR; + } + + cp = gfc_get_code (); + cp->op = EXEC_TRANSFER; + cp->expr = expr; + + *cpp = cp; + return MATCH_YES; +} + + +/* Match an I/O list, building gfc_code structures as we go. */ + +static match +match_io_list (io_kind k, gfc_code ** head_p) +{ + gfc_code *head, *tail, *new; + match m; + + *head_p = head = tail = NULL; + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + + for (;;) + { + m = match_io_element (k, &new); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + tail = gfc_append_code (tail, new); + if (head == NULL) + head = new; + + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + *head_p = head; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in %s statement at %C", io_kind_name (k)); + +cleanup: + gfc_free_statements (head); + return MATCH_ERROR; +} + + +/* Attach the data transfer end node. */ + +static void +terminate_io (gfc_code * io_code) +{ + gfc_code *c; + + if (io_code == NULL) + io_code = &new_st; + + c = gfc_get_code (); + c->op = EXEC_DT_END; + + /* Point to structure that is already there */ + c->ext.dt = new_st.ext.dt; + gfc_append_code (io_code, c); +} + + +/* Match a READ, WRITE or PRINT statement. */ + +static match +match_io (io_kind k) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_code *io_code; + gfc_symbol *sym; + gfc_expr *expr; + int comma_flag; + locus where; + gfc_dt *dt; + match m; + + comma_flag = 0; + current_dt = dt = gfc_getmem (sizeof (gfc_dt)); + + if (gfc_match_char ('(') == MATCH_NO) + { + if (k == M_WRITE) + goto syntax; + + m = match_dt_format (dt); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + comma_flag = 1; + dt->io_unit = default_unit (k); + goto get_io_list; + } + + /* Match a control list */ + if (match_dt_element (k, dt) == MATCH_YES) + goto next; + if (match_dt_unit (k, dt) != MATCH_YES) + goto loop; + + if (gfc_match_char (')') == MATCH_YES) + goto get_io_list; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = match_dt_element (k, dt); + if (m == MATCH_YES) + goto next; + if (m == MATCH_ERROR) + goto cleanup; + + m = match_dt_format (dt); + if (m == MATCH_YES) + goto next; + if (m == MATCH_ERROR) + goto cleanup; + + where = *gfc_current_locus (); + + if (gfc_match_name (name) == MATCH_YES + && !gfc_find_symbol (name, NULL, 1, &sym) + && sym->attr.flavor == FL_NAMELIST) + { + dt->namelist = sym; + if (k == M_READ && check_namelist (sym)) + { + m = MATCH_ERROR; + goto cleanup; + } + goto next; + } + + gfc_set_locus (&where); + + goto loop; /* No matches, try regular elements */ + +next: + if (gfc_match_char (')') == MATCH_YES) + goto get_io_list; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + +loop: + for (;;) + { + m = match_dt_element (k, dt); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + +get_io_list: + /* Optional leading comma (non-standard). */ + if (!comma_flag) + gfc_match_char (','); + + io_code = NULL; + if (gfc_match_eos () != MATCH_YES) + { + if (comma_flag && gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expected comma in I/O list at %C"); + m = MATCH_ERROR; + goto cleanup; + } + + m = match_io_list (k, &io_code); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + + /* A full IO statement has been matched. */ + if (dt->io_unit->expr_type == EXPR_VARIABLE + && k == M_WRITE + && dt->io_unit->ts.type == BT_CHARACTER + && dt->io_unit->symtree->n.sym->attr.intent == INTENT_IN) + { + gfc_error ("Internal file '%s' at %L is INTENT(IN)", + dt->io_unit->symtree->n.sym->name, &dt->io_unit->where); + m = MATCH_ERROR; + goto cleanup; + } + + expr = dt->format_expr; + + if (expr != NULL && expr->expr_type == EXPR_CONSTANT) + check_format_string (expr); + + if (gfc_pure (NULL) + && (k == M_READ || k == M_WRITE) + && dt->io_unit->ts.type != BT_CHARACTER) + { + gfc_error + ("io-unit in %s statement at %C must be an internal file in a " + "PURE procedure", io_kind_name (k)); + m = MATCH_ERROR; + goto cleanup; + } + + new_st.op = (k == M_READ) ? EXEC_READ : EXEC_WRITE; + new_st.ext.dt = dt; + new_st.next = io_code; + + terminate_io (io_code); + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in %s statement at %C", io_kind_name (k)); + m = MATCH_ERROR; + +cleanup: + gfc_free_dt (dt); + return m; +} + + +match +gfc_match_read (void) +{ + return match_io (M_READ); +} + +match +gfc_match_write (void) +{ + return match_io (M_WRITE); +} + +match +gfc_match_print (void) +{ + match m; + + m = match_io (M_PRINT); + if (m != MATCH_YES) + return m; + + if (gfc_pure (NULL)) + { + gfc_error ("PRINT statement at %C not allowed within PURE procedure"); + return MATCH_ERROR; + } + + return MATCH_YES; +} + + +/* Free a gfc_inquire structure. */ + +void +gfc_free_inquire (gfc_inquire * inquire) +{ + + if (inquire == NULL) + return; + + gfc_free_expr (inquire->unit); + gfc_free_expr (inquire->file); + gfc_free_expr (inquire->iostat); + gfc_free_expr (inquire->exist); + gfc_free_expr (inquire->opened); + gfc_free_expr (inquire->number); + gfc_free_expr (inquire->named); + gfc_free_expr (inquire->name); + gfc_free_expr (inquire->access); + gfc_free_expr (inquire->sequential); + gfc_free_expr (inquire->direct); + gfc_free_expr (inquire->form); + gfc_free_expr (inquire->formatted); + gfc_free_expr (inquire->unformatted); + gfc_free_expr (inquire->recl); + gfc_free_expr (inquire->nextrec); + gfc_free_expr (inquire->blank); + gfc_free_expr (inquire->position); + gfc_free_expr (inquire->action); + gfc_free_expr (inquire->read); + gfc_free_expr (inquire->write); + gfc_free_expr (inquire->readwrite); + gfc_free_expr (inquire->delim); + gfc_free_expr (inquire->pad); + gfc_free_expr (inquire->iolength); + + gfc_free (inquire); +} + + +/* Match an element of an INQUIRE statement. */ + +#define RETM if (m != MATCH_NO) return m; + +static match +match_inquire_element (gfc_inquire * inquire) +{ + match m; + + m = match_etag (&tag_unit, &inquire->unit); + RETM m = match_etag (&tag_file, &inquire->file); + RETM m = match_ltag (&tag_err, &inquire->err); + RETM m = match_vtag (&tag_iostat, &inquire->iostat); + RETM m = match_vtag (&tag_exist, &inquire->exist); + RETM m = match_vtag (&tag_opened, &inquire->opened); + RETM m = match_vtag (&tag_named, &inquire->named); + RETM m = match_vtag (&tag_name, &inquire->name); + RETM m = match_vtag (&tag_number, &inquire->number); + RETM m = match_vtag (&tag_s_access, &inquire->access); + RETM m = match_vtag (&tag_sequential, &inquire->sequential); + RETM m = match_vtag (&tag_direct, &inquire->direct); + RETM m = match_vtag (&tag_s_form, &inquire->form); + RETM m = match_vtag (&tag_formatted, &inquire->formatted); + RETM m = match_vtag (&tag_unformatted, &inquire->unformatted); + RETM m = match_vtag (&tag_s_recl, &inquire->recl); + RETM m = match_vtag (&tag_nextrec, &inquire->nextrec); + RETM m = match_vtag (&tag_s_blank, &inquire->blank); + RETM m = match_vtag (&tag_s_position, &inquire->position); + RETM m = match_vtag (&tag_s_action, &inquire->action); + RETM m = match_vtag (&tag_read, &inquire->read); + RETM m = match_vtag (&tag_write, &inquire->write); + RETM m = match_vtag (&tag_readwrite, &inquire->readwrite); + RETM m = match_vtag (&tag_s_delim, &inquire->delim); + RETM m = match_vtag (&tag_s_pad, &inquire->pad); + RETM m = match_vtag (&tag_iolength, &inquire->iolength); + RETM return MATCH_NO; +} + +#undef RETM + + +match +gfc_match_inquire (void) +{ + gfc_inquire *inquire; + gfc_code *code; + match m; + + m = gfc_match_char ('('); + if (m == MATCH_NO) + return m; + + inquire = gfc_getmem (sizeof (gfc_inquire)); + + m = match_inquire_element (inquire); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + m = gfc_match_expr (&inquire->unit); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + + /* See if we have the IOLENGTH form of the inquire statement. */ + if (inquire->iolength != NULL) + { + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + m = match_io_list (M_INQUIRE, &code); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + terminate_io (code); + + new_st.op = EXEC_IOLENGTH; + new_st.expr = inquire->iolength; + gfc_free (inquire); + + if (gfc_pure (NULL)) + { + gfc_free_statements (code); + gfc_error ("INQUIRE statement not allowed in PURE procedure at %C"); + return MATCH_ERROR; + } + + new_st.next = code; + return MATCH_YES; + } + + /* At this point, we have the non-IOLENGTH inquire statement. */ + for (;;) + { + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = match_inquire_element (inquire); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + if (inquire->iolength != NULL) + { + gfc_error ("IOLENGTH tag invalid in INQUIRE statement at %C"); + goto cleanup; + } + } + + if (gfc_match_eos () != MATCH_YES) + goto syntax; + + if (gfc_pure (NULL)) + { + gfc_error ("INQUIRE statement not allowed in PURE procedure at %C"); + goto cleanup; + } + + new_st.op = EXEC_INQUIRE; + new_st.ext.inquire = inquire; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_INQUIRE); + +cleanup: + gfc_free_inquire (inquire); + return MATCH_ERROR; +} + + +/* Resolve everything in a gfc_inquire structure. */ + +try +gfc_resolve_inquire (gfc_inquire * inquire) +{ + + RESOLVE_TAG (&tag_unit, inquire->unit); + RESOLVE_TAG (&tag_file, inquire->file); + RESOLVE_TAG (&tag_iostat, inquire->iostat); + RESOLVE_TAG (&tag_exist, inquire->exist); + RESOLVE_TAG (&tag_opened, inquire->opened); + RESOLVE_TAG (&tag_number, inquire->number); + RESOLVE_TAG (&tag_named, inquire->named); + RESOLVE_TAG (&tag_name, inquire->name); + RESOLVE_TAG (&tag_s_access, inquire->access); + RESOLVE_TAG (&tag_sequential, inquire->sequential); + RESOLVE_TAG (&tag_direct, inquire->direct); + RESOLVE_TAG (&tag_s_form, inquire->form); + RESOLVE_TAG (&tag_formatted, inquire->formatted); + RESOLVE_TAG (&tag_unformatted, inquire->unformatted); + RESOLVE_TAG (&tag_s_recl, inquire->recl); + RESOLVE_TAG (&tag_nextrec, inquire->nextrec); + RESOLVE_TAG (&tag_s_blank, inquire->blank); + RESOLVE_TAG (&tag_s_position, inquire->position); + RESOLVE_TAG (&tag_s_action, inquire->action); + RESOLVE_TAG (&tag_read, inquire->read); + RESOLVE_TAG (&tag_write, inquire->write); + RESOLVE_TAG (&tag_readwrite, inquire->readwrite); + RESOLVE_TAG (&tag_s_delim, inquire->delim); + RESOLVE_TAG (&tag_s_pad, inquire->pad); + + if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE) + return FAILURE; + + return FAILURE; +} diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c new file mode 100644 index 00000000000..24205939d3b --- /dev/null +++ b/gcc/fortran/iresolve.c @@ -0,0 +1,1377 @@ +/* Intrinsic function resolution. + Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. + Contributed by Andy Vaught & Katherine Holcomb + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +/* Assign name and types to intrinsic procedures. For functions, the + first argument to a resolution function is an expression pointer to + the original function node and the rest are pointers to the + arguments of the function call. For subroutines, a pointer to the + code node is passed. The result type and library subroutine name + are generally set according to the function arguments. */ + +#include "config.h" +#include <string.h> +#include <stdarg.h> + +#include "gfortran.h" +#include "intrinsic.h" + + +/* String pool subroutines. This are used to provide static locations + for the string constants that represent library function names. */ + +typedef struct string_node +{ + struct string_node *next; + char string[1]; +} +string_node; + +#define HASH_SIZE 13 + +static string_node *string_head[HASH_SIZE]; + + +/* Return a hash code based on the name. */ + +static int +hash (const char *name) +{ + int h; + + h = 1; + while (*name) + h = 5311966 * h + *name++; + + if (h < 0) + h = -h; + return h % HASH_SIZE; +} + + +/* Given printf-like arguments, return a static address of the + resulting string. If the name is not in the table, it is added. */ + +char * +gfc_get_string (const char *format, ...) +{ + char temp_name[50]; + string_node *p; + va_list ap; + int h; + + va_start (ap, format); + vsprintf (temp_name, format, ap); + va_end (ap); + + h = hash (temp_name); + + /* Search */ + for (p = string_head[h]; p; p = p->next) + if (strcmp (p->string, temp_name) == 0) + return p->string; + + /* Add */ + p = gfc_getmem (sizeof (string_node) + strlen (temp_name)); + + strcpy (p->string, temp_name); + + p->next = string_head[h]; + string_head[h] = p; + + return p->string; +} + + + +static void +free_strings (void) +{ + string_node *p, *q; + int h; + + for (h = 0; h < HASH_SIZE; h++) + { + for (p = string_head[h]; p; p = q) + { + q = p->next; + gfc_free (p); + } + } +} + + +/********************** Resolution functions **********************/ + + +void +gfc_resolve_abs (gfc_expr * f, gfc_expr * a) +{ + + f->ts = a->ts; + if (f->ts.type == BT_COMPLEX) + f->ts.type = BT_REAL; + + f->value.function.name = + gfc_get_string ("__abs_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_acos (gfc_expr * f, gfc_expr * x) +{ + + f->ts = x->ts; + f->value.function.name = + gfc_get_string ("__acos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_aimag (gfc_expr * f, gfc_expr * x) +{ + + f->ts.type = BT_REAL; + f->ts.kind = x->ts.kind; + f->value.function.name = + gfc_get_string ("__aimag_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind) +{ + + f->ts.type = a->ts.type; + f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer); + + /* The resolved name is only used for specific intrinsics where + the return kind is the same as the arg kind. */ + f->value.function.name = + gfc_get_string ("__aint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_dint (gfc_expr * f, gfc_expr * a) +{ + gfc_resolve_aint (f, a, NULL); +} + + +void +gfc_resolve_all (gfc_expr * f, gfc_expr * mask, gfc_expr * dim) +{ + + f->ts = mask->ts; + + if (dim != NULL) + { + gfc_resolve_index (dim, 1); + f->rank = mask->rank - 1; + } + + f->value.function.name = + gfc_get_string ("__all_%c%d", gfc_type_letter (mask->ts.type), + mask->ts.kind); +} + + +void +gfc_resolve_anint (gfc_expr * f, gfc_expr * a, gfc_expr * kind) +{ + + f->ts.type = a->ts.type; + f->ts.kind = (kind == NULL) ? a->ts.kind : mpz_get_si (kind->value.integer); + + /* The resolved name is only used for specific intrinsics where + the return kind is the same as the arg kind. */ + f->value.function.name = + gfc_get_string ("__anint_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_dnint (gfc_expr * f, gfc_expr * a) +{ + gfc_resolve_anint (f, a, NULL); +} + + +void +gfc_resolve_any (gfc_expr * f, gfc_expr * mask, gfc_expr * dim) +{ + + f->ts = mask->ts; + + if (dim != NULL) + { + gfc_resolve_index (dim, 1); + f->rank = mask->rank - 1; + } + + f->value.function.name = + gfc_get_string ("__any_%c%d", gfc_type_letter (mask->ts.type), + mask->ts.kind); +} + + +void +gfc_resolve_asin (gfc_expr * f, gfc_expr * x) +{ + + f->ts = x->ts; + f->value.function.name = + gfc_get_string ("__asin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_atan (gfc_expr * f, gfc_expr * x) +{ + + f->ts = x->ts; + f->value.function.name = + gfc_get_string ("__atan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_atan2 (gfc_expr * f, gfc_expr * x, + gfc_expr * y ATTRIBUTE_UNUSED) +{ + + f->ts = x->ts; + f->value.function.name = + gfc_get_string ("__atan2_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_btest (gfc_expr * f, gfc_expr * i, gfc_expr * pos) +{ + + f->ts.type = BT_LOGICAL; + f->ts.kind = gfc_default_logical_kind (); + + f->value.function.name = gfc_get_string ("__btest_%d_%d", i->ts.kind, + pos->ts.kind); +} + + +void +gfc_resolve_ceiling (gfc_expr * f, gfc_expr * a, gfc_expr * kind) +{ + + f->ts.type = BT_INTEGER; + f->ts.kind = (kind == NULL) ? gfc_default_integer_kind () + : mpz_get_si (kind->value.integer); + + f->value.function.name = + gfc_get_string ("__ceiling_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind) +{ + + f->ts.type = BT_CHARACTER; + f->ts.kind = (kind == NULL) ? gfc_default_character_kind () + : mpz_get_si (kind->value.integer); + + f->value.function.name = + gfc_get_string ("__char_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind) +{ + + f->ts.type = BT_COMPLEX; + f->ts.kind = (kind == NULL) ? gfc_default_real_kind () + : mpz_get_si (kind->value.integer); + + if (y == NULL) + f->value.function.name = + gfc_get_string ("__cmplx0_%d_%c%d", f->ts.kind, + gfc_type_letter (x->ts.type), x->ts.kind); + else + f->value.function.name = + gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind, + gfc_type_letter (x->ts.type), x->ts.kind, + gfc_type_letter (y->ts.type), y->ts.kind); +} + +void +gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y) +{ + gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind ())); +} + +void +gfc_resolve_conjg (gfc_expr * f, gfc_expr * x) +{ + + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__conjg_%d", x->ts.kind); +} + + +void +gfc_resolve_cos (gfc_expr * f, gfc_expr * x) +{ + + f->ts = x->ts; + f->value.function.name = + gfc_get_string ("__cos_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_cosh (gfc_expr * f, gfc_expr * x) +{ + + f->ts = x->ts; + f->value.function.name = + gfc_get_string ("__cosh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_count (gfc_expr * f, gfc_expr * mask, gfc_expr * dim) +{ + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind (); + + if (dim != NULL) + { + f->rank = mask->rank - 1; + gfc_resolve_index (dim, 1); + } + + f->value.function.name = + gfc_get_string ("__count_%d_%c%d", f->ts.kind, + gfc_type_letter (mask->ts.type), mask->ts.kind); +} + + +void +gfc_resolve_cshift (gfc_expr * f, gfc_expr * array, + gfc_expr * shift, + gfc_expr * dim) +{ + int n; + + f->ts = array->ts; + f->rank = array->rank; + + if (shift->rank > 0) + n = 1; + else + n = 0; + + if (dim != NULL) + { + gfc_resolve_index (dim, 1); + /* Convert dim to shift's kind, so we don't need so many variations. */ + if (dim->ts.kind != shift->ts.kind) + gfc_convert_type (dim, &shift->ts, 2); + } + f->value.function.name = + gfc_get_string ("__cshift%d_%d", n, shift->ts.kind); +} + + +void +gfc_resolve_dble (gfc_expr * f, gfc_expr * a) +{ + + f->ts.type = BT_REAL; + f->ts.kind = gfc_default_double_kind (); + f->value.function.name = + gfc_get_string ("__dble_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_dim (gfc_expr * f, gfc_expr * x, + gfc_expr * y ATTRIBUTE_UNUSED) +{ + + f->ts = x->ts; + f->value.function.name = + gfc_get_string ("__dim_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_dot_product (gfc_expr * f, gfc_expr * a, gfc_expr * b) +{ + gfc_expr temp; + + if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL) + { + f->ts.type = BT_LOGICAL; + f->ts.kind = gfc_default_logical_kind (); + } + else + { + temp.expr_type = EXPR_OP; + gfc_clear_ts (&temp.ts); + temp.operator = INTRINSIC_NONE; + temp.op1 = a; + temp.op2 = b; + gfc_type_convert_binary (&temp); + f->ts = temp.ts; + } + + f->value.function.name = + gfc_get_string ("__dot_product_%c%d", gfc_type_letter (f->ts.type), + f->ts.kind); +} + + +void +gfc_resolve_dprod (gfc_expr * f, + gfc_expr * a ATTRIBUTE_UNUSED, + gfc_expr * b ATTRIBUTE_UNUSED) +{ + f->ts.kind = gfc_default_double_kind (); + f->ts.type = BT_REAL; + + f->value.function.name = gfc_get_string ("__dprod_r%d", f->ts.kind); +} + + +void +gfc_resolve_eoshift (gfc_expr * f, gfc_expr * array, + gfc_expr * shift, + gfc_expr * boundary, + gfc_expr * dim) +{ + int n; + + f->ts = array->ts; + f->rank = array->rank; + + n = 0; + if (shift->rank > 0) + n = n | 1; + if (boundary && boundary->rank > 0) + n = n | 2; + + /* Convert dim to the same type as shift, so we don't need quite so many + variations. */ + if (dim != NULL && dim->ts.kind != shift->ts.kind) + gfc_convert_type (dim, &shift->ts, 2); + + f->value.function.name = + gfc_get_string ("__eoshift%d_%d", n, shift->ts.kind); +} + + +void +gfc_resolve_exp (gfc_expr * f, gfc_expr * x) +{ + + f->ts = x->ts; + f->value.function.name = + gfc_get_string ("__exp_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_exponent (gfc_expr * f, gfc_expr * x) +{ + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind (); + + f->value.function.name = gfc_get_string ("__exponent_%d", x->ts.kind); +} + + +void +gfc_resolve_floor (gfc_expr * f, gfc_expr * a, gfc_expr * kind) +{ + + f->ts.type = BT_INTEGER; + f->ts.kind = (kind == NULL) ? gfc_default_integer_kind () + : mpz_get_si (kind->value.integer); + + f->value.function.name = + gfc_get_string ("__floor%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_fraction (gfc_expr * f, gfc_expr * x) +{ + + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__fraction_%d", x->ts.kind); +} + + +void +gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j ATTRIBUTE_UNUSED) +{ + + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__iand_%d", i->ts.kind); +} + + +void +gfc_resolve_ibclr (gfc_expr * f, gfc_expr * i, gfc_expr * pos ATTRIBUTE_UNUSED) +{ + + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__ibclr_%d", i->ts.kind); +} + + +void +gfc_resolve_ibits (gfc_expr * f, gfc_expr * i, + gfc_expr * pos ATTRIBUTE_UNUSED, + gfc_expr * len ATTRIBUTE_UNUSED) +{ + + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__ibits_%d", i->ts.kind); +} + + +void +gfc_resolve_ibset (gfc_expr * f, gfc_expr * i, + gfc_expr * pos ATTRIBUTE_UNUSED) +{ + + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__ibset_%d", i->ts.kind); +} + + +void +gfc_resolve_ichar (gfc_expr * f, gfc_expr * c) +{ + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind (); + + f->value.function.name = gfc_get_string ("__ichar_%d", c->ts.kind); +} + + +void +gfc_resolve_idnint (gfc_expr * f, gfc_expr * a) +{ + gfc_resolve_nint (f, a, NULL); +} + + +void +gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, + gfc_expr * j ATTRIBUTE_UNUSED) +{ + + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__ieor_%d", i->ts.kind); +} + + +void +gfc_resolve_ior (gfc_expr * f, gfc_expr * i, + gfc_expr * j ATTRIBUTE_UNUSED) +{ + + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__ior_%d", i->ts.kind); +} + + +void +gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind) +{ + + f->ts.type = BT_INTEGER; + f->ts.kind = (kind == NULL) ? gfc_default_integer_kind () + : mpz_get_si (kind->value.integer); + + f->value.function.name = + gfc_get_string ("__int_%d_%c%d", f->ts.kind, gfc_type_letter (a->ts.type), + a->ts.kind); +} + + +void +gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift) +{ + + f->ts = i->ts; + f->value.function.name = + gfc_get_string ("__ishft_%d_%d", i->ts.kind, shift->ts.kind); +} + + +void +gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift, + gfc_expr * size) +{ + int s_kind; + + s_kind = (size == NULL) ? gfc_default_integer_kind () : shift->ts.kind; + + f->ts = i->ts; + f->value.function.name = + gfc_get_string ("__ishftc_%d_%d_%d", i->ts.kind, shift->ts.kind, s_kind); +} + + +void +gfc_resolve_lbound (gfc_expr * f, gfc_expr * array ATTRIBUTE_UNUSED, + gfc_expr * dim) +{ + static char lbound[] = "__lbound"; + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind (); + + f->rank = (dim == NULL) ? 1 : 0; + f->value.function.name = lbound; +} + + +void +gfc_resolve_len (gfc_expr * f, gfc_expr * string) +{ + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind (); + f->value.function.name = gfc_get_string ("__len_%d", string->ts.kind); +} + + +void +gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string) +{ + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind (); + f->value.function.name = gfc_get_string ("__len_trim%d", string->ts.kind); +} + + +void +gfc_resolve_log (gfc_expr * f, gfc_expr * x) +{ + + f->ts = x->ts; + f->value.function.name = + gfc_get_string ("__log_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_log10 (gfc_expr * f, gfc_expr * x) +{ + + f->ts = x->ts; + f->value.function.name = + gfc_get_string ("__log10_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_logical (gfc_expr * f, gfc_expr * a, gfc_expr * kind) +{ + + f->ts.type = BT_LOGICAL; + f->ts.kind = (kind == NULL) ? gfc_default_logical_kind () + : mpz_get_si (kind->value.integer); + f->rank = a->rank; + + f->value.function.name = + gfc_get_string ("__logical_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_matmul (gfc_expr * f, gfc_expr * a, gfc_expr * b) +{ + gfc_expr temp; + + if (a->ts.type == BT_LOGICAL && b->ts.type == BT_LOGICAL) + { + f->ts.type = BT_LOGICAL; + f->ts.kind = gfc_default_logical_kind (); + } + else + { + temp.expr_type = EXPR_OP; + gfc_clear_ts (&temp.ts); + temp.operator = INTRINSIC_NONE; + temp.op1 = a; + temp.op2 = b; + gfc_type_convert_binary (&temp); + f->ts = temp.ts; + } + + f->rank = (a->rank == 2 && b->rank == 2) ? 2 : 1; + + f->value.function.name = + gfc_get_string ("__matmul_%c%d", gfc_type_letter (f->ts.type), + f->ts.kind); +} + + +static void +gfc_resolve_minmax (const char * name, gfc_expr * f, gfc_actual_arglist * args) +{ + gfc_actual_arglist *a; + + f->ts.type = args->expr->ts.type; + f->ts.kind = args->expr->ts.kind; + /* Find the largest type kind. */ + for (a = args->next; a; a = a->next) + { + if (a->expr->ts.kind > f->ts.kind) + f->ts.kind = a->expr->ts.kind; + } + + /* Convert all parameters to the required kind. */ + for (a = args; a; a = a->next) + { + if (a->expr->ts.kind != f->ts.kind) + gfc_convert_type (a->expr, &f->ts, 2); + } + + f->value.function.name = + gfc_get_string (name, gfc_type_letter (f->ts.type), f->ts.kind); +} + + +void +gfc_resolve_max (gfc_expr * f, gfc_actual_arglist * args) +{ + gfc_resolve_minmax ("__max_%c%d", f, args); +} + + +void +gfc_resolve_maxloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim, + gfc_expr * mask) +{ + const char *name; + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind (); + + if (dim == NULL) + f->rank = 1; + else + { + f->rank = array->rank - 1; + gfc_resolve_index (dim, 1); + } + + name = mask ? "mmaxloc" : "maxloc"; + f->value.function.name = + gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind, + gfc_type_letter (array->ts.type), array->ts.kind); +} + + +void +gfc_resolve_maxval (gfc_expr * f, gfc_expr * array, gfc_expr * dim, + gfc_expr * mask) +{ + + f->ts = array->ts; + + if (dim != NULL) + { + f->rank = array->rank - 1; + gfc_resolve_index (dim, 1); + } + + f->value.function.name = + gfc_get_string ("__%s_%c%d", mask ? "mmaxval" : "maxval", + gfc_type_letter (array->ts.type), array->ts.kind); +} + + +void +gfc_resolve_merge (gfc_expr * f, gfc_expr * tsource, + gfc_expr * fsource ATTRIBUTE_UNUSED, + gfc_expr * mask ATTRIBUTE_UNUSED) +{ + + f->ts = tsource->ts; + f->value.function.name = + gfc_get_string ("__merge_%c%d", gfc_type_letter (tsource->ts.type), + tsource->ts.kind); +} + + +void +gfc_resolve_min (gfc_expr * f, gfc_actual_arglist * args) +{ + gfc_resolve_minmax ("__min_%c%d", f, args); +} + + +void +gfc_resolve_minloc (gfc_expr * f, gfc_expr * array, gfc_expr * dim, + gfc_expr * mask) +{ + const char *name; + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind (); + + if (dim == NULL) + f->rank = 1; + else + { + f->rank = array->rank - 1; + gfc_resolve_index (dim, 1); + } + + name = mask ? "mminloc" : "minloc"; + f->value.function.name = + gfc_get_string ("__%s%d_%d_%c%d", name, dim != NULL, f->ts.kind, + gfc_type_letter (array->ts.type), array->ts.kind); +} + +void +gfc_resolve_minval (gfc_expr * f, gfc_expr * array, gfc_expr * dim, + gfc_expr * mask) +{ + + f->ts = array->ts; + + if (dim != NULL) + { + f->rank = array->rank - 1; + gfc_resolve_index (dim, 1); + } + + f->value.function.name = + gfc_get_string ("__%s_%c%d", mask ? "mminval" : "minval", + gfc_type_letter (array->ts.type), array->ts.kind); +} + + +void +gfc_resolve_mod (gfc_expr * f, gfc_expr * a, + gfc_expr * p ATTRIBUTE_UNUSED) +{ + + f->ts = a->ts; + f->value.function.name = + gfc_get_string ("__mod_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_modulo (gfc_expr * f, gfc_expr * a, + gfc_expr * p ATTRIBUTE_UNUSED) +{ + + f->ts = a->ts; + f->value.function.name = + gfc_get_string ("__modulo_%c%d", gfc_type_letter (a->ts.type), + a->ts.kind); +} + + +void +gfc_resolve_nint (gfc_expr * f, gfc_expr * a, gfc_expr * kind) +{ + + f->ts.type = BT_INTEGER; + f->ts.kind = (kind == NULL) ? gfc_default_integer_kind () + : mpz_get_si (kind->value.integer); + + f->value.function.name = + gfc_get_string ("__nint_%d_%d", f->ts.kind, a->ts.kind); +} + + +void +gfc_resolve_not (gfc_expr * f, gfc_expr * i) +{ + + f->ts = i->ts; + f->value.function.name = gfc_get_string ("__not_%d", i->ts.kind); +} + + +void +gfc_resolve_pack (gfc_expr * f, + gfc_expr * array ATTRIBUTE_UNUSED, + gfc_expr * mask ATTRIBUTE_UNUSED, + gfc_expr * vector ATTRIBUTE_UNUSED) +{ + static char pack[] = "__pack"; + + f->ts = array->ts; + f->rank = 1; + + f->value.function.name = pack; +} + + +void +gfc_resolve_product (gfc_expr * f, gfc_expr * array, gfc_expr * dim, + gfc_expr * mask) +{ + + f->ts = array->ts; + + if (dim != NULL) + { + f->rank = array->rank - 1; + gfc_resolve_index (dim, 1); + } + + f->value.function.name = + gfc_get_string ("__%s_%c%d", mask ? "mproduct" : "product", + gfc_type_letter (array->ts.type), array->ts.kind); +} + + +void +gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind) +{ + + f->ts.type = BT_REAL; + + if (kind != NULL) + f->ts.kind = mpz_get_si (kind->value.integer); + else + f->ts.kind = (a->ts.type == BT_COMPLEX) ? + a->ts.kind : gfc_default_real_kind (); + + f->value.function.name = + gfc_get_string ("__real_%d_%c%d", f->ts.kind, + gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_repeat (gfc_expr * f, gfc_expr * string, + gfc_expr * ncopies ATTRIBUTE_UNUSED) +{ + + f->ts.type = BT_CHARACTER; + f->ts.kind = string->ts.kind; + f->value.function.name = gfc_get_string ("__repeat_%d", string->ts.kind); +} + + +void +gfc_resolve_reshape (gfc_expr * f, gfc_expr * source, gfc_expr * shape, + gfc_expr * pad ATTRIBUTE_UNUSED, + gfc_expr * order ATTRIBUTE_UNUSED) +{ + static char reshape0[] = "__reshape"; + mpz_t rank; + int kind; + int i; + + f->ts = source->ts; + + gfc_array_size (shape, &rank); + f->rank = mpz_get_si (rank); + mpz_clear (rank); + switch (source->ts.type) + { + case BT_COMPLEX: + kind = source->ts.kind * 2; + break; + + case BT_REAL: + case BT_INTEGER: + case BT_LOGICAL: + kind = source->ts.kind; + break; + + default: + kind = 0; + break; + } + + switch (kind) + { + case 4: + case 8: + /* case 16: */ + f->value.function.name = + gfc_get_string ("__reshape_%d", source->ts.kind); + break; + + default: + f->value.function.name = reshape0; + break; + } + + /* TODO: Make this work with a constant ORDER parameter. */ + if (shape->expr_type == EXPR_ARRAY + && gfc_is_constant_expr (shape) + && order == NULL) + { + gfc_constructor *c; + f->shape = gfc_get_shape (f->rank); + c = shape->value.constructor; + for (i = 0; i < f->rank; i++) + { + mpz_init_set (f->shape[i], c->expr->value.integer); + c = c->next; + } + } +} + + +void +gfc_resolve_rrspacing (gfc_expr * f, gfc_expr * x) +{ + + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__rrspacing_%d", x->ts.kind); +} + + +void +gfc_resolve_scale (gfc_expr * f, gfc_expr * x, + gfc_expr * y ATTRIBUTE_UNUSED) +{ + + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__scale_%d_%d", x->ts.kind, + x->ts.kind); +} + + +void +gfc_resolve_scan (gfc_expr * f, gfc_expr * string, + gfc_expr * set ATTRIBUTE_UNUSED, + gfc_expr * back ATTRIBUTE_UNUSED) +{ + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind (); + f->value.function.name = gfc_get_string ("__scan_%d", string->ts.kind); +} + + +void +gfc_resolve_set_exponent (gfc_expr * f, gfc_expr * x, gfc_expr * i) +{ + + f->ts = x->ts; + f->value.function.name = + gfc_get_string ("__set_exponent_%d_%d", x->ts.kind, i->ts.kind); +} + + +void +gfc_resolve_shape (gfc_expr * f, gfc_expr * array) +{ + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind (); + f->rank = 1; + f->value.function.name = gfc_get_string ("__shape_%d", f->ts.kind); + f->shape = gfc_get_shape (1); + mpz_init_set_ui (f->shape[0], array->rank); +} + + +void +gfc_resolve_sign (gfc_expr * f, gfc_expr * a, gfc_expr * b ATTRIBUTE_UNUSED) +{ + + f->ts = a->ts; + f->value.function.name = + gfc_get_string ("__sign_%c%d", gfc_type_letter (a->ts.type), a->ts.kind); +} + + +void +gfc_resolve_sin (gfc_expr * f, gfc_expr * x) +{ + + f->ts = x->ts; + f->value.function.name = + gfc_get_string ("__sin_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_sinh (gfc_expr * f, gfc_expr * x) +{ + + f->ts = x->ts; + f->value.function.name = + gfc_get_string ("__sinh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_spacing (gfc_expr * f, gfc_expr * x) +{ + + f->ts = x->ts; + f->value.function.name = gfc_get_string ("__spacing_%d", x->ts.kind); +} + + +void +gfc_resolve_spread (gfc_expr * f, gfc_expr * source, + gfc_expr * dim, + gfc_expr * ncopies) +{ + static char spread[] = "__spread"; + + f->ts = source->ts; + f->rank = source->rank + 1; + f->value.function.name = spread; + + gfc_resolve_index (dim, 1); + gfc_resolve_index (ncopies, 1); +} + + +void +gfc_resolve_sqrt (gfc_expr * f, gfc_expr * x) +{ + + f->ts = x->ts; + f->value.function.name = + gfc_get_string ("__sqrt_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim, + gfc_expr * mask) +{ + + f->ts = array->ts; + + if (dim != NULL) + { + f->rank = array->rank - 1; + gfc_resolve_index (dim, 1); + } + + f->value.function.name = + gfc_get_string ("__%s_%c%d", mask ? "msum" : "sum", + gfc_type_letter (array->ts.type), array->ts.kind); +} + + +void +gfc_resolve_tan (gfc_expr * f, gfc_expr * x) +{ + + f->ts = x->ts; + f->value.function.name = + gfc_get_string ("__tan_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_tanh (gfc_expr * f, gfc_expr * x) +{ + + f->ts = x->ts; + f->value.function.name = + gfc_get_string ("__tanh_%c%d", gfc_type_letter (x->ts.type), x->ts.kind); +} + + +void +gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED, + gfc_expr * mold, gfc_expr * size) +{ + /* TODO: Make this do something meaningful. */ + static char transfer0[] = "__transfer0", transfer1[] = "__transfer1"; + + f->ts = mold->ts; + + if (size == NULL && mold->rank == 0) + { + f->rank = 0; + f->value.function.name = transfer0; + } + else + { + f->rank = 1; + f->value.function.name = transfer1; + } +} + + +void +gfc_resolve_transpose (gfc_expr * f, gfc_expr * matrix) +{ + static char transpose0[] = "__transpose"; + int kind; + + f->ts = matrix->ts; + f->rank = 2; + + switch (matrix->ts.type) + { + case BT_COMPLEX: + kind = matrix->ts.kind * 2; + break; + + case BT_REAL: + case BT_INTEGER: + case BT_LOGICAL: + kind = matrix->ts.kind; + break; + + default: + kind = 0; + break; + + } + + switch (kind) + { + case 4: + case 8: + /* case 16: */ + f->value.function.name = + gfc_get_string ("__transpose_%d", kind); + break; + + default: + f->value.function.name = transpose0; + } +} + + +void +gfc_resolve_trim (gfc_expr * f, gfc_expr * string) +{ + + f->ts.type = BT_CHARACTER; + f->ts.kind = string->ts.kind; + f->value.function.name = gfc_get_string ("__trim_%d", string->ts.kind); +} + + +void +gfc_resolve_ubound (gfc_expr * f, gfc_expr * array ATTRIBUTE_UNUSED, + gfc_expr * dim) +{ + static char ubound[] = "__ubound"; + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind (); + + f->rank = (dim == NULL) ? 1 : 0; + f->value.function.name = ubound; +} + + +void +gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask, + gfc_expr * field ATTRIBUTE_UNUSED) +{ + + f->ts.type = vector->ts.type; + f->ts.kind = vector->ts.kind; + f->rank = mask->rank; + + f->value.function.name = + gfc_get_string ("__unpack%d", field->rank > 0 ? 1 : 0); +} + + +void +gfc_resolve_verify (gfc_expr * f, gfc_expr * string, + gfc_expr * set ATTRIBUTE_UNUSED, + gfc_expr * back ATTRIBUTE_UNUSED) +{ + + f->ts.type = BT_INTEGER; + f->ts.kind = gfc_default_integer_kind (); + f->value.function.name = gfc_get_string ("__verify_%d", string->ts.kind); +} + + +/* Intrinsic subroutine resolution. */ + +void +gfc_resolve_cpu_time (gfc_code * c ATTRIBUTE_UNUSED) +{ + const char *name; + + name = gfc_get_string (PREFIX("cpu_time_%d"), + c->ext.actual->expr->ts.kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED) +{ + const char *name; + int kind; + + kind = c->ext.actual->expr->ts.kind; + name = gfc_get_string ((c->ext.actual->expr->rank == 0) ? + PREFIX("random_r%d") : PREFIX("arandom_r%d"), + kind); + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} + + +void +gfc_iresolve_init_1 (void) +{ + int i; + + for (i = 0; i < HASH_SIZE; i++) + string_head[i] = NULL; +} + + +void +gfc_iresolve_done_1 (void) +{ + + free_strings (); +} diff --git a/gcc/fortran/lang-specs.h b/gcc/fortran/lang-specs.h new file mode 100644 index 00000000000..3d8d7c4cbca --- /dev/null +++ b/gcc/fortran/lang-specs.h @@ -0,0 +1,35 @@ +/* Contribution to the specs for the GNU Compiler Collection + from GNU Fortran 95 compiler. + Copyright (C) 2002,2004 Free Software Foundation, Inc. + +This file is licensed under the GPL. */ + +/* This is the contribution to the `default_compilers' array in gcc.c + for the f95 language. */ + +{".F", "@f77-cpp-input", 0}, +{".fpp", "@f77-cpp-input", 0}, +{".FPP", "@f77-cpp-input", 0}, +{"@f77-cpp-input", + "cc1 -P -E -traditional-cpp -D_LANGUAGE_FORTRAN %(cpp_options) \ + %{E|M|MM:%(cpp_debug_options)}\ + %{!M:%{!MM:%{!E: -o %|.f |\n\ + f951 %|.f %{!ffree-form:-ffixed-form} %(cc1_options) %{J*} %{I*}\ + %{!fsyntax-only:%(invoke_as)}}}}", 0}, +{".F90", "@f95-cpp-input", 0}, +{".F95", "@f95-cpp-input", 0}, +{"@f95-cpp-input", + "cc1 -P -E -traditional-cpp -D_LANGUAGE_FORTRAN %(cpp_options) \ + %{E|M|MM:%(cpp_debug_options)}\ + %{!M:%{!MM:%{!E: -o %|.f95 |\n\ + f951 %|.f95 %(cc1_options) %{J*} %{I*}\ + %{!fsyntax-only:%(invoke_as)}}}}", 0}, +{".f90", "@f95", 0}, +{".f95", "@f95", 0}, +{"@f95", "%{!E:f951 %i %(cc1_options) %{J*} %{I*}\ + %{!fsyntax-only:%(invoke_as)}}", 0}, +{".f", "@f77", 0}, +{".for", "@f77", 0}, +{".FOR", "@f77", 0}, +{"@f77", "%{!E:f951 %i %{!ffree-form:-ffixed-form} %(cc1_options) %{J*} %{I*}\ + %{!fsyntax-only:%(invoke_as)}}", 0}, diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt new file mode 100644 index 00000000000..593e3f15eed --- /dev/null +++ b/gcc/fortran/lang.opt @@ -0,0 +1,152 @@ +; Options for the Fortran 95 front end. +; Copyright (C) 2003 Free Software Foundation, Inc. +; +; This file is part of GCC. +; +; GCC is free software; you can redistribute it and/or modify it under +; the terms of the GNU General Public License as published by the Free +; Software Foundation; either version 2, or (at your option) any later +; version. +; +; GCC is distributed in the hope that it will be useful, but WITHOUT ANY +; WARRANTY; without even the implied warranty of MERCHANTABILITY or +; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +; for more details. +; +; You should have received a copy of the GNU General Public License +; along with GCC; see the file COPYING. If not, write to the Free +; Software Foundation, 59 Temple Place - Suite 330, Boston, MA +; 02111-1307, USA. + +; See c.opt for a description of this file's format. + +; Please try to keep this file in ASCII collating order. + +Language +F95 + +I +F95 Joined +-I<directory> Add a directory for INCLUDE and MODULE searching + +J +F95 Joined +-J<directory> Put MODULE files in 'directory' + +Wall +F95 RejectNegative +; Documented in C + +Waliasing +F95 +Warn about possible aliasing of dummy arguments + +Wconversion +F95 +Warn about implicit conversion + +Wimplicit-interface +F95 +Warn about calls with implicit interface + +Wline-truncation +F95 +Warn about truncated source lines + +Wsurprising +F95 +Warn about \"suspicious\" constructs + +Wunused-labels +F95 +Warn when a label is unused + +d8 +F95 RejectNegative +Set the default real and integer kinds to double precision + +fdollar-ok +F95 +Allow dollar signs in entity names + +fdump-parse-tree +F95 +Display the code tree after parsing. + +ffixed-form +F95 +Assume that the source file is fixed form + +ffree-form +F95 +Assume that the source file is free form + +funderscoring +F95 +Append underscores to externally visible names + +fsecond-underscore +F95 +Append a second underscore if the name already contains an underscore + +fimplicit-none +F95 +Specify that no implicit typing is allowed, unless overridden by explicit IMPLICIT statements + +ffixed-line-length-80 +F95 RejectNegative +Use 80 character line width in fixed mode + +ffixed-line-length-132 +F95 RejectNegative +Use 132 character line width in fixed mode + +fmax-identifier-length= +F95 RejectNegative Joined UInteger +-fmax-identifier-length=<n> Maximum identifier length. + +fmax-stack-var-size= +F95 RejectNegative Joined UInteger +-fmax-stack-var-size=<n> Size in bytes of the largest array that will be put on the stack + +fmodule-private +F95 +Set default accessibility of module entities to PRIVATE + +fno-backend +F95 RejectNegative +Don't generate code, just do syntax and semantics checking + +fpack-derived +F95 +Try to layout derived types as compact as possible + +frepack-arrays +F95 +Copy array sections into a contiguous block on procedure entry + +i8 +F95 +Set the default integer kind to double precision + +qkind= +F95 RejectNegative Joined UInteger +-qkind=<n> Set the kind for a real with the 'q' exponent to 'n' + +r8 +F95 +Set the default real kind to double precision + +std=f95 +F95 +Conform to the ISO Fortran 95 standard. + +std=f2003 +F95 +Conform to the ISO Fortran 2003 standard. + +std=gnu +F95 +Conform nothing in particular. + +; This comment is to ensure we retain the blank line above. diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c new file mode 100644 index 00000000000..3c7504159a9 --- /dev/null +++ b/gcc/fortran/match.c @@ -0,0 +1,3558 @@ +/* Matching subroutines in all sizes, shapes and colors. + Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#include "config.h" +#include "system.h" +#include "flags.h" + +#include <stdarg.h> +#include <string.h> + +#include "gfortran.h" +#include "match.h" +#include "parse.h" + +/* For matching and debugging purposes. Order matters here! The + unary operators /must/ precede the binary plus and minus, or + the expression parser breaks. */ + +mstring intrinsic_operators[] = { + minit ("+", INTRINSIC_UPLUS), + minit ("-", INTRINSIC_UMINUS), + minit ("+", INTRINSIC_PLUS), + minit ("-", INTRINSIC_MINUS), + minit ("**", INTRINSIC_POWER), + minit ("//", INTRINSIC_CONCAT), + minit ("*", INTRINSIC_TIMES), + minit ("/", INTRINSIC_DIVIDE), + minit (".and.", INTRINSIC_AND), + minit (".or.", INTRINSIC_OR), + minit (".eqv.", INTRINSIC_EQV), + minit (".neqv.", INTRINSIC_NEQV), + minit (".eq.", INTRINSIC_EQ), + minit ("==", INTRINSIC_EQ), + minit (".ne.", INTRINSIC_NE), + minit ("/=", INTRINSIC_NE), + minit (".ge.", INTRINSIC_GE), + minit (">=", INTRINSIC_GE), + minit (".le.", INTRINSIC_LE), + minit ("<=", INTRINSIC_LE), + minit (".lt.", INTRINSIC_LT), + minit ("<", INTRINSIC_LT), + minit (".gt.", INTRINSIC_GT), + minit (">", INTRINSIC_GT), + minit (".not.", INTRINSIC_NOT), + minit (NULL, INTRINSIC_NONE) +}; + + +/******************** Generic matching subroutines ************************/ + +/* In free form, match at least one space. Always matches in fixed + form. */ + +match +gfc_match_space (void) +{ + locus old_loc; + int c; + + if (gfc_current_file->form == FORM_FIXED) + return MATCH_YES; + + old_loc = *gfc_current_locus (); + + c = gfc_next_char (); + if (!gfc_is_whitespace (c)) + { + gfc_set_locus (&old_loc); + return MATCH_NO; + } + + gfc_gobble_whitespace (); + + return MATCH_YES; +} + + +/* Match an end of statement. End of statement is optional + whitespace, followed by a ';' or '\n' or comment '!'. If a + semicolon is found, we continue to eat whitespace and semicolons. */ + +match +gfc_match_eos (void) +{ + locus old_loc; + int flag, c; + + flag = 0; + + for (;;) + { + old_loc = *gfc_current_locus (); + gfc_gobble_whitespace (); + + c = gfc_next_char (); + switch (c) + { + case '!': + do + { + c = gfc_next_char (); + } + while (c != '\n'); + + /* Fall through */ + + case '\n': + return MATCH_YES; + + case ';': + flag = 1; + continue; + } + + break; + } + + gfc_set_locus (&old_loc); + return (flag) ? MATCH_YES : MATCH_NO; +} + + +/* Match a literal integer on the input, setting the value on + MATCH_YES. Literal ints occur in kind-parameters as well as + old-style character length specifications. */ + +match +gfc_match_small_literal_int (int *value) +{ + locus old_loc; + char c; + int i; + + old_loc = *gfc_current_locus (); + + gfc_gobble_whitespace (); + c = gfc_next_char (); + + if (!ISDIGIT (c)) + { + gfc_set_locus (&old_loc); + return MATCH_NO; + } + + i = c - '0'; + + for (;;) + { + old_loc = *gfc_current_locus (); + c = gfc_next_char (); + + if (!ISDIGIT (c)) + break; + + i = 10 * i + c - '0'; + + if (i > 99999999) + { + gfc_error ("Integer too large at %C"); + return MATCH_ERROR; + } + } + + gfc_set_locus (&old_loc); + + *value = i; + return MATCH_YES; +} + + +/* Match a small, constant integer expression, like in a kind + statement. On MATCH_YES, 'value' is set. */ + +match +gfc_match_small_int (int *value) +{ + gfc_expr *expr; + const char *p; + match m; + int i; + + m = gfc_match_expr (&expr); + if (m != MATCH_YES) + return m; + + p = gfc_extract_int (expr, &i); + gfc_free_expr (expr); + + if (p != NULL) + { + gfc_error (p); + m = MATCH_ERROR; + } + + *value = i; + return m; +} + + +/* Matches a statement label. Uses gfc_match_small_literal_int() to + do most of the work. */ + +match +gfc_match_st_label (gfc_st_label ** label, int allow_zero) +{ + locus old_loc; + match m; + int i; + + old_loc = *gfc_current_locus (); + + m = gfc_match_small_literal_int (&i); + if (m != MATCH_YES) + return m; + + if (((i == 0) && allow_zero) || i <= 99999) + { + *label = gfc_get_st_label (i); + return MATCH_YES; + } + + gfc_error ("Statement label at %C is out of range"); + gfc_set_locus (&old_loc); + return MATCH_ERROR; +} + + +/* Match and validate a label associated with a named IF, DO or SELECT + statement. If the symbol does not have the label attribute, we add + it. We also make sure the symbol does not refer to another + (active) block. A matched label is pointed to by gfc_new_block. */ + +match +gfc_match_label (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_state_data *p; + match m; + + gfc_new_block = NULL; + + m = gfc_match (" %n :", name); + if (m != MATCH_YES) + return m; + + if (gfc_get_symbol (name, NULL, &gfc_new_block)) + { + gfc_error ("Label name '%s' at %C is ambiguous", name); + return MATCH_ERROR; + } + + if (gfc_new_block->attr.flavor != FL_LABEL + && gfc_add_flavor (&gfc_new_block->attr, FL_LABEL, NULL) == FAILURE) + return MATCH_ERROR; + + for (p = gfc_state_stack; p; p = p->previous) + if (p->sym == gfc_new_block) + { + gfc_error ("Label %s at %C already in use by a parent block", + gfc_new_block->name); + return MATCH_ERROR; + } + + return MATCH_YES; +} + + +/* Try and match the input against an array of possibilities. If one + potential matching string is a substring of another, the longest + match takes precedence. Spaces in the target strings are optional + spaces that do not necessarily have to be found in the input + stream. In fixed mode, spaces never appear. If whitespace is + matched, it matches unlimited whitespace in the input. For this + reason, the 'mp' member of the mstring structure is used to track + the progress of each potential match. + + If there is no match we return the tag associated with the + terminating NULL mstring structure and leave the locus pointer + where it started. If there is a match we return the tag member of + the matched mstring and leave the locus pointer after the matched + character. + + A '%' character is a mandatory space. */ + +int +gfc_match_strings (mstring * a) +{ + mstring *p, *best_match; + int no_match, c, possibles; + locus match_loc; + + possibles = 0; + + for (p = a; p->string != NULL; p++) + { + p->mp = p->string; + possibles++; + } + + no_match = p->tag; + + best_match = NULL; + match_loc = *gfc_current_locus (); + + gfc_gobble_whitespace (); + + while (possibles > 0) + { + c = gfc_next_char (); + + /* Apply the next character to the current possibilities. */ + for (p = a; p->string != NULL; p++) + { + if (p->mp == NULL) + continue; + + if (*p->mp == ' ') + { + /* Space matches 1+ whitespace(s). */ + if ((gfc_current_file->form == FORM_FREE) + && gfc_is_whitespace (c)) + continue; + + p->mp++; + } + + if (*p->mp != c) + { + /* Match failed. */ + p->mp = NULL; + possibles--; + continue; + } + + p->mp++; + if (*p->mp == '\0') + { + /* Found a match. */ + match_loc = *gfc_current_locus (); + best_match = p; + possibles--; + p->mp = NULL; + } + } + } + + gfc_set_locus (&match_loc); + + return (best_match == NULL) ? no_match : best_match->tag; +} + + +/* See if the current input looks like a name of some sort. Modifies + the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long. */ + +match +gfc_match_name (char *buffer) +{ + locus old_loc; + int i, c; + + old_loc = *gfc_current_locus (); + gfc_gobble_whitespace (); + + c = gfc_next_char (); + if (!ISALPHA (c)) + { + gfc_set_locus (&old_loc); + return MATCH_NO; + } + + i = 0; + + do + { + buffer[i++] = c; + + if (i > gfc_option.max_identifier_length) + { + gfc_error ("Name at %C is too long"); + return MATCH_ERROR; + } + + old_loc = *gfc_current_locus (); + c = gfc_next_char (); + } + while (ISALNUM (c) + || c == '_' + || (gfc_option.flag_dollar_ok && c == '$')); + + buffer[i] = '\0'; + gfc_set_locus (&old_loc); + + return MATCH_YES; +} + + +/* Match a symbol on the input. Modifies the pointer to the symbol + pointer if successful. */ + +match +gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc) +{ + char buffer[GFC_MAX_SYMBOL_LEN + 1]; + match m; + + m = gfc_match_name (buffer); + if (m != MATCH_YES) + return m; + + if (host_assoc) + return (gfc_get_ha_sym_tree (buffer, matched_symbol)) + ? MATCH_ERROR : MATCH_YES; + + if (gfc_get_sym_tree (buffer, NULL, matched_symbol)) + return MATCH_ERROR; + + return MATCH_YES; +} + + +match +gfc_match_symbol (gfc_symbol ** matched_symbol, int host_assoc) +{ + gfc_symtree *st; + match m; + + m = gfc_match_sym_tree (&st, host_assoc); + + if (m == MATCH_YES) + { + if (st) + *matched_symbol = st->n.sym; + else + *matched_symbol = NULL; + } + return m; +} + +/* Match an intrinsic operator. Returns an INTRINSIC enum. While matching, + we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this + in matchexp.c. */ + +match +gfc_match_intrinsic_op (gfc_intrinsic_op * result) +{ + gfc_intrinsic_op op; + + op = (gfc_intrinsic_op) gfc_match_strings (intrinsic_operators); + + if (op == INTRINSIC_NONE) + return MATCH_NO; + + *result = op; + return MATCH_YES; +} + + +/* Match a loop control phrase: + + <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ] + + If the final integer expression is not present, a constant unity + expression is returned. We don't return MATCH_ERROR until after + the equals sign is seen. */ + +match +gfc_match_iterator (gfc_iterator * iter, int init_flag) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_expr *var, *e1, *e2, *e3; + locus start; + match m; + + /* Match the start of an iterator without affecting the symbol + table. */ + + start = *gfc_current_locus (); + m = gfc_match (" %n =", name); + gfc_set_locus (&start); + + if (m != MATCH_YES) + return MATCH_NO; + + m = gfc_match_variable (&var, 0); + if (m != MATCH_YES) + return MATCH_NO; + + gfc_match_char ('='); + + e1 = e2 = e3 = NULL; + + if (var->ref != NULL) + { + gfc_error ("Loop variable at %C cannot be a sub-component"); + goto cleanup; + } + + if (var->symtree->n.sym->attr.intent == INTENT_IN) + { + gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)", + var->symtree->n.sym->name); + goto cleanup; + } + + if (var->symtree->n.sym->attr.pointer) + { + gfc_error ("Loop variable at %C cannot have the POINTER attribute"); + goto cleanup; + } + + m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') != MATCH_YES) + { + e3 = gfc_int_expr (1); + goto done; + } + + m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + gfc_error ("Expected a step value in iterator at %C"); + goto cleanup; + } + +done: + iter->var = var; + iter->start = e1; + iter->end = e2; + iter->step = e3; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in iterator at %C"); + +cleanup: + gfc_free_expr (e1); + gfc_free_expr (e2); + gfc_free_expr (e3); + + return MATCH_ERROR; +} + + +/* Tries to match the next non-whitespace character on the input. + This subroutine does not return MATCH_ERROR. */ + +match +gfc_match_char (char c) +{ + locus where; + + where = *gfc_current_locus (); + gfc_gobble_whitespace (); + + if (gfc_next_char () == c) + return MATCH_YES; + + gfc_set_locus (&where); + return MATCH_NO; +} + + +/* General purpose matching subroutine. The target string is a + scanf-like format string in which spaces correspond to arbitrary + whitespace (including no whitespace), characters correspond to + themselves. The %-codes are: + + %% Literal percent sign + %e Expression, pointer to a pointer is set + %s Symbol, pointer to the symbol is set + %n Name, character buffer is set to name + %t Matches end of statement. + %o Matches an intrinsic operator, returned as an INTRINSIC enum. + %l Matches a statement label + %v Matches a variable expression (an lvalue) + % Matches a required space (in free form) and optional spaces. */ + +match +gfc_match (const char *target, ...) +{ + gfc_st_label **label; + int matches, *ip; + locus old_loc; + va_list argp; + char c, *np; + match m, n; + void **vp; + const char *p; + + old_loc = *gfc_current_locus (); + va_start (argp, target); + m = MATCH_NO; + matches = 0; + p = target; + +loop: + c = *p++; + switch (c) + { + case ' ': + gfc_gobble_whitespace (); + goto loop; + case '\0': + m = MATCH_YES; + break; + + case '%': + c = *p++; + switch (c) + { + case 'e': + vp = va_arg (argp, void **); + n = gfc_match_expr ((gfc_expr **) vp); + if (n != MATCH_YES) + { + m = n; + goto not_yes; + } + + matches++; + goto loop; + + case 'v': + vp = va_arg (argp, void **); + n = gfc_match_variable ((gfc_expr **) vp, 0); + if (n != MATCH_YES) + { + m = n; + goto not_yes; + } + + matches++; + goto loop; + + case 's': + vp = va_arg (argp, void **); + n = gfc_match_symbol ((gfc_symbol **) vp, 0); + if (n != MATCH_YES) + { + m = n; + goto not_yes; + } + + matches++; + goto loop; + + case 'n': + np = va_arg (argp, char *); + n = gfc_match_name (np); + if (n != MATCH_YES) + { + m = n; + goto not_yes; + } + + matches++; + goto loop; + + case 'l': + label = va_arg (argp, gfc_st_label **); + n = gfc_match_st_label (label, 0); + if (n != MATCH_YES) + { + m = n; + goto not_yes; + } + + matches++; + goto loop; + + case 'o': + ip = va_arg (argp, int *); + n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip); + if (n != MATCH_YES) + { + m = n; + goto not_yes; + } + + matches++; + goto loop; + + case 't': + if (gfc_match_eos () != MATCH_YES) + { + m = MATCH_NO; + goto not_yes; + } + goto loop; + + case ' ': + if (gfc_match_space () == MATCH_YES) + goto loop; + m = MATCH_NO; + goto not_yes; + + case '%': + break; /* Fall through to character matcher */ + + default: + gfc_internal_error ("gfc_match(): Bad match code %c", c); + } + + default: + if (c == gfc_next_char ()) + goto loop; + break; + } + +not_yes: + va_end (argp); + + if (m != MATCH_YES) + { + /* Clean up after a failed match. */ + gfc_set_locus (&old_loc); + va_start (argp, target); + + p = target; + for (; matches > 0; matches--) + { + while (*p++ != '%'); + + switch (*p++) + { + case '%': + matches++; + break; /* Skip */ + + case 'I': + case 'L': + case 'C': + if (*p++ == 'e') + goto undo_expr; + break; + + /* Matches that don't have to be undone */ + case 'o': + case 'l': + case 'n': + case 's': + (void)va_arg (argp, void **); + break; + + case 'e': + case 'E': + case 'v': + undo_expr: + vp = va_arg (argp, void **); + gfc_free_expr (*vp); + *vp = NULL; + break; + } + } + + va_end (argp); + } + + return m; +} + + +/*********************** Statement level matching **********************/ + +/* Matches the start of a program unit, which is the program keyword + followed by an optional symbol. */ + +match +gfc_match_program (void) +{ + gfc_symbol *sym; + match m; + + m = gfc_match_eos (); + if (m == MATCH_YES) + return m; + + m = gfc_match ("% %s%t", &sym); + + if (m == MATCH_NO) + { + gfc_error ("Invalid form of PROGRAM statement at %C"); + m = MATCH_ERROR; + } + + if (m == MATCH_ERROR) + return m; + + if (gfc_add_flavor (&sym->attr, FL_PROGRAM, NULL) == FAILURE) + return MATCH_ERROR; + + gfc_new_block = sym; + + return MATCH_YES; +} + + +/* Match a simple assignment statement. */ + +match +gfc_match_assignment (void) +{ + gfc_expr *lvalue, *rvalue; + locus old_loc; + match m; + + old_loc = *gfc_current_locus (); + + lvalue = rvalue = NULL; + m = gfc_match (" %v =", &lvalue); + if (m != MATCH_YES) + goto cleanup; + + m = gfc_match (" %e%t", &rvalue); + if (m != MATCH_YES) + goto cleanup; + + gfc_set_sym_referenced (lvalue->symtree->n.sym); + + new_st.op = EXEC_ASSIGN; + new_st.expr = lvalue; + new_st.expr2 = rvalue; + + return MATCH_YES; + +cleanup: + gfc_set_locus (&old_loc); + gfc_free_expr (lvalue); + gfc_free_expr (rvalue); + return m; +} + + +/* Match a pointer assignment statement. */ + +match +gfc_match_pointer_assignment (void) +{ + gfc_expr *lvalue, *rvalue; + locus old_loc; + match m; + + old_loc = *gfc_current_locus (); + + lvalue = rvalue = NULL; + + m = gfc_match (" %v =>", &lvalue); + if (m != MATCH_YES) + { + m = MATCH_NO; + goto cleanup; + } + + m = gfc_match (" %e%t", &rvalue); + if (m != MATCH_YES) + goto cleanup; + + new_st.op = EXEC_POINTER_ASSIGN; + new_st.expr = lvalue; + new_st.expr2 = rvalue; + + return MATCH_YES; + +cleanup: + gfc_set_locus (&old_loc); + gfc_free_expr (lvalue); + gfc_free_expr (rvalue); + return m; +} + + +/* The IF statement is a bit of a pain. First of all, there are three + forms of it, the simple IF, the IF that starts a block and the + arithmetic IF. + + There is a problem with the simple IF and that is the fact that we + only have a single level of undo information on symbols. What this + means is for a simple IF, we must re-match the whole IF statement + multiple times in order to guarantee that the symbol table ends up + in the proper state. */ + +match +gfc_match_if (gfc_statement * if_type) +{ + gfc_expr *expr; + gfc_st_label *l1, *l2, *l3; + locus old_loc; + gfc_code *p; + match m, n; + + n = gfc_match_label (); + if (n == MATCH_ERROR) + return n; + + old_loc = *gfc_current_locus (); + + m = gfc_match (" if ( %e", &expr); + if (m != MATCH_YES) + return m; + + if (gfc_match_char (')') != MATCH_YES) + { + gfc_error ("Syntax error in IF-expression at %C"); + gfc_free_expr (expr); + return MATCH_ERROR; + } + + m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3); + + if (m == MATCH_YES) + { + if (n == MATCH_YES) + { + gfc_error + ("Block label not appropriate for arithmetic IF statement " + "at %C"); + + gfc_free_expr (expr); + return MATCH_ERROR; + } + + if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE + || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE + || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE) + { + + gfc_free_expr (expr); + return MATCH_ERROR; + } + + new_st.op = EXEC_ARITHMETIC_IF; + new_st.expr = expr; + new_st.label = l1; + new_st.label2 = l2; + new_st.label3 = l3; + + *if_type = ST_ARITHMETIC_IF; + return MATCH_YES; + } + + if (gfc_match (" then %t") == MATCH_YES) + { + new_st.op = EXEC_IF; + new_st.expr = expr; + + *if_type = ST_IF_BLOCK; + return MATCH_YES; + } + + if (n == MATCH_YES) + { + gfc_error ("Block label is not appropriate IF statement at %C"); + + gfc_free_expr (expr); + return MATCH_ERROR; + } + + /* At this point the only thing left is a simple IF statement. At + this point, n has to be MATCH_NO, so we don't have to worry about + re-matching a block label. From what we've got so far, try + matching an assignment. */ + + *if_type = ST_SIMPLE_IF; + + m = gfc_match_assignment (); + if (m == MATCH_YES) + goto got_match; + + gfc_free_expr (expr); + gfc_undo_symbols (); + gfc_set_locus (&old_loc); + + gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */ + + m = gfc_match_pointer_assignment (); + if (m == MATCH_YES) + goto got_match; + + gfc_free_expr (expr); + gfc_undo_symbols (); + gfc_set_locus (&old_loc); + + gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */ + + /* Look at the next keyword to see which matcher to call. Matching + the keyword doesn't affect the symbol table, so we don't have to + restore between tries. */ + +#define match(string, subr, statement) \ + if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; } + + gfc_clear_error (); + + match ("allocate", gfc_match_allocate, ST_ALLOCATE) + match ("backspace", gfc_match_backspace, ST_BACKSPACE) + match ("call", gfc_match_call, ST_CALL) + match ("close", gfc_match_close, ST_CLOSE) + match ("continue", gfc_match_continue, ST_CONTINUE) + match ("cycle", gfc_match_cycle, ST_CYCLE) + match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE) + match ("end file", gfc_match_endfile, ST_END_FILE) + match ("exit", gfc_match_exit, ST_EXIT) + match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT) + match ("go to", gfc_match_goto, ST_GOTO) + match ("inquire", gfc_match_inquire, ST_INQUIRE) + match ("nullify", gfc_match_nullify, ST_NULLIFY) + match ("open", gfc_match_open, ST_OPEN) + match ("pause", gfc_match_pause, ST_NONE) + match ("print", gfc_match_print, ST_WRITE) + match ("read", gfc_match_read, ST_READ) + match ("return", gfc_match_return, ST_RETURN) + match ("rewind", gfc_match_rewind, ST_REWIND) + match ("pause", gfc_match_stop, ST_PAUSE) + match ("stop", gfc_match_stop, ST_STOP) + match ("write", gfc_match_write, ST_WRITE) + + /* All else has failed, so give up. See if any of the matchers has + stored an error message of some sort. */ + if (gfc_error_check () == 0) + gfc_error ("Unclassifiable statement in IF-clause at %C"); + + gfc_free_expr (expr); + return MATCH_ERROR; + +got_match: + if (m == MATCH_NO) + gfc_error ("Syntax error in IF-clause at %C"); + if (m != MATCH_YES) + { + gfc_free_expr (expr); + return MATCH_ERROR; + } + + /* At this point, we've matched the single IF and the action clause + is in new_st. Rearrange things so that the IF statement appears + in new_st. */ + + p = gfc_get_code (); + p->next = gfc_get_code (); + *p->next = new_st; + p->next->loc = *gfc_current_locus (); + + p->expr = expr; + p->op = EXEC_IF; + + gfc_clear_new_st (); + + new_st.op = EXEC_IF; + new_st.block = p; + + return MATCH_YES; +} + +#undef match + + +/* Match an ELSE statement. */ + +match +gfc_match_else (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + + if (gfc_match_name (name) != MATCH_YES + || gfc_current_block () == NULL + || gfc_match_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after ELSE statement at %C"); + return MATCH_ERROR; + } + + if (strcmp (name, gfc_current_block ()->name) != 0) + { + gfc_error ("Label '%s' at %C doesn't match IF label '%s'", + name, gfc_current_block ()->name); + return MATCH_ERROR; + } + + return MATCH_YES; +} + + +/* Match an ELSE IF statement. */ + +match +gfc_match_elseif (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_expr *expr; + match m; + + m = gfc_match (" ( %e ) then", &expr); + if (m != MATCH_YES) + return m; + + if (gfc_match_eos () == MATCH_YES) + goto done; + + if (gfc_match_name (name) != MATCH_YES + || gfc_current_block () == NULL + || gfc_match_eos () != MATCH_YES) + { + gfc_error ("Unexpected junk after ELSE IF statement at %C"); + goto cleanup; + } + + if (strcmp (name, gfc_current_block ()->name) != 0) + { + gfc_error ("Label '%s' at %C doesn't match IF label '%s'", + name, gfc_current_block ()->name); + goto cleanup; + } + +done: + new_st.op = EXEC_IF; + new_st.expr = expr; + return MATCH_YES; + +cleanup: + gfc_free_expr (expr); + return MATCH_ERROR; +} + + +/* Free a gfc_iterator structure. */ + +void +gfc_free_iterator (gfc_iterator * iter, int flag) +{ + + if (iter == NULL) + return; + + gfc_free_expr (iter->var); + gfc_free_expr (iter->start); + gfc_free_expr (iter->end); + gfc_free_expr (iter->step); + + if (flag) + gfc_free (iter); +} + + +/* Match a DO statement. */ + +match +gfc_match_do (void) +{ + gfc_iterator iter, *ip; + locus old_loc; + gfc_st_label *label; + match m; + + old_loc = *gfc_current_locus (); + + label = NULL; + iter.var = iter.start = iter.end = iter.step = NULL; + + m = gfc_match_label (); + if (m == MATCH_ERROR) + return m; + + if (gfc_match (" do") != MATCH_YES) + return MATCH_NO; + +/* Match an infinite DO, make it like a DO WHILE(.TRUE.) */ + + if (gfc_match_eos () == MATCH_YES) + { + iter.end = gfc_logical_expr (1, NULL); + new_st.op = EXEC_DO_WHILE; + goto done; + } + + m = gfc_match_st_label (&label, 0); + if (m == MATCH_ERROR) + goto cleanup; + + gfc_match_char (','); + + if (gfc_match ("% ") != MATCH_YES) + return MATCH_NO; + + /* See if we have a DO WHILE. */ + if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES) + { + new_st.op = EXEC_DO_WHILE; + goto done; + } + + /* The abortive DO WHILE may have done something to the symbol + table, so we start over: */ + gfc_undo_symbols (); + gfc_set_locus (&old_loc); + + gfc_match_label (); /* This won't error */ + gfc_match (" do "); /* This will work */ + + gfc_match_st_label (&label, 0); /* Can't error out */ + gfc_match_char (','); /* Optional comma */ + + m = gfc_match_iterator (&iter, 0); + if (m == MATCH_NO) + return MATCH_NO; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_eos () != MATCH_YES) + { + gfc_syntax_error (ST_DO); + goto cleanup; + } + + new_st.op = EXEC_DO; + +done: + if (label != NULL + && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) + goto cleanup; + + new_st.label = label; + + if (new_st.op == EXEC_DO_WHILE) + new_st.expr = iter.end; + else + { + new_st.ext.iterator = ip = gfc_get_iterator (); + *ip = iter; + } + + return MATCH_YES; + +cleanup: + gfc_free_iterator (&iter, 0); + + return MATCH_ERROR; +} + + +/* Match an EXIT or CYCLE statement. */ + +static match +match_exit_cycle (gfc_statement st, gfc_exec_op op) +{ + gfc_state_data *p; + gfc_symbol *sym; + match m; + + if (gfc_match_eos () == MATCH_YES) + sym = NULL; + else + { + m = gfc_match ("% %s%t", &sym); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + { + gfc_syntax_error (st); + return MATCH_ERROR; + } + + if (sym->attr.flavor != FL_LABEL) + { + gfc_error ("Name '%s' in %s statement at %C is not a loop name", + sym->name, gfc_ascii_statement (st)); + return MATCH_ERROR; + } + } + + /* Find the loop mentioned specified by the label (or lack of a + label). */ + for (p = gfc_state_stack; p; p = p->previous) + if (p->state == COMP_DO && (sym == NULL || sym == p->sym)) + break; + + if (p == NULL) + { + if (sym == NULL) + gfc_error ("%s statement at %C is not within a loop", + gfc_ascii_statement (st)); + else + gfc_error ("%s statement at %C is not within loop '%s'", + gfc_ascii_statement (st), sym->name); + + return MATCH_ERROR; + } + + /* Save the first statement in the loop - needed by the backend. */ + new_st.ext.whichloop = p->head; + + new_st.op = op; +/* new_st.sym = sym;*/ + + return MATCH_YES; +} + + +/* Match the EXIT statement. */ + +match +gfc_match_exit (void) +{ + + return match_exit_cycle (ST_EXIT, EXEC_EXIT); +} + + +/* Match the CYCLE statement. */ + +match +gfc_match_cycle (void) +{ + + return match_exit_cycle (ST_CYCLE, EXEC_CYCLE); +} + + +/* Match a number or character constant after a STOP or PAUSE statement. */ + +static match +gfc_match_stopcode (gfc_statement st) +{ + int stop_code; + gfc_expr *e; + match m; + + stop_code = 0; + e = NULL; + + if (gfc_match_eos () != MATCH_YES) + { + m = gfc_match_small_literal_int (&stop_code); + if (m == MATCH_ERROR) + goto cleanup; + + if (m == MATCH_YES && stop_code > 99999) + { + gfc_error ("STOP code out of range at %C"); + goto cleanup; + } + + if (m == MATCH_NO) + { + /* Try a character constant. */ + m = gfc_match_expr (&e); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT) + goto syntax; + } + + if (gfc_match_eos () != MATCH_YES) + goto syntax; + } + + if (gfc_pure (NULL)) + { + gfc_error ("%s statement not allowed in PURE procedure at %C", + gfc_ascii_statement (st)); + goto cleanup; + } + + new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE; + new_st.expr = e; + new_st.ext.stop_code = stop_code; + + return MATCH_YES; + +syntax: + gfc_syntax_error (st); + +cleanup: + + gfc_free_expr (e); + return MATCH_ERROR; +} + +/* Match the (deprecated) PAUSE statement. */ + +match +gfc_match_pause (void) +{ + match m; + + m = gfc_match_stopcode (ST_PAUSE); + if (m == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F95_DEL, + "Obsolete: PAUSE statement at %C") + == FAILURE) + m = MATCH_ERROR; + } + return m; +} + + +/* Match the STOP statement. */ + +match +gfc_match_stop (void) +{ + return gfc_match_stopcode (ST_STOP); +} + + +/* Match a CONTINUE statement. */ + +match +gfc_match_continue (void) +{ + + if (gfc_match_eos () != MATCH_YES) + { + gfc_syntax_error (ST_CONTINUE); + return MATCH_ERROR; + } + + new_st.op = EXEC_CONTINUE; + return MATCH_YES; +} + + +/* Match the (deprecated) ASSIGN statement. */ + +match +gfc_match_assign (void) +{ + gfc_expr *expr; + gfc_st_label *label; + + if (gfc_match (" %l", &label) == MATCH_YES) + { + if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE) + return MATCH_ERROR; + if (gfc_match (" to %v%t", &expr) == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F95_DEL, + "Obsolete: ASSIGN statement at %C") + == FAILURE) + return MATCH_ERROR; + + expr->symtree->n.sym->attr.assign = 1; + + new_st.op = EXEC_LABEL_ASSIGN; + new_st.label = label; + new_st.expr = expr; + return MATCH_YES; + } + } + return MATCH_NO; +} + + +/* Match the GO TO statement. As a computed GOTO statement is + matched, it is transformed into an equivalent SELECT block. No + tree is necessary, and the resulting jumps-to-jumps are + specifically optimized away by the back end. */ + +match +gfc_match_goto (void) +{ + gfc_code *head, *tail; + gfc_expr *expr; + gfc_case *cp; + gfc_st_label *label; + int i; + match m; + + if (gfc_match (" %l%t", &label) == MATCH_YES) + { + if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) + return MATCH_ERROR; + + new_st.op = EXEC_GOTO; + new_st.label = label; + return MATCH_YES; + } + + /* The assigned GO TO statement. */ + + if (gfc_match_variable (&expr, 0) == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F95_DEL, + "Obsolete: Assigned GOTO statement at %C") + == FAILURE) + return MATCH_ERROR; + + expr->symtree->n.sym->attr.assign = 1; + new_st.op = EXEC_GOTO; + new_st.expr = expr; + + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + + /* Match label list. */ + gfc_match_char (','); + if (gfc_match_char ('(') != MATCH_YES) + { + gfc_syntax_error (ST_GOTO); + return MATCH_ERROR; + } + head = tail = NULL; + + do + { + m = gfc_match_st_label (&label, 0); + if (m != MATCH_YES) + goto syntax; + + if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) + goto cleanup; + + if (head == NULL) + head = tail = gfc_get_code (); + else + { + tail->block = gfc_get_code (); + tail = tail->block; + } + + tail->label = label; + tail->op = EXEC_GOTO; + } + while (gfc_match_char (',') == MATCH_YES); + + if (gfc_match (")%t") != MATCH_YES) + goto syntax; + + if (head == NULL) + { + gfc_error ( + "Statement label list in GOTO at %C cannot be empty"); + goto syntax; + } + new_st.block = head; + + return MATCH_YES; + } + + /* Last chance is a computed GO TO statement. */ + if (gfc_match_char ('(') != MATCH_YES) + { + gfc_syntax_error (ST_GOTO); + return MATCH_ERROR; + } + + head = tail = NULL; + i = 1; + + do + { + m = gfc_match_st_label (&label, 0); + if (m != MATCH_YES) + goto syntax; + + if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) + goto cleanup; + + if (head == NULL) + head = tail = gfc_get_code (); + else + { + tail->block = gfc_get_code (); + tail = tail->block; + } + + cp = gfc_get_case (); + cp->low = cp->high = gfc_int_expr (i++); + + tail->op = EXEC_SELECT; + tail->ext.case_list = cp; + + tail->next = gfc_get_code (); + tail->next->op = EXEC_GOTO; + tail->next->label = label; + } + while (gfc_match_char (',') == MATCH_YES); + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + if (head == NULL) + { + gfc_error ("Statement label list in GOTO at %C cannot be empty"); + goto syntax; + } + + /* Get the rest of the statement. */ + gfc_match_char (','); + + if (gfc_match (" %e%t", &expr) != MATCH_YES) + goto syntax; + + /* At this point, a computed GOTO has been fully matched and an + equivalent SELECT statement constructed. */ + + new_st.op = EXEC_SELECT; + new_st.expr = NULL; + + /* Hack: For a "real" SELECT, the expression is in expr. We put + it in expr2 so we can distinguish then and produce the correct + diagnostics. */ + new_st.expr2 = expr; + new_st.block = head; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_GOTO); +cleanup: + gfc_free_statements (head); + return MATCH_ERROR; +} + + +/* Frees a list of gfc_alloc structures. */ + +void +gfc_free_alloc_list (gfc_alloc * p) +{ + gfc_alloc *q; + + for (; p; p = q) + { + q = p->next; + gfc_free_expr (p->expr); + gfc_free (p); + } +} + + +/* Match an ALLOCATE statement. */ + +match +gfc_match_allocate (void) +{ + gfc_alloc *head, *tail; + gfc_expr *stat; + match m; + + head = tail = NULL; + stat = NULL; + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + for (;;) + { + if (head == NULL) + head = tail = gfc_get_alloc (); + else + { + tail->next = gfc_get_alloc (); + tail = tail->next; + } + + m = gfc_match_variable (&tail->expr, 0); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_pure (NULL) + && gfc_impure_variable (tail->expr->symtree->n.sym)) + { + gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a " + "PURE procedure"); + goto cleanup; + } + + if (gfc_match_char (',') != MATCH_YES) + break; + + m = gfc_match (" stat = %v", &stat); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + break; + } + + if (stat != NULL) + { + if (stat->symtree->n.sym->attr.intent == INTENT_IN) + { + gfc_error + ("STAT variable '%s' of ALLOCATE statement at %C cannot be " + "INTENT(IN)", stat->symtree->n.sym->name); + goto cleanup; + } + + if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym)) + { + gfc_error + ("Illegal STAT variable in ALLOCATE statement at %C for a PURE " + "procedure"); + goto cleanup; + } + } + + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + + new_st.op = EXEC_ALLOCATE; + new_st.expr = stat; + new_st.ext.alloc_list = head; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_ALLOCATE); + +cleanup: + gfc_free_expr (stat); + gfc_free_alloc_list (head); + return MATCH_ERROR; +} + + +/* Match a NULLIFY statement. A NULLIFY statement is transformed into + a set of pointer assignments to intrinsic NULL(). */ + +match +gfc_match_nullify (void) +{ + gfc_code *tail; + gfc_expr *e, *p; + match m; + + tail = NULL; + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + for (;;) + { + m = gfc_match_variable (&p, 0); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym)) + { + gfc_error + ("Illegal variable in NULLIFY at %C for a PURE procedure"); + goto cleanup; + } + + /* build ' => NULL() ' */ + e = gfc_get_expr (); + e->where = *gfc_current_locus (); + e->expr_type = EXPR_NULL; + e->ts.type = BT_UNKNOWN; + + /* Chain to list */ + if (tail == NULL) + tail = &new_st; + else + { + tail->next = gfc_get_code (); + tail = tail->next; + } + + tail->op = EXEC_POINTER_ASSIGN; + tail->expr = p; + tail->expr2 = e; + + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_NULLIFY); + +cleanup: + gfc_free_statements (tail); + return MATCH_ERROR; +} + + +/* Match a DEALLOCATE statement. */ + +match +gfc_match_deallocate (void) +{ + gfc_alloc *head, *tail; + gfc_expr *stat; + match m; + + head = tail = NULL; + stat = NULL; + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + for (;;) + { + if (head == NULL) + head = tail = gfc_get_alloc (); + else + { + tail->next = gfc_get_alloc (); + tail = tail->next; + } + + m = gfc_match_variable (&tail->expr, 0); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + if (gfc_pure (NULL) + && gfc_impure_variable (tail->expr->symtree->n.sym)) + { + gfc_error + ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE " + "procedure"); + goto cleanup; + } + + if (gfc_match_char (',') != MATCH_YES) + break; + + m = gfc_match (" stat = %v", &stat); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + break; + } + + if (stat != NULL && stat->symtree->n.sym->attr.intent == INTENT_IN) + { + gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C cannot be " + "INTENT(IN)", stat->symtree->n.sym->name); + goto cleanup; + } + + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + + new_st.op = EXEC_DEALLOCATE; + new_st.expr = stat; + new_st.ext.alloc_list = head; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_DEALLOCATE); + +cleanup: + gfc_free_expr (stat); + gfc_free_alloc_list (head); + return MATCH_ERROR; +} + + +/* Match a RETURN statement. */ + +match +gfc_match_return (void) +{ + gfc_expr *e; + match m; + + e = NULL; + if (gfc_match_eos () == MATCH_YES) + goto done; + + if (gfc_find_state (COMP_SUBROUTINE) == FAILURE) + { + gfc_error ("Alternate RETURN statement at %C is only allowed within " + "a SUBROUTINE"); + goto cleanup; + } + + m = gfc_match ("% %e%t", &e); + if (m == MATCH_YES) + goto done; + if (m == MATCH_ERROR) + goto cleanup; + + gfc_syntax_error (ST_RETURN); + +cleanup: + gfc_free_expr (e); + return MATCH_ERROR; + +done: + new_st.op = EXEC_RETURN; + new_st.expr = e; + + return MATCH_YES; +} + + +/* Match a CALL statement. The tricky part here are possible + alternate return specifiers. We handle these by having all + "subroutines" actually return an integer via a register that gives + the return number. If the call specifies alternate returns, we + generate code for a SELECT statement whose case clauses contain + GOTOs to the various labels. */ + +match +gfc_match_call (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_actual_arglist *a, *arglist; + gfc_case *new_case; + gfc_symbol *sym; + gfc_symtree *st; + gfc_code *c; + match m; + int i; + + arglist = NULL; + + m = gfc_match ("% %n", name); + if (m == MATCH_NO) + goto syntax; + if (m != MATCH_YES) + return m; + + if (gfc_get_ha_sym_tree (name, &st)) + return MATCH_ERROR; + + sym = st->n.sym; + gfc_set_sym_referenced (sym); + + if (!sym->attr.generic + && !sym->attr.subroutine + && gfc_add_subroutine (&sym->attr, NULL) == FAILURE) + return MATCH_ERROR; + + if (gfc_match_eos () != MATCH_YES) + { + m = gfc_match_actual_arglist (1, &arglist); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_eos () != MATCH_YES) + goto syntax; + } + + /* If any alternate return labels were found, construct a SELECT + statement that will jump to the right place. */ + + i = 0; + for (a = arglist; a; a = a->next) + if (a->expr == NULL) + i = 1; + + if (i) + { + gfc_symtree *select_st; + gfc_symbol *select_sym; + char name[GFC_MAX_SYMBOL_LEN + 1]; + + new_st.next = c = gfc_get_code (); + c->op = EXEC_SELECT; + sprintf (name, "_result_%s",sym->name); + gfc_get_ha_sym_tree (name, &select_st); /* Can't fail */ + + select_sym = select_st->n.sym; + select_sym->ts.type = BT_INTEGER; + select_sym->ts.kind = gfc_default_integer_kind (); + gfc_set_sym_referenced (select_sym); + c->expr = gfc_get_expr (); + c->expr->expr_type = EXPR_VARIABLE; + c->expr->symtree = select_st; + c->expr->ts = select_sym->ts; + c->expr->where = *gfc_current_locus (); + + i = 0; + for (a = arglist; a; a = a->next) + { + if (a->expr != NULL) + continue; + + if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE) + continue; + + i++; + + c->block = gfc_get_code (); + c = c->block; + c->op = EXEC_SELECT; + + new_case = gfc_get_case (); + new_case->high = new_case->low = gfc_int_expr (i); + c->ext.case_list = new_case; + + c->next = gfc_get_code (); + c->next->op = EXEC_GOTO; + c->next->label = a->label; + } + } + + new_st.op = EXEC_CALL; + new_st.symtree = st; + new_st.ext.actual = arglist; + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_CALL); + +cleanup: + gfc_free_actual_arglist (arglist); + return MATCH_ERROR; +} + + +/* Match an IMPLICIT NONE statement. Actually, this statement is + already matched in parse.c, or we would not end up here in the + first place. So the only thing we need to check, is if there is + trailing garbage. If not, the match is successful. */ + +match +gfc_match_implicit_none (void) +{ + + return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO; +} + + +/* Match the letter range(s) of an IMPLICIT statement. */ + +static match +match_implicit_range (gfc_typespec * ts) +{ + int c, c1, c2, inner; + locus cur_loc; + + cur_loc = *gfc_current_locus (); + + gfc_gobble_whitespace (); + c = gfc_next_char (); + if (c != '(') + { + gfc_error ("Missing character range in IMPLICIT at %C"); + goto bad; + } + + inner = 1; + while (inner) + { + gfc_gobble_whitespace (); + c1 = gfc_next_char (); + if (!ISALPHA (c1)) + goto bad; + + gfc_gobble_whitespace (); + c = gfc_next_char (); + + switch (c) + { + case ')': + inner = 0; /* Fall through */ + + case ',': + c2 = c1; + break; + + case '-': + gfc_gobble_whitespace (); + c2 = gfc_next_char (); + if (!ISALPHA (c2)) + goto bad; + + gfc_gobble_whitespace (); + c = gfc_next_char (); + + if ((c != ',') && (c != ')')) + goto bad; + if (c == ')') + inner = 0; + + break; + + default: + goto bad; + } + + if (c1 > c2) + { + gfc_error ("Letters must be in alphabetic order in " + "IMPLICIT statement at %C"); + goto bad; + } + + /* See if we can add the newly matched range to the pending + implicits from this IMPLICIT statement. We do not check for + conflicts with whatever earlier IMPLICIT statements may have + set. This is done when we've successfully finished matching + the current one. */ + if (gfc_add_new_implicit_range (c1, c2, ts) != SUCCESS) + goto bad; + } + + return MATCH_YES; + +bad: + gfc_syntax_error (ST_IMPLICIT); + + gfc_set_locus (&cur_loc); + return MATCH_ERROR; +} + + +/* Match an IMPLICIT statement, storing the types for + gfc_set_implicit() if the statement is accepted by the parser. + There is a strange looking, but legal syntactic construction + possible. It looks like: + + IMPLICIT INTEGER (a-b) (c-d) + + This is legal if "a-b" is a constant expression that happens to + equal one of the legal kinds for integers. The real problem + happens with an implicit specification that looks like: + + IMPLICIT INTEGER (a-b) + + In this case, a typespec matcher that is "greedy" (as most of the + matchers are) gobbles the character range as a kindspec, leaving + nothing left. We therefore have to go a bit more slowly in the + matching process by inhibiting the kindspec checking during + typespec matching and checking for a kind later. */ + +match +gfc_match_implicit (void) +{ + gfc_typespec ts; + locus cur_loc; + int c; + match m; + + /* We don't allow empty implicit statements. */ + if (gfc_match_eos () == MATCH_YES) + { + gfc_error ("Empty IMPLICIT statement at %C"); + return MATCH_ERROR; + } + + /* First cleanup. */ + gfc_clear_new_implicit (); + + do + { + /* A basic type is mandatory here. */ + m = gfc_match_type_spec (&ts, 0); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_NO) + goto syntax; + + cur_loc = *gfc_current_locus (); + m = match_implicit_range (&ts); + + if (m == MATCH_YES) + { + /* Looks like we have the <TYPE> (<RANGE>). */ + gfc_gobble_whitespace (); + c = gfc_next_char (); + if ((c == '\n') || (c == ',')) + continue; + + gfc_set_locus (&cur_loc); + } + + /* Last chance -- check <TYPE> (<KIND>) (<RANGE>). */ + m = gfc_match_kind_spec (&ts); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_NO) + { + m = gfc_match_old_kind_spec (&ts); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_NO) + goto syntax; + } + + m = match_implicit_range (&ts); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_NO) + goto syntax; + + gfc_gobble_whitespace (); + c = gfc_next_char (); + if ((c != '\n') && (c != ',')) + goto syntax; + + } + while (c == ','); + + /* All we need to now is try to merge the new implicit types back + into the existing types. This will fail if another implicit + type is already defined for a letter. */ + return (gfc_merge_new_implicit () == SUCCESS) ? + MATCH_YES : MATCH_ERROR; + +syntax: + gfc_syntax_error (ST_IMPLICIT); + +error: + return MATCH_ERROR; +} + + +/* Match a common block name. */ + +static match +match_common_name (gfc_symbol ** sym) +{ + match m; + + if (gfc_match_char ('/') == MATCH_NO) + return MATCH_NO; + + if (gfc_match_char ('/') == MATCH_YES) + { + *sym = NULL; + return MATCH_YES; + } + + m = gfc_match_symbol (sym, 0); + + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES) + return MATCH_YES; + + gfc_error ("Syntax error in common block name at %C"); + return MATCH_ERROR; +} + + +/* Match a COMMON statement. */ + +match +gfc_match_common (void) +{ + gfc_symbol *sym, *common_name, **head, *tail, *old_blank_common; + gfc_array_spec *as; + match m; + + old_blank_common = gfc_current_ns->blank_common; + if (old_blank_common) + { + while (old_blank_common->common_next) + old_blank_common = old_blank_common->common_next; + } + + common_name = NULL; + as = NULL; + + if (gfc_match_eos () == MATCH_YES) + goto syntax; + + for (;;) + { + m = match_common_name (&common_name); + if (m == MATCH_ERROR) + goto cleanup; + + if (common_name == NULL) + head = &gfc_current_ns->blank_common; + else + { + head = &common_name->common_head; + + if (!common_name->attr.common + && gfc_add_common (&common_name->attr, NULL) == FAILURE) + goto cleanup; + } + + if (*head == NULL) + tail = NULL; + else + { + tail = *head; + while (tail->common_next) + tail = tail->common_next; + } + + /* Grab the list of symbols. */ + for (;;) + { + m = gfc_match_symbol (&sym, 0); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + if (sym->attr.in_common) + { + gfc_error ("Symbol '%s' at %C is already in a COMMON block", + sym->name); + goto cleanup; + } + + if (gfc_add_in_common (&sym->attr, NULL) == FAILURE) + goto cleanup; + + /* Derived type names must have the SEQUENCE attribute. */ + if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence) + { + gfc_error + ("Derived type variable in COMMON at %C does not have the " + "SEQUENCE attribute"); + goto cleanup; + } + + if (tail != NULL) + tail->common_next = sym; + else + *head = sym; + + tail = sym; + + /* Deal with an optional array specification after the + symbol name. */ + m = gfc_match_array_spec (&as); + if (m == MATCH_ERROR) + goto cleanup; + + if (m == MATCH_YES) + { + if (as->type != AS_EXPLICIT) + { + gfc_error + ("Array specification for symbol '%s' in COMMON at %C " + "must be explicit", sym->name); + goto cleanup; + } + + if (gfc_add_dimension (&sym->attr, NULL) == FAILURE) + goto cleanup; + + if (sym->attr.pointer) + { + gfc_error + ("Symbol '%s' in COMMON at %C cannot be a POINTER array", + sym->name); + goto cleanup; + } + + sym->as = as; + as = NULL; + } + + if (gfc_match_eos () == MATCH_YES) + goto done; + if (gfc_peek_char () == '/') + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + if (gfc_peek_char () == '/') + break; + } + } + +done: + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_COMMON); + +cleanup: + if (old_blank_common) + old_blank_common->common_next = NULL; + else + gfc_current_ns->blank_common = NULL; + gfc_free_array_spec (as); + return MATCH_ERROR; +} + + +/* Match a BLOCK DATA program unit. */ + +match +gfc_match_block_data (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + match m; + + if (gfc_match_eos () == MATCH_YES) + { + gfc_new_block = NULL; + return MATCH_YES; + } + + m = gfc_match (" %n%t", name); + if (m != MATCH_YES) + return MATCH_ERROR; + + if (gfc_get_symbol (name, NULL, &sym)) + return MATCH_ERROR; + + if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, NULL) == FAILURE) + return MATCH_ERROR; + + gfc_new_block = sym; + + return MATCH_YES; +} + + +/* Free a namelist structure. */ + +void +gfc_free_namelist (gfc_namelist * name) +{ + gfc_namelist *n; + + for (; name; name = n) + { + n = name->next; + gfc_free (name); + } +} + + +/* Match a NAMELIST statement. */ + +match +gfc_match_namelist (void) +{ + gfc_symbol *group_name, *sym; + gfc_namelist *nl; + match m, m2; + + m = gfc_match (" / %s /", &group_name); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto error; + + for (;;) + { + if (group_name->ts.type != BT_UNKNOWN) + { + gfc_error + ("Namelist group name '%s' at %C already has a basic type " + "of %s", group_name->name, gfc_typename (&group_name->ts)); + return MATCH_ERROR; + } + + if (group_name->attr.flavor != FL_NAMELIST + && gfc_add_flavor (&group_name->attr, FL_NAMELIST, NULL) == FAILURE) + return MATCH_ERROR; + + for (;;) + { + m = gfc_match_symbol (&sym, 1); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto error; + + if (sym->attr.in_namelist == 0 + && gfc_add_in_namelist (&sym->attr, NULL) == FAILURE) + goto error; + + /* TODO: worry about PRIVATE members of a PUBLIC namelist + group. */ + + nl = gfc_get_namelist (); + nl->sym = sym; + + if (group_name->namelist == NULL) + group_name->namelist = group_name->namelist_tail = nl; + else + { + group_name->namelist_tail->next = nl; + group_name->namelist_tail = nl; + } + + if (gfc_match_eos () == MATCH_YES) + goto done; + + m = gfc_match_char (','); + + if (gfc_match_char ('/') == MATCH_YES) + { + m2 = gfc_match (" %s /", &group_name); + if (m2 == MATCH_YES) + break; + if (m2 == MATCH_ERROR) + goto error; + goto syntax; + } + + if (m != MATCH_YES) + goto syntax; + } + } + +done: + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_NAMELIST); + +error: + return MATCH_ERROR; +} + + +/* Match a MODULE statement. */ + +match +gfc_match_module (void) +{ + match m; + + m = gfc_match (" %s%t", &gfc_new_block); + if (m != MATCH_YES) + return m; + + if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, NULL) == FAILURE) + return MATCH_ERROR; + + return MATCH_YES; +} + + +/* Free equivalence sets and lists. Recursively is the easiest way to + do this. */ + +void +gfc_free_equiv (gfc_equiv * eq) +{ + + if (eq == NULL) + return; + + gfc_free_equiv (eq->eq); + gfc_free_equiv (eq->next); + + gfc_free_expr (eq->expr); + gfc_free (eq); +} + + +/* Match an EQUIVALENCE statement. */ + +match +gfc_match_equivalence (void) +{ + gfc_equiv *eq, *set, *tail; + gfc_ref *ref; + match m; + + tail = NULL; + + for (;;) + { + eq = gfc_get_equiv (); + if (tail == NULL) + tail = eq; + + eq->next = gfc_current_ns->equiv; + gfc_current_ns->equiv = eq; + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + set = eq; + + for (;;) + { + m = gfc_match_variable (&set->expr, 1); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + for (ref = set->expr->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) + { + gfc_error + ("Array reference in EQUIVALENCE at %C cannot be an " + "array section"); + goto cleanup; + } + + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + set->eq = gfc_get_equiv (); + set = set->eq; + } + + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_EQUIVALENCE); + +cleanup: + eq = tail->next; + tail->next = NULL; + + gfc_free_equiv (gfc_current_ns->equiv); + gfc_current_ns->equiv = eq; + + return MATCH_ERROR; +} + + +/* Match a statement function declaration. It is so easy to match + non-statement function statements with a MATCH_ERROR as opposed to + MATCH_NO that we suppress error message in most cases. */ + +match +gfc_match_st_function (void) +{ + gfc_error_buf old_error; + gfc_symbol *sym; + gfc_expr *expr; + match m; + + m = gfc_match_symbol (&sym, 0); + if (m != MATCH_YES) + return m; + + gfc_push_error (&old_error); + + if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, NULL) == FAILURE) + goto undo_error; + + if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES) + goto undo_error; + + m = gfc_match (" = %e%t", &expr); + if (m == MATCH_NO) + goto undo_error; + if (m == MATCH_ERROR) + return m; + + sym->value = expr; + + return MATCH_YES; + +undo_error: + gfc_pop_error (&old_error); + return MATCH_NO; +} + + +/********************* DATA statement subroutines *********************/ + +/* Free a gfc_data_variable structure and everything beneath it. */ + +static void +free_variable (gfc_data_variable * p) +{ + gfc_data_variable *q; + + for (; p; p = q) + { + q = p->next; + gfc_free_expr (p->expr); + gfc_free_iterator (&p->iter, 0); + free_variable (p->list); + + gfc_free (p); + } +} + + +/* Free a gfc_data_value structure and everything beneath it. */ + +static void +free_value (gfc_data_value * p) +{ + gfc_data_value *q; + + for (; p; p = q) + { + q = p->next; + gfc_free_expr (p->expr); + gfc_free (p); + } +} + + +/* Free a list of gfc_data structures. */ + +void +gfc_free_data (gfc_data * p) +{ + gfc_data *q; + + for (; p; p = q) + { + q = p->next; + + free_variable (p->var); + free_value (p->value); + + gfc_free (p); + } +} + + +static match var_element (gfc_data_variable *); + +/* Match a list of variables terminated by an iterator and a right + parenthesis. */ + +static match +var_list (gfc_data_variable * parent) +{ + gfc_data_variable *tail, var; + match m; + + m = var_element (&var); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + goto syntax; + + tail = gfc_get_data_variable (); + *tail = var; + + parent->list = tail; + + for (;;) + { + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = gfc_match_iterator (&parent->iter, 1); + if (m == MATCH_YES) + break; + if (m == MATCH_ERROR) + return MATCH_ERROR; + + m = var_element (&var); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + goto syntax; + + tail->next = gfc_get_data_variable (); + tail = tail->next; + + *tail = var; + } + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_DATA); + return MATCH_ERROR; +} + + +/* Match a single element in a data variable list, which can be a + variable-iterator list. */ + +static match +var_element (gfc_data_variable * new) +{ + match m; + + memset (new, '\0', sizeof (gfc_data_variable)); + + if (gfc_match_char ('(') == MATCH_YES) + return var_list (new); + + m = gfc_match_variable (&new->expr, 0); + if (m != MATCH_YES) + return m; + + if (new->expr->symtree->n.sym->value != NULL) + { + gfc_error ("Variable '%s' at %C already has an initialization", + new->expr->symtree->n.sym->name); + return MATCH_ERROR; + } + + new->expr->symtree->n.sym->attr.data = 1; + return MATCH_YES; +} + + +/* Match the top-level list of data variables. */ + +static match +top_var_list (gfc_data * d) +{ + gfc_data_variable var, *tail, *new; + match m; + + tail = NULL; + + for (;;) + { + m = var_element (&var); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + return MATCH_ERROR; + + new = gfc_get_data_variable (); + *new = var; + + if (tail == NULL) + d->var = new; + else + tail->next = new; + + tail = new; + + if (gfc_match_char ('/') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_DATA); + return MATCH_ERROR; +} + + +static match +match_data_constant (gfc_expr ** result) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + gfc_expr *expr; + match m; + + m = gfc_match_literal_constant (&expr, 1); + if (m == MATCH_YES) + { + *result = expr; + return MATCH_YES; + } + + if (m == MATCH_ERROR) + return MATCH_ERROR; + + m = gfc_match_null (result); + if (m != MATCH_NO) + return m; + + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; + + if (gfc_find_symbol (name, NULL, 1, &sym)) + return MATCH_ERROR; + + if (sym == NULL || sym->attr.flavor != FL_PARAMETER) + { + gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C", + name); + return MATCH_ERROR; + } + + *result = gfc_copy_expr (sym->value); + return MATCH_YES; +} + + +/* Match a list of values in a DATA statement. The leading '/' has + already been seen at this point. */ + +static match +top_val_list (gfc_data * data) +{ + gfc_data_value *new, *tail; + gfc_expr *expr; + const char *msg; + match m; + + tail = NULL; + + for (;;) + { + m = match_data_constant (&expr); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + return MATCH_ERROR; + + new = gfc_get_data_value (); + + if (tail == NULL) + data->value = new; + else + tail->next = new; + + tail = new; + + if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES) + { + tail->expr = expr; + tail->repeat = 1; + } + else + { + msg = gfc_extract_int (expr, &tail->repeat); + gfc_free_expr (expr); + if (msg != NULL) + { + gfc_error (msg); + return MATCH_ERROR; + } + + m = match_data_constant (&tail->expr); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + return MATCH_ERROR; + } + + if (gfc_match_char ('/') == MATCH_YES) + break; + if (gfc_match_char (',') == MATCH_NO) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_DATA); + return MATCH_ERROR; +} + + +/* Match a DATA statement. */ + +match +gfc_match_data (void) +{ + gfc_data *new; + match m; + + for (;;) + { + new = gfc_get_data (); + new->where = *gfc_current_locus (); + + m = top_var_list (new); + if (m != MATCH_YES) + goto cleanup; + + m = top_val_list (new); + if (m != MATCH_YES) + goto cleanup; + + new->next = gfc_current_ns->data; + gfc_current_ns->data = new; + + if (gfc_match_eos () == MATCH_YES) + break; + + gfc_match_char (','); /* Optional comma */ + } + + if (gfc_pure (NULL)) + { + gfc_error ("DATA statement at %C is not allowed in a PURE procedure"); + return MATCH_ERROR; + } + + return MATCH_YES; + +cleanup: + gfc_free_data (new); + return MATCH_ERROR; +} + + +/***************** SELECT CASE subroutines ******************/ + +/* Free a single case structure. */ + +static void +free_case (gfc_case * p) +{ + if (p->low == p->high) + p->high = NULL; + gfc_free_expr (p->low); + gfc_free_expr (p->high); + gfc_free (p); +} + + +/* Free a list of case structures. */ + +void +gfc_free_case_list (gfc_case * p) +{ + gfc_case *q; + + for (; p; p = q) + { + q = p->next; + free_case (p); + } +} + + +/* Match a single case selector. */ + +static match +match_case_selector (gfc_case ** cp) +{ + gfc_case *c; + match m; + + c = gfc_get_case (); + c->where = *gfc_current_locus (); + + if (gfc_match_char (':') == MATCH_YES) + { + m = gfc_match_expr (&c->high); + if (m == MATCH_NO) + goto need_expr; + if (m == MATCH_ERROR) + goto cleanup; + } + + else + { + m = gfc_match_expr (&c->low); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto need_expr; + + /* If we're not looking at a ':' now, make a range out of a single + target. Else get the upper bound for the case range. */ + if (gfc_match_char (':') != MATCH_YES) + c->high = c->low; + else + { + m = gfc_match_expr (&c->high); + if (m == MATCH_ERROR) + goto cleanup; + /* MATCH_NO is fine. It's OK if nothing is there! */ + } + } + + *cp = c; + return MATCH_YES; + +need_expr: + gfc_error ("Expected expression in CASE at %C"); + +cleanup: + free_case (c); + return MATCH_ERROR; +} + + +/* Match the end of a case statement. */ + +static match +match_case_eos (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + match m; + + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + + gfc_gobble_whitespace (); + + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; + + if (strcmp (name, gfc_current_block ()->name) != 0) + { + gfc_error ("Expected case name of '%s' at %C", + gfc_current_block ()->name); + return MATCH_ERROR; + } + + return gfc_match_eos (); +} + + +/* Match a SELECT statement. */ + +match +gfc_match_select (void) +{ + gfc_expr *expr; + match m; + + m = gfc_match_label (); + if (m == MATCH_ERROR) + return m; + + m = gfc_match (" select case ( %e )%t", &expr); + if (m != MATCH_YES) + return m; + + new_st.op = EXEC_SELECT; + new_st.expr = expr; + + return MATCH_YES; +} + + +/* Match a CASE statement. */ + +match +gfc_match_case (void) +{ + gfc_case *c, *head, *tail; + match m; + + head = tail = NULL; + + if (gfc_current_state () != COMP_SELECT) + { + gfc_error ("Unexpected CASE statement at %C"); + return MATCH_ERROR; + } + + if (gfc_match ("% default") == MATCH_YES) + { + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT; + c = gfc_get_case (); + c->where = *gfc_current_locus (); + new_st.ext.case_list = c; + return MATCH_YES; + } + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + for (;;) + { + if (match_case_selector (&c) == MATCH_ERROR) + goto cleanup; + + if (head == NULL) + head = c; + else + tail->next = c; + + tail = c; + + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT; + new_st.ext.case_list = head; + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in CASE-specification at %C"); + +cleanup: + gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */ + return MATCH_ERROR; +} + +/********************* WHERE subroutines ********************/ + +/* Match a WHERE statement. */ + +match +gfc_match_where (gfc_statement * st) +{ + gfc_expr *expr; + match m0, m; + gfc_code *c; + + m0 = gfc_match_label (); + if (m0 == MATCH_ERROR) + return m0; + + m = gfc_match (" where ( %e )", &expr); + if (m != MATCH_YES) + return m; + + if (gfc_match_eos () == MATCH_YES) + { + *st = ST_WHERE_BLOCK; + + new_st.op = EXEC_WHERE; + new_st.expr = expr; + return MATCH_YES; + } + + m = gfc_match_assignment (); + if (m == MATCH_NO) + gfc_syntax_error (ST_WHERE); + + if (m != MATCH_YES) + { + gfc_free_expr (expr); + return MATCH_ERROR; + } + + /* We've got a simple WHERE statement. */ + *st = ST_WHERE; + c = gfc_get_code (); + + c->op = EXEC_WHERE; + c->expr = expr; + c->next = gfc_get_code (); + + *c->next = new_st; + gfc_clear_new_st (); + + new_st.op = EXEC_WHERE; + new_st.block = c; + + return MATCH_YES; +} + + +/* Match an ELSEWHERE statement. We leave behind a WHERE node in + new_st if successful. */ + +match +gfc_match_elsewhere (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_expr *expr; + match m; + + if (gfc_current_state () != COMP_WHERE) + { + gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block"); + return MATCH_ERROR; + } + + expr = NULL; + + if (gfc_match_char ('(') == MATCH_YES) + { + m = gfc_match_expr (&expr); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + } + + if (gfc_match_eos () != MATCH_YES) + { /* Better be a name at this point */ + m = gfc_match_name (name); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_eos () != MATCH_YES) + goto syntax; + + if (strcmp (name, gfc_current_block ()->name) != 0) + { + gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'", + name, gfc_current_block ()->name); + goto cleanup; + } + } + + new_st.op = EXEC_WHERE; + new_st.expr = expr; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_ELSEWHERE); + +cleanup: + gfc_free_expr (expr); + return MATCH_ERROR; +} + + +/******************** FORALL subroutines ********************/ + +/* Free a list of FORALL iterators. */ + +void +gfc_free_forall_iterator (gfc_forall_iterator * iter) +{ + gfc_forall_iterator *next; + + while (iter) + { + next = iter->next; + + gfc_free_expr (iter->var); + gfc_free_expr (iter->start); + gfc_free_expr (iter->end); + gfc_free_expr (iter->stride); + + gfc_free (iter); + iter = next; + } +} + + +/* Match an iterator as part of a FORALL statement. The format is: + + <var> = <start>:<end>[:<stride>][, <scalar mask>] */ + +static match +match_forall_iterator (gfc_forall_iterator ** result) +{ + gfc_forall_iterator *iter; + locus where; + match m; + + where = *gfc_current_locus (); + iter = gfc_getmem (sizeof (gfc_forall_iterator)); + + m = gfc_match_variable (&iter->var, 0); + if (m != MATCH_YES) + goto cleanup; + + if (gfc_match_char ('=') != MATCH_YES) + { + m = MATCH_NO; + goto cleanup; + } + + m = gfc_match_expr (&iter->start); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (':') != MATCH_YES) + goto syntax; + + m = gfc_match_expr (&iter->end); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (':') == MATCH_NO) + iter->stride = gfc_int_expr (1); + else + { + m = gfc_match_expr (&iter->stride); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + } + + *result = iter; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in FORALL iterator at %C"); + m = MATCH_ERROR; + +cleanup: + gfc_set_locus (&where); + gfc_free_forall_iterator (iter); + return m; +} + + +/* Match a FORALL statement. */ + +match +gfc_match_forall (gfc_statement * st) +{ + gfc_forall_iterator *head, *tail, *new; + gfc_expr *mask; + gfc_code *c; + match m0, m; + + head = tail = NULL; + mask = NULL; + c = NULL; + + m0 = gfc_match_label (); + if (m0 == MATCH_ERROR) + return MATCH_ERROR; + + m = gfc_match (" forall ("); + if (m != MATCH_YES) + return m; + + m = match_forall_iterator (&new); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + head = tail = new; + + for (;;) + { + if (gfc_match_char (',') != MATCH_YES) + break; + + m = match_forall_iterator (&new); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + tail->next = new; + tail = new; + continue; + } + + /* Have to have a mask expression. */ + m = gfc_match_expr (&mask); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + break; + } + + if (gfc_match_char (')') == MATCH_NO) + goto syntax; + + if (gfc_match_eos () == MATCH_YES) + { + *st = ST_FORALL_BLOCK; + + new_st.op = EXEC_FORALL; + new_st.expr = mask; + new_st.ext.forall_iterator = head; + + return MATCH_YES; + } + + m = gfc_match_assignment (); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + m = gfc_match_pointer_assignment (); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + + c = gfc_get_code (); + *c = new_st; + + if (gfc_match_eos () != MATCH_YES) + goto syntax; + + gfc_clear_new_st (); + new_st.op = EXEC_FORALL; + new_st.expr = mask; + new_st.ext.forall_iterator = head; + new_st.block = gfc_get_code (); + + new_st.block->op = EXEC_FORALL; + new_st.block->next = c; + + *st = ST_FORALL; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_FORALL); + +cleanup: + gfc_free_forall_iterator (head); + gfc_free_expr (mask); + gfc_free_statements (c); + return MATCH_NO; +} diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h new file mode 100644 index 00000000000..6cd71339c49 --- /dev/null +++ b/gcc/fortran/match.h @@ -0,0 +1,164 @@ +/* All matcher functions. + Copyright (C) 2003 Free Software Foundation, Inc. + Contributed by Steven Bosscher + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#ifndef GFC_MATCH_H +#define GFC_MATCH_H + +#include "gfortran.h" + +/* gfc_new_block points to the symbol of a newly matched block. */ +extern gfc_symbol *gfc_new_block; + +/* Current statement label. Zero means no statement label. Because + new_st can get wiped during statement matching, we have to keep it + separate. */ +extern gfc_st_label *gfc_statement_label; + +/****************** All gfc_match* routines *****************/ + +/* match.c */ + +/* Generic match subroutines */ +match gfc_match_space (void); +match gfc_match_eos (void); +match gfc_match_small_literal_int (int *); +match gfc_match_st_label (gfc_st_label **, int); +match gfc_match_label (void); +match gfc_match_small_int (int *); +int gfc_match_strings (mstring *); +match gfc_match_name (char *); +match gfc_match_symbol (gfc_symbol **, int); +match gfc_match_sym_tree (gfc_symtree **, int); +match gfc_match_intrinsic_op (gfc_intrinsic_op *); +match gfc_match_char (char); +match gfc_match (const char *, ...); +match gfc_match_iterator (gfc_iterator *, int); + +/* Statement matchers */ +match gfc_match_program (void); +match gfc_match_pointer_assignment (void); +match gfc_match_assignment (void); +match gfc_match_if (gfc_statement *); +match gfc_match_else (void); +match gfc_match_elseif (void); +match gfc_match_do (void); +match gfc_match_cycle (void); +match gfc_match_exit (void); +match gfc_match_pause (void); +match gfc_match_stop (void); +match gfc_match_continue (void); +match gfc_match_assign (void); +match gfc_match_goto (void); + +match gfc_match_allocate (void); +match gfc_match_nullify (void); +match gfc_match_deallocate (void); +match gfc_match_return (void); +match gfc_match_call (void); +match gfc_match_common (void); +match gfc_match_implicit_none (void); +match gfc_match_implicit (void); +match gfc_match_block_data (void); +match gfc_match_namelist (void); +match gfc_match_module (void); +match gfc_match_equivalence (void); +match gfc_match_st_function (void); +match gfc_match_data (void); +match gfc_match_case (void); +match gfc_match_select (void); +match gfc_match_where (gfc_statement *); +match gfc_match_elsewhere (void); +match gfc_match_forall (gfc_statement *); + +/* decl.c */ + +match gfc_match_null (gfc_expr **); +match gfc_match_kind_spec (gfc_typespec *); +match gfc_match_old_kind_spec (gfc_typespec *); +match gfc_match_type_spec (gfc_typespec *, int); + +match gfc_match_end (gfc_statement *); +match gfc_match_data_decl (void); +match gfc_match_formal_arglist (gfc_symbol *, int, int); +match gfc_match_function_decl (void); +match gfc_match_entry (void); +match gfc_match_subroutine (void); +match gfc_match_derived_decl (void); + +/* Matchers for attribute declarations */ +match gfc_match_allocatable (void); +match gfc_match_dimension (void); +match gfc_match_external (void); +match gfc_match_intent (void); +match gfc_match_intrinsic (void); +match gfc_match_optional (void); +match gfc_match_parameter (void); +match gfc_match_pointer (void); +match gfc_match_private (gfc_statement *); +match gfc_match_public (gfc_statement *); +match gfc_match_save (void); +match gfc_match_modproc (void); +match gfc_match_target (void); + +/* primary.c */ +match gfc_match_rvalue (gfc_expr **); +match gfc_match_variable (gfc_expr **, int); +match gfc_match_actual_arglist (int, gfc_actual_arglist **); +match gfc_match_literal_constant (gfc_expr **, int); + +/* expr.c -- FIXME: this one should be eliminated by moving the + matcher to matchexp.c and a call to a new function in expr.c that + only makes sure the init expr. is valid. */ +match gfc_match_init_expr (gfc_expr **); + +/* array.c */ +match gfc_match_array_spec (gfc_array_spec **); +match gfc_match_array_ref (gfc_array_ref *, gfc_array_spec *, int); +match gfc_match_array_constructor (gfc_expr **); + +/* interface.c */ +match gfc_match_generic_spec (interface_type *, char *, gfc_intrinsic_op *); +match gfc_match_interface (void); +match gfc_match_end_interface (void); + +/* io.c */ +match gfc_match_format (void); +match gfc_match_open (void); +match gfc_match_close (void); +match gfc_match_endfile (void); +match gfc_match_backspace (void); +match gfc_match_rewind (void); +match gfc_match_inquire (void); +match gfc_match_read (void); +match gfc_match_write (void); +match gfc_match_print (void); + +/* matchexp.c */ +match gfc_match_defined_op_name (char *, int); +match gfc_match_expr (gfc_expr **); + +/* module.c */ +match gfc_match_use (void); +void gfc_use_module (void); + +#endif /* GFC_MATCH_H */ + diff --git a/gcc/fortran/matchexp.c b/gcc/fortran/matchexp.c new file mode 100644 index 00000000000..4acd98e66fc --- /dev/null +++ b/gcc/fortran/matchexp.c @@ -0,0 +1,776 @@ +/* Expression parser. + Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#include "config.h" +#include <string.h> +#include "gfortran.h" +#include "arith.h" +#include "match.h" + +static char expression_syntax[] = "Syntax error in expression at %C"; + + +/* Match a user-defined operator name. This is a normal name with a + few restrictions. The error_flag controls whether an error is + raised if 'true' or 'false' are used or not. */ + +match +gfc_match_defined_op_name (char *result, int error_flag) +{ + static const char * const badops[] = { + "and", "or", "not", "eqv", "neqv", "eq", "ne", "ge", "le", "lt", "gt", + NULL + }; + + char name[GFC_MAX_SYMBOL_LEN + 1]; + locus old_loc; + match m; + int i; + + old_loc = *gfc_current_locus (); + + m = gfc_match (" . %n .", name); + if (m != MATCH_YES) + return m; + + /* .true. and .false. have interpretations as constants. Trying to + use these as operators will fail at a later time. */ + + if (strcmp (name, "true") == 0 || strcmp (name, "false") == 0) + { + if (error_flag) + goto error; + gfc_set_locus (&old_loc); + return MATCH_NO; + } + + for (i = 0; badops[i]; i++) + if (strcmp (badops[i], name) == 0) + goto error; + + for (i = 0; name[i]; i++) + if (!ISALPHA (name[i])) + { + gfc_error ("Bad character '%c' in OPERATOR name at %C", name[i]); + return MATCH_ERROR; + } + + strcpy (result, name); + return MATCH_YES; + +error: + gfc_error ("The name '%s' cannot be used as a defined operator at %C", + name); + + gfc_set_locus (&old_loc); + return MATCH_ERROR; +} + + +/* Match a user defined operator. The symbol found must be an + operator already. */ + +static match +match_defined_operator (gfc_user_op ** result) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + match m; + + m = gfc_match_defined_op_name (name, 0); + if (m != MATCH_YES) + return m; + + *result = gfc_get_uop (name); + return MATCH_YES; +} + + +/* Check to see if the given operator is next on the input. If this + is not the case, the parse pointer remains where it was. */ + +static int +next_operator (gfc_intrinsic_op t) +{ + gfc_intrinsic_op u; + locus old_loc; + + old_loc = *gfc_current_locus (); + if (gfc_match_intrinsic_op (&u) == MATCH_YES && t == u) + return 1; + + gfc_set_locus (&old_loc); + return 0; +} + + +/* Match a primary expression. */ + +static match +match_primary (gfc_expr ** result) +{ + match m; + + m = gfc_match_literal_constant (result, 0); + if (m != MATCH_NO) + return m; + + m = gfc_match_array_constructor (result); + if (m != MATCH_NO) + return m; + + m = gfc_match_rvalue (result); + if (m != MATCH_NO) + return m; + + /* Match an expression in parenthesis. */ + if (gfc_match_char ('(') != MATCH_YES) + return MATCH_NO; + + m = gfc_match_expr (result); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + return m; + + m = gfc_match_char (')'); + if (m == MATCH_NO) + gfc_error ("Expected a right parenthesis in expression at %C"); + + if (m != MATCH_YES) + { + gfc_free_expr (*result); + return MATCH_ERROR; + } + + return MATCH_YES; + +syntax: + gfc_error (expression_syntax); + return MATCH_ERROR; +} + + +/* Build an operator expression node. */ + +static gfc_expr * +build_node (gfc_intrinsic_op operator, locus * where, + gfc_expr * op1, gfc_expr * op2) +{ + gfc_expr *new; + + new = gfc_get_expr (); + new->expr_type = EXPR_OP; + new->operator = operator; + new->where = *where; + + new->op1 = op1; + new->op2 = op2; + + return new; +} + + +/* Match a level 1 expression. */ + +static match +match_level_1 (gfc_expr ** result) +{ + gfc_user_op *uop; + gfc_expr *e, *f; + locus where; + match m; + + where = *gfc_current_locus (); + uop = NULL; + m = match_defined_operator (&uop); + if (m == MATCH_ERROR) + return m; + + m = match_primary (&e); + if (m != MATCH_YES) + return m; + + if (uop == NULL) + *result = e; + else + { + f = build_node (INTRINSIC_USER, &where, e, NULL); + f->uop = uop; + *result = f; + } + + return MATCH_YES; +} + + +static match +match_mult_operand (gfc_expr ** result) +{ + gfc_expr *e, *exp, *r; + locus where; + match m; + + m = match_level_1 (&e); + if (m != MATCH_YES) + return m; + + if (!next_operator (INTRINSIC_POWER)) + { + *result = e; + return MATCH_YES; + } + + where = *gfc_current_locus (); + + m = match_mult_operand (&exp); + if (m == MATCH_NO) + gfc_error ("Expected exponent in expression at %C"); + if (m != MATCH_YES) + { + gfc_free_expr (e); + return MATCH_ERROR; + } + + r = gfc_power (e, exp); + if (r == NULL) + { + gfc_free_expr (e); + gfc_free_expr (exp); + return MATCH_ERROR; + } + + r->where = where; + *result = r; + + return MATCH_YES; +} + + +static match +match_add_operand (gfc_expr ** result) +{ + gfc_expr *all, *e, *total; + locus where, old_loc; + match m; + gfc_intrinsic_op i; + + m = match_mult_operand (&all); + if (m != MATCH_YES) + return m; + + for (;;) + { + /* Build up a string of products or quotients. */ + + old_loc = *gfc_current_locus (); + + if (next_operator (INTRINSIC_TIMES)) + i = INTRINSIC_TIMES; + else + { + if (next_operator (INTRINSIC_DIVIDE)) + i = INTRINSIC_DIVIDE; + else + break; + } + + where = *gfc_current_locus (); + + m = match_mult_operand (&e); + if (m == MATCH_NO) + { + gfc_set_locus (&old_loc); + break; + } + + if (m == MATCH_ERROR) + { + gfc_free_expr (all); + return MATCH_ERROR; + } + + if (i == INTRINSIC_TIMES) + total = gfc_multiply (all, e); + else + total = gfc_divide (all, e); + + if (total == NULL) + { + gfc_free_expr (all); + gfc_free_expr (e); + return MATCH_ERROR; + } + + all = total; + all->where = where; + } + + *result = all; + return MATCH_YES; +} + + +static int +match_add_op (void) +{ + + if (next_operator (INTRINSIC_MINUS)) + return -1; + if (next_operator (INTRINSIC_PLUS)) + return 1; + return 0; +} + + +/* Match a level 2 expression. */ + +static match +match_level_2 (gfc_expr ** result) +{ + gfc_expr *all, *e, *total; + locus where; + match m; + int i; + + where = *gfc_current_locus (); + i = match_add_op (); + + m = match_add_operand (&e); + if (i != 0 && m == MATCH_NO) + { + gfc_error (expression_syntax); + m = MATCH_ERROR; + } + + if (m != MATCH_YES) + return m; + + if (i == 0) + all = e; + else + { + if (i == -1) + all = gfc_uminus (e); + else + all = gfc_uplus (e); + + if (all == NULL) + { + gfc_free_expr (e); + return MATCH_ERROR; + } + } + + all->where = where; + +/* Append add-operands to the sum */ + + for (;;) + { + where = *gfc_current_locus (); + i = match_add_op (); + if (i == 0) + break; + + m = match_add_operand (&e); + if (m == MATCH_NO) + gfc_error (expression_syntax); + if (m != MATCH_YES) + { + gfc_free_expr (all); + return MATCH_ERROR; + } + + if (i == -1) + total = gfc_subtract (all, e); + else + total = gfc_add (all, e); + + if (total == NULL) + { + gfc_free_expr (all); + gfc_free_expr (e); + return MATCH_ERROR; + } + + all = total; + all->where = where; + } + + *result = all; + return MATCH_YES; +} + + +/* Match a level three expression. */ + +static match +match_level_3 (gfc_expr ** result) +{ + gfc_expr *all, *e, *total; + locus where; + match m; + + m = match_level_2 (&all); + if (m != MATCH_YES) + return m; + + for (;;) + { + if (!next_operator (INTRINSIC_CONCAT)) + break; + + where = *gfc_current_locus (); + + m = match_level_2 (&e); + if (m == MATCH_NO) + { + gfc_error (expression_syntax); + gfc_free_expr (all); + } + if (m != MATCH_YES) + return MATCH_ERROR; + + total = gfc_concat (all, e); + if (total == NULL) + { + gfc_free_expr (all); + gfc_free_expr (e); + return MATCH_ERROR; + } + + all = total; + all->where = where; + } + + *result = all; + return MATCH_YES; +} + + +/* Match a level 4 expression. */ + +static match +match_level_4 (gfc_expr ** result) +{ + gfc_expr *left, *right, *r; + gfc_intrinsic_op i; + locus old_loc; + locus where; + match m; + + m = match_level_3 (&left); + if (m != MATCH_YES) + return m; + + old_loc = *gfc_current_locus (); + + if (gfc_match_intrinsic_op (&i) != MATCH_YES) + { + *result = left; + return MATCH_YES; + } + + if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE + && i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT) + { + gfc_set_locus (&old_loc); + *result = left; + return MATCH_YES; + } + + where = *gfc_current_locus (); + + m = match_level_3 (&right); + if (m == MATCH_NO) + gfc_error (expression_syntax); + if (m != MATCH_YES) + { + gfc_free_expr (left); + return MATCH_ERROR; + } + + switch (i) + { + case INTRINSIC_EQ: + r = gfc_eq (left, right); + break; + + case INTRINSIC_NE: + r = gfc_ne (left, right); + break; + + case INTRINSIC_LT: + r = gfc_lt (left, right); + break; + + case INTRINSIC_LE: + r = gfc_le (left, right); + break; + + case INTRINSIC_GT: + r = gfc_gt (left, right); + break; + + case INTRINSIC_GE: + r = gfc_ge (left, right); + break; + + default: + gfc_internal_error ("match_level_4(): Bad operator"); + } + + if (r == NULL) + { + gfc_free_expr (left); + gfc_free_expr (right); + return MATCH_ERROR; + } + + r->where = where; + *result = r; + + return MATCH_YES; +} + + +static match +match_and_operand (gfc_expr ** result) +{ + gfc_expr *e, *r; + locus where; + match m; + int i; + + i = next_operator (INTRINSIC_NOT); + where = *gfc_current_locus (); + + m = match_level_4 (&e); + if (m != MATCH_YES) + return m; + + r = e; + if (i) + { + r = gfc_not (e); + if (r == NULL) + { + gfc_free_expr (e); + return MATCH_ERROR; + } + } + + r->where = where; + *result = r; + + return MATCH_YES; +} + + +static match +match_or_operand (gfc_expr ** result) +{ + gfc_expr *all, *e, *total; + locus where; + match m; + + m = match_and_operand (&all); + if (m != MATCH_YES) + return m; + + for (;;) + { + if (!next_operator (INTRINSIC_AND)) + break; + where = *gfc_current_locus (); + + m = match_and_operand (&e); + if (m == MATCH_NO) + gfc_error (expression_syntax); + if (m != MATCH_YES) + { + gfc_free_expr (all); + return MATCH_ERROR; + } + + total = gfc_and (all, e); + if (total == NULL) + { + gfc_free_expr (all); + gfc_free_expr (e); + return MATCH_ERROR; + } + + all = total; + all->where = where; + } + + *result = all; + return MATCH_YES; +} + + +static match +match_equiv_operand (gfc_expr ** result) +{ + gfc_expr *all, *e, *total; + locus where; + match m; + + m = match_or_operand (&all); + if (m != MATCH_YES) + return m; + + for (;;) + { + if (!next_operator (INTRINSIC_OR)) + break; + where = *gfc_current_locus (); + + m = match_or_operand (&e); + if (m == MATCH_NO) + gfc_error (expression_syntax); + if (m != MATCH_YES) + { + gfc_free_expr (all); + return MATCH_ERROR; + } + + total = gfc_or (all, e); + if (total == NULL) + { + gfc_free_expr (all); + gfc_free_expr (e); + return MATCH_ERROR; + } + + all = total; + all->where = where; + } + + *result = all; + return MATCH_YES; +} + + +/* Match a level 5 expression. */ + +static match +match_level_5 (gfc_expr ** result) +{ + gfc_expr *all, *e, *total; + locus where; + match m; + gfc_intrinsic_op i; + + m = match_equiv_operand (&all); + if (m != MATCH_YES) + return m; + + for (;;) + { + if (next_operator (INTRINSIC_EQV)) + i = INTRINSIC_EQV; + else + { + if (next_operator (INTRINSIC_NEQV)) + i = INTRINSIC_NEQV; + else + break; + } + + where = *gfc_current_locus (); + + m = match_equiv_operand (&e); + if (m == MATCH_NO) + gfc_error (expression_syntax); + if (m != MATCH_YES) + { + gfc_free_expr (all); + return MATCH_ERROR; + } + + if (i == INTRINSIC_EQV) + total = gfc_eqv (all, e); + else + total = gfc_neqv (all, e); + + if (total == NULL) + { + gfc_free_expr (all); + gfc_free_expr (e); + return MATCH_ERROR; + } + + all = total; + all->where = where; + } + + *result = all; + return MATCH_YES; +} + + +/* Match an expression. At this level, we are stringing together + level 5 expressions separated by binary operators. */ + +match +gfc_match_expr (gfc_expr ** result) +{ + gfc_expr *all, *e; + gfc_user_op *uop; + locus where; + match m; + + m = match_level_5 (&all); + if (m != MATCH_YES) + return m; + + for (;;) + { + m = match_defined_operator (&uop); + if (m == MATCH_NO) + break; + if (m == MATCH_ERROR) + { + gfc_free_expr (all); + return MATCH_ERROR; + } + + where = *gfc_current_locus (); + + m = match_level_5 (&e); + if (m == MATCH_NO) + gfc_error (expression_syntax); + if (m != MATCH_YES) + { + gfc_free_expr (all); + return MATCH_ERROR; + } + + all = build_node (INTRINSIC_USER, &where, all, e); + all->uop = uop; + } + + *result = all; + return MATCH_YES; +} diff --git a/gcc/fortran/mathbuiltins.def b/gcc/fortran/mathbuiltins.def new file mode 100644 index 00000000000..c46c1d523a5 --- /dev/null +++ b/gcc/fortran/mathbuiltins.def @@ -0,0 +1,14 @@ +DEFINE_MATH_BUILTIN (ACOS, "acos", 1) +DEFINE_MATH_BUILTIN (ASIN, "asin", 1) +DEFINE_MATH_BUILTIN (ATAN, "atan", 1) +DEFINE_MATH_BUILTIN (ATAN2, "atan2", 2) +DEFINE_MATH_BUILTIN (COS, "cos", 1) +DEFINE_MATH_BUILTIN (COSH, "cosh", 1) +DEFINE_MATH_BUILTIN (EXP, "exp", 1) +DEFINE_MATH_BUILTIN (LOG, "log", 1) +DEFINE_MATH_BUILTIN (LOG10, "log10", 1) +DEFINE_MATH_BUILTIN (SIN, "sin", 1) +DEFINE_MATH_BUILTIN (SINH, "sinh", 1) +DEFINE_MATH_BUILTIN (SQRT, "sqrt", 1) +DEFINE_MATH_BUILTIN (TAN, "tan", 1) +DEFINE_MATH_BUILTIN (TANH, "tanh", 1) diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c new file mode 100644 index 00000000000..1054386e0e3 --- /dev/null +++ b/gcc/fortran/misc.c @@ -0,0 +1,327 @@ +/* Miscellaneous stuff that doesn't fit anywhere else. + Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#include "config.h" +#include <stdlib.h> +#include <string.h> +#include <sys/stat.h> + +#include "gfortran.h" + + +/* Get a block of memory. Many callers assume that the memory we + return is zeroed. */ + +void * +gfc_getmem (size_t n) +{ + void *p; + + if (n == 0) + return NULL; + + p = xmalloc (n); + if (p == NULL) + gfc_fatal_error ("Out of memory-- malloc() failed"); + memset (p, 0, n); + return p; +} + + +/* gfortran.h defines free to something that triggers a syntax error, + but we need free() here. */ + +#define temp free +#undef free + +void +gfc_free (void *p) +{ + + if (p != NULL) + free (p); +} + +#define free temp +#undef temp + + +/* Get terminal width */ + +int +gfc_terminal_width(void) +{ + return 80; +} + + +/* Initialize a typespec to unknown. */ + +void +gfc_clear_ts (gfc_typespec * ts) +{ + + ts->type = BT_UNKNOWN; + ts->kind = 0; + ts->derived = NULL; + ts->cl = NULL; +} + + +/* Open a file for reading. */ + +FILE * +gfc_open_file (const char *name) +{ + struct stat statbuf; + + if (!*name) + return stdin; + + if (stat (name, &statbuf) < 0) + return NULL; + + if (!S_ISREG (statbuf.st_mode)) + return NULL; + + return fopen (name, "r"); +} + + +/* Given a word, return the correct article. */ + +const char * +gfc_article (const char *word) +{ + const char *p; + + switch (*word) + { + case 'a': + case 'A': + case 'e': + case 'E': + case 'i': + case 'I': + case 'o': + case 'O': + case 'u': + case 'U': + p = "an"; + break; + + default: + p = "a"; + } + + return p; +} + + +/* Return a string for each type. */ + +const char * +gfc_basic_typename (bt type) +{ + const char *p; + + switch (type) + { + case BT_INTEGER: + p = "INTEGER"; + break; + case BT_REAL: + p = "REAL"; + break; + case BT_COMPLEX: + p = "COMPLEX"; + break; + case BT_LOGICAL: + p = "LOGICAL"; + break; + case BT_CHARACTER: + p = "CHARACTER"; + break; + case BT_DERIVED: + p = "DERIVED"; + break; + case BT_PROCEDURE: + p = "PROCEDURE"; + break; + case BT_UNKNOWN: + p = "UNKNOWN"; + break; + default: + gfc_internal_error ("gfc_basic_typename(): Undefined type"); + } + + return p; +} + + +/* Return a string descibing the type and kind of a typespec. Because + we return alternating buffers, this subroutine can appear twice in + the argument list of a single statement. */ + +const char * +gfc_typename (gfc_typespec * ts) +{ + static char buffer1[60], buffer2[60]; + static int flag = 0; + char *buffer; + + buffer = flag ? buffer1 : buffer2; + flag = !flag; + + switch (ts->type) + { + case BT_INTEGER: + sprintf (buffer, "INTEGER(%d)", ts->kind); + break; + case BT_REAL: + sprintf (buffer, "REAL(%d)", ts->kind); + break; + case BT_COMPLEX: + sprintf (buffer, "COMPLEX(%d)", ts->kind); + break; + case BT_LOGICAL: + sprintf (buffer, "LOGICAL(%d)", ts->kind); + break; + case BT_CHARACTER: + sprintf (buffer, "CHARACTER(%d)", ts->kind); + break; + case BT_DERIVED: + sprintf (buffer, "TYPE(%s)", ts->derived->name); + break; + case BT_PROCEDURE: + strcpy (buffer, "PROCEDURE"); + break; + case BT_UNKNOWN: + strcpy (buffer, "UNKNOWN"); + break; + default: + gfc_internal_error ("gfc_typespec(): Undefined type"); + } + + return buffer; +} + + +/* Given an mstring array and a code, locate the code in the table, + returning a pointer to the string. */ + +const char * +gfc_code2string (const mstring * m, int code) +{ + + while (m->string != NULL) + { + if (m->tag == code) + return m->string; + m++; + } + + gfc_internal_error ("gfc_code2string(): Bad code"); + /* Not reached */ +} + + +/* Given an mstring array and a string, returns the value of the tag + field. Returns the final tag if no matches to the string are + found. */ + +int +gfc_string2code (const mstring * m, const char *string) +{ + + for (; m->string != NULL; m++) + if (strcmp (m->string, string) == 0) + return m->tag; + + return m->tag; +} + + +/* Convert an intent code to a string. */ +/* TODO: move to gfortran.h as define. */ +const char * +gfc_intent_string (sym_intent i) +{ + + return gfc_code2string (intents, i); +} + + +/***************** Initialization functions ****************/ + +/* Top level initialization. */ + +void +gfc_init_1 (void) +{ + + gfc_error_init_1 (); + gfc_scanner_init_1 (); + gfc_arith_init_1 (); + gfc_intrinsic_init_1 (); + gfc_iresolve_init_1 (); + gfc_simplify_init_1 (); +} + + +/* Per program unit initialization. */ + +void +gfc_init_2 (void) +{ + + gfc_symbol_init_2 (); + gfc_module_init_2 (); +} + + +/******************* Destructor functions ******************/ + +/* Call all of the top level destructors. */ + +void +gfc_done_1 (void) +{ + + gfc_scanner_done_1 (); + gfc_intrinsic_done_1 (); + gfc_simplify_done_1 (); + gfc_iresolve_done_1 (); + gfc_arith_done_1 (); +} + + +/* Per program unit destructors. */ + +void +gfc_done_2 (void) +{ + + gfc_symbol_done_2 (); + gfc_module_done_2 (); +} + diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c new file mode 100644 index 00000000000..3498f75d463 --- /dev/null +++ b/gcc/fortran/module.c @@ -0,0 +1,3459 @@ +/* Handle modules, which amounts to loading and saving symbols and + their attendant structures. + Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* The syntax of g95 modules resembles that of lisp lists, ie a + sequence of atoms, which can be left or right parenthesis, names, + integers or strings. Parenthesis are always matched which allows + us to skip over sections at high speed without having to know + anything about the internal structure of the lists. A "name" is + usually a fortran 95 identifier, but can also start with '@' in + order to reference a hidden symbol. + + The first line of a module is an informational message about what + created the module, the file it came from and when it was created. + The second line is a warning for people not to edit the module. + The rest of the module looks like: + + ( ( <Interface info for UPLUS> ) + ( <Interface info for UMINUS> ) + ... + ) + ( ( <name of operator interface> <module of op interface> <i/f1> ... ) + ... + ) + ( ( <name of generic interface> <module of generic interface> <i/f1> ... ) + ... + ) + ( <Symbol Number (in no particular order)> + <True name of symbol> + <Module name of symbol> + ( <symbol information> ) + ... + ) + ( <Symtree name> + <Ambiguous flag> + <Symbol number> + ... + ) + + In general, symbols refer to other symbols by their symbol number, + which are zero based. Symbols are written to the module in no + particular order. */ + +#include "config.h" +#include <string.h> +#include <stdio.h> +#include <errno.h> +#include <unistd.h> +#include <time.h> + +#include "gfortran.h" +#include "match.h" +#include "parse.h" /* FIXME */ + +#define MODULE_EXTENSION ".mod" + + +/* Structure that descibes a position within a module file */ + +typedef struct +{ + int column, line; + fpos_t pos; +} +module_locus; + + +typedef enum +{ + P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL +} +pointer_t; + +/* The fixup structure lists pointers to pointers that have to + be updated when a pointer value becomes known. */ + +typedef struct fixup_t +{ + void **pointer; + struct fixup_t *next; +} +fixup_t; + + +/* Structure for holding extra info needed for pointers being read */ + +typedef struct pointer_info +{ + BBT_HEADER (pointer_info); + int integer; + pointer_t type; + + /* The first component of each member of the union is the pointer + being stored */ + + fixup_t *fixup; + + union + { + void *pointer; /* Member for doing pointer searches */ + + struct + { + gfc_symbol *sym; + char true_name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1]; + enum + { UNUSED, NEEDED, USED } + state; + int ns, referenced; + module_locus where; + fixup_t *stfixup; + gfc_symtree *symtree; + } + rsym; + + struct + { + gfc_symbol *sym; + enum + { UNREFERENCED = 0, NEEDS_WRITE, WRITTEN } + state; + } + wsym; + } + u; + +} +pointer_info; + +#define gfc_get_pointer_info() gfc_getmem(sizeof(pointer_info)) + + +/* Lists of rename info for the USE statement */ + +typedef struct gfc_use_rename +{ + char local_name[GFC_MAX_SYMBOL_LEN + 1], use_name[GFC_MAX_SYMBOL_LEN + 1]; + struct gfc_use_rename *next; + int found; + gfc_intrinsic_op operator; + locus where; +} +gfc_use_rename; + +#define gfc_get_use_rename() gfc_getmem(sizeof(gfc_use_rename)) + +/* Local variables */ + +/* The FILE for the module we're reading or writing. */ +static FILE *module_fp; + +/* The name of the module we're reading (USE'ing) or writing. */ +static char module_name[GFC_MAX_SYMBOL_LEN + 1]; + +static int module_line, module_column, only_flag; +static enum +{ IO_INPUT, IO_OUTPUT } +iomode; + +static gfc_use_rename *gfc_rename_list; +static pointer_info *pi_root; +static int symbol_number; /* Counter for assigning symbol numbers */ + + + +/*****************************************************************/ + +/* Pointer/integer conversion. Pointers between structures are stored + as integers in the module file. The next couple of subroutines + handle this translation for reading and writing. */ + +/* Recursively free the tree of pointer structures. */ + +static void +free_pi_tree (pointer_info * p) +{ + + if (p == NULL) + return; + + if (p->fixup != NULL) + gfc_internal_error ("free_pi_tree(): Unresolved fixup"); + + free_pi_tree (p->left); + free_pi_tree (p->right); + + gfc_free (p); +} + + +/* Compare pointers when searching by pointer. Used when writing a + module. */ + +static int +compare_pointers (void * _sn1, void * _sn2) +{ + pointer_info *sn1, *sn2; + + sn1 = (pointer_info *) _sn1; + sn2 = (pointer_info *) _sn2; + + if (sn1->u.pointer < sn2->u.pointer) + return -1; + if (sn1->u.pointer > sn2->u.pointer) + return 1; + + return 0; +} + + +/* Compare integers when searching by integer. Used when reading a + module. */ + +static int +compare_integers (void * _sn1, void * _sn2) +{ + pointer_info *sn1, *sn2; + + sn1 = (pointer_info *) _sn1; + sn2 = (pointer_info *) _sn2; + + if (sn1->integer < sn2->integer) + return -1; + if (sn1->integer > sn2->integer) + return 1; + + return 0; +} + + +/* Initialize the pointer_info tree. */ + +static void +init_pi_tree (void) +{ + compare_fn compare; + pointer_info *p; + + pi_root = NULL; + compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers; + + /* Pointer 0 is the NULL pointer. */ + p = gfc_get_pointer_info (); + p->u.pointer = NULL; + p->integer = 0; + p->type = P_OTHER; + + gfc_insert_bbt (&pi_root, p, compare); + + /* Pointer 1 is the current namespace. */ + p = gfc_get_pointer_info (); + p->u.pointer = gfc_current_ns; + p->integer = 1; + p->type = P_NAMESPACE; + + gfc_insert_bbt (&pi_root, p, compare); + + symbol_number = 2; +} + + +/* During module writing, call here with a pointer to something, + returning the pointer_info node. */ + +static pointer_info * +find_pointer (void *gp) +{ + pointer_info *p; + + p = pi_root; + while (p != NULL) + { + if (p->u.pointer == gp) + break; + p = (gp < p->u.pointer) ? p->left : p->right; + } + + return p; +} + + +/* Given a pointer while writing, returns the pointer_info tree node, + creating it if it doesn't exist. */ + +static pointer_info * +get_pointer (void *gp) +{ + pointer_info *p; + + p = find_pointer (gp); + if (p != NULL) + return p; + + /* Pointer doesn't have an integer. Give it one. */ + p = gfc_get_pointer_info (); + + p->u.pointer = gp; + p->integer = symbol_number++; + + gfc_insert_bbt (&pi_root, p, compare_pointers); + + return p; +} + + +/* Given an integer during reading, find it in the pointer_info tree, + creating the node if not found. */ + +static pointer_info * +get_integer (int integer) +{ + pointer_info *p, t; + int c; + + t.integer = integer; + + p = pi_root; + while (p != NULL) + { + c = compare_integers (&t, p); + if (c == 0) + break; + + p = (c < 0) ? p->left : p->right; + } + + if (p != NULL) + return p; + + p = gfc_get_pointer_info (); + p->integer = integer; + p->u.pointer = NULL; + + gfc_insert_bbt (&pi_root, p, compare_integers); + + return p; +} + + +/* Recursive function to find a pointer within a tree by brute force. */ + +static pointer_info * +fp2 (pointer_info * p, const void *target) +{ + pointer_info *q; + + if (p == NULL) + return NULL; + + if (p->u.pointer == target) + return p; + + q = fp2 (p->left, target); + if (q != NULL) + return q; + + return fp2 (p->right, target); +} + + +/* During reading, find a pointer_info node from the pointer value. + This amounts to a brute-force search. */ + +static pointer_info * +find_pointer2 (void *p) +{ + + return fp2 (pi_root, p); +} + + +/* Resolve any fixups using a known pointer. */ +static void +resolve_fixups (fixup_t *f, void * gp) +{ + fixup_t *next; + + for (; f; f = next) + { + next = f->next; + *(f->pointer) = gp; + gfc_free (f); + } +} + +/* Call here during module reading when we know what pointer to + associate with an integer. Any fixups that exist are resolved at + this time. */ + +static void +associate_integer_pointer (pointer_info * p, void *gp) +{ + if (p->u.pointer != NULL) + gfc_internal_error ("associate_integer_pointer(): Already associated"); + + p->u.pointer = gp; + + resolve_fixups (p->fixup, gp); + + p->fixup = NULL; +} + + +/* During module reading, given an integer and a pointer to a pointer, + either store the pointer from an already-known value or create a + fixup structure in order to store things later. Returns zero if + the reference has been actually stored, or nonzero if the reference + must be fixed later (ie associate_integer_pointer must be called + sometime later. Returns the pointer_info structure. */ + +static pointer_info * +add_fixup (int integer, void *gp) +{ + pointer_info *p; + fixup_t *f; + char **cp; + + p = get_integer (integer); + + if (p->integer == 0 || p->u.pointer != NULL) + { + cp = gp; + *cp = p->u.pointer; + } + else + { + f = gfc_getmem (sizeof (fixup_t)); + + f->next = p->fixup; + p->fixup = f; + + f->pointer = gp; + } + + return p; +} + + +/*****************************************************************/ + +/* Parser related subroutines */ + +/* Free the rename list left behind by a USE statement. */ + +static void +free_rename (void) +{ + gfc_use_rename *next; + + for (; gfc_rename_list; gfc_rename_list = next) + { + next = gfc_rename_list->next; + gfc_free (gfc_rename_list); + } +} + + +/* Match a USE statement. */ + +match +gfc_match_use (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_use_rename *tail = NULL, *new; + interface_type type; + gfc_intrinsic_op operator; + match m; + + m = gfc_match_name (module_name); + if (m != MATCH_YES) + return m; + + free_rename (); + only_flag = 0; + + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + if (gfc_match (" only :") == MATCH_YES) + only_flag = 1; + + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + + for (;;) + { + /* Get a new rename struct and add it to the rename list. */ + new = gfc_get_use_rename (); + new->where = *gfc_current_locus (); + new->found = 0; + + if (gfc_rename_list == NULL) + gfc_rename_list = new; + else + tail->next = new; + tail = new; + + /* See what kind of interface we're dealing with. Asusume it is + not an operator. */ + new->operator = INTRINSIC_NONE; + if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR) + goto cleanup; + + switch (type) + { + case INTERFACE_NAMELESS: + gfc_error ("Missing generic specification in USE statement at %C"); + goto cleanup; + + case INTERFACE_GENERIC: + m = gfc_match (" =>"); + + if (only_flag) + { + if (m != MATCH_YES) + strcpy (new->use_name, name); + else + { + strcpy (new->local_name, name); + + m = gfc_match_name (new->use_name); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + } + } + else + { + if (m != MATCH_YES) + goto syntax; + strcpy (new->local_name, name); + + m = gfc_match_name (new->use_name); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + } + + break; + + case INTERFACE_USER_OP: + strcpy (new->use_name, name); + /* Fall through */ + + case INTERFACE_INTRINSIC_OP: + new->operator = operator; + break; + } + + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_USE); + +cleanup: + free_rename (); + return MATCH_ERROR; +} + + +/* Given a name, return the name under which to load this symbol. + Returns NULL if this symbol shouldn't be loaded. */ + +static const char * +find_use_name (const char *name) +{ + gfc_use_rename *u; + + for (u = gfc_rename_list; u; u = u->next) + if (strcmp (u->use_name, name) == 0) + break; + + if (u == NULL) + return only_flag ? NULL : name; + + u->found = 1; + + return (u->local_name[0] != '\0') ? u->local_name : name; +} + + +/* Try to find the operator in the current list. */ + +static gfc_use_rename * +find_use_operator (gfc_intrinsic_op operator) +{ + gfc_use_rename *u; + + for (u = gfc_rename_list; u; u = u->next) + if (u->operator == operator) + return u; + + return NULL; +} + + +/*****************************************************************/ + +/* The next couple of subroutines maintain a tree used to avoid a + brute-force search for a combination of true name and module name. + While symtree names, the name that a particular symbol is known by + can changed with USE statements, we still have to keep track of the + true names to generate the correct reference, and also avoid + loading the same real symbol twice in a program unit. + + When we start reading, the true name tree is built and maintained + as symbols are read. The tree is searched as we load new symbols + to see if it already exists someplace in the namespace. */ + +typedef struct true_name +{ + BBT_HEADER (true_name); + gfc_symbol *sym; +} +true_name; + +static true_name *true_name_root; + + +/* Compare two true_name structures. */ + +static int +compare_true_names (void * _t1, void * _t2) +{ + true_name *t1, *t2; + int c; + + t1 = (true_name *) _t1; + t2 = (true_name *) _t2; + + c = strcmp (t1->sym->module, t2->sym->module); + if (c != 0) + return c; + + return strcmp (t1->sym->name, t2->sym->name); +} + + +/* Given a true name, search the true name tree to see if it exists + within the main namespace. */ + +static gfc_symbol * +find_true_name (const char *name, const char *module) +{ + true_name t, *p; + gfc_symbol sym; + int c; + + strcpy (sym.name, name); + strcpy (sym.module, module); + t.sym = &sym; + + p = true_name_root; + while (p != NULL) + { + c = compare_true_names ((void *)(&t), (void *) p); + if (c == 0) + return p->sym; + + p = (c < 0) ? p->left : p->right; + } + + return NULL; +} + + +/* Given a gfc_symbol pointer that is not in the true name tree, add + it. */ + +static void +add_true_name (gfc_symbol * sym) +{ + true_name *t; + + t = gfc_getmem (sizeof (true_name)); + t->sym = sym; + + gfc_insert_bbt (&true_name_root, t, compare_true_names); +} + + +/* Recursive function to build the initial true name tree by + recursively traversing the current namespace. */ + +static void +build_tnt (gfc_symtree * st) +{ + + if (st == NULL) + return; + + build_tnt (st->left); + build_tnt (st->right); + + if (find_true_name (st->n.sym->name, st->n.sym->module) != NULL) + return; + + add_true_name (st->n.sym); +} + + +/* Initialize the true name tree with the current namespace. */ + +static void +init_true_name_tree (void) +{ + true_name_root = NULL; + + build_tnt (gfc_current_ns->sym_root); +} + + +/* Recursively free a true name tree node. */ + +static void +free_true_name (true_name * t) +{ + + if (t == NULL) + return; + free_true_name (t->left); + free_true_name (t->right); + + gfc_free (t); +} + + +/*****************************************************************/ + +/* Module reading and writing. */ + +typedef enum +{ + ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING +} +atom_type; + +static atom_type last_atom; + + +/* The name buffer must be at least as long as a symbol name. Right + now it's not clear how we're going to store numeric constants-- + probably as a hexadecimal string, since this will allow the exact + number to be preserved (this can't be done by a decimal + representation). Worry about that later. TODO! */ + +#define MAX_ATOM_SIZE 100 + +static int atom_int; +static char *atom_string, atom_name[MAX_ATOM_SIZE]; + + +/* Report problems with a module. Error reporting is not very + elaborate, since this sorts of errors shouldn't really happen. + This subroutine never returns. */ + +static void bad_module (const char *) ATTRIBUTE_NORETURN; + +static void +bad_module (const char *message) +{ + const char *p; + + switch (iomode) + { + case IO_INPUT: + p = "Reading"; + break; + case IO_OUTPUT: + p = "Writing"; + break; + default: + p = "???"; + break; + } + + fclose (module_fp); + + gfc_fatal_error ("%s module %s at line %d column %d: %s", p, + module_name, module_line, module_column, message); +} + + +/* Set the module's input pointer. */ + +static void +set_module_locus (module_locus * m) +{ + + module_column = m->column; + module_line = m->line; + fsetpos (module_fp, &m->pos); +} + + +/* Get the module's input pointer so that we can restore it later. */ + +static void +get_module_locus (module_locus * m) +{ + + m->column = module_column; + m->line = module_line; + fgetpos (module_fp, &m->pos); +} + + +/* Get the next character in the module, updating our reckoning of + where we are. */ + +static int +module_char (void) +{ + int c; + + c = fgetc (module_fp); + + if (c == EOF) + bad_module ("Unexpected EOF"); + + if (c == '\n') + { + module_line++; + module_column = 0; + } + + module_column++; + return c; +} + + +/* Parse a string constant. The delimiter is guaranteed to be a + single quote. */ + +static void +parse_string (void) +{ + module_locus start; + int len, c; + char *p; + + get_module_locus (&start); + + len = 0; + + /* See how long the string is */ + for ( ; ; ) + { + c = module_char (); + if (c == EOF) + bad_module ("Unexpected end of module in string constant"); + + if (c != '\'') + { + len++; + continue; + } + + c = module_char (); + if (c == '\'') + { + len++; + continue; + } + + break; + } + + set_module_locus (&start); + + atom_string = p = gfc_getmem (len + 1); + + for (; len > 0; len--) + { + c = module_char (); + if (c == '\'') + module_char (); /* Guaranteed to be another \' */ + *p++ = c; + } + + module_char (); /* Terminating \' */ + *p = '\0'; /* C-style string for debug purposes */ +} + + +/* Parse a small integer. */ + +static void +parse_integer (int c) +{ + module_locus m; + + atom_int = c - '0'; + + for (;;) + { + get_module_locus (&m); + + c = module_char (); + if (!ISDIGIT (c)) + break; + + atom_int = 10 * atom_int + c - '0'; + if (atom_int > 99999999) + bad_module ("Integer overflow"); + } + + set_module_locus (&m); +} + + +/* Parse a name. */ + +static void +parse_name (int c) +{ + module_locus m; + char *p; + int len; + + p = atom_name; + + *p++ = c; + len = 1; + + get_module_locus (&m); + + for (;;) + { + c = module_char (); + if (!ISALNUM (c) && c != '_' && c != '-') + break; + + *p++ = c; + if (++len > GFC_MAX_SYMBOL_LEN) + bad_module ("Name too long"); + } + + *p = '\0'; + + fseek (module_fp, -1, SEEK_CUR); + module_column = m.column + len - 1; + + if (c == '\n') + module_line--; +} + + +/* Read the next atom in the module's input stream. */ + +static atom_type +parse_atom (void) +{ + int c; + + do + { + c = module_char (); + } + while (c == ' ' || c == '\n'); + + switch (c) + { + case '(': + return ATOM_LPAREN; + + case ')': + return ATOM_RPAREN; + + case '\'': + parse_string (); + return ATOM_STRING; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + parse_integer (c); + return ATOM_INTEGER; + + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'g': + case 'h': + case 'i': + case 'j': + case 'k': + case 'l': + case 'm': + case 'n': + case 'o': + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + case 'z': + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + case 'G': + case 'H': + case 'I': + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + case 'S': + case 'T': + case 'U': + case 'V': + case 'W': + case 'X': + case 'Y': + case 'Z': + parse_name (c); + return ATOM_NAME; + + default: + bad_module ("Bad name"); + } + + /* Not reached */ +} + + +/* Peek at the next atom on the input. */ + +static atom_type +peek_atom (void) +{ + module_locus m; + atom_type a; + + get_module_locus (&m); + + a = parse_atom (); + if (a == ATOM_STRING) + gfc_free (atom_string); + + set_module_locus (&m); + return a; +} + + +/* Read the next atom from the input, requiring that it be a + particular kind. */ + +static void +require_atom (atom_type type) +{ + module_locus m; + atom_type t; + const char *p; + + get_module_locus (&m); + + t = parse_atom (); + if (t != type) + { + switch (type) + { + case ATOM_NAME: + p = "Expected name"; + break; + case ATOM_LPAREN: + p = "Expected left parenthesis"; + break; + case ATOM_RPAREN: + p = "Expected right parenthesis"; + break; + case ATOM_INTEGER: + p = "Expected integer"; + break; + case ATOM_STRING: + p = "Expected string"; + break; + default: + gfc_internal_error ("require_atom(): bad atom type required"); + } + + set_module_locus (&m); + bad_module (p); + } +} + + +/* Given a pointer to an mstring array, require that the current input + be one of the strings in the array. We return the enum value. */ + +static int +find_enum (const mstring * m) +{ + int i; + + i = gfc_string2code (m, atom_name); + if (i >= 0) + return i; + + bad_module ("find_enum(): Enum not found"); + + /* Not reached */ +} + + +/**************** Module output subroutines ***************************/ + +/* Output a character to a module file. */ + +static void +write_char (char out) +{ + + if (fputc (out, module_fp) == EOF) + gfc_fatal_error ("Error writing modules file: %s", strerror (errno)); + + if (out != '\n') + module_column++; + else + { + module_column = 1; + module_line++; + } +} + + +/* Write an atom to a module. The line wrapping isn't perfect, but it + should work most of the time. This isn't that big of a deal, since + the file really isn't meant to be read by people anyway. */ + +static void +write_atom (atom_type atom, const void *v) +{ + char buffer[20]; + int i, len; + const char *p; + + switch (atom) + { + case ATOM_STRING: + case ATOM_NAME: + p = v; + break; + + case ATOM_LPAREN: + p = "("; + break; + + case ATOM_RPAREN: + p = ")"; + break; + + case ATOM_INTEGER: + i = *((const int *) v); + if (i < 0) + gfc_internal_error ("write_atom(): Writing negative integer"); + + sprintf (buffer, "%d", i); + p = buffer; + break; + + default: + gfc_internal_error ("write_atom(): Trying to write dab atom"); + + } + + len = strlen (p); + + if (atom != ATOM_RPAREN) + { + if (module_column + len > 72) + write_char ('\n'); + else + { + + if (last_atom != ATOM_LPAREN && module_column != 1) + write_char (' '); + } + } + + if (atom == ATOM_STRING) + write_char ('\''); + + while (*p) + { + if (atom == ATOM_STRING && *p == '\'') + write_char ('\''); + write_char (*p++); + } + + if (atom == ATOM_STRING) + write_char ('\''); + + last_atom = atom; +} + + + +/***************** Mid-level I/O subroutines *****************/ + +/* These subroutines let their caller read or write atoms without + caring about which of the two is actually happening. This lets a + subroutine concentrate on the actual format of the data being + written. */ + +static void mio_expr (gfc_expr **); +static void mio_symbol_ref (gfc_symbol **); +static void mio_symtree_ref (gfc_symtree **); + +/* Read or write an enumerated value. On writing, we return the input + value for the convenience of callers. We avoid using an integer + pointer because enums are sometimes inside bitfields. */ + +static int +mio_name (int t, const mstring * m) +{ + + if (iomode == IO_OUTPUT) + write_atom (ATOM_NAME, gfc_code2string (m, t)); + else + { + require_atom (ATOM_NAME); + t = find_enum (m); + } + + return t; +} + +/* Specialisation of mio_name. */ + +#define DECL_MIO_NAME(TYPE) \ + static inline TYPE \ + MIO_NAME(TYPE) (TYPE t, const mstring * m) \ + { \ + return (TYPE)mio_name ((int)t, m); \ + } +#define MIO_NAME(TYPE) mio_name_##TYPE + +static void +mio_lparen (void) +{ + + if (iomode == IO_OUTPUT) + write_atom (ATOM_LPAREN, NULL); + else + require_atom (ATOM_LPAREN); +} + + +static void +mio_rparen (void) +{ + + if (iomode == IO_OUTPUT) + write_atom (ATOM_RPAREN, NULL); + else + require_atom (ATOM_RPAREN); +} + + +static void +mio_integer (int *ip) +{ + + if (iomode == IO_OUTPUT) + write_atom (ATOM_INTEGER, ip); + else + { + require_atom (ATOM_INTEGER); + *ip = atom_int; + } +} + + +/* Read or write a character pointer that points to a string on the + heap. */ + +static void +mio_allocated_string (char **sp) +{ + + if (iomode == IO_OUTPUT) + write_atom (ATOM_STRING, *sp); + else + { + require_atom (ATOM_STRING); + *sp = atom_string; + } +} + + +/* Read or write a string that is in static memory or inside of some + already-allocated structure. */ + +static void +mio_internal_string (char *string) +{ + + if (iomode == IO_OUTPUT) + write_atom (ATOM_STRING, string); + else + { + require_atom (ATOM_STRING); + strcpy (string, atom_string); + gfc_free (atom_string); + } +} + + + +typedef enum +{ AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL, + AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_COMMON, AB_RESULT, + AB_ENTRY, AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, AB_SAVED_COMMON, + AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE, + AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT +} +ab_attribute; + +static const mstring attr_bits[] = +{ + minit ("ALLOCATABLE", AB_ALLOCATABLE), + minit ("DIMENSION", AB_DIMENSION), + minit ("EXTERNAL", AB_EXTERNAL), + minit ("INTRINSIC", AB_INTRINSIC), + minit ("OPTIONAL", AB_OPTIONAL), + minit ("POINTER", AB_POINTER), + minit ("SAVE", AB_SAVE), + minit ("TARGET", AB_TARGET), + minit ("DUMMY", AB_DUMMY), + minit ("COMMON", AB_COMMON), + minit ("RESULT", AB_RESULT), + minit ("ENTRY", AB_ENTRY), + minit ("DATA", AB_DATA), + minit ("IN_NAMELIST", AB_IN_NAMELIST), + minit ("IN_COMMON", AB_IN_COMMON), + minit ("SAVED_COMMON", AB_SAVED_COMMON), + minit ("FUNCTION", AB_FUNCTION), + minit ("SUBROUTINE", AB_SUBROUTINE), + minit ("SEQUENCE", AB_SEQUENCE), + minit ("ELEMENTAL", AB_ELEMENTAL), + minit ("PURE", AB_PURE), + minit ("RECURSIVE", AB_RECURSIVE), + minit ("GENERIC", AB_GENERIC), + minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT), + minit (NULL, -1) +}; + +/* Specialisation of mio_name. */ +DECL_MIO_NAME(ab_attribute) +DECL_MIO_NAME(ar_type) +DECL_MIO_NAME(array_type) +DECL_MIO_NAME(bt) +DECL_MIO_NAME(expr_t) +DECL_MIO_NAME(gfc_access) +DECL_MIO_NAME(gfc_intrinsic_op) +DECL_MIO_NAME(ifsrc) +DECL_MIO_NAME(procedure_type) +DECL_MIO_NAME(ref_type) +DECL_MIO_NAME(sym_flavor) +DECL_MIO_NAME(sym_intent) +#undef DECL_MIO_NAME + +/* Symbol attributes are stored in list with the first three elements + being the enumerated fields, while the remaining elements (if any) + indicate the individual attribute bits. The access field is not + saved-- it controls what symbols are exported when a module is + written. */ + +static void +mio_symbol_attribute (symbol_attribute * attr) +{ + atom_type t; + + mio_lparen (); + + attr->flavor = MIO_NAME(sym_flavor) (attr->flavor, flavors); + attr->intent = MIO_NAME(sym_intent) (attr->intent, intents); + attr->proc = MIO_NAME(procedure_type) (attr->proc, procedures); + attr->if_source = MIO_NAME(ifsrc) (attr->if_source, ifsrc_types); + + if (iomode == IO_OUTPUT) + { + if (attr->allocatable) + MIO_NAME(ab_attribute) (AB_ALLOCATABLE, attr_bits); + if (attr->dimension) + MIO_NAME(ab_attribute) (AB_DIMENSION, attr_bits); + if (attr->external) + MIO_NAME(ab_attribute) (AB_EXTERNAL, attr_bits); + if (attr->intrinsic) + MIO_NAME(ab_attribute) (AB_INTRINSIC, attr_bits); + if (attr->optional) + MIO_NAME(ab_attribute) (AB_OPTIONAL, attr_bits); + if (attr->pointer) + MIO_NAME(ab_attribute) (AB_POINTER, attr_bits); + if (attr->save) + MIO_NAME(ab_attribute) (AB_SAVE, attr_bits); + if (attr->target) + MIO_NAME(ab_attribute) (AB_TARGET, attr_bits); + if (attr->dummy) + MIO_NAME(ab_attribute) (AB_DUMMY, attr_bits); + if (attr->common) + MIO_NAME(ab_attribute) (AB_COMMON, attr_bits); + if (attr->result) + MIO_NAME(ab_attribute) (AB_RESULT, attr_bits); + if (attr->entry) + MIO_NAME(ab_attribute) (AB_ENTRY, attr_bits); + + if (attr->data) + MIO_NAME(ab_attribute) (AB_DATA, attr_bits); + if (attr->in_namelist) + MIO_NAME(ab_attribute) (AB_IN_NAMELIST, attr_bits); + if (attr->in_common) + MIO_NAME(ab_attribute) (AB_IN_COMMON, attr_bits); + if (attr->saved_common) + MIO_NAME(ab_attribute) (AB_SAVED_COMMON, attr_bits); + + if (attr->function) + MIO_NAME(ab_attribute) (AB_FUNCTION, attr_bits); + if (attr->subroutine) + MIO_NAME(ab_attribute) (AB_SUBROUTINE, attr_bits); + if (attr->generic) + MIO_NAME(ab_attribute) (AB_GENERIC, attr_bits); + + if (attr->sequence) + MIO_NAME(ab_attribute) (AB_SEQUENCE, attr_bits); + if (attr->elemental) + MIO_NAME(ab_attribute) (AB_ELEMENTAL, attr_bits); + if (attr->pure) + MIO_NAME(ab_attribute) (AB_PURE, attr_bits); + if (attr->recursive) + MIO_NAME(ab_attribute) (AB_RECURSIVE, attr_bits); + if (attr->always_explicit) + MIO_NAME(ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits); + + mio_rparen (); + + } + else + { + + for (;;) + { + t = parse_atom (); + if (t == ATOM_RPAREN) + break; + if (t != ATOM_NAME) + bad_module ("Expected attribute bit name"); + + switch ((ab_attribute) find_enum (attr_bits)) + { + case AB_ALLOCATABLE: + attr->allocatable = 1; + break; + case AB_DIMENSION: + attr->dimension = 1; + break; + case AB_EXTERNAL: + attr->external = 1; + break; + case AB_INTRINSIC: + attr->intrinsic = 1; + break; + case AB_OPTIONAL: + attr->optional = 1; + break; + case AB_POINTER: + attr->pointer = 1; + break; + case AB_SAVE: + attr->save = 1; + break; + case AB_TARGET: + attr->target = 1; + break; + case AB_DUMMY: + attr->dummy = 1; + break; + case AB_COMMON: + attr->common = 1; + break; + case AB_RESULT: + attr->result = 1; + break; + case AB_ENTRY: + attr->entry = 1; + break; + case AB_DATA: + attr->data = 1; + break; + case AB_IN_NAMELIST: + attr->in_namelist = 1; + break; + case AB_IN_COMMON: + attr->in_common = 1; + break; + case AB_SAVED_COMMON: + attr->saved_common = 1; + break; + case AB_FUNCTION: + attr->function = 1; + break; + case AB_SUBROUTINE: + attr->subroutine = 1; + break; + case AB_GENERIC: + attr->generic = 1; + break; + case AB_SEQUENCE: + attr->sequence = 1; + break; + case AB_ELEMENTAL: + attr->elemental = 1; + break; + case AB_PURE: + attr->pure = 1; + break; + case AB_RECURSIVE: + attr->recursive = 1; + break; + case AB_ALWAYS_EXPLICIT: + attr->always_explicit = 1; + break; + } + } + } +} + + +static const mstring bt_types[] = { + minit ("INTEGER", BT_INTEGER), + minit ("REAL", BT_REAL), + minit ("COMPLEX", BT_COMPLEX), + minit ("LOGICAL", BT_LOGICAL), + minit ("CHARACTER", BT_CHARACTER), + minit ("DERIVED", BT_DERIVED), + minit ("PROCEDURE", BT_PROCEDURE), + minit ("UNKNOWN", BT_UNKNOWN), + minit (NULL, -1) +}; + + +static void +mio_charlen (gfc_charlen ** clp) +{ + gfc_charlen *cl; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + cl = *clp; + if (cl != NULL) + mio_expr (&cl->length); + } + else + { + + if (peek_atom () != ATOM_RPAREN) + { + cl = gfc_get_charlen (); + mio_expr (&cl->length); + + *clp = cl; + + cl->next = gfc_current_ns->cl_list; + gfc_current_ns->cl_list = cl; + } + } + + mio_rparen (); +} + + +/* Return a symtree node with a name that is guaranteed to be unique + within the namespace and corresponds to an illegal fortran name. */ + +static gfc_symtree * +get_unique_symtree (gfc_namespace * ns) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + static int serial = 0; + + sprintf (name, "@%d", serial++); + return gfc_new_symtree (&ns->sym_root, name); +} + + +/* See if a name is a generated name. */ + +static int +check_unique_name (const char *name) +{ + + return *name == '@'; +} + + +static void +mio_typespec (gfc_typespec * ts) +{ + + mio_lparen (); + + ts->type = MIO_NAME(bt) (ts->type, bt_types); + + if (ts->type != BT_DERIVED) + mio_integer (&ts->kind); + else + mio_symbol_ref (&ts->derived); + + mio_charlen (&ts->cl); + + mio_rparen (); +} + + +static const mstring array_spec_types[] = { + minit ("EXPLICIT", AS_EXPLICIT), + minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE), + minit ("DEFERRED", AS_DEFERRED), + minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE), + minit (NULL, -1) +}; + + +static void +mio_array_spec (gfc_array_spec ** asp) +{ + gfc_array_spec *as; + int i; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + if (*asp == NULL) + goto done; + as = *asp; + } + else + { + if (peek_atom () == ATOM_RPAREN) + { + *asp = NULL; + goto done; + } + + *asp = as = gfc_get_array_spec (); + } + + mio_integer (&as->rank); + as->type = MIO_NAME(array_type) (as->type, array_spec_types); + + for (i = 0; i < as->rank; i++) + { + mio_expr (&as->lower[i]); + mio_expr (&as->upper[i]); + } + +done: + mio_rparen (); +} + + +/* Given a pointer to an array reference structure (which lives in a + gfc_ref structure), find the corresponding array specification + structure. Storing the pointer in the ref structure doesn't quite + work when loading from a module. Generating code for an array + reference also needs more infomation than just the array spec. */ + +static const mstring array_ref_types[] = { + minit ("FULL", AR_FULL), + minit ("ELEMENT", AR_ELEMENT), + minit ("SECTION", AR_SECTION), + minit (NULL, -1) +}; + +static void +mio_array_ref (gfc_array_ref * ar) +{ + int i; + + mio_lparen (); + ar->type = MIO_NAME(ar_type) (ar->type, array_ref_types); + mio_integer (&ar->dimen); + + switch (ar->type) + { + case AR_FULL: + break; + + case AR_ELEMENT: + for (i = 0; i < ar->dimen; i++) + mio_expr (&ar->start[i]); + + break; + + case AR_SECTION: + for (i = 0; i < ar->dimen; i++) + { + mio_expr (&ar->start[i]); + mio_expr (&ar->end[i]); + mio_expr (&ar->stride[i]); + } + + break; + + case AR_UNKNOWN: + gfc_internal_error ("mio_array_ref(): Unknown array ref"); + } + + for (i = 0; i < ar->dimen; i++) + mio_integer ((int *) &ar->dimen_type[i]); + + if (iomode == IO_INPUT) + { + ar->where = *gfc_current_locus (); + + for (i = 0; i < ar->dimen; i++) + ar->c_where[i] = *gfc_current_locus (); + } + + mio_rparen (); +} + + +/* Saves or restores a pointer. The pointer is converted back and + forth from an integer. We return the pointer_info pointer so that + the caller can take additional action based on the pointer type. */ + +static pointer_info * +mio_pointer_ref (void *gp) +{ + pointer_info *p; + + if (iomode == IO_OUTPUT) + { + p = get_pointer (*((char **) gp)); + write_atom (ATOM_INTEGER, &p->integer); + } + else + { + require_atom (ATOM_INTEGER); + p = add_fixup (atom_int, gp); + } + + return p; +} + + +/* Save and load references to components that occur within + expressions. We have to describe these references by a number and + by name. The number is necessary for forward references during + reading, and the name is necessary if the symbol already exists in + the namespace and is not loaded again. */ + +static void +mio_component_ref (gfc_component ** cp, gfc_symbol * sym) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_component *q; + pointer_info *p; + + p = mio_pointer_ref (cp); + if (p->type == P_UNKNOWN) + p->type = P_COMPONENT; + + if (iomode == IO_OUTPUT) + mio_internal_string ((*cp)->name); + else + { + mio_internal_string (name); + + if (sym->components != NULL && p->u.pointer == NULL) + { + /* Symbol already loaded, so search by name. */ + for (q = sym->components; q; q = q->next) + if (strcmp (q->name, name) == 0) + break; + + if (q == NULL) + gfc_internal_error ("mio_component_ref(): Component not found"); + + associate_integer_pointer (p, q); + } + + /* Make sure this symbol will eventually be loaded. */ + p = find_pointer2 (sym); + if (p->u.rsym.state == UNUSED) + p->u.rsym.state = NEEDED; + } +} + + +static void +mio_component (gfc_component * c) +{ + pointer_info *p; + int n; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + p = get_pointer (c); + mio_integer (&p->integer); + } + else + { + mio_integer (&n); + p = get_integer (n); + associate_integer_pointer (p, c); + } + + if (p->type == P_UNKNOWN) + p->type = P_COMPONENT; + + mio_internal_string (c->name); + mio_typespec (&c->ts); + mio_array_spec (&c->as); + + mio_integer (&c->dimension); + mio_integer (&c->pointer); + + mio_expr (&c->initializer); + mio_rparen (); +} + + +static void +mio_component_list (gfc_component ** cp) +{ + gfc_component *c, *tail; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (c = *cp; c; c = c->next) + mio_component (c); + } + else + { + + *cp = NULL; + tail = NULL; + + for (;;) + { + if (peek_atom () == ATOM_RPAREN) + break; + + c = gfc_get_component (); + mio_component (c); + + if (tail == NULL) + *cp = c; + else + tail->next = c; + + tail = c; + } + } + + mio_rparen (); +} + + +static void +mio_actual_arg (gfc_actual_arglist * a) +{ + + mio_lparen (); + mio_internal_string (a->name); + mio_expr (&a->expr); + mio_rparen (); +} + + +static void +mio_actual_arglist (gfc_actual_arglist ** ap) +{ + gfc_actual_arglist *a, *tail; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (a = *ap; a; a = a->next) + mio_actual_arg (a); + + } + else + { + tail = NULL; + + for (;;) + { + if (peek_atom () != ATOM_LPAREN) + break; + + a = gfc_get_actual_arglist (); + + if (tail == NULL) + *ap = a; + else + tail->next = a; + + tail = a; + mio_actual_arg (a); + } + } + + mio_rparen (); +} + + +/* Read and write formal argument lists. */ + +static void +mio_formal_arglist (gfc_symbol * sym) +{ + gfc_formal_arglist *f, *tail; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (f = sym->formal; f; f = f->next) + mio_symbol_ref (&f->sym); + + } + else + { + sym->formal = tail = NULL; + + while (peek_atom () != ATOM_RPAREN) + { + f = gfc_get_formal_arglist (); + mio_symbol_ref (&f->sym); + + if (sym->formal == NULL) + sym->formal = f; + else + tail->next = f; + + tail = f; + } + } + + mio_rparen (); +} + + +/* Save or restore a reference to a symbol node. */ + +void +mio_symbol_ref (gfc_symbol ** symp) +{ + pointer_info *p; + + p = mio_pointer_ref (symp); + if (p->type == P_UNKNOWN) + p->type = P_SYMBOL; + + if (iomode == IO_OUTPUT) + { + if (p->u.wsym.state == UNREFERENCED) + p->u.wsym.state = NEEDS_WRITE; + } + else + { + if (p->u.rsym.state == UNUSED) + p->u.rsym.state = NEEDED; + } +} + + +/* Save or restore a reference to a symtree node. */ + +static void +mio_symtree_ref (gfc_symtree ** stp) +{ + pointer_info *p; + fixup_t *f; + + if (iomode == IO_OUTPUT) + { + mio_symbol_ref (&(*stp)->n.sym); + } + else + { + require_atom (ATOM_INTEGER); + p = get_integer (atom_int); + if (p->type == P_UNKNOWN) + p->type = P_SYMBOL; + + if (p->u.rsym.state == UNUSED) + p->u.rsym.state = NEEDED; + + if (p->u.rsym.symtree != NULL) + { + *stp = p->u.rsym.symtree; + } + else + { + f = gfc_getmem (sizeof (fixup_t)); + + f->next = p->u.rsym.stfixup; + p->u.rsym.stfixup = f; + + f->pointer = (void **)stp; + } + } +} + +static void +mio_iterator (gfc_iterator ** ip) +{ + gfc_iterator *iter; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + if (*ip == NULL) + goto done; + } + else + { + if (peek_atom () == ATOM_RPAREN) + { + *ip = NULL; + goto done; + } + + *ip = gfc_get_iterator (); + } + + iter = *ip; + + mio_expr (&iter->var); + mio_expr (&iter->start); + mio_expr (&iter->end); + mio_expr (&iter->step); + +done: + mio_rparen (); +} + + + +static void +mio_constructor (gfc_constructor ** cp) +{ + gfc_constructor *c, *tail; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (c = *cp; c; c = c->next) + { + mio_lparen (); + mio_expr (&c->expr); + mio_iterator (&c->iterator); + mio_rparen (); + } + } + else + { + + *cp = NULL; + tail = NULL; + + while (peek_atom () != ATOM_RPAREN) + { + c = gfc_get_constructor (); + + if (tail == NULL) + *cp = c; + else + tail->next = c; + + tail = c; + + mio_lparen (); + mio_expr (&c->expr); + mio_iterator (&c->iterator); + mio_rparen (); + } + } + + mio_rparen (); +} + + + +static const mstring ref_types[] = { + minit ("ARRAY", REF_ARRAY), + minit ("COMPONENT", REF_COMPONENT), + minit ("SUBSTRING", REF_SUBSTRING), + minit (NULL, -1) +}; + + +static void +mio_ref (gfc_ref ** rp) +{ + gfc_ref *r; + + mio_lparen (); + + r = *rp; + r->type = MIO_NAME(ref_type) (r->type, ref_types); + + switch (r->type) + { + case REF_ARRAY: + mio_array_ref (&r->u.ar); + break; + + case REF_COMPONENT: + mio_symbol_ref (&r->u.c.sym); + mio_component_ref (&r->u.c.component, r->u.c.sym); + break; + + case REF_SUBSTRING: + mio_expr (&r->u.ss.start); + mio_expr (&r->u.ss.end); + mio_charlen (&r->u.ss.length); + break; + } + + mio_rparen (); +} + + +static void +mio_ref_list (gfc_ref ** rp) +{ + gfc_ref *ref, *head, *tail; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (ref = *rp; ref; ref = ref->next) + mio_ref (&ref); + } + else + { + head = tail = NULL; + + while (peek_atom () != ATOM_RPAREN) + { + if (head == NULL) + head = tail = gfc_get_ref (); + else + { + tail->next = gfc_get_ref (); + tail = tail->next; + } + + mio_ref (&tail); + } + + *rp = head; + } + + mio_rparen (); +} + + +/* Read and write an integer value. */ + +static void +mio_gmp_integer (mpz_t * integer) +{ + char *p; + + if (iomode == IO_INPUT) + { + if (parse_atom () != ATOM_STRING) + bad_module ("Expected integer string"); + + mpz_init (*integer); + if (mpz_set_str (*integer, atom_string, 10)) + bad_module ("Error converting integer"); + + gfc_free (atom_string); + + } + else + { + p = mpz_get_str (NULL, 10, *integer); + write_atom (ATOM_STRING, p); + gfc_free (p); + } +} + + +static void +mio_gmp_real (mpf_t * real) +{ + mp_exp_t exponent; + char *p; + + if (iomode == IO_INPUT) + { + if (parse_atom () != ATOM_STRING) + bad_module ("Expected real string"); + + mpf_init (*real); + mpf_set_str (*real, atom_string, -16); + gfc_free (atom_string); + + } + else + { + p = mpf_get_str (NULL, &exponent, 16, 0, *real); + atom_string = gfc_getmem (strlen (p) + 20); + + sprintf (atom_string, "0.%s@%ld", p, exponent); + write_atom (ATOM_STRING, atom_string); + + gfc_free (atom_string); + gfc_free (p); + } +} + + +/* Save and restore the shape of an array constructor. */ + +static void +mio_shape (mpz_t ** pshape, int rank) +{ + mpz_t *shape; + atom_type t; + int n; + + /* A NULL shape is represented by (). */ + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + shape = *pshape; + if (!shape) + { + mio_rparen (); + return; + } + } + else + { + t = peek_atom (); + if (t == ATOM_RPAREN) + { + *pshape = NULL; + mio_rparen (); + return; + } + + shape = gfc_get_shape (rank); + *pshape = shape; + } + + for (n = 0; n < rank; n++) + mio_gmp_integer (&shape[n]); + + mio_rparen (); +} + + +static const mstring expr_types[] = { + minit ("OP", EXPR_OP), + minit ("FUNCTION", EXPR_FUNCTION), + minit ("CONSTANT", EXPR_CONSTANT), + minit ("VARIABLE", EXPR_VARIABLE), + minit ("SUBSTRING", EXPR_SUBSTRING), + minit ("STRUCTURE", EXPR_STRUCTURE), + minit ("ARRAY", EXPR_ARRAY), + minit ("NULL", EXPR_NULL), + minit (NULL, -1) +}; + +/* INTRINSIC_ASSIGN is missing because it is used as an index for + generic operators, not in expressions. INTRINSIC_USER is also + replaced by the correct function name by the time we see it. */ + +static const mstring intrinsics[] = +{ + minit ("UPLUS", INTRINSIC_UPLUS), + minit ("UMINUS", INTRINSIC_UMINUS), + minit ("PLUS", INTRINSIC_PLUS), + minit ("MINUS", INTRINSIC_MINUS), + minit ("TIMES", INTRINSIC_TIMES), + minit ("DIVIDE", INTRINSIC_DIVIDE), + minit ("POWER", INTRINSIC_POWER), + minit ("CONCAT", INTRINSIC_CONCAT), + minit ("AND", INTRINSIC_AND), + minit ("OR", INTRINSIC_OR), + minit ("EQV", INTRINSIC_EQV), + minit ("NEQV", INTRINSIC_NEQV), + minit ("EQ", INTRINSIC_EQ), + minit ("NE", INTRINSIC_NE), + minit ("GT", INTRINSIC_GT), + minit ("GE", INTRINSIC_GE), + minit ("LT", INTRINSIC_LT), + minit ("LE", INTRINSIC_LE), + minit ("NOT", INTRINSIC_NOT), + minit (NULL, -1) +}; + +/* Read and write expressions. The form "()" is allowed to indicate a + NULL expression. */ + +static void +mio_expr (gfc_expr ** ep) +{ + gfc_expr *e; + atom_type t; + int flag; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + if (*ep == NULL) + { + mio_rparen (); + return; + } + + e = *ep; + MIO_NAME(expr_t) (e->expr_type, expr_types); + + } + else + { + t = parse_atom (); + if (t == ATOM_RPAREN) + { + *ep = NULL; + return; + } + + if (t != ATOM_NAME) + bad_module ("Expected expression type"); + + e = *ep = gfc_get_expr (); + e->where = *gfc_current_locus (); + e->expr_type = (expr_t) find_enum (expr_types); + } + + mio_typespec (&e->ts); + mio_integer (&e->rank); + + switch (e->expr_type) + { + case EXPR_OP: + e->operator = MIO_NAME(gfc_intrinsic_op) (e->operator, intrinsics); + + switch (e->operator) + { + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + case INTRINSIC_NOT: + mio_expr (&e->op1); + break; + + case INTRINSIC_PLUS: + case INTRINSIC_MINUS: + case INTRINSIC_TIMES: + case INTRINSIC_DIVIDE: + case INTRINSIC_POWER: + case INTRINSIC_CONCAT: + case INTRINSIC_AND: + case INTRINSIC_OR: + case INTRINSIC_EQV: + case INTRINSIC_NEQV: + case INTRINSIC_EQ: + case INTRINSIC_NE: + case INTRINSIC_GT: + case INTRINSIC_GE: + case INTRINSIC_LT: + case INTRINSIC_LE: + mio_expr (&e->op1); + mio_expr (&e->op2); + break; + + default: + bad_module ("Bad operator"); + } + + break; + + case EXPR_FUNCTION: + mio_symtree_ref (&e->symtree); + mio_actual_arglist (&e->value.function.actual); + + if (iomode == IO_OUTPUT) + { + mio_allocated_string (&e->value.function.name); + flag = e->value.function.esym != NULL; + mio_integer (&flag); + if (flag) + mio_symbol_ref (&e->value.function.esym); + else + write_atom (ATOM_STRING, e->value.function.isym->name); + + } + else + { + require_atom (ATOM_STRING); + e->value.function.name = gfc_get_string (atom_string); + gfc_free (atom_string); + + mio_integer (&flag); + if (flag) + mio_symbol_ref (&e->value.function.esym); + else + { + require_atom (ATOM_STRING); + e->value.function.isym = gfc_find_function (atom_string); + gfc_free (atom_string); + } + } + + break; + + case EXPR_VARIABLE: + mio_symtree_ref (&e->symtree); + mio_ref_list (&e->ref); + break; + + case EXPR_SUBSTRING: + mio_allocated_string (&e->value.character.string); + mio_expr (&e->op1); + mio_expr (&e->op2); + break; + + case EXPR_STRUCTURE: + case EXPR_ARRAY: + mio_constructor (&e->value.constructor); + mio_shape (&e->shape, e->rank); + break; + + case EXPR_CONSTANT: + switch (e->ts.type) + { + case BT_INTEGER: + mio_gmp_integer (&e->value.integer); + break; + + case BT_REAL: + mio_gmp_real (&e->value.real); + break; + + case BT_COMPLEX: + mio_gmp_real (&e->value.complex.r); + mio_gmp_real (&e->value.complex.i); + break; + + case BT_LOGICAL: + mio_integer (&e->value.logical); + break; + + case BT_CHARACTER: + mio_integer (&e->value.character.length); + mio_allocated_string (&e->value.character.string); + break; + + default: + bad_module ("Bad type in constant expression"); + } + + break; + + case EXPR_NULL: + break; + } + + mio_rparen (); +} + + +/* Save/restore lists of gfc_interface stuctures. When loading an + interface, we are really appending to the existing list of + interfaces. Checking for duplicate and ambiguous interfaces has to + be done later when all symbols have been loaded. */ + +static void +mio_interface_rest (gfc_interface ** ip) +{ + gfc_interface *tail, *p; + + if (iomode == IO_OUTPUT) + { + if (ip != NULL) + for (p = *ip; p; p = p->next) + mio_symbol_ref (&p->sym); + } + else + { + + if (*ip == NULL) + tail = NULL; + else + { + tail = *ip; + while (tail->next) + tail = tail->next; + } + + for (;;) + { + if (peek_atom () == ATOM_RPAREN) + break; + + p = gfc_get_interface (); + mio_symbol_ref (&p->sym); + + if (tail == NULL) + *ip = p; + else + tail->next = p; + + tail = p; + } + } + + mio_rparen (); +} + + +/* Save/restore a nameless operator interface. */ + +static void +mio_interface (gfc_interface ** ip) +{ + + mio_lparen (); + mio_interface_rest (ip); +} + + +/* Save/restore a named operator interface. */ + +static void +mio_symbol_interface (char *name, char *module, + gfc_interface ** ip) +{ + + mio_lparen (); + + mio_internal_string (name); + mio_internal_string (module); + + mio_interface_rest (ip); +} + + +static void +mio_namespace_ref (gfc_namespace ** nsp) +{ + gfc_namespace *ns; + pointer_info *p; + + p = mio_pointer_ref (nsp); + + if (p->type == P_UNKNOWN) + p->type = P_NAMESPACE; + + if (iomode == IO_INPUT && p->integer != 0 && p->u.pointer == NULL) + { + ns = gfc_get_namespace (NULL); + associate_integer_pointer (p, ns); + } +} + + +/* Unlike most other routines, the address of the symbol node is + already fixed on input and the name/module has already been filled + in. */ + +static void +mio_symbol (gfc_symbol * sym) +{ + gfc_formal_arglist *formal; + + mio_lparen (); + + mio_symbol_attribute (&sym->attr); + mio_typespec (&sym->ts); + + /* Contained procedures don't have formal namespaces. Instead we output the + procedure namespace. The will contain the formal arguments. */ + if (iomode == IO_OUTPUT) + { + formal = sym->formal; + while (formal && !formal->sym) + formal = formal->next; + + if (formal) + mio_namespace_ref (&formal->sym->ns); + else + mio_namespace_ref (&sym->formal_ns); + } + else + { + mio_namespace_ref (&sym->formal_ns); + if (sym->formal_ns) + { + sym->formal_ns->proc_name = sym; + sym->refs++; + } + } + + /* Save/restore common block links */ + mio_symbol_ref (&sym->common_head); + mio_symbol_ref (&sym->common_next); + + mio_formal_arglist (sym); + + mio_expr (&sym->value); + mio_array_spec (&sym->as); + + mio_symbol_ref (&sym->result); + + /* Note that components are always saved, even if they are supposed + to be private. Component access is checked during searching. */ + + mio_component_list (&sym->components); + + if (sym->components != NULL) + sym->component_access = + MIO_NAME(gfc_access) (sym->component_access, access_types); + + mio_symbol_ref (&sym->common_head); + mio_symbol_ref (&sym->common_next); + + mio_rparen (); +} + + +/************************* Top level subroutines *************************/ + +/* Skip a list between balanced left and right parens. */ + +static void +skip_list (void) +{ + int level; + + level = 0; + do + { + switch (parse_atom ()) + { + case ATOM_LPAREN: + level++; + break; + + case ATOM_RPAREN: + level--; + break; + + case ATOM_STRING: + gfc_free (atom_string); + break; + + case ATOM_NAME: + case ATOM_INTEGER: + break; + } + } + while (level > 0); +} + + +/* Load operator interfaces from the module. Interfaces are unusual + in that they attach themselves to existing symbols. */ + +static void +load_operator_interfaces (void) +{ + const char *p; + char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1]; + gfc_user_op *uop; + + mio_lparen (); + + while (peek_atom () != ATOM_RPAREN) + { + mio_lparen (); + + mio_internal_string (name); + mio_internal_string (module); + + /* Decide if we need to load this one or not. */ + p = find_use_name (name); + if (p == NULL) + { + while (parse_atom () != ATOM_RPAREN); + } + else + { + uop = gfc_get_uop (p); + mio_interface_rest (&uop->operator); + } + } + + mio_rparen (); +} + + +/* Load interfaces from the module. Interfaces are unusual in that + they attach themselves to existing symbols. */ + +static void +load_generic_interfaces (void) +{ + const char *p; + char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + + mio_lparen (); + + while (peek_atom () != ATOM_RPAREN) + { + mio_lparen (); + + mio_internal_string (name); + mio_internal_string (module); + + /* Decide if we need to load this one or not. */ + p = find_use_name (name); + + if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym)) + { + while (parse_atom () != ATOM_RPAREN); + continue; + } + + if (sym == NULL) + { + gfc_get_symbol (p, NULL, &sym); + + sym->attr.flavor = FL_PROCEDURE; + sym->attr.generic = 1; + sym->attr.use_assoc = 1; + } + + mio_interface_rest (&sym->generic); + } + + mio_rparen (); +} + + +/* Recursive function to traverse the pointer_info tree and load a + needed symbol. We return nonzero if we load a symbol and stop the + traversal, because the act of loading can alter the tree. */ + +static int +load_needed (pointer_info * p) +{ + gfc_namespace *ns; + pointer_info *q; + gfc_symbol *sym; + + if (p == NULL) + return 0; + if (load_needed (p->left)) + return 1; + if (load_needed (p->right)) + return 1; + + if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED) + return 0; + + p->u.rsym.state = USED; + + set_module_locus (&p->u.rsym.where); + + sym = p->u.rsym.sym; + if (sym == NULL) + { + q = get_integer (p->u.rsym.ns); + + ns = (gfc_namespace *) q->u.pointer; + if (ns == NULL) + { + /* Create an interface namespace if necessary. These are + the namespaces that hold the formal parameters of module + procedures. */ + + ns = gfc_get_namespace (NULL); + associate_integer_pointer (q, ns); + } + + sym = gfc_new_symbol (p->u.rsym.true_name, ns); + strcpy (sym->module, p->u.rsym.module); + + associate_integer_pointer (p, sym); + } + + mio_symbol (sym); + sym->attr.use_assoc = 1; + + return 1; +} + + +/* Recursive function for cleaning up things after a module has been + read. */ + +static void +read_cleanup (pointer_info * p) +{ + gfc_symtree *st; + pointer_info *q; + + if (p == NULL) + return; + + read_cleanup (p->left); + read_cleanup (p->right); + + if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced) + { + /* Add hidden symbols to the symtree. */ + q = get_integer (p->u.rsym.ns); + st = get_unique_symtree ((gfc_namespace *) q->u.pointer); + + st->n.sym = p->u.rsym.sym; + st->n.sym->refs++; + + /* Fixup any symtree references. */ + p->u.rsym.symtree = st; + resolve_fixups (p->u.rsym.stfixup, st); + p->u.rsym.stfixup = NULL; + } + + /* Free unused symbols. */ + if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED) + gfc_free_symbol (p->u.rsym.sym); +} + + +/* Read a module file. */ + +static void +read_module (void) +{ + module_locus operator_interfaces, user_operators; + const char *p; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_intrinsic_op i; + int ambiguous, symbol; + pointer_info *info; + gfc_use_rename *u; + gfc_symtree *st; + gfc_symbol *sym; + + get_module_locus (&operator_interfaces); /* Skip these for now */ + skip_list (); + + get_module_locus (&user_operators); + skip_list (); + skip_list (); + + mio_lparen (); + + /* Create the fixup nodes for all the symbols. */ + + while (peek_atom () != ATOM_RPAREN) + { + require_atom (ATOM_INTEGER); + info = get_integer (atom_int); + + info->type = P_SYMBOL; + info->u.rsym.state = UNUSED; + + mio_internal_string (info->u.rsym.true_name); + mio_internal_string (info->u.rsym.module); + + require_atom (ATOM_INTEGER); + info->u.rsym.ns = atom_int; + + get_module_locus (&info->u.rsym.where); + skip_list (); + + /* See if the symbol has already been loaded by a previous module. + If so, we reference the existing symbol and prevent it from + being loaded again. */ + + sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module); + if (sym == NULL) + continue; + + info->u.rsym.state = USED; + info->u.rsym.referenced = 1; + info->u.rsym.sym = sym; + } + + mio_rparen (); + + /* Parse the symtree lists. This lets us mark which symbols need to + be loaded. Renaming is also done at this point by replacing the + symtree name. */ + + mio_lparen (); + + while (peek_atom () != ATOM_RPAREN) + { + mio_internal_string (name); + mio_integer (&ambiguous); + mio_integer (&symbol); + + info = get_integer (symbol); + + /* Get the local name for this symbol. */ + p = find_use_name (name); + + /* Skip symtree nodes not in an ONLY caluse. */ + if (p == NULL) + continue; + + /* Check for ambiguous symbols. */ + st = gfc_find_symtree (gfc_current_ns->sym_root, p); + + if (st != NULL) + { + if (st->n.sym != info->u.rsym.sym) + st->ambiguous = 1; + info->u.rsym.symtree = st; + } + else + { + /* Create a symtree node in the current namespace for this symbol. */ + st = check_unique_name (p) ? get_unique_symtree (gfc_current_ns) : + gfc_new_symtree (&gfc_current_ns->sym_root, p); + + st->ambiguous = ambiguous; + + sym = info->u.rsym.sym; + + /* Create a symbol node if it doesn't already exist. */ + if (sym == NULL) + { + sym = info->u.rsym.sym = + gfc_new_symbol (info->u.rsym.true_name, gfc_current_ns); + + strcpy (sym->module, info->u.rsym.module); + } + + st->n.sym = sym; + st->n.sym->refs++; + + /* Store the symtree pointing to this symbol. */ + info->u.rsym.symtree = st; + + if (info->u.rsym.state == UNUSED) + info->u.rsym.state = NEEDED; + info->u.rsym.referenced = 1; + } + } + + mio_rparen (); + + /* Load intrinsic operator interfaces. */ + set_module_locus (&operator_interfaces); + mio_lparen (); + + for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) + { + if (i == INTRINSIC_USER) + continue; + + if (only_flag) + { + u = find_use_operator (i); + + if (u == NULL) + { + skip_list (); + continue; + } + + u->found = 1; + } + + mio_interface (&gfc_current_ns->operator[i]); + } + + mio_rparen (); + + /* Load generic and user operator interfaces. These must follow the + loading of symtree because otherwise symbols can be marked as + ambiguous. */ + + set_module_locus (&user_operators); + + load_operator_interfaces (); + load_generic_interfaces (); + + /* At this point, we read those symbols that are needed but haven't + been loaded yet. If one symbol requires another, the other gets + marked as NEEDED if its previous state was UNUSED. */ + + while (load_needed (pi_root)); + + /* Make sure all elements of the rename-list were found in the + module. */ + + for (u = gfc_rename_list; u; u = u->next) + { + if (u->found) + continue; + + if (u->operator == INTRINSIC_NONE) + { + gfc_error ("Symbol '%s' referenced at %L not found in module '%s'", + u->use_name, &u->where, module_name); + continue; + } + + if (u->operator == INTRINSIC_USER) + { + gfc_error + ("User operator '%s' referenced at %L not found in module '%s'", + u->use_name, &u->where, module_name); + continue; + } + + gfc_error + ("Intrinsic operator '%s' referenced at %L not found in module " + "'%s'", gfc_op2string (u->operator), &u->where, module_name); + } + + gfc_check_interfaces (gfc_current_ns); + + /* Clean up symbol nodes that were never loaded, create references + to hidden symbols. */ + + read_cleanup (pi_root); +} + + +/* Given an access type that is specific to an entity and the default + access, return nonzero if we should write the entity. */ + +static int +check_access (gfc_access specific_access, gfc_access default_access) +{ + + if (specific_access == ACCESS_PUBLIC) + return 1; + if (specific_access == ACCESS_PRIVATE) + return 0; + + if (gfc_option.flag_module_access_private) + { + if (default_access == ACCESS_PUBLIC) + return 1; + } + else + { + if (default_access != ACCESS_PRIVATE) + return 1; + } + + return 0; +} + + +/* Write a symbol to the module. */ + +static void +write_symbol (int n, gfc_symbol * sym) +{ + + if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL) + gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name); + + mio_integer (&n); + mio_internal_string (sym->name); + + if (sym->module[0] == '\0') + strcpy (sym->module, module_name); + + mio_internal_string (sym->module); + mio_pointer_ref (&sym->ns); + + mio_symbol (sym); + write_char ('\n'); +} + + +/* Recursive traversal function to write the initial set of symbols to + the module. We check to see if the symbol should be written + according to the access specification. */ + +static void +write_symbol0 (gfc_symtree * st) +{ + gfc_symbol *sym; + pointer_info *p; + + if (st == NULL) + return; + + write_symbol0 (st->left); + write_symbol0 (st->right); + + sym = st->n.sym; + + if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic + && !sym->attr.subroutine && !sym->attr.function) + return; + + if (!check_access (sym->attr.access, sym->ns->default_access)) + return; + + p = get_pointer (sym); + if (p->type == P_UNKNOWN) + p->type = P_SYMBOL; + + if (p->u.wsym.state == WRITTEN) + return; + + write_symbol (p->integer, sym); + p->u.wsym.state = WRITTEN; + + return; +} + + +/* Recursive traversal function to write the secondary set of symbols + to the module file. These are symbols that were not public yet are + needed by the public symbols or another dependent symbol. The act + of writing a symbol can modify the pointer_info tree, so we cease + traversal if we find a symbol to write. We return nonzero if a + symbol was written and pass that information upwards. */ + +static int +write_symbol1 (pointer_info * p) +{ + + if (p == NULL) + return 0; + + if (write_symbol1 (p->left)) + return 1; + if (write_symbol1 (p->right)) + return 1; + + if (p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE) + return 0; + + p->u.wsym.state = WRITTEN; + write_symbol (p->integer, p->u.wsym.sym); + + return 1; +} + + +/* Write operator interfaces associated with a symbol. */ + +static void +write_operator (gfc_user_op * uop) +{ + static char nullstring[] = ""; + + if (uop->operator == NULL + || !check_access (uop->access, uop->ns->default_access)) + return; + + mio_symbol_interface (uop->name, nullstring, &uop->operator); +} + + +/* Write generic interfaces associated with a symbol. */ + +static void +write_generic (gfc_symbol * sym) +{ + + if (sym->generic == NULL + || !check_access (sym->attr.access, sym->ns->default_access)) + return; + + mio_symbol_interface (sym->name, sym->module, &sym->generic); +} + + +static void +write_symtree (gfc_symtree * st) +{ + gfc_symbol *sym; + pointer_info *p; + + sym = st->n.sym; + if (!check_access (sym->attr.access, sym->ns->default_access) + || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic + && !sym->attr.subroutine && !sym->attr.function)) + return; + + if (check_unique_name (st->name)) + return; + + p = find_pointer (sym); + if (p == NULL) + gfc_internal_error ("write_symtree(): Symbol not written"); + + mio_internal_string (st->name); + mio_integer (&st->ambiguous); + mio_integer (&p->integer); +} + + +static void +write_module (void) +{ + gfc_intrinsic_op i; + + /* Write the operator interfaces. */ + mio_lparen (); + + for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) + { + if (i == INTRINSIC_USER) + continue; + + mio_interface (check_access (gfc_current_ns->operator_access[i], + gfc_current_ns->default_access) + ? &gfc_current_ns->operator[i] : NULL); + } + + mio_rparen (); + write_char ('\n'); + write_char ('\n'); + + mio_lparen (); + gfc_traverse_user_op (gfc_current_ns, write_operator); + mio_rparen (); + write_char ('\n'); + write_char ('\n'); + + mio_lparen (); + gfc_traverse_ns (gfc_current_ns, write_generic); + mio_rparen (); + write_char ('\n'); + write_char ('\n'); + + /* Write symbol information. First we traverse all symbols in the + primary namespace, writing those that need to be written. + Sometimes writing one symbol will cause another to need to be + written. A list of these symbols ends up on the write stack, and + we end by popping the bottom of the stack and writing the symbol + until the stack is empty. */ + + mio_lparen (); + + write_symbol0 (gfc_current_ns->sym_root); + while (write_symbol1 (pi_root)); + + mio_rparen (); + + write_char ('\n'); + write_char ('\n'); + + mio_lparen (); + gfc_traverse_symtree (gfc_current_ns, write_symtree); + mio_rparen (); +} + + +/* Given module, dump it to disk. If there was an error while + processing the module, dump_flag will be set to zero and we delete + the module file, even if it was already there. */ + +void +gfc_dump_module (const char *name, int dump_flag) +{ + char filename[PATH_MAX], *p; + gfc_file *g; + time_t now; + + filename[0] = '\0'; + if (gfc_option.module_dir != NULL) + strcpy (filename, gfc_option.module_dir); + + strcat (filename, name); + strcat (filename, MODULE_EXTENSION); + + if (!dump_flag) + { + unlink (filename); + return; + } + + module_fp = fopen (filename, "w"); + if (module_fp == NULL) + gfc_fatal_error ("Can't open module file '%s' for writing: %s", + filename, strerror (errno)); + + /* Find the top level filename. */ + g = gfc_current_file; + while (g->next) + g = g->next; + + now = time (NULL); + p = ctime (&now); + + *strchr (p, '\n') = '\0'; + + fprintf (module_fp, "GFORTRAN module created from %s on %s\n", g->filename, p); + fputs ("If you edit this, you'll get what you deserve.\n\n", module_fp); + + iomode = IO_OUTPUT; + strcpy (module_name, name); + + init_pi_tree (); + + write_module (); + + free_pi_tree (pi_root); + pi_root = NULL; + + write_char ('\n'); + + if (fclose (module_fp)) + gfc_fatal_error ("Error writing module file '%s' for writing: %s", + filename, strerror (errno)); +} + + +/* Process a USE directive. */ + +void +gfc_use_module (void) +{ + char filename[GFC_MAX_SYMBOL_LEN + 5]; + gfc_state_data *p; + int c, line; + + strcpy (filename, module_name); + strcat (filename, MODULE_EXTENSION); + + module_fp = gfc_open_included_file (filename); + if (module_fp == NULL) + gfc_fatal_error ("Can't open module file '%s' for reading: %s", + filename, strerror (errno)); + + iomode = IO_INPUT; + module_line = 1; + module_column = 1; + + /* Skip the first two lines of the module. */ + /* FIXME: Could also check for valid two lines here, instead. */ + line = 0; + while (line < 2) + { + c = module_char (); + if (c == EOF) + bad_module ("Unexpected end of module"); + if (c == '\n') + line++; + } + + /* Make sure we're not reading the same module that we may be building. */ + for (p = gfc_state_stack; p; p = p->previous) + if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0) + gfc_fatal_error ("Can't USE the same module we're building!"); + + init_pi_tree (); + init_true_name_tree (); + + read_module (); + + free_true_name (true_name_root); + true_name_root = NULL; + + free_pi_tree (pi_root); + pi_root = NULL; + + fclose (module_fp); +} + + +void +gfc_module_init_2 (void) +{ + + last_atom = ATOM_LPAREN; +} + + +void +gfc_module_done_2 (void) +{ + + free_rename (); +} diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c new file mode 100644 index 00000000000..7d6d8f31efc --- /dev/null +++ b/gcc/fortran/options.c @@ -0,0 +1,320 @@ +/* Parse and display command line options. + Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include <string.h> +#include <stdlib.h> + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "flags.h" +#include "intl.h" +#include "opts.h" +#include "options.h" +#include "tree-inline.h" + +#include "gfortran.h" + +gfc_option_t gfc_option; + + +/* Get ready for options handling. */ + +unsigned int +gfc_init_options (unsigned int argc ATTRIBUTE_UNUSED, + const char **argv ATTRIBUTE_UNUSED) +{ + + gfc_option.source = NULL; + gfc_option.module_dir = NULL; + gfc_option.source_form = FORM_UNKNOWN; + gfc_option.fixed_line_length = 72; + gfc_option.max_identifier_length = GFC_MAX_SYMBOL_LEN; + gfc_option.verbose = 0; + + gfc_option.warn_aliasing = 0; + gfc_option.warn_conversion = 0; + gfc_option.warn_implicit_interface = 0; + gfc_option.warn_line_truncation = 0; + gfc_option.warn_surprising = 0; + gfc_option.warn_unused_labels = 0; + + gfc_option.flag_dollar_ok = 0; + gfc_option.flag_underscoring = 1; + gfc_option.flag_second_underscore = 1; + gfc_option.flag_implicit_none = 0; + gfc_option.flag_max_stack_var_size = 32768; + gfc_option.flag_module_access_private = 0; + gfc_option.flag_no_backend = 0; + gfc_option.flag_pack_derived = 0; + gfc_option.flag_repack_arrays = 0; + + gfc_option.q_kind = gfc_default_double_kind (); + gfc_option.i8 = 0; + gfc_option.r8 = 0; + gfc_option.d8 = 0; + + flag_argument_noalias = 2; + + gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL + | GFC_STD_F2003_OBS | GFC_STD_F2003_DEL | GFC_STD_F2003 | GFC_STD_GNU; + gfc_option.warn_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL + | GFC_STD_F2003 | GFC_STD_GNU; + + return CL_F95; +} + + +/* Finalize commandline options. */ + +bool +gfc_post_options (const char **pfilename) +{ + const char *filename = *pfilename; + + /* Verify the input file name. */ + if (!filename || strcmp (filename, "-") == 0) + { + filename = ""; + } + + gfc_option.source = filename; + + flag_inline_trees = 1; + + /* Use tree inlining. */ + if (!flag_no_inline) + flag_no_inline = 1; + if (flag_inline_functions) + { + flag_inline_trees = 2; + flag_inline_functions = 0; + } + + return false; +} + + +/* Set the options for -Wall. */ + +static void +set_Wall (void) +{ + + gfc_option.warn_aliasing = 1; + gfc_option.warn_line_truncation = 1; + gfc_option.warn_surprising = 1; + gfc_option.warn_unused_labels = 1; + + set_Wunused (1); + warn_return_type = 1; + warn_switch = 1; + + /* We save the value of warn_uninitialized, since if they put + -Wuninitialized on the command line, we need to generate a + warning about not using it without also specifying -O. */ + + if (warn_uninitialized != 1) + warn_uninitialized = 2; +} + + +static void +gfc_handle_module_path_options (const char *arg) +{ + + if (gfc_option.module_dir != NULL) + { + gfc_status ("gfortran: Only one -M option allowed\n"); + exit (3); + } + + if (arg == NULL) + { + gfc_status ("gfortran: Directory required after -M\n"); + exit (3); + } + + gfc_option.module_dir = (char *) gfc_getmem (strlen (arg)); + strcpy (gfc_option.module_dir, arg); + strcat (gfc_option.module_dir, "/"); +} + +/* Handle command-line options. Returns 0 if unrecognized, 1 if + recognized and handled. */ +int +gfc_handle_option (size_t scode, const char *arg, int value) +{ + int result = 1; + enum opt_code code = (enum opt_code) scode; + + /* Ignore file names. */ + if (code == N_OPTS) + return 1; + + switch (code) + { + default: + result = 0; + break; + + case OPT_Wall: + set_Wall (); + break; + + case OPT_Waliasing: + gfc_option.warn_aliasing = value; + break; + + case OPT_Wconversion: + gfc_option.warn_conversion = value; + break; + + case OPT_Wimplicit_interface: + gfc_option.warn_implicit_interface = value; + break; + + case OPT_Wline_truncation: + gfc_option.warn_line_truncation = value; + break; + + case OPT_Wsurprising: + gfc_option.warn_surprising = value; + break; + + case OPT_Wunused_labels: + gfc_option.warn_unused_labels = value; + break; + + case OPT_fdollar_ok: + gfc_option.flag_dollar_ok = value; + break; + + case OPT_fdump_parse_tree: + gfc_option.verbose = value; + break; + + case OPT_ffixed_form: + gfc_option.source_form = FORM_FIXED; + break; + + case OPT_ffree_form: + gfc_option.source_form = FORM_FREE; + break; + + case OPT_funderscoring: + gfc_option.flag_underscoring = value; + break; + + case OPT_fsecond_underscore: + gfc_option.flag_second_underscore = value; + break; + + case OPT_fimplicit_none: + gfc_option.flag_implicit_none = value; + break; + + case OPT_fmax_stack_var_size_: + gfc_option.flag_max_stack_var_size = value; + break; + + case OPT_fmodule_private: + gfc_option.flag_module_access_private = value; + break; + + case OPT_fno_backend: + gfc_option.flag_no_backend = value; + break; + + case OPT_fpack_derived: + gfc_option.flag_pack_derived = value; + break; + + case OPT_frepack_arrays: + gfc_option.flag_repack_arrays = value; + break; + + case OPT_ffixed_line_length_80: + gfc_option.fixed_line_length = 80; + break; + + case OPT_ffixed_line_length_132: + gfc_option.fixed_line_length = 132; + break; + + case OPT_fmax_identifier_length_: + if (value > GFC_MAX_SYMBOL_LEN) + gfc_fatal_error ("Maximum supported idenitifier length is %d", + GFC_MAX_SYMBOL_LEN); + gfc_option.max_identifier_length = value; + break; + + case OPT_qkind_: + if (gfc_validate_kind (BT_REAL, value) < 0) + gfc_fatal_error ("Argument to -fqkind isn't a valid real kind"); + gfc_option.q_kind = value; + break; + + case OPT_i8: + gfc_option.i8 = value; + break; + + case OPT_r8: + gfc_option.r8 = value; + break; + + case OPT_d8: + gfc_option.d8 = value; + break; + + case OPT_I: + gfc_add_include_path (arg); + break; + + case OPT_J: + case OPT_M: + gfc_handle_module_path_options (arg); + + case OPT_std_f95: + gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F2003_OBS + | GFC_STD_F2003_DEL; + gfc_option.warn_std = GFC_STD_F95_OBS; + gfc_option.max_identifier_length = 31; + break; + + case OPT_std_f2003: + gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F2003_OBS + | GFC_STD_F2003; + gfc_option.warn_std = GFC_STD_F95_OBS | GFC_STD_F2003_OBS; + gfc_option.max_identifier_length = 63; + break; + + case OPT_std_gnu: + gfc_option.allow_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL + | GFC_STD_F2003_OBS | GFC_STD_F2003_DEL | GFC_STD_F2003 | GFC_STD_GNU; + gfc_option.warn_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL + | GFC_STD_F2003_OBS | GFC_STD_F2003_DEL | GFC_STD_GNU; + break; + } + + return result; +} diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c new file mode 100644 index 00000000000..6494ba8e578 --- /dev/null +++ b/gcc/fortran/parse.c @@ -0,0 +1,2503 @@ +/* Main parser. + Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#include "config.h" +#include <string.h> +#include <setjmp.h> + +#include "gfortran.h" +#include "match.h" +#include "parse.h" + +/* Current statement label. Zero means no statement label. Because + new_st can get wiped during statement matching, we have to keep it + separate. */ + +gfc_st_label *gfc_statement_label; + +static locus label_locus; +static jmp_buf eof; + +gfc_state_data *gfc_state_stack; + +/* TODO: Re-order functions to kill these forward decls. */ +static void check_statement_label (gfc_statement); +static void undo_new_statement (void); +static void reject_statement (void); + +/* A sort of half-matching function. We try to match the word on the + input with the passed string. If this succeeds, we call the + keyword-dependent matching function that will match the rest of the + statement. For single keywords, the matching subroutine is + gfc_match_eos(). */ + +static match +match_word (const char *str, match (*subr) (void), locus * old_locus) +{ + match m; + + if (str != NULL) + { + m = gfc_match (str); + if (m != MATCH_YES) + return m; + } + + m = (*subr) (); + + if (m != MATCH_YES) + { + gfc_set_locus (old_locus); + reject_statement (); + } + + return m; +} + + +/* Figure out what the next statement is, (mostly) regardless of + proper ordering. */ + +#define match(keyword, subr, st) \ + if (match_word(keyword, subr, &old_locus) == MATCH_YES) \ + return st; \ + else \ + undo_new_statement (); + +static gfc_statement +decode_statement (void) +{ + gfc_statement st; + locus old_locus; + match m; + int c; + +#ifdef GFC_DEBUG + gfc_symbol_state (); +#endif + + gfc_clear_error (); /* Clear any pending errors. */ + gfc_clear_warning (); /* Clear any pending warnings. */ + + if (gfc_match_eos () == MATCH_YES) + return ST_NONE; + + old_locus = *gfc_current_locus (); + + /* Try matching a data declaration or function declaration. The + input "REALFUNCTIONA(N)" can mean several things in different + contexts, so it (and its relatives) get special treatment. */ + + if (gfc_current_state () == COMP_NONE + || gfc_current_state () == COMP_INTERFACE + || gfc_current_state () == COMP_CONTAINS) + { + m = gfc_match_function_decl (); + if (m == MATCH_YES) + return ST_FUNCTION; + else if (m == MATCH_ERROR) + reject_statement (); + + gfc_undo_symbols (); + gfc_set_locus (&old_locus); + } + + /* Match statements whose error messages are meant to be overwritten + by something better. */ + + match (NULL, gfc_match_assignment, ST_ASSIGNMENT); + match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT); + match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION); + + match (NULL, gfc_match_data_decl, ST_DATA_DECL); + + /* Try to match a subroutine statement, which has the same optional + prefixes that functions can have. */ + + if (gfc_match_subroutine () == MATCH_YES) + return ST_SUBROUTINE; + gfc_undo_symbols (); + gfc_set_locus (&old_locus); + + /* Check for the IF, DO, SELECT, WHERE and FORALL statements, which + might begin with a block label. The match functions for these + statements are unusual in that their keyword is not seen before + the matcher is called. */ + + if (gfc_match_if (&st) == MATCH_YES) + return st; + gfc_undo_symbols (); + gfc_set_locus (&old_locus); + + if (gfc_match_where (&st) == MATCH_YES) + return st; + gfc_undo_symbols (); + gfc_set_locus (&old_locus); + + if (gfc_match_forall (&st) == MATCH_YES) + return st; + gfc_undo_symbols (); + gfc_set_locus (&old_locus); + + match (NULL, gfc_match_do, ST_DO); + match (NULL, gfc_match_select, ST_SELECT_CASE); + + /* General statement matching: Instead of testing every possible + statement, we eliminate most possibilities by peeking at the + first character. */ + + c = gfc_peek_char (); + + switch (c) + { + case 'a': + match ("allocate", gfc_match_allocate, ST_ALLOCATE); + match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL); + match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT); + break; + + case 'b': + match ("backspace", gfc_match_backspace, ST_BACKSPACE); + match ("block data", gfc_match_block_data, ST_BLOCK_DATA); + break; + + case 'c': + match ("call", gfc_match_call, ST_CALL); + match ("close", gfc_match_close, ST_CLOSE); + match ("continue", gfc_match_continue, ST_CONTINUE); + match ("cycle", gfc_match_cycle, ST_CYCLE); + match ("case", gfc_match_case, ST_CASE); + match ("common", gfc_match_common, ST_COMMON); + match ("contains", gfc_match_eos, ST_CONTAINS); + break; + + case 'd': + match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE); + match ("data", gfc_match_data, ST_DATA); + match ("dimension", gfc_match_dimension, ST_ATTR_DECL); + break; + + case 'e': + match ("end file", gfc_match_endfile, ST_END_FILE); + match ("exit", gfc_match_exit, ST_EXIT); + match ("else", gfc_match_else, ST_ELSE); + match ("else where", gfc_match_elsewhere, ST_ELSEWHERE); + match ("else if", gfc_match_elseif, ST_ELSEIF); + + if (gfc_match_end (&st) == MATCH_YES) + return st; + + match ("entry", gfc_match_entry, ST_ENTRY); + match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE); + match ("external", gfc_match_external, ST_ATTR_DECL); + break; + + case 'f': + match ("format", gfc_match_format, ST_FORMAT); + break; + + case 'g': + match ("go to", gfc_match_goto, ST_GOTO); + break; + + case 'i': + match ("inquire", gfc_match_inquire, ST_INQUIRE); + match ("implicit", gfc_match_implicit, ST_IMPLICIT); + match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE); + match ("interface", gfc_match_interface, ST_INTERFACE); + match ("intent", gfc_match_intent, ST_ATTR_DECL); + match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL); + break; + + case 'm': + match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC); + match ("module", gfc_match_module, ST_MODULE); + break; + + case 'n': + match ("nullify", gfc_match_nullify, ST_NULLIFY); + match ("namelist", gfc_match_namelist, ST_NAMELIST); + break; + + case 'o': + match ("open", gfc_match_open, ST_OPEN); + match ("optional", gfc_match_optional, ST_ATTR_DECL); + break; + + case 'p': + match ("print", gfc_match_print, ST_WRITE); + match ("parameter", gfc_match_parameter, ST_PARAMETER); + match ("pause", gfc_match_pause, ST_PAUSE); + match ("pointer", gfc_match_pointer, ST_ATTR_DECL); + if (gfc_match_private (&st) == MATCH_YES) + return st; + match ("program", gfc_match_program, ST_PROGRAM); + if (gfc_match_public (&st) == MATCH_YES) + return st; + break; + + case 'r': + match ("read", gfc_match_read, ST_READ); + match ("return", gfc_match_return, ST_RETURN); + match ("rewind", gfc_match_rewind, ST_REWIND); + break; + + case 's': + match ("sequence", gfc_match_eos, ST_SEQUENCE); + match ("stop", gfc_match_stop, ST_STOP); + match ("save", gfc_match_save, ST_ATTR_DECL); + break; + + case 't': + match ("target", gfc_match_target, ST_ATTR_DECL); + match ("type", gfc_match_derived_decl, ST_DERIVED_DECL); + break; + + case 'u': + match ("use", gfc_match_use, ST_USE); + break; + + case 'w': + match ("write", gfc_match_write, ST_WRITE); + break; + } + + /* All else has failed, so give up. See if any of the matchers has + stored an error message of some sort. */ + + if (gfc_error_check () == 0) + gfc_error_now ("Unclassifiable statement at %C"); + + reject_statement (); + + gfc_error_recovery (); + + return ST_NONE; +} + +#undef match + + +/* Get the next statement in free form source. */ + +static gfc_statement +next_free (void) +{ + match m; + int c, d; + + gfc_gobble_whitespace (); + + c = gfc_peek_char (); + + if (ISDIGIT (c)) + { + /* Found a statement label? */ + m = gfc_match_st_label (&gfc_statement_label, 0); + + d = gfc_peek_char (); + if (m != MATCH_YES || !gfc_is_whitespace (d)) + { + do + { + /* Skip the bad statement label. */ + gfc_warning_now ("Ignoring bad statement label at %C"); + c = gfc_next_char (); + } + while (ISDIGIT (c)); + } + else + { + label_locus = *gfc_current_locus (); + + if (gfc_statement_label->value == 0) + { + gfc_warning_now ("Ignoring statement label of zero at %C"); + gfc_free_st_label (gfc_statement_label); + gfc_statement_label = NULL; + } + + gfc_gobble_whitespace (); + + if (gfc_match_eos () == MATCH_YES) + { + gfc_warning_now + ("Ignoring statement label in empty statement at %C"); + gfc_free_st_label (gfc_statement_label); + gfc_statement_label = NULL; + return ST_NONE; + } + } + } + + return decode_statement (); +} + + +/* Get the next statement in fixed-form source. */ + +static gfc_statement +next_fixed (void) +{ + int label, digit_flag, i; + locus loc; + char c; + + if (!gfc_at_bol ()) + return decode_statement (); + + /* Skip past the current label field, parsing a statement label if + one is there. This is a weird number parser, since the number is + contained within five columns and can have any kind of embedded + spaces. We also check for characters that make the rest of the + line a comment. */ + + label = 0; + digit_flag = 0; + + for (i = 0; i < 5; i++) + { + c = gfc_next_char_literal (0); + + switch (c) + { + case ' ': + break; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + label = label * 10 + c - '0'; + label_locus = *gfc_current_locus (); + digit_flag = 1; + break; + + /* Comments have already been skipped by the time we get + here so don't bother checking for them. */ + + default: + gfc_buffer_error (0); + gfc_error ("Non-numeric character in statement label at %C"); + return ST_NONE; + } + } + + if (digit_flag) + { + if (label == 0) + gfc_warning_now ("Zero is not a valid statement label at %C"); + else + { + /* We've found a valid statement label. */ + gfc_statement_label = gfc_get_st_label (label); + } + } + + /* Since this line starts a statement, it cannot be a continuation + of a previous statement. Hence we mostly ignore column 6. */ + + if (gfc_next_char_literal (0) == '\n') + goto blank_line; + + /* Now that we've taken care of the statement label columns, we have + to make sure that the first nonblank character is not a '!'. If + it is, the rest of the line is a comment. */ + + do + { + loc = *gfc_current_locus (); + c = gfc_next_char_literal (0); + } + while (gfc_is_whitespace (c)); + + if (c == '!') + goto blank_line; + gfc_set_locus (&loc); + + if (gfc_match_eos () == MATCH_YES) + goto blank_line; + + /* At this point, we've got a nonblank statement to parse. */ + return decode_statement (); + +blank_line: + if (digit_flag) + gfc_warning ("Statement label in blank line will be " "ignored at %C"); + gfc_advance_line (); + return ST_NONE; +} + + +/* Return the next non-ST_NONE statement to the caller. We also worry + about including files and the ends of include files at this stage. */ + +static gfc_statement +next_statement (void) +{ + gfc_statement st; + + gfc_new_block = NULL; + + for (;;) + { + gfc_statement_label = NULL; + gfc_buffer_error (1); + + if (gfc_at_eol ()) + gfc_advance_line (); + + gfc_skip_comments (); + + if (gfc_at_bol () && gfc_check_include ()) + continue; + + if (gfc_at_eof () && gfc_current_file->included_by != NULL) + { + gfc_current_file = gfc_current_file->included_by; + gfc_advance_line (); + continue; + } + + if (gfc_at_end ()) + { + st = ST_NONE; + break; + } + + st = + (gfc_current_file->form == FORM_FIXED) ? next_fixed () : next_free (); + if (st != ST_NONE) + break; + } + + gfc_buffer_error (0); + + if (st != ST_NONE) + check_statement_label (st); + + return st; +} + + +/****************************** Parser ***********************************/ + +/* The parser subroutines are of type 'try' that fail if the file ends + unexpectedly. */ + +/* Macros that expand to case-labels for various classes of + statements. Start with executable statements that directly do + things. */ + +#define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \ + case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \ + case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \ + case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \ + case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \ + case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \ + case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: case ST_LABEL_ASSIGNMENT + +/* Statements that mark other executable statements. */ + +#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \ + case ST_WHERE_BLOCK: case ST_SELECT_CASE + +/* Declaration statements */ + +#define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \ + case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \ + case ST_TYPE: case ST_INTERFACE + +/* Block end statements. Errors associated with interchanging these + are detected in gfc_match_end(). */ + +#define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \ + case ST_END_PROGRAM: case ST_END_SUBROUTINE + + +/* Push a new state onto the stack. */ + +static void +push_state (gfc_state_data * p, gfc_compile_state new_state, gfc_symbol * sym) +{ + + p->state = new_state; + p->previous = gfc_state_stack; + p->sym = sym; + p->head = p->tail = NULL; + + gfc_state_stack = p; +} + + +/* Pop the current state. */ + +static void +pop_state (void) +{ + + gfc_state_stack = gfc_state_stack->previous; +} + + +/* Try to find the given state in the state stack. */ + +try +gfc_find_state (gfc_compile_state state) +{ + gfc_state_data *p; + + for (p = gfc_state_stack; p; p = p->previous) + if (p->state == state) + break; + + return (p == NULL) ? FAILURE : SUCCESS; +} + + +/* Starts a new level in the statement list. */ + +static gfc_code * +new_level (gfc_code * q) +{ + gfc_code *p; + + p = q->block = gfc_get_code (); + + gfc_state_stack->head = gfc_state_stack->tail = p; + + return p; +} + + +/* Add the current new_st code structure and adds it to the current + program unit. As a side-effect, it zeroes the new_st. */ + +static gfc_code * +add_statement (void) +{ + gfc_code *p; + + p = gfc_get_code (); + *p = new_st; + + p->loc = *gfc_current_locus (); + + if (gfc_state_stack->head == NULL) + gfc_state_stack->head = p; + else + gfc_state_stack->tail->next = p; + + while (p->next != NULL) + p = p->next; + + gfc_state_stack->tail = p; + + gfc_clear_new_st (); + + return p; +} + + +/* Frees everything associated with the current statement. */ + +static void +undo_new_statement (void) +{ + gfc_free_statements (new_st.block); + gfc_free_statements (new_st.next); + gfc_free_statement (&new_st); + gfc_clear_new_st (); +} + + +/* If the current statement has a statement label, make sure that it + is allowed to, or should have one. */ + +static void +check_statement_label (gfc_statement st) +{ + gfc_sl_type type; + + if (gfc_statement_label == NULL) + { + if (st == ST_FORMAT) + gfc_error ("FORMAT statement at %L does not have a statement label", + &new_st.loc); + return; + } + + switch (st) + { + case ST_END_PROGRAM: + case ST_END_FUNCTION: + case ST_END_SUBROUTINE: + case ST_ENDDO: + case ST_ENDIF: + case ST_END_SELECT: + case_executable: + case_exec_markers: + type = ST_LABEL_TARGET; + break; + + case ST_FORMAT: + type = ST_LABEL_FORMAT; + break; + + /* Statement labels are not restricted from appearing on a + particular line. However, there are plenty of situations + where the resulting label can't be referenced. */ + + default: + type = ST_LABEL_BAD_TARGET; + break; + } + + gfc_define_st_label (gfc_statement_label, type, &label_locus); + + new_st.here = gfc_statement_label; +} + + +/* Figures out what the enclosing program unit is. This will be a + function, subroutine, program, block data or module. */ + +gfc_state_data * +gfc_enclosing_unit (gfc_compile_state * result) +{ + gfc_state_data *p; + + for (p = gfc_state_stack; p; p = p->previous) + if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE + || p->state == COMP_MODULE || p->state == COMP_BLOCK_DATA + || p->state == COMP_PROGRAM) + { + + if (result != NULL) + *result = p->state; + return p; + } + + if (result != NULL) + *result = COMP_PROGRAM; + return NULL; +} + + +/* Translate a statement enum to a string. */ + +const char * +gfc_ascii_statement (gfc_statement st) +{ + const char *p; + + switch (st) + { + case ST_ARITHMETIC_IF: + p = "arithmetic IF"; + break; + case ST_ALLOCATE: + p = "ALLOCATE"; + break; + case ST_ATTR_DECL: + p = "attribute declaration"; + break; + case ST_BACKSPACE: + p = "BACKSPACE"; + break; + case ST_BLOCK_DATA: + p = "BLOCK DATA"; + break; + case ST_CALL: + p = "CALL"; + break; + case ST_CASE: + p = "CASE"; + break; + case ST_CLOSE: + p = "CLOSE"; + break; + case ST_COMMON: + p = "COMMON"; + break; + case ST_CONTINUE: + p = "CONTINUE"; + break; + case ST_CONTAINS: + p = "CONTAINS"; + break; + case ST_CYCLE: + p = "CYCLE"; + break; + case ST_DATA_DECL: + p = "data declaration"; + break; + case ST_DATA: + p = "DATA"; + break; + case ST_DEALLOCATE: + p = "DEALLOCATE"; + break; + case ST_DERIVED_DECL: + p = "Derived type declaration"; + break; + case ST_DO: + p = "DO"; + break; + case ST_ELSE: + p = "ELSE"; + break; + case ST_ELSEIF: + p = "ELSE IF"; + break; + case ST_ELSEWHERE: + p = "ELSEWHERE"; + break; + case ST_END_BLOCK_DATA: + p = "END BLOCK DATA"; + break; + case ST_ENDDO: + p = "END DO"; + break; + case ST_END_FILE: + p = "END FILE"; + break; + case ST_END_FORALL: + p = "END FORALL"; + break; + case ST_END_FUNCTION: + p = "END FUNCTION"; + break; + case ST_ENDIF: + p = "END IF"; + break; + case ST_END_INTERFACE: + p = "END INTERFACE"; + break; + case ST_END_MODULE: + p = "END MODULE"; + break; + case ST_END_PROGRAM: + p = "END PROGRAM"; + break; + case ST_END_SELECT: + p = "END SELECT"; + break; + case ST_END_SUBROUTINE: + p = "END SUBROUTINE"; + break; + case ST_END_WHERE: + p = "END WHERE"; + break; + case ST_END_TYPE: + p = "END TYPE"; + break; + case ST_ENTRY: + p = "ENTRY"; + break; + case ST_EQUIVALENCE: + p = "EQUIVALENCE"; + break; + case ST_EXIT: + p = "EXIT"; + break; + case ST_FORALL_BLOCK: /* Fall through */ + case ST_FORALL: + p = "FORALL"; + break; + case ST_FORMAT: + p = "FORMAT"; + break; + case ST_FUNCTION: + p = "FUNCTION"; + break; + case ST_GOTO: + p = "GOTO"; + break; + case ST_IF_BLOCK: + p = "block IF"; + break; + case ST_IMPLICIT: + p = "IMPLICIT"; + break; + case ST_IMPLICIT_NONE: + p = "IMPLICIT NONE"; + break; + case ST_IMPLIED_ENDDO: + p = "implied END DO"; + break; + case ST_INQUIRE: + p = "INQUIRE"; + break; + case ST_INTERFACE: + p = "INTERFACE"; + break; + case ST_PARAMETER: + p = "PARAMETER"; + break; + case ST_PRIVATE: + p = "PRIVATE"; + break; + case ST_PUBLIC: + p = "PUBLIC"; + break; + case ST_MODULE: + p = "MODULE"; + break; + case ST_PAUSE: + p = "PAUSE"; + break; + case ST_MODULE_PROC: + p = "MODULE PROCEDURE"; + break; + case ST_NAMELIST: + p = "NAMELIST"; + break; + case ST_NULLIFY: + p = "NULLIFY"; + break; + case ST_OPEN: + p = "OPEN"; + break; + case ST_PROGRAM: + p = "PROGRAM"; + break; + case ST_READ: + p = "READ"; + break; + case ST_RETURN: + p = "RETURN"; + break; + case ST_REWIND: + p = "REWIND"; + break; + case ST_STOP: + p = "STOP"; + break; + case ST_SUBROUTINE: + p = "SUBROUTINE"; + break; + case ST_TYPE: + p = "TYPE"; + break; + case ST_USE: + p = "USE"; + break; + case ST_WHERE_BLOCK: /* Fall through */ + case ST_WHERE: + p = "WHERE"; + break; + case ST_WRITE: + p = "WRITE"; + break; + case ST_ASSIGNMENT: + p = "assignment"; + break; + case ST_POINTER_ASSIGNMENT: + p = "pointer assignment"; + break; + case ST_SELECT_CASE: + p = "SELECT CASE"; + break; + case ST_SEQUENCE: + p = "SEQUENCE"; + break; + case ST_SIMPLE_IF: + p = "Simple IF"; + break; + case ST_STATEMENT_FUNCTION: + p = "STATEMENT FUNCTION"; + break; + case ST_LABEL_ASSIGNMENT: + p = "LABEL ASSIGNMENT"; + break; + default: + gfc_internal_error ("gfc_ascii_statement(): Bad statement code"); + } + + return p; +} + + +/* Return the name of a compile state. */ + +const char * +gfc_state_name (gfc_compile_state state) +{ + const char *p; + + switch (state) + { + case COMP_PROGRAM: + p = "a PROGRAM"; + break; + case COMP_MODULE: + p = "a MODULE"; + break; + case COMP_SUBROUTINE: + p = "a SUBROUTINE"; + break; + case COMP_FUNCTION: + p = "a FUNCTION"; + break; + case COMP_BLOCK_DATA: + p = "a BLOCK DATA"; + break; + case COMP_INTERFACE: + p = "an INTERFACE"; + break; + case COMP_DERIVED: + p = "a DERIVED TYPE block"; + break; + case COMP_IF: + p = "an IF-THEN block"; + break; + case COMP_DO: + p = "a DO block"; + break; + case COMP_SELECT: + p = "a SELECT block"; + break; + case COMP_FORALL: + p = "a FORALL block"; + break; + case COMP_WHERE: + p = "a WHERE block"; + break; + case COMP_CONTAINS: + p = "a contained subprogram"; + break; + + default: + gfc_internal_error ("gfc_state_name(): Bad state"); + } + + return p; +} + + +/* Do whatever is necessary to accept the last statement. */ + +static void +accept_statement (gfc_statement st) +{ + + switch (st) + { + case ST_USE: + gfc_use_module (); + break; + + case ST_IMPLICIT_NONE: + gfc_set_implicit_none (); + break; + + case ST_IMPLICIT: + gfc_set_implicit (); + break; + + case ST_FUNCTION: + case ST_SUBROUTINE: + case ST_MODULE: + gfc_current_ns->proc_name = gfc_new_block; + break; + + /* If the statement is the end of a block, lay down a special code + that allows a branch to the end of the block from within the + construct. */ + + case ST_ENDIF: + case ST_ENDDO: + case ST_END_SELECT: + if (gfc_statement_label != NULL) + { + new_st.op = EXEC_NOP; + add_statement (); + } + + break; + + /* The end-of-program unit statements do not get the special + marker and require a statement of some sort if they are a + branch target. */ + + case ST_END_PROGRAM: + case ST_END_FUNCTION: + case ST_END_SUBROUTINE: + if (gfc_statement_label != NULL) + { + new_st.op = EXEC_RETURN; + add_statement (); + } + + break; + + case ST_BLOCK_DATA: + { + gfc_symbol *block_data = NULL; + symbol_attribute attr; + + gfc_get_symbol ("_BLOCK_DATA__", gfc_current_ns, &block_data); + gfc_clear_attr (&attr); + attr.flavor = FL_PROCEDURE; + attr.proc = PROC_UNKNOWN; + attr.subroutine = 1; + attr.access = ACCESS_PUBLIC; + block_data->attr = attr; + gfc_current_ns->proc_name = block_data; + gfc_commit_symbols (); + } + + break; + + case_executable: + case_exec_markers: + add_statement (); + break; + + default: + break; + } + + gfc_commit_symbols (); + gfc_warning_check (); + gfc_clear_new_st (); +} + + +/* Undo anything tentative that has been built for the current + statement. */ + +static void +reject_statement (void) +{ + + gfc_undo_symbols (); + gfc_clear_warning (); + undo_new_statement (); +} + + +/* Generic complaint about an out of order statement. We also do + whatever is necessary to clean up. */ + +static void +unexpected_statement (gfc_statement st) +{ + + gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st)); + + reject_statement (); +} + + +/* Given the next statement seen by the matcher, make sure that it is + in proper order with the last. This subroutine is initialized by + calling it with an argument of ST_NONE. If there is a problem, we + issue an error and return FAILURE. Otherwise we return SUCCESS. + + Individual parsers need to verify that the statements seen are + valid before calling here, ie ENTRY statements are not allowed in + INTERFACE blocks. The following diagram is taken from the standard: + + +---------------------------------------+ + | program subroutine function module | + +---------------------------------------+ + | use | + |---------------------------------------+ + | | implicit none | + | +-----------+------------------+ + | | parameter | implicit | + | +-----------+------------------+ + | format | | derived type | + | entry | parameter | interface | + | | data | specification | + | | | statement func | + | +-----------+------------------+ + | | data | executable | + +--------+-----------+------------------+ + | contains | + +---------------------------------------+ + | internal module/subprogram | + +---------------------------------------+ + | end | + +---------------------------------------+ + +*/ + +typedef struct +{ + enum + { ORDER_START, ORDER_USE, ORDER_IMPLICIT_NONE, ORDER_IMPLICIT, + ORDER_SPEC, ORDER_EXEC + } + state; + gfc_statement last_statement; + locus where; +} +st_state; + +static try +verify_st_order (st_state * p, gfc_statement st) +{ + + switch (st) + { + case ST_NONE: + p->state = ORDER_START; + break; + + case ST_USE: + if (p->state > ORDER_USE) + goto order; + p->state = ORDER_USE; + break; + + case ST_IMPLICIT_NONE: + if (p->state > ORDER_IMPLICIT_NONE) + goto order; + + /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY + statement disqualifies a USE but not an IMPLICIT NONE. + Duplicate IMPLICIT NONEs are caught when the implicit types + are set. */ + + p->state = ORDER_IMPLICIT_NONE; + break; + + case ST_IMPLICIT: + if (p->state > ORDER_IMPLICIT) + goto order; + p->state = ORDER_IMPLICIT; + break; + + case ST_FORMAT: + case ST_ENTRY: + if (p->state < ORDER_IMPLICIT_NONE) + p->state = ORDER_IMPLICIT_NONE; + break; + + case ST_PARAMETER: + if (p->state >= ORDER_EXEC) + goto order; + if (p->state < ORDER_IMPLICIT) + p->state = ORDER_IMPLICIT; + break; + + case ST_DATA: + if (p->state < ORDER_SPEC) + p->state = ORDER_SPEC; + break; + + case ST_PUBLIC: + case ST_PRIVATE: + case ST_DERIVED_DECL: + case_decl: + if (p->state >= ORDER_EXEC) + goto order; + if (p->state < ORDER_SPEC) + p->state = ORDER_SPEC; + break; + + case_executable: + case_exec_markers: + if (p->state < ORDER_EXEC) + p->state = ORDER_EXEC; + break; + + default: + gfc_internal_error + ("Unexpected %s statement in verify_st_order() at %C", + gfc_ascii_statement (st)); + } + + /* All is well, record the statement in case we need it next time. */ + p->where = *gfc_current_locus (); + p->last_statement = st; + return SUCCESS; + +order: + gfc_error ("%s statement at %C cannot follow %s statement at %L", + gfc_ascii_statement (st), + gfc_ascii_statement (p->last_statement), &p->where); + + return FAILURE; +} + + +/* Handle an unexpected end of file. This is a show-stopper... */ + +static void unexpected_eof (void) ATTRIBUTE_NORETURN; + +static void +unexpected_eof (void) +{ + gfc_state_data *p; + + gfc_error ("Unexpected end of file in '%s'", gfc_current_file->filename); + + /* Memory cleanup. Move to "second to last". */ + for (p = gfc_state_stack; p && p->previous && p->previous->previous; + p = p->previous); + + gfc_current_ns->code = (p && p->previous) ? p->head : NULL; + gfc_done_2 (); + + longjmp (eof, 1); +} + + +/* Parse a derived type. */ + +static void +parse_derived (void) +{ + int compiling_type, seen_private, seen_sequence, seen_component, error_flag; + gfc_statement st; + gfc_component *c; + gfc_state_data s; + + error_flag = 0; + + accept_statement (ST_DERIVED_DECL); + push_state (&s, COMP_DERIVED, gfc_new_block); + + gfc_new_block->component_access = ACCESS_PUBLIC; + seen_private = 0; + seen_sequence = 0; + seen_component = 0; + + compiling_type = 1; + + while (compiling_type) + { + st = next_statement (); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_DATA_DECL: + accept_statement (st); + seen_component = 1; + break; + + case ST_END_TYPE: + compiling_type = 0; + + if (!seen_component) + { + gfc_error ("Derived type definition at %C has no components"); + error_flag = 1; + } + + accept_statement (ST_END_TYPE); + break; + + case ST_PRIVATE: + if (gfc_find_state (COMP_MODULE) == FAILURE) + { + gfc_error + ("PRIVATE statement in TYPE at %C must be inside a MODULE"); + error_flag = 1; + break; + } + + if (seen_component) + { + gfc_error ("PRIVATE statement at %C must precede " + "structure components"); + error_flag = 1; + break; + } + + if (seen_private) + { + gfc_error ("Duplicate PRIVATE statement at %C"); + error_flag = 1; + } + + s.sym->component_access = ACCESS_PRIVATE; + accept_statement (ST_PRIVATE); + seen_private = 1; + break; + + case ST_SEQUENCE: + if (seen_component) + { + gfc_error ("SEQUENCE statement at %C must precede " + "structure components"); + error_flag = 1; + break; + } + + if (gfc_current_block ()->attr.sequence) + gfc_warning ("SEQUENCE attribute at %C already specified in " + "TYPE statement"); + + if (seen_sequence) + { + gfc_error ("Duplicate SEQUENCE statement at %C"); + error_flag = 1; + } + + seen_sequence = 1; + gfc_add_sequence (&gfc_current_block ()->attr, NULL); + break; + + default: + unexpected_statement (st); + break; + } + } + + /* Sanity checks on the structure. If the structure has the + SEQUENCE attribute, then all component structures must also have + SEQUENCE. */ + if (error_flag == 0 && gfc_current_block ()->attr.sequence) + for (c = gfc_current_block ()->components; c; c = c->next) + { + if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0) + { + gfc_error + ("Component %s of SEQUENCE type declared at %C does not " + "have the SEQUENCE attribute", c->ts.derived->name); + } + } + + pop_state (); +} + + + +/* Parse an interface. We must be able to deal with the possibility + of recursive interfaces. The parse_spec() subroutine is mutually + recursive with parse_interface(). */ + +static gfc_statement parse_spec (gfc_statement); + +static void +parse_interface (void) +{ + gfc_compile_state new_state, current_state; + gfc_symbol *prog_unit, *sym; + gfc_interface_info save; + gfc_state_data s1, s2; + gfc_statement st; + int seen_body; + + accept_statement (ST_INTERFACE); + + current_interface.ns = gfc_current_ns; + save = current_interface; + + sym = (current_interface.type == INTERFACE_GENERIC + || current_interface.type == INTERFACE_USER_OP) ? gfc_new_block : NULL; + + push_state (&s1, COMP_INTERFACE, sym); + seen_body = 0; + current_state = COMP_NONE; + +loop: + gfc_current_ns = gfc_get_namespace (current_interface.ns); + + st = next_statement (); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_SUBROUTINE: + new_state = COMP_SUBROUTINE; + gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, + gfc_new_block->formal, NULL); + break; + + case ST_FUNCTION: + new_state = COMP_FUNCTION; + gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, + gfc_new_block->formal, NULL); + break; + + case ST_MODULE_PROC: /* The module procedure matcher makes + sure the context is correct. */ + seen_body = 1; + accept_statement (st); + gfc_free_namespace (gfc_current_ns); + goto loop; + + case ST_END_INTERFACE: + gfc_free_namespace (gfc_current_ns); + gfc_current_ns = current_interface.ns; + goto done; + + default: + gfc_error ("Unexpected %s statement in INTERFACE block at %C", + gfc_ascii_statement (st)); + reject_statement (); + gfc_free_namespace (gfc_current_ns); + goto loop; + } + + + /* Make sure that a generic interface has only subroutines or + functions and that the generic name has the right attribute. */ + if (current_interface.type == INTERFACE_GENERIC) + { + if (current_state == COMP_NONE) + { + if (new_state == COMP_FUNCTION) + gfc_add_function (&sym->attr, NULL); + if (new_state == COMP_SUBROUTINE) + gfc_add_subroutine (&sym->attr, NULL); + + current_state = new_state; + } + else + { + if (new_state != current_state) + { + if (new_state == COMP_SUBROUTINE) + gfc_error + ("SUBROUTINE at %C does not belong in a generic function " + "interface"); + + if (new_state == COMP_FUNCTION) + gfc_error + ("FUNCTION at %C does not belong in a generic subroutine " + "interface"); + } + } + } + + push_state (&s2, new_state, gfc_new_block); + accept_statement (st); + prog_unit = gfc_new_block; + prog_unit->formal_ns = gfc_current_ns; + +decl: + /* Read data declaration statements. */ + st = parse_spec (ST_NONE); + + if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION) + { + gfc_error ("Unexpected %s statement at %C in INTERFACE body", + gfc_ascii_statement (st)); + reject_statement (); + goto decl; + } + + seen_body = 1; + + current_interface = save; + gfc_add_interface (prog_unit); + + pop_state (); + goto loop; + +done: + if (!seen_body) + gfc_error ("INTERFACE block at %C is empty"); + + pop_state (); +} + + +/* Parse a set of specification statements. Returns the statement + that doesn't fit. */ + +static gfc_statement +parse_spec (gfc_statement st) +{ + st_state ss; + + verify_st_order (&ss, ST_NONE); + if (st == ST_NONE) + st = next_statement (); + +loop: + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_FORMAT: + case ST_ENTRY: + case ST_DATA: /* Not allowed in interfaces */ + if (gfc_current_state () == COMP_INTERFACE) + break; + + /* Fall through */ + + case ST_USE: + case ST_IMPLICIT_NONE: + case ST_IMPLICIT: + case ST_PARAMETER: + case ST_PUBLIC: + case ST_PRIVATE: + case ST_DERIVED_DECL: + case_decl: + if (verify_st_order (&ss, st) == FAILURE) + { + reject_statement (); + st = next_statement (); + goto loop; + } + + switch (st) + { + case ST_INTERFACE: + parse_interface (); + break; + + case ST_DERIVED_DECL: + parse_derived (); + break; + + case ST_PUBLIC: + case ST_PRIVATE: + if (gfc_current_state () != COMP_MODULE) + { + gfc_error ("%s statement must appear in a MODULE", + gfc_ascii_statement (st)); + break; + } + + if (gfc_current_ns->default_access != ACCESS_UNKNOWN) + { + gfc_error ("%s statement at %C follows another accessibility " + "specification", gfc_ascii_statement (st)); + break; + } + + gfc_current_ns->default_access = (st == ST_PUBLIC) + ? ACCESS_PUBLIC : ACCESS_PRIVATE; + + break; + + default: + break; + } + + accept_statement (st); + st = next_statement (); + goto loop; + + default: + break; + } + + return st; +} + + +/* Parse a WHERE block, (not a simple WHERE statement). */ + +static void +parse_where_block (void) +{ + int seen_empty_else; + gfc_code *top, *d; + gfc_state_data s; + gfc_statement st; + + accept_statement (ST_WHERE_BLOCK); + top = gfc_state_stack->tail; + + push_state (&s, COMP_WHERE, gfc_new_block); + + d = add_statement (); + d->expr = top->expr; + d->op = EXEC_WHERE; + + top->expr = NULL; + top->block = d; + + seen_empty_else = 0; + + do + { + st = next_statement (); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_WHERE_BLOCK: + parse_where_block (); + /* Fall through */ + + case ST_ASSIGNMENT: + case ST_WHERE: + accept_statement (st); + break; + + case ST_ELSEWHERE: + if (seen_empty_else) + { + gfc_error + ("ELSEWHERE statement at %C follows previous unmasked " + "ELSEWHERE"); + break; + } + + if (new_st.expr == NULL) + seen_empty_else = 1; + + d = new_level (gfc_state_stack->head); + d->op = EXEC_WHERE; + d->expr = new_st.expr; + + accept_statement (st); + + break; + + case ST_END_WHERE: + accept_statement (st); + break; + + default: + gfc_error ("Unexpected %s statement in WHERE block at %C", + gfc_ascii_statement (st)); + reject_statement (); + break; + } + + } + while (st != ST_END_WHERE); + + pop_state (); +} + + +/* Parse a FORALL block (not a simple FORALL statement). */ + +static void +parse_forall_block (void) +{ + gfc_code *top, *d; + gfc_state_data s; + gfc_statement st; + + accept_statement (ST_FORALL_BLOCK); + top = gfc_state_stack->tail; + + push_state (&s, COMP_FORALL, gfc_new_block); + + d = add_statement (); + d->op = EXEC_FORALL; + top->block = d; + + do + { + st = next_statement (); + switch (st) + { + + case ST_ASSIGNMENT: + case ST_POINTER_ASSIGNMENT: + case ST_WHERE: + case ST_FORALL: + accept_statement (st); + break; + + case ST_WHERE_BLOCK: + parse_where_block (); + break; + + case ST_FORALL_BLOCK: + parse_forall_block (); + break; + + case ST_END_FORALL: + accept_statement (st); + break; + + case ST_NONE: + unexpected_eof (); + + default: + gfc_error ("Unexpected %s statement in FORALL block at %C", + gfc_ascii_statement (st)); + + reject_statement (); + break; + } + } + while (st != ST_END_FORALL); + + pop_state (); +} + + +static gfc_statement parse_executable (gfc_statement); + +/* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */ + +static void +parse_if_block (void) +{ + gfc_code *top, *d; + gfc_statement st; + locus else_locus; + gfc_state_data s; + int seen_else; + + seen_else = 0; + accept_statement (ST_IF_BLOCK); + + top = gfc_state_stack->tail; + push_state (&s, COMP_IF, gfc_new_block); + + new_st.op = EXEC_IF; + d = add_statement (); + + d->expr = top->expr; + top->expr = NULL; + top->block = d; + + do + { + st = parse_executable (ST_NONE); + + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_ELSEIF: + if (seen_else) + { + gfc_error + ("ELSE IF statement at %C cannot follow ELSE statement at %L", + &else_locus); + + reject_statement (); + break; + } + + d = new_level (gfc_state_stack->head); + d->op = EXEC_IF; + d->expr = new_st.expr; + + accept_statement (st); + + break; + + case ST_ELSE: + if (seen_else) + { + gfc_error ("Duplicate ELSE statements at %L and %C", + &else_locus); + reject_statement (); + break; + } + + seen_else = 1; + else_locus = *gfc_current_locus (); + + d = new_level (gfc_state_stack->head); + d->op = EXEC_IF; + + accept_statement (st); + + break; + + case ST_ENDIF: + break; + + default: + unexpected_statement (st); + break; + } + } + while (st != ST_ENDIF); + + pop_state (); + accept_statement (st); +} + + +/* Parse a SELECT block. */ + +static void +parse_select_block (void) +{ + gfc_statement st; + gfc_code *cp; + gfc_state_data s; + + accept_statement (ST_SELECT_CASE); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_SELECT, gfc_new_block); + + /* Make sure that the next statement is a CASE or END SELECT. */ + for (;;) + { + st = next_statement (); + if (st == ST_NONE) + unexpected_eof (); + if (st == ST_END_SELECT) + { + /* Empty SELECT CASE is OK. */ + accept_statement (st); + pop_state (); + return; + } + if (st == ST_CASE) + break; + + gfc_error + ("Expected a CASE or END SELECT statement following SELECT CASE " + "at %C"); + + reject_statement (); + } + + /* At this point, we're got a nonempty select block. */ + cp = new_level (cp); + *cp = new_st; + + accept_statement (st); + + do + { + st = parse_executable (ST_NONE); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_CASE: + cp = new_level (gfc_state_stack->head); + *cp = new_st; + gfc_clear_new_st (); + + accept_statement (st); + /* Fall through */ + + case ST_END_SELECT: + break; + + /* Can't have an executable statement because of + parse_executable(). */ + default: + unexpected_statement (st); + break; + } + } + while (st != ST_END_SELECT); + + pop_state (); + accept_statement (st); +} + + +/* Checks to see if the current statement label closes an enddo. + Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues + an error) if it incorrectly closes an ENDDO. */ + +static int +check_do_closure (void) +{ + gfc_state_data *p; + + if (gfc_statement_label == NULL) + return 0; + + for (p = gfc_state_stack; p; p = p->previous) + if (p->state == COMP_DO) + break; + + if (p == NULL) + return 0; /* No loops to close */ + + if (p->ext.end_do_label == gfc_statement_label) + { + + if (p == gfc_state_stack) + return 1; + + gfc_error + ("End of nonblock DO statement at %C is within another block"); + return 2; + } + + /* At this point, the label doesn't terminate the innermost loop. + Make sure it doesn't terminate another one. */ + for (; p; p = p->previous) + if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label) + { + gfc_error ("End of nonblock DO statement at %C is interwoven " + "with another DO loop"); + return 2; + } + + return 0; +} + + +/* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are + handled inside of parse_executable(), because they aren't really + loop statements. */ + +static void +parse_do_block (void) +{ + gfc_statement st; + gfc_code *top; + gfc_state_data s; + + s.ext.end_do_label = new_st.label; + + accept_statement (ST_DO); + + top = gfc_state_stack->tail; + push_state (&s, COMP_DO, gfc_new_block); + + top->block = new_level (top); + top->block->op = EXEC_DO; + +loop: + st = parse_executable (ST_NONE); + + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_ENDDO: + if (s.ext.end_do_label != NULL + && s.ext.end_do_label != gfc_statement_label) + gfc_error_now + ("Statement label in ENDDO at %C doesn't match DO label"); + /* Fall through */ + + case ST_IMPLIED_ENDDO: + break; + + default: + unexpected_statement (st); + goto loop; + } + + pop_state (); + accept_statement (st); +} + + +/* Accept a series of executable statements. We return the first + statement that doesn't fit to the caller. Any block statements are + passed on to the correct handler, which usually passes the buck + right back here. */ + +static gfc_statement +parse_executable (gfc_statement st) +{ + int close_flag; + + if (st == ST_NONE) + st = next_statement (); + + for (;; st = next_statement ()) + { + + close_flag = check_do_closure (); + if (close_flag) + switch (st) + { + case ST_GOTO: + case ST_END_PROGRAM: + case ST_RETURN: + case ST_EXIT: + case ST_END_FUNCTION: + case ST_CYCLE: + case ST_PAUSE: + case ST_STOP: + case ST_END_SUBROUTINE: + + case ST_DO: + case ST_FORALL: + case ST_WHERE: + case ST_SELECT_CASE: + gfc_error + ("%s statement at %C cannot terminate a non-block DO loop", + gfc_ascii_statement (st)); + break; + + default: + break; + } + + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_FORMAT: + case ST_DATA: + case ST_ENTRY: + case_executable: + accept_statement (st); + if (close_flag == 1) + return ST_IMPLIED_ENDDO; + continue; + + case ST_IF_BLOCK: + parse_if_block (); + continue; + + case ST_SELECT_CASE: + parse_select_block (); + continue; + + case ST_DO: + parse_do_block (); + if (check_do_closure () == 1) + return ST_IMPLIED_ENDDO; + continue; + + case ST_WHERE_BLOCK: + parse_where_block (); + continue; + + case ST_FORALL_BLOCK: + parse_forall_block (); + continue; + + default: + break; + } + + break; + } + + return st; +} + + +/* Parse a series of contained program units. */ + +static void parse_progunit (gfc_statement); + + +/* Fix the symbols for sibling functions. These are incorrectly added to + the child namespace as the parser didn't know about this procedure. */ + +static void +gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings) +{ + gfc_namespace *ns; + gfc_symtree *st; + gfc_symbol *old_sym; + + for (ns = siblings; ns; ns = ns->sibling) + { + gfc_find_sym_tree (sym->name, ns, 0, &st); + if (!st) + continue; + + old_sym = st->n.sym; + if (old_sym->attr.flavor == FL_PROCEDURE && old_sym->ns == ns + && ! old_sym->attr.contained) + { + /* Replace it with the symbol from the parent namespace. */ + st->n.sym = sym; + sym->refs++; + + /* Free the old (local) symbol. */ + old_sym->refs--; + if (old_sym->refs == 0) + gfc_free_symbol (old_sym); + } + + /* Do the same for any contined procedures. */ + gfc_fixup_sibling_symbols (sym, ns->contained); + } +} + +static void +parse_contained (int module) +{ + gfc_namespace *ns, *parent_ns; + gfc_state_data s1, s2; + gfc_statement st; + gfc_symbol *sym; + + push_state (&s1, COMP_CONTAINS, NULL); + parent_ns = gfc_current_ns; + + do + { + gfc_current_ns = gfc_get_namespace (parent_ns); + + gfc_current_ns->sibling = parent_ns->contained; + parent_ns->contained = gfc_current_ns; + + st = next_statement (); + + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_FUNCTION: + case ST_SUBROUTINE: + accept_statement (st); + + push_state (&s2, + (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE, + gfc_new_block); + + /* For internal procedures, create/update the symbol in the + * parent namespace */ + + if (!module) + { + if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym)) + gfc_error + ("Contained procedure '%s' at %C is already ambiguous", + gfc_new_block->name); + else + { + if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, + &gfc_new_block->declared_at) == + SUCCESS) + { + if (st == ST_FUNCTION) + gfc_add_function (&sym->attr, + &gfc_new_block->declared_at); + else + gfc_add_subroutine (&sym->attr, + &gfc_new_block->declared_at); + } + } + + gfc_commit_symbols (); + } + else + sym = gfc_new_block; + + /* Mark this as a contained function, so it isn't replaced + by other module functions. */ + sym->attr.contained = 1; + + /* Fix up any sibling functions that refer to this one. */ + gfc_fixup_sibling_symbols (sym, gfc_current_ns); + + parse_progunit (ST_NONE); + + gfc_current_ns->code = s2.head; + gfc_current_ns = parent_ns; + + pop_state (); + break; + + /* These statements are associated with the end of the host + unit. */ + case ST_END_FUNCTION: + case ST_END_MODULE: + case ST_END_PROGRAM: + case ST_END_SUBROUTINE: + accept_statement (st); + break; + + default: + gfc_error ("Unexpected %s statement in CONTAINS section at %C", + gfc_ascii_statement (st)); + reject_statement (); + break; + } + } + while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE + && st != ST_END_MODULE && st != ST_END_PROGRAM); + + /* The first namespace in the list is guaranteed to not have + anything (worthwhile) in it. */ + + gfc_current_ns = parent_ns; + + ns = gfc_current_ns->contained; + gfc_current_ns->contained = ns->sibling; + gfc_free_namespace (ns); + + pop_state (); +} + + +/* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */ + +static void +parse_progunit (gfc_statement st) +{ + gfc_state_data *p; + int n; + + st = parse_spec (st); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_CONTAINS: + goto contains; + + case_end: + accept_statement (st); + goto done; + + default: + break; + } + +loop: + for (;;) + { + st = parse_executable (st); + + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_CONTAINS: + goto contains; + + case_end: + accept_statement (st); + goto done; + + default: + break; + } + + unexpected_statement (st); + reject_statement (); + st = next_statement (); + } + +contains: + n = 0; + + for (p = gfc_state_stack; p; p = p->previous) + if (p->state == COMP_CONTAINS) + n++; + + if (gfc_find_state (COMP_MODULE) == SUCCESS) + n--; + + if (n > 0) + { + gfc_error ("CONTAINS statement at %C is already in a contained " + "program unit"); + st = next_statement (); + goto loop; + } + + parse_contained (0); + +done: + gfc_current_ns->code = gfc_state_stack->head; +} + + +/* Parse a block data program unit. */ + +static void +parse_block_data (void) +{ + gfc_statement st; + + st = parse_spec (ST_NONE); + + while (st != ST_END_BLOCK_DATA) + { + gfc_error ("Unexpected %s statement in BLOCK DATA at %C", + gfc_ascii_statement (st)); + reject_statement (); + st = next_statement (); + } +} + + +/* Parse a module subprogram. */ + +static void +parse_module (void) +{ + gfc_statement st; + + st = parse_spec (ST_NONE); + +loop: + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_CONTAINS: + parse_contained (1); + break; + + case ST_END_MODULE: + accept_statement (st); + break; + + default: + gfc_error ("Unexpected %s statement in MODULE at %C", + gfc_ascii_statement (st)); + + reject_statement (); + st = next_statement (); + goto loop; + } +} + + +/* Top level parser. */ + +try +gfc_parse_file (void) +{ + int seen_program, errors_before, errors; + gfc_state_data top, s; + gfc_statement st; + locus prog_locus; + + top.state = COMP_NONE; + top.sym = NULL; + top.previous = NULL; + top.head = top.tail = NULL; + + gfc_state_stack = ⊤ + + gfc_clear_new_st (); + + gfc_statement_label = NULL; + + if (setjmp (eof)) + return FAILURE; /* Come here on unexpected EOF */ + + seen_program = 0; + +loop: + gfc_init_2 (); + st = next_statement (); + switch (st) + { + case ST_NONE: + gfc_done_2 (); + goto done; + + case ST_PROGRAM: + if (seen_program) + goto duplicate_main; + seen_program = 1; + prog_locus = *gfc_current_locus (); + + push_state (&s, COMP_PROGRAM, gfc_new_block); + accept_statement (st); + parse_progunit (ST_NONE); + break; + + case ST_SUBROUTINE: + push_state (&s, COMP_SUBROUTINE, gfc_new_block); + accept_statement (st); + parse_progunit (ST_NONE); + break; + + case ST_FUNCTION: + push_state (&s, COMP_FUNCTION, gfc_new_block); + accept_statement (st); + parse_progunit (ST_NONE); + break; + + case ST_BLOCK_DATA: + push_state (&s, COMP_BLOCK_DATA, gfc_new_block); + accept_statement (st); + parse_block_data (); + break; + + case ST_MODULE: + push_state (&s, COMP_MODULE, gfc_new_block); + accept_statement (st); + + gfc_get_errors (NULL, &errors_before); + parse_module (); + break; + + /* Anything else starts a nameless main program block. */ + default: + if (seen_program) + goto duplicate_main; + seen_program = 1; + prog_locus = *gfc_current_locus (); + + push_state (&s, COMP_PROGRAM, gfc_new_block); + parse_progunit (st); + break; + } + + gfc_current_ns->code = s.head; + + gfc_resolve (gfc_current_ns); + + /* Dump the parse tree if requested. */ + if (gfc_option.verbose) + gfc_show_namespace (gfc_current_ns); + + gfc_get_errors (NULL, &errors); + if (s.state == COMP_MODULE) + { + gfc_dump_module (s.sym->name, errors_before == errors); + if (errors == 0 && ! gfc_option.flag_no_backend) + gfc_generate_module_code (gfc_current_ns); + } + else + { + if (errors == 0 && ! gfc_option.flag_no_backend) + gfc_generate_code (gfc_current_ns); + } + + pop_state (); + gfc_done_2 (); + goto loop; + +done: + return SUCCESS; + +duplicate_main: + /* If we see a duplicate main program, shut down. If the second + instance is an implied main program, ie data decls or executable + statements, we're in for lots of errors. */ + gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus); + reject_statement (); + gfc_done_2 (); + return SUCCESS; +} diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h new file mode 100644 index 00000000000..7598441d736 --- /dev/null +++ b/gcc/fortran/parse.h @@ -0,0 +1,65 @@ +/* Parser header + Copyright (C) 2003 Free Software Foundaton, Inc. + Contributed by Steven Bosscher + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#ifndef GFC_PARSE_H +#define GFC_PARSE_H + +#include "gfortran.h" + +/* Enum for what the compiler is currently doing. */ +typedef enum +{ + COMP_NONE, COMP_PROGRAM, COMP_MODULE, COMP_SUBROUTINE, COMP_FUNCTION, + COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_IF, COMP_DO, + COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS +} +gfc_compile_state; + +/* Stack element for the current compilation state. These structures + are allocated as automatic variables. */ +typedef struct gfc_state_data +{ + gfc_compile_state state; + gfc_symbol *sym; /* Block name associated with this level */ + struct gfc_code *head, *tail; + struct gfc_state_data *previous; + + /* Block-specific state data. */ + union + { + gfc_st_label *end_do_label; + } + ext; +} +gfc_state_data; + +extern gfc_state_data *gfc_state_stack; + +#define gfc_current_block() (gfc_state_stack->sym) +#define gfc_current_state() (gfc_state_stack->state) + +try gfc_find_state (gfc_compile_state); +gfc_state_data *gfc_enclosing_unit (gfc_compile_state *); +const char *gfc_ascii_statement (gfc_statement); +const char *gfc_state_name (gfc_compile_state); + +#endif /* GFC_PARSE_H */ diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c new file mode 100644 index 00000000000..03e975776ea --- /dev/null +++ b/gcc/fortran/primary.c @@ -0,0 +1,2214 @@ +/* Primary expression subroutines + Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#include "config.h" +#include "system.h" +#include "flags.h" + +#include <string.h> +#include <stdlib.h> +#include "gfortran.h" +#include "arith.h" +#include "match.h" +#include "parse.h" + +/* Matches a kind-parameter expression, which is either a named + symbolic constant or a nonnegative integer constant. If + successful, sets the kind value to the correct integer. */ + +static match +match_kind_param (int *kind) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + const char *p; + match m; + + m = gfc_match_small_literal_int (kind); + if (m != MATCH_NO) + return m; + + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; + + if (gfc_find_symbol (name, NULL, 1, &sym)) + return MATCH_ERROR; + + if (sym == NULL) + return MATCH_NO; + + if (sym->attr.flavor != FL_PARAMETER) + return MATCH_NO; + + p = gfc_extract_int (sym->value, kind); + if (p != NULL) + return MATCH_NO; + + if (*kind < 0) + return MATCH_NO; + + return MATCH_YES; +} + + +/* Get a trailing kind-specification for non-character variables. + Returns: + the integer kind value or: + -1 if an error was generated + -2 if no kind was found */ + +static int +get_kind (void) +{ + int kind; + match m; + + if (gfc_match_char ('_') != MATCH_YES) + return -2; + + m = match_kind_param (&kind); + if (m == MATCH_NO) + gfc_error ("Missing kind-parameter at %C"); + + return (m == MATCH_YES) ? kind : -1; +} + + +/* Given a character and a radix, see if the character is a valid + digit in that radix. */ + +static int +check_digit (int c, int radix) +{ + int r; + + switch (radix) + { + case 2: + r = ('0' <= c && c <= '1'); + break; + + case 8: + r = ('0' <= c && c <= '7'); + break; + + case 10: + r = ('0' <= c && c <= '9'); + break; + + case 16: + r = ('0' <= c && c <= '9') || ('a' <= c && c <= 'f'); + break; + + default: + gfc_internal_error ("check_digit(): bad radix"); + } + + return r; +} + + +/* Match the digit string part of an integer if signflag is not set, + the signed digit string part if signflag is set. If the buffer + is NULL, we just count characters for the resolution pass. Returns + the number of characters matched, -1 for no match. */ + +static int +match_digits (int signflag, int radix, char *buffer) +{ + locus old_loc; + int length, c; + + length = 0; + c = gfc_next_char (); + + if (signflag && (c == '+' || c == '-')) + { + if (buffer != NULL) + *buffer++ = c; + c = gfc_next_char (); + length++; + } + + if (!check_digit (c, radix)) + return -1; + + length++; + if (buffer != NULL) + *buffer++ = c; + + for (;;) + { + old_loc = *gfc_current_locus (); + c = gfc_next_char (); + + if (!check_digit (c, radix)) + break; + + if (buffer != NULL) + *buffer++ = c; + length++; + } + + gfc_set_locus (&old_loc); + + return length; +} + + +/* Match an integer (digit string and optional kind). + A sign will be accepted if signflag is set. */ + +static match +match_integer_constant (gfc_expr ** result, int signflag) +{ + int length, kind; + locus old_loc; + char *buffer; + gfc_expr *e; + + old_loc = *gfc_current_locus (); + gfc_gobble_whitespace (); + + length = match_digits (signflag, 10, NULL); + gfc_set_locus (&old_loc); + if (length == -1) + return MATCH_NO; + + buffer = alloca (length + 1); + memset (buffer, '\0', length + 1); + + gfc_gobble_whitespace (); + + match_digits (signflag, 10, buffer); + + kind = get_kind (); + if (kind == -2) + kind = gfc_default_integer_kind (); + if (kind == -1) + return MATCH_ERROR; + + if (gfc_validate_kind (BT_INTEGER, kind) == -1) + { + gfc_error ("Integer kind %d at %C not available", kind); + return MATCH_ERROR; + } + + e = gfc_convert_integer (buffer, kind, 10, gfc_current_locus ()); + + if (gfc_range_check (e) != ARITH_OK) + { + gfc_error ("Integer too big for its kind at %C"); + + gfc_free_expr (e); + return MATCH_ERROR; + } + + *result = e; + return MATCH_YES; +} + + +/* Match a binary, octal or hexadecimal constant that can be found in + a DATA statement. */ + +static match +match_boz_constant (gfc_expr ** result) +{ + int radix, delim, length; + locus old_loc; + char *buffer; + gfc_expr *e; + const char *rname; + + old_loc = *gfc_current_locus (); + gfc_gobble_whitespace (); + + switch (gfc_next_char ()) + { + case 'b': + radix = 2; + rname = "binary"; + break; + case 'o': + radix = 8; + rname = "octal"; + break; + case 'x': + if (pedantic) + gfc_warning_now ("Hexadecimal constant at %C uses non-standard " + "syntax. Use \"Z\" instead."); + /* Fall through. */ + case 'z': + radix = 16; + rname = "hexadecimal"; + break; + default: + goto backup; + } + + /* No whitespace allowed here. */ + + delim = gfc_next_char (); + if (delim != '\'' && delim != '\"') + goto backup; + + old_loc = *gfc_current_locus (); + + length = match_digits (0, radix, NULL); + if (length == -1) + { + gfc_error ("Empty set of digits in %s constants at %C", rname); + return MATCH_ERROR; + } + + if (gfc_next_char () != delim) + { + gfc_error ("Illegal character in %s constant at %C.", rname); + return MATCH_ERROR; + } + + gfc_set_locus (&old_loc); + + buffer = alloca (length + 1); + memset (buffer, '\0', length + 1); + + match_digits (0, radix, buffer); + gfc_next_char (); + + e = gfc_convert_integer (buffer, gfc_default_integer_kind (), radix, + gfc_current_locus ()); + + if (gfc_range_check (e) != ARITH_OK) + { + gfc_error ("Integer too big for default integer kind at %C"); + + gfc_free_expr (e); + return MATCH_ERROR; + } + + *result = e; + return MATCH_YES; + +backup: + gfc_set_locus (&old_loc); + return MATCH_NO; +} + + +/* Match a real constant of some sort. */ + +static match +match_real_constant (gfc_expr ** result, int signflag) +{ + int kind, c, count, seen_dp, seen_digits, exp_char; + locus old_loc, temp_loc; + char *p, *buffer; + gfc_expr *e; + + old_loc = *gfc_current_locus (); + gfc_gobble_whitespace (); + + e = NULL; + + count = 0; + seen_dp = 0; + seen_digits = 0; + exp_char = ' '; + + c = gfc_next_char (); + if (signflag && (c == '+' || c == '-')) + { + c = gfc_next_char (); + count++; + } + + /* Scan significand. */ + for (;; c = gfc_next_char (), count++) + { + if (c == '.') + { + if (seen_dp) + goto done; + + /* Check to see if "." goes with a following operator like ".eq.". */ + temp_loc = *gfc_current_locus (); + c = gfc_next_char (); + + if (c == 'e' || c == 'd' || c == 'q') + { + c = gfc_next_char (); + if (c == '.') + goto done; /* Operator named .e. or .d. */ + } + + if (ISALPHA (c)) + goto done; /* Distinguish 1.e9 from 1.eq.2 */ + + gfc_set_locus (&temp_loc); + seen_dp = 1; + continue; + } + + if (ISDIGIT (c)) + { + seen_digits = 1; + continue; + } + + break; + } + + if (!seen_digits || (c != 'e' && c != 'd' && c != 'q')) + goto done; + exp_char = c; + + /* Scan exponent. */ + c = gfc_next_char (); + count++; + + if (c == '+' || c == '-') + { /* optional sign */ + c = gfc_next_char (); + count++; + } + + if (!ISDIGIT (c)) + { + /* TODO: seen_digits is always true at this point */ + if (!seen_digits) + { + gfc_set_locus (&old_loc); + return MATCH_NO; /* ".e" can be something else */ + } + + gfc_error ("Missing exponent in real number at %C"); + return MATCH_ERROR; + } + + while (ISDIGIT (c)) + { + c = gfc_next_char (); + count++; + } + +done: + /* See what we've got! */ + if (!seen_digits || (!seen_dp && exp_char == ' ')) + { + gfc_set_locus (&old_loc); + return MATCH_NO; + } + + /* Convert the number. */ + gfc_set_locus (&old_loc); + gfc_gobble_whitespace (); + + buffer = alloca (count + 1); + memset (buffer, '\0', count + 1); + + /* Hack for mpf_init_set_str(). */ + p = buffer; + while (count > 0) + { + *p = gfc_next_char (); + if (*p == 'd' || *p == 'q') + *p = 'e'; + p++; + count--; + } + + kind = get_kind (); + if (kind == -1) + goto cleanup; + + switch (exp_char) + { + case 'd': + if (kind != -2) + { + gfc_error + ("Real number at %C has a 'd' exponent and an explicit kind"); + goto cleanup; + } + kind = gfc_default_double_kind (); + break; + + case 'q': + if (kind != -2) + { + gfc_error + ("Real number at %C has a 'q' exponent and an explicit kind"); + goto cleanup; + } + kind = gfc_option.q_kind; + break; + + default: + if (kind == -2) + kind = gfc_default_real_kind (); + + if (gfc_validate_kind (BT_REAL, kind) == -1) + { + gfc_error ("Invalid real kind %d at %C", kind); + goto cleanup; + } + } + + e = gfc_convert_real (buffer, kind, gfc_current_locus ()); + + switch (gfc_range_check (e)) + { + case ARITH_OK: + break; + case ARITH_OVERFLOW: + gfc_error ("Real constant overflows its kind at %C"); + goto cleanup; + + case ARITH_UNDERFLOW: + gfc_error ("Real constant underflows its kind at %C"); + goto cleanup; + + default: + gfc_internal_error ("gfc_range_check() returned bad value"); + } + + *result = e; + return MATCH_YES; + +cleanup: + gfc_free_expr (e); + return MATCH_ERROR; +} + + +/* Match a substring reference. */ + +static match +match_substring (gfc_charlen * cl, int init, gfc_ref ** result) +{ + gfc_expr *start, *end; + locus old_loc; + gfc_ref *ref; + match m; + + start = NULL; + end = NULL; + + old_loc = *gfc_current_locus (); + + m = gfc_match_char ('('); + if (m != MATCH_YES) + return MATCH_NO; + + if (gfc_match_char (':') != MATCH_YES) + { + if (init) + m = gfc_match_init_expr (&start); + else + m = gfc_match_expr (&start); + + if (m != MATCH_YES) + { + m = MATCH_NO; + goto cleanup; + } + + m = gfc_match_char (':'); + if (m != MATCH_YES) + goto cleanup; + } + + if (gfc_match_char (')') != MATCH_YES) + { + if (init) + m = gfc_match_init_expr (&end); + else + m = gfc_match_expr (&end); + + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + m = gfc_match_char (')'); + if (m == MATCH_NO) + goto syntax; + } + + /* Optimize away the (:) reference. */ + if (start == NULL && end == NULL) + ref = NULL; + else + { + ref = gfc_get_ref (); + + ref->type = REF_SUBSTRING; + if (start == NULL) + start = gfc_int_expr (1); + ref->u.ss.start = start; + if (end == NULL && cl) + end = gfc_copy_expr (cl->length); + ref->u.ss.end = end; + ref->u.ss.length = cl; + } + + *result = ref; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in SUBSTRING specification at %C"); + m = MATCH_ERROR; + +cleanup: + gfc_free_expr (start); + gfc_free_expr (end); + + gfc_set_locus (&old_loc); + return m; +} + + +/* Reads the next character of a string constant, taking care to + return doubled delimiters on the input as a single instance of + the delimiter. + + Special return values are: + -1 End of the string, as determined by the delimiter + -2 Unterminated string detected + + Backslash codes are also expanded at this time. */ + +static int +next_string_char (char delimiter) +{ + locus old_locus; + int c; + + c = gfc_next_char_literal (1); + + if (c == '\n') + return -2; + + if (c == '\\') + { + old_locus = *gfc_current_locus (); + + switch (gfc_next_char_literal (1)) + { + case 'a': + c = '\a'; + break; + case 'b': + c = '\b'; + break; + case 't': + c = '\t'; + break; + case 'f': + c = '\f'; + break; + case 'n': + c = '\n'; + break; + case 'r': + c = '\r'; + break; + case 'v': + c = '\v'; + break; + case '\\': + c = '\\'; + break; + + default: + /* Unknown backslash codes are simply not expanded */ + gfc_set_locus (&old_locus); + break; + } + } + + if (c != delimiter) + return c; + + old_locus = *gfc_current_locus (); + c = gfc_next_char_literal (1); + + if (c == delimiter) + return c; + gfc_set_locus (&old_locus); + + return -1; +} + + +/* Special case of gfc_match_name() that matches a parameter kind name + before a string constant. This takes case of the weird but legal + case of: weird case of: + + kind_____'string' + + where kind____ is a parameter. gfc_match_name() will happily slurp + up all the underscores, which leads to problems. If we return + MATCH_YES, the parse pointer points to the final underscore, which + is not part of the name. We never return MATCH_ERROR-- errors in + the name will be detected later. */ + +static match +match_charkind_name (char *name) +{ + locus old_loc; + char c, peek; + int len; + + gfc_gobble_whitespace (); + c = gfc_next_char (); + if (!ISALPHA (c)) + return MATCH_NO; + + *name++ = c; + len = 1; + + for (;;) + { + old_loc = *gfc_current_locus (); + c = gfc_next_char (); + + if (c == '_') + { + peek = gfc_peek_char (); + + if (peek == '\'' || peek == '\"') + { + gfc_set_locus (&old_loc); + *name = '\0'; + return MATCH_YES; + } + } + + if (!ISALNUM (c) + && c != '_' + && (gfc_option.flag_dollar_ok && c != '$')) + break; + + *name++ = c; + if (++len > GFC_MAX_SYMBOL_LEN) + break; + } + + return MATCH_NO; +} + + +/* See if the current input matches a character constant. Lots of + contortions have to be done to match the kind parameter which comes + before the actual string. The main consideration is that we don't + want to error out too quickly. For example, we don't actually do + any validation of the kinds until we have actually seen a legal + delimiter. Using match_kind_param() generates errors too quickly. */ + +static match +match_string_constant (gfc_expr ** result) +{ + char *p, name[GFC_MAX_SYMBOL_LEN + 1]; + int i, c, kind, length, delimiter; + locus old_locus, start_locus; + gfc_symbol *sym; + gfc_expr *e; + const char *q; + match m; + + old_locus = *gfc_current_locus (); + + gfc_gobble_whitespace (); + + start_locus = *gfc_current_locus (); + + c = gfc_next_char (); + if (c == '\'' || c == '"') + { + kind = gfc_default_character_kind (); + goto got_delim; + } + + if (ISDIGIT (c)) + { + kind = 0; + + while (ISDIGIT (c)) + { + kind = kind * 10 + c - '0'; + if (kind > 9999999) + goto no_match; + c = gfc_next_char (); + } + + } + else + { + gfc_set_locus (&old_locus); + + m = match_charkind_name (name); + if (m != MATCH_YES) + goto no_match; + + if (gfc_find_symbol (name, NULL, 1, &sym) + || sym == NULL + || sym->attr.flavor != FL_PARAMETER) + goto no_match; + + kind = -1; + c = gfc_next_char (); + } + + if (c == ' ') + { + gfc_gobble_whitespace (); + c = gfc_next_char (); + } + + if (c != '_') + goto no_match; + + gfc_gobble_whitespace (); + start_locus = *gfc_current_locus (); + + c = gfc_next_char (); + if (c != '\'' && c != '"') + goto no_match; + + if (kind == -1) + { + q = gfc_extract_int (sym->value, &kind); + if (q != NULL) + { + gfc_error (q); + return MATCH_ERROR; + } + } + + if (gfc_validate_kind (BT_CHARACTER, kind) == -1) + { + gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind); + return MATCH_ERROR; + } + +got_delim: + /* Scan the string into a block of memory by first figuring out how + long it is, allocating the structure, then re-reading it. This + isn't particularly efficient, but string constants aren't that + common in most code. TODO: Use obstacks? */ + + delimiter = c; + length = 0; + + for (;;) + { + c = next_string_char (delimiter); + if (c == -1) + break; + if (c == -2) + { + gfc_set_locus (&start_locus); + gfc_error ("Unterminated character constant beginning at %C"); + return MATCH_ERROR; + } + + length++; + } + + e = gfc_get_expr (); + + e->expr_type = EXPR_CONSTANT; + e->ref = NULL; + e->ts.type = BT_CHARACTER; + e->ts.kind = kind; + e->where = start_locus; + + e->value.character.string = p = gfc_getmem (length + 1); + e->value.character.length = length; + + gfc_set_locus (&start_locus); + gfc_next_char (); /* Skip delimiter */ + + for (i = 0; i < length; i++) + *p++ = next_string_char (delimiter); + + *p = '\0'; /* TODO: C-style string is for development/debug purposes. */ + + if (next_string_char (delimiter) != -1) + gfc_internal_error ("match_string_constant(): Delimiter not found"); + + if (match_substring (NULL, 0, &e->ref) != MATCH_NO) + e->expr_type = EXPR_SUBSTRING; + + *result = e; + + return MATCH_YES; + +no_match: + gfc_set_locus (&old_locus); + return MATCH_NO; +} + + +/* Match a .true. or .false. */ + +static match +match_logical_constant (gfc_expr ** result) +{ + static mstring logical_ops[] = { + minit (".false.", 0), + minit (".true.", 1), + minit (NULL, -1) + }; + + gfc_expr *e; + int i, kind; + + i = gfc_match_strings (logical_ops); + if (i == -1) + return MATCH_NO; + + kind = get_kind (); + if (kind == -1) + return MATCH_ERROR; + if (kind == -2) + kind = gfc_default_logical_kind (); + + if (gfc_validate_kind (BT_LOGICAL, kind) == -1) + gfc_error ("Bad kind for logical constant at %C"); + + e = gfc_get_expr (); + + e->expr_type = EXPR_CONSTANT; + e->value.logical = i; + e->ts.type = BT_LOGICAL; + e->ts.kind = kind; + e->where = *gfc_current_locus (); + + *result = e; + return MATCH_YES; +} + + +/* Match a real or imaginary part of a complex constant that is a + symbolic constant. */ + +static match +match_sym_complex_part (gfc_expr ** result) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + gfc_expr *e; + match m; + + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; + + if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL) + return MATCH_NO; + + if (sym->attr.flavor != FL_PARAMETER) + { + gfc_error ("Expected PARAMETER symbol in complex constant at %C"); + return MATCH_ERROR; + } + + if (!gfc_numeric_ts (&sym->value->ts)) + { + gfc_error ("Numeric PARAMETER required in complex constant at %C"); + return MATCH_ERROR; + } + + if (sym->value->rank != 0) + { + gfc_error ("Scalar PARAMETER required in complex constant at %C"); + return MATCH_ERROR; + } + + switch (sym->value->ts.type) + { + case BT_REAL: + e = gfc_copy_expr (sym->value); + break; + + case BT_COMPLEX: + e = gfc_complex2real (sym->value, sym->value->ts.kind); + if (e == NULL) + goto error; + break; + + case BT_INTEGER: + e = gfc_int2real (sym->value, gfc_default_real_kind ()); + if (e == NULL) + goto error; + break; + + default: + gfc_internal_error ("gfc_match_sym_complex_part(): Bad type"); + } + + *result = e; /* e is a scalar, real, constant expression */ + return MATCH_YES; + +error: + gfc_error ("Error converting PARAMETER constant in complex constant at %C"); + return MATCH_ERROR; +} + + +/* Match the real and imaginary parts of a complex number. This + subroutine is essentially match_real_constant() modified in a + couple of ways: A sign is always allowed and numbers that would + look like an integer to match_real_constant() are automatically + created as floating point numbers. The messiness involved with + making sure a decimal point belongs to the number and not a + trailing operator is not necessary here either (Hooray!). */ + +static match +match_const_complex_part (gfc_expr ** result) +{ + int kind, seen_digits, seen_dp, count; + char *p, c, exp_char, *buffer; + locus old_loc; + + old_loc = *gfc_current_locus (); + gfc_gobble_whitespace (); + + seen_dp = 0; + seen_digits = 0; + count = 0; + exp_char = ' '; + + c = gfc_next_char (); + if (c == '-' || c == '+') + { + c = gfc_next_char (); + count++; + } + + for (;; c = gfc_next_char (), count++) + { + if (c == '.') + { + if (seen_dp) + goto no_match; + seen_dp = 1; + continue; + } + + if (ISDIGIT (c)) + { + seen_digits = 1; + continue; + } + + break; + } + + if (!seen_digits || (c != 'd' && c != 'e')) + goto done; + exp_char = c; + + /* Scan exponent. */ + c = gfc_next_char (); + count++; + + if (c == '+' || c == '-') + { /* optional sign */ + c = gfc_next_char (); + count++; + } + + if (!ISDIGIT (c)) + { + gfc_error ("Missing exponent in real number at %C"); + return MATCH_ERROR; + } + + while (ISDIGIT (c)) + { + c = gfc_next_char (); + count++; + } + +done: + if (!seen_digits) + goto no_match; + + /* Convert the number. */ + gfc_set_locus (&old_loc); + gfc_gobble_whitespace (); + + buffer = alloca (count + 1); + memset (buffer, '\0', count + 1); + + /* Hack for mpf_init_set_str(). */ + p = buffer; + while (count > 0) + { + c = gfc_next_char (); + if (c == 'd') + c = 'e'; + *p++ = c; + count--; + } + + *p = '\0'; + + kind = get_kind (); + if (kind == -1) + return MATCH_ERROR; + + /* If the number looked like an integer, forget about a kind we may + have seen, otherwise validate the kind against real kinds. */ + if (seen_dp == 0 && exp_char == ' ') + { + if (kind == -2) + kind = gfc_default_integer_kind (); + + } + else + { + if (exp_char == 'd') + { + if (kind != -2) + { + gfc_error + ("Real number at %C has a 'd' exponent and an explicit kind"); + return MATCH_ERROR; + } + kind = gfc_default_double_kind (); + + } + else + { + if (kind == -2) + kind = gfc_default_real_kind (); + } + + if (gfc_validate_kind (BT_REAL, kind) == -1) + { + gfc_error ("Invalid real kind %d at %C", kind); + return MATCH_ERROR; + } + } + + *result = gfc_convert_real (buffer, kind, gfc_current_locus ()); + return MATCH_YES; + +no_match: + gfc_set_locus (&old_loc); + return MATCH_NO; +} + + +/* Match a real or imaginary part of a complex number. */ + +static match +match_complex_part (gfc_expr ** result) +{ + match m; + + m = match_sym_complex_part (result); + if (m != MATCH_NO) + return m; + + return match_const_complex_part (result); +} + + +/* Try to match a complex constant. */ + +static match +match_complex_constant (gfc_expr ** result) +{ + gfc_expr *e, *real, *imag; + gfc_error_buf old_error; + gfc_typespec target; + locus old_loc; + int kind; + match m; + + old_loc = *gfc_current_locus (); + real = imag = e = NULL; + + m = gfc_match_char ('('); + if (m != MATCH_YES) + return m; + + gfc_push_error (&old_error); + + m = match_complex_part (&real); + if (m == MATCH_NO) + goto cleanup; + + if (gfc_match_char (',') == MATCH_NO) + { + gfc_pop_error (&old_error); + m = MATCH_NO; + goto cleanup; + } + + /* If m is error, then something was wrong with the real part and we + assume we have a complex constant because we've seen the ','. An + ambiguous case here is the start of an iterator list of some + sort. These sort of lists are matched prior to coming here. */ + + if (m == MATCH_ERROR) + goto cleanup; + gfc_pop_error (&old_error); + + m = match_complex_part (&imag); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + m = gfc_match_char (')'); + if (m == MATCH_NO) + goto syntax; + + if (m == MATCH_ERROR) + goto cleanup; + + /* Decide on the kind of this complex number. */ + kind = gfc_kind_max (real, imag); + target.type = BT_REAL; + target.kind = kind; + + if (kind != real->ts.kind) + gfc_convert_type (real, &target, 2); + if (kind != imag->ts.kind) + gfc_convert_type (imag, &target, 2); + + e = gfc_convert_complex (real, imag, kind); + e->where = *gfc_current_locus (); + + gfc_free_expr (real); + gfc_free_expr (imag); + + *result = e; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in COMPLEX constant at %C"); + m = MATCH_ERROR; + +cleanup: + gfc_free_expr (e); + gfc_free_expr (real); + gfc_free_expr (imag); + gfc_set_locus (&old_loc); + + return m; +} + + +/* Match constants in any of several forms. Returns nonzero for a + match, zero for no match. */ + +match +gfc_match_literal_constant (gfc_expr ** result, int signflag) +{ + match m; + + m = match_complex_constant (result); + if (m != MATCH_NO) + return m; + + m = match_string_constant (result); + if (m != MATCH_NO) + return m; + + m = match_boz_constant (result); + if (m != MATCH_NO) + return m; + + m = match_real_constant (result, signflag); + if (m != MATCH_NO) + return m; + + m = match_integer_constant (result, signflag); + if (m != MATCH_NO) + return m; + + m = match_logical_constant (result); + if (m != MATCH_NO) + return m; + + return MATCH_NO; +} + + +/* Match a single actual argument value. An actual argument is + usually an expression, but can also be a procedure name. If the + argument is a single name, it is not always possible to tell + whether the name is a dummy procedure or not. We treat these cases + by creating an argument that looks like a dummy procedure and + fixing things later during resolution. */ + +static match +match_actual_arg (gfc_expr ** result) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symtree *symtree; + locus where, w; + gfc_expr *e; + int c; + + where = *gfc_current_locus (); + + switch (gfc_match_name (name)) + { + case MATCH_ERROR: + return MATCH_ERROR; + + case MATCH_NO: + break; + + case MATCH_YES: + w = *gfc_current_locus (); + gfc_gobble_whitespace (); + c = gfc_next_char (); + gfc_set_locus (&w); + + if (c != ',' && c != ')') + break; + + if (gfc_find_sym_tree (name, NULL, 1, &symtree)) + break; + /* Handle error elsewhere. */ + + /* Eliminate a couple of common cases where we know we don't + have a function argument. */ + if (symtree == NULL) + { + gfc_get_sym_tree (name, NULL, &symtree); + gfc_set_sym_referenced (symtree->n.sym); + } + else + { + gfc_symbol *sym; + + sym = symtree->n.sym; + gfc_set_sym_referenced (sym); + if (sym->attr.flavor != FL_PROCEDURE + && sym->attr.flavor != FL_UNKNOWN) + break; + + /* If the symbol is a function with itself as the result and + is being defined, then we have a variable. */ + if (sym->result == sym + && (gfc_current_ns->proc_name == sym + || (gfc_current_ns->parent != NULL + && gfc_current_ns->parent->proc_name == sym))) + break; + } + + e = gfc_get_expr (); /* Leave it unknown for now */ + e->symtree = symtree; + e->expr_type = EXPR_VARIABLE; + e->ts.type = BT_PROCEDURE; + e->where = where; + + *result = e; + return MATCH_YES; + } + + gfc_set_locus (&where); + return gfc_match_expr (result); +} + + +/* Match a keyword argument. */ + +static match +match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_actual_arglist *a; + locus name_locus; + match m; + + name_locus = *gfc_current_locus (); + m = gfc_match_name (name); + + if (m != MATCH_YES) + goto cleanup; + if (gfc_match_char ('=') != MATCH_YES) + { + m = MATCH_NO; + goto cleanup; + } + + m = match_actual_arg (&actual->expr); + if (m != MATCH_YES) + goto cleanup; + + /* Make sure this name has not appeared yet. */ + + if (name[0] != '\0') + { + for (a = base; a; a = a->next) + if (strcmp (a->name, name) == 0) + { + gfc_error + ("Keyword '%s' at %C has already appeared in the current " + "argument list", name); + return MATCH_ERROR; + } + } + + strcpy (actual->name, name); + return MATCH_YES; + +cleanup: + gfc_set_locus (&name_locus); + return m; +} + + +/* Matches an actual argument list of a function or subroutine, from + the opening parenthesis to the closing parenthesis. The argument + list is assumed to allow keyword arguments because we don't know if + the symbol associated with the procedure has an implicit interface + or not. We make sure keywords are unique. */ + +match +gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp) +{ + gfc_actual_arglist *head, *tail; + int seen_keyword; + gfc_st_label *label; + locus old_loc; + match m; + + *argp = tail = NULL; + old_loc = *gfc_current_locus (); + + seen_keyword = 0; + + if (gfc_match_char ('(') == MATCH_NO) + return (sub_flag) ? MATCH_YES : MATCH_NO; + + if (gfc_match_char (')') == MATCH_YES) + return MATCH_YES; + head = NULL; + + for (;;) + { + if (head == NULL) + head = tail = gfc_get_actual_arglist (); + else + { + tail->next = gfc_get_actual_arglist (); + tail = tail->next; + } + + if (sub_flag && gfc_match_char ('*') == MATCH_YES) + { + m = gfc_match_st_label (&label, 0); + if (m == MATCH_NO) + gfc_error ("Expected alternate return label at %C"); + if (m != MATCH_YES) + goto cleanup; + + tail->label = label; + goto next; + } + + /* After the first keyword argument is seen, the following + arguments must also have keywords. */ + if (seen_keyword) + { + m = match_keyword_arg (tail, head); + + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + gfc_error + ("Missing keyword name in actual argument list at %C"); + goto cleanup; + } + + } + else + { + /* See if we have the first keyword argument. */ + m = match_keyword_arg (tail, head); + if (m == MATCH_YES) + seen_keyword = 1; + if (m == MATCH_ERROR) + goto cleanup; + + if (m == MATCH_NO) + { + /* Try for a non-keyword argument. */ + m = match_actual_arg (&tail->expr); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } + } + + next: + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + *argp = head; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in argument list at %C"); + +cleanup: + gfc_free_actual_arglist (head); + gfc_set_locus (&old_loc); + + return MATCH_ERROR; +} + + +/* Used by match_varspec() to extend the reference list by one + element. */ + +static gfc_ref * +extend_ref (gfc_expr * primary, gfc_ref * tail) +{ + + if (primary->ref == NULL) + primary->ref = tail = gfc_get_ref (); + else + { + if (tail == NULL) + gfc_internal_error ("extend_ref(): Bad tail"); + tail->next = gfc_get_ref (); + tail = tail->next; + } + + return tail; +} + + +/* Match any additional specifications associated with the current + variable like member references or substrings. If equiv_flag is + set we only match stuff that is allowed inside an EQUIVALENCE + statement. */ + +static match +match_varspec (gfc_expr * primary, int equiv_flag) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_ref *substring, *tail; + gfc_component *component; + gfc_symbol *sym; + match m; + + tail = NULL; + + if (primary->symtree->n.sym->attr.dimension + || (equiv_flag + && gfc_peek_char () == '(')) + { + + tail = extend_ref (primary, tail); + tail->type = REF_ARRAY; + + m = gfc_match_array_ref (&tail->u.ar, primary->symtree->n.sym->as, + equiv_flag); + if (m != MATCH_YES) + return m; + } + + sym = primary->symtree->n.sym; + primary->ts = sym->ts; + + if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES) + goto check_substring; + + sym = sym->ts.derived; + + for (;;) + { + m = gfc_match_name (name); + if (m == MATCH_NO) + gfc_error ("Expected structure component name at %C"); + if (m != MATCH_YES) + return MATCH_ERROR; + + component = gfc_find_component (sym, name); + if (component == NULL) + return MATCH_ERROR; + + tail = extend_ref (primary, tail); + tail->type = REF_COMPONENT; + + tail->u.c.component = component; + tail->u.c.sym = sym; + + primary->ts = component->ts; + + if (component->as != NULL) + { + tail = extend_ref (primary, tail); + tail->type = REF_ARRAY; + + m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag); + if (m != MATCH_YES) + return m; + } + + if (component->ts.type != BT_DERIVED + || gfc_match_char ('%') != MATCH_YES) + break; + + sym = component->ts.derived; + } + +check_substring: + if (primary->ts.type == BT_CHARACTER) + { + switch (match_substring (primary->ts.cl, equiv_flag, &substring)) + { + case MATCH_YES: + if (tail == NULL) + primary->ref = substring; + else + tail->next = substring; + + if (primary->expr_type == EXPR_CONSTANT) + primary->expr_type = EXPR_SUBSTRING; + + break; + + case MATCH_NO: + break; + + case MATCH_ERROR: + return MATCH_ERROR; + } + } + + return MATCH_YES; +} + + +/* Given an expression that is a variable, figure out what the + ultimate variable's type and attribute is, traversing the reference + structures if necessary. + + This subroutine is trickier than it looks. We start at the base + symbol and store the attribute. Component references load a + completely new attribute. + + A couple of rules come into play. Subobjects of targets are always + targets themselves. If we see a component that goes through a + pointer, then the expression must also be a target, since the + pointer is associated with something (if it isn't core will soon be + dumped). If we see a full part or section of an array, the + expression is also an array. + + We can have at most one full array reference. */ + +symbol_attribute +gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts) +{ + int dimension, pointer, target; + symbol_attribute attr; + gfc_ref *ref; + + if (expr->expr_type != EXPR_VARIABLE) + gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable"); + + ref = expr->ref; + attr = expr->symtree->n.sym->attr; + + dimension = attr.dimension; + pointer = attr.pointer; + + target = attr.target; + if (pointer) + target = 1; + + if (ts != NULL && expr->ts.type == BT_UNKNOWN) + *ts = expr->symtree->n.sym->ts; + + for (; ref; ref = ref->next) + switch (ref->type) + { + case REF_ARRAY: + + switch (ref->u.ar.type) + { + case AR_FULL: + dimension = 1; + break; + + case AR_SECTION: + pointer = 0; + dimension = 1; + break; + + case AR_ELEMENT: + pointer = 0; + break; + + case AR_UNKNOWN: + gfc_internal_error ("gfc_variable_attr(): Bad array reference"); + } + + break; + + case REF_COMPONENT: + gfc_get_component_attr (&attr, ref->u.c.component); + if (ts != NULL) + *ts = ref->u.c.component->ts; + + pointer = ref->u.c.component->pointer; + if (pointer) + target = 1; + + break; + + case REF_SUBSTRING: + pointer = 0; + break; + } + + attr.dimension = dimension; + attr.pointer = pointer; + attr.target = target; + + return attr; +} + + +/* Return the attribute from a general expression. */ + +symbol_attribute +gfc_expr_attr (gfc_expr * e) +{ + symbol_attribute attr; + + switch (e->expr_type) + { + case EXPR_VARIABLE: + attr = gfc_variable_attr (e, NULL); + break; + + case EXPR_FUNCTION: + gfc_clear_attr (&attr); + + if (e->value.function.esym != NULL) + attr = e->value.function.esym->result->attr; + + /* TODO: NULL() returns pointers. May have to take care of this + here. */ + + break; + + default: + gfc_clear_attr (&attr); + break; + } + + return attr; +} + + +/* Match a structure constructor. The initial symbol has already been + seen. */ + +static match +match_structure_constructor (gfc_symbol * sym, gfc_expr ** result) +{ + gfc_constructor *head, *tail; + gfc_component *comp; + gfc_expr *e; + locus where; + match m; + + head = tail = NULL; + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + where = *gfc_current_locus (); + + gfc_find_component (sym, NULL); + + for (comp = sym->components; comp; comp = comp->next) + { + if (head == NULL) + tail = head = gfc_get_constructor (); + else + { + tail->next = gfc_get_constructor (); + tail = tail->next; + } + + m = gfc_match_expr (&tail->expr); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + { + if (comp->next == NULL) + { + gfc_error + ("Too many components in structure constructor at %C"); + goto cleanup; + } + + continue; + } + + break; + } + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + if (comp->next != NULL) + { + gfc_error ("Too few components in structure constructor at %C"); + goto cleanup; + } + + e = gfc_get_expr (); + + e->expr_type = EXPR_STRUCTURE; + + e->ts.type = BT_DERIVED; + e->ts.derived = sym; + e->where = where; + + e->value.constructor = head; + + *result = e; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in structure constructor at %C"); + +cleanup: + gfc_free_constructor (head); + return MATCH_ERROR; +} + + +/* Matches a variable name followed by anything that might follow it-- + array reference, argument list of a function, etc. */ + +match +gfc_match_rvalue (gfc_expr ** result) +{ + gfc_actual_arglist *actual_arglist; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_state_data *st; + gfc_symbol *sym; + gfc_symtree *symtree; + locus where; + gfc_expr *e; + match m; + int i; + + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; + + if (gfc_find_state (COMP_INTERFACE) == SUCCESS) + i = gfc_get_sym_tree (name, NULL, &symtree); + else + i = gfc_get_ha_sym_tree (name, &symtree); + + if (i) + return MATCH_ERROR; + + sym = symtree->n.sym; + e = NULL; + where = *gfc_current_locus (); + + gfc_set_sym_referenced (sym); + + if (sym->attr.function && sym->result == sym + && (gfc_current_ns->proc_name == sym + || (gfc_current_ns->parent != NULL + && gfc_current_ns->parent->proc_name == sym))) + goto variable; + + if (sym->attr.function || sym->attr.external || sym->attr.intrinsic) + goto function0; + + if (sym->attr.generic) + goto generic_function; + + switch (sym->attr.flavor) + { + case FL_VARIABLE: + variable: + if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%' + && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED) + gfc_set_default_type (sym, 0, sym->ns); + + e = gfc_get_expr (); + + e->expr_type = EXPR_VARIABLE; + e->symtree = symtree; + + m = match_varspec (e, 0); + break; + + case FL_PARAMETER: + if (sym->value + && sym->value->expr_type != EXPR_ARRAY) + e = gfc_copy_expr (sym->value); + else + { + e = gfc_get_expr (); + e->expr_type = EXPR_VARIABLE; + } + + e->symtree = symtree; + m = match_varspec (e, 0); + break; + + case FL_DERIVED: + sym = gfc_use_derived (sym); + if (sym == NULL) + m = MATCH_ERROR; + else + m = match_structure_constructor (sym, &e); + break; + + /* If we're here, then the name is known to be the name of a + procedure, yet it is not sure to be the name of a function. */ + case FL_PROCEDURE: + if (sym->attr.subroutine) + { + gfc_error ("Unexpected use of subroutine name '%s' at %C", + sym->name); + m = MATCH_ERROR; + break; + } + + /* At this point, the name has to be a non-statement function. + If the name is the same as the current function being + compiled, then we have a variable reference (to the function + result) if the name is non-recursive. */ + + st = gfc_enclosing_unit (NULL); + + if (st != NULL && st->state == COMP_FUNCTION + && st->sym == sym + && !sym->attr.recursive) + { + e = gfc_get_expr (); + e->symtree = symtree; + e->expr_type = EXPR_VARIABLE; + + m = match_varspec (e, 0); + break; + } + + /* Match a function reference. */ + function0: + m = gfc_match_actual_arglist (0, &actual_arglist); + if (m == MATCH_NO) + { + if (sym->attr.proc == PROC_ST_FUNCTION) + gfc_error ("Statement function '%s' requires argument list at %C", + sym->name); + else + gfc_error ("Function '%s' requires an argument list at %C", + sym->name); + + m = MATCH_ERROR; + break; + } + + if (m != MATCH_YES) + { + m = MATCH_ERROR; + break; + } + + gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */ + sym = symtree->n.sym; + + e = gfc_get_expr (); + e->symtree = symtree; + e->expr_type = EXPR_FUNCTION; + e->value.function.actual = actual_arglist; + e->where = *gfc_current_locus (); + + if (sym->as != NULL) + e->rank = sym->as->rank; + + if (!sym->attr.function + && gfc_add_function (&sym->attr, NULL) == FAILURE) + { + m = MATCH_ERROR; + break; + } + + if (sym->result == NULL) + sym->result = sym; + + m = MATCH_YES; + break; + + case FL_UNKNOWN: + + /* Special case for derived type variables that get their types + via an IMPLICIT statement. This can't wait for the + resolution phase. */ + + if (gfc_peek_char () == '%' + && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED) + gfc_set_default_type (sym, 0, sym->ns); + + /* If the symbol has a dimension attribute, the expression is a + variable. */ + + if (sym->attr.dimension) + { + if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE) + { + m = MATCH_ERROR; + break; + } + + e = gfc_get_expr (); + e->symtree = symtree; + e->expr_type = EXPR_VARIABLE; + m = match_varspec (e, 0); + break; + } + + /* Name is not an array, so we peek to see if a '(' implies a + function call or a substring reference. Otherwise the + variable is just a scalar. */ + + gfc_gobble_whitespace (); + if (gfc_peek_char () != '(') + { + /* Assume a scalar variable */ + e = gfc_get_expr (); + e->symtree = symtree; + e->expr_type = EXPR_VARIABLE; + + if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE) + { + m = MATCH_ERROR; + break; + } + + e->ts = sym->ts; + m = match_varspec (e, 0); + break; + } + + /* See if this could possibly be a substring reference of a name + that we're not sure is a variable yet. */ + + e = gfc_get_expr (); + e->symtree = symtree; + + if ((sym->ts.type == BT_UNKNOWN || sym->ts.type == BT_CHARACTER) + && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES) + { + + e->expr_type = EXPR_VARIABLE; + + if (sym->attr.flavor != FL_VARIABLE + && gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE) + { + m = MATCH_ERROR; + break; + } + + if (sym->ts.type == BT_UNKNOWN + && gfc_set_default_type (sym, 1, NULL) == FAILURE) + { + m = MATCH_ERROR; + break; + } + + e->ts = sym->ts; + m = MATCH_YES; + break; + } + + /* Give up, assume we have a function. */ + + gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */ + sym = symtree->n.sym; + e->expr_type = EXPR_FUNCTION; + + if (!sym->attr.function + && gfc_add_function (&sym->attr, NULL) == FAILURE) + { + m = MATCH_ERROR; + break; + } + + sym->result = sym; + + m = gfc_match_actual_arglist (0, &e->value.function.actual); + if (m == MATCH_NO) + gfc_error ("Missing argument list in function '%s' at %C", sym->name); + + if (m != MATCH_YES) + { + m = MATCH_ERROR; + break; + } + + /* If our new function returns a character, array or structure + type, it might have subsequent references. */ + + m = match_varspec (e, 0); + if (m == MATCH_NO) + m = MATCH_YES; + + break; + + generic_function: + gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */ + + e = gfc_get_expr (); + e->symtree = symtree; + e->expr_type = EXPR_FUNCTION; + + m = gfc_match_actual_arglist (0, &e->value.function.actual); + break; + + default: + gfc_error ("Symbol at %C is not appropriate for an expression"); + return MATCH_ERROR; + } + + if (m == MATCH_YES) + { + e->where = where; + *result = e; + } + else + gfc_free_expr (e); + + return m; +} + + +/* Match a variable, ie something that can be assigned to. This + starts as a symbol, can be a structure component or an array + reference. It can be a function if the function doesn't have a + separate RESULT variable. If the symbol has not been previously + seen, we assume it is a variable. */ + +match +gfc_match_variable (gfc_expr ** result, int equiv_flag) +{ + gfc_symbol *sym; + gfc_symtree *st; + gfc_expr *expr; + locus where; + match m; + + m = gfc_match_sym_tree (&st, 1); + if (m != MATCH_YES) + return m; + where = *gfc_current_locus (); + + sym = st->n.sym; + gfc_set_sym_referenced (sym); + switch (sym->attr.flavor) + { + case FL_VARIABLE: + break; + + case FL_UNKNOWN: + if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE) + return MATCH_ERROR; + + /* Special case for derived type variables that get their types + via an IMPLICIT statement. This can't wait for the + resolution phase. */ + + if (gfc_peek_char () == '%' + && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED) + gfc_set_default_type (sym, 0, sym->ns); + + break; + + case FL_PROCEDURE: + /* Check for a nonrecursive function result */ + if (sym->attr.function && (sym->result == sym || sym->attr.entry)) + { + + /* If a function result is a derived type, then the derived + type may still have to be resolved. */ + + if (sym->ts.type == BT_DERIVED + && gfc_use_derived (sym->ts.derived) == NULL) + return MATCH_ERROR; + + break; + } + + /* Fall through to error */ + + default: + gfc_error ("Expected VARIABLE at %C"); + return MATCH_ERROR; + } + + expr = gfc_get_expr (); + + expr->expr_type = EXPR_VARIABLE; + expr->symtree = st; + expr->ts = sym->ts; + expr->where = where; + + /* Now see if we have to do more. */ + m = match_varspec (expr, equiv_flag); + if (m != MATCH_YES) + { + gfc_free_expr (expr); + return m; + } + + *result = expr; + return MATCH_YES; +} diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c new file mode 100644 index 00000000000..cec47165c02 --- /dev/null +++ b/gcc/fortran/resolve.c @@ -0,0 +1,4435 @@ +/* Perform type resolution on the various stuctures. + Copyright (C) 2001, 2002, 2003 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include "config.h" +#include "gfortran.h" +#include "arith.h" /* For gfc_compare_expr(). */ +#include <assert.h> +#include <string.h> + +/* Stack to push the current if we descend into a block during + resolution. See resolve_branch() and resolve_code(). */ + +typedef struct code_stack +{ + struct gfc_code *head, *current; + struct code_stack *prev; +} +code_stack; + +static code_stack *cs_base = NULL; + + +/* Nonzero if we're inside a FORALL block */ + +static int forall_flag; + +/* Resolve types of formal argument lists. These have to be done early so that + the formal argument lists of module procedures can be copied to the + containing module before the individual procedures are resolved + individually. We also resolve argument lists of procedures in interface + blocks because they are self-contained scoping units. + + Since a dummy argument cannot be a non-dummy procedure, the only + resort left for untyped names are the IMPLICIT types. */ + +static void +resolve_formal_arglist (gfc_symbol * proc) +{ + gfc_formal_arglist *f; + gfc_symbol *sym; + int i; + + /* TODO: Procedures whose return character length parameter is not constant + or assumed must also have explicit interfaces. */ + if (proc->result != NULL) + sym = proc->result; + else + sym = proc; + + if (gfc_elemental (proc) + || sym->attr.pointer || sym->attr.allocatable + || (sym->as && sym->as->rank > 0)) + proc->attr.always_explicit = 1; + + for (f = proc->formal; f; f = f->next) + { + sym = f->sym; + + if (sym == NULL) + { + /* Alternate return placeholder. */ + if (gfc_elemental (proc)) + gfc_error ("Alternate return specifier in elemental subroutine " + "'%s' at %L is not allowed", proc->name, + &proc->declared_at); + if (proc->attr.function) + gfc_error ("Alternate return specifier in function " + "'%s' at %L is not allowed", proc->name, + &proc->declared_at); + continue; + } + + if (sym->attr.if_source != IFSRC_UNKNOWN) + resolve_formal_arglist (sym); + + if (sym->attr.subroutine || sym->attr.external || sym->attr.intrinsic) + { + if (gfc_pure (proc) && !gfc_pure (sym)) + { + gfc_error + ("Dummy procedure '%s' of PURE procedure at %L must also " + "be PURE", sym->name, &sym->declared_at); + continue; + } + + if (gfc_elemental (proc)) + { + gfc_error + ("Dummy procedure at %L not allowed in ELEMENTAL procedure", + &sym->declared_at); + continue; + } + + continue; + } + + if (sym->ts.type == BT_UNKNOWN) + { + if (!sym->attr.function || sym->result == sym) + gfc_set_default_type (sym, 1, sym->ns); + else + { + /* Set the type of the RESULT, then copy. */ + if (sym->result->ts.type == BT_UNKNOWN) + gfc_set_default_type (sym->result, 1, sym->result->ns); + + sym->ts = sym->result->ts; + if (sym->as == NULL) + sym->as = gfc_copy_array_spec (sym->result->as); + } + } + + gfc_resolve_array_spec (sym->as, 0); + + /* We can't tell if an array with dimension (:) is assumed or deferred + shape until we know if it has the pointer or allocatable attributes. + */ + if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED + && !(sym->attr.pointer || sym->attr.allocatable)) + { + sym->as->type = AS_ASSUMED_SHAPE; + for (i = 0; i < sym->as->rank; i++) + sym->as->lower[i] = gfc_int_expr (1); + } + + if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE) + || sym->attr.pointer || sym->attr.allocatable || sym->attr.target + || sym->attr.optional) + proc->attr.always_explicit = 1; + + /* If the flavor is unknown at this point, it has to be a variable. + A procedure specification would have already set the type. */ + + if (sym->attr.flavor == FL_UNKNOWN) + gfc_add_flavor (&sym->attr, FL_VARIABLE, &sym->declared_at); + + if (gfc_pure (proc)) + { + if (proc->attr.function && !sym->attr.pointer + && sym->attr.flavor != FL_PROCEDURE + && sym->attr.intent != INTENT_IN) + + gfc_error ("Argument '%s' of pure function '%s' at %L must be " + "INTENT(IN)", sym->name, proc->name, + &sym->declared_at); + + if (proc->attr.subroutine && !sym->attr.pointer + && sym->attr.intent == INTENT_UNKNOWN) + + gfc_error + ("Argument '%s' of pure subroutine '%s' at %L must have " + "its INTENT specified", sym->name, proc->name, + &sym->declared_at); + } + + + if (gfc_elemental (proc)) + { + if (sym->as != NULL) + { + gfc_error + ("Argument '%s' of elemental procedure at %L must be scalar", + sym->name, &sym->declared_at); + continue; + } + + if (sym->attr.pointer) + { + gfc_error + ("Argument '%s' of elemental procedure at %L cannot have " + "the POINTER attribute", sym->name, &sym->declared_at); + continue; + } + } + + /* Each dummy shall be specified to be scalar. */ + if (proc->attr.proc == PROC_ST_FUNCTION) + { + if (sym->as != NULL) + { + gfc_error + ("Argument '%s' of statement function at %L must be scalar", + sym->name, &sym->declared_at); + continue; + } + + if (sym->ts.type == BT_CHARACTER) + { + gfc_charlen *cl = sym->ts.cl; + if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) + { + gfc_error + ("Character-valued argument '%s' of statement function at " + "%L must has constant length", + sym->name, &sym->declared_at); + continue; + } + } + } + } +} + + +/* Work function called when searching for symbols that have argument lists + associated with them. */ + +static void +find_arglists (gfc_symbol * sym) +{ + + if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns) + return; + + resolve_formal_arglist (sym); +} + + +/* Given a namespace, resolve all formal argument lists within the namespace. + */ + +static void +resolve_formal_arglists (gfc_namespace * ns) +{ + + if (ns == NULL) + return; + + gfc_traverse_ns (ns, find_arglists); +} + + +/* Resolve contained function types. Because contained functions can call one + another, they have to be worked out before any of the contained procedures + can be resolved. + + The good news is that if a function doesn't already have a type, the only + way it can get one is through an IMPLICIT type or a RESULT variable, because + by definition contained functions are contained namespace they're contained + in, not in a sibling or parent namespace. */ + +static void +resolve_contained_functions (gfc_namespace * ns) +{ + gfc_symbol *contained_sym, *sym_lower; + gfc_namespace *child; + try t; + + resolve_formal_arglists (ns); + + for (child = ns->contained; child; child = child->sibling) + { + sym_lower = child->proc_name; + + /* If this namespace is not a function, ignore it. */ + if (! sym_lower + || !( sym_lower->attr.function + || sym_lower->attr.flavor == FL_VARIABLE)) + continue; + + /* Find the contained symbol in the current namespace. */ + gfc_find_symbol (sym_lower->name, ns, 0, &contained_sym); + + if (contained_sym == NULL) + gfc_internal_error ("resolve_contained_functions(): Contained " + "function not found in parent namespace"); + + /* Try to find out of what type the function is. If there was an + explicit RESULT clause, try to get the type from it. If the + function is never defined, set it to the implicit type. If + even that fails, give up. */ + if (sym_lower->result != NULL) + sym_lower = sym_lower->result; + + if (sym_lower->ts.type == BT_UNKNOWN) + { + /* Assume we can find an implicit type. */ + t = SUCCESS; + + if (sym_lower->result == NULL) + t = gfc_set_default_type (sym_lower, 0, child); + else + { + if (sym_lower->result->ts.type == BT_UNKNOWN) + t = gfc_set_default_type (sym_lower->result, 0, NULL); + + sym_lower->ts = sym_lower->result->ts; + } + + if (t == FAILURE) + gfc_error ("Contained function '%s' at %L has no IMPLICIT type", + sym_lower->name, &sym_lower->declared_at); /* FIXME */ + } + + /* If the symbol in the parent of the contained namespace is not + the same as the one in contained namespace itself, copy over + the type information. */ + /* ??? Shouldn't we replace the symbol with the parent symbol instead? */ + if (contained_sym != sym_lower) + { + contained_sym->ts = sym_lower->ts; + contained_sym->as = gfc_copy_array_spec (sym_lower->as); + } + } +} + + +/* Resolve all of the elements of a structure constructor and make sure that + the types are correct. */ + +static try +resolve_structure_cons (gfc_expr * expr) +{ + gfc_constructor *cons; + gfc_component *comp; + try t; + + t = SUCCESS; + cons = expr->value.constructor; + /* A constructor may have references if it is the result of substituting a + parameter variable. In this case we just pull out the component we + want. */ + if (expr->ref) + comp = expr->ref->u.c.sym->components; + else + comp = expr->ts.derived->components; + + for (; comp; comp = comp->next, cons = cons->next) + { + if (! cons->expr) + { + t = FAILURE; + continue; + } + + if (gfc_resolve_expr (cons->expr) == FAILURE) + { + t = FAILURE; + continue; + } + + /* If we don't have the right type, try to convert it. */ + + if (!gfc_compare_types (&cons->expr->ts, &comp->ts) + && gfc_convert_type (cons->expr, &comp->ts, 1) == FAILURE) + t = FAILURE; + } + + return t; +} + + + +/****************** Expression name resolution ******************/ + +/* Returns 0 if a symbol was not declared with a type or + or attribute declaration statement, nonzero otherwise. */ + +static int +was_declared (gfc_symbol * sym) +{ + symbol_attribute a; + + a = sym->attr; + + if (!a.implicit_type && sym->ts.type != BT_UNKNOWN) + return 1; + + if (a.allocatable || a.dimension || a.external || a.intrinsic + || a.optional || a.pointer || a.save || a.target + || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN) + return 1; + + return 0; +} + + +/* Determine if a symbol is generic or not. */ + +static int +generic_sym (gfc_symbol * sym) +{ + gfc_symbol *s; + + if (sym->attr.generic || + (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name))) + return 1; + + if (was_declared (sym) || sym->ns->parent == NULL) + return 0; + + gfc_find_symbol (sym->name, sym->ns->parent, 1, &s); + + return (s == NULL) ? 0 : generic_sym (s); +} + + +/* Determine if a symbol is specific or not. */ + +static int +specific_sym (gfc_symbol * sym) +{ + gfc_symbol *s; + + if (sym->attr.if_source == IFSRC_IFBODY + || sym->attr.proc == PROC_MODULE + || sym->attr.proc == PROC_INTERNAL + || sym->attr.proc == PROC_ST_FUNCTION + || (sym->attr.intrinsic && + gfc_specific_intrinsic (sym->name)) + || sym->attr.external) + return 1; + + if (was_declared (sym) || sym->ns->parent == NULL) + return 0; + + gfc_find_symbol (sym->name, sym->ns->parent, 1, &s); + + return (s == NULL) ? 0 : specific_sym (s); +} + + +/* Figure out if the procedure is specific, generic or unknown. */ + +typedef enum +{ PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN } +proc_type; + +static proc_type +procedure_kind (gfc_symbol * sym) +{ + + if (generic_sym (sym)) + return PTYPE_GENERIC; + + if (specific_sym (sym)) + return PTYPE_SPECIFIC; + + return PTYPE_UNKNOWN; +} + + +/* Resolve an actual argument list. Most of the time, this is just + resolving the expressions in the list. + The exception is that we sometimes have to decide whether arguments + that look like procedure arguments are really simple variable + references. */ + +static try +resolve_actual_arglist (gfc_actual_arglist * arg) +{ + gfc_symbol *sym; + gfc_symtree *parent_st; + gfc_expr *e; + + for (; arg; arg = arg->next) + { + + e = arg->expr; + if (e == NULL) + { + /* Check the label is a valid branching target. */ + if (arg->label) + { + if (arg->label->defined == ST_LABEL_UNKNOWN) + { + gfc_error ("Label %d referenced at %L is never defined", + arg->label->value, &arg->label->where); + return FAILURE; + } + } + continue; + } + + if (e->ts.type != BT_PROCEDURE) + { + if (gfc_resolve_expr (e) != SUCCESS) + return FAILURE; + continue; + } + + /* See if the expression node should really be a variable + reference. */ + + sym = e->symtree->n.sym; + + if (sym->attr.flavor == FL_PROCEDURE + || sym->attr.intrinsic + || sym->attr.external) + { + + /* If the symbol is the function that names the current (or + parent) scope, then we really have a variable reference. */ + + if (sym->attr.function && sym->result == sym + && (sym->ns->proc_name == sym + || (sym->ns->parent != NULL + && sym->ns->parent->proc_name == sym))) + goto got_variable; + + continue; + } + + /* See if the name is a module procedure in a parent unit. */ + + if (was_declared (sym) || sym->ns->parent == NULL) + goto got_variable; + + if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st)) + { + gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where); + return FAILURE; + } + + if (parent_st == NULL) + goto got_variable; + + sym = parent_st->n.sym; + e->symtree = parent_st; /* Point to the right thing. */ + + if (sym->attr.flavor == FL_PROCEDURE + || sym->attr.intrinsic + || sym->attr.external) + { + continue; + } + + got_variable: + e->expr_type = EXPR_VARIABLE; + e->ts = sym->ts; + if (sym->as != NULL) + { + e->rank = sym->as->rank; + e->ref = gfc_get_ref (); + e->ref->type = REF_ARRAY; + e->ref->u.ar.type = AR_FULL; + e->ref->u.ar.as = sym->as; + } + } + + return SUCCESS; +} + + +/************* Function resolution *************/ + +/* Resolve a function call known to be generic. + Section 14.1.2.4.1. */ + +static match +resolve_generic_f0 (gfc_expr * expr, gfc_symbol * sym) +{ + gfc_symbol *s; + + if (sym->attr.generic) + { + s = + gfc_search_interface (sym->generic, 0, &expr->value.function.actual); + if (s != NULL) + { + expr->value.function.name = s->name; + expr->value.function.esym = s; + expr->ts = s->ts; + if (s->as != NULL) + expr->rank = s->as->rank; + return MATCH_YES; + } + + /* TODO: Need to search for elemental references in generic interface */ + } + + if (sym->attr.intrinsic) + return gfc_intrinsic_func_interface (expr, 0); + + return MATCH_NO; +} + + +static try +resolve_generic_f (gfc_expr * expr) +{ + gfc_symbol *sym; + match m; + + sym = expr->symtree->n.sym; + + for (;;) + { + m = resolve_generic_f0 (expr, sym); + if (m == MATCH_YES) + return SUCCESS; + else if (m == MATCH_ERROR) + return FAILURE; + +generic: + if (sym->ns->parent == NULL) + break; + gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); + + if (sym == NULL) + break; + if (!generic_sym (sym)) + goto generic; + } + + /* Last ditch attempt. */ + + if (!gfc_generic_intrinsic (expr->symtree->n.sym->name)) + { + gfc_error ("Generic function '%s' at %L is not an intrinsic function", + expr->symtree->n.sym->name, &expr->where); + return FAILURE; + } + + m = gfc_intrinsic_func_interface (expr, 0); + if (m == MATCH_YES) + return SUCCESS; + if (m == MATCH_NO) + gfc_error + ("Generic function '%s' at %L is not consistent with a specific " + "intrinsic interface", expr->symtree->n.sym->name, &expr->where); + + return FAILURE; +} + + +/* Resolve a function call known to be specific. */ + +static match +resolve_specific_f0 (gfc_symbol * sym, gfc_expr * expr) +{ + match m; + + if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY) + { + if (sym->attr.dummy) + { + sym->attr.proc = PROC_DUMMY; + goto found; + } + + sym->attr.proc = PROC_EXTERNAL; + goto found; + } + + if (sym->attr.proc == PROC_MODULE + || sym->attr.proc == PROC_ST_FUNCTION + || sym->attr.proc == PROC_INTERNAL) + goto found; + + if (sym->attr.intrinsic) + { + m = gfc_intrinsic_func_interface (expr, 1); + if (m == MATCH_YES) + return MATCH_YES; + if (m == MATCH_NO) + gfc_error + ("Function '%s' at %L is INTRINSIC but is not compatible with " + "an intrinsic", sym->name, &expr->where); + + return MATCH_ERROR; + } + + return MATCH_NO; + +found: + gfc_procedure_use (sym, &expr->value.function.actual, &expr->where); + + expr->ts = sym->ts; + expr->value.function.name = sym->name; + expr->value.function.esym = sym; + if (sym->as != NULL) + expr->rank = sym->as->rank; + + return MATCH_YES; +} + + +static try +resolve_specific_f (gfc_expr * expr) +{ + gfc_symbol *sym; + match m; + + sym = expr->symtree->n.sym; + + for (;;) + { + m = resolve_specific_f0 (sym, expr); + if (m == MATCH_YES) + return SUCCESS; + if (m == MATCH_ERROR) + return FAILURE; + + if (sym->ns->parent == NULL) + break; + + gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); + + if (sym == NULL) + break; + } + + gfc_error ("Unable to resolve the specific function '%s' at %L", + expr->symtree->n.sym->name, &expr->where); + + return SUCCESS; +} + + +/* Resolve a procedure call not known to be generic nor specific. */ + +static try +resolve_unknown_f (gfc_expr * expr) +{ + gfc_symbol *sym; + gfc_typespec *ts; + + sym = expr->symtree->n.sym; + + if (sym->attr.dummy) + { + sym->attr.proc = PROC_DUMMY; + expr->value.function.name = sym->name; + goto set_type; + } + + /* See if we have an intrinsic function reference. */ + + if (gfc_intrinsic_name (sym->name, 0)) + { + if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES) + return SUCCESS; + return FAILURE; + } + + /* The reference is to an external name. */ + + sym->attr.proc = PROC_EXTERNAL; + expr->value.function.name = sym->name; + expr->value.function.esym = expr->symtree->n.sym; + + if (sym->as != NULL) + expr->rank = sym->as->rank; + + /* Type of the expression is either the type of the symbol or the + default type of the symbol. */ + +set_type: + gfc_procedure_use (sym, &expr->value.function.actual, &expr->where); + + if (sym->ts.type != BT_UNKNOWN) + expr->ts = sym->ts; + else + { + ts = gfc_get_default_type (sym, sym->ns); + + if (ts->type == BT_UNKNOWN) + { + gfc_error ("Function '%s' at %L has no implicit type", + sym->name, &expr->where); + return FAILURE; + } + else + expr->ts = *ts; + } + + return SUCCESS; +} + + +/* Figure out if if a function reference is pure or not. Also sets the name + of the function for a potential error message. Returns nonzero if the + function is PURE, zero if not. */ + +static int +pure_function (gfc_expr * e, char **name) +{ + int pure; + + if (e->value.function.esym) + { + pure = gfc_pure (e->value.function.esym); + *name = e->value.function.esym->name; + } + else if (e->value.function.isym) + { + pure = e->value.function.isym->pure + || e->value.function.isym->elemental; + *name = e->value.function.isym->name; + } + else + { + /* Implicit functions are not pure. */ + pure = 0; + *name = e->value.function.name; + } + + return pure; +} + + +/* Resolve a function call, which means resolving the arguments, then figuring + out which entity the name refers to. */ +/* TODO: Check procedure arguments so that an INTENT(IN) isn't passed + to INTENT(OUT) or INTENT(INOUT). */ + +static try +resolve_function (gfc_expr * expr) +{ + gfc_actual_arglist *arg; + char *name; + try t; + + if (resolve_actual_arglist (expr->value.function.actual) == FAILURE) + return FAILURE; + +/* See if function is already resolved. */ + + if (expr->value.function.name != NULL) + { + if (expr->ts.type == BT_UNKNOWN) + expr->ts = expr->symtree->n.sym->ts; + t = SUCCESS; + } + else + { + /* Apply the rules of section 14.1.2. */ + + switch (procedure_kind (expr->symtree->n.sym)) + { + case PTYPE_GENERIC: + t = resolve_generic_f (expr); + break; + + case PTYPE_SPECIFIC: + t = resolve_specific_f (expr); + break; + + case PTYPE_UNKNOWN: + t = resolve_unknown_f (expr); + break; + + default: + gfc_internal_error ("resolve_function(): bad function type"); + } + } + + /* If the expression is still a function (it might have simplified), + then we check to see if we are calling an elemental function. */ + + if (expr->expr_type != EXPR_FUNCTION) + return t; + + if (expr->value.function.actual != NULL + && ((expr->value.function.esym != NULL + && expr->value.function.esym->attr.elemental) + || (expr->value.function.isym != NULL + && expr->value.function.isym->elemental))) + { + + /* The rank of an elemental is the rank of its array argument(s). */ + + for (arg = expr->value.function.actual; arg; arg = arg->next) + { + if (arg->expr != NULL && arg->expr->rank > 0) + { + expr->rank = arg->expr->rank; + break; + } + } + } + + if (!pure_function (expr, &name)) + { + if (forall_flag) + { + gfc_error + ("Function reference to '%s' at %L is inside a FORALL block", + name, &expr->where); + t = FAILURE; + } + else if (gfc_pure (NULL)) + { + gfc_error ("Function reference to '%s' at %L is to a non-PURE " + "procedure within a PURE procedure", name, &expr->where); + t = FAILURE; + } + } + + return t; +} + + +/************* Subroutine resolution *************/ + +static void +pure_subroutine (gfc_code * c, gfc_symbol * sym) +{ + + if (gfc_pure (sym)) + return; + + if (forall_flag) + gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE", + sym->name, &c->loc); + else if (gfc_pure (NULL)) + gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name, + &c->loc); +} + + +static match +resolve_generic_s0 (gfc_code * c, gfc_symbol * sym) +{ + gfc_symbol *s; + + if (sym->attr.generic) + { + s = gfc_search_interface (sym->generic, 1, &c->ext.actual); + if (s != NULL) + { + c->resolved_sym = s; + pure_subroutine (c, s); + return MATCH_YES; + } + + /* TODO: Need to search for elemental references in generic interface. */ + } + + if (sym->attr.intrinsic) + return gfc_intrinsic_sub_interface (c, 0); + + return MATCH_NO; +} + + +static try +resolve_generic_s (gfc_code * c) +{ + gfc_symbol *sym; + match m; + + sym = c->symtree->n.sym; + + m = resolve_generic_s0 (c, sym); + if (m == MATCH_YES) + return SUCCESS; + if (m == MATCH_ERROR) + return FAILURE; + + if (sym->ns->parent != NULL) + { + gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); + if (sym != NULL) + { + m = resolve_generic_s0 (c, sym); + if (m == MATCH_YES) + return SUCCESS; + if (m == MATCH_ERROR) + return FAILURE; + } + } + + /* Last ditch attempt. */ + + if (!gfc_generic_intrinsic (sym->name)) + { + gfc_error + ("Generic subroutine '%s' at %L is not an intrinsic subroutine", + sym->name, &c->loc); + return FAILURE; + } + + m = gfc_intrinsic_sub_interface (c, 0); + if (m == MATCH_YES) + return SUCCESS; + if (m == MATCH_NO) + gfc_error ("Generic subroutine '%s' at %L is not consistent with an " + "intrinsic subroutine interface", sym->name, &c->loc); + + return FAILURE; +} + + +/* Resolve a subroutine call known to be specific. */ + +static match +resolve_specific_s0 (gfc_code * c, gfc_symbol * sym) +{ + match m; + + if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY) + { + if (sym->attr.dummy) + { + sym->attr.proc = PROC_DUMMY; + goto found; + } + + sym->attr.proc = PROC_EXTERNAL; + goto found; + } + + if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL) + goto found; + + if (sym->attr.intrinsic) + { + m = gfc_intrinsic_sub_interface (c, 1); + if (m == MATCH_YES) + return MATCH_YES; + if (m == MATCH_NO) + gfc_error ("Subroutine '%s' at %L is INTRINSIC but is not compatible " + "with an intrinsic", sym->name, &c->loc); + + return MATCH_ERROR; + } + + return MATCH_NO; + +found: + gfc_procedure_use (sym, &c->ext.actual, &c->loc); + + c->resolved_sym = sym; + pure_subroutine (c, sym); + + return MATCH_YES; +} + + +static try +resolve_specific_s (gfc_code * c) +{ + gfc_symbol *sym; + match m; + + sym = c->symtree->n.sym; + + m = resolve_specific_s0 (c, sym); + if (m == MATCH_YES) + return SUCCESS; + if (m == MATCH_ERROR) + return FAILURE; + + gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); + + if (sym != NULL) + { + m = resolve_specific_s0 (c, sym); + if (m == MATCH_YES) + return SUCCESS; + if (m == MATCH_ERROR) + return FAILURE; + } + + gfc_error ("Unable to resolve the specific subroutine '%s' at %L", + sym->name, &c->loc); + + return FAILURE; +} + + +/* Resolve a subroutine call not known to be generic nor specific. */ + +static try +resolve_unknown_s (gfc_code * c) +{ + gfc_symbol *sym; + + sym = c->symtree->n.sym; + + if (sym->attr.dummy) + { + sym->attr.proc = PROC_DUMMY; + goto found; + } + + /* See if we have an intrinsic function reference. */ + + if (gfc_intrinsic_name (sym->name, 1)) + { + if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES) + return SUCCESS; + return FAILURE; + } + + /* The reference is to an external name. */ + +found: + gfc_procedure_use (sym, &c->ext.actual, &c->loc); + + c->resolved_sym = sym; + + pure_subroutine (c, sym); + + return SUCCESS; +} + + +/* Resolve a subroutine call. Although it was tempting to use the same code + for functions, subroutines and functions are stored differently and this + makes things awkward. */ + +static try +resolve_call (gfc_code * c) +{ + try t; + + if (resolve_actual_arglist (c->ext.actual) == FAILURE) + return FAILURE; + + if (c->resolved_sym != NULL) + return SUCCESS; + + switch (procedure_kind (c->symtree->n.sym)) + { + case PTYPE_GENERIC: + t = resolve_generic_s (c); + break; + + case PTYPE_SPECIFIC: + t = resolve_specific_s (c); + break; + + case PTYPE_UNKNOWN: + t = resolve_unknown_s (c); + break; + + default: + gfc_internal_error ("resolve_subroutine(): bad function type"); + } + + return t; +} + + +/* Resolve an operator expression node. This can involve replacing the + operation with a user defined function call. */ + +static try +resolve_operator (gfc_expr * e) +{ + gfc_expr *op1, *op2; + char msg[200]; + try t; + + /* Resolve all subnodes-- give them types. */ + + switch (e->operator) + { + default: + if (gfc_resolve_expr (e->op2) == FAILURE) + return FAILURE; + + /* Fall through... */ + + case INTRINSIC_NOT: + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + if (gfc_resolve_expr (e->op1) == FAILURE) + return FAILURE; + break; + } + + /* Typecheck the new node. */ + + op1 = e->op1; + op2 = e->op2; + + switch (e->operator) + { + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + if (op1->ts.type == BT_INTEGER + || op1->ts.type == BT_REAL + || op1->ts.type == BT_COMPLEX) + { + e->ts = op1->ts; + break; + } + + sprintf (msg, "Operand of unary numeric operator '%s' at %%L is %s", + gfc_op2string (e->operator), gfc_typename (&e->ts)); + goto bad_op; + + case INTRINSIC_PLUS: + case INTRINSIC_MINUS: + case INTRINSIC_TIMES: + case INTRINSIC_DIVIDE: + case INTRINSIC_POWER: + if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) + { + gfc_type_convert_binary (e); + break; + } + + sprintf (msg, + "Operands of binary numeric operator '%s' at %%L are %s/%s", + gfc_op2string (e->operator), gfc_typename (&op1->ts), + gfc_typename (&op2->ts)); + goto bad_op; + + case INTRINSIC_CONCAT: + if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER) + { + e->ts.type = BT_CHARACTER; + e->ts.kind = op1->ts.kind; + break; + } + + sprintf (msg, + "Operands of string concatenation operator at %%L are %s/%s", + gfc_typename (&op1->ts), gfc_typename (&op2->ts)); + goto bad_op; + + case INTRINSIC_AND: + case INTRINSIC_OR: + case INTRINSIC_EQV: + case INTRINSIC_NEQV: + if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL) + { + e->ts.type = BT_LOGICAL; + e->ts.kind = gfc_kind_max (op1, op2); + if (op1->ts.kind < e->ts.kind) + gfc_convert_type (op1, &e->ts, 2); + else if (op2->ts.kind < e->ts.kind) + gfc_convert_type (op2, &e->ts, 2); + break; + } + + sprintf (msg, "Operands of logical operator '%s' at %%L are %s/%s", + gfc_op2string (e->operator), gfc_typename (&op1->ts), + gfc_typename (&op2->ts)); + + goto bad_op; + + case INTRINSIC_NOT: + if (op1->ts.type == BT_LOGICAL) + { + e->ts.type = BT_LOGICAL; + e->ts.kind = op1->ts.kind; + break; + } + + sprintf (msg, "Operand of .NOT. operator at %%L is %s", + gfc_typename (&op1->ts)); + goto bad_op; + + case INTRINSIC_GT: + case INTRINSIC_GE: + case INTRINSIC_LT: + case INTRINSIC_LE: + if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX) + { + strcpy (msg, "COMPLEX quantities cannot be compared at %L"); + goto bad_op; + } + + /* Fall through... */ + + case INTRINSIC_EQ: + case INTRINSIC_NE: + if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER) + { + e->ts.type = BT_LOGICAL; + e->ts.kind = gfc_default_logical_kind (); + break; + } + + if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) + { + gfc_type_convert_binary (e); + + e->ts.type = BT_LOGICAL; + e->ts.kind = gfc_default_logical_kind (); + break; + } + + sprintf (msg, "Operands of comparison operator '%s' at %%L are %s/%s", + gfc_op2string (e->operator), gfc_typename (&op1->ts), + gfc_typename (&op2->ts)); + + goto bad_op; + + case INTRINSIC_USER: + if (op2 == NULL) + sprintf (msg, "Operand of user operator '%s' at %%L is %s", + e->uop->ns->proc_name->name, gfc_typename (&op1->ts)); + else + sprintf (msg, "Operands of user operator '%s' at %%L are %s/%s", + e->uop->ns->proc_name->name, gfc_typename (&op1->ts), + gfc_typename (&op2->ts)); + + goto bad_op; + + default: + gfc_internal_error ("resolve_operator(): Bad intrinsic"); + } + + /* Deal with arrayness of an operand through an operator. */ + + t = SUCCESS; + + switch (e->operator) + { + case INTRINSIC_PLUS: + case INTRINSIC_MINUS: + case INTRINSIC_TIMES: + case INTRINSIC_DIVIDE: + case INTRINSIC_POWER: + case INTRINSIC_CONCAT: + case INTRINSIC_AND: + case INTRINSIC_OR: + case INTRINSIC_EQV: + case INTRINSIC_NEQV: + case INTRINSIC_EQ: + case INTRINSIC_NE: + case INTRINSIC_GT: + case INTRINSIC_GE: + case INTRINSIC_LT: + case INTRINSIC_LE: + + if (op1->rank == 0 && op2->rank == 0) + e->rank = 0; + + if (op1->rank == 0 && op2->rank != 0) + { + e->rank = op2->rank; + + if (e->shape == NULL) + e->shape = gfc_copy_shape (op2->shape, op2->rank); + } + + if (op1->rank != 0 && op2->rank == 0) + { + e->rank = op1->rank; + + if (e->shape == NULL) + e->shape = gfc_copy_shape (op1->shape, op1->rank); + } + + if (op1->rank != 0 && op2->rank != 0) + { + if (op1->rank == op2->rank) + { + e->rank = op1->rank; + + if (e->shape == NULL) + e->shape = gfc_copy_shape (op1->shape, op1->rank); + + } + else + { + gfc_error ("Inconsistent ranks for operator at %L and %L", + &op1->where, &op2->where); + t = FAILURE; + + /* Allow higher level expressions to work. */ + e->rank = 0; + } + } + + break; + + case INTRINSIC_NOT: + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + e->rank = op1->rank; + + if (e->shape == NULL) + e->shape = gfc_copy_shape (op1->shape, op1->rank); + + /* Simply copy arrayness attribute */ + break; + + default: + break; + } + + /* Attempt to simplify the expression. */ + if (t == SUCCESS) + t = gfc_simplify_expr (e, 0); + return t; + +bad_op: + if (gfc_extend_expr (e) == SUCCESS) + return SUCCESS; + + gfc_error (msg, &e->where); + return FAILURE; +} + + +/************** Array resolution subroutines **************/ + + +typedef enum +{ CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN } +comparison; + +/* Compare two integer expressions. */ + +static comparison +compare_bound (gfc_expr * a, gfc_expr * b) +{ + int i; + + if (a == NULL || a->expr_type != EXPR_CONSTANT + || b == NULL || b->expr_type != EXPR_CONSTANT) + return CMP_UNKNOWN; + + if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER) + gfc_internal_error ("compare_bound(): Bad expression"); + + i = mpz_cmp (a->value.integer, b->value.integer); + + if (i < 0) + return CMP_LT; + if (i > 0) + return CMP_GT; + return CMP_EQ; +} + + +/* Compare an integer expression with an integer. */ + +static comparison +compare_bound_int (gfc_expr * a, int b) +{ + int i; + + if (a == NULL || a->expr_type != EXPR_CONSTANT) + return CMP_UNKNOWN; + + if (a->ts.type != BT_INTEGER) + gfc_internal_error ("compare_bound_int(): Bad expression"); + + i = mpz_cmp_si (a->value.integer, b); + + if (i < 0) + return CMP_LT; + if (i > 0) + return CMP_GT; + return CMP_EQ; +} + + +/* Compare a single dimension of an array reference to the array + specification. */ + +static try +check_dimension (int i, gfc_array_ref * ar, gfc_array_spec * as) +{ + +/* Given start, end and stride values, calculate the minimum and + maximum referenced indexes. */ + + switch (ar->type) + { + case AR_FULL: + break; + + case AR_ELEMENT: + if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT) + goto bound; + if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT) + goto bound; + + break; + + case AR_SECTION: + if (compare_bound_int (ar->stride[i], 0) == CMP_EQ) + { + gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]); + return FAILURE; + } + + if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT) + goto bound; + if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT) + goto bound; + + /* TODO: Possibly, we could warn about end[i] being out-of-bound although + it is legal (see 6.2.2.3.1). */ + + break; + + default: + gfc_internal_error ("check_dimension(): Bad array reference"); + } + + return SUCCESS; + +bound: + gfc_warning ("Array reference at %L is out of bounds", &ar->c_where[i]); + return SUCCESS; +} + + +/* Compare an array reference with an array specification. */ + +static try +compare_spec_to_ref (gfc_array_ref * ar) +{ + gfc_array_spec *as; + int i; + + as = ar->as; + i = as->rank - 1; + /* TODO: Full array sections are only allowed as actual parameters. */ + if (as->type == AS_ASSUMED_SIZE + && (/*ar->type == AR_FULL + ||*/ (ar->type == AR_SECTION + && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL))) + { + gfc_error ("Rightmost upper bound of assumed size array section" + " not specified at %L", &ar->where); + return FAILURE; + } + + if (ar->type == AR_FULL) + return SUCCESS; + + if (as->rank != ar->dimen) + { + gfc_error ("Rank mismatch in array reference at %L (%d/%d)", + &ar->where, ar->dimen, as->rank); + return FAILURE; + } + + for (i = 0; i < as->rank; i++) + if (check_dimension (i, ar, as) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +/* Resolve one part of an array index. */ + +try +gfc_resolve_index (gfc_expr * index, int check_scalar) +{ + gfc_typespec ts; + + if (index == NULL) + return SUCCESS; + + if (gfc_resolve_expr (index) == FAILURE) + return FAILURE; + + if (index->ts.type != BT_INTEGER) + { + gfc_error ("Array index at %L must be of INTEGER type", &index->where); + return FAILURE; + } + + if (check_scalar && index->rank != 0) + { + gfc_error ("Array index at %L must be scalar", &index->where); + return FAILURE; + } + + if (index->ts.kind != gfc_index_integer_kind) + { + ts.type = BT_INTEGER; + ts.kind = gfc_index_integer_kind; + + gfc_convert_type_warn (index, &ts, 2, 0); + } + + return SUCCESS; +} + + +/* Given an expression that contains array references, update those array + references to point to the right array specifications. While this is + filled in during matching, this information is difficult to save and load + in a module, so we take care of it here. + + The idea here is that the original array reference comes from the + base symbol. We traverse the list of reference structures, setting + the stored reference to references. Component references can + provide an additional array specification. */ + +static void +find_array_spec (gfc_expr * e) +{ + gfc_array_spec *as; + gfc_component *c; + gfc_ref *ref; + + as = e->symtree->n.sym->as; + c = e->symtree->n.sym->components; + + for (ref = e->ref; ref; ref = ref->next) + switch (ref->type) + { + case REF_ARRAY: + if (as == NULL) + gfc_internal_error ("find_array_spec(): Missing spec"); + + ref->u.ar.as = as; + as = NULL; + break; + + case REF_COMPONENT: + for (; c; c = c->next) + if (c == ref->u.c.component) + break; + + if (c == NULL) + gfc_internal_error ("find_array_spec(): Component not found"); + + if (c->dimension) + { + if (as != NULL) + gfc_internal_error ("find_array_spec(): unused as(1)"); + as = c->as; + } + + c = c->ts.derived->components; + break; + + case REF_SUBSTRING: + break; + } + + if (as != NULL) + gfc_internal_error ("find_array_spec(): unused as(2)"); +} + + +/* Resolve an array reference. */ + +static try +resolve_array_ref (gfc_array_ref * ar) +{ + int i, check_scalar; + + for (i = 0; i < ar->dimen; i++) + { + check_scalar = ar->dimen_type[i] == DIMEN_RANGE; + + if (gfc_resolve_index (ar->start[i], check_scalar) == FAILURE) + return FAILURE; + if (gfc_resolve_index (ar->end[i], check_scalar) == FAILURE) + return FAILURE; + if (gfc_resolve_index (ar->stride[i], check_scalar) == FAILURE) + return FAILURE; + + if (ar->dimen_type[i] == DIMEN_UNKNOWN) + switch (ar->start[i]->rank) + { + case 0: + ar->dimen_type[i] = DIMEN_ELEMENT; + break; + + case 1: + ar->dimen_type[i] = DIMEN_VECTOR; + break; + + default: + gfc_error ("Array index at %L is an array of rank %d", + &ar->c_where[i], ar->start[i]->rank); + return FAILURE; + } + } + + /* If the reference type is unknown, figure out what kind it is. */ + + if (ar->type == AR_UNKNOWN) + { + ar->type = AR_ELEMENT; + for (i = 0; i < ar->dimen; i++) + if (ar->dimen_type[i] == DIMEN_RANGE + || ar->dimen_type[i] == DIMEN_VECTOR) + { + ar->type = AR_SECTION; + break; + } + } + + if (compare_spec_to_ref (ar) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + +static try +resolve_substring (gfc_ref * ref) +{ + + if (ref->u.ss.start != NULL) + { + if (gfc_resolve_expr (ref->u.ss.start) == FAILURE) + return FAILURE; + + if (ref->u.ss.start->ts.type != BT_INTEGER) + { + gfc_error ("Substring start index at %L must be of type INTEGER", + &ref->u.ss.start->where); + return FAILURE; + } + + if (ref->u.ss.start->rank != 0) + { + gfc_error ("Substring start index at %L must be scalar", + &ref->u.ss.start->where); + return FAILURE; + } + + if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT) + { + gfc_error ("Substring start index at %L is less than one", + &ref->u.ss.start->where); + return FAILURE; + } + } + + if (ref->u.ss.end != NULL) + { + if (gfc_resolve_expr (ref->u.ss.end) == FAILURE) + return FAILURE; + + if (ref->u.ss.end->ts.type != BT_INTEGER) + { + gfc_error ("Substring end index at %L must be of type INTEGER", + &ref->u.ss.end->where); + return FAILURE; + } + + if (ref->u.ss.end->rank != 0) + { + gfc_error ("Substring end index at %L must be scalar", + &ref->u.ss.end->where); + return FAILURE; + } + + if (ref->u.ss.length != NULL + && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT) + { + gfc_error ("Substring end index at %L is out of bounds", + &ref->u.ss.start->where); + return FAILURE; + } + } + + return SUCCESS; +} + + +/* Resolve subtype references. */ + +static try +resolve_ref (gfc_expr * expr) +{ + int current_part_dimension, n_components, seen_part_dimension; + gfc_ref *ref; + + for (ref = expr->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.as == NULL) + { + find_array_spec (expr); + break; + } + + for (ref = expr->ref; ref; ref = ref->next) + switch (ref->type) + { + case REF_ARRAY: + if (resolve_array_ref (&ref->u.ar) == FAILURE) + return FAILURE; + break; + + case REF_COMPONENT: + break; + + case REF_SUBSTRING: + resolve_substring (ref); + break; + } + + /* Check constraints on part references. */ + + current_part_dimension = 0; + seen_part_dimension = 0; + n_components = 0; + + for (ref = expr->ref; ref; ref = ref->next) + { + switch (ref->type) + { + case REF_ARRAY: + switch (ref->u.ar.type) + { + case AR_FULL: + case AR_SECTION: + current_part_dimension = 1; + break; + + case AR_ELEMENT: + current_part_dimension = 0; + break; + + case AR_UNKNOWN: + gfc_internal_error ("resolve_ref(): Bad array reference"); + } + + break; + + case REF_COMPONENT: + if ((current_part_dimension || seen_part_dimension) + && ref->u.c.component->pointer) + { + gfc_error + ("Component to the right of a part reference with nonzero " + "rank must not have the POINTER attribute at %L", + &expr->where); + return FAILURE; + } + + n_components++; + break; + + case REF_SUBSTRING: + break; + } + + if (((ref->type == REF_COMPONENT && n_components > 1) + || ref->next == NULL) + && current_part_dimension + && seen_part_dimension) + { + + gfc_error ("Two or more part references with nonzero rank must " + "not be specified at %L", &expr->where); + return FAILURE; + } + + if (ref->type == REF_COMPONENT) + { + if (current_part_dimension) + seen_part_dimension = 1; + + /* reset to make sure */ + current_part_dimension = 0; + } + } + + return SUCCESS; +} + + +/* Given an expression, determine its shape. This is easier than it sounds. + Leaves the shape array NULL if it is not possible to determine the shape. */ + +static void +expression_shape (gfc_expr * e) +{ + mpz_t array[GFC_MAX_DIMENSIONS]; + int i; + + if (e->rank == 0 || e->shape != NULL) + return; + + for (i = 0; i < e->rank; i++) + if (gfc_array_dimen_size (e, i, &array[i]) == FAILURE) + goto fail; + + e->shape = gfc_get_shape (e->rank); + + memcpy (e->shape, array, e->rank * sizeof (mpz_t)); + + return; + +fail: + for (i--; i >= 0; i--) + mpz_clear (array[i]); +} + + +/* Given a variable expression node, compute the rank of the expression by + examining the base symbol and any reference structures it may have. */ + +static void +expression_rank (gfc_expr * e) +{ + gfc_ref *ref; + int i, rank; + + if (e->ref == NULL) + { + if (e->expr_type == EXPR_ARRAY) + goto done; + /* Constructors can have a rank different from one via RESHAPE(). */ + + if (e->symtree == NULL) + { + e->rank = 0; + goto done; + } + + e->rank = (e->symtree->n.sym->as == NULL) + ? 0 : e->symtree->n.sym->as->rank; + goto done; + } + + rank = 0; + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type != REF_ARRAY) + continue; + + if (ref->u.ar.type == AR_FULL) + { + rank = ref->u.ar.as->rank; + break; + } + + if (ref->u.ar.type == AR_SECTION) + { + /* Figure out the rank of the section. */ + if (rank != 0) + gfc_internal_error ("expression_rank(): Two array specs"); + + for (i = 0; i < ref->u.ar.dimen; i++) + if (ref->u.ar.dimen_type[i] == DIMEN_RANGE + || ref->u.ar.dimen_type[i] == DIMEN_VECTOR) + rank++; + + break; + } + } + + e->rank = rank; + +done: + expression_shape (e); +} + + +/* Resolve a variable expression. */ + +static try +resolve_variable (gfc_expr * e) +{ + gfc_symbol *sym; + + if (e->ref && resolve_ref (e) == FAILURE) + return FAILURE; + + sym = e->symtree->n.sym; + if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function) + { + e->ts.type = BT_PROCEDURE; + return SUCCESS; + } + + if (sym->ts.type != BT_UNKNOWN) + gfc_variable_attr (e, &e->ts); + else + { + /* Must be a simple variable reference. */ + if (gfc_set_default_type (sym, 1, NULL) == FAILURE) + return FAILURE; + e->ts = sym->ts; + } + + return SUCCESS; +} + + +/* Resolve an expression. That is, make sure that types of operands agree + with their operators, intrinsic operators are converted to function calls + for overloaded types and unresolved function references are resolved. */ + +try +gfc_resolve_expr (gfc_expr * e) +{ + try t; + + if (e == NULL) + return SUCCESS; + + switch (e->expr_type) + { + case EXPR_OP: + t = resolve_operator (e); + break; + + case EXPR_FUNCTION: + t = resolve_function (e); + break; + + case EXPR_VARIABLE: + t = resolve_variable (e); + if (t == SUCCESS) + expression_rank (e); + break; + + case EXPR_SUBSTRING: + t = resolve_ref (e); + break; + + case EXPR_CONSTANT: + case EXPR_NULL: + t = SUCCESS; + break; + + case EXPR_ARRAY: + t = FAILURE; + if (resolve_ref (e) == FAILURE) + break; + + t = gfc_resolve_array_constructor (e); + /* Also try to expand a constructor. */ + if (t == SUCCESS) + { + expression_rank (e); + gfc_expand_constructor (e); + } + + break; + + case EXPR_STRUCTURE: + t = resolve_ref (e); + if (t == FAILURE) + break; + + t = resolve_structure_cons (e); + if (t == FAILURE) + break; + + t = gfc_simplify_expr (e, 0); + break; + + default: + gfc_internal_error ("gfc_resolve_expr(): Bad expression type"); + } + + return t; +} + + +/* Resolve the expressions in an iterator structure and require that they all + be of integer type. */ + +try +gfc_resolve_iterator (gfc_iterator * iter) +{ + + if (gfc_resolve_expr (iter->var) == FAILURE) + return FAILURE; + + if (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0) + { + gfc_error ("Loop variable at %L must be a scalar INTEGER", + &iter->var->where); + return FAILURE; + } + + if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym)) + { + gfc_error ("Cannot assign to loop variable in PURE procedure at %L", + &iter->var->where); + return FAILURE; + } + + if (gfc_resolve_expr (iter->start) == FAILURE) + return FAILURE; + + if (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0) + { + gfc_error ("Start expression in DO loop at %L must be a scalar INTEGER", + &iter->start->where); + return FAILURE; + } + + if (gfc_resolve_expr (iter->end) == FAILURE) + return FAILURE; + + if (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0) + { + gfc_error ("End expression in DO loop at %L must be a scalar INTEGER", + &iter->end->where); + return FAILURE; + } + + if (gfc_resolve_expr (iter->step) == FAILURE) + return FAILURE; + + if (iter->step->ts.type != BT_INTEGER || iter->step->rank != 0) + { + gfc_error ("Step expression in DO loop at %L must be a scalar INTEGER", + &iter->step->where); + return FAILURE; + } + + if (iter->step->expr_type == EXPR_CONSTANT + && mpz_cmp_ui (iter->step->value.integer, 0) == 0) + { + gfc_error ("Step expression in DO loop at %L cannot be zero", + &iter->step->where); + return FAILURE; + } + + return SUCCESS; +} + + +/* Resolve a list of FORALL iterators. */ + +static void +resolve_forall_iterators (gfc_forall_iterator * iter) +{ + + while (iter) + { + if (gfc_resolve_expr (iter->var) == SUCCESS + && iter->var->ts.type != BT_INTEGER) + gfc_error ("FORALL Iteration variable at %L must be INTEGER", + &iter->var->where); + + if (gfc_resolve_expr (iter->start) == SUCCESS + && iter->start->ts.type != BT_INTEGER) + gfc_error ("FORALL start expression at %L must be INTEGER", + &iter->start->where); + if (iter->var->ts.kind != iter->start->ts.kind) + gfc_convert_type (iter->start, &iter->var->ts, 2); + + if (gfc_resolve_expr (iter->end) == SUCCESS + && iter->end->ts.type != BT_INTEGER) + gfc_error ("FORALL end expression at %L must be INTEGER", + &iter->end->where); + if (iter->var->ts.kind != iter->end->ts.kind) + gfc_convert_type (iter->end, &iter->var->ts, 2); + + if (gfc_resolve_expr (iter->stride) == SUCCESS + && iter->stride->ts.type != BT_INTEGER) + gfc_error ("FORALL Stride expression at %L must be INTEGER", + &iter->stride->where); + if (iter->var->ts.kind != iter->stride->ts.kind) + gfc_convert_type (iter->stride, &iter->var->ts, 2); + + iter = iter->next; + } +} + + +/* Given a pointer to a symbol that is a derived type, see if any components + have the POINTER attribute. The search is recursive if necessary. + Returns zero if no pointer components are found, nonzero otherwise. */ + +static int +derived_pointer (gfc_symbol * sym) +{ + gfc_component *c; + + for (c = sym->components; c; c = c->next) + { + if (c->pointer) + return 1; + + if (c->ts.type == BT_DERIVED && derived_pointer (c->ts.derived)) + return 1; + } + + return 0; +} + + +/* Resolve the argument of a deallocate expression. The expression must be + a pointer or a full array. */ + +static try +resolve_deallocate_expr (gfc_expr * e) +{ + symbol_attribute attr; + int allocatable; + gfc_ref *ref; + + if (gfc_resolve_expr (e) == FAILURE) + return FAILURE; + + attr = gfc_expr_attr (e); + if (attr.pointer) + return SUCCESS; + + if (e->expr_type != EXPR_VARIABLE) + goto bad; + + allocatable = e->symtree->n.sym->attr.allocatable; + for (ref = e->ref; ref; ref = ref->next) + switch (ref->type) + { + case REF_ARRAY: + if (ref->u.ar.type != AR_FULL) + allocatable = 0; + break; + + case REF_COMPONENT: + allocatable = (ref->u.c.component->as != NULL + && ref->u.c.component->as->type == AS_DEFERRED); + break; + + case REF_SUBSTRING: + allocatable = 0; + break; + } + + if (allocatable == 0) + { + bad: + gfc_error ("Expression in DEALLOCATE statement at %L must be " + "ALLOCATABLE or a POINTER", &e->where); + } + + return SUCCESS; +} + + +/* Resolve the expression in an ALLOCATE statement, doing the additional + checks to see whether the expression is OK or not. The expression must + have a trailing array reference that gives the size of the array. */ + +static try +resolve_allocate_expr (gfc_expr * e) +{ + int i, pointer, allocatable, dimension; + symbol_attribute attr; + gfc_ref *ref, *ref2; + gfc_array_ref *ar; + + if (gfc_resolve_expr (e) == FAILURE) + return FAILURE; + + /* Make sure the expression is allocatable or a pointer. If it is + pointer, the next-to-last reference must be a pointer. */ + + ref2 = NULL; + + if (e->expr_type != EXPR_VARIABLE) + { + allocatable = 0; + + attr = gfc_expr_attr (e); + pointer = attr.pointer; + dimension = attr.dimension; + + } + else + { + allocatable = e->symtree->n.sym->attr.allocatable; + pointer = e->symtree->n.sym->attr.pointer; + dimension = e->symtree->n.sym->attr.dimension; + + for (ref = e->ref; ref; ref2 = ref, ref = ref->next) + switch (ref->type) + { + case REF_ARRAY: + if (ref->next != NULL) + pointer = 0; + break; + + case REF_COMPONENT: + allocatable = (ref->u.c.component->as != NULL + && ref->u.c.component->as->type == AS_DEFERRED); + + pointer = ref->u.c.component->pointer; + dimension = ref->u.c.component->dimension; + break; + + case REF_SUBSTRING: + allocatable = 0; + pointer = 0; + break; + } + } + + if (allocatable == 0 && pointer == 0) + { + gfc_error ("Expression in ALLOCATE statement at %L must be " + "ALLOCATABLE or a POINTER", &e->where); + return FAILURE; + } + + if (pointer && dimension == 0) + return SUCCESS; + + /* Make sure the next-to-last reference node is an array specification. */ + + if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL) + { + gfc_error ("Array specification required in ALLOCATE statement " + "at %L", &e->where); + return FAILURE; + } + + if (ref2->u.ar.type == AR_ELEMENT) + return SUCCESS; + + /* Make sure that the array section reference makes sense in the + context of an ALLOCATE specification. */ + + ar = &ref2->u.ar; + + for (i = 0; i < ar->dimen; i++) + switch (ar->dimen_type[i]) + { + case DIMEN_ELEMENT: + break; + + case DIMEN_RANGE: + if (ar->start[i] != NULL + && ar->end[i] != NULL + && ar->stride[i] == NULL) + break; + + /* Fall Through... */ + + case DIMEN_UNKNOWN: + case DIMEN_VECTOR: + gfc_error ("Bad array specification in ALLOCATE statement at %L", + &e->where); + return FAILURE; + } + + return SUCCESS; +} + + +/************ SELECT CASE resolution subroutines ************/ + +/* Callback function for our mergesort variant. Determines interval + overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for + op1 > op2. Assumes we're not dealing with the default case. */ + +static int +compare_cases (const void * _op1, const void * _op2) +{ + const gfc_case *op1, *op2; + + op1 = (const gfc_case *) _op1; + op2 = (const gfc_case *) _op2; + + if (op1->low == NULL) /* op1 = (:N) */ + { + if (op2->low == NULL) /* op2 = (:M), so overlap. */ + return 0; + + else if (op2->high == NULL) /* op2 = (M:) */ + { + if (gfc_compare_expr (op1->high, op2->low) < 0) + return -1; /* N < M */ + else + return 0; + } + + else /* op2 = (L:M) */ + { + if (gfc_compare_expr (op1->high, op2->low) < 0) + return -1; /* N < L */ + else + return 0; + } + } + + else if (op1->high == NULL) /* op1 = (N:) */ + { + if (op2->low == NULL) /* op2 = (:M) */ + { + if (gfc_compare_expr (op1->low, op2->high) > 0) + return 1; /* N > M */ + else + return 0; + } + + else if (op2->high == NULL) /* op2 = (M:), so overlap. */ + return 0; + + else /* op2 = (L:M) */ + { + if (gfc_compare_expr (op1->low, op2->high) > 0) + return 1; /* N > M */ + else + return 0; + } + } + + else /* op1 = (N:P) */ + { + if (op2->low == NULL) /* op2 = (:M) */ + { + if (gfc_compare_expr (op1->low, op2->high) > 0) + return 1; /* N > M */ + else + return 0; + } + + else if (op2->high == NULL) /* op2 = (M:) */ + { + if (gfc_compare_expr (op1->high, op2->low) < 0) + return -1; /* P < M */ + else + return 0; + } + + else /* op2 = (L:M) */ + { + if (gfc_compare_expr (op1->high, op2->low) < 0) + return -1; /* P < L */ + + if (gfc_compare_expr (op1->low, op2->high) > 0) + return 1; /* N > M */ + + return 0; + } + } +} + + +/* Merge-sort a double linked case list, detecting overlap in the + process. LIST is the head of the double linked case list before it + is sorted. Returns the head of the sorted list if we don't see any + overlap, or NULL otherwise. */ + +static gfc_case * +check_case_overlap (gfc_case * list) +{ + gfc_case *p, *q, *e, *tail; + int insize, nmerges, psize, qsize, cmp, overlap_seen; + + /* If the passed list was empty, return immediately. */ + if (!list) + return NULL; + + overlap_seen = 0; + insize = 1; + + /* Loop unconditionally. The only exit from this loop is a return + statement, when we've finished sorting the case list. */ + for (;;) + { + p = list; + list = NULL; + tail = NULL; + + /* Count the number of merges we do in this pass. */ + nmerges = 0; + + /* Loop while there exists a merge to be done. */ + while (p) + { + int i; + + /* Count this merge. */ + nmerges++; + + /* Cut the list in two pieces by steppin INSIZE places + forward in the list, starting from P. */ + psize = 0; + q = p; + for (i = 0; i < insize; i++) + { + psize++; + q = q->right; + if (!q) + break; + } + qsize = insize; + + /* Now we have two lists. Merge them! */ + while (psize > 0 || (qsize > 0 && q != NULL)) + { + + /* See from which the next case to merge comes from. */ + if (psize == 0) + { + /* P is empty so the next case must come from Q. */ + e = q; + q = q->right; + qsize--; + } + else if (qsize == 0 || q == NULL) + { + /* Q is empty. */ + e = p; + p = p->right; + psize--; + } + else + { + cmp = compare_cases (p, q); + if (cmp < 0) + { + /* The whole case range for P is less than the + one for Q. */ + e = p; + p = p->right; + psize--; + } + else if (cmp > 0) + { + /* The whole case range for Q is greater than + the case range for P. */ + e = q; + q = q->right; + qsize--; + } + else + { + /* The cases overlap, or they are the same + element in the list. Either way, we must + issue an error and get the next case from P. */ + /* FIXME: Sort P and Q by line number. */ + gfc_error ("CASE label at %L overlaps with CASE " + "label at %L", &p->where, &q->where); + overlap_seen = 1; + e = p; + p = p->right; + psize--; + } + } + + /* Add the next element to the merged list. */ + if (tail) + tail->right = e; + else + list = e; + e->left = tail; + tail = e; + } + + /* P has now stepped INSIZE places along, and so has Q. So + they're the same. */ + p = q; + } + tail->right = NULL; + + /* If we have done only one merge or none at all, we've + finished sorting the cases. */ + if (nmerges <= 1) + { + if (!overlap_seen) + return list; + else + return NULL; + } + + /* Otherwise repeat, merging lists twice the size. */ + insize *= 2; + } +} + + +/* Check to see if an expression is suitable for use in a CASE + statement. Makes sure that all case expressions are scalar + constants of the same type/kind. Return FAILURE if anything + is wrong. */ + +static try +validate_case_label_expr (gfc_expr * e, gfc_expr * case_expr) +{ + gfc_typespec case_ts = case_expr->ts; + + if (e == NULL) return SUCCESS; + + if (e->expr_type != EXPR_CONSTANT) + { + gfc_error ("Expression in CASE statement at %L must be a constant", + &e->where); + return FAILURE; + } + + if (e->ts.type != case_ts.type) + { + gfc_error ("Expression in CASE statement at %L must be of type %s", + &e->where, gfc_basic_typename (case_ts.type)); + return FAILURE; + } + + if (e->ts.kind != case_ts.kind) + { + gfc_error("Expression in CASE statement at %L must be kind %d", + &e->where, case_ts.kind); + return FAILURE; + } + + if (e->rank != 0) + { + gfc_error ("Expression in CASE statement at %L must be scalar", + &e->where); + return FAILURE; + } + + return SUCCESS; +} + + +/* Given a completely parsed select statement, we: + + - Validate all expressions and code within the SELECT. + - Make sure that the selection expression is not of the wrong type. + - Make sure that no case ranges overlap. + - Eliminate unreachable cases and unreachable code resulting from + removing case labels. + + The standard does allow unreachable cases, e.g. CASE (5:3). But + they are a hassle for code generation, and to prevent that, we just + cut them out here. This is not necessary for overlapping cases + because they are illegal and we never even try to generate code. + + We have the additional caveat that a SELECT construct could have + been a computed GOTO in the source code. Furtunately we can fairly + easily work around that here: The case_expr for a "real" SELECT CASE + is in code->expr1, but for a computed GOTO it is in code->expr2. All + we have to do is make sure that the case_expr is a scalar integer + expression. */ + +static void +resolve_select (gfc_code * code) +{ + gfc_code *body; + gfc_expr *case_expr; + gfc_case *cp, *default_case, *tail, *head; + int seen_unreachable; + int ncases; + bt type; + try t; + + if (code->expr == NULL) + { + /* This was actually a computed GOTO statement. */ + case_expr = code->expr2; + if (case_expr->ts.type != BT_INTEGER + || case_expr->rank != 0) + gfc_error ("Selection expression in computed GOTO statement " + "at %L must be a scalar integer expression", + &case_expr->where); + + /* Further checking is not necessary because this SELECT was built + by the compiler, so it should always be OK. Just move the + case_expr from expr2 to expr so that we can handle computed + GOTOs as normal SELECTs from here on. */ + code->expr = code->expr2; + code->expr2 = NULL; + return; + } + + case_expr = code->expr; + + type = case_expr->ts.type; + if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER) + { + gfc_error ("Argument of SELECT statement at %L cannot be %s", + &case_expr->where, gfc_typename (&case_expr->ts)); + + /* Punt. Going on here just produce more garbage error messages. */ + return; + } + + if (case_expr->rank != 0) + { + gfc_error ("Argument of SELECT statement at %L must be a scalar " + "expression", &case_expr->where); + + /* Punt. */ + return; + } + + /* Assume there is no DEFAULT case. */ + default_case = NULL; + head = tail = NULL; + ncases = 0; + + for (body = code->block; body; body = body->block) + { + /* Assume the CASE list is OK, and all CASE labels can be matched. */ + t = SUCCESS; + seen_unreachable = 0; + + /* Walk the case label list, making sure that all case labels + are legal. */ + for (cp = body->ext.case_list; cp; cp = cp->next) + { + /* Count the number of cases in the whole construct. */ + ncases++; + + /* Intercept the DEFAULT case. */ + if (cp->low == NULL && cp->high == NULL) + { + if (default_case != NULL) + { + gfc_error ("The DEFAULT CASE at %L cannot be followed " + "by a second DEFAULT CASE at %L", + &default_case->where, &cp->where); + t = FAILURE; + break; + } + else + { + default_case = cp; + continue; + } + } + + /* Deal with single value cases and case ranges. Errors are + issued from the validation function. */ + if(validate_case_label_expr (cp->low, case_expr) != SUCCESS + || validate_case_label_expr (cp->high, case_expr) != SUCCESS) + { + t = FAILURE; + break; + } + + if (type == BT_LOGICAL + && ((cp->low == NULL || cp->high == NULL) + || cp->low != cp->high)) + { + gfc_error + ("Logical range in CASE statement at %L is not allowed", + &cp->low->where); + t = FAILURE; + break; + } + + if (cp->low != NULL && cp->high != NULL + && cp->low != cp->high + && gfc_compare_expr (cp->low, cp->high) > 0) + { + if (gfc_option.warn_surprising) + gfc_warning ("Range specification at %L can never " + "be matched", &cp->where); + + cp->unreachable = 1; + seen_unreachable = 1; + } + else + { + /* If the case range can be matched, it can also overlap with + other cases. To make sure it does not, we put it in a + double linked list here. We sort that with a merge sort + later on to detect any overlapping cases. */ + if (!head) + { + head = tail = cp; + head->right = head->left = NULL; + } + else + { + tail->right = cp; + tail->right->left = tail; + tail = tail->right; + tail->right = NULL; + } + } + } + + /* It there was a failure in the previous case label, give up + for this case label list. Continue with the next block. */ + if (t == FAILURE) + continue; + + /* See if any case labels that are unreachable have been seen. + If so, we eliminate them. This is a bit of a kludge because + the case lists for a single case statement (label) is a + single forward linked lists. */ + if (seen_unreachable) + { + /* Advance until the first case in the list is reachable. */ + while (body->ext.case_list != NULL + && body->ext.case_list->unreachable) + { + gfc_case *n = body->ext.case_list; + body->ext.case_list = body->ext.case_list->next; + n->next = NULL; + gfc_free_case_list (n); + } + + /* Strip all other unreachable cases. */ + if (body->ext.case_list) + { + for (cp = body->ext.case_list; cp->next; cp = cp->next) + { + if (cp->next->unreachable) + { + gfc_case *n = cp->next; + cp->next = cp->next->next; + n->next = NULL; + gfc_free_case_list (n); + } + } + } + } + } + + /* See if there were overlapping cases. If the check returns NULL, + there was overlap. In that case we don't do anything. If head + is non-NULL, we prepend the DEFAULT case. The sorted list can + then used during code generation for SELECT CASE constructs with + a case expression of a CHARACTER type. */ + if (head) + { + head = check_case_overlap (head); + + /* Prepend the default_case if it is there. */ + if (head != NULL && default_case) + { + default_case->left = NULL; + default_case->right = head; + head->left = default_case; + } + } + + /* Eliminate dead blocks that may be the result if we've seen + unreachable case labels for a block. */ + for (body = code; body && body->block; body = body->block) + { + if (body->block->ext.case_list == NULL) + { + /* Cut the unreachable block from the code chain. */ + gfc_code *c = body->block; + body->block = c->block; + + /* Kill the dead block, but not the blocks below it. */ + c->block = NULL; + gfc_free_statements (c); + } + } + + /* More than two cases is legal but insane for logical selects. + Issue a warning for it. */ + if (gfc_option.warn_surprising && type == BT_LOGICAL + && ncases > 2) + gfc_warning ("Logical SELECT CASE block at %L has more that two cases", + &code->loc); +} + + +/*********** Toplevel code resolution subroutines ***********/ + +/* Given a branch to a label and a namespace, if the branch is conforming. + The code node described where the branch is located. */ + +static void +resolve_branch (gfc_st_label * label, gfc_code * code) +{ + gfc_code *block, *found; + code_stack *stack; + gfc_st_label *lp; + + if (label == NULL) + return; + lp = label; + + /* Step one: is this a valid branching target? */ + + if (lp->defined == ST_LABEL_UNKNOWN) + { + gfc_error ("Label %d referenced at %L is never defined", lp->value, + &lp->where); + return; + } + + if (lp->defined != ST_LABEL_TARGET) + { + gfc_error ("Statement at %L is not a valid branch target statement " + "for the branch statement at %L", &lp->where, &code->loc); + return; + } + + /* Step two: make sure this branch is not a branch to itself ;-) */ + + if (code->here == label) + { + gfc_warning ("Branch at %L causes an infinite loop", &code->loc); + return; + } + + /* Step three: Try to find the label in the parse tree. To do this, + we traverse the tree block-by-block: first the block that + contains this GOTO, then the block that it is nested in, etc. We + can ignore other blocks because branching into another block is + not allowed. */ + + found = NULL; + + for (stack = cs_base; stack; stack = stack->prev) + { + for (block = stack->head; block; block = block->next) + { + if (block->here == label) + { + found = block; + break; + } + } + + if (found) + break; + } + + if (found == NULL) + { + /* still nothing, so illegal. */ + gfc_error_now ("Label at %L is not in the same block as the " + "GOTO statement at %L", &lp->where, &code->loc); + return; + } + + /* Step four: Make sure that the branching target is legal if + the statement is an END {SELECT,DO,IF}. */ + + if (found->op == EXEC_NOP) + { + for (stack = cs_base; stack; stack = stack->prev) + if (stack->current->next == found) + break; + + if (stack == NULL) + gfc_notify_std (GFC_STD_F95_DEL, + "Obsolete: GOTO at %L jumps to END of construct at %L", + &code->loc, &found->loc); + } +} + + +/* Check whether EXPR1 has the same shape as EXPR2. */ + +static try +resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2) +{ + mpz_t shape[GFC_MAX_DIMENSIONS]; + mpz_t shape2[GFC_MAX_DIMENSIONS]; + try result = FAILURE; + int i; + + /* Compare the rank. */ + if (expr1->rank != expr2->rank) + return result; + + /* Compare the size of each dimension. */ + for (i=0; i<expr1->rank; i++) + { + if (gfc_array_dimen_size (expr1, i, &shape[i]) == FAILURE) + goto ignore; + + if (gfc_array_dimen_size (expr2, i, &shape2[i]) == FAILURE) + goto ignore; + + if (mpz_cmp (shape[i], shape2[i])) + goto over; + } + + /* When either of the two expression is an assumed size array, we + ignore the comparison of dimension sizes. */ +ignore: + result = SUCCESS; + +over: + for (i--; i>=0; i--) + { + mpz_clear (shape[i]); + mpz_clear (shape2[i]); + } + return result; +} + + +/* Check whether a WHERE assignment target or a WHERE mask expression + has the same shape as the outmost WHERE mask expression. */ + +static void +resolve_where (gfc_code *code, gfc_expr *mask) +{ + gfc_code *cblock; + gfc_code *cnext; + gfc_expr *e = NULL; + + cblock = code->block; + + /* Store the first WHERE mask-expr of the WHERE statement or construct. + In case of nested WHERE, only the outmost one is stored. */ + if (mask == NULL) /* outmost WHERE */ + e = cblock->expr; + else /* inner WHERE */ + e = mask; + + while (cblock) + { + if (cblock->expr) + { + /* Check if the mask-expr has a consistent shape with the + outmost WHERE mask-expr. */ + if (resolve_where_shape (cblock->expr, e) == FAILURE) + gfc_error ("WHERE mask at %L has inconsistent shape", + &cblock->expr->where); + } + + /* the assignment statement of a WHERE statement, or the first + statement in where-body-construct of a WHERE construct */ + cnext = cblock->next; + while (cnext) + { + switch (cnext->op) + { + /* WHERE assignment statement */ + case EXEC_ASSIGN: + + /* Check shape consistent for WHERE assignment target. */ + if (e && resolve_where_shape (cnext->expr, e) == FAILURE) + gfc_error ("WHERE assignment target at %L has " + "inconsistent shape", &cnext->expr->where); + break; + + /* WHERE or WHERE construct is part of a where-body-construct */ + case EXEC_WHERE: + resolve_where (cnext, e); + break; + + default: + gfc_error ("Unsupported statement inside WHERE at %L", + &cnext->loc); + } + /* the next statement within the same where-body-construct */ + cnext = cnext->next; + } + /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */ + cblock = cblock->block; + } +} + + +/* Check whether the FORALL index appears in the expression or not. */ + +static try +gfc_find_forall_index (gfc_expr *expr, gfc_symbol *symbol) +{ + gfc_array_ref ar; + gfc_ref *tmp; + gfc_actual_arglist *args; + int i; + + switch (expr->expr_type) + { + case EXPR_VARIABLE: + assert (expr->symtree->n.sym); + + /* A scalar assignment */ + if (!expr->ref) + { + if (expr->symtree->n.sym == symbol) + return SUCCESS; + else + return FAILURE; + } + + /* the expr is array ref, substring or struct component. */ + tmp = expr->ref; + while (tmp != NULL) + { + switch (tmp->type) + { + case REF_ARRAY: + /* Check if the symbol appears in the array subscript. */ + ar = tmp->u.ar; + for (i = 0; i < GFC_MAX_DIMENSIONS; i++) + { + if (ar.start[i]) + if (gfc_find_forall_index (ar.start[i], symbol) == SUCCESS) + return SUCCESS; + + if (ar.end[i]) + if (gfc_find_forall_index (ar.end[i], symbol) == SUCCESS) + return SUCCESS; + + if (ar.stride[i]) + if (gfc_find_forall_index (ar.stride[i], symbol) == SUCCESS) + return SUCCESS; + } /* end for */ + break; + + case REF_SUBSTRING: + if (expr->symtree->n.sym == symbol) + return SUCCESS; + tmp = expr->ref; + /* Check if the symbol appears in the substring section. */ + if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS) + return SUCCESS; + if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS) + return SUCCESS; + break; + + case REF_COMPONENT: + break; + + default: + gfc_error("expresion reference type error at %L", &expr->where); + } + tmp = tmp->next; + } + break; + + /* If the expression is a function call, then check if the symbol + appears in the actual arglist of the function. */ + case EXPR_FUNCTION: + for (args = expr->value.function.actual; args; args = args->next) + { + if (gfc_find_forall_index(args->expr,symbol) == SUCCESS) + return SUCCESS; + } + break; + + /* It seems not to happen. */ + case EXPR_SUBSTRING: + if (expr->ref) + { + tmp = expr->ref; + assert(expr->ref->type == REF_SUBSTRING); + if (gfc_find_forall_index (tmp->u.ss.start, symbol) == SUCCESS) + return SUCCESS; + if (gfc_find_forall_index (tmp->u.ss.end, symbol) == SUCCESS) + return SUCCESS; + } + break; + + /* It seems not to happen. */ + case EXPR_STRUCTURE: + case EXPR_ARRAY: + gfc_error ("Unsupported statement while finding forall index in " + "expression"); + break; + default: + break; + } + + /* Find the FORALL index in the first operand. */ + if (expr->op1) + { + if (gfc_find_forall_index (expr->op1, symbol) == SUCCESS) + return SUCCESS; + } + + /* Find the FORALL index in the second operand. */ + if (expr->op2) + { + if (gfc_find_forall_index (expr->op2, symbol) == SUCCESS) + return SUCCESS; + } + return FAILURE; +} + + +/* Resolve assignment in FORALL construct. + NVAR is the number of FORALL index variables, and VAR_EXPR records the + FORALL index variables. */ + +static void +gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr) +{ + int n; + + for (n = 0; n < nvar; n++) + { + gfc_symbol *forall_index; + + forall_index = var_expr[n]->symtree->n.sym; + + /* Check whether the assignment target is one of the FORALL index + variable. */ + if ((code->expr->expr_type == EXPR_VARIABLE) + && (code->expr->symtree->n.sym == forall_index)) + gfc_error ("Assignment to a FORALL index variable at %L", + &code->expr->where); + else + { + /* If one of the FORALL index variables doesn't appear in the + assignment target, then there will be a many-to-one + assignment. */ + if (gfc_find_forall_index (code->expr, forall_index) == FAILURE) + gfc_error ("The FORALL with index '%s' cause more than one " + "assignment to this object at %L", + var_expr[n]->symtree->name, &code->expr->where); + } + } +} + + +/* Resolve WHERE statement in FORALL construct. */ + +static void +gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr){ + gfc_code *cblock; + gfc_code *cnext; + + cblock = code->block; + while (cblock) + { + /* the assignment statement of a WHERE statement, or the first + statement in where-body-construct of a WHERE construct */ + cnext = cblock->next; + while (cnext) + { + switch (cnext->op) + { + /* WHERE assignment statement */ + case EXEC_ASSIGN: + gfc_resolve_assign_in_forall (cnext, nvar, var_expr); + break; + + /* WHERE or WHERE construct is part of a where-body-construct */ + case EXEC_WHERE: + gfc_resolve_where_code_in_forall (cnext, nvar, var_expr); + break; + + default: + gfc_error ("Unsupported statement inside WHERE at %L", + &cnext->loc); + } + /* the next statement within the same where-body-construct */ + cnext = cnext->next; + } + /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */ + cblock = cblock->block; + } +} + + +/* Traverse the FORALL body to check whether the following errors exist: + 1. For assignment, check if a many-to-one assignment happens. + 2. For WHERE statement, check the WHERE body to see if there is any + many-to-one assignment. */ + +static void +gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr) +{ + gfc_code *c; + + c = code->block->next; + while (c) + { + switch (c->op) + { + case EXEC_ASSIGN: + case EXEC_POINTER_ASSIGN: + gfc_resolve_assign_in_forall (c, nvar, var_expr); + break; + + /* Because the resolve_blocks() will handle the nested FORALL, + there is no need to handle it here. */ + case EXEC_FORALL: + break; + case EXEC_WHERE: + gfc_resolve_where_code_in_forall(c, nvar, var_expr); + break; + default: + break; + } + /* The next statement in the FORALL body. */ + c = c->next; + } +} + + +/* Given a FORALL construct, first resolve the FORALL iterator, then call + gfc_resolve_forall_body to resolve the FORALL body. */ + +static void resolve_blocks (gfc_code *, gfc_namespace *); + +static void +gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) +{ + static gfc_expr **var_expr; + static int total_var = 0; + static int nvar = 0; + gfc_forall_iterator *fa; + gfc_symbol *forall_index; + gfc_code *next; + int i; + + /* Start to resolve a FORALL construct */ + if (forall_save == 0) + { + /* Count the total number of FORALL index in the nested FORALL + construct in order to allocate the VAR_EXPR with proper size. */ + next = code; + while ((next != NULL) && (next->op == EXEC_FORALL)) + { + for (fa = next->ext.forall_iterator; fa; fa = fa->next) + total_var ++; + next = next->block->next; + } + + /* allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */ + var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *)); + } + + /* The information about FORALL iterator, including FORALL index start, end + and stride. The FORALL index can not appear in start, end or stride. */ + for (fa = code->ext.forall_iterator; fa; fa = fa->next) + { + /* Check if any outer FORALL index name is the same as the current + one. */ + for (i = 0; i < nvar; i++) + { + if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym) + { + gfc_error ("An outer FORALL construct already has an index " + "with this name %L", &fa->var->where); + } + } + + /* Record the current FORALL index. */ + var_expr[nvar] = gfc_copy_expr (fa->var); + + forall_index = fa->var->symtree->n.sym; + + /* Check if the FORALL index appears in start, end or stride. */ + if (gfc_find_forall_index (fa->start, forall_index) == SUCCESS) + gfc_error ("A FORALL index must not appear in a limit or stride " + "expression in the same FORALL at %L", &fa->start->where); + if (gfc_find_forall_index (fa->end, forall_index) == SUCCESS) + gfc_error ("A FORALL index must not appear in a limit or stride " + "expression in the same FORALL at %L", &fa->end->where); + if (gfc_find_forall_index (fa->stride, forall_index) == SUCCESS) + gfc_error ("A FORALL index must not appear in a limit or stride " + "expression in the same FORALL at %L", &fa->stride->where); + nvar++; + } + + /* Resolve the FORALL body. */ + gfc_resolve_forall_body (code, nvar, var_expr); + + /* May call gfc_resolve_forall to resolve the inner FORALL loop. */ + resolve_blocks (code->block, ns); + + /* Free VAR_EXPR after the whole FORALL construct resolved. */ + for (i = 0; i < total_var; i++) + gfc_free_expr (var_expr[i]); + + /* Reset the counters. */ + total_var = 0; + nvar = 0; +} + + +/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and + DO code nodes. */ + +static void resolve_code (gfc_code *, gfc_namespace *); + +static void +resolve_blocks (gfc_code * b, gfc_namespace * ns) +{ + try t; + + for (; b; b = b->block) + { + t = gfc_resolve_expr (b->expr); + if (gfc_resolve_expr (b->expr2) == FAILURE) + t = FAILURE; + + switch (b->op) + { + case EXEC_IF: + if (t == SUCCESS && b->expr != NULL + && (b->expr->ts.type != BT_LOGICAL || b->expr->rank != 0)) + gfc_error + ("ELSE IF clause at %L requires a scalar LOGICAL expression", + &b->expr->where); + break; + + case EXEC_WHERE: + if (t == SUCCESS + && b->expr != NULL + && (b->expr->ts.type != BT_LOGICAL + || b->expr->rank == 0)) + gfc_error + ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array", + &b->expr->where); + break; + + case EXEC_GOTO: + resolve_branch (b->label, b); + break; + + case EXEC_SELECT: + case EXEC_FORALL: + case EXEC_DO: + case EXEC_DO_WHILE: + break; + + default: + gfc_internal_error ("resolve_block(): Bad block type"); + } + + resolve_code (b->next, ns); + } +} + + +/* Given a block of code, recursively resolve everything pointed to by this + code block. */ + +static void +resolve_code (gfc_code * code, gfc_namespace * ns) +{ + int forall_save = 0; + code_stack frame; + gfc_alloc *a; + try t; + + frame.prev = cs_base; + frame.head = code; + cs_base = &frame; + + for (; code; code = code->next) + { + frame.current = code; + + if (code->op == EXEC_FORALL) + { + forall_save = forall_flag; + forall_flag = 1; + gfc_resolve_forall (code, ns, forall_save); + } + else + resolve_blocks (code->block, ns); + + if (code->op == EXEC_FORALL) + forall_flag = forall_save; + + t = gfc_resolve_expr (code->expr); + if (gfc_resolve_expr (code->expr2) == FAILURE) + t = FAILURE; + + switch (code->op) + { + case EXEC_NOP: + case EXEC_CYCLE: + case EXEC_IOLENGTH: + case EXEC_PAUSE: + case EXEC_STOP: + case EXEC_EXIT: + case EXEC_CONTINUE: + case EXEC_DT_END: + case EXEC_TRANSFER: + break; + + case EXEC_WHERE: + resolve_where (code, NULL); + break; + + case EXEC_GOTO: + if (code->expr != NULL && code->expr->ts.type != BT_INTEGER) + gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER " + "variable", &code->expr->where); + else + resolve_branch (code->label, code); + break; + + case EXEC_RETURN: + if (code->expr != NULL && code->expr->ts.type != BT_INTEGER) + gfc_error ("Alternate RETURN statement at %L requires an INTEGER " + "return specifier", &code->expr->where); + break; + + case EXEC_ASSIGN: + if (t == FAILURE) + break; + + if (gfc_extend_assign (code, ns) == SUCCESS) + goto call; + + if (gfc_pure (NULL)) + { + if (gfc_impure_variable (code->expr->symtree->n.sym)) + { + gfc_error + ("Cannot assign to variable '%s' in PURE procedure at %L", + code->expr->symtree->n.sym->name, &code->expr->where); + break; + } + + if (code->expr2->ts.type == BT_DERIVED + && derived_pointer (code->expr2->ts.derived)) + { + gfc_error + ("Right side of assignment at %L is a derived type " + "containing a POINTER in a PURE procedure", + &code->expr2->where); + break; + } + } + + gfc_check_assign (code->expr, code->expr2, 1); + break; + + case EXEC_LABEL_ASSIGN: + if (code->label->defined == ST_LABEL_UNKNOWN) + gfc_error ("Label %d referenced at %L is never defined", + code->label->value, &code->label->where); + if (t == SUCCESS && code->expr->ts.type != BT_INTEGER) + gfc_error ("ASSIGN statement at %L requires an INTEGER " + "variable", &code->expr->where); + break; + + case EXEC_POINTER_ASSIGN: + if (t == FAILURE) + break; + + gfc_check_pointer_assign (code->expr, code->expr2); + break; + + case EXEC_ARITHMETIC_IF: + if (t == SUCCESS + && code->expr->ts.type != BT_INTEGER + && code->expr->ts.type != BT_REAL) + gfc_error ("Arithmetic IF statement at %L requires a numeric " + "expression", &code->expr->where); + + resolve_branch (code->label, code); + resolve_branch (code->label2, code); + resolve_branch (code->label3, code); + break; + + case EXEC_IF: + if (t == SUCCESS && code->expr != NULL + && (code->expr->ts.type != BT_LOGICAL + || code->expr->rank != 0)) + gfc_error ("IF clause at %L requires a scalar LOGICAL expression", + &code->expr->where); + break; + + case EXEC_CALL: + call: + resolve_call (code); + break; + + case EXEC_SELECT: + /* Select is complicated. Also, a SELECT construct could be + a transformed computed GOTO. */ + resolve_select (code); + break; + + case EXEC_DO: + if (code->ext.iterator != NULL) + gfc_resolve_iterator (code->ext.iterator); + break; + + case EXEC_DO_WHILE: + if (code->expr == NULL) + gfc_internal_error ("resolve_code(): No expression on DO WHILE"); + if (t == SUCCESS + && (code->expr->rank != 0 + || code->expr->ts.type != BT_LOGICAL)) + gfc_error ("Exit condition of DO WHILE loop at %L must be " + "a scalar LOGICAL expression", &code->expr->where); + break; + + case EXEC_ALLOCATE: + if (t == SUCCESS && code->expr != NULL + && code->expr->ts.type != BT_INTEGER) + gfc_error ("STAT tag in ALLOCATE statement at %L must be " + "of type INTEGER", &code->expr->where); + + for (a = code->ext.alloc_list; a; a = a->next) + resolve_allocate_expr (a->expr); + + break; + + case EXEC_DEALLOCATE: + if (t == SUCCESS && code->expr != NULL + && code->expr->ts.type != BT_INTEGER) + gfc_error + ("STAT tag in DEALLOCATE statement at %L must be of type " + "INTEGER", &code->expr->where); + + for (a = code->ext.alloc_list; a; a = a->next) + resolve_deallocate_expr (a->expr); + + break; + + case EXEC_OPEN: + if (gfc_resolve_open (code->ext.open) == FAILURE) + break; + + resolve_branch (code->ext.open->err, code); + break; + + case EXEC_CLOSE: + if (gfc_resolve_close (code->ext.close) == FAILURE) + break; + + resolve_branch (code->ext.close->err, code); + break; + + case EXEC_BACKSPACE: + case EXEC_ENDFILE: + case EXEC_REWIND: + if (gfc_resolve_filepos (code->ext.filepos) == FAILURE) + break; + + resolve_branch (code->ext.filepos->err, code); + break; + + case EXEC_INQUIRE: + if (gfc_resolve_inquire (code->ext.inquire) == FAILURE) + break; + + resolve_branch (code->ext.inquire->err, code); + break; + + case EXEC_READ: + case EXEC_WRITE: + if (gfc_resolve_dt (code->ext.dt) == FAILURE) + break; + + resolve_branch (code->ext.dt->err, code); + resolve_branch (code->ext.dt->end, code); + resolve_branch (code->ext.dt->eor, code); + break; + + case EXEC_FORALL: + resolve_forall_iterators (code->ext.forall_iterator); + + if (code->expr != NULL && code->expr->ts.type != BT_LOGICAL) + gfc_error + ("FORALL mask clause at %L requires a LOGICAL expression", + &code->expr->where); + break; + + default: + gfc_internal_error ("resolve_code(): Bad statement code"); + } + } + + cs_base = frame.prev; +} + + +/* Resolve initial values and make sure they are compatible with + the variable. */ + +static void +resolve_values (gfc_symbol * sym) +{ + + if (sym->value == NULL) + return; + + if (gfc_resolve_expr (sym->value) == FAILURE) + return; + + gfc_check_assign_symbol (sym, sym->value); +} + + +/* Do anything necessary to resolve a symbol. Right now, we just + assume that an otherwise unknown symbol is a variable. This sort + of thing commonly happens for symbols in module. */ + +static void +resolve_symbol (gfc_symbol * sym) +{ + /* Zero if we are checking a formal namespace. */ + static int formal_ns_flag = 1; + int formal_ns_save, check_constant, mp_flag; + + if (sym->attr.flavor == FL_UNKNOWN) + { + if (sym->attr.external == 0 && sym->attr.intrinsic == 0) + sym->attr.flavor = FL_VARIABLE; + else + { + sym->attr.flavor = FL_PROCEDURE; + if (sym->attr.dimension) + sym->attr.function = 1; + } + } + + /* Symbols that are module procedures with results (functions) have + the types and array specification copied for type checking in + procedures that call them, as well as for saving to a module + file. These symbols can't stand the scrutiny that their results + can. */ + mp_flag = (sym->result != NULL && sym->result != sym); + + /* Assign default type to symbols that need one and don't have one. */ + if (sym->ts.type == BT_UNKNOWN) + { + if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER) + gfc_set_default_type (sym, 0, NULL); + + if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function) + { + if (!mp_flag) + gfc_set_default_type (sym, 0, NULL); + else + { + /* Result may be in another namespace. */ + resolve_symbol (sym->result); + + sym->ts = sym->result->ts; + sym->as = gfc_copy_array_spec (sym->result->as); + } + } + } + + if (sym->as != NULL + && (sym->as->type == AS_ASSUMED_SIZE + || sym->as->type == AS_ASSUMED_SHAPE) + && sym->attr.dummy == 0) + { + gfc_error("Assumed %s array at %L must be a dummy argument", + sym->as->type == AS_ASSUMED_SIZE ? "size" : "shape", + &sym->declared_at); + return; + } + + /* Make sure that character string variables with assumed length are + dummy argument. */ + + if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result + && sym->ts.type == BT_CHARACTER + && sym->ts.cl->length == NULL && sym->attr.dummy == 0) + { + gfc_error ("Entity with assumed character length at %L must be a " + "dummy argument or a PARAMETER", &sym->declared_at); + return; + } + + /* Make sure a parameter that has been implicitly typed still + matches the implicit type, since PARAMETER statements can precede + IMPLICIT statements. */ + + if (sym->attr.flavor == FL_PARAMETER + && sym->attr.implicit_type + && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns))) + gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a " + "later IMPLICIT type", sym->name, &sym->declared_at); + + /* Make sure the types of derived parameters are consistent. This + type checking is deferred until resolution because the type may + refer to a derived type from the host. */ + + if (sym->attr.flavor == FL_PARAMETER + && sym->ts.type == BT_DERIVED + && !gfc_compare_types (&sym->ts, &sym->value->ts)) + gfc_error ("Incompatible derived type in PARAMETER at %L", + &sym->value->where); + + /* Make sure symbols with known intent or optional are really dummy + variable. Because of ENTRY statement, this has to be deferred + until resolution time. */ + + if (! sym->attr.dummy + && (sym->attr.optional + || sym->attr.intent != INTENT_UNKNOWN)) + { + gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at); + return; + } + + if (sym->attr.proc == PROC_ST_FUNCTION) + { + if (sym->ts.type == BT_CHARACTER) + { + gfc_charlen *cl = sym->ts.cl; + if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) + { + gfc_error ("Character-valued statement function '%s' at %L must " + "have constant length", sym->name, &sym->declared_at); + return; + } + } + } + + /* Constraints on deferred shape variable. */ + if (sym->attr.flavor == FL_VARIABLE + || (sym->attr.flavor == FL_PROCEDURE + && sym->attr.function)) + { + if (sym->as == NULL || sym->as->type != AS_DEFERRED) + { + if (sym->attr.allocatable) + { + if (sym->attr.dimension) + gfc_error ("Allocatable array at %L must have a deferred shape", + &sym->declared_at); + else + gfc_error ("Object at %L may not be ALLOCATABLE", + &sym->declared_at); + return; + } + + if (sym->attr.pointer && sym->attr.dimension) + { + gfc_error ("Pointer to array at %L must have a deferred shape", + &sym->declared_at); + return; + } + + } + else + { + if (!mp_flag && !sym->attr.allocatable + && !sym->attr.pointer && !sym->attr.dummy) + { + gfc_error ("Array at %L cannot have a deferred shape", + &sym->declared_at); + return; + } + } + } + + /* Make sure that intrinsic exist */ + if (sym->attr.intrinsic + && ! gfc_intrinsic_name(sym->name, 0) + && ! gfc_intrinsic_name(sym->name, 1)) + gfc_error("Intrinsic at %L does not exist", &sym->declared_at); + + /* Resolve array specifier. Check as well some constraints + on COMMON blocks. */ + + check_constant = sym->attr.in_common && !sym->attr.pointer; + gfc_resolve_array_spec (sym->as, check_constant); + + /* Resolve formal namespaces. */ + + if (formal_ns_flag && sym != NULL && sym->formal_ns != NULL) + { + formal_ns_save = formal_ns_flag; + formal_ns_flag = 0; + gfc_resolve (sym->formal_ns); + formal_ns_flag = formal_ns_save; + } +} + + + +/************* Resolve DATA statements *************/ + +static struct +{ + gfc_data_value *vnode; + int left; +} +values; + + +/* Advance the values structure to point to the next value in the data list. */ + +static try +next_data_value (void) +{ + + while (values.left == 0) + { + if (values.vnode->next == NULL) + return FAILURE; + + values.vnode = values.vnode->next; + values.left = values.vnode->repeat; + } + + values.left--; + return SUCCESS; +} + + +static try +check_data_variable (gfc_data_variable * var, locus * where) +{ + gfc_expr *e; + mpz_t size; + mpz_t offset; + try t; + int mark = 0; + int i; + mpz_t section_index[GFC_MAX_DIMENSIONS]; + gfc_ref *ref; + gfc_array_ref *ar; + + if (gfc_resolve_expr (var->expr) == FAILURE) + return FAILURE; + + ar = NULL; + mpz_init_set_si (offset, 0); + e = var->expr; + + if (e->expr_type != EXPR_VARIABLE) + gfc_internal_error ("check_data_variable(): Bad expression"); + + if (e->rank == 0) + mpz_init_set_ui (size, 1); + else + { + ref = e->ref; + + /* Find the array section reference. */ + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type != REF_ARRAY) + continue; + if (ref->u.ar.type == AR_ELEMENT) + continue; + break; + } + assert (ref); + + /* Set marks asscording to the reference pattern. */ + switch (ref->u.ar.type) + { + case AR_FULL: + mark = 1; + break; + + case AR_SECTION: + ar = &ref->u.ar; + /* Get the start position of array section. */ + gfc_get_section_index (ar, section_index, &offset); + mark = 2; + break; + + default: + abort(); + } + + if (gfc_array_size (e, &size) == FAILURE) + { + gfc_error ("Nonconstant array section at %L in DATA statement", + &e->where); + mpz_clear (offset); + return FAILURE; + } + } + + t = SUCCESS; + + while (mpz_cmp_ui (size, 0) > 0) + { + if (next_data_value () == FAILURE) + { + gfc_error ("DATA statement at %L has more variables than values", + where); + t = FAILURE; + break; + } + + t = gfc_check_assign (var->expr, values.vnode->expr, 0); + if (t == FAILURE) + break; + + /* Assign initial value to symbol. */ + gfc_assign_data_value (var->expr, values.vnode->expr, offset); + + if (mark == 1) + mpz_add_ui (offset, offset, 1); + + /* Modify the array section indexes and recalculate the offset for + next element. */ + else if (mark == 2) + gfc_advance_section (section_index, ar, &offset); + + mpz_sub_ui (size, size, 1); + } + if (mark == 2) + { + for (i = 0; i < ar->dimen; i++) + mpz_clear (section_index[i]); + } + + mpz_clear (size); + mpz_clear (offset); + + return t; +} + + +static try traverse_data_var (gfc_data_variable *, locus *); + +/* Iterate over a list of elements in a DATA statement. */ + +static try +traverse_data_list (gfc_data_variable * var, locus * where) +{ + mpz_t trip; + iterator_stack frame; + gfc_expr *e; + + mpz_init (frame.value); + + mpz_init_set (trip, var->iter.end->value.integer); + mpz_sub (trip, trip, var->iter.start->value.integer); + mpz_add (trip, trip, var->iter.step->value.integer); + + mpz_div (trip, trip, var->iter.step->value.integer); + + mpz_set (frame.value, var->iter.start->value.integer); + + frame.prev = iter_stack; + frame.variable = var->iter.var->symtree; + iter_stack = &frame; + + while (mpz_cmp_ui (trip, 0) > 0) + { + if (traverse_data_var (var->list, where) == FAILURE) + { + mpz_clear (trip); + return FAILURE; + } + + e = gfc_copy_expr (var->expr); + if (gfc_simplify_expr (e, 1) == FAILURE) + { + gfc_free_expr (e); + return FAILURE; + } + + mpz_add (frame.value, frame.value, var->iter.step->value.integer); + + mpz_sub_ui (trip, trip, 1); + } + + mpz_clear (trip); + mpz_clear (frame.value); + + iter_stack = frame.prev; + return SUCCESS; +} + + +/* Type resolve variables in the variable list of a DATA statement. */ + +static try +traverse_data_var (gfc_data_variable * var, locus * where) +{ + try t; + + for (; var; var = var->next) + { + if (var->expr == NULL) + t = traverse_data_list (var, where); + else + t = check_data_variable (var, where); + + if (t == FAILURE) + return FAILURE; + } + + return SUCCESS; +} + + +/* Resolve the expressions and iterators associated with a data statement. + This is separate from the assignment checking because data lists should + only be resolved once. */ + +static try +resolve_data_variables (gfc_data_variable * d) +{ + + for (; d; d = d->next) + { + if (d->list == NULL) + { + if (gfc_resolve_expr (d->expr) == FAILURE) + return FAILURE; + } + else + { + if (gfc_resolve_iterator (&d->iter) == FAILURE) + return FAILURE; + + if (d->iter.start->expr_type != EXPR_CONSTANT + || d->iter.end->expr_type != EXPR_CONSTANT + || d->iter.step->expr_type != EXPR_CONSTANT) + gfc_internal_error ("resolve_data_variables(): Bad iterator"); + + if (resolve_data_variables (d->list) == FAILURE) + return FAILURE; + } + } + + return SUCCESS; +} + + +/* Resolve a single DATA statement. We implement this by storing a pointer to + the value list into static variables, and then recursively traversing the + variables list, expanding iterators and such. */ + +static void +resolve_data (gfc_data * d) +{ + + if (resolve_data_variables (d->var) == FAILURE) + return; + + values.vnode = d->value; + values.left = (d->value == NULL) ? 0 : d->value->repeat; + + if (traverse_data_var (d->var, &d->where) == FAILURE) + return; + + /* At this point, we better not have any values left. */ + + if (next_data_value () == SUCCESS) + gfc_error ("DATA statement at %L has more values than variables", + &d->where); +} + + +/* Determines if a variable is not 'pure', ie not assignable within a pure + procedure. Returns zero if assignment is OK, nonzero if there is a problem. + */ + +int +gfc_impure_variable (gfc_symbol * sym) +{ + + if (sym->attr.use_assoc || sym->attr.in_common) + return 1; + + if (sym->ns != gfc_current_ns) + return !sym->attr.function; + + /* TODO: Check storage association through EQUIVALENCE statements */ + + return 0; +} + + +/* Test whether a symbol is pure or not. For a NULL pointer, checks the + symbol of the current procedure. */ + +int +gfc_pure (gfc_symbol * sym) +{ + symbol_attribute attr; + + if (sym == NULL) + sym = gfc_current_ns->proc_name; + if (sym == NULL) + return 0; + + attr = sym->attr; + + return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental); +} + + +/* Test whether the current procedure is elemental or not. */ + +int +gfc_elemental (gfc_symbol * sym) +{ + symbol_attribute attr; + + if (sym == NULL) + sym = gfc_current_ns->proc_name; + if (sym == NULL) + return 0; + attr = sym->attr; + + return attr.flavor == FL_PROCEDURE && attr.elemental; +} + + +/* Warn about unused labels. */ + +static void +warn_unused_label (gfc_namespace * ns) +{ + gfc_st_label *l; + + l = ns->st_labels; + if (l == NULL) + return; + + while (l->next) + l = l->next; + + for (; l; l = l->prev) + { + if (l->defined == ST_LABEL_UNKNOWN) + continue; + + switch (l->referenced) + { + case ST_LABEL_UNKNOWN: + gfc_warning ("Label %d at %L defined but not used", l->value, + &l->where); + break; + + case ST_LABEL_BAD_TARGET: + gfc_warning ("Label %d at %L defined but cannot be used", l->value, + &l->where); + break; + + default: + break; + } + } +} + + +/* Resolve derived type EQUIVALENCE object. */ + +static try +resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) +{ + gfc_symbol *d; + gfc_component *c = derived->components; + + if (!derived) + return SUCCESS; + + /* Shall not be an object of nonsequence derived type. */ + if (!derived->attr.sequence) + { + gfc_error ("Derived type variable '%s' at %L must have SEQUENCE " + "attribute to be an EQUIVALENCE object", sym->name, &e->where); + return FAILURE; + } + + for (; c ; c = c->next) + { + d = c->ts.derived; + if (d && (resolve_equivalence_derived (c->ts.derived, sym, e) == FAILURE)) + return FAILURE; + + /* Shall not be an object of sequence derived type containing a pointer + in the structure. */ + if (c->pointer) + { + gfc_error ("Derived type variable '%s' at %L has pointer componet(s) " + "cannot be an EQUIVALENCE object", sym->name, &e->where); + return FAILURE; + } + } + return SUCCESS; +} + + +/* Resolve equivalence object. + An EQUIVALENCE object shall not be a dummy argument, a pointer, an + allocatable array, an object of nonsequence derived type, an object of + sequence derived type containing a pointer at any level of component + selection, an automatic object, a function name, an entry name, a result + name, a named constant, a structure component, or a subobject of any of + the preceding objects. */ + +static void +resolve_equivalence (gfc_equiv *eq) +{ + gfc_symbol *sym; + gfc_symbol *derived; + gfc_expr *e; + gfc_ref *r; + + for (; eq; eq = eq->eq) + { + e = eq->expr; + if (gfc_resolve_expr (e) == FAILURE) + continue; + + sym = e->symtree->n.sym; + + /* Shall not be a dummy argument. */ + if (sym->attr.dummy) + { + gfc_error ("Dummy argument '%s' at %L cannot be an EQUIVALENCE " + "object", sym->name, &e->where); + continue; + } + + /* Shall not be an allocatable array. */ + if (sym->attr.allocatable) + { + gfc_error ("Allocatable array '%s' at %L cannot be an EQUIVALENCE " + "object", sym->name, &e->where); + continue; + } + + /* Shall not be a pointer. */ + if (sym->attr.pointer) + { + gfc_error ("Pointer '%s' at %L cannot be an EQUIVALENCE object", + sym->name, &e->where); + continue; + } + + /* Shall not be a function name, ... */ + if (sym->attr.function || sym->attr.result || sym->attr.entry + || sym->attr.subroutine) + { + gfc_error ("Entity '%s' at %L cannot be an EQUIVALENCE object", + sym->name, &e->where); + continue; + } + + /* Shall not be a named constant. */ + if (e->expr_type == EXPR_CONSTANT) + { + gfc_error ("Named constant '%s' at %L cannot be an EQUIVALENCE " + "object", sym->name, &e->where); + continue; + } + + derived = e->ts.derived; + if (derived && resolve_equivalence_derived (derived, sym, e) == FAILURE) + continue; + + if (!e->ref) + continue; + + /* Shall not be an automatic array. */ + if (e->ref->type == REF_ARRAY + && gfc_resolve_array_spec (e->ref->u.ar.as, 1) == FAILURE) + { + gfc_error ("Array '%s' at %L with non-constant bounds cannot be " + "an EQUIVALENCE object", sym->name, &e->where); + continue; + } + + /* Shall not be a structure component. */ + r = e->ref; + while (r) + { + if (r->type == REF_COMPONENT) + { + gfc_error ("Structure component '%s' at %L cannot be an " + "EQUIVALENCE object", + r->u.c.component->name, &e->where); + break; + } + r = r->next; + } + } +} + + +/* This function is called after a complete program unit has been compiled. + Its purpose is to examine all of the expressions associated with a program + unit, assign types to all intermediate expressions, make sure that all + assignments are to compatible types and figure out which names refer to + which functions or subroutines. */ + +void +gfc_resolve (gfc_namespace * ns) +{ + gfc_namespace *old_ns, *n; + gfc_charlen *cl; + gfc_data *d; + gfc_equiv *eq; + + old_ns = gfc_current_ns; + gfc_current_ns = ns; + + resolve_contained_functions (ns); + + gfc_traverse_ns (ns, resolve_symbol); + + for (n = ns->contained; n; n = n->sibling) + { + if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name)) + gfc_error ("Contained procedure '%s' at %L of a PURE procedure must " + "also be PURE", n->proc_name->name, + &n->proc_name->declared_at); + + gfc_resolve (n); + } + + forall_flag = 0; + gfc_check_interfaces (ns); + + for (cl = ns->cl_list; cl; cl = cl->next) + { + if (cl->length == NULL || gfc_resolve_expr (cl->length) == FAILURE) + continue; + + if (cl->length->ts.type != BT_INTEGER) + gfc_error + ("Character length specification at %L must be of type INTEGER", + &cl->length->where); + } + + gfc_traverse_ns (ns, resolve_values); + + if (ns->save_all) + gfc_save_all (ns); + + iter_stack = NULL; + for (d = ns->data; d; d = d->next) + resolve_data (d); + + iter_stack = NULL; + gfc_traverse_ns (ns, gfc_formalize_init_value); + + for (eq = ns->equiv; eq; eq = eq->next) + resolve_equivalence (eq); + + cs_base = NULL; + resolve_code (ns->code, ns); + + /* Warn about unused labels. */ + if (gfc_option.warn_unused_labels) + warn_unused_label (ns); + + gfc_current_ns = old_ns; +} + diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c new file mode 100644 index 00000000000..c3e3acb8bf3 --- /dev/null +++ b/gcc/fortran/scanner.c @@ -0,0 +1,1073 @@ +/* Character scanner. + Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Set of subroutines to (ultimately) return the next character to the + various matching subroutines. This file's job is to read files and + build up lines that are parsed by the parser. This means that we + handle continuation lines and "include" lines. + + The first thing the scanner does is to load an entire file into + memory. We load the entire file into memory for a couple reasons. + The first is that we want to be able to deal with nonseekable input + (pipes, stdin) and there is a lot of backing up involved during + parsing. + + The second is that we want to be able to print the locus of errors, + and an error on line 999999 could conflict with something on line + one. Given nonseekable input, we've got to store the whole thing. + + One thing that helps are the column truncation limits that give us + an upper bound on the size of individual lines. We don't store the + truncated stuff. + + From the scanner's viewpoint, the higher level subroutines ask for + new characters and do a lot of jumping backwards. */ + +#include "config.h" +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <strings.h> + +#include "gfortran.h" + +/* Structure for holding module and include file search path. */ +typedef struct gfc_directorylist +{ + char *path; + struct gfc_directorylist *next; +} +gfc_directorylist; + +/* List of include file search directories. */ +static gfc_directorylist *include_dirs; + +static gfc_file *first_file, *first_duplicated_file; +static int continue_flag, end_flag; + +gfc_file *gfc_current_file; + + +/* Main scanner initialization. */ + +void +gfc_scanner_init_1 (void) +{ + + gfc_current_file = NULL; + first_file = NULL; + first_duplicated_file = NULL; + end_flag = 0; +} + + +/* Main scanner destructor. */ + +void +gfc_scanner_done_1 (void) +{ + + linebuf *lp, *lp2; + gfc_file *fp, *fp2; + + for (fp = first_file; fp; fp = fp2) + { + + if (fp->start != NULL) + { + /* Free linebuf blocks */ + for (fp2 = fp->next; fp2; fp2 = fp2->next) + if (fp->start == fp2->start) + fp2->start = NULL; + + for (lp = fp->start; lp; lp = lp2) + { + lp2 = lp->next; + gfc_free (lp); + } + } + + fp2 = fp->next; + gfc_free (fp); + } + + for (fp = first_duplicated_file; fp; fp = fp2) + { + fp2 = fp->next; + gfc_free (fp); + } +} + + +/* Adds path to the list pointed to by list. */ + +void +gfc_add_include_path (const char *path) +{ + gfc_directorylist *dir; + const char *p; + + p = path; + while (*p == ' ' || *p == '\t') /* someone might do 'gfortran "-I include"' */ + if (*p++ == '\0') + return; + + dir = include_dirs; + if (!dir) + { + dir = include_dirs = gfc_getmem (sizeof (gfc_directorylist)); + } + else + { + while (dir->next) + dir = dir->next; + + dir->next = gfc_getmem (sizeof (gfc_directorylist)); + dir = dir->next; + } + + dir->next = NULL; + dir->path = gfc_getmem (strlen (p) + 2); + strcpy (dir->path, p); + strcat (dir->path, "/"); /* make '/' last character */ +} + + +/* Release resources allocated for options. */ + +void +gfc_release_include_path (void) +{ + gfc_directorylist *p; + + gfc_free (gfc_option.module_dir); + while (include_dirs != NULL) + { + p = include_dirs; + include_dirs = include_dirs->next; + gfc_free (p->path); + gfc_free (p); + } +} + + +/* Opens file for reading, searching through the include directories + given if necessary. */ + +FILE * +gfc_open_included_file (const char *name) +{ + char fullname[PATH_MAX]; + gfc_directorylist *p; + FILE *f; + + f = gfc_open_file (name); + if (f != NULL) + return f; + + for (p = include_dirs; p; p = p->next) + { + if (strlen (p->path) + strlen (name) + 1 > PATH_MAX) + continue; + + strcpy (fullname, p->path); + strcat (fullname, name); + + f = gfc_open_file (fullname); + if (f != NULL) + return f; + } + + return NULL; +} + + +/* Return a pointer to the current locus. */ + +locus * +gfc_current_locus (void) +{ + + if (gfc_current_file == NULL) + return NULL; + return &gfc_current_file->loc; +} + + +/* Let a caller move the current read pointer (backwards). */ + +void +gfc_set_locus (locus * lp) +{ + + gfc_current_file->loc = *lp; +} + + +/* Test to see if we're at the end of the main source file. */ + +int +gfc_at_end (void) +{ + + return end_flag; +} + + +/* Test to see if we're at the end of the current file. */ + +int +gfc_at_eof (void) +{ + + if (gfc_at_end ()) + return 1; + + if (gfc_current_file->start->lines == 0) + return 1; /* Null file */ + + if (gfc_current_file->loc.lp == NULL) + return 1; + + return 0; +} + + +/* Test to see if we're at the beginning of a new line. */ + +int +gfc_at_bol (void) +{ + int i; + + if (gfc_at_eof ()) + return 1; + + i = gfc_current_file->loc.line; + + return gfc_current_file->loc.nextc == gfc_current_file->loc.lp->line[i]; +} + + +/* Test to see if we're at the end of a line. */ + +int +gfc_at_eol (void) +{ + + if (gfc_at_eof ()) + return 1; + + return *gfc_current_file->loc.nextc == '\0'; +} + + +/* Advance the current line pointer to the next line. */ + +void +gfc_advance_line (void) +{ + locus *locp; + linebuf *lp; + + if (gfc_at_end ()) + return; + + locp = &gfc_current_file->loc; + lp = locp->lp; + if (lp == NULL) + return; + + if (++locp->line >= lp->lines) + { + locp->lp = lp = lp->next; + if (lp == NULL) + return; /* End of this file */ + + locp->line = 0; + } + + locp->nextc = lp->line[locp->line]; +} + + +/* Get the next character from the input, advancing gfc_current_file's + locus. When we hit the end of the line or the end of the file, we + start returning a '\n' in order to complete the current statement. + No Fortran line conventions are implemented here. + + Requiring explicit advances to the next line prevents the parse + pointer from being on the wrong line if the current statement ends + prematurely. */ + +static int +next_char (void) +{ + locus *locp; + int c; + + /* End the current include level, but not if we're in the middle + of processing a continuation. */ + if (gfc_at_eof ()) + { + if (continue_flag != 0 || gfc_at_end ()) + return '\n'; + + if (gfc_current_file->included_by == NULL) + end_flag = 1; + + return '\n'; + } + + locp = &gfc_current_file->loc; + if (locp->nextc == NULL) + return '\n'; + + c = *locp->nextc++; + if (c == '\0') + { + locp->nextc--; /* Stay stuck on this line */ + c = '\n'; + } + + return c; +} + + +/* Checks the current line buffer to see if it is an include line. If + so, we load the new file and prepare to read from it. Include + lines happen at a lower level than regular parsing because the + string-matching subroutine is far simpler than the normal one. + + We never return a syntax error because a statement like "include = 5" + is perfectly legal. We return zero if no include was processed or + nonzero if we matched an include. */ + +int +gfc_check_include (void) +{ + char c, quote, path[PATH_MAX + 1]; + const char *include; + locus start; + int i; + + include = "include"; + + start = *gfc_current_locus (); + gfc_gobble_whitespace (); + + /* Match the 'include' */ + while (*include != '\0') + if (*include++ != gfc_next_char ()) + goto no_include; + + gfc_gobble_whitespace (); + + quote = next_char (); + if (quote != '"' && quote != '\'') + goto no_include; + + /* Copy the filename */ + for (i = 0;;) + { + c = next_char (); + if (c == '\n') + goto no_include; /* No close quote */ + if (c == quote) + break; + + /* This shouldn't happen-- PATH_MAX should be way longer than the + max line length. */ + + if (i >= PATH_MAX) + gfc_internal_error ("Pathname of include file is too long at %C"); + + path[i++] = c; + } + + path[i] = '\0'; + if (i == 0) + goto no_include; /* No filename! */ + + /* At this point, we've got a filename to be included. The rest + of the include line is ignored */ + + gfc_new_file (path, gfc_current_file->form); + return 1; + +no_include: + gfc_set_locus (&start); + return 0; +} + + +/* Skip a comment. When we come here the parse pointer is positioned + immediately after the comment character. If we ever implement + compiler directives withing comments, here is where we parse the + directive. */ + +static void +skip_comment_line (void) +{ + char c; + + do + { + c = next_char (); + } + while (c != '\n'); + + gfc_advance_line (); +} + + +/* Comment lines are null lines, lines containing only blanks or lines + on which the first nonblank line is a '!'. */ + +static void +skip_free_comments (void) +{ + locus start; + char c; + + for (;;) + { + start = *gfc_current_locus (); + if (gfc_at_eof ()) + break; + + do + { + c = next_char (); + } + while (gfc_is_whitespace (c)); + + if (c == '\n') + { + gfc_advance_line (); + continue; + } + + if (c == '!') + { + skip_comment_line (); + continue; + } + + break; + } + + gfc_set_locus (&start); +} + + +/* Skip comment lines in fixed source mode. We have the same rules as + in skip_free_comment(), except that we can have a 'c', 'C' or '*' + in column 1. and a '!' cannot be in* column 6. */ + +static void +skip_fixed_comments (void) +{ + locus start; + int col; + char c; + + for (;;) + { + start = *gfc_current_locus (); + if (gfc_at_eof ()) + break; + + c = next_char (); + if (c == '\n') + { + gfc_advance_line (); + continue; + } + + if (c == '!' || c == 'c' || c == 'C' || c == '*') + { + skip_comment_line (); + continue; + } + + col = 1; + do + { + c = next_char (); + col++; + } + while (gfc_is_whitespace (c)); + + if (c == '\n') + { + gfc_advance_line (); + continue; + } + + if (col != 6 && c == '!') + { + skip_comment_line (); + continue; + } + + break; + } + + gfc_set_locus (&start); +} + + +/* Skips the current line if it is a comment. Assumes that we are at + the start of the current line. */ + +void +gfc_skip_comments (void) +{ + + if (!gfc_at_bol () || gfc_current_file->form == FORM_FREE) + skip_free_comments (); + else + skip_fixed_comments (); +} + + +/* Get the next character from the input, taking continuation lines + and end-of-line comments into account. This implies that comment + lines between continued lines must be eaten here. For higher-level + subroutines, this flattens continued lines into a single logical + line. The in_string flag denotes whether we're inside a character + context or not. */ + +int +gfc_next_char_literal (int in_string) +{ + locus old_loc; + int i, c; + + continue_flag = 0; + +restart: + c = next_char (); + if (gfc_at_end ()) + return c; + + if (gfc_current_file->form == FORM_FREE) + { + + if (!in_string && c == '!') + { + /* This line can't be continued */ + do + { + c = next_char (); + } + while (c != '\n'); + + goto done; + } + + if (c != '&') + goto done; + + /* If the next nonblank character is a ! or \n, we've got a + continuation line. */ + old_loc = gfc_current_file->loc; + + c = next_char (); + while (gfc_is_whitespace (c)) + c = next_char (); + + /* Character constants to be continued cannot have commentary + after the '&'. */ + + if (in_string && c != '\n') + { + gfc_set_locus (&old_loc); + c = '&'; + goto done; + } + + if (c != '!' && c != '\n') + { + gfc_set_locus (&old_loc); + c = '&'; + goto done; + } + + continue_flag = 1; + if (c == '!') + skip_comment_line (); + else + gfc_advance_line (); + + /* We've got a continuation line and need to find where it continues. + First eat any comment lines. */ + gfc_skip_comments (); + + /* Now that we have a non-comment line, probe ahead for the + first non-whitespace character. If it is another '&', then + reading starts at the next character, otherwise we must back + up to where the whitespace started and resume from there. */ + + old_loc = *gfc_current_locus (); + + c = next_char (); + while (gfc_is_whitespace (c)) + c = next_char (); + + if (c != '&') + gfc_set_locus (&old_loc); + + } + else + { + /* Fixed form continuation. */ + if (!in_string && c == '!') + { + /* Skip comment at end of line. */ + do + { + c = next_char (); + } + while (c != '\n'); + } + + if (c != '\n') + goto done; + + continue_flag = 1; + old_loc = *gfc_current_locus (); + + gfc_advance_line (); + gfc_skip_comments (); + + /* See if this line is a continuation line. */ + for (i = 0; i < 5; i++) + { + c = next_char (); + if (c != ' ') + goto not_continuation; + } + + c = next_char (); + if (c == '0' || c == ' ') + goto not_continuation; + } + + /* Ready to read first character of continuation line, which might + be another continuation line! */ + goto restart; + +not_continuation: + c = '\n'; + gfc_set_locus (&old_loc); + +done: + continue_flag = 0; + return c; +} + + +/* Get the next character of input, folded to lowercase. In fixed + form mode, we also ignore spaces. When matcher subroutines are + parsing character literals, they have to call + gfc_next_char_literal(). */ + +int +gfc_next_char (void) +{ + int c; + + do + { + c = gfc_next_char_literal (0); + } + while (gfc_current_file->form == FORM_FIXED && gfc_is_whitespace (c)); + + return TOLOWER (c); +} + + +int +gfc_peek_char (void) +{ + locus old_loc; + int c; + + old_loc = *gfc_current_locus (); + c = gfc_next_char (); + gfc_set_locus (&old_loc); + + return c; +} + + +/* Recover from an error. We try to get past the current statement + and get lined up for the next. The next statement follows a '\n' + or a ';'. We also assume that we are not within a character + constant, and deal with finding a '\'' or '"'. */ + +void +gfc_error_recovery (void) +{ + char c, delim; + + if (gfc_at_eof ()) + return; + + for (;;) + { + c = gfc_next_char (); + if (c == '\n' || c == ';') + break; + + if (c != '\'' && c != '"') + { + if (gfc_at_eof ()) + break; + continue; + } + delim = c; + + for (;;) + { + c = next_char (); + + if (c == delim) + break; + if (c == '\n') + goto done; + if (c == '\\') + { + c = next_char (); + if (c == '\n') + goto done; + } + } + if (gfc_at_eof ()) + break; + } + +done: + if (c == '\n') + gfc_advance_line (); +} + + +/* Read ahead until the next character to be read is not whitespace. */ + +void +gfc_gobble_whitespace (void) +{ + locus old_loc; + int c; + + do + { + old_loc = *gfc_current_locus (); + c = gfc_next_char_literal (0); + } + while (gfc_is_whitespace (c)); + + gfc_set_locus (&old_loc); +} + + +/* Load a single line into the buffer. We truncate lines that are too + long. In fixed mode, we expand a tab that occurs within the + statement label region to expand to spaces that leave the next + character in the source region. */ + +static void +load_line (FILE * input, gfc_source_form form, char *buffer, + char *filename, int linenum) +{ + int c, maxlen, i, trunc_flag; + + maxlen = (form == FORM_FREE) ? 132 : gfc_option.fixed_line_length; + + i = 0; + + for (;;) + { + c = fgetc (input); + + if (c == EOF) + break; + if (c == '\n') + break; + + if (c == '\r') + continue; /* Gobble characters */ + if (c == '\0') + continue; + + if (form == FORM_FIXED && c == '\t' && i <= 6) + { /* Tab expandsion */ + while (i <= 6) + { + *buffer++ = ' '; + i++; + } + + continue; + } + + *buffer++ = c; + i++; + + if (i >= maxlen) + { /* Truncate the rest of the line */ + trunc_flag = 1; + + for (;;) + { + c = fgetc (input); + if (c == '\n' || c == EOF) + break; + + if (gfc_option.warn_line_truncation + && trunc_flag + && !gfc_is_whitespace (c)) + { + gfc_warning_now ("Line %d of %s is being truncated", + linenum, filename); + trunc_flag = 0; + } + } + + ungetc ('\n', input); + } + } + + *buffer = '\0'; +} + + +/* Load a file into memory by calling load_line until the file ends. */ + +static void +load_file (FILE * input, gfc_file * fp) +{ + char *linep, line[GFC_MAX_LINE + 1]; + int len, linenum; + linebuf *lp; + + fp->start = lp = gfc_getmem (sizeof (linebuf)); + + linenum = 1; + lp->lines = 0; + lp->start_line = 1; + lp->next = NULL; + + linep = (char *) (lp + 1); + + /* Load the file. */ + for (;;) + { + load_line (input, fp->form, line, fp->filename, linenum); + linenum++; + + len = strlen (line); + + if (feof (input) && len == 0) + break; + + /* See if we need another linebuf. */ + if (((char *) &lp->line[lp->lines + 2]) > linep - len - 1) + { + lp->next = gfc_getmem (sizeof (linebuf)); + + lp->next->start_line = lp->start_line + lp->lines; + lp = lp->next; + lp->lines = 0; + + linep = (char *) (lp + 1); + } + + linep = linep - len - 1; + lp->line[lp->lines++] = linep; + strcpy (linep, line); + } +} + + +/* Determine the source form from the filename extension. We assume + case insensitivity. */ + +static gfc_source_form +form_from_filename (const char *filename) +{ + + static const struct + { + const char *extension; + gfc_source_form form; + } + exttype[] = + { + { + ".f90", FORM_FREE} + , + { + ".f95", FORM_FREE} + , + { + ".f", FORM_FIXED} + , + { + ".for", FORM_FIXED} + , + { + "", FORM_UNKNOWN} + }; /* sentinel value */ + + gfc_source_form f_form; + const char *fileext; + int i; + + /* Find end of file name. */ + i = 0; + while ((i < PATH_MAX) && (filename[i] != '\0')) + i++; + + /* Improperly terminated or too-long filename. */ + if (i == PATH_MAX) + return FORM_UNKNOWN; + + /* Find last period. */ + while (i >= 0 && (filename[i] != '.')) + i--; + + /* Did we see a file extension? */ + if (i < 0) + return FORM_UNKNOWN; /* Nope */ + + /* Get file extension and compare it to others. */ + fileext = &(filename[i]); + + i = -1; + f_form = FORM_UNKNOWN; + do + { + i++; + if (strcasecmp (fileext, exttype[i].extension) == 0) + { + f_form = exttype[i].form; + break; + } + } + while (exttype[i].form != FORM_UNKNOWN); + + return f_form; +} + + +/* Open a new file and start scanning from that file. Every new file + gets a gfc_file node, even if it is a duplicate file. Returns SUCCESS + if everything went OK, FAILURE otherwise. */ + +try +gfc_new_file (const char *filename, gfc_source_form form) +{ + gfc_file *fp, *fp2; + FILE *input; + int len; + + len = strlen (filename); + if (len > PATH_MAX) + { + gfc_error_now ("Filename '%s' is too long- ignoring it", filename); + return FAILURE; + } + + fp = gfc_getmem (sizeof (gfc_file)); + + /* Make sure this file isn't being included recursively. */ + for (fp2 = gfc_current_file; fp2; fp2 = fp2->included_by) + if (strcmp (filename, fp2->filename) == 0) + { + gfc_error_now ("Recursive inclusion of file '%s' at %C- ignoring it", + filename); + gfc_free (fp); + return FAILURE; + } + + /* See if the file has already been included. */ + for (fp2 = first_file; fp2; fp2 = fp2->next) + if (strcmp (filename, fp2->filename) == 0) + { + *fp = *fp2; + fp->next = first_duplicated_file; + first_duplicated_file = fp; + goto init_fp; + } + + strcpy (fp->filename, filename); + + if (gfc_current_file == NULL) + input = gfc_open_file (filename); + else + input = gfc_open_included_file (filename); + + if (input == NULL) + { + if (gfc_current_file == NULL) + gfc_error_now ("Can't open file '%s'", filename); + else + gfc_error_now ("Can't open file '%s' included at %C", filename); + + gfc_free (fp); + return FAILURE; + } + + /* Decide which form the file will be read in as. */ + if (form != FORM_UNKNOWN) + fp->form = form; + else + { + fp->form = form_from_filename (filename); + + if (fp->form == FORM_UNKNOWN) + { + fp->form = FORM_FREE; + gfc_warning_now ("Reading file %s as free form", filename); + } + } + + fp->next = first_file; + first_file = fp; + + load_file (input, fp); + fclose (input); + +init_fp: + fp->included_by = gfc_current_file; + gfc_current_file = fp; + + fp->loc.line = 0; + fp->loc.lp = fp->start; + fp->loc.nextc = fp->start->line[0]; + fp->loc.file = fp; + + return SUCCESS; +} diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c new file mode 100644 index 00000000000..876eb2fdaf1 --- /dev/null +++ b/gcc/fortran/simplify.c @@ -0,0 +1,4008 @@ +/* Simplify intrinsic functions at compile-time. + Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc. + Contributed by Andy Vaught & Katherine Holcomb + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include "config.h" +#include "system.h" +#include "flags.h" + +#include <string.h> + +#include "gfortran.h" +#include "arith.h" +#include "intrinsic.h" + +static mpf_t mpf_zero, mpf_half, mpf_one; +static mpz_t mpz_zero; + +gfc_expr gfc_bad_expr; + + +/* Note that 'simplification' is not just transforming expressions. + For functions that are not simplified at compile time, range + checking is done if possible. + + The return convention is that each simplification function returns: + + A new expression node corresponding to the simplified arguments. + The original arguments are destroyed by the caller, and must not + be a part of the new expression. + + NULL pointer indicating that no simplification was possible and + the original expression should remain intact. If the + simplification function sets the type and/or the function name + via the pointer gfc_simple_expression, then this type is + retained. + + An expression pointer to gfc_bad_expr (a static placeholder) + indicating that some error has prevented simplification. For + example, sqrt(-1.0). The error is generated within the function + and should be propagated upwards + + By the time a simplification function gets control, it has been + decided that the function call is really supposed to be the + intrinsic. No type checking is strictly necessary, since only + valid types will be passed on. On the other hand, a simplification + subroutine may have to look at the type of an argument as part of + its processing. + + Array arguments are never passed to these subroutines. + + The functions in this file don't have much comment with them, but + everything is reasonably straight-forward. The Standard, chapter 13 + is the best comment you'll find for this file anyway. */ + +/* Static table for converting non-ascii character sets to ascii. + The xascii_table[] is the inverse table. */ + +static int ascii_table[256] = { + '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', + '\b', '\t', '\n', '\v', '\0', '\r', '\0', '\0', + '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', + '\0', '\0', '\0', '\0', '\0', '\0', '\0', '\0', + ' ', '!', '\'', '#', '$', '%', '&', '\'', + '(', ')', '*', '+', ',', '-', '.', '/', + '0', '1', '2', '3', '4', '5', '6', '7', + '8', '9', ':', ';', '<', '=', '>', '?', + '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G', + 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', + 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', + 'X', 'Y', 'Z', '[', '\\', ']', '^', '_', + '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g', + 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', + 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', + 'x', 'y', 'z', '{', '|', '}', '~', '\?' +}; + +static int xascii_table[256]; + + +/* Range checks an expression node. If all goes well, returns the + node, otherwise returns &gfc_bad_expr and frees the node. */ + +static gfc_expr * +range_check (gfc_expr * result, const char *name) +{ + + if (gfc_range_check (result) == ARITH_OK) + return result; + + gfc_error ("Result of %s overflows its kind at %L", name, &result->where); + gfc_free_expr (result); + return &gfc_bad_expr; +} + + +/* A helper function that gets an optional and possibly missing + kind parameter. Returns the kind, -1 if something went wrong. */ + +static int +get_kind (bt type, gfc_expr * k, const char *name, int default_kind) +{ + int kind; + + if (k == NULL) + return default_kind; + + if (k->expr_type != EXPR_CONSTANT) + { + gfc_error ("KIND parameter of %s at %L must be an initialization " + "expression", name, &k->where); + + return -1; + } + + if (gfc_extract_int (k, &kind) != NULL + || gfc_validate_kind (type, kind) == -1) + { + + gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where); + return -1; + } + + return kind; +} + + +/********************** Simplification functions *****************************/ + +gfc_expr * +gfc_simplify_abs (gfc_expr * e) +{ + gfc_expr *result; + mpf_t a, b; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + switch (e->ts.type) + { + case BT_INTEGER: + result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where); + + mpz_abs (result->value.integer, e->value.integer); + + result = range_check (result, "IABS"); + break; + + case BT_REAL: + result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); + + mpf_abs (result->value.real, e->value.real); + + result = range_check (result, "ABS"); + break; + + case BT_COMPLEX: + result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); + + mpf_init (a); + mpf_mul (a, e->value.complex.r, e->value.complex.r); + + mpf_init (b); + mpf_mul (b, e->value.complex.i, e->value.complex.i); + + mpf_add (a, a, b); + mpf_sqrt (result->value.real, a); + + mpf_clear (a); + mpf_clear (b); + + result = range_check (result, "CABS"); + break; + + default: + gfc_internal_error ("gfc_simplify_abs(): Bad type"); + } + + return result; +} + + +gfc_expr * +gfc_simplify_achar (gfc_expr * e) +{ + gfc_expr *result; + int index; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + /* We cannot assume that the native character set is ASCII in this + function. */ + if (gfc_extract_int (e, &index) != NULL || index < 0 || index > 127) + { + gfc_error ("Extended ASCII not implemented: argument of ACHAR at %L " + "must be between 0 and 127", &e->where); + return &gfc_bad_expr; + } + + result = gfc_constant_result (BT_CHARACTER, gfc_default_character_kind (), + &e->where); + + result->value.character.string = gfc_getmem (2); + + result->value.character.length = 1; + result->value.character.string[0] = ascii_table[index]; + result->value.character.string[1] = '\0'; /* For debugger */ + return result; +} + + +gfc_expr * +gfc_simplify_acos (gfc_expr * x) +{ + gfc_expr *result; + mpf_t negative, square, term; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpf_cmp_si (x->value.real, 1) > 0 || mpf_cmp_si (x->value.real, -1) < 0) + { + gfc_error ("Argument of ACOS at %L must be between -1 and 1", + &x->where); + return &gfc_bad_expr; + } + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + if (mpf_cmp_si (x->value.real, 1) == 0) + { + mpf_set_ui (result->value.real, 0); + return range_check (result, "ACOS"); + } + + if (mpf_cmp_si (x->value.real, -1) == 0) + { + mpf_set (result->value.real, pi); + return range_check (result, "ACOS"); + } + + mpf_init (negative); + mpf_init (square); + mpf_init (term); + + mpf_pow_ui (square, x->value.real, 2); + mpf_ui_sub (term, 1, square); + mpf_sqrt (term, term); + mpf_div (term, x->value.real, term); + mpf_neg (term, term); + arctangent (&term, &negative); + mpf_add (result->value.real, half_pi, negative); + + mpf_clear (negative); + mpf_clear (square); + mpf_clear (term); + + return range_check (result, "ACOS"); +} + + +gfc_expr * +gfc_simplify_adjustl (gfc_expr * e) +{ + gfc_expr *result; + int count, i, len; + char ch; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + len = e->value.character.length; + + result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); + + result->value.character.length = len; + result->value.character.string = gfc_getmem (len + 1); + + for (count = 0, i = 0; i < len; ++i) + { + ch = e->value.character.string[i]; + if (ch != ' ') + break; + ++count; + } + + for (i = 0; i < len - count; ++i) + { + result->value.character.string[i] = + e->value.character.string[count + i]; + } + + for (i = len - count; i < len; ++i) + { + result->value.character.string[i] = ' '; + } + + result->value.character.string[len] = '\0'; /* For debugger */ + + return result; +} + + +gfc_expr * +gfc_simplify_adjustr (gfc_expr * e) +{ + gfc_expr *result; + int count, i, len; + char ch; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + len = e->value.character.length; + + result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); + + result->value.character.length = len; + result->value.character.string = gfc_getmem (len + 1); + + for (count = 0, i = len - 1; i >= 0; --i) + { + ch = e->value.character.string[i]; + if (ch != ' ') + break; + ++count; + } + + for (i = 0; i < count; ++i) + { + result->value.character.string[i] = ' '; + } + + for (i = count; i < len; ++i) + { + result->value.character.string[i] = + e->value.character.string[i - count]; + } + + result->value.character.string[len] = '\0'; /* For debugger */ + + return result; +} + + +gfc_expr * +gfc_simplify_aimag (gfc_expr * e) +{ + gfc_expr *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); + mpf_set (result->value.real, e->value.complex.i); + + return range_check (result, "AIMAG"); +} + + +gfc_expr * +gfc_simplify_aint (gfc_expr * e, gfc_expr * k) +{ + gfc_expr *rtrunc, *result; + int kind; + + kind = get_kind (BT_REAL, k, "AINT", e->ts.kind); + if (kind == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + rtrunc = gfc_copy_expr (e); + + mpf_trunc (rtrunc->value.real, e->value.real); + + result = gfc_real2real (rtrunc, kind); + gfc_free_expr (rtrunc); + + return range_check (result, "AINT"); +} + + +gfc_expr * +gfc_simplify_dint (gfc_expr * e) +{ + gfc_expr *rtrunc, *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + rtrunc = gfc_copy_expr (e); + + mpf_trunc (rtrunc->value.real, e->value.real); + + result = gfc_real2real (rtrunc, gfc_default_double_kind ()); + gfc_free_expr (rtrunc); + + return range_check (result, "DINT"); + +} + + +gfc_expr * +gfc_simplify_anint (gfc_expr * e, gfc_expr * k) +{ + gfc_expr *rtrunc, *result; + int kind, cmp; + + kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind); + if (kind == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (e->ts.type, kind, &e->where); + + rtrunc = gfc_copy_expr (e); + + cmp = mpf_cmp_ui (e->value.real, 0); + + if (cmp > 0) + { + mpf_add (rtrunc->value.real, e->value.real, mpf_half); + mpf_trunc (result->value.real, rtrunc->value.real); + } + else if (cmp < 0) + { + mpf_sub (rtrunc->value.real, e->value.real, mpf_half); + mpf_trunc (result->value.real, rtrunc->value.real); + } + else + mpf_set_ui (result->value.real, 0); + + gfc_free_expr (rtrunc); + + return range_check (result, "ANINT"); +} + + +gfc_expr * +gfc_simplify_dnint (gfc_expr * e) +{ + gfc_expr *rtrunc, *result; + int cmp; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = + gfc_constant_result (BT_REAL, gfc_default_double_kind (), &e->where); + + rtrunc = gfc_copy_expr (e); + + cmp = mpf_cmp_ui (e->value.real, 0); + + if (cmp > 0) + { + mpf_add (rtrunc->value.real, e->value.real, mpf_half); + mpf_trunc (result->value.real, rtrunc->value.real); + } + else if (cmp < 0) + { + mpf_sub (rtrunc->value.real, e->value.real, mpf_half); + mpf_trunc (result->value.real, rtrunc->value.real); + } + else + mpf_set_ui (result->value.real, 0); + + gfc_free_expr (rtrunc); + + return range_check (result, "DNINT"); +} + + +gfc_expr * +gfc_simplify_asin (gfc_expr * x) +{ + gfc_expr *result; + mpf_t negative, square, term; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpf_cmp_si (x->value.real, 1) > 0 || mpf_cmp_si (x->value.real, -1) < 0) + { + gfc_error ("Argument of ASIN at %L must be between -1 and 1", + &x->where); + return &gfc_bad_expr; + } + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + if (mpf_cmp_si (x->value.real, 1) == 0) + { + mpf_set (result->value.real, half_pi); + return range_check (result, "ASIN"); + } + + if (mpf_cmp_si (x->value.real, -1) == 0) + { + mpf_init (negative); + mpf_neg (negative, half_pi); + mpf_set (result->value.real, negative); + mpf_clear (negative); + return range_check (result, "ASIN"); + } + + mpf_init (square); + mpf_init (term); + + mpf_pow_ui (square, x->value.real, 2); + mpf_ui_sub (term, 1, square); + mpf_sqrt (term, term); + mpf_div (term, x->value.real, term); + arctangent (&term, &result->value.real); + + mpf_clear (square); + mpf_clear (term); + + return range_check (result, "ASIN"); +} + + +gfc_expr * +gfc_simplify_atan (gfc_expr * x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + arctangent (&x->value.real, &result->value.real); + + return range_check (result, "ATAN"); + +} + + +gfc_expr * +gfc_simplify_atan2 (gfc_expr * y, gfc_expr * x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + + if (mpf_sgn (y->value.real) == 0 && mpf_sgn (x->value.real) == 0) + { + gfc_error + ("If first argument of ATAN2 %L is zero, the second argument " + "must not be zero", &x->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + arctangent2 (&y->value.real, &x->value.real, &result->value.real); + + return range_check (result, "ATAN2"); + +} + + +gfc_expr * +gfc_simplify_bit_size (gfc_expr * e) +{ + gfc_expr *result; + int i; + + i = gfc_validate_kind (e->ts.type, e->ts.kind); + if (i == -1) + gfc_internal_error ("In gfc_simplify_bit_size(): Bad kind"); + + result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where); + mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size); + + return result; +} + + +gfc_expr * +gfc_simplify_btest (gfc_expr * e, gfc_expr * bit) +{ + int b; + + if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT) + return NULL; + + if (gfc_extract_int (bit, &b) != NULL || b < 0) + return gfc_logical_expr (0, &e->where); + + return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where); +} + + +gfc_expr * +gfc_simplify_ceiling (gfc_expr * e, gfc_expr * k) +{ + gfc_expr *ceil, *result; + int kind; + + kind = get_kind (BT_REAL, k, "CEILING", gfc_default_real_kind ()); + if (kind == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (BT_INTEGER, kind, &e->where); + + ceil = gfc_copy_expr (e); + + mpf_ceil (ceil->value.real, e->value.real); + mpz_set_f (result->value.integer, ceil->value.real); + + gfc_free_expr (ceil); + + return range_check (result, "CEILING"); +} + + +gfc_expr * +gfc_simplify_char (gfc_expr * e, gfc_expr * k) +{ + gfc_expr *result; + int c, kind; + + kind = get_kind (BT_CHARACTER, k, "CHAR", gfc_default_character_kind ()); + if (kind == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + if (gfc_extract_int (e, &c) != NULL || c < 0 || c > 255) + { + gfc_error ("Bad character in CHAR function at %L", &e->where); + return &gfc_bad_expr; + } + + result = gfc_constant_result (BT_CHARACTER, kind, &e->where); + + result->value.character.length = 1; + result->value.character.string = gfc_getmem (2); + + result->value.character.string[0] = c; + result->value.character.string[1] = '\0'; /* For debugger */ + + return result; +} + + +/* Common subroutine for simplifying CMPLX and DCMPLX. */ + +static gfc_expr * +simplify_cmplx (const char *name, gfc_expr * x, gfc_expr * y, int kind) +{ + gfc_expr *result; + + result = gfc_constant_result (BT_COMPLEX, kind, &x->where); + + mpf_set_ui (result->value.complex.i, 0); + + switch (x->ts.type) + { + case BT_INTEGER: + mpf_set_z (result->value.complex.r, x->value.integer); + break; + + case BT_REAL: + mpf_set (result->value.complex.r, x->value.real); + break; + + case BT_COMPLEX: + mpf_set (result->value.complex.r, x->value.complex.r); + mpf_set (result->value.complex.i, x->value.complex.i); + break; + + default: + gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)"); + } + + if (y != NULL) + { + switch (y->ts.type) + { + case BT_INTEGER: + mpf_set_z (result->value.complex.i, y->value.integer); + break; + + case BT_REAL: + mpf_set (result->value.complex.i, y->value.real); + break; + + default: + gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)"); + } + } + + return range_check (result, name); +} + + +gfc_expr * +gfc_simplify_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * k) +{ + int kind; + + if (x->expr_type != EXPR_CONSTANT + || (y != NULL && y->expr_type != EXPR_CONSTANT)) + return NULL; + + kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind ()); + if (kind == -1) + return &gfc_bad_expr; + + return simplify_cmplx ("CMPLX", x, y, kind); +} + + +gfc_expr * +gfc_simplify_conjg (gfc_expr * e) +{ + gfc_expr *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_copy_expr (e); + mpf_neg (result->value.complex.i, result->value.complex.i); + + return range_check (result, "CONJG"); +} + + +gfc_expr * +gfc_simplify_cos (gfc_expr * x) +{ + gfc_expr *result; + mpf_t xp, xq; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + cosine (&x->value.real, &result->value.real); + break; + case BT_COMPLEX: + mpf_init (xp); + mpf_init (xq); + + cosine (&x->value.complex.r, &xp); + hypercos (&x->value.complex.i, &xq); + mpf_mul (result->value.complex.r, xp, xq); + + sine (&x->value.complex.r, &xp); + hypersine (&x->value.complex.i, &xq); + mpf_mul (xp, xp, xq); + mpf_neg (result->value.complex.i, xp); + + mpf_clear (xp); + mpf_clear (xq); + break; + default: + gfc_internal_error ("in gfc_simplify_cos(): Bad type"); + } + + return range_check (result, "COS"); + +} + + +gfc_expr * +gfc_simplify_cosh (gfc_expr * x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + hypercos (&x->value.real, &result->value.real); + + return range_check (result, "COSH"); +} + + +gfc_expr * +gfc_simplify_dcmplx (gfc_expr * x, gfc_expr * y) +{ + + if (x->expr_type != EXPR_CONSTANT + || (y != NULL && y->expr_type != EXPR_CONSTANT)) + return NULL; + + return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind ()); +} + + +gfc_expr * +gfc_simplify_dble (gfc_expr * e) +{ + gfc_expr *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + switch (e->ts.type) + { + case BT_INTEGER: + result = gfc_int2real (e, gfc_default_double_kind ()); + break; + + case BT_REAL: + result = gfc_real2real (e, gfc_default_double_kind ()); + break; + + case BT_COMPLEX: + result = gfc_complex2real (e, gfc_default_double_kind ()); + break; + + default: + gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where); + } + + return range_check (result, "DBLE"); +} + + +gfc_expr * +gfc_simplify_digits (gfc_expr * x) +{ + int i, digits; + + i = gfc_validate_kind (x->ts.type, x->ts.kind); + if (i == -1) + goto bad; + + switch (x->ts.type) + { + case BT_INTEGER: + digits = gfc_integer_kinds[i].digits; + break; + + case BT_REAL: + case BT_COMPLEX: + digits = gfc_real_kinds[i].digits; + break; + + default: + bad: + gfc_internal_error ("gfc_simplify_digits(): Bad type"); + } + + return gfc_int_expr (digits); +} + + +gfc_expr * +gfc_simplify_dim (gfc_expr * x, gfc_expr * y) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_INTEGER: + if (mpz_cmp (x->value.integer, y->value.integer) > 0) + mpz_sub (result->value.integer, x->value.integer, y->value.integer); + else + mpz_set (result->value.integer, mpz_zero); + + break; + + case BT_REAL: + if (mpf_cmp (x->value.real, y->value.real) > 0) + mpf_sub (result->value.real, x->value.real, y->value.real); + else + mpf_set (result->value.real, mpf_zero); + + break; + + default: + gfc_internal_error ("gfc_simplify_dim(): Bad type"); + } + + return range_check (result, "DIM"); +} + + +gfc_expr * +gfc_simplify_dprod (gfc_expr * x, gfc_expr * y) +{ + gfc_expr *mult1, *mult2, *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = + gfc_constant_result (BT_REAL, gfc_default_double_kind (), &x->where); + + mult1 = gfc_real2real (x, gfc_default_double_kind ()); + mult2 = gfc_real2real (y, gfc_default_double_kind ()); + + mpf_mul (result->value.real, mult1->value.real, mult2->value.real); + + gfc_free_expr (mult1); + gfc_free_expr (mult2); + + return range_check (result, "DPROD"); +} + + +gfc_expr * +gfc_simplify_epsilon (gfc_expr * e) +{ + gfc_expr *result; + int i; + + i = gfc_validate_kind (e->ts.type, e->ts.kind); + if (i == -1) + gfc_internal_error ("gfc_simplify_epsilon(): Bad kind"); + + result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); + + mpf_set (result->value.real, gfc_real_kinds[i].epsilon); + + return range_check (result, "EPSILON"); +} + + +gfc_expr * +gfc_simplify_exp (gfc_expr * x) +{ + gfc_expr *result; + mpf_t xp, xq; + double ln2, absval, rhuge; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + /* Exactitude doesn't matter here */ + ln2 = .6931472; + rhuge = ln2 * mpz_get_d (gfc_integer_kinds[0].huge); + + switch (x->ts.type) + { + case BT_REAL: + absval = mpf_get_d (x->value.real); + if (absval < 0) + absval = -absval; + if (absval > rhuge) + { + /* Underflow (set arg to zero) if x is negative and its + magnitude is greater than the maximum C long int times + ln2, because the exponential method in arith.c will fail + for such values. */ + if (mpf_cmp_ui (x->value.real, 0) < 0) + { + if (pedantic == 1) + gfc_warning_now + ("Argument of EXP at %L is negative and too large, " + "setting result to zero", &x->where); + mpf_set_ui (result->value.real, 0); + return range_check (result, "EXP"); + } + /* Overflow if magnitude of x is greater than C long int + huge times ln2. */ + else + { + gfc_error ("Argument of EXP at %L too large", &x->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + } + exponential (&x->value.real, &result->value.real); + break; + + case BT_COMPLEX: + /* Using Euler's formula. */ + absval = mpf_get_d (x->value.complex.r); + if (absval < 0) + absval = -absval; + if (absval > rhuge) + { + if (mpf_cmp_ui (x->value.complex.r, 0) < 0) + { + if (pedantic == 1) + gfc_warning_now + ("Real part of argument of EXP at %L is negative " + "and too large, setting result to zero", &x->where); + + mpf_set_ui (result->value.complex.r, 0); + mpf_set_ui (result->value.complex.i, 0); + return range_check (result, "EXP"); + } + else + { + gfc_error ("Real part of argument of EXP at %L too large", + &x->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + } + mpf_init (xp); + mpf_init (xq); + exponential (&x->value.complex.r, &xq); + cosine (&x->value.complex.i, &xp); + mpf_mul (result->value.complex.r, xq, xp); + sine (&x->value.complex.i, &xp); + mpf_mul (result->value.complex.i, xq, xp); + mpf_clear (xp); + mpf_clear (xq); + break; + + default: + gfc_internal_error ("in gfc_simplify_exp(): Bad type"); + } + + return range_check (result, "EXP"); +} + + +gfc_expr * +gfc_simplify_exponent (gfc_expr * x) +{ + mpf_t i2, absv, ln2, lnx; + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (), + &x->where); + + if (mpf_cmp (x->value.real, mpf_zero) == 0) + { + mpz_set_ui (result->value.integer, 0); + return result; + } + + mpf_init_set_ui (i2, 2); + mpf_init (absv); + mpf_init (ln2); + mpf_init (lnx); + + natural_logarithm (&i2, &ln2); + + mpf_abs (absv, x->value.real); + natural_logarithm (&absv, &lnx); + + mpf_div (lnx, lnx, ln2); + mpf_trunc (lnx, lnx); + mpf_add_ui (lnx, lnx, 1); + mpz_set_f (result->value.integer, lnx); + + mpf_clear (i2); + mpf_clear (ln2); + mpf_clear (lnx); + mpf_clear (absv); + + return range_check (result, "EXPONENT"); +} + + +gfc_expr * +gfc_simplify_float (gfc_expr * a) +{ + gfc_expr *result; + + if (a->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_int2real (a, gfc_default_real_kind ()); + return range_check (result, "FLOAT"); +} + + +gfc_expr * +gfc_simplify_floor (gfc_expr * e, gfc_expr * k) +{ + gfc_expr *result; + mpf_t floor; + int kind; + + kind = get_kind (BT_REAL, k, "FLOOR", gfc_default_real_kind ()); + if (kind == -1) + gfc_internal_error ("gfc_simplify_floor(): Bad kind"); + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (BT_INTEGER, kind, &e->where); + + mpf_init (floor); + mpf_floor (floor, e->value.real); + mpz_set_f (result->value.integer, floor); + mpf_clear (floor); + + return range_check (result, "FLOOR"); +} + + +gfc_expr * +gfc_simplify_fraction (gfc_expr * x) +{ + gfc_expr *result; + mpf_t i2, absv, ln2, lnx, pow2; + unsigned long exp2; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where); + + if (mpf_cmp (x->value.real, mpf_zero) == 0) + { + mpf_set (result->value.real, mpf_zero); + return result; + } + + mpf_init_set_ui (i2, 2); + mpf_init (absv); + mpf_init (ln2); + mpf_init (lnx); + mpf_init (pow2); + + natural_logarithm (&i2, &ln2); + + mpf_abs (absv, x->value.real); + natural_logarithm (&absv, &lnx); + + mpf_div (lnx, lnx, ln2); + mpf_trunc (lnx, lnx); + mpf_add_ui (lnx, lnx, 1); + + exp2 = (unsigned long) mpf_get_d (lnx); + mpf_pow_ui (pow2, i2, exp2); + + mpf_div (result->value.real, absv, pow2); + + mpf_clear (i2); + mpf_clear (ln2); + mpf_clear (absv); + mpf_clear (lnx); + mpf_clear (pow2); + + return range_check (result, "FRACTION"); +} + + +gfc_expr * +gfc_simplify_huge (gfc_expr * e) +{ + gfc_expr *result; + int i; + + i = gfc_validate_kind (e->ts.type, e->ts.kind); + if (i == -1) + goto bad_type; + + result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where); + + switch (e->ts.type) + { + case BT_INTEGER: + mpz_set (result->value.integer, gfc_integer_kinds[i].huge); + break; + + case BT_REAL: + mpf_set (result->value.real, gfc_real_kinds[i].huge); + break; + + bad_type: + default: + gfc_internal_error ("gfc_simplify_huge(): Bad type"); + } + + return result; +} + + +gfc_expr * +gfc_simplify_iachar (gfc_expr * e) +{ + gfc_expr *result; + int index; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + if (e->value.character.length != 1) + { + gfc_error ("Argument of IACHAR at %L must be of length one", &e->where); + return &gfc_bad_expr; + } + + index = xascii_table[(int) e->value.character.string[0] & 0xFF]; + + result = gfc_int_expr (index); + result->where = e->where; + + return range_check (result, "IACHAR"); +} + + +gfc_expr * +gfc_simplify_iand (gfc_expr * x, gfc_expr * y) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where); + + mpz_and (result->value.integer, x->value.integer, y->value.integer); + + return range_check (result, "IAND"); +} + + +gfc_expr * +gfc_simplify_ibclr (gfc_expr * x, gfc_expr * y) +{ + gfc_expr *result; + int k, pos; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + if (gfc_extract_int (y, &pos) != NULL || pos < 0) + { + gfc_error ("Invalid second argument of IBCLR at %L", &y->where); + return &gfc_bad_expr; + } + + k = gfc_validate_kind (x->ts.type, x->ts.kind); + if (k == -1) + gfc_internal_error ("gfc_simplify_ibclr(): Bad kind"); + + if (pos > gfc_integer_kinds[k].bit_size) + { + gfc_error ("Second argument of IBCLR exceeds bit size at %L", + &y->where); + return &gfc_bad_expr; + } + + result = gfc_copy_expr (x); + + mpz_clrbit (result->value.integer, pos); + return range_check (result, "IBCLR"); +} + + +gfc_expr * +gfc_simplify_ibits (gfc_expr * x, gfc_expr * y, gfc_expr * z) +{ + gfc_expr *result; + int pos, len; + int i, k, bitsize; + int *bits; + + if (x->expr_type != EXPR_CONSTANT + || y->expr_type != EXPR_CONSTANT + || z->expr_type != EXPR_CONSTANT) + return NULL; + + if (gfc_extract_int (y, &pos) != NULL || pos < 0) + { + gfc_error ("Invalid second argument of IBITS at %L", &y->where); + return &gfc_bad_expr; + } + + if (gfc_extract_int (z, &len) != NULL || len < 0) + { + gfc_error ("Invalid third argument of IBITS at %L", &z->where); + return &gfc_bad_expr; + } + + k = gfc_validate_kind (BT_INTEGER, x->ts.kind); + if (k == -1) + gfc_internal_error ("gfc_simplify_ibits(): Bad kind"); + + bitsize = gfc_integer_kinds[k].bit_size; + + if (pos + len > bitsize) + { + gfc_error + ("Sum of second and third arguments of IBITS exceeds bit size " + "at %L", &y->where); + return &gfc_bad_expr; + } + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + bits = gfc_getmem (bitsize * sizeof (int)); + + for (i = 0; i < bitsize; i++) + bits[i] = 0; + + for (i = 0; i < len; i++) + bits[i] = mpz_tstbit (x->value.integer, i + pos); + + for (i = 0; i < bitsize; i++) + { + if (bits[i] == 0) + { + mpz_clrbit (result->value.integer, i); + } + else if (bits[i] == 1) + { + mpz_setbit (result->value.integer, i); + } + else + { + gfc_internal_error ("IBITS: Bad bit"); + } + } + + gfc_free (bits); + + return range_check (result, "IBITS"); +} + + +gfc_expr * +gfc_simplify_ibset (gfc_expr * x, gfc_expr * y) +{ + gfc_expr *result; + int k, pos; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + if (gfc_extract_int (y, &pos) != NULL || pos < 0) + { + gfc_error ("Invalid second argument of IBSET at %L", &y->where); + return &gfc_bad_expr; + } + + k = gfc_validate_kind (x->ts.type, x->ts.kind); + if (k == -1) + gfc_internal_error ("gfc_simplify_ibset(): Bad kind"); + + if (pos > gfc_integer_kinds[k].bit_size) + { + gfc_error ("Second argument of IBSET exceeds bit size at %L", + &y->where); + return &gfc_bad_expr; + } + + result = gfc_copy_expr (x); + + mpz_setbit (result->value.integer, pos); + return range_check (result, "IBSET"); +} + + +gfc_expr * +gfc_simplify_ichar (gfc_expr * e) +{ + gfc_expr *result; + int index; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + if (e->value.character.length != 1) + { + gfc_error ("Argument of ICHAR at %L must be of length one", &e->where); + return &gfc_bad_expr; + } + + index = (int) e->value.character.string[0]; + + if (index < CHAR_MIN || index > CHAR_MAX) + { + gfc_error ("Argument of ICHAR at %L out of range of this processor", + &e->where); + return &gfc_bad_expr; + } + + result = gfc_int_expr (index); + result->where = e->where; + return range_check (result, "ICHAR"); +} + + +gfc_expr * +gfc_simplify_ieor (gfc_expr * x, gfc_expr * y) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where); + + mpz_xor (result->value.integer, x->value.integer, y->value.integer); + + return range_check (result, "IEOR"); +} + + +gfc_expr * +gfc_simplify_index (gfc_expr * x, gfc_expr * y, gfc_expr * b) +{ + gfc_expr *result; + int back, len, lensub; + int i, j, k, count, index = 0, start; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + if (b != NULL && b->value.logical != 0) + back = 1; + else + back = 0; + + result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (), + &x->where); + + len = x->value.character.length; + lensub = y->value.character.length; + + if (len < lensub) + { + mpz_set_si (result->value.integer, 0); + return result; + } + + if (back == 0) + { + + if (lensub == 0) + { + mpz_set_si (result->value.integer, 1); + return result; + } + else if (lensub == 1) + { + for (i = 0; i < len; i++) + { + for (j = 0; j < lensub; j++) + { + if (y->value.character.string[j] == + x->value.character.string[i]) + { + index = i + 1; + goto done; + } + } + } + } + else + { + for (i = 0; i < len; i++) + { + for (j = 0; j < lensub; j++) + { + if (y->value.character.string[j] == + x->value.character.string[i]) + { + start = i; + count = 0; + + for (k = 0; k < lensub; k++) + { + if (y->value.character.string[k] == + x->value.character.string[k + start]) + count++; + } + + if (count == lensub) + { + index = start + 1; + goto done; + } + } + } + } + } + + } + else + { + + if (lensub == 0) + { + mpz_set_si (result->value.integer, len + 1); + return result; + } + else if (lensub == 1) + { + for (i = 0; i < len; i++) + { + for (j = 0; j < lensub; j++) + { + if (y->value.character.string[j] == + x->value.character.string[len - i]) + { + index = len - i + 1; + goto done; + } + } + } + } + else + { + for (i = 0; i < len; i++) + { + for (j = 0; j < lensub; j++) + { + if (y->value.character.string[j] == + x->value.character.string[len - i]) + { + start = len - i; + if (start <= len - lensub) + { + count = 0; + for (k = 0; k < lensub; k++) + if (y->value.character.string[k] == + x->value.character.string[k + start]) + count++; + + if (count == lensub) + { + index = start + 1; + goto done; + } + } + else + { + continue; + } + } + } + } + } + } + +done: + mpz_set_si (result->value.integer, index); + return range_check (result, "INDEX"); +} + + +gfc_expr * +gfc_simplify_int (gfc_expr * e, gfc_expr * k) +{ + gfc_expr *rpart, *rtrunc, *result; + int kind; + + kind = get_kind (BT_REAL, k, "INT", gfc_default_real_kind ()); + if (kind == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (BT_INTEGER, kind, &e->where); + + switch (e->ts.type) + { + case BT_INTEGER: + mpz_set (result->value.integer, e->value.integer); + break; + + case BT_REAL: + rtrunc = gfc_copy_expr (e); + mpf_trunc (rtrunc->value.real, e->value.real); + mpz_set_f (result->value.integer, rtrunc->value.real); + gfc_free_expr (rtrunc); + break; + + case BT_COMPLEX: + rpart = gfc_complex2real (e, kind); + rtrunc = gfc_copy_expr (rpart); + mpf_trunc (rtrunc->value.real, rpart->value.real); + mpz_set_f (result->value.integer, rtrunc->value.real); + gfc_free_expr (rpart); + gfc_free_expr (rtrunc); + break; + + default: + gfc_error ("Argument of INT at %L is not a valid type", &e->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + return range_check (result, "INT"); +} + + +gfc_expr * +gfc_simplify_ifix (gfc_expr * e) +{ + gfc_expr *rtrunc, *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (), + &e->where); + + rtrunc = gfc_copy_expr (e); + + mpf_trunc (rtrunc->value.real, e->value.real); + mpz_set_f (result->value.integer, rtrunc->value.real); + + gfc_free_expr (rtrunc); + return range_check (result, "IFIX"); +} + + +gfc_expr * +gfc_simplify_idint (gfc_expr * e) +{ + gfc_expr *rtrunc, *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (), + &e->where); + + rtrunc = gfc_copy_expr (e); + + mpf_trunc (rtrunc->value.real, e->value.real); + mpz_set_f (result->value.integer, rtrunc->value.real); + + gfc_free_expr (rtrunc); + return range_check (result, "IDINT"); +} + + +gfc_expr * +gfc_simplify_ior (gfc_expr * x, gfc_expr * y) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where); + + mpz_ior (result->value.integer, x->value.integer, y->value.integer); + return range_check (result, "IOR"); +} + + +gfc_expr * +gfc_simplify_ishft (gfc_expr * e, gfc_expr * s) +{ + gfc_expr *result; + int shift, ashift, isize, k; + long e_int; + + if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) + return NULL; + + if (gfc_extract_int (s, &shift) != NULL) + { + gfc_error ("Invalid second argument of ISHFT at %L", &s->where); + return &gfc_bad_expr; + } + + k = gfc_validate_kind (BT_INTEGER, e->ts.kind); + if (k == -1) + gfc_internal_error ("gfc_simplify_ishft(): Bad kind"); + + isize = gfc_integer_kinds[k].bit_size; + + if (shift >= 0) + ashift = shift; + else + ashift = -shift; + + if (ashift > isize) + { + gfc_error + ("Magnitude of second argument of ISHFT exceeds bit size at %L", + &s->where); + return &gfc_bad_expr; + } + + e_int = mpz_get_si (e->value.integer); + if (e_int > INT_MAX || e_int < INT_MIN) + gfc_internal_error ("ISHFT: unable to extract integer"); + + result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where); + + if (shift == 0) + { + mpz_set (result->value.integer, e->value.integer); + return range_check (result, "ISHFT"); + } + + if (shift > 0) + mpz_set_si (result->value.integer, e_int << shift); + else + mpz_set_si (result->value.integer, e_int >> ashift); + + return range_check (result, "ISHFT"); +} + + +gfc_expr * +gfc_simplify_ishftc (gfc_expr * e, gfc_expr * s, gfc_expr * sz) +{ + gfc_expr *result; + int shift, ashift, isize, delta, k; + int i, *bits; + + if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) + return NULL; + + if (gfc_extract_int (s, &shift) != NULL) + { + gfc_error ("Invalid second argument of ISHFTC at %L", &s->where); + return &gfc_bad_expr; + } + + k = gfc_validate_kind (e->ts.type, e->ts.kind); + if (k == -1) + gfc_internal_error ("gfc_simplify_ishftc(): Bad kind"); + + if (sz != NULL) + { + if (gfc_extract_int (sz, &isize) != NULL || isize < 0) + { + gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where); + return &gfc_bad_expr; + } + } + else + isize = gfc_integer_kinds[k].bit_size; + + if (shift >= 0) + ashift = shift; + else + ashift = -shift; + + if (ashift > isize) + { + gfc_error + ("Magnitude of second argument of ISHFTC exceeds third argument " + "at %L", &s->where); + return &gfc_bad_expr; + } + + result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where); + + bits = gfc_getmem (isize * sizeof (int)); + + for (i = 0; i < isize; i++) + bits[i] = mpz_tstbit (e->value.integer, i); + + delta = isize - ashift; + + if (shift == 0) + { + mpz_set (result->value.integer, e->value.integer); + gfc_free (bits); + return range_check (result, "ISHFTC"); + } + + else if (shift > 0) + { + for (i = 0; i < delta; i++) + { + if (bits[i] == 0) + mpz_clrbit (result->value.integer, i + shift); + if (bits[i] == 1) + mpz_setbit (result->value.integer, i + shift); + } + + for (i = delta; i < isize; i++) + { + if (bits[i] == 0) + mpz_clrbit (result->value.integer, i - delta); + if (bits[i] == 1) + mpz_setbit (result->value.integer, i - delta); + } + + gfc_free (bits); + return range_check (result, "ISHFTC"); + } + else + { + for (i = 0; i < ashift; i++) + { + if (bits[i] == 0) + mpz_clrbit (result->value.integer, i + delta); + if (bits[i] == 1) + mpz_setbit (result->value.integer, i + delta); + } + + for (i = ashift; i < isize; i++) + { + if (bits[i] == 0) + mpz_clrbit (result->value.integer, i + shift); + if (bits[i] == 1) + mpz_setbit (result->value.integer, i + shift); + } + + gfc_free (bits); + return range_check (result, "ISHFTC"); + } +} + + +gfc_expr * +gfc_simplify_kind (gfc_expr * e) +{ + + if (e->ts.type == BT_DERIVED) + { + gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where); + return &gfc_bad_expr; + } + + return gfc_int_expr (e->ts.kind); +} + + +static gfc_expr * +gfc_simplify_bound (gfc_expr * array, gfc_expr * dim, int upper) +{ + gfc_ref *ref; + gfc_array_spec *as; + int i; + + if (array->expr_type != EXPR_VARIABLE) + return NULL; + + if (dim == NULL) + return NULL; + + if (dim->expr_type != EXPR_CONSTANT) + return NULL; + + /* Follow any component references. */ + as = array->symtree->n.sym->as; + ref = array->ref; + while (ref->next != NULL) + { + if (ref->type == REF_COMPONENT) + as = ref->u.c.sym->as; + ref = ref->next; + } + + if (ref->type != REF_ARRAY || ref->u.ar.type != AR_FULL) + return NULL; + + i = mpz_get_si (dim->value.integer); + if (upper) + return as->upper[i-1]; + else + return as->lower[i-1]; +} + + +gfc_expr * +gfc_simplify_lbound (gfc_expr * array, gfc_expr * dim) +{ + return gfc_simplify_bound (array, dim, 0); +} + + +gfc_expr * +gfc_simplify_len (gfc_expr * e) +{ + gfc_expr *result; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (), + &e->where); + + mpz_set_si (result->value.integer, e->value.character.length); + return range_check (result, "LEN"); +} + + +gfc_expr * +gfc_simplify_len_trim (gfc_expr * e) +{ + gfc_expr *result; + int count, len, lentrim, i; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (), + &e->where); + + len = e->value.character.length; + + for (count = 0, i = 1; i <= len; i++) + if (e->value.character.string[len - i] == ' ') + count++; + else + break; + + lentrim = len - count; + + mpz_set_si (result->value.integer, lentrim); + return range_check (result, "LEN_TRIM"); +} + + +gfc_expr * +gfc_simplify_lge (gfc_expr * a, gfc_expr * b) +{ + + if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) >= 0, + &a->where); +} + + +gfc_expr * +gfc_simplify_lgt (gfc_expr * a, gfc_expr * b) +{ + + if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) > 0, + &a->where); +} + + +gfc_expr * +gfc_simplify_lle (gfc_expr * a, gfc_expr * b) +{ + + if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) <= 0, + &a->where); +} + + +gfc_expr * +gfc_simplify_llt (gfc_expr * a, gfc_expr * b) +{ + + if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT) + return NULL; + + return gfc_logical_expr (gfc_compare_string (a, b, xascii_table) < 0, + &a->where); +} + + +gfc_expr * +gfc_simplify_log (gfc_expr * x) +{ + gfc_expr *result; + mpf_t xr, xi; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + if (mpf_cmp (x->value.real, mpf_zero) <= 0) + { + gfc_error + ("Argument of LOG at %L cannot be less than or equal to zero", + &x->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + natural_logarithm (&x->value.real, &result->value.real); + break; + + case BT_COMPLEX: + if ((mpf_cmp (x->value.complex.r, mpf_zero) == 0) + && (mpf_cmp (x->value.complex.i, mpf_zero) == 0)) + { + gfc_error ("Complex argument of LOG at %L cannot be zero", + &x->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + mpf_init (xr); + mpf_init (xi); + + mpf_div (xr, x->value.complex.i, x->value.complex.r); + arctangent2 (&x->value.complex.i, &x->value.complex.r, + &result->value.complex.i); + + mpf_mul (xr, x->value.complex.r, x->value.complex.r); + mpf_mul (xi, x->value.complex.i, x->value.complex.i); + mpf_add (xr, xr, xi); + mpf_sqrt (xr, xr); + natural_logarithm (&xr, &result->value.complex.r); + + mpf_clear (xr); + mpf_clear (xi); + + break; + + default: + gfc_internal_error ("gfc_simplify_log: bad type"); + } + + return range_check (result, "LOG"); +} + + +gfc_expr * +gfc_simplify_log10 (gfc_expr * x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + if (mpf_cmp (x->value.real, mpf_zero) <= 0) + { + gfc_error + ("Argument of LOG10 at %L cannot be less than or equal to zero", + &x->where); + return &gfc_bad_expr; + } + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + common_logarithm (&x->value.real, &result->value.real); + + return range_check (result, "LOG10"); +} + + +gfc_expr * +gfc_simplify_logical (gfc_expr * e, gfc_expr * k) +{ + gfc_expr *result; + int kind; + + kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind ()); + if (kind < 0) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (BT_LOGICAL, kind, &e->where); + + result->value.logical = e->value.logical; + + return result; +} + + +/* This function is special since MAX() can take any number of + arguments. The simplified expression is a rewritten version of the + argument list containing at most one constant element. Other + constant elements are deleted. Because the argument list has + already been checked, this function always succeeds. sign is 1 for + MAX(), -1 for MIN(). */ + +static gfc_expr * +simplify_min_max (gfc_expr * expr, int sign) +{ + gfc_actual_arglist *arg, *last, *extremum; + gfc_intrinsic_sym * specific; + + last = NULL; + extremum = NULL; + specific = expr->value.function.isym; + + arg = expr->value.function.actual; + + for (; arg; last = arg, arg = arg->next) + { + if (arg->expr->expr_type != EXPR_CONSTANT) + continue; + + if (extremum == NULL) + { + extremum = arg; + continue; + } + + switch (arg->expr->ts.type) + { + case BT_INTEGER: + if (mpz_cmp (arg->expr->value.integer, + extremum->expr->value.integer) * sign > 0) + mpz_set (extremum->expr->value.integer, arg->expr->value.integer); + + break; + + case BT_REAL: + if (mpf_cmp (arg->expr->value.real, extremum->expr->value.real) * + sign > 0) + mpf_set (extremum->expr->value.real, arg->expr->value.real); + + break; + + default: + gfc_internal_error ("gfc_simplify_max(): Bad type in arglist"); + } + + /* Delete the extra constant argument. */ + if (last == NULL) + expr->value.function.actual = arg->next; + else + last->next = arg->next; + + arg->next = NULL; + gfc_free_actual_arglist (arg); + arg = last; + } + + /* If there is one value left, replace the function call with the + expression. */ + if (expr->value.function.actual->next != NULL) + return NULL; + + /* Convert to the correct type and kind. */ + if (expr->ts.type != BT_UNKNOWN) + return gfc_convert_constant (expr->value.function.actual->expr, + expr->ts.type, expr->ts.kind); + + if (specific->ts.type != BT_UNKNOWN) + return gfc_convert_constant (expr->value.function.actual->expr, + specific->ts.type, specific->ts.kind); + + return gfc_copy_expr (expr->value.function.actual->expr); +} + + +gfc_expr * +gfc_simplify_min (gfc_expr * e) +{ + + return simplify_min_max (e, -1); +} + + +gfc_expr * +gfc_simplify_max (gfc_expr * e) +{ + + return simplify_min_max (e, 1); +} + + +gfc_expr * +gfc_simplify_maxexponent (gfc_expr * x) +{ + gfc_expr *result; + int i; + + i = gfc_validate_kind (BT_REAL, x->ts.kind); + if (i == -1) + gfc_internal_error ("gfc_simplify_maxexponent(): Bad kind"); + + result = gfc_int_expr (gfc_real_kinds[i].max_exponent); + result->where = x->where; + + return result; +} + + +gfc_expr * +gfc_simplify_minexponent (gfc_expr * x) +{ + gfc_expr *result; + int i; + + i = gfc_validate_kind (BT_REAL, x->ts.kind); + if (i == -1) + gfc_internal_error ("gfc_simplify_minexponent(): Bad kind"); + + result = gfc_int_expr (gfc_real_kinds[i].min_exponent); + result->where = x->where; + + return result; +} + + +gfc_expr * +gfc_simplify_mod (gfc_expr * a, gfc_expr * p) +{ + gfc_expr *result; + mpf_t quot, iquot, term; + + if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where); + + switch (a->ts.type) + { + case BT_INTEGER: + if (mpz_cmp_ui (p->value.integer, 0) == 0) + { + /* Result is processor-dependent. */ + gfc_error ("Second argument MOD at %L is zero", &a->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); + break; + + case BT_REAL: + if (mpf_cmp_ui (p->value.real, 0) == 0) + { + /* Result is processor-dependent. */ + gfc_error ("Second argument of MOD at %L is zero", &p->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + mpf_init (quot); + mpf_init (iquot); + mpf_init (term); + + mpf_div (quot, a->value.real, p->value.real); + mpf_trunc (iquot, quot); + mpf_mul (term, iquot, p->value.real); + mpf_sub (result->value.real, a->value.real, term); + + mpf_clear (quot); + mpf_clear (iquot); + mpf_clear (term); + break; + + default: + gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); + } + + return range_check (result, "MOD"); +} + + +gfc_expr * +gfc_simplify_modulo (gfc_expr * a, gfc_expr * p) +{ + gfc_expr *result; + mpf_t quot, iquot, term; + + if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where); + + switch (a->ts.type) + { + case BT_INTEGER: + if (mpz_cmp_ui (p->value.integer, 0) == 0) + { + /* Result is processor-dependent. This processor just opts + to not handle it at all. */ + gfc_error ("Second argument of MODULO at %L is zero", &a->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); + + break; + + case BT_REAL: + if (mpf_cmp_ui (p->value.real, 0) == 0) + { + /* Result is processor-dependent. */ + gfc_error ("Second argument of MODULO at %L is zero", &p->where); + gfc_free_expr (result); + return &gfc_bad_expr; + } + + mpf_init (quot); + mpf_init (iquot); + mpf_init (term); + + mpf_div (quot, a->value.real, p->value.real); + mpf_floor (iquot, quot); + mpf_mul (term, iquot, p->value.real); + + mpf_clear (quot); + mpf_clear (iquot); + mpf_clear (term); + + mpf_sub (result->value.real, a->value.real, term); + break; + + default: + gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); + } + + return range_check (result, "MODULO"); +} + + +/* Exists for the sole purpose of consistency with other intrinsics. */ +gfc_expr * +gfc_simplify_mvbits (gfc_expr * f ATTRIBUTE_UNUSED, + gfc_expr * fp ATTRIBUTE_UNUSED, + gfc_expr * l ATTRIBUTE_UNUSED, + gfc_expr * to ATTRIBUTE_UNUSED, + gfc_expr * tp ATTRIBUTE_UNUSED) +{ + return NULL; +} + + +gfc_expr * +gfc_simplify_nearest (gfc_expr * x, gfc_expr * s) +{ + gfc_expr *result; + float rval; + double val, eps; + int p, i, k, match_float; + + /* FIXME: This implementation is dopey and probably not quite right, + but it's a start. */ + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + k = gfc_validate_kind (x->ts.type, x->ts.kind); + if (k == -1) + gfc_internal_error ("gfc_simplify_precision(): Bad kind"); + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + val = mpf_get_d (x->value.real); + p = gfc_real_kinds[k].digits; + + eps = 1.; + for (i = 1; i < p; ++i) + { + eps = eps / 2.; + } + + /* TODO we should make sure that 'float' matches kind 4 */ + match_float = gfc_real_kinds[k].kind == 4; + if (mpf_cmp_ui (s->value.real, 0) > 0) + { + if (match_float) + { + rval = (float) val; + rval = rval + eps; + mpf_set_d (result->value.real, rval); + } + else + { + val = val + eps; + mpf_set_d (result->value.real, val); + } + } + else if (mpf_cmp_ui (s->value.real, 0) < 0) + { + if (match_float) + { + rval = (float) val; + rval = rval - eps; + mpf_set_d (result->value.real, rval); + } + else + { + val = val - eps; + mpf_set_d (result->value.real, val); + } + } + else + { + gfc_error ("Invalid second argument of NEAREST at %L", &s->where); + gfc_free (result); + return &gfc_bad_expr; + } + + return range_check (result, "NEAREST"); + +} + + +static gfc_expr * +simplify_nint (const char *name, gfc_expr * e, gfc_expr * k) +{ + gfc_expr *rtrunc, *itrunc, *result; + int kind, cmp; + + kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind ()); + if (kind == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (BT_INTEGER, kind, &e->where); + + rtrunc = gfc_copy_expr (e); + itrunc = gfc_copy_expr (e); + + cmp = mpf_cmp_ui (e->value.real, 0); + + if (cmp > 0) + { + mpf_add (rtrunc->value.real, e->value.real, mpf_half); + mpf_trunc (itrunc->value.real, rtrunc->value.real); + } + else if (cmp < 0) + { + mpf_sub (rtrunc->value.real, e->value.real, mpf_half); + mpf_trunc (itrunc->value.real, rtrunc->value.real); + } + else + mpf_set_ui (itrunc->value.real, 0); + + mpz_set_f (result->value.integer, itrunc->value.real); + + gfc_free_expr (itrunc); + gfc_free_expr (rtrunc); + + return range_check (result, name); +} + + +gfc_expr * +gfc_simplify_nint (gfc_expr * e, gfc_expr * k) +{ + + return simplify_nint ("NINT", e, k); +} + + +gfc_expr * +gfc_simplify_idnint (gfc_expr * e) +{ + + return simplify_nint ("IDNINT", e, NULL); +} + + +gfc_expr * +gfc_simplify_not (gfc_expr * e) +{ + gfc_expr *result; + int i; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where); + + mpz_com (result->value.integer, e->value.integer); + + /* Because of how GMP handles numbers, the result must be ANDed with + the max_int mask. For radices <> 2, this will require change. */ + + i = gfc_validate_kind (BT_INTEGER, e->ts.kind); + if (i == -1) + gfc_internal_error ("gfc_simplify_not(): Bad kind"); + + mpz_and (result->value.integer, result->value.integer, + gfc_integer_kinds[i].max_int); + + return range_check (result, "NOT"); +} + + +gfc_expr * +gfc_simplify_null (gfc_expr * mold) +{ + gfc_expr *result; + + result = gfc_get_expr (); + result->expr_type = EXPR_NULL; + + if (mold == NULL) + result->ts.type = BT_UNKNOWN; + else + { + result->ts = mold->ts; + result->where = mold->where; + } + + return result; +} + + +gfc_expr * +gfc_simplify_precision (gfc_expr * e) +{ + gfc_expr *result; + int i; + + i = gfc_validate_kind (e->ts.type, e->ts.kind); + if (i == -1) + gfc_internal_error ("gfc_simplify_precision(): Bad kind"); + + result = gfc_int_expr (gfc_real_kinds[i].precision); + result->where = e->where; + + return result; +} + + +gfc_expr * +gfc_simplify_radix (gfc_expr * e) +{ + gfc_expr *result; + int i; + + i = gfc_validate_kind (e->ts.type, e->ts.kind); + if (i == -1) + goto bad; + + switch (e->ts.type) + { + case BT_INTEGER: + i = gfc_integer_kinds[i].radix; + break; + + case BT_REAL: + i = gfc_real_kinds[i].radix; + break; + + default: + bad: + gfc_internal_error ("gfc_simplify_radix(): Bad type"); + } + + result = gfc_int_expr (i); + result->where = e->where; + + return result; +} + + +gfc_expr * +gfc_simplify_range (gfc_expr * e) +{ + gfc_expr *result; + int i; + long j; + + i = gfc_validate_kind (e->ts.type, e->ts.kind); + if (i == -1) + goto bad_type; + + switch (e->ts.type) + { + case BT_INTEGER: + j = gfc_integer_kinds[i].range; + break; + + case BT_REAL: + case BT_COMPLEX: + j = gfc_real_kinds[i].range; + break; + + bad_type: + default: + gfc_internal_error ("gfc_simplify_range(): Bad kind"); + } + + result = gfc_int_expr (j); + result->where = e->where; + + return result; +} + + +gfc_expr * +gfc_simplify_real (gfc_expr * e, gfc_expr * k) +{ + gfc_expr *result; + int kind; + + if (e->ts.type == BT_COMPLEX) + kind = get_kind (BT_REAL, k, "REAL", e->ts.kind); + else + kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind ()); + + if (kind == -1) + return &gfc_bad_expr; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + switch (e->ts.type) + { + case BT_INTEGER: + result = gfc_int2real (e, kind); + break; + + case BT_REAL: + result = gfc_real2real (e, kind); + break; + + case BT_COMPLEX: + result = gfc_complex2real (e, kind); + break; + + default: + gfc_internal_error ("bad type in REAL"); + /* Not reached */ + } + + return range_check (result, "REAL"); +} + +gfc_expr * +gfc_simplify_repeat (gfc_expr * e, gfc_expr * n) +{ + gfc_expr *result; + int i, j, len, ncopies, nlen; + + if (e->expr_type != EXPR_CONSTANT || n->expr_type != EXPR_CONSTANT) + return NULL; + + if (n != NULL && (gfc_extract_int (n, &ncopies) != NULL || ncopies < 0)) + { + gfc_error ("Invalid second argument of REPEAT at %L", &n->where); + return &gfc_bad_expr; + } + + len = e->value.character.length; + nlen = ncopies * len; + + result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); + + if (ncopies == 0) + { + result->value.character.string = gfc_getmem (1); + result->value.character.length = 0; + result->value.character.string[0] = '\0'; + return result; + } + + result->value.character.length = nlen; + result->value.character.string = gfc_getmem (nlen + 1); + + for (i = 0; i < ncopies; i++) + for (j = 0; j < len; j++) + result->value.character.string[j + i * len] = + e->value.character.string[j]; + + result->value.character.string[nlen] = '\0'; /* For debugger */ + return result; +} + + +/* This one is a bear, but mainly has to do with shuffling elements. */ + +gfc_expr * +gfc_simplify_reshape (gfc_expr * source, gfc_expr * shape_exp, + gfc_expr * pad, gfc_expr * order_exp) +{ + + int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS]; + int i, rank, npad, x[GFC_MAX_DIMENSIONS]; + gfc_constructor *head, *tail; + mpz_t index, size; + unsigned long j; + size_t nsource; + gfc_expr *e; + + /* Unpack the shape array. */ + if (source->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (source)) + return NULL; + + if (shape_exp->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (shape_exp)) + return NULL; + + if (pad != NULL + && (pad->expr_type != EXPR_ARRAY + || !gfc_is_constant_expr (pad))) + return NULL; + + if (order_exp != NULL + && (order_exp->expr_type != EXPR_ARRAY + || !gfc_is_constant_expr (order_exp))) + return NULL; + + mpz_init (index); + rank = 0; + head = tail = NULL; + + for (;;) + { + e = gfc_get_array_element (shape_exp, rank); + if (e == NULL) + break; + + if (gfc_extract_int (e, &shape[rank]) != NULL) + { + gfc_error ("Integer too large in shape specification at %L", + &e->where); + gfc_free_expr (e); + goto bad_reshape; + } + + gfc_free_expr (e); + + if (rank >= GFC_MAX_DIMENSIONS) + { + gfc_error ("Too many dimensions in shape specification for RESHAPE " + "at %L", &e->where); + + goto bad_reshape; + } + + if (shape[rank] < 0) + { + gfc_error ("Shape specification at %L cannot be negative", + &e->where); + goto bad_reshape; + } + + rank++; + } + + if (rank == 0) + { + gfc_error ("Shape specification at %L cannot be the null array", + &shape_exp->where); + goto bad_reshape; + } + + /* Now unpack the order array if present. */ + if (order_exp == NULL) + { + for (i = 0; i < rank; i++) + order[i] = i; + + } + else + { + + for (i = 0; i < rank; i++) + x[i] = 0; + + for (i = 0; i < rank; i++) + { + e = gfc_get_array_element (order_exp, i); + if (e == NULL) + { + gfc_error + ("ORDER parameter of RESHAPE at %L is not the same size " + "as SHAPE parameter", &order_exp->where); + goto bad_reshape; + } + + if (gfc_extract_int (e, &order[i]) != NULL) + { + gfc_error ("Error in ORDER parameter of RESHAPE at %L", + &e->where); + gfc_free_expr (e); + goto bad_reshape; + } + + gfc_free_expr (e); + + if (order[i] < 1 || order[i] > rank) + { + gfc_error ("ORDER parameter of RESHAPE at %L is out of range", + &e->where); + goto bad_reshape; + } + + order[i]--; + + if (x[order[i]]) + { + gfc_error ("Invalid permutation in ORDER parameter at %L", + &e->where); + goto bad_reshape; + } + + x[order[i]] = 1; + } + } + + /* Count the elements in the source and padding arrays. */ + + npad = 0; + if (pad != NULL) + { + gfc_array_size (pad, &size); + npad = mpz_get_ui (size); + mpz_clear (size); + } + + gfc_array_size (source, &size); + nsource = mpz_get_ui (size); + mpz_clear (size); + + /* If it weren't for that pesky permutation we could just loop + through the source and round out any shortage with pad elements. + But no, someone just had to have the compiler do something the + user should be doing. */ + + for (i = 0; i < rank; i++) + x[i] = 0; + + for (;;) + { + /* Figure out which element to extract. */ + mpz_set_ui (index, 0); + + for (i = rank - 1; i >= 0; i--) + { + mpz_add_ui (index, index, x[order[i]]); + if (i != 0) + mpz_mul_ui (index, index, shape[order[i - 1]]); + } + + if (mpz_cmp_ui (index, INT_MAX) > 0) + gfc_internal_error ("Reshaped array too large at %L", &e->where); + + j = mpz_get_ui (index); + + if (j < nsource) + e = gfc_get_array_element (source, j); + else + { + j = j - nsource; + + if (npad == 0) + { + gfc_error + ("PAD parameter required for short SOURCE parameter at %L", + &source->where); + goto bad_reshape; + } + + j = j % npad; + e = gfc_get_array_element (pad, j); + } + + if (head == NULL) + head = tail = gfc_get_constructor (); + else + { + tail->next = gfc_get_constructor (); + tail = tail->next; + } + + if (e == NULL) + goto bad_reshape; + + tail->where = e->where; + tail->expr = e; + + /* Calculate the next element. */ + i = 0; + +inc: + if (++x[i] < shape[i]) + continue; + x[i++] = 0; + if (i < rank) + goto inc; + + break; + } + + mpz_clear (index); + + e = gfc_get_expr (); + e->where = source->where; + e->expr_type = EXPR_ARRAY; + e->value.constructor = head; + e->shape = gfc_get_shape (rank); + + for (i = 0; i < rank; i++) + mpz_init_set_ui (e->shape[i], shape[order[i]]); + + e->ts = head->expr->ts; + e->rank = rank; + + return e; + +bad_reshape: + gfc_free_constructor (head); + mpz_clear (index); + return &gfc_bad_expr; +} + + +gfc_expr * +gfc_simplify_rrspacing (gfc_expr * x) +{ + gfc_expr *result; + mpf_t i2, absv, ln2, lnx, frac, pow2; + unsigned long exp2; + int i, p; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + i = gfc_validate_kind (x->ts.type, x->ts.kind); + if (i == -1) + gfc_internal_error ("gfc_simplify_rrspacing(): Bad kind"); + + result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where); + + p = gfc_real_kinds[i].digits; + + if (mpf_cmp (x->value.real, mpf_zero) == 0) + { + mpf_ui_div (result->value.real, 1, gfc_real_kinds[i].tiny); + return result; + } + + mpf_init_set_ui (i2, 2); + mpf_init (ln2); + mpf_init (absv); + mpf_init (lnx); + mpf_init (frac); + mpf_init (pow2); + + natural_logarithm (&i2, &ln2); + + mpf_abs (absv, x->value.real); + natural_logarithm (&absv, &lnx); + + mpf_div (lnx, lnx, ln2); + mpf_trunc (lnx, lnx); + mpf_add_ui (lnx, lnx, 1); + + exp2 = (unsigned long) mpf_get_d (lnx); + mpf_pow_ui (pow2, i2, exp2); + mpf_div (frac, absv, pow2); + + exp2 = (unsigned long) p; + mpf_mul_2exp (result->value.real, frac, exp2); + + mpf_clear (i2); + mpf_clear (ln2); + mpf_clear (absv); + mpf_clear (lnx); + mpf_clear (frac); + mpf_clear (pow2); + + return range_check (result, "RRSPACING"); +} + + +gfc_expr * +gfc_simplify_scale (gfc_expr * x, gfc_expr * i) +{ + int k, neg_flag, power, exp_range; + mpf_t scale, radix; + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where); + + if (mpf_sgn (x->value.real) == 0) + { + mpf_set_ui (result->value.real, 0); + return result; + } + + k = gfc_validate_kind (BT_REAL, x->ts.kind); + if (k == -1) + gfc_internal_error ("gfc_simplify_scale(): Bad kind"); + + exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent; + + /* This check filters out values of i that would overflow an int. */ + if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0 + || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0) + { + gfc_error ("Result of SCALE overflows its kind at %L", &result->where); + return &gfc_bad_expr; + } + + /* Compute scale = radix ** power. */ + power = mpz_get_si (i->value.integer); + + if (power >= 0) + neg_flag = 0; + else + { + neg_flag = 1; + power = -power; + } + + mpf_init_set_ui (radix, gfc_real_kinds[k].radix); + mpf_init (scale); + mpf_pow_ui (scale, radix, power); + + if (neg_flag) + mpf_div (result->value.real, x->value.real, scale); + else + mpf_mul (result->value.real, x->value.real, scale); + + mpf_clear (scale); + mpf_clear (radix); + + return range_check (result, "SCALE"); +} + + +gfc_expr * +gfc_simplify_scan (gfc_expr * e, gfc_expr * c, gfc_expr * b) +{ + gfc_expr *result; + int back; + size_t i; + size_t indx, len, lenc; + + if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT) + return NULL; + + if (b != NULL && b->value.logical != 0) + back = 1; + else + back = 0; + + result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (), + &e->where); + + len = e->value.character.length; + lenc = c->value.character.length; + + if (len == 0 || lenc == 0) + { + indx = 0; + } + else + { + if (back == 0) + { + indx = + strcspn (e->value.character.string, c->value.character.string) + 1; + if (indx > len) + indx = 0; + } + else + { + i = 0; + for (indx = len; indx > 0; indx--) + { + for (i = 0; i < lenc; i++) + { + if (c->value.character.string[i] + == e->value.character.string[indx - 1]) + break; + } + if (i < lenc) + break; + } + } + } + mpz_set_ui (result->value.integer, indx); + return range_check (result, "SCAN"); +} + + +gfc_expr * +gfc_simplify_selected_int_kind (gfc_expr * e) +{ + int i, kind, range; + gfc_expr *result; + + if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL) + return NULL; + + kind = INT_MAX; + + for (i = 0; gfc_integer_kinds[i].kind != 0; i++) + if (gfc_integer_kinds[i].range >= range + && gfc_integer_kinds[i].kind < kind) + kind = gfc_integer_kinds[i].kind; + + if (kind == INT_MAX) + kind = -1; + + result = gfc_int_expr (kind); + result->where = e->where; + + return result; +} + + +gfc_expr * +gfc_simplify_selected_real_kind (gfc_expr * p, gfc_expr * q) +{ + int range, precision, i, kind, found_precision, found_range; + gfc_expr *result; + + if (p == NULL) + precision = 0; + else + { + if (p->expr_type != EXPR_CONSTANT + || gfc_extract_int (p, &precision) != NULL) + return NULL; + } + + if (q == NULL) + range = 0; + else + { + if (q->expr_type != EXPR_CONSTANT + || gfc_extract_int (q, &range) != NULL) + return NULL; + } + + kind = INT_MAX; + found_precision = 0; + found_range = 0; + + for (i = 0; gfc_real_kinds[i].kind != 0; i++) + { + if (gfc_real_kinds[i].precision >= precision) + found_precision = 1; + + if (gfc_real_kinds[i].range >= range) + found_range = 1; + + if (gfc_real_kinds[i].precision >= precision + && gfc_real_kinds[i].range >= range && gfc_real_kinds[i].kind < kind) + kind = gfc_real_kinds[i].kind; + } + + if (kind == INT_MAX) + { + kind = 0; + + if (!found_precision) + kind = -1; + if (!found_range) + kind -= 2; + } + + result = gfc_int_expr (kind); + result->where = (p != NULL) ? p->where : q->where; + + return result; +} + + +gfc_expr * +gfc_simplify_set_exponent (gfc_expr * x, gfc_expr * i) +{ + gfc_expr *result; + mpf_t i2, ln2, absv, lnx, pow2, frac; + unsigned long exp2; + + if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where); + + if (mpf_cmp (x->value.real, mpf_zero) == 0) + { + mpf_set (result->value.real, mpf_zero); + return result; + } + + mpf_init_set_ui (i2, 2); + mpf_init (ln2); + mpf_init (absv); + mpf_init (lnx); + mpf_init (pow2); + mpf_init (frac); + + natural_logarithm (&i2, &ln2); + + mpf_abs (absv, x->value.real); + natural_logarithm (&absv, &lnx); + + mpf_div (lnx, lnx, ln2); + mpf_trunc (lnx, lnx); + mpf_add_ui (lnx, lnx, 1); + + /* Old exponent value, and fraction. */ + exp2 = (unsigned long) mpf_get_d (lnx); + mpf_pow_ui (pow2, i2, exp2); + + mpf_div (frac, absv, pow2); + + /* New exponent. */ + exp2 = (unsigned long) mpz_get_d (i->value.integer); + mpf_mul_2exp (result->value.real, frac, exp2); + + mpf_clear (i2); + mpf_clear (ln2); + mpf_clear (absv); + mpf_clear (lnx); + mpf_clear (pow2); + mpf_clear (frac); + + return range_check (result, "SET_EXPONENT"); +} + + +gfc_expr * +gfc_simplify_shape (gfc_expr * source) +{ + mpz_t shape[GFC_MAX_DIMENSIONS]; + gfc_expr *result, *e, *f; + gfc_array_ref *ar; + int n; + try t; + + result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind (), + &source->where); + + if (source->rank == 0 || source->expr_type != EXPR_VARIABLE) + return result; + + ar = gfc_find_array_ref (source); + + t = gfc_array_ref_shape (ar, shape); + + for (n = 0; n < source->rank; n++) + { + e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (), + &source->where); + + if (t == SUCCESS) + { + mpz_set (e->value.integer, shape[n]); + mpz_clear (shape[n]); + } + else + { + mpz_set_ui (e->value.integer, n + 1); + + f = gfc_simplify_size (source, e); + gfc_free_expr (e); + if (f == NULL) + { + gfc_free_expr (result); + return NULL; + } + else + { + e = f; + } + } + + gfc_append_constructor (result, e); + } + + return result; +} + + +gfc_expr * +gfc_simplify_size (gfc_expr * array, gfc_expr * dim) +{ + mpz_t size; + gfc_expr *result; + int d; + + if (dim == NULL) + { + if (gfc_array_size (array, &size) == FAILURE) + return NULL; + } + else + { + if (dim->expr_type != EXPR_CONSTANT) + return NULL; + + d = mpz_get_ui (dim->value.integer) - 1; + if (gfc_array_dimen_size (array, d, &size) == FAILURE) + return NULL; + } + + result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (), + &array->where); + + mpz_set (result->value.integer, size); + + return result; +} + + +gfc_expr * +gfc_simplify_sign (gfc_expr * x, gfc_expr * y) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_INTEGER: + mpz_abs (result->value.integer, x->value.integer); + if (mpz_sgn (y->value.integer) < 0) + mpz_neg (result->value.integer, result->value.integer); + + break; + + case BT_REAL: + /* TODO: Handle -0.0 and +0.0 correctly on machines that support + it. */ + mpf_abs (result->value.real, x->value.real); + if (mpf_sgn (y->value.integer) < 0) + mpf_neg (result->value.real, result->value.real); + + break; + + default: + gfc_internal_error ("Bad type in gfc_simplify_sign"); + } + + return result; +} + + +gfc_expr * +gfc_simplify_sin (gfc_expr * x) +{ + gfc_expr *result; + mpf_t xp, xq; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + switch (x->ts.type) + { + case BT_REAL: + sine (&x->value.real, &result->value.real); + break; + + case BT_COMPLEX: + mpf_init (xp); + mpf_init (xq); + + sine (&x->value.complex.r, &xp); + hypercos (&x->value.complex.i, &xq); + mpf_mul (result->value.complex.r, xp, xq); + + cosine (&x->value.complex.r, &xp); + hypersine (&x->value.complex.i, &xq); + mpf_mul (result->value.complex.i, xp, xq); + + mpf_clear (xp); + mpf_clear (xq); + break; + + default: + gfc_internal_error ("in gfc_simplify_sin(): Bad type"); + } + + return range_check (result, "SIN"); +} + + +gfc_expr * +gfc_simplify_sinh (gfc_expr * x) +{ + gfc_expr *result; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + hypersine (&x->value.real, &result->value.real); + + return range_check (result, "SINH"); +} + + +/* The argument is always a double precision real that is converted to + single precision. TODO: Rounding! */ + +gfc_expr * +gfc_simplify_sngl (gfc_expr * a) +{ + gfc_expr *result; + + if (a->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_real2real (a, gfc_default_real_kind ()); + return range_check (result, "SNGL"); +} + + +gfc_expr * +gfc_simplify_spacing (gfc_expr * x) +{ + gfc_expr *result; + mpf_t i1, i2, ln2, absv, lnx; + long diff; + unsigned long exp2; + int i, p; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + i = gfc_validate_kind (x->ts.type, x->ts.kind); + if (i == -1) + gfc_internal_error ("gfc_simplify_spacing(): Bad kind"); + + p = gfc_real_kinds[i].digits; + + result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where); + + if (mpf_cmp (x->value.real, mpf_zero) == 0) + { + mpf_set (result->value.real, gfc_real_kinds[i].tiny); + return result; + } + + mpf_init_set_ui (i1, 1); + mpf_init_set_ui (i2, 2); + mpf_init (ln2); + mpf_init (absv); + mpf_init (lnx); + + natural_logarithm (&i2, &ln2); + + mpf_abs (absv, x->value.real); + natural_logarithm (&absv, &lnx); + + mpf_div (lnx, lnx, ln2); + mpf_trunc (lnx, lnx); + mpf_add_ui (lnx, lnx, 1); + + diff = (long) mpf_get_d (lnx) - (long) p; + if (diff >= 0) + { + exp2 = (unsigned) diff; + mpf_mul_2exp (result->value.real, i1, exp2); + } + else + { + diff = -diff; + exp2 = (unsigned) diff; + mpf_div_2exp (result->value.real, i1, exp2); + } + + mpf_clear (i1); + mpf_clear (i2); + mpf_clear (ln2); + mpf_clear (absv); + mpf_clear (lnx); + + if (mpf_cmp (result->value.real, gfc_real_kinds[i].tiny) < 0) + mpf_set (result->value.real, gfc_real_kinds[i].tiny); + + return range_check (result, "SPACING"); +} + + +gfc_expr * +gfc_simplify_sqrt (gfc_expr * e) +{ + gfc_expr *result; + mpf_t ac, ad, s, t, w; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where); + + switch (e->ts.type) + { + case BT_REAL: + if (mpf_cmp_si (e->value.real, 0) < 0) + goto negative_arg; + mpf_sqrt (result->value.real, e->value.real); + + break; + + case BT_COMPLEX: + /* Formula taken from Numerical Recipes to avoid over- and + underflow. */ + + mpf_init (ac); + mpf_init (ad); + mpf_init (s); + mpf_init (t); + mpf_init (w); + + if (mpf_cmp_ui (e->value.complex.r, 0) == 0 + && mpf_cmp_ui (e->value.complex.i, 0) == 0) + { + + mpf_set_ui (result->value.complex.r, 0); + mpf_set_ui (result->value.complex.i, 0); + break; + } + + mpf_abs (ac, e->value.complex.r); + mpf_abs (ad, e->value.complex.i); + + if (mpf_cmp (ac, ad) >= 0) + { + mpf_div (t, e->value.complex.i, e->value.complex.r); + mpf_mul (t, t, t); + mpf_add_ui (t, t, 1); + mpf_sqrt (t, t); + mpf_add_ui (t, t, 1); + mpf_div_ui (t, t, 2); + mpf_sqrt (t, t); + mpf_sqrt (s, ac); + mpf_mul (w, s, t); + } + else + { + mpf_div (s, e->value.complex.r, e->value.complex.i); + mpf_mul (t, s, s); + mpf_add_ui (t, t, 1); + mpf_sqrt (t, t); + mpf_abs (s, s); + mpf_add (t, t, s); + mpf_div_ui (t, t, 2); + mpf_sqrt (t, t); + mpf_sqrt (s, ad); + mpf_mul (w, s, t); + } + + if (mpf_cmp_ui (w, 0) != 0 && mpf_cmp_ui (e->value.complex.r, 0) >= 0) + { + mpf_mul_ui (t, w, 2); + mpf_div (result->value.complex.i, e->value.complex.i, t); + mpf_set (result->value.complex.r, w); + } + else if (mpf_cmp_ui (w, 0) != 0 + && mpf_cmp_ui (e->value.complex.r, 0) < 0 + && mpf_cmp_ui (e->value.complex.i, 0) >= 0) + { + mpf_mul_ui (t, w, 2); + mpf_div (result->value.complex.r, e->value.complex.i, t); + mpf_set (result->value.complex.i, w); + } + else if (mpf_cmp_ui (w, 0) != 0 + && mpf_cmp_ui (e->value.complex.r, 0) < 0 + && mpf_cmp_ui (e->value.complex.i, 0) < 0) + { + mpf_mul_ui (t, w, 2); + mpf_div (result->value.complex.r, ad, t); + mpf_neg (w, w); + mpf_set (result->value.complex.i, w); + } + else + gfc_internal_error ("invalid complex argument of SQRT at %L", + &e->where); + + mpf_clear (s); + mpf_clear (t); + mpf_clear (ac); + mpf_clear (ad); + mpf_clear (w); + + break; + + default: + gfc_internal_error ("invalid argument of SQRT at %L", &e->where); + } + + return range_check (result, "SQRT"); + +negative_arg: + gfc_free_expr (result); + gfc_error ("Argument of SQRT at %L has a negative value", &e->where); + return &gfc_bad_expr; +} + + +gfc_expr * +gfc_simplify_tan (gfc_expr * x) +{ + gfc_expr *result; + mpf_t mpf_sin, mpf_cos, mag_cos; + int i; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + i = gfc_validate_kind (BT_REAL, x->ts.kind); + if (i == -1) + gfc_internal_error ("gfc_simplify_tan(): Bad kind"); + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + mpf_init (mpf_sin); + mpf_init (mpf_cos); + mpf_init (mag_cos); + sine (&x->value.real, &mpf_sin); + cosine (&x->value.real, &mpf_cos); + mpf_abs (mag_cos, mpf_cos); + if (mpf_cmp_ui (mag_cos, 0) == 0) + { + gfc_error ("Tangent undefined at %L", &x->where); + mpf_clear (mpf_sin); + mpf_clear (mpf_cos); + mpf_clear (mag_cos); + gfc_free_expr (result); + return &gfc_bad_expr; + } + else if (mpf_cmp (mag_cos, gfc_real_kinds[i].tiny) < 0) + { + gfc_error ("Tangent cannot be accurately evaluated at %L", &x->where); + mpf_clear (mpf_sin); + mpf_clear (mpf_cos); + mpf_clear (mag_cos); + gfc_free_expr (result); + return &gfc_bad_expr; + } + else + { + mpf_div (result->value.real, mpf_sin, mpf_cos); + mpf_clear (mpf_sin); + mpf_clear (mpf_cos); + mpf_clear (mag_cos); + } + + return range_check (result, "TAN"); +} + + +gfc_expr * +gfc_simplify_tanh (gfc_expr * x) +{ + gfc_expr *result; + mpf_t xp, xq; + + if (x->expr_type != EXPR_CONSTANT) + return NULL; + + result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where); + + mpf_init (xp); + mpf_init (xq); + + hypersine (&x->value.real, &xq); + hypercos (&x->value.real, &xp); + + mpf_div (result->value.real, xq, xp); + + mpf_clear (xp); + mpf_clear (xq); + + return range_check (result, "TANH"); + +} + + +gfc_expr * +gfc_simplify_tiny (gfc_expr * e) +{ + gfc_expr *result; + int i; + + i = gfc_validate_kind (BT_REAL, e->ts.kind); + if (i == -1) + gfc_internal_error ("gfc_simplify_error(): Bad kind"); + + result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where); + mpf_set (result->value.real, gfc_real_kinds[i].tiny); + + return result; +} + + +gfc_expr * +gfc_simplify_trim (gfc_expr * e) +{ + gfc_expr *result; + int count, i, len, lentrim; + + if (e->expr_type != EXPR_CONSTANT) + return NULL; + + len = e->value.character.length; + + result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where); + + for (count = 0, i = 1; i <= len; ++i) + { + if (e->value.character.string[len - i] == ' ') + count++; + else + break; + } + + lentrim = len - count; + + result->value.character.length = lentrim; + result->value.character.string = gfc_getmem (lentrim + 1); + + for (i = 0; i < lentrim; i++) + result->value.character.string[i] = e->value.character.string[i]; + + result->value.character.string[lentrim] = '\0'; /* For debugger */ + + return result; +} + + +gfc_expr * +gfc_simplify_ubound (gfc_expr * array, gfc_expr * dim) +{ + return gfc_simplify_bound (array, dim, 1); +} + + +gfc_expr * +gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b) +{ + gfc_expr *result; + int back; + size_t index, len, lenset; + size_t i; + + if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT) + return NULL; + + if (b != NULL && b->value.logical != 0) + back = 1; + else + back = 0; + + result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind (), + &s->where); + + len = s->value.character.length; + lenset = set->value.character.length; + + if (len == 0) + { + mpz_set_ui (result->value.integer, 0); + return result; + } + + if (back == 0) + { + if (lenset == 0) + { + mpz_set_ui (result->value.integer, len); + return result; + } + + index = + strspn (s->value.character.string, set->value.character.string) + 1; + if (index > len) + index = 0; + + } + else + { + if (lenset == 0) + { + mpz_set_ui (result->value.integer, 1); + return result; + } + for (index = len; index > 0; index --) + { + for (i = 0; i < lenset; i++) + { + if (s->value.character.string[index - 1] + == set->value.character.string[i]) + break; + } + if (i == lenset) + break; + } + } + + mpz_set_ui (result->value.integer, index); + return result; +} + +/****************** Constant simplification *****************/ + +/* Master function to convert one constant to another. While this is + used as a simplification function, it requires the destination type + and kind information which is supplied by a special case in + do_simplify(). */ + +gfc_expr * +gfc_convert_constant (gfc_expr * e, bt type, int kind) +{ + gfc_expr *g, *result, *(*f) (gfc_expr *, int); + gfc_constructor *head, *c, *tail = NULL; + + switch (e->ts.type) + { + case BT_INTEGER: + switch (type) + { + case BT_INTEGER: + f = gfc_int2int; + break; + case BT_REAL: + f = gfc_int2real; + break; + case BT_COMPLEX: + f = gfc_int2complex; + break; + default: + goto oops; + } + break; + + case BT_REAL: + switch (type) + { + case BT_INTEGER: + f = gfc_real2int; + break; + case BT_REAL: + f = gfc_real2real; + break; + case BT_COMPLEX: + f = gfc_real2complex; + break; + default: + goto oops; + } + break; + + case BT_COMPLEX: + switch (type) + { + case BT_INTEGER: + f = gfc_complex2int; + break; + case BT_REAL: + f = gfc_complex2real; + break; + case BT_COMPLEX: + f = gfc_complex2complex; + break; + + default: + goto oops; + } + break; + + case BT_LOGICAL: + if (type != BT_LOGICAL) + goto oops; + f = gfc_log2log; + break; + + default: + oops: + gfc_internal_error ("gfc_convert_constant(): Unexpected type"); + } + + result = NULL; + + switch (e->expr_type) + { + case EXPR_CONSTANT: + result = f (e, kind); + if (result == NULL) + return &gfc_bad_expr; + break; + + case EXPR_ARRAY: + if (!gfc_is_constant_expr (e)) + break; + + head = NULL; + + for (c = e->value.constructor; c; c = c->next) + { + if (head == NULL) + head = tail = gfc_get_constructor (); + else + { + tail->next = gfc_get_constructor (); + tail = tail->next; + } + + tail->where = c->where; + + if (c->iterator == NULL) + tail->expr = f (c->expr, kind); + else + { + g = gfc_convert_constant (c->expr, type, kind); + if (g == &gfc_bad_expr) + return g; + tail->expr = g; + } + + if (tail->expr == NULL) + { + gfc_free_constructor (head); + return NULL; + } + } + + result = gfc_get_expr (); + result->ts.type = type; + result->ts.kind = kind; + result->expr_type = EXPR_ARRAY; + result->value.constructor = head; + result->shape = gfc_copy_shape (e->shape, e->rank); + result->where = e->where; + result->rank = e->rank; + break; + + default: + break; + } + + return result; +} + + +/****************** Helper functions ***********************/ + +/* Given a collating table, create the inverse table. */ + +static void +invert_table (const int *table, int *xtable) +{ + int i; + + for (i = 0; i < 256; i++) + xtable[i] = 0; + + for (i = 0; i < 256; i++) + xtable[table[i]] = i; +} + + +void +gfc_simplify_init_1 (void) +{ + + mpf_init_set_str (mpf_zero, "0.0", 10); + mpf_init_set_str (mpf_half, "0.5", 10); + mpf_init_set_str (mpf_one, "1.0", 10); + mpz_init_set_str (mpz_zero, "0", 10); + + invert_table (ascii_table, xascii_table); +} + + +void +gfc_simplify_done_1 (void) +{ + + mpf_clear (mpf_zero); + mpf_clear (mpf_half); + mpf_clear (mpf_one); + mpz_clear (mpz_zero); +} diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c new file mode 100644 index 00000000000..c4f4533e94f --- /dev/null +++ b/gcc/fortran/st.c @@ -0,0 +1,186 @@ +/* Build executable statement trees. + Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Executable statements are strung together into a singly linked list + of code structures. These structures are later translated into GCC + GENERIC tree structures and from there to executable code for a + target. */ + +#include "config.h" +#include "gfortran.h" +#include <string.h> + +gfc_code new_st; + + +/* Zeroes out the new_st structure. */ + +void +gfc_clear_new_st (void) +{ + + memset (&new_st, '\0', sizeof (new_st)); + new_st.op = EXEC_NOP; +} + + +/* Get a gfc_code structure. */ + +gfc_code * +gfc_get_code (void) +{ + gfc_code *c; + + c = gfc_getmem (sizeof (gfc_code)); + c->loc = *gfc_current_locus (); + return c; +} + + +/* Given some part of a gfc_code structure, append a set of code to + its tail, returning a pointer to the new tail. */ + +gfc_code * +gfc_append_code (gfc_code * tail, gfc_code * new) +{ + + if (tail != NULL) + { + while (tail->next != NULL) + tail = tail->next; + + tail->next = new; + } + + while (new->next != NULL) + new = new->next; + + return new; +} + + +/* Free a single code structure, but not the actual structure itself. */ + +void +gfc_free_statement (gfc_code * p) +{ + + if (p->expr) + gfc_free_expr (p->expr); + if (p->expr2) + gfc_free_expr (p->expr2); + + switch (p->op) + { + case EXEC_NOP: + case EXEC_ASSIGN: + case EXEC_GOTO: + case EXEC_CYCLE: + case EXEC_RETURN: + case EXEC_IF: + case EXEC_PAUSE: + case EXEC_STOP: + case EXEC_EXIT: + case EXEC_WHERE: + case EXEC_IOLENGTH: + case EXEC_POINTER_ASSIGN: + case EXEC_DO_WHILE: + case EXEC_CONTINUE: + case EXEC_TRANSFER: + case EXEC_LABEL_ASSIGN: + + case EXEC_ARITHMETIC_IF: + break; + + case EXEC_CALL: + gfc_free_actual_arglist (p->ext.actual); + break; + + case EXEC_SELECT: + if (p->ext.case_list) + gfc_free_case_list (p->ext.case_list); + break; + + case EXEC_DO: + gfc_free_iterator (p->ext.iterator, 1); + break; + + case EXEC_ALLOCATE: + case EXEC_DEALLOCATE: + gfc_free_alloc_list (p->ext.alloc_list); + break; + + case EXEC_OPEN: + gfc_free_open (p->ext.open); + break; + + case EXEC_CLOSE: + gfc_free_close (p->ext.close); + break; + + case EXEC_BACKSPACE: + case EXEC_ENDFILE: + case EXEC_REWIND: + gfc_free_filepos (p->ext.filepos); + break; + + case EXEC_INQUIRE: + gfc_free_inquire (p->ext.inquire); + break; + + case EXEC_READ: + case EXEC_WRITE: + gfc_free_dt (p->ext.dt); + break; + + case EXEC_DT_END: + /* The ext.dt member is a duplicate pointer and doesn't need to + be freed. */ + break; + + case EXEC_FORALL: + gfc_free_forall_iterator (p->ext.forall_iterator); + break; + + default: + gfc_internal_error ("gfc_free_statement(): Bad statement"); + } +} + + +/* Free a code statement and all other code structures linked to it. */ + +void +gfc_free_statements (gfc_code * p) +{ + gfc_code *q; + + for (; p; p = q) + { + q = p->next; + + if (p->block) + gfc_free_statements (p->block); + gfc_free_statement (p); + gfc_free (p); + } +} + diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c new file mode 100644 index 00000000000..1bf32b241e7 --- /dev/null +++ b/gcc/fortran/symbol.c @@ -0,0 +1,2417 @@ +/* Maintain binary trees of symbols. + Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#include "config.h" +#include <string.h> +#include <stdio.h> +#include <stdlib.h> + +#include "gfortran.h" +#include "parse.h" + +/* Strings for all symbol attributes. We use these for dumping the + parse tree, in error messages, and also when reading and writing + modules. */ + +const mstring flavors[] = +{ + minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM), + minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE), + minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER), + minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE), + minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST), + minit (NULL, -1) +}; + +const mstring procedures[] = +{ + minit ("UNKNOWN-PROC", PROC_UNKNOWN), + minit ("MODULE-PROC", PROC_MODULE), + minit ("INTERNAL-PROC", PROC_INTERNAL), + minit ("DUMMY-PROC", PROC_DUMMY), + minit ("INTRINSIC-PROC", PROC_INTRINSIC), + minit ("EXTERNAL-PROC", PROC_EXTERNAL), + minit ("STATEMENT-PROC", PROC_ST_FUNCTION), + minit (NULL, -1) +}; + +const mstring intents[] = +{ + minit ("UNKNOWN-INTENT", INTENT_UNKNOWN), + minit ("IN", INTENT_IN), + minit ("OUT", INTENT_OUT), + minit ("INOUT", INTENT_INOUT), + minit (NULL, -1) +}; + +const mstring access_types[] = +{ + minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN), + minit ("PUBLIC", ACCESS_PUBLIC), + minit ("PRIVATE", ACCESS_PRIVATE), + minit (NULL, -1) +}; + +const mstring ifsrc_types[] = +{ + minit ("UNKNOWN", IFSRC_UNKNOWN), + minit ("DECL", IFSRC_DECL), + minit ("BODY", IFSRC_IFBODY), + minit ("USAGE", IFSRC_USAGE) +}; + + +/* This is to make sure the backend generates setup code in the correct + order. */ + +static int next_dummy_order = 1; + + +gfc_namespace *gfc_current_ns; + +static gfc_symbol *changed_syms = NULL; + + +/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/ + +/* The following static variables hold the default types set by + IMPLICIT statements. We have to store kind information because of + IMPLICIT DOUBLE PRECISION statements. IMPLICIT NONE stores a + BT_UNKNOWN into all elements. The arrays of flags indicate whether + a particular element has been explicitly set or not. */ + +static gfc_typespec new_ts[GFC_LETTERS]; +static int new_flag[GFC_LETTERS]; + + +/* Handle a correctly parsed IMPLICIT NONE. */ + +void +gfc_set_implicit_none (void) +{ + int i; + + for (i = 'a'; i <= 'z'; i++) + { + gfc_clear_ts (&gfc_current_ns->default_type[i - 'a']); + gfc_current_ns->set_flag[i - 'a'] = 1; + } +} + + +/* Sets the implicit types parsed by gfc_match_implicit(). */ + +void +gfc_set_implicit (void) +{ + int i; + + for (i = 0; i < GFC_LETTERS; i++) + if (new_flag[i]) + { + gfc_current_ns->default_type[i] = new_ts[i]; + gfc_current_ns->set_flag[i] = 1; + } +} + + +/* Wipe anything a previous IMPLICIT statement may have tried to do. */ +void gfc_clear_new_implicit (void) +{ + int i; + + for (i = 0; i < GFC_LETTERS; i++) + { + gfc_clear_ts (&new_ts[i]); + if (new_flag[i]) + new_flag[i] = 0; + } +} + + +/* Prepare for a new implicit range. Sets flags in new_flag[] and + copies the typespec to new_ts[]. */ + +try gfc_add_new_implicit_range (int c1, int c2, gfc_typespec * ts) +{ + int i; + + c1 -= 'a'; + c2 -= 'a'; + + for (i = c1; i <= c2; i++) + { + if (new_flag[i]) + { + gfc_error ("Letter '%c' already set in IMPLICIT statement at %C", + i + 'A'); + return FAILURE; + } + + new_ts[i] = *ts; + new_flag[i] = 1; + } + + return SUCCESS; +} + + +/* Add a matched implicit range for gfc_set_implicit(). An implicit + statement has been fully matched at this point. We now need to + check if merging the new implicit types back into the existing + types will work. */ + +try +gfc_merge_new_implicit (void) +{ + int i; + + for (i = 0; i < GFC_LETTERS; i++) + if (new_flag[i]) + { + if (gfc_current_ns->set_flag[i]) + { + gfc_error ("Letter %c already has an IMPLICIT type at %C", + i + 'A'); + return FAILURE; + } + } + + return SUCCESS; +} + + +/* Given a symbol, return a pointer to the typespec for it's default + type. */ + +gfc_typespec * +gfc_get_default_type (gfc_symbol * sym, gfc_namespace * ns) +{ + char letter; + + letter = sym->name[0]; + if (letter < 'a' || letter > 'z') + gfc_internal_error ("gfc_get_default_type(): Bad symbol"); + + if (ns == NULL) + ns = gfc_current_ns; + + return &ns->default_type[letter - 'a']; +} + + +/* Given a pointer to a symbol, set its type according to the first + letter of its name. Fails if the letter in question has no default + type. */ + +try +gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns) +{ + gfc_typespec *ts; + + if (sym->ts.type != BT_UNKNOWN) + gfc_internal_error ("gfc_set_default_type(): symbol already has a type"); + + ts = gfc_get_default_type (sym, ns); + + if (ts->type == BT_UNKNOWN) + { + if (error_flag) + gfc_error ("Symbol '%s' at %L has no IMPLICIT type", sym->name, + &sym->declared_at); + + return FAILURE; + } + + sym->ts = *ts; + sym->attr.implicit_type = 1; + + return SUCCESS; +} + + +/******************** Symbol attribute stuff *********************/ + +/* This is a generic conflict-checker. We do this to avoid having a + single conflict in two places. */ + +#define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; } +#define conf2(a) if (attr->a) { a2 = a; goto conflict; } + +static try +check_conflict (symbol_attribute * attr, locus * where) +{ + static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER", + *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT", + *intrinsic = "INTRINSIC", *allocatable = "ALLOCATABLE", + *elemental = "ELEMENTAL", *private = "PRIVATE", *recursive = "RECURSIVE", + *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST", + *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY", + *function = "FUNCTION", *subroutine = "SUBROUTINE", + *dimension = "DIMENSION"; + + const char *a1, *a2; + + if (where == NULL) + where = gfc_current_locus (); + + if (attr->pointer && attr->intent != INTENT_UNKNOWN) + { + a1 = pointer; + a2 = intent; + goto conflict; + } + + /* Check for attributes not allowed in a BLOCK DATA. */ + if (gfc_current_state () == COMP_BLOCK_DATA) + { + a1 = NULL; + + if (attr->allocatable) + a1 = allocatable; + if (attr->external) + a1 = external; + if (attr->optional) + a1 = optional; + if (attr->access == ACCESS_PRIVATE) + a1 = private; + if (attr->access == ACCESS_PUBLIC) + a1 = public; + if (attr->intent != INTENT_UNKNOWN) + a1 = intent; + + if (a1 != NULL) + { + gfc_error + ("%s attribute not allowed in BLOCK DATA program unit at %L", a1, + where); + return FAILURE; + } + } + + conf (dummy, save); + conf (pointer, target); + conf (pointer, external); + conf (pointer, intrinsic); + conf (target, external); + conf (target, intrinsic); + conf (external, dimension); /* See Fortran 95's R504. */ + + conf (external, intrinsic); + conf (allocatable, pointer); + conf (allocatable, dummy); /* TODO: Allowed in Fortran 200x. */ + conf (allocatable, function); /* TODO: Allowed in Fortran 200x. */ + conf (allocatable, result); /* TODO: Allowed in Fortran 200x. */ + conf (elemental, recursive); + + conf (in_common, dummy); + conf (in_common, allocatable); + conf (in_common, result); + conf (dummy, result); + + conf (in_namelist, pointer); + conf (in_namelist, allocatable); + + conf (entry, result); + + conf (function, subroutine); + + a1 = gfc_code2string (flavors, attr->flavor); + + if (attr->in_namelist + && attr->flavor != FL_VARIABLE + && attr->flavor != FL_UNKNOWN) + { + + a2 = in_namelist; + goto conflict; + } + + switch (attr->flavor) + { + case FL_PROGRAM: + case FL_BLOCK_DATA: + case FL_MODULE: + case FL_LABEL: + conf2 (dummy); + conf2 (save); + conf2 (pointer); + conf2 (target); + conf2 (external); + conf2 (intrinsic); + conf2 (allocatable); + conf2 (result); + conf2 (in_namelist); + conf2 (optional); + conf2 (function); + conf2 (subroutine); + break; + + case FL_VARIABLE: + case FL_NAMELIST: + break; + + case FL_PROCEDURE: + conf2 (intent); + + if (attr->subroutine) + { + conf2(save); + conf2(pointer); + conf2(target); + conf2(allocatable); + conf2(result); + conf2(in_namelist); + conf2(function); + } + + switch (attr->proc) + { + case PROC_ST_FUNCTION: + conf2 (in_common); + break; + + case PROC_MODULE: + conf2 (dummy); + break; + + case PROC_DUMMY: + conf2 (result); + conf2 (in_common); + conf2 (save); + break; + + default: + break; + } + + break; + + case FL_DERIVED: + conf2 (dummy); + conf2 (save); + conf2 (pointer); + conf2 (target); + conf2 (external); + conf2 (intrinsic); + conf2 (allocatable); + conf2 (optional); + conf2 (entry); + conf2 (function); + conf2 (subroutine); + + if (attr->intent != INTENT_UNKNOWN) + { + a2 = intent; + goto conflict; + } + break; + + case FL_PARAMETER: + conf2 (external); + conf2 (intrinsic); + conf2 (optional); + conf2 (allocatable); + conf2 (function); + conf2 (subroutine); + conf2 (entry); + conf2 (pointer); + conf2 (target); + conf2 (dummy); + conf2 (in_common); + break; + + default: + break; + } + + return SUCCESS; + +conflict: + gfc_error ("%s attribute conflicts with %s attribute at %L", a1, a2, where); + return FAILURE; +} + +#undef conf +#undef conf2 + + +/* Mark a symbol as referenced. */ + +void +gfc_set_sym_referenced (gfc_symbol * sym) +{ + if (sym->attr.referenced) + return; + + sym->attr.referenced = 1; + + /* Remember which order dummy variables are accessed in. */ + if (sym->attr.dummy) + sym->dummy_order = next_dummy_order++; +} + + +/* Common subroutine called by attribute changing subroutines in order + to prevent them from changing a symbol that has been + use-associated. Returns zero if it is OK to change the symbol, + nonzero if not. */ + +static int +check_used (symbol_attribute * attr, locus * where) +{ + + if (attr->use_assoc == 0) + return 0; + + if (where == NULL) + where = gfc_current_locus (); + + gfc_error ("Cannot change attributes of USE-associated symbol at %L", + where); + + return 1; +} + + +/* Used to prevent changing the attributes of a symbol after it has been + used. This check is only done from dummy variable as only these can be + used in specification expressions. Applying this to all symbols causes + error when we reach the body of a contained function. */ + +static int +check_done (symbol_attribute * attr, locus * where) +{ + + if (!(attr->dummy && attr->referenced)) + return 0; + + if (where == NULL) + where = gfc_current_locus (); + + gfc_error ("Cannot change attributes of symbol at %L" + " after it has been used", where); + + return 1; +} + + +/* Generate an error because of a duplicate attribute. */ + +static void +duplicate_attr (const char *attr, locus * where) +{ + + if (where == NULL) + where = gfc_current_locus (); + + gfc_error ("Duplicate %s attribute specified at %L", attr, where); +} + + +try +gfc_add_allocatable (symbol_attribute * attr, locus * where) +{ + + if (check_used (attr, where) || check_done (attr, where)) + return FAILURE; + + if (attr->allocatable) + { + duplicate_attr ("ALLOCATABLE", where); + return FAILURE; + } + + attr->allocatable = 1; + return check_conflict (attr, where); +} + + +try +gfc_add_dimension (symbol_attribute * attr, locus * where) +{ + + if (check_used (attr, where) || check_done (attr, where)) + return FAILURE; + + if (attr->dimension) + { + duplicate_attr ("DIMENSION", where); + return FAILURE; + } + + attr->dimension = 1; + return check_conflict (attr, where); +} + + +try +gfc_add_external (symbol_attribute * attr, locus * where) +{ + + if (check_used (attr, where) || check_done (attr, where)) + return FAILURE; + + if (attr->external) + { + duplicate_attr ("EXTERNAL", where); + return FAILURE; + } + + attr->external = 1; + + return check_conflict (attr, where); +} + + +try +gfc_add_intrinsic (symbol_attribute * attr, locus * where) +{ + + if (check_used (attr, where) || check_done (attr, where)) + return FAILURE; + + if (attr->intrinsic) + { + duplicate_attr ("INTRINSIC", where); + return FAILURE; + } + + attr->intrinsic = 1; + + return check_conflict (attr, where); +} + + +try +gfc_add_optional (symbol_attribute * attr, locus * where) +{ + + if (check_used (attr, where) || check_done (attr, where)) + return FAILURE; + + if (attr->optional) + { + duplicate_attr ("OPTIONAL", where); + return FAILURE; + } + + attr->optional = 1; + return check_conflict (attr, where); +} + + +try +gfc_add_pointer (symbol_attribute * attr, locus * where) +{ + + if (check_used (attr, where) || check_done (attr, where)) + return FAILURE; + + attr->pointer = 1; + return check_conflict (attr, where); +} + + +try +gfc_add_result (symbol_attribute * attr, locus * where) +{ + + if (check_used (attr, where) || check_done (attr, where)) + return FAILURE; + + attr->result = 1; + return check_conflict (attr, where); +} + + +try +gfc_add_save (symbol_attribute * attr, locus * where) +{ + + if (check_used (attr, where)) + return FAILURE; + + if (gfc_pure (NULL)) + { + gfc_error + ("SAVE attribute at %L cannot be specified in a PURE procedure", + where); + return FAILURE; + } + + if (attr->save) + { + duplicate_attr ("SAVE", where); + return FAILURE; + } + + attr->save = 1; + return check_conflict (attr, where); +} + + +try +gfc_add_saved_common (symbol_attribute * attr, locus * where) +{ + + if (check_used (attr, where)) + return FAILURE; + + if (attr->saved_common) + { + duplicate_attr ("SAVE", where); + return FAILURE; + } + + attr->saved_common = 1; + return check_conflict (attr, where); +} + + +try +gfc_add_target (symbol_attribute * attr, locus * where) +{ + + if (check_used (attr, where) || check_done (attr, where)) + return FAILURE; + + if (attr->target) + { + duplicate_attr ("TARGET", where); + return FAILURE; + } + + attr->target = 1; + return check_conflict (attr, where); +} + + +try +gfc_add_dummy (symbol_attribute * attr, locus * where) +{ + + if (check_used (attr, where)) + return FAILURE; + + /* Duplicate dummy arguments are allow due to ENTRY statements. */ + attr->dummy = 1; + return check_conflict (attr, where); +} + + +try +gfc_add_common (symbol_attribute * attr, locus * where) +{ + + if (check_used (attr, where) || check_done (attr, where)) + return FAILURE; + + attr->common = 1; + return check_conflict (attr, where); +} + + +try +gfc_add_in_common (symbol_attribute * attr, locus * where) +{ + + if (check_used (attr, where) || check_done (attr, where)) + return FAILURE; + + /* Duplicate attribute already checked for. */ + attr->in_common = 1; + if (check_conflict (attr, where) == FAILURE) + return FAILURE; + + if (attr->flavor == FL_VARIABLE) + return SUCCESS; + + return gfc_add_flavor (attr, FL_VARIABLE, where); +} + + +try +gfc_add_in_namelist (symbol_attribute * attr, locus * where) +{ + + attr->in_namelist = 1; + return check_conflict (attr, where); +} + + +try +gfc_add_sequence (symbol_attribute * attr, locus * where) +{ + + if (check_used (attr, where)) + return FAILURE; + + attr->sequence = 1; + return check_conflict (attr, where); +} + + +try +gfc_add_elemental (symbol_attribute * attr, locus * where) +{ + + if (check_used (attr, where) || check_done (attr, where)) + return FAILURE; + + attr->elemental = 1; + return check_conflict (attr, where); +} + + +try +gfc_add_pure (symbol_attribute * attr, locus * where) +{ + + if (check_used (attr, where) || check_done (attr, where)) + return FAILURE; + + attr->pure = 1; + return check_conflict (attr, where); +} + + +try +gfc_add_recursive (symbol_attribute * attr, locus * where) +{ + + if (check_used (attr, where) || check_done (attr, where)) + return FAILURE; + + attr->recursive = 1; + return check_conflict (attr, where); +} + + +try +gfc_add_entry (symbol_attribute * attr, locus * where) +{ + + if (check_used (attr, where)) + return FAILURE; + + if (attr->entry) + { + duplicate_attr ("ENTRY", where); + return FAILURE; + } + + attr->entry = 1; + return check_conflict (attr, where); +} + + +try +gfc_add_function (symbol_attribute * attr, locus * where) +{ + + if (attr->flavor != FL_PROCEDURE + && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE) + return FAILURE; + + attr->function = 1; + return check_conflict (attr, where); +} + + +try +gfc_add_subroutine (symbol_attribute * attr, locus * where) +{ + + if (attr->flavor != FL_PROCEDURE + && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE) + return FAILURE; + + attr->subroutine = 1; + return check_conflict (attr, where); +} + + +try +gfc_add_generic (symbol_attribute * attr, locus * where) +{ + + if (attr->flavor != FL_PROCEDURE + && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE) + return FAILURE; + + attr->generic = 1; + return check_conflict (attr, where); +} + + +/* Flavors are special because some flavors are not what fortran + considers attributes and can be reaffirmed multiple times. */ + +try +gfc_add_flavor (symbol_attribute * attr, sym_flavor f, locus * where) +{ + + if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE + || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED + || f == FL_NAMELIST) && check_used (attr, where)) + return FAILURE; + + if (attr->flavor == f && f == FL_VARIABLE) + return SUCCESS; + + if (attr->flavor != FL_UNKNOWN) + { + if (where == NULL) + where = gfc_current_locus (); + + gfc_error ("%s attribute conflicts with %s attribute at %L", + gfc_code2string (flavors, attr->flavor), + gfc_code2string (flavors, f), where); + + return FAILURE; + } + + attr->flavor = f; + + return check_conflict (attr, where); +} + + +try +gfc_add_procedure (symbol_attribute * attr, procedure_type t, locus * where) +{ + + if (check_used (attr, where) || check_done (attr, where)) + return FAILURE; + + if (attr->flavor != FL_PROCEDURE + && gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE) + return FAILURE; + + if (where == NULL) + where = gfc_current_locus (); + + if (attr->proc != PROC_UNKNOWN) + { + gfc_error ("%s procedure at %L is already %s %s procedure", + gfc_code2string (procedures, t), where, + gfc_article (gfc_code2string (procedures, attr->proc)), + gfc_code2string (procedures, attr->proc)); + + return FAILURE; + } + + attr->proc = t; + + /* Statement functions are always scalar and functions. */ + if (t == PROC_ST_FUNCTION + && ((!attr->function && gfc_add_function (attr, where) == FAILURE) + || attr->dimension)) + return FAILURE; + + return check_conflict (attr, where); +} + + +try +gfc_add_intent (symbol_attribute * attr, sym_intent intent, locus * where) +{ + + if (check_used (attr, where)) + return FAILURE; + + if (attr->intent == INTENT_UNKNOWN) + { + attr->intent = intent; + return check_conflict (attr, where); + } + + if (where == NULL) + where = gfc_current_locus (); + + gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L", + gfc_intent_string (attr->intent), + gfc_intent_string (intent), where); + + return FAILURE; +} + + +/* No checks for use-association in public and private statements. */ + +try +gfc_add_access (symbol_attribute * attr, gfc_access access, locus * where) +{ + + if (attr->access == ACCESS_UNKNOWN) + { + attr->access = access; + return check_conflict (attr, where); + } + + if (where == NULL) + where = gfc_current_locus (); + gfc_error ("ACCESS specification at %L was already specified", where); + + return FAILURE; +} + + +try +gfc_add_explicit_interface (gfc_symbol * sym, ifsrc source, + gfc_formal_arglist * formal, locus * where) +{ + + if (check_used (&sym->attr, where)) + return FAILURE; + + if (where == NULL) + where = gfc_current_locus (); + + if (sym->attr.if_source != IFSRC_UNKNOWN + && sym->attr.if_source != IFSRC_DECL) + { + gfc_error ("Symbol '%s' at %L already has an explicit interface", + sym->name, where); + return FAILURE; + } + + sym->formal = formal; + sym->attr.if_source = source; + + return SUCCESS; +} + + +/* Add a type to a symbol. */ + +try +gfc_add_type (gfc_symbol * sym, gfc_typespec * ts, locus * where) +{ + sym_flavor flavor; + +/* TODO: This is legal if it is reaffirming an implicit type. + if (check_done (&sym->attr, where)) + return FAILURE;*/ + + if (where == NULL) + where = gfc_current_locus (); + + if (sym->ts.type != BT_UNKNOWN) + { + gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name, + where, gfc_basic_typename (sym->ts.type)); + return FAILURE; + } + + flavor = sym->attr.flavor; + + if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE + || flavor == FL_LABEL || (flavor == FL_PROCEDURE + && sym->attr.subroutine) + || flavor == FL_DERIVED || flavor == FL_NAMELIST) + { + gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where); + return FAILURE; + } + + sym->ts = *ts; + return SUCCESS; +} + + +/* Clears all attributes. */ + +void +gfc_clear_attr (symbol_attribute * attr) +{ + + attr->allocatable = 0; + attr->dimension = 0; + attr->external = 0; + attr->intrinsic = 0; + attr->optional = 0; + attr->pointer = 0; + attr->save = 0; + attr->target = 0; + attr->dummy = 0; + attr->common = 0; + attr->result = 0; + attr->entry = 0; + attr->data = 0; + attr->use_assoc = 0; + attr->in_namelist = 0; + + attr->in_common = 0; + attr->saved_common = 0; + attr->function = 0; + attr->subroutine = 0; + attr->generic = 0; + attr->implicit_type = 0; + attr->sequence = 0; + attr->elemental = 0; + attr->pure = 0; + attr->recursive = 0; + + attr->access = ACCESS_UNKNOWN; + attr->intent = INTENT_UNKNOWN; + attr->flavor = FL_UNKNOWN; + attr->proc = PROC_UNKNOWN; + attr->if_source = IFSRC_UNKNOWN; +} + + +/* Check for missing attributes in the new symbol. Currently does + nothing, but it's not clear that it is unnecessary yet. */ + +try +gfc_missing_attr (symbol_attribute * attr ATTRIBUTE_UNUSED, + locus * where ATTRIBUTE_UNUSED) +{ + + return SUCCESS; +} + + +/* Copy an attribute to a symbol attribute, bit by bit. Some + attributes have a lot of side-effects but cannot be present given + where we are called from, so we ignore some bits. */ + +try +gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where) +{ + + if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE) + goto fail; + + if (src->dimension && gfc_add_dimension (dest, where) == FAILURE) + goto fail; + if (src->optional && gfc_add_optional (dest, where) == FAILURE) + goto fail; + if (src->pointer && gfc_add_pointer (dest, where) == FAILURE) + goto fail; + if (src->save && gfc_add_save (dest, where) == FAILURE) + goto fail; + if (src->target && gfc_add_target (dest, where) == FAILURE) + goto fail; + if (src->dummy && gfc_add_dummy (dest, where) == FAILURE) + goto fail; + if (src->common && gfc_add_common (dest, where) == FAILURE) + goto fail; + if (src->result && gfc_add_result (dest, where) == FAILURE) + goto fail; + if (src->entry) + dest->entry = 1; + + if (src->in_namelist && gfc_add_in_namelist (dest, where) == FAILURE) + goto fail; + + if (src->in_common && gfc_add_in_common (dest, where) == FAILURE) + goto fail; + if (src->saved_common && gfc_add_saved_common (dest, where) == FAILURE) + goto fail; + + if (src->generic && gfc_add_generic (dest, where) == FAILURE) + goto fail; + if (src->function && gfc_add_function (dest, where) == FAILURE) + goto fail; + if (src->subroutine && gfc_add_subroutine (dest, where) == FAILURE) + goto fail; + + if (src->sequence && gfc_add_sequence (dest, where) == FAILURE) + goto fail; + if (src->elemental && gfc_add_elemental (dest, where) == FAILURE) + goto fail; + if (src->pure && gfc_add_pure (dest, where) == FAILURE) + goto fail; + if (src->recursive && gfc_add_recursive (dest, where) == FAILURE) + goto fail; + + if (src->flavor != FL_UNKNOWN + && gfc_add_flavor (dest, src->flavor, where) == FAILURE) + goto fail; + + if (src->intent != INTENT_UNKNOWN + && gfc_add_intent (dest, src->intent, where) == FAILURE) + goto fail; + + if (src->access != ACCESS_UNKNOWN + && gfc_add_access (dest, src->access, where) == FAILURE) + goto fail; + + if (gfc_missing_attr (dest, where) == FAILURE) + goto fail; + + /* The subroutines that set these bits also cause flavors to be set, + and that has already happened in the original, so don't let to + happen again. */ + if (src->external) + dest->external = 1; + if (src->intrinsic) + dest->intrinsic = 1; + + return SUCCESS; + +fail: + return FAILURE; +} + + +/************** Component name management ************/ + +/* Component names of a derived type form their own little namespaces + that are separate from all other spaces. The space is composed of + a singly linked list of gfc_component structures whose head is + located in the parent symbol. */ + + +/* Add a component name to a symbol. The call fails if the name is + already present. On success, the component pointer is modified to + point to the additional component structure. */ + +try +gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** component) +{ + gfc_component *p, *tail; + + tail = NULL; + + for (p = sym->components; p; p = p->next) + { + if (strcmp (p->name, name) == 0) + { + gfc_error ("Component '%s' at %C already declared at %L", + name, &p->loc); + return FAILURE; + } + + tail = p; + } + + /* Allocate new component */ + p = gfc_get_component (); + + if (tail == NULL) + sym->components = p; + else + tail->next = p; + + strcpy (p->name, name); + p->loc = *gfc_current_locus (); + + *component = p; + return SUCCESS; +} + + +/* Recursive function to switch derived types of all symbol in a + namespace. */ + +static void +switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to) +{ + gfc_symbol *sym; + + if (st == NULL) + return; + + sym = st->n.sym; + if (sym->ts.type == BT_DERIVED && sym->ts.derived == from) + sym->ts.derived = to; + + switch_types (st->left, from, to); + switch_types (st->right, from, to); +} + + +/* This subroutine is called when a derived type is used in order to + make the final determination about which version to use. The + standard requires that a type be defined before it is 'used', but + such types can appear in IMPLICIT statements before the actual + definition. 'Using' in this context means declaring a variable to + be that type or using the type constructor. + + If a type is used and the components haven't been defined, then we + have to have a derived type in a parent unit. We find the node in + the other namespace and point the symtree node in this namespace to + that node. Further reference to this name point to the correct + node. If we can't find the node in a parent namespace, then have + an error. + + This subroutine takes a pointer to a symbol node and returns a + pointer to the translated node or NULL for an error. Usually there + is no translation and we return the node we were passed. */ + +static gfc_symtree * +gfc_use_ha_derived (gfc_symbol * sym) +{ + gfc_symbol *s, *p; + gfc_typespec *t; + gfc_symtree *st; + int i; + + if (sym->ns->parent == NULL) + goto bad; + + if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s)) + { + gfc_error ("Symbol '%s' at %C is ambiguous", sym->name); + return NULL; + } + + if (s == NULL || s->attr.flavor != FL_DERIVED) + goto bad; + + /* Get rid of symbol sym, translating all references to s. */ + for (i = 0; i < GFC_LETTERS; i++) + { + t = &sym->ns->default_type[i]; + if (t->derived == sym) + t->derived = s; + } + + st = gfc_find_symtree (sym->ns->sym_root, sym->name); + st->n.sym = s; + + s->refs++; + + /* Unlink from list of modified symbols. */ + if (changed_syms == sym) + changed_syms = sym->tlink; + else + for (p = changed_syms; p; p = p->tlink) + if (p->tlink == sym) + { + p->tlink = sym->tlink; + break; + } + + switch_types (sym->ns->sym_root, sym, s); + + /* TODO: Also have to replace sym -> s in other lists like + namelists, common lists and interface lists. */ + gfc_free_symbol (sym); + + return st; + +bad: + gfc_error ("Derived type '%s' at %C is being used before it is defined", + sym->name); + return NULL; +} + + +gfc_symbol * +gfc_use_derived (gfc_symbol * sym) +{ + gfc_symtree *st; + + if (sym->components != NULL) + return sym; /* Already defined */ + + st = gfc_use_ha_derived (sym); + if (st) + return st->n.sym; + else + return NULL; +} + + +/* Given a derived type node and a component name, try to locate the + component structure. Returns the NULL pointer if the component is + not found or the components are private. */ + +gfc_component * +gfc_find_component (gfc_symbol * sym, const char *name) +{ + gfc_component *p; + + if (name == NULL) + return NULL; + + sym = gfc_use_derived (sym); + + if (sym == NULL) + return NULL; + + for (p = sym->components; p; p = p->next) + if (strcmp (p->name, name) == 0) + break; + + if (p == NULL) + gfc_error ("'%s' at %C is not a member of the '%s' structure", + name, sym->name); + else + { + if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE) + { + gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'", + name, sym->name); + p = NULL; + } + } + + return p; +} + + +/* Given a symbol, free all of the component structures and everything + they point to. */ + +static void +free_components (gfc_component * p) +{ + gfc_component *q; + + for (; p; p = q) + { + q = p->next; + + gfc_free_array_spec (p->as); + gfc_free_expr (p->initializer); + + gfc_free (p); + } +} + + +/* Set component attributes from a standard symbol attribute + structure. */ + +void +gfc_set_component_attr (gfc_component * c, symbol_attribute * attr) +{ + + c->dimension = attr->dimension; + c->pointer = attr->pointer; +} + + +/* Get a standard symbol attribute structure given the component + structure. */ + +void +gfc_get_component_attr (symbol_attribute * attr, gfc_component * c) +{ + + gfc_clear_attr (attr); + attr->dimension = c->dimension; + attr->pointer = c->pointer; +} + + +/******************** Statement label management ********************/ + +/* Free a single gfc_st_label structure, making sure the list is not + messed up. This function is called only when some parse error + occurs. */ + +void +gfc_free_st_label (gfc_st_label * l) +{ + + if (l == NULL) + return; + + if (l->prev) + (l->prev->next = l->next); + + if (l->next) + (l->next->prev = l->prev); + + if (l->format != NULL) + gfc_free_expr (l->format); + gfc_free (l); +} + +/* Free a whole list of gfc_st_label structures. */ + +static void +free_st_labels (gfc_st_label * l1) +{ + gfc_st_label *l2; + + for (; l1; l1 = l2) + { + l2 = l1->next; + if (l1->format != NULL) + gfc_free_expr (l1->format); + gfc_free (l1); + } +} + + +/* Given a label number, search for and return a pointer to the label + structure, creating it if it does not exist. */ + +gfc_st_label * +gfc_get_st_label (int labelno) +{ + gfc_st_label *lp; + + /* First see if the label is already in this namespace. */ + for (lp = gfc_current_ns->st_labels; lp; lp = lp->next) + if (lp->value == labelno) + break; + if (lp != NULL) + return lp; + + lp = gfc_getmem (sizeof (gfc_st_label)); + + lp->value = labelno; + lp->defined = ST_LABEL_UNKNOWN; + lp->referenced = ST_LABEL_UNKNOWN; + + lp->prev = NULL; + lp->next = gfc_current_ns->st_labels; + if (gfc_current_ns->st_labels) + gfc_current_ns->st_labels->prev = lp; + gfc_current_ns->st_labels = lp; + + return lp; +} + + +/* Called when a statement with a statement label is about to be + accepted. We add the label to the list of the current namespace, + making sure it hasn't been defined previously and referenced + correctly. */ + +void +gfc_define_st_label (gfc_st_label * lp, gfc_sl_type type, locus * label_locus) +{ + int labelno; + + labelno = lp->value; + + if (lp->defined != ST_LABEL_UNKNOWN) + gfc_error ("Duplicate statement label %d at %L and %L", labelno, + &lp->where, label_locus); + else + { + lp->where = *label_locus; + + switch (type) + { + case ST_LABEL_FORMAT: + if (lp->referenced == ST_LABEL_TARGET) + gfc_error ("Label %d at %C already referenced as branch target", + labelno); + else + lp->defined = ST_LABEL_FORMAT; + + break; + + case ST_LABEL_TARGET: + if (lp->referenced == ST_LABEL_FORMAT) + gfc_error ("Label %d at %C already referenced as a format label", + labelno); + else + lp->defined = ST_LABEL_TARGET; + + break; + + default: + lp->defined = ST_LABEL_BAD_TARGET; + lp->referenced = ST_LABEL_BAD_TARGET; + } + } +} + + +/* Reference a label. Given a label and its type, see if that + reference is consistent with what is known about that label, + updating the unknown state. Returns FAILURE if something goes + wrong. */ + +try +gfc_reference_st_label (gfc_st_label * lp, gfc_sl_type type) +{ + gfc_sl_type label_type; + int labelno; + try rc; + + if (lp == NULL) + return SUCCESS; + + labelno = lp->value; + + if (lp->defined != ST_LABEL_UNKNOWN) + label_type = lp->defined; + else + { + label_type = lp->referenced; + lp->where = *gfc_current_locus (); + } + + if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET) + { + gfc_error ("Label %d at %C previously used as a FORMAT label", labelno); + rc = FAILURE; + goto done; + } + + if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET) + && type == ST_LABEL_FORMAT) + { + gfc_error ("Label %d at %C previously used as branch target", labelno); + rc = FAILURE; + goto done; + } + + lp->referenced = type; + rc = SUCCESS; + +done: + return rc; +} + + +/************** Symbol table management subroutines ****************/ + +/* Basic details: Fortran 95 requires a potentially unlimited number + of distinct namespaces when compiling a program unit. This case + occurs during a compilation of internal subprograms because all of + the internal subprograms must be read before we can start + generating code for the host. + + Given the tricky nature of the fortran grammar, we must be able to + undo changes made to a symbol table if the current interpretation + of a statement is found to be incorrect. Whenever a symbol is + looked up, we make a copy of it and link to it. All of these + symbols are kept in a singly linked list so that we can commit or + undo the changes at a later time. + + A symtree may point to a symbol node outside of it's namespace. In + this case, that symbol has been used as a host associated variable + at some previous time. */ + +/* Allocate a new namespace structure. */ + +gfc_namespace * +gfc_get_namespace (gfc_namespace * parent) +{ + gfc_namespace *ns; + gfc_typespec *ts; + gfc_intrinsic_op in; + int i; + + ns = gfc_getmem (sizeof (gfc_namespace)); + ns->sym_root = NULL; + ns->uop_root = NULL; + ns->default_access = ACCESS_UNKNOWN; + ns->parent = parent; + + for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++) + ns->operator_access[in] = ACCESS_UNKNOWN; + + /* Initialize default implicit types. */ + for (i = 'a'; i <= 'z'; i++) + { + ns->set_flag[i - 'a'] = 0; + ts = &ns->default_type[i - 'a']; + + if (ns->parent != NULL) + { + /* Copy parent settings */ + *ts = ns->parent->default_type[i - 'a']; + continue; + } + + if (gfc_option.flag_implicit_none != 0) + { + gfc_clear_ts (ts); + continue; + } + + if ('i' <= i && i <= 'n') + { + ts->type = BT_INTEGER; + ts->kind = gfc_default_integer_kind (); + } + else + { + ts->type = BT_REAL; + ts->kind = gfc_default_real_kind (); + } + } + + return ns; +} + + +/* Comparison function for symtree nodes. */ + +static int +compare_symtree (void * _st1, void * _st2) +{ + gfc_symtree *st1, *st2; + + st1 = (gfc_symtree *) _st1; + st2 = (gfc_symtree *) _st2; + + return strcmp (st1->name, st2->name); +} + + +/* Allocate a new symtree node and associate it with the new symbol. */ + +gfc_symtree * +gfc_new_symtree (gfc_symtree ** root, const char *name) +{ + gfc_symtree *st; + + st = gfc_getmem (sizeof (gfc_symtree)); + strcpy (st->name, name); + + gfc_insert_bbt (root, st, compare_symtree); + return st; +} + + +/* Delete a symbol from the tree. Does not free the symbol itself! */ + +static void +delete_symtree (gfc_symtree ** root, const char *name) +{ + gfc_symtree st, *st0; + + st0 = gfc_find_symtree (*root, name); + + strcpy (st.name, name); + gfc_delete_bbt (root, &st, compare_symtree); + + gfc_free (st0); +} + + +/* Given a root symtree node and a name, try to find the symbol within + the namespace. Returns NULL if the symbol is not found. */ + +gfc_symtree * +gfc_find_symtree (gfc_symtree * st, const char *name) +{ + int c; + + while (st != NULL) + { + c = strcmp (name, st->name); + if (c == 0) + return st; + + st = (c < 0) ? st->left : st->right; + } + + return NULL; +} + + +/* Given a name find a user operator node, creating it if it doesn't + exist. These are much simpler than symbols because they can't be + ambiguous with one another. */ + +gfc_user_op * +gfc_get_uop (const char *name) +{ + gfc_user_op *uop; + gfc_symtree *st; + + st = gfc_find_symtree (gfc_current_ns->uop_root, name); + if (st != NULL) + return st->n.uop; + + st = gfc_new_symtree (&gfc_current_ns->uop_root, name); + + uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op)); + strcpy (uop->name, name); + uop->access = ACCESS_UNKNOWN; + uop->ns = gfc_current_ns; + + return uop; +} + + +/* Given a name find the user operator node. Returns NULL if it does + not exist. */ + +gfc_user_op * +gfc_find_uop (const char *name, gfc_namespace * ns) +{ + gfc_symtree *st; + + if (ns == NULL) + ns = gfc_current_ns; + + st = gfc_find_symtree (ns->uop_root, name); + return (st == NULL) ? NULL : st->n.uop; +} + + +/* Remove a gfc_symbol structure and everything it points to. */ + +void +gfc_free_symbol (gfc_symbol * sym) +{ + + if (sym == NULL) + return; + + gfc_free_array_spec (sym->as); + + free_components (sym->components); + + gfc_free_expr (sym->value); + + gfc_free_namelist (sym->namelist); + + gfc_free_namespace (sym->formal_ns); + + gfc_free_interface (sym->generic); + + gfc_free_formal_arglist (sym->formal); + + gfc_free (sym); +} + + +/* Allocate and initialize a new symbol node. */ + +gfc_symbol * +gfc_new_symbol (const char *name, gfc_namespace * ns) +{ + gfc_symbol *p; + + p = gfc_getmem (sizeof (gfc_symbol)); + + gfc_clear_ts (&p->ts); + gfc_clear_attr (&p->attr); + p->ns = ns; + + p->declared_at = *gfc_current_locus (); + + if (strlen (name) > GFC_MAX_SYMBOL_LEN) + gfc_internal_error ("new_symbol(): Symbol name too long"); + + strcpy (p->name, name); + return p; +} + + +/* Generate an error if a symbol is ambiguous. */ + +static void +ambiguous_symbol (const char *name, gfc_symtree * st) +{ + + if (st->n.sym->module[0]) + gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' " + "from module '%s'", name, st->n.sym->name, st->n.sym->module); + else + gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' " + "from current program unit", name, st->n.sym->name); +} + + +/* Search for a symbol starting in the current namespace, resorting to + any parent namespaces if requested by a nonzero parent_flag. + Returns nonzero if the symbol is ambiguous. */ + +int +gfc_find_sym_tree (const char *name, gfc_namespace * ns, int parent_flag, + gfc_symtree ** result) +{ + gfc_symtree *st; + + if (ns == NULL) + ns = gfc_current_ns; + + do + { + st = gfc_find_symtree (ns->sym_root, name); + if (st != NULL) + { + *result = st; + if (st->ambiguous) + { + ambiguous_symbol (name, st); + return 1; + } + + return 0; + } + + if (!parent_flag) + break; + + ns = ns->parent; + } + while (ns != NULL); + + *result = NULL; + return 0; +} + + +int +gfc_find_symbol (const char *name, gfc_namespace * ns, int parent_flag, + gfc_symbol ** result) +{ + gfc_symtree *st; + int i; + + i = gfc_find_sym_tree (name, ns, parent_flag, &st); + + if (st == NULL) + *result = NULL; + else + *result = st->n.sym; + + return i; +} + + +/* Save symbol with the information necessary to back it out. */ + +static void +save_symbol_data (gfc_symbol * sym) +{ + + if (sym->new || sym->old_symbol != NULL) + return; + + sym->old_symbol = gfc_getmem (sizeof (gfc_symbol)); + *(sym->old_symbol) = *sym; + + sym->tlink = changed_syms; + changed_syms = sym; +} + + +/* Given a name, find a symbol, or create it if it does not exist yet + in the current namespace. If the symbol is found we make sure that + it's OK. + + The integer return code indicates + 0 All OK + 1 The symbol name was ambiguous + 2 The name meant to be established was already host associated. + + So if the return value is nonzero, then an error was issued. */ + +int +gfc_get_sym_tree (const char *name, gfc_namespace * ns, gfc_symtree ** result) +{ + gfc_symtree *st; + gfc_symbol *p; + + /* This doesn't usually happen during resolution. */ + if (ns == NULL) + ns = gfc_current_ns; + + /* Try to find the symbol in ns. */ + st = gfc_find_symtree (ns->sym_root, name); + + if (st == NULL) + { + /* If not there, create a new symbol. */ + p = gfc_new_symbol (name, ns); + + /* Add to the list of tentative symbols. */ + p->old_symbol = NULL; + p->tlink = changed_syms; + p->mark = 1; + p->new = 1; + changed_syms = p; + + st = gfc_new_symtree (&ns->sym_root, name); + st->n.sym = p; + p->refs++; + + } + else + { + /* Make sure the existing symbol is OK. */ + if (st->ambiguous) + { + ambiguous_symbol (name, st); + return 1; + } + + p = st->n.sym; + + if (p->ns != ns && (!p->attr.function || ns->proc_name != p)) + { + /* Symbol is from another namespace. */ + gfc_error ("Symbol '%s' at %C has already been host associated", + name); + return 2; + } + + p->mark = 1; + + /* Copy in case this symbol is changed. */ + save_symbol_data (p); + } + + *result = st; + return 0; +} + + +int +gfc_get_symbol (const char *name, gfc_namespace * ns, gfc_symbol ** result) +{ + gfc_symtree *st; + int i; + + + i = gfc_get_sym_tree (name, ns, &st); + if (i != 0) + return i; + + if (st) + *result = st->n.sym; + else + *result = NULL; + return i; +} + + +/* Subroutine that searches for a symbol, creating it if it doesn't + exist, but tries to host-associate the symbol if possible. */ + +int +gfc_get_ha_sym_tree (const char *name, gfc_symtree ** result) +{ + gfc_symtree *st; + int i; + + i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st); + if (st != NULL) + { + save_symbol_data (st->n.sym); + + *result = st; + return i; + } + + if (gfc_current_ns->parent != NULL) + { + i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st); + if (i) + return i; + + if (st != NULL) + { + *result = st; + return 0; + } + } + + return gfc_get_sym_tree (name, gfc_current_ns, result); +} + + +int +gfc_get_ha_symbol (const char *name, gfc_symbol ** result) +{ + int i; + gfc_symtree *st; + + i = gfc_get_ha_sym_tree (name, &st); + + if (st) + *result = st->n.sym; + else + *result = NULL; + + return i; +} + +/* Return true if both symbols could refer to the same data object. Does + not take account of aliasing due to equivalence statements. */ + +int +gfc_symbols_could_alias (gfc_symbol * lsym, gfc_symbol * rsym) +{ + /* Aliasing isn't possible if the symbols have different base types. */ + if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0) + return 0; + + /* Pointers can point to other pointers, target objects and allocatable + objects. Two allocatable objects cannot share the same storage. */ + if (lsym->attr.pointer + && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target)) + return 1; + if (lsym->attr.target && rsym->attr.pointer) + return 1; + if (lsym->attr.allocatable && rsym->attr.pointer) + return 1; + + return 0; +} + + +/* Undoes all the changes made to symbols in the current statement. + This subroutine is made simpler due to the fact that attributes are + never removed once added. */ + +void +gfc_undo_symbols (void) +{ + gfc_symbol *p, *q, *old; + + for (p = changed_syms; p; p = q) + { + q = p->tlink; + + if (p->new) + { + /* Symbol was new. */ + delete_symtree (&p->ns->sym_root, p->name); + + p->refs--; + if (p->refs < 0) + gfc_internal_error ("gfc_undo_symbols(): Negative refs"); + if (p->refs == 0) + gfc_free_symbol (p); + continue; + } + + /* Restore previous state of symbol. Just copy simple stuff. */ + p->mark = 0; + old = p->old_symbol; + + p->ts.type = old->ts.type; + p->ts.kind = old->ts.kind; + + p->attr = old->attr; + + if (p->value != old->value) + { + gfc_free_expr (old->value); + p->value = NULL; + } + + if (p->as != old->as) + { + if (p->as) + gfc_free_array_spec (p->as); + p->as = old->as; + } + + p->generic = old->generic; + p->component_access = old->component_access; + + if (p->namelist != NULL && old->namelist == NULL) + { + gfc_free_namelist (p->namelist); + p->namelist = NULL; + } + else + { + + if (p->namelist_tail != old->namelist_tail) + { + gfc_free_namelist (old->namelist_tail); + old->namelist_tail->next = NULL; + } + } + + p->namelist_tail = old->namelist_tail; + + if (p->formal != old->formal) + { + gfc_free_formal_arglist (p->formal); + p->formal = old->formal; + } + + gfc_free (p->old_symbol); + p->old_symbol = NULL; + p->tlink = NULL; + } + + changed_syms = NULL; +} + + +/* Makes the changes made in the current statement permanent-- gets + rid of undo information. */ + +void +gfc_commit_symbols (void) +{ + gfc_symbol *p, *q; + + for (p = changed_syms; p; p = q) + { + q = p->tlink; + p->tlink = NULL; + p->mark = 0; + p->new = 0; + + if (p->old_symbol != NULL) + { + gfc_free (p->old_symbol); + p->old_symbol = NULL; + } + } + + changed_syms = NULL; +} + + +/* Recursive function that deletes an entire tree and all the user + operator nodes that it contains. */ + +static void +free_uop_tree (gfc_symtree * uop_tree) +{ + + if (uop_tree == NULL) + return; + + free_uop_tree (uop_tree->left); + free_uop_tree (uop_tree->right); + + gfc_free_interface (uop_tree->n.uop->operator); + + gfc_free (uop_tree->n.uop); + gfc_free (uop_tree); +} + + +/* Recursive function that deletes an entire tree and all the symbols + that it contains. */ + +static void +free_sym_tree (gfc_symtree * sym_tree) +{ + gfc_namespace *ns; + gfc_symbol *sym; + + if (sym_tree == NULL) + return; + + free_sym_tree (sym_tree->left); + free_sym_tree (sym_tree->right); + + sym = sym_tree->n.sym; + + sym->refs--; + if (sym->refs < 0) + gfc_internal_error ("free_sym_tree(): Negative refs"); + + if (sym->formal_ns != NULL && sym->refs == 1) + { + /* As formal_ns contains a reference to sym, delete formal_ns just + before the deletion of sym. */ + ns = sym->formal_ns; + sym->formal_ns = NULL; + gfc_free_namespace (ns); + } + else if (sym->refs == 0) + { + /* Go ahead and delete the symbol. */ + gfc_free_symbol (sym); + } + + gfc_free (sym_tree); +} + + +/* Free a namespace structure and everything below it. Interface + lists associated with intrinsic operators are not freed. These are + taken care of when a specific name is freed. */ + +void +gfc_free_namespace (gfc_namespace * ns) +{ + gfc_charlen *cl, *cl2; + gfc_namespace *p, *q; + gfc_intrinsic_op i; + + if (ns == NULL) + return; + + gfc_free_statements (ns->code); + + free_sym_tree (ns->sym_root); + free_uop_tree (ns->uop_root); + + for (cl = ns->cl_list; cl; cl = cl2) + { + cl2 = cl->next; + gfc_free_expr (cl->length); + gfc_free (cl); + } + + free_st_labels (ns->st_labels); + + gfc_free_equiv (ns->equiv); + + for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) + gfc_free_interface (ns->operator[i]); + + gfc_free_data (ns->data); + p = ns->contained; + gfc_free (ns); + + /* Recursively free any contained namespaces. */ + while (p != NULL) + { + q = p; + p = p->sibling; + + gfc_free_namespace (q); + } +} + + +void +gfc_symbol_init_2 (void) +{ + + gfc_current_ns = gfc_get_namespace (NULL); +} + + +void +gfc_symbol_done_2 (void) +{ + + gfc_free_namespace (gfc_current_ns); + gfc_current_ns = NULL; +} + + +/* Clear mark bits from symbol nodes associated with a symtree node. */ + +static void +clear_sym_mark (gfc_symtree * st) +{ + + st->n.sym->mark = 0; +} + + +/* Recursively traverse the symtree nodes. */ + +static void +traverse_symtree (gfc_symtree * st, void (*func) (gfc_symtree *)) +{ + + if (st != NULL) + { + (*func) (st); + + traverse_symtree (st->left, func); + traverse_symtree (st->right, func); + } +} + + +void +gfc_traverse_symtree (gfc_namespace * ns, void (*func) (gfc_symtree *)) +{ + + traverse_symtree (ns->sym_root, func); +} + + +/* Recursive namespace traversal function. */ + +static void +traverse_ns (gfc_symtree * st, void (*func) (gfc_symbol *)) +{ + + if (st == NULL) + return; + + if (st->n.sym->mark == 0) + (*func) (st->n.sym); + st->n.sym->mark = 1; + + traverse_ns (st->left, func); + traverse_ns (st->right, func); +} + + +/* Call a given function for all symbols in the namespace. We take + care that each gfc_symbol node is called exactly once. */ + +void +gfc_traverse_ns (gfc_namespace * ns, void (*func) (gfc_symbol *)) +{ + + gfc_traverse_symtree (ns, clear_sym_mark); + + traverse_ns (ns->sym_root, func); +} + + +/* Given a symbol, mark it as SAVEd if it is allowed. */ + +static void +save_symbol (gfc_symbol * sym) +{ + + if (sym->attr.use_assoc) + return; + + if (sym->attr.common) + { + gfc_add_saved_common (&sym->attr, &sym->declared_at); + return; + } + + if (sym->attr.in_common + || sym->attr.dummy + || sym->attr.flavor != FL_VARIABLE) + return; + + gfc_add_save (&sym->attr, &sym->declared_at); +} + + +/* Mark those symbols which can be SAVEd as such. */ + +void +gfc_save_all (gfc_namespace * ns) +{ + + gfc_traverse_ns (ns, save_symbol); +} + + +#ifdef GFC_DEBUG +/* Make sure that no changes to symbols are pending. */ + +void +gfc_symbol_state(void) { + + if (changed_syms != NULL) + gfc_internal_error("Symbol changes still pending!"); +} +#endif + diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c new file mode 100644 index 00000000000..452b0fec81c --- /dev/null +++ b/gcc/fortran/trans-array.c @@ -0,0 +1,4158 @@ +/* Array translation routines + Copyright (C) 2002, 2003 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + and Steven Bosscher <s.bosscher@student.tudelft.nl> + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* trans-array.c-- Various array related code, including scalarization, + allocation, initialization and other support routines. */ + +/* How the scalarizer works. + In gfortran, array expressions use the same core routines as scalar + expressions. + First, a Scalarization State (SS) chain is built. This is done by walking + the expression tree, and building a linear list of the terms in the + expression. As the tree is walked, scalar subexpressions are translated. + + The scalarization parameters are stored in a gfc_loopinfo structure. + First the start and stride of each term is calculated by + gfc_conv_ss_startstride. During this process the expressions for the array + descriptors and data pointers are also translated. + + If the expression is an assignment, we must then resolve any dependencies. + In fortran all the rhs values of an assignment must be evaluated before + any assignments take place. This can require a temporary array to store the + values. We also require a temporary when we are passing array expressions + or vector subecripts as procedure parameters. + + Array sections are passed without copying to a temporary. These use the + scalarizer to determine the shape of the section. The flag + loop->array_parameter tells the scalarizer that the actual values and loop + variables will not be required. + + The function gfc_conv_loop_setup generates the scalarization setup code. + It determines the range of the scalarizing loop variables. If a temporary + is required, this is created and initialized. Code for scalar expressions + taken outside the loop is also generated at this time. Next the offset and + scaling required to translate from loop variables to array indices for each + term is calculated. + + A call to gfc_start_scalarized_body marks the start of the scalarized + expression. This creates a scope and declares the loop variables. Before + calling this gfc_make_ss_chain_used must be used to indicate which terms + will be used inside this loop. + + The scalar gfc_conv_* functions are then used to build the main body of the + scalarization loop. Scalarization loop variables and precalculated scalar + values are automaticaly substituted. Note that gfc_advance_se_ss_chain + must be used, rather than changing the se->ss directly. + + For assignment expressions requiring a temporary two sub loops are + generated. The first stores the result of the expression in the temporary, + the second copies it to the result. A call to + gfc_trans_scalarized_loop_boundary marks the end of the main loop code and + the start of the copying loop. The temporary may be less than full rank. + + Finally gfc_trans_scalarizing_loops is called to generate the implicit do + loops. The loops are added to the pre chain of the loopinfo. The post + chain may still contain cleanup code. + + After the loop code has been added into its parent scope gfc_cleanup_loop + is called to free all the SS allocated by the scalarizer. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "tree-simple.h" +#include <stdio.h> +#include "ggc.h" +#include "toplev.h" +#include "real.h" +#include "flags.h" +#include <assert.h> +#include <gmp.h> +#include "gfortran.h" +#include "trans.h" +#include "trans-stmt.h" +#include "trans-types.h" +#include "trans-array.h" +#include "trans-const.h" +#include "dependency.h" + +static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *); + +/* The contents of this structure aren't actualy used, just the address. */ +static gfc_ss gfc_ss_terminator_var; +gfc_ss * const gfc_ss_terminator = &gfc_ss_terminator_var; + +unsigned HOST_WIDE_INT gfc_stack_space_left; + + +/* Returns true if a variable of specified size should go on the stack. */ + +int +gfc_can_put_var_on_stack (tree size) +{ + unsigned HOST_WIDE_INT low; + + if (!INTEGER_CST_P (size)) + return 0; + + if (gfc_option.flag_max_stack_var_size < 0) + return 1; + + if (TREE_INT_CST_HIGH (size) != 0) + return 0; + + low = TREE_INT_CST_LOW (size); + if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size) + return 0; + +/* TODO: Set a per-function stack size limit. */ +#if 0 + /* We should be a bit more clever with array temps. */ + if (gfc_option.flag_max_function_vars_size >= 0) + { + if (low > gfc_stack_space_left) + return 0; + + gfc_stack_space_left -= low; + } +#endif + + return 1; +} + +static tree +gfc_array_dataptr_type (tree desc) +{ + return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc))); +} + + +/* Build expressions to access the members of an array descriptor. + It's surprisingly easy to mess up here, so never access + an array descriptor by "brute force", always use these + functions. This also avoids problems if we change the format + of an array descriptor. + + To understand these magic numbers, look at the comments + before gfc_build_array_type() in trans-types.c. + + The code within these defines should be the only code which knows the format + of an array descriptor. + + Any code just needing to read obtain the bounds of an array should use + gfc_conv_array_* rather than the following functions as these will return + know constant values, and work with arrays which do not have descriptors. + + Don't forget to #undef these! */ + +#define DATA_FIELD 0 +#define OFFSET_FIELD 1 +#define DTYPE_FIELD 2 +#define DIMENSION_FIELD 3 + +#define STRIDE_SUBFIELD 0 +#define LBOUND_SUBFIELD 1 +#define UBOUND_SUBFIELD 2 + +tree +gfc_conv_descriptor_data (tree desc) +{ + tree field; + tree type; + + type = TREE_TYPE (desc); + assert (GFC_DESCRIPTOR_TYPE_P (type)); + + field = TYPE_FIELDS (type); + assert (DATA_FIELD == 0); + assert (field != NULL_TREE + && TREE_CODE (TREE_TYPE (field)) == POINTER_TYPE + && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == ARRAY_TYPE); + + return build (COMPONENT_REF, TREE_TYPE (field), desc, field); +} + +tree +gfc_conv_descriptor_offset (tree desc) +{ + tree type; + tree field; + + type = TREE_TYPE (desc); + assert (GFC_DESCRIPTOR_TYPE_P (type)); + + field = gfc_advance_chain (TYPE_FIELDS (type), OFFSET_FIELD); + assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); + + return build (COMPONENT_REF, TREE_TYPE (field), desc, field); +} + +tree +gfc_conv_descriptor_dtype (tree desc) +{ + tree field; + tree type; + + type = TREE_TYPE (desc); + assert (GFC_DESCRIPTOR_TYPE_P (type)); + + field = gfc_advance_chain (TYPE_FIELDS (type), DTYPE_FIELD); + assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); + + return build (COMPONENT_REF, TREE_TYPE (field), desc, field); +} + +static tree +gfc_conv_descriptor_dimension (tree desc, tree dim) +{ + tree field; + tree type; + tree tmp; + + type = TREE_TYPE (desc); + assert (GFC_DESCRIPTOR_TYPE_P (type)); + + field = gfc_advance_chain (TYPE_FIELDS (type), DIMENSION_FIELD); + assert (field != NULL_TREE + && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE + && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE); + + tmp = build (COMPONENT_REF, TREE_TYPE (field), desc, field); + tmp = gfc_build_array_ref (tmp, dim); + return tmp; +} + +tree +gfc_conv_descriptor_stride (tree desc, tree dim) +{ + tree tmp; + tree field; + + tmp = gfc_conv_descriptor_dimension (desc, dim); + field = TYPE_FIELDS (TREE_TYPE (tmp)); + field = gfc_advance_chain (field, STRIDE_SUBFIELD); + assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); + + tmp = build (COMPONENT_REF, TREE_TYPE (field), tmp, field); + return tmp; +} + +tree +gfc_conv_descriptor_lbound (tree desc, tree dim) +{ + tree tmp; + tree field; + + tmp = gfc_conv_descriptor_dimension (desc, dim); + field = TYPE_FIELDS (TREE_TYPE (tmp)); + field = gfc_advance_chain (field, LBOUND_SUBFIELD); + assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); + + tmp = build (COMPONENT_REF, TREE_TYPE (field), tmp, field); + return tmp; +} + +tree +gfc_conv_descriptor_ubound (tree desc, tree dim) +{ + tree tmp; + tree field; + + tmp = gfc_conv_descriptor_dimension (desc, dim); + field = TYPE_FIELDS (TREE_TYPE (tmp)); + field = gfc_advance_chain (field, UBOUND_SUBFIELD); + assert (field != NULL_TREE && TREE_TYPE (field) == gfc_array_index_type); + + tmp = build (COMPONENT_REF, TREE_TYPE (field), tmp, field); + return tmp; +} + + +/* Generate an initializer for a static pointer or allocatable array. */ + +void +gfc_trans_static_array_pointer (gfc_symbol * sym) +{ + tree tmp; + tree field; + tree type; + + assert (TREE_STATIC (sym->backend_decl)); + /* Just zero the data member. */ + type = TREE_TYPE (sym->backend_decl); + assert (GFC_DESCRIPTOR_TYPE_P (type)); + assert (DATA_FIELD == 0); + field = TYPE_FIELDS (type); + + tmp = tree_cons (field, null_pointer_node, NULL_TREE); + tmp = build1 (CONSTRUCTOR, type, tmp); + TREE_CONSTANT (tmp) = 1; + TREE_INVARIANT (tmp) = 1; + DECL_INITIAL (sym->backend_decl) = tmp; +} + + +/* Cleanup those #defines. */ + +#undef DATA_FIELD +#undef OFFSET_FIELD +#undef DTYPE_FIELD +#undef DIMENSION_FIELD +#undef STRIDE_SUBFIELD +#undef LBOUND_SUBFIELD +#undef UBOUND_SUBFIELD + + +/* Mark a SS chain as used. Flags specifies in which loops the SS is used. + flags & 1 = Main loop body. + flags & 2 = temp copy loop. */ + +void +gfc_mark_ss_chain_used (gfc_ss * ss, unsigned flags) +{ + for (; ss != gfc_ss_terminator; ss = ss->next) + ss->useflags = flags; +} + +static void gfc_free_ss (gfc_ss *); + + +/* Free a gfc_ss chain. */ + +static void +gfc_free_ss_chain (gfc_ss * ss) +{ + gfc_ss *next; + + while (ss != gfc_ss_terminator) + { + assert (ss != NULL); + next = ss->next; + gfc_free_ss (ss); + ss = next; + } +} + + +/* Free a SS. */ + +static void +gfc_free_ss (gfc_ss * ss) +{ + int n; + + switch (ss->type) + { + case GFC_SS_SECTION: + case GFC_SS_VECTOR: + for (n = 0; n < GFC_MAX_DIMENSIONS; n++) + { + if (ss->data.info.subscript[n]) + gfc_free_ss_chain (ss->data.info.subscript[n]); + } + break; + + default: + break; + } + + gfc_free (ss); +} + + +/* Free all the SS associated with a loop. */ + +void +gfc_cleanup_loop (gfc_loopinfo * loop) +{ + gfc_ss *ss; + gfc_ss *next; + + ss = loop->ss; + while (ss != gfc_ss_terminator) + { + assert (ss != NULL); + next = ss->loop_chain; + gfc_free_ss (ss); + ss = next; + } +} + + +/* Associate a SS chain with a loop. */ + +void +gfc_add_ss_to_loop (gfc_loopinfo * loop, gfc_ss * head) +{ + gfc_ss *ss; + + if (head == gfc_ss_terminator) + return; + + ss = head; + for (; ss && ss != gfc_ss_terminator; ss = ss->next) + { + if (ss->next == gfc_ss_terminator) + ss->loop_chain = loop->ss; + else + ss->loop_chain = ss->next; + } + assert (ss == gfc_ss_terminator); + loop->ss = head; +} + + +/* Generate code to allocate an array temporary, or create a variable to + hold the data. */ + +static void +gfc_trans_allocate_array_storage (gfc_loopinfo * loop, gfc_ss_info * info, + tree size, tree nelem) +{ + tree tmp; + tree args; + tree desc; + tree data; + bool onstack; + + desc = info->descriptor; + data = gfc_conv_descriptor_data (desc); + onstack = gfc_can_put_var_on_stack (size); + if (onstack) + { + /* Make a temporary variable to hold the data. */ + tmp = fold (build (MINUS_EXPR, TREE_TYPE (nelem), nelem, + integer_one_node)); + tmp = build_range_type (gfc_array_index_type, integer_zero_node, tmp); + tmp = build_array_type (gfc_get_element_type (TREE_TYPE (desc)), tmp); + tmp = gfc_create_var (tmp, "A"); + tmp = gfc_build_addr_expr (TREE_TYPE (data), tmp); + gfc_add_modify_expr (&loop->pre, data, tmp); + info->data = data; + info->offset = gfc_index_zero_node; + + } + else + { + /* Allocate memory to hold the data. */ + args = gfc_chainon_list (NULL_TREE, size); + + if (gfc_index_integer_kind == 4) + tmp = gfor_fndecl_internal_malloc; + else if (gfc_index_integer_kind == 8) + tmp = gfor_fndecl_internal_malloc64; + else + abort (); + tmp = gfc_build_function_call (tmp, args); + tmp = convert (TREE_TYPE (data), tmp); + gfc_add_modify_expr (&loop->pre, data, tmp); + + info->data = data; + info->offset = gfc_index_zero_node; + } + + /* The offset is zero because we create temporaries with a zero + lower bound. */ + tmp = gfc_conv_descriptor_offset (desc); + gfc_add_modify_expr (&loop->pre, tmp, gfc_index_zero_node); + + if (!onstack) + { + /* Free the temporary. */ + tmp = convert (pvoid_type_node, info->data); + tmp = gfc_chainon_list (NULL_TREE, tmp); + tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp); + gfc_add_expr_to_block (&loop->post, tmp); + } +} + + +/* Generate code to allocate and initialize the descriptor for a temporary + array. Fills in the descriptor, data and offset fields of info. Also + adjusts the loop variables to be zero-based. Returns the size of the + array. */ + +tree +gfc_trans_allocate_temp_array (gfc_loopinfo * loop, gfc_ss_info * info, + tree eltype, tree string_length) +{ + tree type; + tree desc; + tree tmp; + tree size; + tree nelem; + int n; + int dim; + + assert (info->dimen > 0); + /* Set the lower bound to zero. */ + for (dim = 0; dim < info->dimen; dim++) + { + n = loop->order[dim]; + if (n < loop->temp_dim) + assert (integer_zerop (loop->from[n])); + else + { + loop->to[n] = fold (build (MINUS_EXPR, gfc_array_index_type, + loop->to[n], loop->from[n])); + loop->from[n] = integer_zero_node; + } + + info->delta[dim] = integer_zero_node; + info->start[dim] = integer_zero_node; + info->stride[dim] = integer_one_node; + info->dim[dim] = dim; + } + + /* Initialise the descriptor. */ + type = + gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1); + desc = gfc_create_var (type, "atmp"); + GFC_DECL_PACKED_ARRAY (desc) = 1; + + info->descriptor = desc; + size = integer_one_node; + + /* Fill in the array dtype. */ + tmp = gfc_conv_descriptor_dtype (desc); + gfc_add_modify_expr (&loop->pre, tmp, + GFC_TYPE_ARRAY_DTYPE (TREE_TYPE (desc))); + + /* Fill in the bounds and stride. This is a packed array, so: + size = 1; + for (n = 0; n < rank; n++) + { + stride[n] = size + delta = ubound[n] + 1 - lbound[n]; + size = size * delta; + } + size = size * sizeof(element); */ + for (n = 0; n < info->dimen; n++) + { + /* Store the stride and bound components in the descriptor. */ + tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]); + gfc_add_modify_expr (&loop->pre, tmp, size); + + tmp = gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]); + gfc_add_modify_expr (&loop->pre, tmp, integer_zero_node); + + tmp = gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]); + gfc_add_modify_expr (&loop->pre, tmp, loop->to[n]); + + tmp = fold (build (PLUS_EXPR, gfc_array_index_type, + loop->to[n], integer_one_node)); + + size = fold (build (MULT_EXPR, gfc_array_index_type, size, tmp)); + size = gfc_evaluate_now (size, &loop->pre); + } + + /* TODO: Where does the string length go? */ + if (string_length) + gfc_todo_error ("temporary arrays of strings"); + + /* Get the size of the array. */ + nelem = size; + size = fold (build (MULT_EXPR, gfc_array_index_type, size, + TYPE_SIZE_UNIT (gfc_get_element_type (type)))); + + gfc_trans_allocate_array_storage (loop, info, size, nelem); + + if (info->dimen > loop->temp_dim) + loop->temp_dim = info->dimen; + + return size; +} + + +/* Make sure offset is a variable. */ + +static void +gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset, + tree * offsetvar) +{ + /* We should have already created the offset variable. We cannot + create it here because we may be in an inner scopde. */ + assert (*offsetvar != NULL_TREE); + gfc_add_modify_expr (pblock, *offsetvar, *poffset); + *poffset = *offsetvar; + TREE_USED (*offsetvar) = 1; +} + + +/* Add the contents of an array to the constructor. */ + +static void +gfc_trans_array_constructor_subarray (stmtblock_t * pblock, + tree type ATTRIBUTE_UNUSED, + tree pointer, gfc_expr * expr, + tree * poffset, tree * offsetvar) +{ + gfc_se se; + gfc_ss *ss; + gfc_loopinfo loop; + stmtblock_t body; + tree tmp; + + /* We need this to be a variable so we can increment it. */ + gfc_put_offset_into_var (pblock, poffset, offsetvar); + + gfc_init_se (&se, NULL); + + /* Walk the array expression. */ + ss = gfc_walk_expr (expr); + assert (ss != gfc_ss_terminator); + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, ss); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop); + + /* Make the loop body. */ + gfc_mark_ss_chain_used (ss, 1); + gfc_start_scalarized_body (&loop, &body); + gfc_copy_loopinfo_to_se (&se, &loop); + se.ss = ss; + + gfc_conv_expr (&se, expr); + gfc_add_block_to_block (&body, &se.pre); + + /* Store the value. */ + tmp = gfc_build_indirect_ref (pointer); + tmp = gfc_build_array_ref (tmp, *poffset); + gfc_add_modify_expr (&body, tmp, se.expr); + + /* Increment the offset. */ + tmp = build (PLUS_EXPR, gfc_array_index_type, *poffset, integer_one_node); + gfc_add_modify_expr (&body, *poffset, tmp); + + /* Finish the loop. */ + gfc_add_block_to_block (&body, &se.post); + assert (se.ss == gfc_ss_terminator); + gfc_trans_scalarizing_loops (&loop, &body); + gfc_add_block_to_block (&loop.pre, &loop.post); + tmp = gfc_finish_block (&loop.pre); + gfc_add_expr_to_block (pblock, tmp); + + gfc_cleanup_loop (&loop); +} + + +/* Assign the values to the elements of an array constructor. */ + +static void +gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, + tree pointer, gfc_constructor * c, + tree * poffset, tree * offsetvar) +{ + tree tmp; + tree ref; + stmtblock_t body; + tree loopbody; + gfc_se se; + + for (; c; c = c->next) + { + /* If this is an iterator or an array, the offset must be a variable. */ + if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset)) + gfc_put_offset_into_var (pblock, poffset, offsetvar); + + gfc_start_block (&body); + + if (c->expr->expr_type == EXPR_ARRAY) + { + /* Array constructors can be nested. */ + gfc_trans_array_constructor_value (&body, type, pointer, + c->expr->value.constructor, + poffset, offsetvar); + } + else if (c->expr->rank > 0) + { + gfc_trans_array_constructor_subarray (&body, type, pointer, + c->expr, poffset, offsetvar); + } + else + { + /* This code really upsets the gimplifier so don't bother for now. */ + gfc_constructor *p; + HOST_WIDE_INT n; + HOST_WIDE_INT size; + + p = c; + n = 0; + while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT)) + { + p = p->next; + n++; + } + if (n < 4) + { + /* Scalar values. */ + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, c->expr); + gfc_add_block_to_block (&body, &se.pre); + + ref = gfc_build_indirect_ref (pointer); + ref = gfc_build_array_ref (ref, *poffset); + gfc_add_modify_expr (&body, ref, se.expr); + gfc_add_block_to_block (&body, &se.post); + + *poffset = fold (build (PLUS_EXPR, gfc_array_index_type, + *poffset, integer_one_node)); + } + else + { + /* Collect multiple scalar constants into a constructor. */ + tree list; + tree init; + tree bound; + tree tmptype; + + p = c; + list = NULL_TREE; + /* Count the number of consecutive scalar constants. */ + while (p && !(p->iterator + || p->expr->expr_type != EXPR_CONSTANT)) + { + gfc_init_se (&se, NULL); + gfc_conv_constant (&se, p->expr); + list = tree_cons (NULL_TREE, se.expr, list); + c = p; + p = p->next; + } + + bound = build_int_2 (n - 1, 0); + /* Create an array type to hold them. */ + tmptype = build_range_type (gfc_array_index_type, + integer_zero_node, bound); + tmptype = build_array_type (type, tmptype); + + init = build1 (CONSTRUCTOR, tmptype, nreverse (list)); + TREE_CONSTANT (init) = 1; + TREE_INVARIANT (init) = 1; + TREE_STATIC (init) = 1; + /* Create a static variable to hold the data. */ + tmp = gfc_create_var (tmptype, "data"); + TREE_STATIC (tmp) = 1; + TREE_CONSTANT (tmp) = 1; + TREE_INVARIANT (tmp) = 1; + DECL_INITIAL (tmp) = init; + init = tmp; + + /* Use BUILTIN_MEMCPY to assign the values. */ + tmp = gfc_build_indirect_ref (pointer); + tmp = gfc_build_array_ref (tmp, *poffset); + tmp = gfc_build_addr_expr (NULL, tmp); + init = gfc_build_addr_expr (NULL, init); + + size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type)); + bound = build_int_2 (n * size, 0); + tmp = gfc_chainon_list (NULL_TREE, tmp); + tmp = gfc_chainon_list (tmp, init); + tmp = gfc_chainon_list (tmp, bound); + tmp = gfc_build_function_call (built_in_decls[BUILT_IN_MEMCPY], + tmp); + gfc_add_expr_to_block (&body, tmp); + + *poffset = fold (build (PLUS_EXPR, gfc_array_index_type, + *poffset, bound)); + } + if (!INTEGER_CST_P (*poffset)) + { + gfc_add_modify_expr (&body, *offsetvar, *poffset); + *poffset = *offsetvar; + } + } + + /* The frontend should already have done any expansions. */ + if (c->iterator) + { + tree end; + tree step; + tree loopvar; + tree exit_label; + + loopbody = gfc_finish_block (&body); + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, c->iterator->var); + gfc_add_block_to_block (pblock, &se.pre); + loopvar = se.expr; + + /* Initialize thie loop. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, c->iterator->start); + gfc_add_block_to_block (pblock, &se.pre); + gfc_add_modify_expr (pblock, loopvar, se.expr); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, c->iterator->end); + gfc_add_block_to_block (pblock, &se.pre); + end = gfc_evaluate_now (se.expr, pblock); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, c->iterator->step); + gfc_add_block_to_block (pblock, &se.pre); + step = gfc_evaluate_now (se.expr, pblock); + + /* Generate the loop body. */ + exit_label = gfc_build_label_decl (NULL_TREE); + gfc_start_block (&body); + + /* Generate the exit condition. */ + end = build (GT_EXPR, boolean_type_node, loopvar, end); + tmp = build1_v (GOTO_EXPR, exit_label); + TREE_USED (exit_label) = 1; + tmp = build_v (COND_EXPR, end, tmp, build_empty_stmt ()); + gfc_add_expr_to_block (&body, tmp); + + /* The main loop body. */ + gfc_add_expr_to_block (&body, loopbody); + + /* Increment the loop variable. */ + tmp = build (PLUS_EXPR, TREE_TYPE (loopvar), loopvar, step); + gfc_add_modify_expr (&body, loopvar, tmp); + + /* Finish the loop. */ + tmp = gfc_finish_block (&body); + tmp = build_v (LOOP_EXPR, tmp); + gfc_add_expr_to_block (pblock, tmp); + + /* Add the exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (pblock, tmp); + } + else + { + /* Pass the code as is. */ + tmp = gfc_finish_block (&body); + gfc_add_expr_to_block (pblock, tmp); + } + } +} + + +/* Get the size of an expression. Returns -1 if the size isn't constant. + Implied do loops with non-constant bounds are tricky because we must only + evaluate the bounds once. */ + +static void +gfc_get_array_cons_size (mpz_t * size, gfc_constructor * c) +{ + gfc_iterator *i; + mpz_t val; + mpz_t len; + + mpz_set_ui (*size, 0); + mpz_init (len); + mpz_init (val); + + for (; c; c = c->next) + { + if (c->expr->expr_type == EXPR_ARRAY) + { + /* A nested array constructor. */ + gfc_get_array_cons_size (&len, c->expr->value.constructor); + if (mpz_sgn (len) < 0) + { + mpz_set (*size, len); + mpz_clear (len); + mpz_clear (val); + return; + } + } + else + { + if (c->expr->rank > 0) + { + mpz_set_si (*size, -1); + mpz_clear (len); + mpz_clear (val); + return; + } + mpz_set_ui (len, 1); + } + + if (c->iterator) + { + i = c->iterator; + + if (i->start->expr_type != EXPR_CONSTANT + || i->end->expr_type != EXPR_CONSTANT + || i->step->expr_type != EXPR_CONSTANT) + { + mpz_set_si (*size, -1); + mpz_clear (len); + mpz_clear (val); + return; + } + + mpz_add (val, i->end->value.integer, i->start->value.integer); + mpz_tdiv_q (val, val, i->step->value.integer); + mpz_add_ui (val, val, 1); + mpz_mul (len, len, val); + } + mpz_add (*size, *size, len); + } + mpz_clear (len); + mpz_clear (val); +} + + +/* Array constructors are handled by constructing a temporary, then using that + within the scalarization loop. This is not optimal, but seems by far the + simplest method. */ + +static void +gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss) +{ + tree offset; + tree offsetvar; + tree desc; + tree size; + tree type; + + if (ss->expr->ts.type == BT_CHARACTER) + gfc_todo_error ("Character string array constructors"); + type = gfc_typenode_for_spec (&ss->expr->ts); + ss->data.info.dimen = loop->dimen; + size = + gfc_trans_allocate_temp_array (loop, &ss->data.info, type, NULL_TREE); + + desc = ss->data.info.descriptor; + offset = integer_zero_node; + offsetvar = gfc_create_var_np (gfc_array_index_type, "offset"); + TREE_USED (offsetvar) = 0; + gfc_trans_array_constructor_value (&loop->pre, type, + ss->data.info.data, + ss->expr->value.constructor, &offset, + &offsetvar); + + if (TREE_USED (offsetvar)) + pushdecl (offsetvar); + else + assert (INTEGER_CST_P (offset)); +#if 0 + /* Disable bound checking for now cos it's probably broken. */ + if (flag_bounds_check) + { + abort (); + } +#endif +} + + +/* Add the pre and post chains for all the scalar expressions in a SS chain + to loop. This is called after the loop parameters have been calculated, + but before the actual scalarizing loops. */ +/*GCC ARRAYS*/ + +static void +gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript) +{ + gfc_se se; + int n; + + assert (ss != NULL); + + for (; ss != gfc_ss_terminator; ss = ss->loop_chain) + { + assert (ss); + + switch (ss->type) + { + case GFC_SS_SCALAR: + /* Scalar expression. Evaluate this now. This includes elemental + dimension indices, but not array section bounds. */ + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, ss->expr); + gfc_add_block_to_block (&loop->pre, &se.pre); + + if (ss->expr->ts.type != BT_CHARACTER) + { + /* Move the evaluation of scalar expressions outside the + scalarization loop. */ + if (subscript) + se.expr = convert(gfc_array_index_type, se.expr); + se.expr = gfc_evaluate_now (se.expr, &loop->pre); + gfc_add_block_to_block (&loop->pre, &se.post); + } + else + gfc_add_block_to_block (&loop->post, &se.post); + + ss->data.scalar.expr = se.expr; + ss->data.scalar.string_length = se.string_length; + break; + + case GFC_SS_REFERENCE: + /* Scalar reference. Evaluate this now. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_reference (&se, ss->expr); + gfc_add_block_to_block (&loop->pre, &se.pre); + gfc_add_block_to_block (&loop->post, &se.post); + + ss->data.scalar.expr = gfc_evaluate_now (se.expr, &loop->pre); + ss->data.scalar.string_length = se.string_length; + break; + + case GFC_SS_SECTION: + case GFC_SS_VECTOR: + /* Scalarized expression. Evaluate any scalar subscripts. */ + for (n = 0; n < GFC_MAX_DIMENSIONS; n++) + { + /* Add the expressions for scalar subscripts. */ + if (ss->data.info.subscript[n]) + gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true); + } + break; + + case GFC_SS_INTRINSIC: + gfc_add_intrinsic_ss_code (loop, ss); + break; + + case GFC_SS_FUNCTION: + /* Array function return value. We call the function and save its + result in a temporary for use inside the loop. */ + gfc_init_se (&se, NULL); + se.loop = loop; + se.ss = ss; + gfc_conv_expr (&se, ss->expr); + gfc_add_block_to_block (&loop->pre, &se.pre); + gfc_add_block_to_block (&loop->post, &se.post); + break; + + case GFC_SS_CONSTRUCTOR: + gfc_trans_array_constructor (loop, ss); + break; + + default: + abort (); + } + } +} + + +/* Translate expressions for the descriptor and data pointer of a SS. */ +/*GCC ARRAYS*/ + +static void +gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) +{ + gfc_se se; + tree tmp; + + /* Get the descriptor for the array to be scalarized. */ + assert (ss->expr->expr_type == EXPR_VARIABLE); + gfc_init_se (&se, NULL); + se.descriptor_only = 1; + gfc_conv_expr_lhs (&se, ss->expr); + gfc_add_block_to_block (block, &se.pre); + ss->data.info.descriptor = se.expr; + + if (base) + { + /* Also the data pointer. */ + tmp = gfc_conv_array_data (se.expr); + /* If this is a variable or address of a variable we use it directly. + Otherwise we must evaluate it now to to avoid break dependency + analysis by pulling the expressions for elemental array indices + inside the loop. */ + if (!(DECL_P (tmp) + || (TREE_CODE (tmp) == ADDR_EXPR + && DECL_P (TREE_OPERAND (tmp, 0))))) + tmp = gfc_evaluate_now (tmp, block); + ss->data.info.data = tmp; + + tmp = gfc_conv_array_offset (se.expr); + ss->data.info.offset = gfc_evaluate_now (tmp, block); + } +} + + +/* Initialise a gfc_loopinfo structure. */ + +void +gfc_init_loopinfo (gfc_loopinfo * loop) +{ + int n; + + memset (loop, 0, sizeof (gfc_loopinfo)); + gfc_init_block (&loop->pre); + gfc_init_block (&loop->post); + + /* Initialy scalarize in order. */ + for (n = 0; n < GFC_MAX_DIMENSIONS; n++) + loop->order[n] = n; + + loop->ss = gfc_ss_terminator; +} + + +/* Copies the loop variable info to a gfc_se sructure. Does not copy the SS + chain. */ + +void +gfc_copy_loopinfo_to_se (gfc_se * se, gfc_loopinfo * loop) +{ + se->loop = loop; +} + + +/* Return an expression for the data pointer of an array. */ + +tree +gfc_conv_array_data (tree descriptor) +{ + tree type; + + type = TREE_TYPE (descriptor); + if (GFC_ARRAY_TYPE_P (type)) + { + if (TREE_CODE (type) == POINTER_TYPE) + return descriptor; + else + { + /* Descritporless arrays. */ + return gfc_build_addr_expr (NULL, descriptor); + } + } + else + return gfc_conv_descriptor_data (descriptor); +} + + +/* Return an expression for the base offset of an array. */ + +tree +gfc_conv_array_offset (tree descriptor) +{ + tree type; + + type = TREE_TYPE (descriptor); + if (GFC_ARRAY_TYPE_P (type)) + return GFC_TYPE_ARRAY_OFFSET (type); + else + return gfc_conv_descriptor_offset (descriptor); +} + + +/* Get an expression for the array stride. */ + +tree +gfc_conv_array_stride (tree descriptor, int dim) +{ + tree tmp; + tree type; + + type = TREE_TYPE (descriptor); + + /* For descriptorless arrays use the array size. */ + tmp = GFC_TYPE_ARRAY_STRIDE (type, dim); + if (tmp != NULL_TREE) + return tmp; + + tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[dim]); + return tmp; +} + + +/* Like gfc_conv_array_stride, but for the lower bound. */ + +tree +gfc_conv_array_lbound (tree descriptor, int dim) +{ + tree tmp; + tree type; + + type = TREE_TYPE (descriptor); + + tmp = GFC_TYPE_ARRAY_LBOUND (type, dim); + if (tmp != NULL_TREE) + return tmp; + + tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[dim]); + return tmp; +} + + +/* Like gfc_conv_array_stride, but for the upper bound. */ + +tree +gfc_conv_array_ubound (tree descriptor, int dim) +{ + tree tmp; + tree type; + + type = TREE_TYPE (descriptor); + + tmp = GFC_TYPE_ARRAY_UBOUND (type, dim); + if (tmp != NULL_TREE) + return tmp; + + /* This should only ever happen when passing an assumed shape array + as an actual parameter. The value will never be used. */ + if (GFC_ARRAY_TYPE_P (TREE_TYPE (descriptor))) + return integer_zero_node; + + tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[dim]); + return tmp; +} + + +/* Translate an array reference. The descriptor should be in se->expr. + Do not use this function, it wil be removed soon. */ +/*GCC ARRAYS*/ + +static void +gfc_conv_array_index_ref (gfc_se * se, tree pointer, tree * indices, + tree offset, int dimen) +{ + tree array; + tree tmp; + tree index; + int n; + + array = gfc_build_indirect_ref (pointer); + + index = offset; + for (n = 0; n < dimen; n++) + { + /* index = index + stride[n]*indices[n] */ + tmp = gfc_conv_array_stride (se->expr, n); + tmp = fold (build (MULT_EXPR, gfc_array_index_type, indices[n], tmp)); + + index = fold (build (PLUS_EXPR, gfc_array_index_type, index, tmp)); + } + + /* Result = data[index]. */ + tmp = gfc_build_array_ref (array, index); + + /* Check we've used the correct number of dimensions. */ + assert (TREE_CODE (TREE_TYPE (tmp)) != ARRAY_TYPE); + + se->expr = tmp; +} + + +/* Generate code to perform an array index bound check. */ + +static tree +gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n) +{ + tree cond; + tree fault; + tree tmp; + + if (!flag_bounds_check) + return index; + + index = gfc_evaluate_now (index, &se->pre); + /* Check lower bound. */ + tmp = gfc_conv_array_lbound (descriptor, n); + fault = fold (build (LT_EXPR, boolean_type_node, index, tmp)); + /* Check upper bound. */ + tmp = gfc_conv_array_ubound (descriptor, n); + cond = fold (build (GT_EXPR, boolean_type_node, index, tmp)); + fault = fold (build (TRUTH_OR_EXPR, boolean_type_node, fault, cond)); + + gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre); + + return index; +} + + +/* A reference to an array vector subscript. Uses recursion to handle nested + vector subscripts. */ + +static tree +gfc_conv_vector_array_index (gfc_se * se, tree index, gfc_ss * ss) +{ + tree descsave; + tree indices[GFC_MAX_DIMENSIONS]; + gfc_array_ref *ar; + gfc_ss_info *info; + int n; + + assert (ss && ss->type == GFC_SS_VECTOR); + + /* Save the descriptor. */ + descsave = se->expr; + info = &ss->data.info; + se->expr = info->descriptor; + + ar = &info->ref->u.ar; + for (n = 0; n < ar->dimen; n++) + { + switch (ar->dimen_type[n]) + { + case DIMEN_ELEMENT: + assert (info->subscript[n] != gfc_ss_terminator + && info->subscript[n]->type == GFC_SS_SCALAR); + indices[n] = info->subscript[n]->data.scalar.expr; + break; + + case DIMEN_RANGE: + indices[n] = index; + break; + + case DIMEN_VECTOR: + index = gfc_conv_vector_array_index (se, index, info->subscript[n]); + + indices[n] = + gfc_trans_array_bound_check (se, info->descriptor, index, n); + break; + + default: + abort (); + } + } + /* Get the index from the vector. */ + gfc_conv_array_index_ref (se, info->data, indices, info->offset, ar->dimen); + index = se->expr; + /* Put the descriptor back. */ + se->expr = descsave; + + return index; +} + + +/* Return the offset for an index. Performs bound checking for elemental + dimensions. Single element references are processed seperately. */ + +static tree +gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, + gfc_array_ref * ar, tree stride) +{ + tree index; + + /* Get the index into the array for this dimension. */ + if (ar) + { + assert (ar->type != AR_ELEMENT); + if (ar->dimen_type[dim] == DIMEN_ELEMENT) + { + assert (i == -1); + /* Elemental dimension. */ + assert (info->subscript[dim] + && info->subscript[dim]->type == GFC_SS_SCALAR); + /* We've already translated this value outside the loop. */ + index = info->subscript[dim]->data.scalar.expr; + + index = + gfc_trans_array_bound_check (se, info->descriptor, index, dim); + } + else + { + /* Scalarized dimension. */ + assert (info && se->loop); + + /* Multiply the loop variable by the stride and dela. */ + index = se->loop->loopvar[i]; + index = fold (build (MULT_EXPR, gfc_array_index_type, index, + info->stride[i])); + index = fold (build (PLUS_EXPR, gfc_array_index_type, index, + info->delta[i])); + + if (ar->dimen_type[dim] == DIMEN_VECTOR) + { + /* Handle vector subscripts. */ + index = gfc_conv_vector_array_index (se, index, + info->subscript[dim]); + index = + gfc_trans_array_bound_check (se, info->descriptor, index, + dim); + } + else + assert (ar->dimen_type[dim] == DIMEN_RANGE); + } + } + else + { + /* Temporary array. */ + assert (se->loop); + index = se->loop->loopvar[se->loop->order[i]]; + } + + /* Multiply by the stride. */ + index = fold (build (MULT_EXPR, gfc_array_index_type, index, stride)); + + return index; +} + + +/* Build a scalarized reference to an array. */ + +static void +gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) +{ + gfc_ss_info *info; + tree index; + tree tmp; + int n; + + info = &se->ss->data.info; + if (ar) + n = se->loop->order[0]; + else + n = 0; + + index = gfc_conv_array_index_offset (se, info, info->dim[n], n, ar, + info->stride0); + /* Add the offset for this dimension to the stored offset for all other + dimensions. */ + index = fold (build (PLUS_EXPR, gfc_array_index_type, index, info->offset)); + + tmp = gfc_build_indirect_ref (info->data); + se->expr = gfc_build_array_ref (tmp, index); +} + + +/* Translate access of temporary array. */ + +void +gfc_conv_tmp_array_ref (gfc_se * se) +{ + tree desc; + + desc = se->ss->data.info.descriptor; + /* TODO: We need the string length for string variables. */ + + gfc_conv_scalarized_array_ref (se, NULL); +} + + +/* Build an array reference. se->expr already holds the array descriptor. + This should be either a variable, indirect variable reference or component + reference. For arrays which do not have a descriptor, se->expr will be + the data pointer. + a(i, j, k) = base[offset + i * stride[0] + j * stride[1] + k * stride[2]]*/ + +void +gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar) +{ + int n; + tree index; + tree tmp; + tree stride; + tree fault; + gfc_se indexse; + + /* Handle scalarized references seperately. */ + if (ar->type != AR_ELEMENT) + { + gfc_conv_scalarized_array_ref (se, ar); + return; + } + + index = integer_zero_node; + + fault = integer_zero_node; + + /* Calculate the offsets from all the dimensions. */ + for (n = 0; n < ar->dimen; n++) + { + /* Calculate the index for this demension. */ + gfc_init_se (&indexse, NULL); + gfc_conv_expr_type (&indexse, ar->start[n], gfc_array_index_type); + gfc_add_block_to_block (&se->pre, &indexse.pre); + + if (flag_bounds_check) + { + /* Check array bounds. */ + tree cond; + + indexse.expr = gfc_evaluate_now (indexse.expr, &se->pre); + + tmp = gfc_conv_array_lbound (se->expr, n); + cond = fold (build (LT_EXPR, boolean_type_node, indexse.expr, tmp)); + fault = + fold (build (TRUTH_OR_EXPR, boolean_type_node, fault, cond)); + + tmp = gfc_conv_array_ubound (se->expr, n); + cond = fold (build (GT_EXPR, boolean_type_node, indexse.expr, tmp)); + fault = + fold (build (TRUTH_OR_EXPR, boolean_type_node, fault, cond)); + } + + /* Multiply the index by the stride. */ + stride = gfc_conv_array_stride (se->expr, n); + tmp = fold (build (MULT_EXPR, gfc_array_index_type, indexse.expr, + stride)); + + /* And add it to the total. */ + index = fold (build (PLUS_EXPR, gfc_array_index_type, index, tmp)); + } + + if (flag_bounds_check) + gfc_trans_runtime_check (fault, gfc_strconst_fault, &se->pre); + + tmp = gfc_conv_array_offset (se->expr); + if (!integer_zerop (tmp)) + index = fold (build (PLUS_EXPR, gfc_array_index_type, index, tmp)); + + /* Access the calculated element. */ + tmp = gfc_conv_array_data (se->expr); + tmp = gfc_build_indirect_ref (tmp); + se->expr = gfc_build_array_ref (tmp, index); +} + + +/* Generate the code to be executed immediately before entering a + scalarization loop. */ + +static void +gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag, + stmtblock_t * pblock) +{ + tree index; + tree stride; + gfc_ss_info *info; + gfc_ss *ss; + gfc_se se; + int i; + + /* This code will be executed before entering the scalarization loop + for this dimension. */ + for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) + { + if ((ss->useflags & flag) == 0) + continue; + + if (ss->type != GFC_SS_SECTION + && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR) + continue; + + info = &ss->data.info; + + if (dim >= info->dimen) + continue; + + if (dim == info->dimen - 1) + { + /* For the outermost loop calculate the offset due to any + elemental dimensions. It will have been initialized with the + base offset of the array. */ + if (info->ref) + { + for (i = 0; i < info->ref->u.ar.dimen; i++) + { + if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT) + continue; + + gfc_init_se (&se, NULL); + se.loop = loop; + se.expr = info->descriptor; + stride = gfc_conv_array_stride (info->descriptor, i); + index = gfc_conv_array_index_offset (&se, info, i, -1, + &info->ref->u.ar, + stride); + gfc_add_block_to_block (pblock, &se.pre); + + info->offset = fold (build (PLUS_EXPR, gfc_array_index_type, + info->offset, index)); + info->offset = gfc_evaluate_now (info->offset, pblock); + } + + i = loop->order[0]; + stride = gfc_conv_array_stride (info->descriptor, info->dim[i]); + } + else + stride = gfc_conv_array_stride (info->descriptor, 0); + + /* Calculate the stride of the innermost loop. Hopefully this will + allow the backend optimizers to do their stuff more effectively. + */ + info->stride0 = gfc_evaluate_now (stride, pblock); + } + else + { + /* Add the offset for the previous loop dimension. */ + gfc_array_ref *ar; + + if (info->ref) + { + ar = &info->ref->u.ar; + i = loop->order[dim + 1]; + } + else + { + ar = NULL; + i = dim + 1; + } + + gfc_init_se (&se, NULL); + se.loop = loop; + se.expr = info->descriptor; + stride = gfc_conv_array_stride (info->descriptor, info->dim[i]); + index = gfc_conv_array_index_offset (&se, info, info->dim[i], i, + ar, stride); + gfc_add_block_to_block (pblock, &se.pre); + info->offset = fold (build (PLUS_EXPR, gfc_array_index_type, + info->offset, index)); + info->offset = gfc_evaluate_now (info->offset, pblock); + } + + /* Remeber this offset for the second loop. */ + if (dim == loop->temp_dim - 1) + info->saved_offset = info->offset; + } +} + + +/* Start a scalarized expression. Creates a scope and declares loop + variables. */ + +void +gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody) +{ + int dim; + int n; + int flags; + + assert (!loop->array_parameter); + + for (dim = loop->dimen - 1; dim >= 0; dim--) + { + n = loop->order[dim]; + + gfc_start_block (&loop->code[n]); + + /* Create the loop variable. */ + loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "S"); + + if (dim < loop->temp_dim) + flags = 3; + else + flags = 1; + /* Calculate values that will be constant within this loop. */ + gfc_trans_preloop_setup (loop, dim, flags, &loop->code[n]); + } + gfc_start_block (pbody); +} + + +/* Generates the actual loop code for a scalarization loop. */ + +static void +gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, + stmtblock_t * pbody) +{ + stmtblock_t block; + tree cond; + tree tmp; + tree loopbody; + tree exit_label; + + loopbody = gfc_finish_block (pbody); + + /* Initialize the loopvar. */ + gfc_add_modify_expr (&loop->code[n], loop->loopvar[n], loop->from[n]); + + exit_label = gfc_build_label_decl (NULL_TREE); + + /* Generate the loop body. */ + gfc_init_block (&block); + + /* The exit condition. */ + cond = build (GT_EXPR, boolean_type_node, loop->loopvar[n], loop->to[n]); + tmp = build1_v (GOTO_EXPR, exit_label); + TREE_USED (exit_label) = 1; + tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ()); + gfc_add_expr_to_block (&block, tmp); + + /* The main body. */ + gfc_add_expr_to_block (&block, loopbody); + + /* Increment the loopvar. */ + tmp = build (PLUS_EXPR, gfc_array_index_type, + loop->loopvar[n], integer_one_node); + gfc_add_modify_expr (&block, loop->loopvar[n], tmp); + + /* Build the loop. */ + tmp = gfc_finish_block (&block); + tmp = build_v (LOOP_EXPR, tmp); + gfc_add_expr_to_block (&loop->code[n], tmp); + + /* Add the exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&loop->code[n], tmp); +} + + +/* Finishes and generates the loops for a scalarized expression. */ + +void +gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body) +{ + int dim; + int n; + gfc_ss *ss; + stmtblock_t *pblock; + tree tmp; + + pblock = body; + /* Generate the loops. */ + for (dim = 0; dim < loop->dimen; dim++) + { + n = loop->order[dim]; + gfc_trans_scalarized_loop_end (loop, n, pblock); + loop->loopvar[n] = NULL_TREE; + pblock = &loop->code[n]; + } + + tmp = gfc_finish_block (pblock); + gfc_add_expr_to_block (&loop->pre, tmp); + + /* Clear all the used flags. */ + for (ss = loop->ss; ss; ss = ss->loop_chain) + ss->useflags = 0; +} + + +/* Finish the main body of a scalarized expression, and start the secondary + copying body. */ + +void +gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body) +{ + int dim; + int n; + stmtblock_t *pblock; + gfc_ss *ss; + + pblock = body; + /* We finish as many loops as are used by the temporary. */ + for (dim = 0; dim < loop->temp_dim - 1; dim++) + { + n = loop->order[dim]; + gfc_trans_scalarized_loop_end (loop, n, pblock); + loop->loopvar[n] = NULL_TREE; + pblock = &loop->code[n]; + } + + /* We don't want to finish the outermost loop entirely. */ + n = loop->order[loop->temp_dim - 1]; + gfc_trans_scalarized_loop_end (loop, n, pblock); + + /* Restore the initial offsets. */ + for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) + { + if ((ss->useflags & 2) == 0) + continue; + + if (ss->type != GFC_SS_SECTION + && ss->type != GFC_SS_FUNCTION && ss->type != GFC_SS_CONSTRUCTOR) + continue; + + ss->data.info.offset = ss->data.info.saved_offset; + } + + /* Restart all the inner loops we just finished. */ + for (dim = loop->temp_dim - 2; dim >= 0; dim--) + { + n = loop->order[dim]; + + gfc_start_block (&loop->code[n]); + + loop->loopvar[n] = gfc_create_var (gfc_array_index_type, "Q"); + + gfc_trans_preloop_setup (loop, dim, 2, &loop->code[n]); + } + + /* Start a block for the secondary copying code. */ + gfc_start_block (body); +} + + +/* Calculate the upper bound of an array section. */ + +static tree +gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock) +{ + int dim; + gfc_ss *vecss; + gfc_expr *end; + tree desc; + tree bound; + gfc_se se; + + assert (ss->type == GFC_SS_SECTION); + + /* For vector array subscripts we want the size of the vector. */ + dim = ss->data.info.dim[n]; + vecss = ss; + while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR) + { + vecss = vecss->data.info.subscript[dim]; + assert (vecss && vecss->type == GFC_SS_VECTOR); + dim = vecss->data.info.dim[0]; + } + + assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE); + end = vecss->data.info.ref->u.ar.end[dim]; + desc = vecss->data.info.descriptor; + + if (end) + { + /* The upper bound was specified. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, end, gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + bound = se.expr; + } + else + { + /* No upper bound was specified, so use the bound of the array. */ + bound = gfc_conv_array_ubound (desc, dim); + } + + return bound; +} + + +/* Calculate the lower bound of an array section. */ + +static void +gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) +{ + gfc_expr *start; + gfc_expr *stride; + gfc_ss *vecss; + tree desc; + gfc_se se; + gfc_ss_info *info; + int dim; + + info = &ss->data.info; + + dim = info->dim[n]; + + /* For vector array subscripts we want the size of the vector. */ + vecss = ss; + while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR) + { + vecss = vecss->data.info.subscript[dim]; + assert (vecss && vecss->type == GFC_SS_VECTOR); + /* Get the descriptors for the vector subscripts as well. */ + if (!vecss->data.info.descriptor) + gfc_conv_ss_descriptor (&loop->pre, vecss, !loop->array_parameter); + dim = vecss->data.info.dim[0]; + } + + assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE); + start = vecss->data.info.ref->u.ar.start[dim]; + stride = vecss->data.info.ref->u.ar.stride[dim]; + desc = vecss->data.info.descriptor; + + /* Calculate the start of the range. For vector subscripts this will + be the range of the vector. */ + if (start) + { + /* Specified section start. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, start, gfc_array_index_type); + gfc_add_block_to_block (&loop->pre, &se.pre); + info->start[n] = se.expr; + } + else + { + /* No lower bound specified so use the bound of the array. */ + info->start[n] = gfc_conv_array_lbound (desc, dim); + } + info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre); + + /* Calculate the stride. */ + if (stride == NULL) + info->stride[n] = integer_one_node; + else + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, stride, gfc_array_index_type); + gfc_add_block_to_block (&loop->pre, &se.pre); + info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre); + } +} + + +/* Calculates the range start and stride for a SS chain. Also gets the + descriptor and data pointer. The range of vector subscripts is the size + of the vector. Array bounds are also checked. */ + +void +gfc_conv_ss_startstride (gfc_loopinfo * loop) +{ + int n; + tree tmp; + gfc_ss *ss; + gfc_ss *vecss; + tree desc; + + loop->dimen = 0; + /* Determine the rank of the loop. */ + for (ss = loop->ss; + ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain) + { + switch (ss->type) + { + case GFC_SS_SECTION: + case GFC_SS_CONSTRUCTOR: + case GFC_SS_FUNCTION: + loop->dimen = ss->data.info.dimen; + break; + + default: + break; + } + } + + if (loop->dimen == 0) + gfc_todo_error ("Unable to determine rank of expression"); + + + /* loop over all the SS in the chain. */ + for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) + { + switch (ss->type) + { + case GFC_SS_SECTION: + /* Get the descriptor for the array. */ + gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter); + + for (n = 0; n < ss->data.info.dimen; n++) + gfc_conv_section_startstride (loop, ss, n); + break; + + case GFC_SS_CONSTRUCTOR: + case GFC_SS_FUNCTION: + for (n = 0; n < ss->data.info.dimen; n++) + { + ss->data.info.start[n] = integer_zero_node; + ss->data.info.stride[n] = integer_one_node; + } + break; + + default: + break; + } + } + + /* The rest is just runtime bound checking. */ + if (flag_bounds_check) + { + stmtblock_t block; + tree fault; + tree bound; + tree end; + tree size[GFC_MAX_DIMENSIONS]; + gfc_ss_info *info; + int dim; + + gfc_start_block (&block); + + fault = integer_zero_node; + for (n = 0; n < loop->dimen; n++) + size[n] = NULL_TREE; + + for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) + { + if (ss->type != GFC_SS_SECTION) + continue; + + /* TODO: range checking for mapped dimensions. */ + info = &ss->data.info; + + /* This only checks scalarized dimensions, elemental dimensions are + checked later. */ + for (n = 0; n < loop->dimen; n++) + { + dim = info->dim[n]; + vecss = ss; + while (vecss->data.info.ref->u.ar.dimen_type[dim] + == DIMEN_VECTOR) + { + vecss = vecss->data.info.subscript[dim]; + assert (vecss && vecss->type == GFC_SS_VECTOR); + dim = vecss->data.info.dim[0]; + } + assert (vecss->data.info.ref->u.ar.dimen_type[dim] + == DIMEN_RANGE); + desc = vecss->data.info.descriptor; + + /* Check lower bound. */ + bound = gfc_conv_array_lbound (desc, dim); + tmp = info->start[n]; + tmp = fold (build (LT_EXPR, boolean_type_node, tmp, bound)); + fault = fold (build (TRUTH_OR_EXPR, boolean_type_node, fault, + tmp)); + + /* Check the upper bound. */ + bound = gfc_conv_array_ubound (desc, dim); + end = gfc_conv_section_upper_bound (ss, n, &block); + tmp = fold (build (GT_EXPR, boolean_type_node, end, bound)); + fault = fold (build (TRUTH_OR_EXPR, boolean_type_node, fault, + tmp)); + + /* Check the section sizes match. */ + tmp = fold (build (MINUS_EXPR, gfc_array_index_type, end, + info->start[n])); + tmp = fold (build (FLOOR_DIV_EXPR, gfc_array_index_type, tmp, + info->stride[n])); + /* We remember the size of the first section, and check all the + others against this. */ + if (size[n]) + { + tmp = + fold (build (NE_EXPR, boolean_type_node, tmp, size[n])); + fault = + build (TRUTH_OR_EXPR, boolean_type_node, fault, tmp); + } + else + size[n] = gfc_evaluate_now (tmp, &block); + } + } + gfc_trans_runtime_check (fault, gfc_strconst_bounds, &block); + + tmp = gfc_finish_block (&block); + gfc_add_expr_to_block (&loop->pre, tmp); + } +} + + +/* Return true if the two SS could be aliased, ie. both point to the same data + object. */ +/* TODO: resolve aliases based on frontend expressions. */ + +static int +gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss) +{ + gfc_ref *lref; + gfc_ref *rref; + gfc_symbol *lsym; + gfc_symbol *rsym; + + lsym = lss->expr->symtree->n.sym; + rsym = rss->expr->symtree->n.sym; + if (gfc_symbols_could_alias (lsym, rsym)) + return 1; + + if (rsym->ts.type != BT_DERIVED + && lsym->ts.type != BT_DERIVED) + return 0; + + /* For Derived types we must check all the component types. We can ignore + array references as these will have the same base type as the previous + component ref. */ + for (lref = lss->expr->ref; lref != lss->data.info.ref; lref = lref->next) + { + if (lref->type != REF_COMPONENT) + continue; + + if (gfc_symbols_could_alias (lref->u.c.sym, rsym)) + return 1; + + for (rref = rss->expr->ref; rref != rss->data.info.ref; + rref = rref->next) + { + if (rref->type != REF_COMPONENT) + continue; + + if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym)) + return 1; + } + } + + for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next) + { + if (rref->type != REF_COMPONENT) + break; + + if (gfc_symbols_could_alias (rref->u.c.sym, lsym)) + return 1; + } + + return 0; +} + + +/* Resolve array data dependencies. Creates a temporary if required. */ +/* TODO: Calc dependencies with gfc_expr rather than gfc_ss, and move to + dependency.c. */ + +void +gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, + gfc_ss * rss) +{ + gfc_ss *ss; + gfc_ref *lref; + gfc_ref *rref; + gfc_ref *aref; + int nDepend = 0; + int temp_dim = 0; + + loop->temp_ss = NULL; + aref = dest->data.info.ref; + temp_dim = 0; + + for (ss = rss; ss != gfc_ss_terminator; ss = ss->next) + { + if (ss->type != GFC_SS_SECTION) + continue; + + if (gfc_could_be_alias (dest, ss)) + { + nDepend = 1; + break; + } + + if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym) + { + lref = dest->expr->ref; + rref = ss->expr->ref; + + nDepend = gfc_dep_resolver (lref, rref); +#if 0 + /* TODO : loop shifting. */ + if (nDepend == 1) + { + /* Mark the dimensions for LOOP SHIFTING */ + for (n = 0; n < loop->dimen; n++) + { + int dim = dest->data.info.dim[n]; + + if (lref->u.ar.dimen_type[dim] == DIMEN_VECTOR) + depends[n] = 2; + else if (! gfc_is_same_range (&lref->u.ar, + &rref->u.ar, dim, 0)) + depends[n] = 1; + } + + /* Put all the dimensions with dependancies in the + innermost loops. */ + dim = 0; + for (n = 0; n < loop->dimen; n++) + { + assert (loop->order[n] == n); + if (depends[n]) + loop->order[dim++] = n; + } + temp_dim = dim; + for (n = 0; n < loop->dimen; n++) + { + if (! depends[n]) + loop->order[dim++] = n; + } + + assert (dim == loop->dimen); + break; + } +#endif + } + } + + if (nDepend == 1) + { + loop->temp_ss = gfc_get_ss (); + loop->temp_ss->type = GFC_SS_TEMP; + loop->temp_ss->data.temp.type = + gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor)); + loop->temp_ss->data.temp.string_length = NULL_TREE; + loop->temp_ss->data.temp.dimen = loop->dimen; + loop->temp_ss->next = gfc_ss_terminator; + gfc_add_ss_to_loop (loop, loop->temp_ss); + } + else + loop->temp_ss = NULL; +} + + +/* Initialise the scalarization loop. Creates the loop variables. Determines + the range of the loop variables. Creates a temporary if required. + Calculates how to transform from loop variables to array indices for each + expression. Also generates code for scalar expressions which have been + moved outside the loop. */ + +void +gfc_conv_loop_setup (gfc_loopinfo * loop) +{ + int n; + int dim; + gfc_ss_info *info; + gfc_ss_info *specinfo; + gfc_ss *ss; + tree tmp; + tree len; + gfc_ss *loopspec[GFC_MAX_DIMENSIONS]; + mpz_t *cshape; + mpz_t i; + + mpz_init (i); + for (n = 0; n < loop->dimen; n++) + { + loopspec[n] = NULL; + /* We use one SS term, and use that to determine the bounds of the + loop for this dimension. We try to pick the simplest term. */ + for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) + { + if (ss->expr && ss->expr->shape) + { + /* The frontend has worked out the size for us. */ + loopspec[n] = ss; + continue; + } + + if (ss->type == GFC_SS_CONSTRUCTOR) + { + /* Try to figure out the size of the constructior. */ + /* TODO: avoid this by making the prontend set the shape. */ + gfc_get_array_cons_size (&i, ss->expr->value.constructor); + /* A negative value meens we failed. */ + if (mpz_sgn (i) > 0) + { + mpz_sub_ui (i, i, 1); + loop->to[n] = + gfc_conv_mpz_to_tree (i, gfc_index_integer_kind); + loopspec[n] = ss; + } + continue; + } + + /* We don't know how to handle functions yet. + This may not be possible in all cases. */ + if (ss->type != GFC_SS_SECTION) + continue; + + info = &ss->data.info; + + if (loopspec[n]) + specinfo = &loopspec[n]->data.info; + else + specinfo = NULL; + info = &ss->data.info; + + /* Criteria for choosing a loop specifier (most important first): + stride of one + known stride + known lower bound + known upper bound + */ + if (!specinfo) + loopspec[n] = ss; + else if (loopspec[n]->type != GFC_SS_CONSTRUCTOR) + { + if (integer_onep (info->stride[n]) + && !integer_onep (specinfo->stride[n])) + loopspec[n] = ss; + else if (INTEGER_CST_P (info->stride[n]) + && !INTEGER_CST_P (specinfo->stride[n])) + loopspec[n] = ss; + else if (INTEGER_CST_P (info->start[n]) + && !INTEGER_CST_P (specinfo->start[n])) + loopspec[n] = ss; + /* We don't work out the upper bound. + else if (INTEGER_CST_P (info->finish[n]) + && ! INTEGER_CST_P (specinfo->finish[n])) + loopspec[n] = ss; */ + } + } + + if (!loopspec[n]) + gfc_todo_error ("Unable to find scalarization loop specifier"); + + info = &loopspec[n]->data.info; + + /* Set the extents of this range. */ + cshape = loopspec[n]->expr->shape; + if (cshape && INTEGER_CST_P (info->start[n]) + && INTEGER_CST_P (info->stride[n])) + { + loop->from[n] = info->start[n]; + mpz_set (i, cshape[n]); + mpz_sub_ui (i, i, 1); + /* To = from + (size - 1) * stride. */ + tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind); + if (!integer_onep (info->stride[n])) + { + tmp = fold (build (MULT_EXPR, gfc_array_index_type, + tmp, info->stride[n])); + } + loop->to[n] = fold (build (PLUS_EXPR, gfc_array_index_type, + loop->from[n], tmp)); + } + else + { + loop->from[n] = info->start[n]; + switch (loopspec[n]->type) + { + case GFC_SS_CONSTRUCTOR: + assert (info->dimen == 1); + assert (loop->to[n]); + break; + + case GFC_SS_SECTION: + loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n, + &loop->pre); + break; + + default: + abort (); + } + } + + /* Transform everything so we have a simple incrementing variable. */ + if (integer_onep (info->stride[n])) + info->delta[n] = integer_zero_node; + else + { + /* Set the delta for this section. */ + info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre); + /* Number of iterations is (end - start + step) / step. + with start = 0, this simplifies to + last = end / step; + for (i = 0; i<=last; i++){...}; */ + tmp = fold (build (MINUS_EXPR, gfc_array_index_type, loop->to[n], + loop->from[n])); + tmp = fold (build (TRUNC_DIV_EXPR, gfc_array_index_type, tmp, + info->stride[n])); + loop->to[n] = gfc_evaluate_now (tmp, &loop->pre); + /* Make the loop variable start at 0. */ + loop->from[n] = integer_zero_node; + } + } + + /* If we want a temporary then create it. */ + if (loop->temp_ss != NULL) + { + assert (loop->temp_ss->type == GFC_SS_TEMP); + tmp = loop->temp_ss->data.temp.type; + len = loop->temp_ss->data.temp.string_length; + n = loop->temp_ss->data.temp.dimen; + memset (&loop->temp_ss->data.info, 0, sizeof (gfc_ss_info)); + loop->temp_ss->type = GFC_SS_SECTION; + loop->temp_ss->data.info.dimen = n; + gfc_trans_allocate_temp_array (loop, &loop->temp_ss->data.info, + tmp, len); + } + + /* Add all the scalar code that can be taken out of the loops. */ + gfc_add_loop_ss_code (loop, loop->ss, false); + + for (n = 0; n < loop->temp_dim; n++) + loopspec[loop->order[n]] = NULL; + + mpz_clear (i); + + /* For array parameters we don't have loop variables, so don't calculate the + translations. */ + if (loop->array_parameter) + return; + + /* Calculate the translation from loop variables to array indices. */ + for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) + { + if (ss->type != GFC_SS_SECTION) + continue; + + info = &ss->data.info; + + for (n = 0; n < info->dimen; n++) + { + dim = info->dim[n]; + + /* If we are specifying the range the delta may already be set. */ + if (loopspec[n] != ss) + { + /* Calculate the offset relative to the loop variable. + First multiply by the stride. */ + tmp = fold (build (MULT_EXPR, gfc_array_index_type, + loop->from[n], info->stride[n])); + + /* Then subtract this from our starting value. */ + tmp = fold (build (MINUS_EXPR, gfc_array_index_type, + info->start[n], tmp)); + + info->delta[n] = gfc_evaluate_now (tmp, &loop->pre); + } + } + } +} + + +/* Fills in an array descriptor, and returns the size of the array. The size + will be a simple_val, ie a variable or a constant. Also calculates the + offset of the base. Returns the size of the arrary. + { + stride = 1; + offset = 0; + for (n = 0; n < rank; n++) + { + a.lbound[n] = specified_lower_bound; + offset = offset + a.lbond[n] * stride; + size = 1 - lbound; + a.ubound[n] = specified_upper_bound; + a.stride[n] = stride; + size = ubound + size; //size = ubound + 1 - lbound + stride = stride * size; + } + return (stride); + } */ +/*GCC ARRAYS*/ + +static tree +gfc_array_init_size (tree descriptor, int rank, tree * poffset, + gfc_expr ** lower, gfc_expr ** upper, + stmtblock_t * pblock) +{ + tree type; + tree tmp; + tree size; + tree offset; + tree stride; + gfc_expr *ubound; + gfc_se se; + int n; + + type = TREE_TYPE (descriptor); + + stride = integer_one_node; + offset = integer_zero_node; + + /* Set the dtype. */ + tmp = gfc_conv_descriptor_dtype (descriptor); + gfc_add_modify_expr (pblock, tmp, + GFC_TYPE_ARRAY_DTYPE (TREE_TYPE (descriptor))); + + for (n = 0; n < rank; n++) + { + /* We have 3 possibilities for determining the size of the array: + lower == NULL => lbound = 1, ubound = upper[n] + upper[n] = NULL => lbound = 1, ubound = lower[n] + upper[n] != NULL => lbound = lower[n], ubound = upper[n] */ + ubound = upper[n]; + + /* Set lower bound. */ + gfc_init_se (&se, NULL); + if (lower == NULL) + se.expr = integer_one_node; + else + { + assert (lower[n]); + if (ubound) + { + gfc_conv_expr_type (&se, lower[n], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + } + else + { + se.expr = integer_one_node; + ubound = lower[n]; + } + } + tmp = gfc_conv_descriptor_lbound (descriptor, gfc_rank_cst[n]); + gfc_add_modify_expr (pblock, tmp, se.expr); + + /* Work out the offset for this component. */ + tmp = fold (build (MULT_EXPR, gfc_array_index_type, se.expr, stride)); + offset = fold (build (MINUS_EXPR, gfc_array_index_type, offset, tmp)); + + /* Start the calculation for the size of this dimension. */ + size = build (MINUS_EXPR, gfc_array_index_type, + integer_one_node, se.expr); + + /* Set upper bound. */ + gfc_init_se (&se, NULL); + assert (ubound); + gfc_conv_expr_type (&se, ubound, gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + + tmp = gfc_conv_descriptor_ubound (descriptor, gfc_rank_cst[n]); + gfc_add_modify_expr (pblock, tmp, se.expr); + + /* Store the stride. */ + tmp = gfc_conv_descriptor_stride (descriptor, gfc_rank_cst[n]); + gfc_add_modify_expr (pblock, tmp, stride); + + /* Calculate the size of this dimension. */ + size = fold (build (PLUS_EXPR, gfc_array_index_type, se.expr, size)); + + /* Multiply the stride by the number of elements in this dimension. */ + stride = fold (build (MULT_EXPR, gfc_array_index_type, stride, size)); + stride = gfc_evaluate_now (stride, pblock); + } + + /* The stride is the number of elements in the array, so multiply by the + size of an element to get the total size. */ + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + size = fold (build (MULT_EXPR, gfc_array_index_type, stride, tmp)); + + if (poffset != NULL) + { + offset = gfc_evaluate_now (offset, pblock); + *poffset = offset; + } + + size = gfc_evaluate_now (size, pblock); + return size; +} + + +/* Initialises the descriptor and generates a call to _gfor_allocate. Does + the work for an ALLOCATE statement. */ +/*GCC ARRAYS*/ + +void +gfc_array_allocate (gfc_se * se, gfc_ref * ref, tree pstat) +{ + tree tmp; + tree pointer; + tree allocate; + tree offset; + tree size; + gfc_expr **lower; + gfc_expr **upper; + + /* Figure out the size of the array. */ + switch (ref->u.ar.type) + { + case AR_ELEMENT: + lower = NULL; + upper = ref->u.ar.start; + break; + + case AR_FULL: + assert (ref->u.ar.as->type == AS_EXPLICIT); + + lower = ref->u.ar.as->lower; + upper = ref->u.ar.as->upper; + break; + + case AR_SECTION: + lower = ref->u.ar.start; + upper = ref->u.ar.end; + break; + + default: + abort (); + break; + } + + size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset, + lower, upper, &se->pre); + + /* Allocate memory to store the data. */ + tmp = gfc_conv_descriptor_data (se->expr); + pointer = gfc_build_addr_expr (NULL, tmp); + pointer = gfc_evaluate_now (pointer, &se->pre); + + if (gfc_array_index_type == gfc_int4_type_node) + allocate = gfor_fndecl_allocate; + else if (gfc_array_index_type == gfc_int8_type_node) + allocate = gfor_fndecl_allocate64; + else + abort (); + + tmp = gfc_chainon_list (NULL_TREE, pointer); + tmp = gfc_chainon_list (tmp, size); + tmp = gfc_chainon_list (tmp, pstat); + tmp = gfc_build_function_call (allocate, tmp); + gfc_add_expr_to_block (&se->pre, tmp); + + pointer = gfc_conv_descriptor_data (se->expr); + + tmp = gfc_conv_descriptor_offset (se->expr); + gfc_add_modify_expr (&se->pre, tmp, offset); +} + + +/* Deallocate an array variable. Also used when an allocated variable goes + out of scope. */ +/*GCC ARRAYS*/ + +tree +gfc_array_deallocate (tree descriptor) +{ + tree var; + tree tmp; + stmtblock_t block; + + gfc_start_block (&block); + /* Get a pointer to the data. */ + tmp = gfc_conv_descriptor_data (descriptor); + tmp = gfc_build_addr_expr (NULL, tmp); + var = gfc_create_var (TREE_TYPE (tmp), "ptr"); + gfc_add_modify_expr (&block, var, tmp); + + /* Parameter is the address of the data component. */ + tmp = gfc_chainon_list (NULL_TREE, var); + tmp = gfc_chainon_list (tmp, integer_zero_node); + tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + + +/* Create an array constructor from an initialization expression. + We assume the frontend already did any expansions and conversions. */ + +tree +gfc_conv_array_initializer (tree type, gfc_expr * expr) +{ + gfc_constructor *c; + tree list; + tree tmp; + mpz_t maxval; + gfc_se se; + HOST_WIDE_INT hi; + unsigned HOST_WIDE_INT lo; + tree index, range; + + list = NULL_TREE; + switch (expr->expr_type) + { + case EXPR_CONSTANT: + case EXPR_STRUCTURE: + /* A single scalar or derived type value. Create an array with all + elements equal to that value. */ + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, expr); + + tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); + assert (tmp && INTEGER_CST_P (tmp)); + hi = TREE_INT_CST_HIGH (tmp); + lo = TREE_INT_CST_LOW (tmp); + lo++; + if (lo == 0) + hi++; + /* This will probably eat buckets of memory for large arrays. */ + while (hi != 0 || lo != 0) + { + list = tree_cons (NULL_TREE, se.expr, list); + if (lo == 0) + hi--; + lo--; + } + break; + + case EXPR_ARRAY: + /* Create a list of all the elements. */ + for (c = expr->value.constructor; c; c = c->next) + { + if (c->iterator) + { + /* Problems occur when we get something like + integer :: a(lots) = (/(i, i=1,lots)/) */ + /* TODO: Unexpanded array initializers. */ + internal_error + ("Possible frontend bug: array constructor not expanded"); + } + if (mpz_cmp_si (c->n.offset, 0) != 0) + index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind); + else + index = NULL_TREE; + mpz_init (maxval); + if (mpz_cmp_si (c->repeat, 0) != 0) + { + tree tmp1, tmp2; + + mpz_set (maxval, c->repeat); + mpz_add (maxval, c->n.offset, maxval); + mpz_sub_ui (maxval, maxval, 1); + tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); + if (mpz_cmp_si (c->n.offset, 0) != 0) + { + mpz_add_ui (maxval, c->n.offset, 1); + tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); + } + else + tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind); + + range = build (RANGE_EXPR, integer_type_node, tmp1, tmp2); + } + else + range = NULL; + mpz_clear (maxval); + + gfc_init_se (&se, NULL); + switch (c->expr->expr_type) + { + case EXPR_CONSTANT: + gfc_conv_constant (&se, c->expr); + if (range == NULL_TREE) + list = tree_cons (index, se.expr, list); + else + { + if (index != NULL_TREE) + list = tree_cons (index, se.expr, list); + list = tree_cons (range, se.expr, list); + } + break; + + case EXPR_STRUCTURE: + gfc_conv_structure (&se, c->expr, 1); + list = tree_cons (index, se.expr, list); + break; + + default: + abort(); + } + } + /* We created the list in reverse order. */ + list = nreverse (list); + break; + + default: + abort(); + } + + /* Create a constructor from the list of elements. */ + tmp = build1 (CONSTRUCTOR, type, list); + TREE_CONSTANT (tmp) = 1; + TREE_INVARIANT (tmp) = 1; + return tmp; +} + + +/* Generate code to evaluate non-constant array bounds. Sets *poffset and + returns the size (in elements) of the array. */ + +static tree +gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, + stmtblock_t * pblock) +{ + gfc_array_spec *as; + tree size; + tree stride; + tree offset; + tree ubound; + tree lbound; + tree tmp; + gfc_se se; + + int dim; + + as = sym->as; + + size = integer_one_node; + offset = integer_zero_node; + for (dim = 0; dim < as->rank; dim++) + { + /* Evaluate non-constant array bound expressions. */ + lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); + if (as->lower[dim] && !INTEGER_CST_P (lbound)) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + gfc_add_modify_expr (pblock, lbound, se.expr); + } + ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); + if (as->upper[dim] && !INTEGER_CST_P (ubound)) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + gfc_add_modify_expr (pblock, ubound, se.expr); + } + /* The offset of this dimension. offset = offset - lbound * stride. */ + tmp = fold (build (MULT_EXPR, gfc_array_index_type, lbound, size)); + offset = fold (build (MINUS_EXPR, gfc_array_index_type, offset, tmp)); + + /* The size of this dimension, and the stride of the next. */ + if (dim + 1 < as->rank) + stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1); + else + stride = NULL_TREE; + + if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride))) + { + /* Calculate stride = size * (ubound + 1 - lbound). */ + tmp = fold (build (MINUS_EXPR, gfc_array_index_type, + integer_one_node, lbound)); + tmp = fold (build (PLUS_EXPR, gfc_array_index_type, ubound, tmp)); + tmp = fold (build (MULT_EXPR, gfc_array_index_type, size, tmp)); + if (stride) + gfc_add_modify_expr (pblock, stride, tmp); + else + stride = gfc_evaluate_now (tmp, pblock); + } + + size = stride; + } + + *poffset = offset; + return size; +} + + +/* Generate code to initialize/allocate an array variable. */ + +tree +gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) +{ + stmtblock_t block; + tree type; + tree tmp; + tree fndecl; + tree size; + tree offset; + tree args; + bool onstack; + + assert (!(sym->attr.pointer || sym->attr.allocatable)); + + /* Do nothing for USEd variables. */ + if (sym->attr.use_assoc) + return fnbody; + + type = TREE_TYPE (decl); + assert (GFC_ARRAY_TYPE_P (type)); + onstack = TREE_CODE (type) != POINTER_TYPE; + + /* We never generate initialization code of module variables. */ + if (fnbody == NULL_TREE) + { + assert (onstack); + + /* Generate static initializer. */ + if (sym->value) + { + DECL_INITIAL (decl) = + gfc_conv_array_initializer (TREE_TYPE (decl), sym->value); + } + return fnbody; + } + + gfc_start_block (&block); + + /* Evaluate character string length. */ + if (sym->ts.type == BT_CHARACTER + && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl)) + { + gfc_trans_init_string_length (sym->ts.cl, &block); + + DECL_DEFER_OUTPUT (decl) = 1; + + /* Generate code to allocate the automatic variable. It will be + freed automatically. */ + tmp = gfc_build_addr_expr (NULL, decl); + args = gfc_chainon_list (NULL_TREE, tmp); + args = gfc_chainon_list (args, sym->ts.cl->backend_decl); + tmp = gfc_build_function_call (built_in_decls[BUILT_IN_STACK_ALLOC], + args); + gfc_add_expr_to_block (&block, tmp); + } + + if (onstack) + { + if (sym->value) + { + DECL_INITIAL (decl) = + gfc_conv_array_initializer (TREE_TYPE (decl), sym->value); + } + + gfc_add_expr_to_block (&block, fnbody); + return gfc_finish_block (&block); + } + + type = TREE_TYPE (type); + + assert (!sym->attr.use_assoc); + assert (!TREE_STATIC (decl)); + assert (!sym->module[0]); + + if (sym->ts.type == BT_CHARACTER + && !INTEGER_CST_P (sym->ts.cl->backend_decl)) + gfc_trans_init_string_length (sym->ts.cl, &block); + + size = gfc_trans_array_bounds (type, sym, &offset, &block); + + /* The size is the number of elements in the array, so multiply by the + size of an element to get the total size. */ + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + size = fold (build (MULT_EXPR, gfc_array_index_type, size, tmp)); + + /* Allocate memory to hold the data. */ + tmp = gfc_chainon_list (NULL_TREE, size); + + if (gfc_index_integer_kind == 4) + fndecl = gfor_fndecl_internal_malloc; + else if (gfc_index_integer_kind == 8) + fndecl = gfor_fndecl_internal_malloc64; + else + abort (); + tmp = gfc_build_function_call (fndecl, tmp); + tmp = fold (convert (TREE_TYPE (decl), tmp)); + gfc_add_modify_expr (&block, decl, tmp); + + /* Set offset of the array. */ + if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) + gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); + + + /* Automatic arrays should not have initializers. */ + assert (!sym->value); + + gfc_add_expr_to_block (&block, fnbody); + + /* Free the temporary. */ + tmp = convert (pvoid_type_node, decl); + tmp = gfc_chainon_list (NULL_TREE, tmp); + tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + + +/* Generate entry and exit code for g77 calling convention arrays. */ + +tree +gfc_trans_g77_array (gfc_symbol * sym, tree body) +{ + tree parm; + tree type; + locus loc; + tree offset; + tree tmp; + stmtblock_t block; + + gfc_get_backend_locus (&loc); + gfc_set_backend_locus (&sym->declared_at); + + /* Descriptor type. */ + parm = sym->backend_decl; + type = TREE_TYPE (parm); + assert (GFC_ARRAY_TYPE_P (type)); + + gfc_start_block (&block); + + if (sym->ts.type == BT_CHARACTER + && !INTEGER_CST_P (sym->ts.cl->backend_decl)) + gfc_trans_init_string_length (sym->ts.cl, &block); + + /* Evaluate the bounds of the array. */ + gfc_trans_array_bounds (type, sym, &offset, &block); + + /* Set the offset. */ + if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) + gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); + + /* Set the pointer itself if we aren't using the parameter dirtectly. */ + if (TREE_CODE (parm) != PARM_DECL) + { + tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm)); + gfc_add_modify_expr (&block, parm, tmp); + } + tmp = gfc_finish_block (&block); + + gfc_set_backend_locus (&loc); + + gfc_start_block (&block); + /* Add the initialization code to the start of the function. */ + gfc_add_expr_to_block (&block, tmp); + gfc_add_expr_to_block (&block, body); + + return gfc_finish_block (&block); +} + + +/* Modify the descriptor of an array parameter so that it has the + correct lower bound. Also move the upper bound accordingly. + If the array is not packed, it will be copied into a temporary. + For each dimension we set the new lower and upper bounds. Then we copy the + stride and calculate the offset for this dimension. We also work out + what the stride of a packed array would be, and see it the two match. + If the array need repacking, we set the stride to the values we just + calculated, recalculate the offset and copy the array data. + Code is also added to copy the data back at the end of the function. + */ + +tree +gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) +{ + tree size; + tree type; + tree offset; + locus loc; + stmtblock_t block; + stmtblock_t cleanup; + tree lbound; + tree ubound; + tree dubound; + tree dlbound; + tree dumdesc; + tree tmp; + tree stmt; + tree stride; + tree stmt_packed; + tree stmt_unpacked; + tree partial; + gfc_se se; + int n; + int checkparm; + int no_repack; + + if (sym->attr.dummy && gfc_is_nodesc_array (sym)) + return gfc_trans_g77_array (sym, body); + + gfc_get_backend_locus (&loc); + gfc_set_backend_locus (&sym->declared_at); + + /* Descriptor type. */ + type = TREE_TYPE (tmpdesc); + assert (GFC_ARRAY_TYPE_P (type)); + dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); + dumdesc = gfc_build_indirect_ref (dumdesc); + gfc_start_block (&block); + + if (sym->ts.type == BT_CHARACTER + && !INTEGER_CST_P (sym->ts.cl->backend_decl)) + gfc_trans_init_string_length (sym->ts.cl, &block); + + checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check); + + no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc) + || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)); + + if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)) + { + /* For non-constant shape arrays we only check if the first dimension + is contiguous. Repacking higher dimensions wouldn't gain us + anything as we still don't know the array stride. */ + partial = gfc_create_var (boolean_type_node, "partial"); + TREE_USED (partial) = 1; + tmp = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]); + tmp = fold (build (EQ_EXPR, boolean_type_node, tmp, integer_one_node)); + gfc_add_modify_expr (&block, partial, tmp); + } + else + { + partial = NULL_TREE; + } + + /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive + here, however I think it does the right thing. */ + if (no_repack) + { + /* Set the first stride. */ + stride = gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[0]); + stride = gfc_evaluate_now (stride, &block); + + tmp = build (EQ_EXPR, boolean_type_node, stride, integer_zero_node); + tmp = build (COND_EXPR, gfc_array_index_type, tmp, + integer_one_node, stride); + stride = GFC_TYPE_ARRAY_STRIDE (type, 0); + gfc_add_modify_expr (&block, stride, tmp); + + /* Allow the user to disable array repacking. */ + stmt_unpacked = NULL_TREE; + } + else + { + assert (integer_onep (GFC_TYPE_ARRAY_STRIDE (type, 0))); + /* A library call to repack the array if neccessary. */ + tmp = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); + tmp = gfc_chainon_list (NULL_TREE, tmp); + stmt_unpacked = gfc_build_function_call (gfor_fndecl_in_pack, tmp); + + stride = integer_one_node; + } + + /* This is for the case where the array data is used directly without + calling the repack function. */ + if (no_repack || partial != NULL_TREE) + stmt_packed = gfc_conv_descriptor_data (dumdesc); + else + stmt_packed = NULL_TREE; + + /* Assign the data pointer. */ + if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) + { + /* Don't repack unknown shape arrays when the first stride is 1. */ + tmp = build (COND_EXPR, TREE_TYPE (stmt_packed), partial, + stmt_packed, stmt_unpacked); + } + else + tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked; + gfc_add_modify_expr (&block, tmpdesc, tmp); + + offset = integer_zero_node; + size = integer_one_node; + + /* Evaluate the bounds of the array. */ + for (n = 0; n < sym->as->rank; n++) + { + if (checkparm || !sym->as->upper[n]) + { + /* Get the bounds of the actual parameter. */ + dubound = gfc_conv_descriptor_ubound (dumdesc, gfc_rank_cst[n]); + dlbound = gfc_conv_descriptor_lbound (dumdesc, gfc_rank_cst[n]); + } + else + { + dubound = NULL_TREE; + dlbound = NULL_TREE; + } + + lbound = GFC_TYPE_ARRAY_LBOUND (type, n); + if (!INTEGER_CST_P (lbound)) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, sym->as->upper[n], + gfc_array_index_type); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_modify_expr (&block, lbound, se.expr); + } + + ubound = GFC_TYPE_ARRAY_UBOUND (type, n); + /* Set the desired upper bound. */ + if (sym->as->upper[n]) + { + /* We know what we want the upper bound to be. */ + if (!INTEGER_CST_P (ubound)) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, sym->as->upper[n], + gfc_array_index_type); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_modify_expr (&block, ubound, se.expr); + } + + /* Check the sizes match. */ + if (checkparm) + { + /* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */ + + tmp = fold (build (MINUS_EXPR, gfc_array_index_type, ubound, + lbound)); + stride = build (MINUS_EXPR, gfc_array_index_type, dubound, + dlbound); + tmp = fold (build (NE_EXPR, gfc_array_index_type, tmp, stride)); + gfc_trans_runtime_check (tmp, gfc_strconst_bounds, &block); + } + } + else + { + /* For assumed shape arrays move the upper bound by the same amount + as the lower bound. */ + tmp = build (MINUS_EXPR, gfc_array_index_type, dubound, dlbound); + tmp = fold (build (PLUS_EXPR, gfc_array_index_type, tmp, lbound)); + gfc_add_modify_expr (&block, ubound, tmp); + } + /* The offset of this dimension. offset = offset - lbound * stride. */ + tmp = fold (build (MULT_EXPR, gfc_array_index_type, lbound, stride)); + offset = fold (build (MINUS_EXPR, gfc_array_index_type, offset, tmp)); + + /* The size of this dimension, and the stride of the next. */ + if (n + 1 < sym->as->rank) + { + stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1); + + if (no_repack || partial != NULL_TREE) + { + stmt_unpacked = + gfc_conv_descriptor_stride (dumdesc, gfc_rank_cst[n+1]); + } + + /* Figure out the stride if not a known constant. */ + if (!INTEGER_CST_P (stride)) + { + if (no_repack) + stmt_packed = NULL_TREE; + else + { + /* Calculate stride = size * (ubound + 1 - lbound). */ + tmp = fold (build (MINUS_EXPR, gfc_array_index_type, + integer_one_node, lbound)); + tmp = fold (build (PLUS_EXPR, gfc_array_index_type, + ubound, tmp)); + size = fold (build (MULT_EXPR, gfc_array_index_type, + size, tmp)); + stmt_packed = size; + } + + /* Assign the stride. */ + if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) + { + tmp = build (COND_EXPR, gfc_array_index_type, partial, + stmt_unpacked, stmt_packed); + } + else + tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked; + gfc_add_modify_expr (&block, stride, tmp); + } + } + } + + /* Set the offset. */ + if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) + gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); + + stmt = gfc_finish_block (&block); + + gfc_start_block (&block); + + /* Only do the entry/initialization code if the arg is present. */ + dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); + if (sym->attr.optional) + { + tmp = gfc_conv_expr_present (sym); + stmt = build_v (COND_EXPR, tmp, stmt, build_empty_stmt ()); + } + gfc_add_expr_to_block (&block, stmt); + + /* Add the main function body. */ + gfc_add_expr_to_block (&block, body); + + /* Cleanup code. */ + if (!no_repack) + { + gfc_start_block (&cleanup); + + if (sym->attr.intent != INTENT_IN) + { + /* Copy the data back. */ + tmp = gfc_chainon_list (NULL_TREE, dumdesc); + tmp = gfc_chainon_list (tmp, tmpdesc); + tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp); + gfc_add_expr_to_block (&cleanup, tmp); + } + + /* Free the temporary. */ + tmp = gfc_chainon_list (NULL_TREE, tmpdesc); + tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp); + gfc_add_expr_to_block (&cleanup, tmp); + + stmt = gfc_finish_block (&cleanup); + + /* Only do the cleanup if the array was repacked. */ + tmp = gfc_build_indirect_ref (dumdesc); + tmp = gfc_conv_descriptor_data (tmp); + tmp = build (NE_EXPR, boolean_type_node, tmp, tmpdesc); + stmt = build_v (COND_EXPR, tmp, stmt, build_empty_stmt ()); + + if (sym->attr.optional) + { + tmp = gfc_conv_expr_present (sym); + stmt = build_v (COND_EXPR, tmp, stmt, build_empty_stmt ()); + } + gfc_add_expr_to_block (&block, stmt); + } + /* We don't need to free any memory allocated by internal_pack as it will + be freed at the end of the function by pop_context. */ + return gfc_finish_block (&block); +} + + +/* Convert an array for passing as an actual parameter. Expressions + and vector subscripts are evaluated and stored in a teporary, which is then + passed. For whole arrays the descriptor is passed. For array sections + a modified copy of the descriptor is passed, but using the original data. + Also used for array pointer assignments by setting se->direct_byref. */ + +void +gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) +{ + gfc_loopinfo loop; + gfc_ss *secss; + gfc_ss_info *info; + int need_tmp; + int n; + tree tmp; + tree desc; + stmtblock_t block; + tree start; + tree offset; + int full; + + assert (ss != gfc_ss_terminator); + + /* TODO: Pass constant array constructors without a temporary. */ + /* If we have a linear array section, we can pass it directly. Otherwise + we need to copy it into a temporary. */ + if (expr->expr_type == EXPR_VARIABLE) + { + gfc_ss *vss; + + /* Find the SS for the array section. */ + secss = ss; + while (secss != gfc_ss_terminator && secss->type != GFC_SS_SECTION) + secss = secss->next; + + assert (secss != gfc_ss_terminator); + + need_tmp = 0; + for (n = 0; n < secss->data.info.dimen; n++) + { + vss = secss->data.info.subscript[secss->data.info.dim[n]]; + if (vss && vss->type == GFC_SS_VECTOR) + need_tmp = 1; + } + + info = &secss->data.info; + + /* Get the descriptor for the array. */ + gfc_conv_ss_descriptor (&se->pre, secss, 0); + desc = info->descriptor; + if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) + { + /* Create a new descriptor if the array doesn't have one. */ + full = 0; + } + else if (info->ref->u.ar.type == AR_FULL) + full = 1; + else if (se->direct_byref) + full = 0; + else + { + assert (info->ref->u.ar.type == AR_SECTION); + + full = 1; + for (n = 0; n < info->ref->u.ar.dimen; n++) + { + /* Detect passing the full array as a section. This could do + even more checking, but it doesn't seem worth it. */ + if (info->ref->u.ar.start[n] + || info->ref->u.ar.end[n] + || (info->ref->u.ar.stride[n] + && !gfc_expr_is_one (info->ref->u.ar.stride[n], 0))) + { + full = 0; + break; + } + } + } + if (full) + { + if (se->direct_byref) + { + /* Copy the descriptor for pointer assignments. */ + gfc_add_modify_expr (&se->pre, se->expr, desc); + } + else if (se->want_pointer) + { + /* We pass full arrays directly. This means that pointers and + allocatable arrays should also work. */ + se->expr = gfc_build_addr_expr (NULL, desc); + } + else + { + se->expr = desc; + } + return; + } + } + else + { + need_tmp = 1; + secss = NULL; + info = NULL; + } + + gfc_init_loopinfo (&loop); + + /* Associate the SS with the loop. */ + gfc_add_ss_to_loop (&loop, ss); + + /* Tell the scalarizer not to bother creating loop varliables, etc. */ + if (!need_tmp) + loop.array_parameter = 1; + else + assert (se->want_pointer && !se->direct_byref); + + /* Setup the scalarizing loops and bounds. */ + gfc_conv_ss_startstride (&loop); + + if (need_tmp) + { + /* Tell the scalarizer to make a temporary. */ + loop.temp_ss = gfc_get_ss (); + loop.temp_ss->type = GFC_SS_TEMP; + loop.temp_ss->next = gfc_ss_terminator; + loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts); + loop.temp_ss->data.temp.string_length = NULL; + loop.temp_ss->data.temp.dimen = loop.dimen; + gfc_add_ss_to_loop (&loop, loop.temp_ss); + } + + gfc_conv_loop_setup (&loop); + + if (need_tmp) + { + /* Copy into a temporary and pass that. We don't need to copy the data + back because expressions and vector subscripts must be INTENT_IN. */ + /* TODO: Optimize passing function return values. */ + gfc_se lse; + gfc_se rse; + + /* Start the copying loops. */ + gfc_mark_ss_chain_used (loop.temp_ss, 1); + gfc_mark_ss_chain_used (ss, 1); + gfc_start_scalarized_body (&loop, &block); + + /* Copy each data element. */ + gfc_init_se (&lse, NULL); + gfc_copy_loopinfo_to_se (&lse, &loop); + gfc_init_se (&rse, NULL); + gfc_copy_loopinfo_to_se (&rse, &loop); + + lse.ss = loop.temp_ss; + rse.ss = ss; + + gfc_conv_scalarized_array_ref (&lse, NULL); + gfc_conv_expr_val (&rse, expr); + + gfc_add_block_to_block (&block, &rse.pre); + gfc_add_block_to_block (&block, &lse.pre); + + gfc_add_modify_expr (&block, lse.expr, rse.expr); + + /* Finish the copying loops. */ + gfc_trans_scalarizing_loops (&loop, &block); + + /* Set the first stride component to zero to indicate a temporary. */ + desc = loop.temp_ss->data.info.descriptor; + tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[0]); + gfc_add_modify_expr (&loop.pre, tmp, integer_zero_node); + + assert (is_gimple_lvalue (desc)); + se->expr = gfc_build_addr_expr (NULL, desc); + } + else + { + /* We pass sections without copying to a temporary. A function may + decide to repack the array to speed up access, but we're not + bothered about that here. */ + int dim; + tree parm; + tree parmtype; + tree stride; + tree from; + tree to; + tree base; + + /* Otherwise make a new descriptor and point it at the section we + want. The loop variable limits will be the limits of the section. + */ + desc = info->descriptor; + assert (secss && secss != gfc_ss_terminator); + if (se->direct_byref) + { + /* For pointer assignments we fill in the destination. */ + parm = se->expr; + parmtype = TREE_TYPE (parm); + } + else + { + /* Otherwise make a new one. */ + parmtype = gfc_get_element_type (TREE_TYPE (desc)); + parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, + loop.from, loop.to, 0); + parm = gfc_create_var (parmtype, "parm"); + } + + offset = integer_zero_node; + dim = 0; + + /* The following can be somewhat confusing. We have two + descriptors, a new one and the original array. + {parm, parmtype, dim} refer to the new one. + {desc, type, n, secss, loop} refer to the original, which maybe + a descriptorless array. + The bounds of the scaralization are the bounds of the section. + We don't have to worry about numeric overflows when calculating + the offsets because all elements are within the array data. */ + + /* Set the dtype. */ + tmp = gfc_conv_descriptor_dtype (parm); + gfc_add_modify_expr (&loop.pre, tmp, GFC_TYPE_ARRAY_DTYPE (parmtype)); + + if (se->direct_byref) + base = integer_zero_node; + else + base = NULL_TREE; + + for (n = 0; n < info->ref->u.ar.dimen; n++) + { + stride = gfc_conv_array_stride (desc, n); + + /* Work out the offset. */ + if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT) + { + assert (info->subscript[n] + && info->subscript[n]->type == GFC_SS_SCALAR); + start = info->subscript[n]->data.scalar.expr; + } + else + { + /* Check we haven't somehow got out of sync. */ + assert (info->dim[dim] == n); + + /* Evaluate and remember the start of the section. */ + start = info->start[dim]; + stride = gfc_evaluate_now (stride, &loop.pre); + } + + tmp = gfc_conv_array_lbound (desc, n); + tmp = fold (build (MINUS_EXPR, TREE_TYPE (tmp), start, tmp)); + + tmp = fold (build (MULT_EXPR, TREE_TYPE (tmp), tmp, stride)); + offset = fold (build (PLUS_EXPR, TREE_TYPE (tmp), offset, tmp)); + + if (info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT) + { + /* For elemental dimensions, we only need the offset. */ + continue; + } + + /* Vector subscripts need copying and are handled elsewhere. */ + assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE); + + /* Set the new lower bound. */ + from = loop.from[dim]; + to = loop.to[dim]; + if (!integer_onep (from)) + { + /* Make sure the new section starts at 1. */ + tmp = fold (build (MINUS_EXPR, TREE_TYPE (from), + integer_one_node, from)); + to = fold (build (PLUS_EXPR, TREE_TYPE (to), to, tmp)); + from = integer_one_node; + } + tmp = gfc_conv_descriptor_lbound (parm, gfc_rank_cst[dim]); + gfc_add_modify_expr (&loop.pre, tmp, from); + + /* Set the new upper bound. */ + tmp = gfc_conv_descriptor_ubound (parm, gfc_rank_cst[dim]); + gfc_add_modify_expr (&loop.pre, tmp, to); + + /* Multiply the stride by the section stride to get the + total stride. */ + stride = fold (build (MULT_EXPR, gfc_array_index_type, stride, + info->stride[dim])); + + if (se->direct_byref) + { + base = fold (build (MINUS_EXPR, TREE_TYPE (base), + base, stride)); + } + + /* Store the new stride. */ + tmp = gfc_conv_descriptor_stride (parm, gfc_rank_cst[dim]); + gfc_add_modify_expr (&loop.pre, tmp, stride); + + dim++; + } + + /* Point the data pointer at the first element in the section. */ + tmp = gfc_conv_array_data (desc); + tmp = gfc_build_indirect_ref (tmp); + tmp = gfc_build_array_ref (tmp, offset); + offset = gfc_build_addr_expr (gfc_array_dataptr_type (desc), tmp); + + tmp = gfc_conv_descriptor_data (parm); + gfc_add_modify_expr (&loop.pre, tmp, offset); + + if (se->direct_byref) + { + /* Set the offset. */ + tmp = gfc_conv_descriptor_offset (parm); + gfc_add_modify_expr (&loop.pre, tmp, base); + } + else + { + /* Only the callee knows what the correct offset it, so just set + it to zero here. */ + tmp = gfc_conv_descriptor_offset (parm); + gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node); + } + + if (!se->direct_byref) + { + /* Get a pointer to the new descriptor. */ + if (se->want_pointer) + se->expr = gfc_build_addr_expr (NULL, parm); + else + se->expr = parm; + } + } + + gfc_add_block_to_block (&se->pre, &loop.pre); + gfc_add_block_to_block (&se->post, &loop.post); + + /* Cleanup the scalarizer. */ + gfc_cleanup_loop (&loop); +} + + +/* Convert an array for passing as an actual parameter. */ +/* TODO: Optimize passing g77 arrays. */ + +void +gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77) +{ + tree ptr; + tree desc; + tree tmp; + tree stmt; + gfc_symbol *sym; + stmtblock_t block; + + /* Passing address of the array if it is not pointer or assumed-shape. */ + if (expr->expr_type == EXPR_VARIABLE + && expr->ref->u.ar.type == AR_FULL && g77) + { + sym = expr->symtree->n.sym; + tmp = gfc_get_symbol_decl (sym); + if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE + && !sym->attr.allocatable) + { + if (!sym->attr.dummy) + se->expr = gfc_build_addr_expr (NULL, tmp); + else + se->expr = tmp; + return; + } + if (sym->attr.allocatable) + { + se->expr = gfc_conv_array_data (tmp); + return; + } + } + + se->want_pointer = 1; + gfc_conv_expr_descriptor (se, expr, ss); + + if (g77) + { + desc = se->expr; + /* Repack the array. */ + tmp = gfc_chainon_list (NULL_TREE, desc); + ptr = gfc_build_function_call (gfor_fndecl_in_pack, tmp); + ptr = gfc_evaluate_now (ptr, &se->pre); + se->expr = ptr; + + gfc_start_block (&block); + + /* Copy the data back. */ + tmp = gfc_chainon_list (NULL_TREE, desc); + tmp = gfc_chainon_list (tmp, ptr); + tmp = gfc_build_function_call (gfor_fndecl_in_unpack, tmp); + gfc_add_expr_to_block (&block, tmp); + + /* Free the temporary. */ + tmp = convert (pvoid_type_node, ptr); + tmp = gfc_chainon_list (NULL_TREE, tmp); + tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp); + gfc_add_expr_to_block (&block, tmp); + + stmt = gfc_finish_block (&block); + + gfc_init_block (&block); + /* Only if it was repacked. This code needs to be executed before the + loop cleanup code. */ + tmp = gfc_build_indirect_ref (desc); + tmp = gfc_conv_array_data (tmp); + tmp = build (NE_EXPR, boolean_type_node, ptr, tmp); + tmp = build_v (COND_EXPR, tmp, stmt, build_empty_stmt ()); + + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, &se->post); + + gfc_init_block (&se->post); + gfc_add_block_to_block (&se->post, &block); + } +} + + +/* NULLIFY an allocated/pointer array on function entry, free it on exit. */ + +tree +gfc_trans_deferred_array (gfc_symbol * sym, tree body) +{ + tree type; + tree tmp; + tree descriptor; + tree deallocate; + stmtblock_t block; + stmtblock_t fnblock; + locus loc; + + /* Make sure the frontend gets these right. */ + if (!(sym->attr.pointer || sym->attr.allocatable)) + fatal_error + ("Possible frontend bug: Deferred array size without pointer or allocatable attribute."); + + gfc_init_block (&fnblock); + + assert (TREE_CODE (sym->backend_decl) == VAR_DECL); + if (sym->ts.type == BT_CHARACTER + && !INTEGER_CST_P (sym->ts.cl->backend_decl)) + gfc_trans_init_string_length (sym->ts.cl, &fnblock); + + /* Parameter variables don't need anything special. */ + if (sym->attr.dummy) + { + gfc_add_expr_to_block (&fnblock, body); + + return gfc_finish_block (&fnblock); + } + + gfc_get_backend_locus (&loc); + gfc_set_backend_locus (&sym->declared_at); + descriptor = sym->backend_decl; + + if (TREE_STATIC (descriptor)) + { + /* SAVEd variables are not freed on exit. */ + gfc_trans_static_array_pointer (sym); + return body; + } + + /* Get the descriptor type. */ + type = TREE_TYPE (sym->backend_decl); + assert (GFC_DESCRIPTOR_TYPE_P (type)); + + /* NULLIFY the data pointer. */ + tmp = gfc_conv_descriptor_data (descriptor); + gfc_add_modify_expr (&fnblock, tmp, integer_zero_node); + + gfc_add_expr_to_block (&fnblock, body); + + gfc_set_backend_locus (&loc); + /* Allocatable arrays need to be freed when they go out of scope. */ + if (sym->attr.allocatable) + { + gfc_start_block (&block); + + /* Deallocate if still allocated at the end of the procedure. */ + deallocate = gfc_array_deallocate (descriptor); + + tmp = gfc_conv_descriptor_data (descriptor); + tmp = build (NE_EXPR, boolean_type_node, tmp, integer_zero_node); + tmp = build_v (COND_EXPR, tmp, deallocate, build_empty_stmt ()); + gfc_add_expr_to_block (&block, tmp); + + tmp = gfc_finish_block (&block); + gfc_add_expr_to_block (&fnblock, tmp); + } + + return gfc_finish_block (&fnblock); +} + +/************ Expression Walking Functions ******************/ + +/* Walk a variable reference. + + Possible extension - multiple component subscripts. + x(:,:) = foo%a(:)%b(:) + Transforms to + forall (i=..., j=...) + x(i,j) = foo%a(j)%b(i) + end forall + This adds a fair amout of complexity because you need to deal with more + than one ref. Maybe handle in a similar manner to vector subscripts. + Maybe not worth the effort. */ + + +static gfc_ss * +gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) +{ + gfc_ref *ref; + gfc_array_ref *ar; + gfc_ss *newss; + gfc_ss *head; + int n; + + for (ref = expr->ref; ref; ref = ref->next) + { + /* We're only interested in array sections. */ + if (ref->type != REF_ARRAY) + continue; + + ar = &ref->u.ar; + switch (ar->type) + { + case AR_ELEMENT: + /* TODO: Take elemental array references out of scalarization + loop. */ + break; + + case AR_FULL: + newss = gfc_get_ss (); + newss->type = GFC_SS_SECTION; + newss->expr = expr; + newss->next = ss; + newss->data.info.dimen = ar->as->rank; + newss->data.info.ref = ref; + + /* Make sure array is the same as array(:,:), this way + we don't need to special case all the time. */ + ar->dimen = ar->as->rank; + for (n = 0; n < ar->dimen; n++) + { + newss->data.info.dim[n] = n; + ar->dimen_type[n] = DIMEN_RANGE; + + assert (ar->start[n] == NULL); + assert (ar->end[n] == NULL); + assert (ar->stride[n] == NULL); + } + return newss; + + case AR_SECTION: + newss = gfc_get_ss (); + newss->type = GFC_SS_SECTION; + newss->expr = expr; + newss->next = ss; + newss->data.info.dimen = 0; + newss->data.info.ref = ref; + + head = newss; + + /* We add SS chains for all the subscripts in the section. */ + for (n = 0; n < ar->dimen; n++) + { + gfc_ss *indexss; + + switch (ar->dimen_type[n]) + { + case DIMEN_ELEMENT: + /* Add SS for elemental (scalar) subscripts. */ + assert (ar->start[n]); + indexss = gfc_get_ss (); + indexss->type = GFC_SS_SCALAR; + indexss->expr = ar->start[n]; + indexss->next = gfc_ss_terminator; + indexss->loop_chain = gfc_ss_terminator; + newss->data.info.subscript[n] = indexss; + break; + + case DIMEN_RANGE: + /* We don't add anything for sections, just remember this + dimension for later. */ + newss->data.info.dim[newss->data.info.dimen] = n; + newss->data.info.dimen++; + break; + + case DIMEN_VECTOR: + /* Get a SS for the vector. This will not be added to the + chain directly. */ + indexss = gfc_walk_expr (ar->start[n]); + if (indexss == gfc_ss_terminator) + internal_error ("scalar vector subscript???"); + + /* We currently only handle really simple vector + subscripts. */ + if (indexss->next != gfc_ss_terminator) + gfc_todo_error ("vector subscript expressions"); + indexss->loop_chain = gfc_ss_terminator; + + /* Mark this as a vector subscript. We don't add this + directly into the chain, but as a subscript of the + existing SS for this term. */ + indexss->type = GFC_SS_VECTOR; + newss->data.info.subscript[n] = indexss; + /* Also remember this dimension. */ + newss->data.info.dim[newss->data.info.dimen] = n; + newss->data.info.dimen++; + break; + + default: + /* We should know what sort of section it is by now. */ + abort (); + } + } + /* We should have at least one non-elemental dimension. */ + assert (newss->data.info.dimen > 0); + return head; + break; + + default: + /* We should know what sort of section it is by now. */ + abort (); + } + + } + return ss; +} + + +/* Walk an expression operator. If only one operand of a binary expression is + scalar, we must also add the scalar term to the SS chain. */ + +static gfc_ss * +gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr) +{ + gfc_ss *head; + gfc_ss *head2; + gfc_ss *newss; + + head = gfc_walk_subexpr (ss, expr->op1); + if (expr->op2 == NULL) + head2 = head; + else + head2 = gfc_walk_subexpr (head, expr->op2); + + /* All operands are scalar. Pass back and let the caller deal with it. */ + if (head2 == ss) + return head2; + + /* All operands require scalarization. */ + if (head != ss && (expr->op2 == NULL || head2 != head)) + return head2; + + /* One of the operands needs scalarization, the other is scalar. + Create a gfc_ss for the scalar expression. */ + newss = gfc_get_ss (); + newss->type = GFC_SS_SCALAR; + if (head == ss) + { + /* First operand is scalar. We build the chain in reverse order, so + add the scarar SS after the second operand. */ + head = head2; + while (head && head->next != ss) + head = head->next; + /* Check we haven't somehow broken the chain. */ + assert (head); + newss->next = ss; + head->next = newss; + newss->expr = expr->op1; + } + else /* head2 == head */ + { + assert (head2 == head); + /* Second operand is scalar. */ + newss->next = head2; + head2 = newss; + newss->expr = expr->op2; + } + + return head2; +} + + +/* Reverse a SS chain. */ + +static gfc_ss * +gfc_reverse_ss (gfc_ss * ss) +{ + gfc_ss *next; + gfc_ss *head; + + assert (ss != NULL); + + head = gfc_ss_terminator; + while (ss != gfc_ss_terminator) + { + next = ss->next; + assert (next != NULL); /* Check we didn't somehow break the chain. */ + ss->next = head; + head = ss; + ss = next; + } + + return (head); +} + + +/* Walk the arguments of an elemental function. */ + +gfc_ss * +gfc_walk_elemental_function_args (gfc_ss * ss, gfc_expr * expr, + gfc_ss_type type) +{ + gfc_actual_arglist *arg; + int scalar; + gfc_ss *head; + gfc_ss *tail; + gfc_ss *newss; + + head = gfc_ss_terminator; + tail = NULL; + scalar = 1; + for (arg = expr->value.function.actual; arg; arg = arg->next) + { + if (!arg->expr) + continue; + + newss = gfc_walk_subexpr (head, arg->expr); + if (newss == head) + { + /* Scalar argumet. */ + newss = gfc_get_ss (); + newss->type = type; + newss->expr = arg->expr; + newss->next = head; + } + else + scalar = 0; + + head = newss; + if (!tail) + { + tail = head; + while (tail->next != gfc_ss_terminator) + tail = tail->next; + } + } + + if (scalar) + { + /* If all the arguments are scalar we don't need the argument SS. */ + gfc_free_ss_chain (head); + /* Pass it back. */ + return ss; + } + + /* Add it onto the existing chain. */ + tail->next = ss; + return head; +} + + +/* Walk a function call. Scalar functions are passed back, and taken out of + scalarization loops. For elemental functions we walk their arguments. + The result of functions returning arrays is stored in a temporary outside + the loop, so that the function is only called once. Hence we do not need + to walk their arguments. */ + +static gfc_ss * +gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) +{ + gfc_ss *newss; + gfc_intrinsic_sym *isym; + gfc_symbol *sym; + + isym = expr->value.function.isym; + + /* Handle intrinsic functions seperately. */ + if (isym) + return gfc_walk_intrinsic_function (ss, expr, isym); + + sym = expr->value.function.esym; + if (!sym) + sym = expr->symtree->n.sym; + + /* A function that returns arrays. */ + if (gfc_return_by_reference (sym) && sym->result->attr.dimension) + { + newss = gfc_get_ss (); + newss->type = GFC_SS_FUNCTION; + newss->expr = expr; + newss->next = ss; + newss->data.info.dimen = expr->rank; + return newss; + } + + /* Walk the parameters of an elemental function. For now we always pass + by reference. */ + if (sym->attr.elemental) + return gfc_walk_elemental_function_args (ss, expr, GFC_SS_REFERENCE); + + /* Scalar functions are OK as these are evaluated outside the scalarisation + loop. Pass back and let the caller deal with it. */ + return ss; +} + + +/* An array temporary is constructed for array constructors. */ + +static gfc_ss * +gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr) +{ + gfc_ss *newss; + int n; + + newss = gfc_get_ss (); + newss->type = GFC_SS_CONSTRUCTOR; + newss->expr = expr; + newss->next = ss; + newss->data.info.dimen = expr->rank; + for (n = 0; n < expr->rank; n++) + newss->data.info.dim[n] = n; + + return newss; +} + + +/* Walk an expresson. Add walked expressions to the head of the SS chain. + A wholy scalar expression will not be added. */ + +static gfc_ss * +gfc_walk_subexpr (gfc_ss * ss, gfc_expr * expr) +{ + gfc_ss *head; + + switch (expr->expr_type) + { + case EXPR_VARIABLE: + head = gfc_walk_variable_expr (ss, expr); + return head; + + case EXPR_OP: + head = gfc_walk_op_expr (ss, expr); + return head; + + case EXPR_FUNCTION: + head = gfc_walk_function_expr (ss, expr); + return head; + + case EXPR_CONSTANT: + case EXPR_NULL: + case EXPR_STRUCTURE: + /* Pass back and let the caller deal with it. */ + break; + + case EXPR_ARRAY: + head = gfc_walk_array_constructor (ss, expr); + return head; + + case EXPR_SUBSTRING: + /* Pass back and let the caller deal with it. */ + break; + + default: + internal_error ("bad expression type during walk (%d)", + expr->expr_type); + } + return ss; +} + + +/* Entry point for expression walking. + A return value equal to the passed chain means this is + a scalar expression. It is up to the caller to take whatever action is + neccessary to translate these. */ + +gfc_ss * +gfc_walk_expr (gfc_expr * expr) +{ + gfc_ss *res; + + res = gfc_walk_subexpr (gfc_ss_terminator, expr); + return gfc_reverse_ss (res); +} + diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h new file mode 100644 index 00000000000..fe3f9ce707d --- /dev/null +++ b/gcc/fortran/trans-array.h @@ -0,0 +1,117 @@ +/* Header for array handling functions + Copyright (C) 2002, 2003 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Generate code to free an array. */ +tree gfc_array_deallocate (tree); + +/* Generate code to initialise an allocate an array. Statements are added to + se, which should contain an expression for the array descriptor. */ +void gfc_array_allocate (gfc_se *, gfc_ref *, tree); + +/* Generate code to allocate a temporary array. */ +tree gfc_trans_allocate_temp_array (gfc_loopinfo *, gfc_ss_info *, tree, + tree); + +/* Generate function entry code for allocation of compiler allocated array + variables. */ +tree gfc_trans_auto_array_allocation (tree, gfc_symbol *, tree); +/* Generate entry and exit code for dummy array parameters. */ +tree gfc_trans_dummy_array_bias (gfc_symbol *, tree, tree); +/* Generate entry and exit code for g77 calling convention arrays. */ +tree gfc_trans_g77_array (gfc_symbol *, tree); +/* Add initialisation for deferred arrays. */ +tree gfc_trans_deferred_array (gfc_symbol *, tree); +/* Generate an initializer for a static pointer or allocatable array. */ +void gfc_trans_static_array_pointer (gfc_symbol *); + +/* Generate scalarization information for an expression. */ +gfc_ss *gfc_walk_expr (gfc_expr *); +/* Walk the arguments of an intrinsic function. */ +gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_expr *, gfc_ss_type); +/* Walk an intrinsic function. */ +gfc_ss *gfc_walk_intrinsic_function (gfc_ss *, gfc_expr *, + gfc_intrinsic_sym *); + +/* Free the SS assocuated with a loop. */ +void gfc_cleanup_loop (gfc_loopinfo *); +/* Associate a SS chain with a loop. */ +void gfc_add_ss_to_loop (gfc_loopinfo *, gfc_ss *); +/* Mark a SS chain as used in this loop. */ +void gfc_mark_ss_chain_used (gfc_ss *, unsigned); + +/* Calculates the lower bound and stride of array sections. */ +void gfc_conv_ss_startstride (gfc_loopinfo *); + +void gfc_init_loopinfo (gfc_loopinfo *); +void gfc_copy_loopinfo_to_se (gfc_se *, gfc_loopinfo *); + +/* Marks the start of a scalarized expression, and declares loop variables. */ +void gfc_start_scalarized_body (gfc_loopinfo *, stmtblock_t *); +/* Generates the actual loops for a scalarized expression. */ +void gfc_trans_scalarizing_loops (gfc_loopinfo *, stmtblock_t *); +/* Mark the end of the main loop body and the start of the copying loop. */ +void gfc_trans_scalarized_loop_boundary (gfc_loopinfo *, stmtblock_t *); +/* Initialise the scalarization loop parameters. */ +void gfc_conv_loop_setup (gfc_loopinfo *); +/* Resolve array assignment dependencies. */ +void gfc_conv_resolve_dependencies (gfc_loopinfo *, gfc_ss *, gfc_ss *); + +/* Get a single array element. */ +void gfc_conv_array_ref (gfc_se *, gfc_array_ref *); +/* Translate a reference to a temporary array. */ +void gfc_conv_tmp_array_ref (gfc_se * se); +/* Translate a reference to an array temporary. */ +void gfc_conv_tmp_ref (gfc_se *); + +/* Evaluate an array expression. */ +void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *, gfc_ss *); +/* Convert an array for passing as an actual function parameter. */ +void gfc_conv_array_parameter (gfc_se *, gfc_expr *, gfc_ss *, int); + +/* These work with both descriptors and descriptorless arrays. */ +tree gfc_conv_array_data (tree); +tree gfc_conv_array_offset (tree); +/* Return either an INT_CST or an expression for that part of the descriptor. */ +tree gfc_conv_array_stride (tree, int); +tree gfc_conv_array_lbound (tree, int); +tree gfc_conv_array_ubound (tree, int); + +/* The remaining space available for stack variables. */ +extern unsigned HOST_WIDE_INT gfc_stack_space_left; +/* Returns true if a variable of specified size should go on the stack. */ +int gfc_can_put_var_on_stack (tree); + +/* Build expressions for accessing components of an array descriptor. */ +tree gfc_conv_descriptor_data (tree); +tree gfc_conv_descriptor_offset (tree); +tree gfc_conv_descriptor_dtype (tree); +tree gfc_conv_descriptor_stride (tree, tree); +tree gfc_conv_descriptor_lbound (tree, tree); +tree gfc_conv_descriptor_ubound (tree, tree); + +/* Dependency checking for WHERE and FORALL. */ +int gfc_check_dependency (gfc_expr *, gfc_expr *, gfc_expr **, int); +/* Dependency checking for function calls. */ +int gfc_check_fncall_dependency (gfc_expr *, gfc_expr *); + +/* Add pre-loop scalarization code for intrinsic functions which require + special handling. */ +void gfc_add_intrinsic_ss_code (gfc_loopinfo *, gfc_ss *); diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c new file mode 100644 index 00000000000..0c954191818 --- /dev/null +++ b/gcc/fortran/trans-common.c @@ -0,0 +1,756 @@ +/* Common block and equivalence list handling + Copyright (C) 2000-2003 Free Software Foundation, Inc. + Contributed by Canqun Yang <canqun@nudt.edu.cn> + +This file is part of GNU G95. + +G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* The core algorithm is based on Andy Vaught's g95 tree. Also the + way to build UNION_TYPE is borrowed from Richard Henderson. + + Transform common blocks. An integral part of this is processing + equvalence variables. Equivalenced variables that are not in a + common block end up in a private block of their own. + + Each common block or local equivalence list is declared as a union. + Variables within the block are represented as a field within the + block with the proper offset. + + So if two variables are equivalenced, they just point to a common + area in memory. + + Mathematically, laying out an equivalence block is equivalent to + solving a linear system of equations. The matrix is usually a + sparse matrix in which each row contains all zero elements except + for a +1 and a -1, a sort of a generalized Vandermonde matrix. The + matrix is usually block diagonal. The system can be + overdetermined, underdetermined or have a unique solution. If the + system is inconsistent, the program is not standard conforming. + The solution vector is integral, since all of the pivots are +1 or -1. + + How we lay out an equivalence block is a little less complicated. + In an equivalence list with n elements, there are n-1 conditions to + be satisfied. The conditions partition the variables into what we + will call segments. If A and B are equivalenced then A and B are + in the same segment. If B and C are equivalenced as well, then A, + B and C are in a segment and so on. Each segment is a block of + memory that has one or more variables equivalenced in some way. A + common block is made up of a series of segments that are joined one + after the other. In the linear system, a segment is a block + diagonal. + + To lay out a segment we first start with some variable and + determine its length. The first variable is assumed to start at + offset one and extends to however long it is. We then traverse the + list of equivalences to find an unused condition that involves at + least one of the variables currently in the segment. + + Each equivalence condition amounts to the condition B+b=C+c where B + and C are the offsets of the B and C variables, and b and c are + constants which are nonzero for array elements, substrings or + structure components. So for + + EQUIVALENCE(B(2), C(3)) + we have + B + 2*size of B's elements = C + 3*size of C's elements. + + If B and C are known we check to see if the condition already + holds. If B is known we can solve for C. Since we know the length + of C, we can see if the minimum and maximum extents of the segment + are affected. Eventually, we make a full pass through the + equivalence list without finding any new conditions and the segment + is fully specified. + + At this point, the segment is added to the current common block. + Since we know the minimum extent of the segment, everything in the + segment is translated to its position in the common block. The + usual case here is that there are no equivalence statements and the + common block is series of segments with one variable each, which is + a diagonal matrix in the matrix formulation. + + Once all common blocks have been created, the list of equivalences + is examined for still-unused equivalence conditions. We create a + block for each merged equivalence list. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "toplev.h" +#include "tm.h" +#include "gfortran.h" +#include "trans.h" +#include "trans-types.h" +#include "trans-const.h" + + +typedef struct segment_info +{ + gfc_symbol *sym; + int offset; + int length; + tree field; + struct segment_info *next; +} segment_info; + +static segment_info *current_segment, *current_common; +static int current_length, current_offset; +static gfc_namespace *gfc_common_ns = NULL; + +#define get_segment_info() gfc_getmem (sizeof (segment_info)) + +#define BLANK_COMMON_NAME "__BLNK__" + + +/* Construct mangled common block name from symbol name. */ + +static tree +gfc_sym_mangled_common_id (gfc_symbol *sym) +{ + int has_underscore; + char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1]; + + if (strcmp (sym->name, BLANK_COMMON_NAME) == 0) + return get_identifier (sym->name); + if (gfc_option.flag_underscoring) + { + has_underscore = strchr (sym->name, '_') != 0; + if (gfc_option.flag_second_underscore && has_underscore) + snprintf (name, sizeof name, "%s__", sym->name); + else + snprintf (name, sizeof name, "%s_", sym->name); + return get_identifier (name); + } + else + return get_identifier (sym->name); +} + + +/* Build a filed declaration for a common variable or a local equivalence + object. */ + +static tree +build_field (segment_info *h, tree union_type, record_layout_info rli) +{ + tree type = gfc_sym_type (h->sym); + tree name = get_identifier (h->sym->name); + tree field = build_decl (FIELD_DECL, name, type); + HOST_WIDE_INT offset = h->offset; + unsigned int desired_align, known_align; + + known_align = (offset & -offset) * BITS_PER_UNIT; + if (known_align == 0 || known_align > BIGGEST_ALIGNMENT) + known_align = BIGGEST_ALIGNMENT; + + desired_align = update_alignment_for_field (rli, field, known_align); + if (desired_align > known_align) + DECL_PACKED (field) = 1; + + DECL_FIELD_CONTEXT (field) = union_type; + DECL_FIELD_OFFSET (field) = size_int (offset); + DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node; + SET_DECL_OFFSET_ALIGN (field, known_align); + + rli->offset = size_binop (MAX_EXPR, rli->offset, + size_binop (PLUS_EXPR, + DECL_FIELD_OFFSET (field), + DECL_SIZE_UNIT (field))); + return field; +} + + +/* Get storage for local equivalence. */ + +static tree +build_equiv_decl (tree union_type, bool is_init) +{ + tree decl; + decl = build_decl (VAR_DECL, NULL, union_type); + DECL_ARTIFICIAL (decl) = 1; + + if (is_init) + DECL_COMMON (decl) = 0; + else + DECL_COMMON (decl) = 1; + + TREE_ADDRESSABLE (decl) = 1; + TREE_USED (decl) = 1; + gfc_add_decl_to_function (decl); + + return decl; +} + + +/* Get storage for common block. */ + +static tree +build_common_decl (gfc_symbol *sym, tree union_type, bool is_init) +{ + gfc_symbol *common_sym; + tree decl; + + /* Create a namespace to store symbols for common blocks. */ + if (gfc_common_ns == NULL) + gfc_common_ns = gfc_get_namespace (NULL); + + gfc_get_symbol (sym->name, gfc_common_ns, &common_sym); + decl = common_sym->backend_decl; + + /* Update the size of this common block as needed. */ + if (decl != NULL_TREE) + { + tree size = build_int_2 (current_length, 0); + if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size)) + { + /* Named common blocks of the same name shall be of the same size + in all scoping units of a program in which they appear, but + blank common blocks may be of different sizes. */ + if (strcmp (sym->name, BLANK_COMMON_NAME)) + gfc_warning ("named COMMON block '%s' at %L shall be of the " + "same size", sym->name, &sym->declared_at); + DECL_SIZE_UNIT (decl) = size; + } + } + + /* If this common block has been declared in a previous program unit, + and either it is already initialized or there is no new initialization + for it, just return. */ + if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl))) + return decl; + + /* If there is no backend_decl for the common block, build it. */ + if (decl == NULL_TREE) + { + decl = build_decl (VAR_DECL, get_identifier (sym->name), union_type); + SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (sym)); + TREE_PUBLIC (decl) = 1; + TREE_STATIC (decl) = 1; + DECL_ALIGN (decl) = BIGGEST_ALIGNMENT; + DECL_USER_ALIGN (decl) = 0; + } + + /* Has no initial values. */ + if (!is_init) + { + DECL_INITIAL (decl) = NULL_TREE; + DECL_COMMON (decl) = 1; + DECL_DEFER_OUTPUT (decl) = 1; + + /* Place the back end declaration for this common block in + GLOBAL_BINDING_LEVEL. */ + common_sym->backend_decl = pushdecl_top_level (decl); + } + else + { + DECL_INITIAL (decl) = error_mark_node; + DECL_COMMON (decl) = 0; + DECL_DEFER_OUTPUT (decl) = 0; + common_sym->backend_decl = decl; + } + return decl; +} + + +/* Declare memory for the common block or local equivalence, and create + backend declarations for all of the elements. */ + +static void +create_common (gfc_symbol *sym) +{ + segment_info *h, *next_s; + tree union_type; + tree *field_link; + record_layout_info rli; + tree decl; + bool is_init = false; + + /* Declare the variables inside the common block. */ + union_type = make_node (UNION_TYPE); + rli = start_record_layout (union_type); + field_link = &TYPE_FIELDS (union_type); + + for (h = current_common; h; h = next_s) + { + tree field; + field = build_field (h, union_type, rli); + + /* Link the field into the type. */ + *field_link = field; + field_link = &TREE_CHAIN (field); + h->field = field; + /* Has initial value. */ + if (h->sym->value) + is_init = true; + + next_s = h->next; + } + finish_record_layout (rli, true); + + if (is_init) + gfc_todo_error ("initial values for COMMON or EQUIVALENCE"); + + if (sym) + decl = build_common_decl (sym, union_type, is_init); + else + decl = build_equiv_decl (union_type, is_init); + + /* Build component reference for each variable. */ + for (h = current_common; h; h = next_s) + { + h->sym->backend_decl = build (COMPONENT_REF, TREE_TYPE (h->field), + decl, h->field); + + next_s = h->next; + gfc_free (h); + } +} + + +/* Given a symbol, find it in the current segment list. Returns NULL if + not found. */ + +static segment_info * +find_segment_info (gfc_symbol *symbol) +{ + segment_info *n; + + for (n = current_segment; n; n = n->next) + if (n->sym == symbol) return n; + + return NULL; +} + + +/* Given a variable symbol, calculate the total length in bytes of the + variable. */ + +static int +calculate_length (gfc_symbol *symbol) +{ + int j, element_size; + mpz_t elements; + + if (symbol->ts.type == BT_CHARACTER) + gfc_conv_const_charlen (symbol->ts.cl); + element_size = int_size_in_bytes (gfc_typenode_for_spec (&symbol->ts)); + if (symbol->as == NULL) + return element_size; + + /* Calculate the number of elements in the array */ + if (spec_size (symbol->as, &elements) == FAILURE) + gfc_internal_error ("calculate_length(): Unable to determine array size"); + j = mpz_get_ui (elements); + mpz_clear (elements); + + return j*element_size;; +} + + +/* Given an expression node, make sure it is a constant integer and return + the mpz_t value. */ + +static mpz_t * +get_mpz (gfc_expr *g) +{ + if (g->expr_type != EXPR_CONSTANT) + gfc_internal_error ("get_mpz(): Not an integer constant"); + + return &g->value.integer; +} + + +/* Given an array specification and an array reference, figure out the + array element number (zero based). Bounds and elements are guaranteed + to be constants. If something goes wrong we generate an error and + return zero. */ + +static int +element_number (gfc_array_ref *ar) +{ + mpz_t multiplier, offset, extent, l; + gfc_array_spec *as; + int b, rank; + + as = ar->as; + rank = as->rank; + mpz_init_set_ui (multiplier, 1); + mpz_init_set_ui (offset, 0); + mpz_init (extent); + mpz_init (l); + + for (b = 0; b < rank; b++) + { + if (ar->dimen_type[b] != DIMEN_ELEMENT) + gfc_internal_error ("element_number(): Bad dimension type"); + + mpz_sub (l, *get_mpz (ar->start[b]), *get_mpz (as->lower[b])); + + mpz_mul (l, l, multiplier); + mpz_add (offset, offset, l); + + mpz_sub (extent, *get_mpz (as->upper[b]), *get_mpz (as->lower[b])); + mpz_add_ui (extent, extent, 1); + + if (mpz_sgn (extent) < 0) + mpz_set_ui (extent, 0); + + mpz_mul (multiplier, multiplier, extent); + } + + b = mpz_get_ui (offset); + + mpz_clear (multiplier); + mpz_clear (offset); + mpz_clear (extent); + mpz_clear (l); + + return b; +} + + +/* Given a single element of an equivalence list, figure out the offset + from the base symbol. For simple variables or full arrays, this is + simply zero. For an array element we have to calculate the array + element number and multiply by the element size. For a substring we + have to calculate the further reference. */ + +static int +calculate_offset (gfc_expr *s) +{ + int a, element_size, offset; + gfc_typespec *element_type; + gfc_ref *reference; + + offset = 0; + element_type = &s->symtree->n.sym->ts; + + for (reference = s->ref; reference; reference = reference->next) + switch (reference->type) + { + case REF_ARRAY: + switch (reference->u.ar.type) + { + case AR_FULL: + break; + + case AR_ELEMENT: + a = element_number (&reference->u.ar); + if (element_type->type == BT_CHARACTER) + gfc_conv_const_charlen (element_type->cl); + element_size = + int_size_in_bytes (gfc_typenode_for_spec (element_type)); + offset += a * element_size; + break; + + default: + gfc_error ("bad array reference at %L", &s->where); + } + break; + case REF_SUBSTRING: + if (reference->u.ss.start != NULL) + offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1; + break; + default: + gfc_error ("illegal reference type at %L as EQUIVALENCE object", + &s->where); + } + return offset; +} + + +/* Add a new segment_info structure to the current eq1 is already in the + list at s1, eq2 is not. */ + +static void +new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2) +{ + int offset1, offset2; + segment_info *a; + + offset1 = calculate_offset (eq1->expr); + offset2 = calculate_offset (eq2->expr); + + a = get_segment_info (); + + a->sym = eq2->expr->symtree->n.sym; + a->offset = v->offset + offset1 - offset2; + a->length = calculate_length (eq2->expr->symtree->n.sym); + + a->next = current_segment; + current_segment = a; +} + + +/* Given two equivalence structures that are both already in the list, make + sure that this new condition is not violated, generating an error if it + is. */ + +static void +confirm_condition (segment_info *k, gfc_equiv *eq1, segment_info *e, + gfc_equiv *eq2) +{ + int offset1, offset2; + + offset1 = calculate_offset (eq1->expr); + offset2 = calculate_offset (eq2->expr); + + if (k->offset + offset1 != e->offset + offset2) + gfc_error ("inconsistent equivalence rules involving '%s' at %L and " + "'%s' at %L", k->sym->name, &k->sym->declared_at, + e->sym->name, &e->sym->declared_at); +} + + +/* At this point we have a new equivalence condition to process. If both + variables are already present, then we are confirming that the condition + holds. Otherwise we are adding a new variable to the segment list. */ + +static void +add_condition (gfc_equiv *eq1, gfc_equiv *eq2) +{ + segment_info *n, *t; + + eq1->expr->symtree->n.sym->mark = 1; + eq2->expr->symtree->n.sym->mark = 1; + + eq2->used = 1; + + n = find_segment_info (eq1->expr->symtree->n.sym); + t = find_segment_info (eq2->expr->symtree->n.sym); + + if (n == NULL && t == NULL) + abort (); + if (n != NULL && t == NULL) + new_condition (n, eq1, eq2); + if (n == NULL && t != NULL) + new_condition (t, eq2, eq1); + if (n != NULL && t != NULL) + confirm_condition (n, eq1, t, eq2); +} + + +/* Given a symbol, search through the equivalence lists for an unused + condition that involves the symbol. If a rule is found, we return + nonzero, the rule is marked as used and the eq1 and eq2 pointers point + to the rule. */ + +static int +find_equivalence (gfc_symbol *sym, gfc_equiv **eq1, gfc_equiv **eq2) +{ + gfc_equiv *c, *l; + + for (c = sym->ns->equiv; c; c = c->next) + for (l = c->eq; l; l = l->eq) + { + if (l->used) continue; + + if (c->expr->symtree->n.sym == sym || l->expr->symtree->n.sym == sym) + { + *eq1 = c; + *eq2 = l; + return 1; + } + } + return 0; +} + + +/* Function for adding symbols to current segment. Returns zero if the + segment was modified. Equivalence rules are considered to be between + the first expression in the list and each of the other expressions in + the list. Symbols are scanned multiple times because a symbol can be + equivalenced more than once. */ + +static int +add_equivalences (void) +{ + int segment_modified; + gfc_equiv *eq1, *eq2; + segment_info *f; + + segment_modified = 0; + + for (f = current_segment; f; f = f->next) + if (find_equivalence (f->sym, &eq1, &eq2)) break; + + if (f != NULL) + { + add_condition (eq1, eq2); + segment_modified = 1; + } + + return segment_modified; +} + + +/* Given a seed symbol, create a new segment consisting of that symbol + and all of the symbols equivalenced with that symbol. */ + +static void +new_segment (gfc_symbol *common_sym, gfc_symbol *sym) +{ + segment_info *v; + int length; + + current_segment = get_segment_info (); + current_segment->sym = sym; + current_segment->offset = current_offset; + length = calculate_length (sym); + current_segment->length = length; + + sym->mark = 1; + + /* Add all object directly or indirectly equivalenced with this common + variable. */ + while (add_equivalences ()); + + /* Calculate the storage size to hold the common block. */ + for (v = current_segment; v; v = v->next) + { + if (v->offset < 0) + gfc_error ("the equivalence set for '%s' cause an invalid extension " + "to COMMON '%s' at %L", + sym->name, common_sym->name, &common_sym->declared_at); + if (current_length < (v->offset + v->length)) + current_length = v->offset + v->length; + } + + /* The offset of the next common variable. */ + current_offset += length; + + /* Append the current segment to the current common. */ + v = current_segment; + while (v->next != NULL) + v = v->next; + + v->next = current_common; + current_common = current_segment; + current_segment = NULL; +} + + +/* Create a new block for each merged equivalence list. */ + +static void +finish_equivalences (gfc_namespace *ns) +{ + gfc_equiv *z, *y; + gfc_symbol *sym; + segment_info *v; + int min_offset; + + for (z = ns->equiv; z; z = z->next) + for (y= z->eq; y; y = y->eq) + { + if (y->used) continue; + sym = z->expr->symtree->n.sym; + current_length = 0; + current_segment = get_segment_info (); + current_segment->sym = sym; + current_segment->offset = 0; + current_segment->length = calculate_length (sym); + sym->mark = 1; + + /* All object directly or indrectly equivalenced with this symbol. */ + while (add_equivalences ()); + + /* Calculate the minimal offset. */ + min_offset = 0; + for (v = current_segment; v; v = v->next) + min_offset = (min_offset >= v->offset) ? v->offset : min_offset; + + /* Adjust the offset of each equivalence object, and calculate the + maximal storage size to hold them. */ + for (v = current_segment; v; v = v->next) + { + v->offset -= min_offset; + if (current_length < (v->offset + v->length)) + current_length = v->offset + v->length; + } + + current_common = current_segment; + create_common (NULL); + break; + } +} + + +/* Translate a single common block. */ + +static void +translate_common (gfc_symbol *common_sym, gfc_symbol *var_list) +{ + gfc_symbol *sym; + + current_common = NULL; + current_length = 0; + current_offset = 0; + + /* Mark bits indicate which symbols have already been placed in a + common area. */ + for (sym = var_list; sym; sym = sym->common_next) + sym->mark = 0; + + for (;;) + { + for (sym = var_list; sym; sym = sym->common_next) + if (!sym->mark) break; + + /* All symbols have been placed in a common. */ + if (sym == NULL) break; + new_segment (common_sym, sym); + } + + create_common (common_sym); +} + + +/* Work function for translating a named common block. */ + +static void +named_common (gfc_symbol *s) +{ + if (s->attr.common) + translate_common (s, s->common_head); +} + + +/* Translate the common blocks in a namespace. Unlike other variables, + these have to be created before code, because the backend_decl depends + on the rest of the common block. */ + +void +gfc_trans_common (gfc_namespace *ns) +{ + gfc_symbol *sym; + + /* Translate the blank common block. */ + if (ns->blank_common != NULL) + { + gfc_get_symbol (BLANK_COMMON_NAME, ns, &sym); + translate_common (sym, ns->blank_common); + } + + /* Translate all named common blocks. */ + gfc_traverse_ns (ns, named_common); + + /* Commit the newly created symbols for common blocks. */ + gfc_commit_symbols (); + + /* Translate local equivalence. */ + finish_equivalences (ns); +} diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c new file mode 100644 index 00000000000..a0a72911834 --- /dev/null +++ b/gcc/fortran/trans-const.c @@ -0,0 +1,375 @@ +/* Translation of constants + Copyright (C) 2002, 2003 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* trans-const.c -- convert constant values */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include <stdio.h> +#include "ggc.h" +#include "toplev.h" +#include "real.h" +#include <gmp.h> +#include <assert.h> +#include <math.h> +#include "gfortran.h" +#include "trans.h" +#include "trans-const.h" +#include "trans-types.h" + +/* String constants. */ +tree gfc_strconst_bounds; +tree gfc_strconst_fault; +tree gfc_strconst_wrong_return; +tree gfc_strconst_current_filename; + +tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1]; + +/* Build a constant with given type from an int_cst. */ +tree +gfc_build_const (tree type, tree intval) +{ + tree val; + tree zero; + + switch (TREE_CODE (type)) + { + case INTEGER_TYPE: + val = convert (type, intval); + break; + + case REAL_TYPE: + val = build_real_from_int_cst (type, intval); + break; + + case COMPLEX_TYPE: + val = build_real_from_int_cst (TREE_TYPE (type), intval); + zero = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node); + val = build_complex (type, val, zero); + break; + + default: + abort (); + } + return val; +} + +tree +gfc_build_string_const (int length, const char *s) +{ + tree str; + tree len; + + str = build_string (length, s); + len = build_int_2 (length, 0); + TREE_TYPE (str) = + build_array_type (gfc_character1_type_node, + build_range_type (gfc_strlen_type_node, + integer_one_node, len)); + return str; +} + +/* Return a string constant with the given length. Used for static + initializers. The constant will be padded to the full length. */ +tree +gfc_conv_string_init (tree length, gfc_expr * expr) +{ + char *s; + HOST_WIDE_INT len; + int slen; + tree str; + + assert (expr->expr_type == EXPR_CONSTANT); + assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1); + assert (INTEGER_CST_P (length)); + assert (TREE_INT_CST_HIGH (length) == 0); + + len = TREE_INT_CST_LOW (length); + slen = expr->value.character.length; + assert (len >= slen); + if (len != slen) + { + s = gfc_getmem (len); + memcpy (s, expr->value.character.string, slen); + memset (&s[slen], ' ', len - slen); + str = gfc_build_string_const (len, s); + gfc_free (s); + } + else + str = gfc_build_string_const (len, expr->value.character.string); + + return str; +} + + +/* Create a tree node for the string length if it is constant. */ + +void +gfc_conv_const_charlen (gfc_charlen * cl) +{ + if (cl->backend_decl) + return; + + if (cl->length && cl->length->expr_type == EXPR_CONSTANT) + { + cl->backend_decl = gfc_conv_mpz_to_tree (cl->length->value.integer, + cl->length->ts.kind); + } +} + +void +gfc_init_constants (void) +{ + int n; + + for (n = 0; n <= GFC_MAX_DIMENSIONS; n++) + { + gfc_rank_cst[n] = build_int_2 (n, 0); + TREE_TYPE (gfc_rank_cst[n]) = gfc_array_index_type; + } + + gfc_strconst_bounds = gfc_build_string_const (21, "Array bound mismatch"); + + gfc_strconst_fault = + gfc_build_string_const (30, "Array reference out of bounds"); + + gfc_strconst_wrong_return = + gfc_build_string_const (32, "Incorrect function return value"); + + gfc_strconst_current_filename = + gfc_build_string_const (strlen (gfc_option.source) + 1, + gfc_option.source); +} + +#define BITS_PER_HOST_WIDE_INT (8 * sizeof (HOST_WIDE_INT)) +/* Converts a GMP integer into a backend tree node. */ +tree +gfc_conv_mpz_to_tree (mpz_t i, int kind) +{ + int val; + tree res; + HOST_WIDE_INT high; + unsigned HOST_WIDE_INT low; + int negate; + char buff[10]; + char *p; + char *q; + int n; + + /* TODO: could be wrong if sizeof(HOST_WIDE_INT) |= SIZEOF (int). */ + if (mpz_fits_slong_p (i)) + { + val = mpz_get_si (i); + res = build_int_2 (val, (val < 0) ? (HOST_WIDE_INT)-1 : 0); + TREE_TYPE (res) = gfc_get_int_type (kind); + return (res); + } + + n = mpz_sizeinbase (i, 16); + if (n > 8) + q = gfc_getmem (n + 2); + else + q = buff; + + low = 0; + high = 0; + p = mpz_get_str (q, 16, i); + if (p[0] == '-') + { + negate = 1; + p++; + } + else + negate = 0; + + while (*p) + { + n = *(p++); + if (n >= '0' && n <= '9') + n = n - '0'; + else if (n >= 'a' && n <= 'z') + n = n + 10 - 'a'; + else if (n >= 'A' && n <= 'Z') + n = n + 10 - 'A'; + else + abort (); + + assert (n >= 0 && n < 16); + high = (high << 4) + (low >> (BITS_PER_HOST_WIDE_INT - 4)); + low = (low << 4) + n; + } + res = build_int_2 (low, high); + TREE_TYPE (res) = gfc_get_int_type (kind); + if (negate) + res = fold (build1 (NEGATE_EXPR, TREE_TYPE (res), res)); + + if (q != buff) + gfc_free (q); + + return res; +} + +/* Converts a real constant into backend form. Uses an intermediate string + representation. */ +tree +gfc_conv_mpf_to_tree (mpf_t f, int kind) +{ + tree res; + tree type; + mp_exp_t exp; + char *p; + char *q; + int n; + int edigits; + + for (n = 0; gfc_real_kinds[n].kind != 0; n++) + { + if (gfc_real_kinds[n].kind == kind) + break; + } + assert (gfc_real_kinds[n].kind); + + assert (gfc_real_kinds[n].radix == 2); + + n = MAX (abs (gfc_real_kinds[n].min_exponent), + abs (gfc_real_kinds[n].min_exponent)); +#if 0 + edigits = 2 + (int) (log (n) / log (gfc_real_kinds[n].radix)); +#endif + edigits = 1; + while (n > 0) + { + n = n / 10; + edigits += 3; + } + + + p = mpf_get_str (NULL, &exp, 10, 0, f); + + /* We also have one minus sign, "e", "." and a null terminator. */ + q = (char *) gfc_getmem (strlen (p) + edigits + 4); + + if (p[0]) + { + if (p[0] == '-') + { + strcpy (&q[2], &p[1]); + q[0] = '-'; + q[1] = '.'; + } + else + { + strcpy (&q[1], p); + q[0] = '.'; + } + strcat (q, "e"); + sprintf (&q[strlen (q)], "%d", (int) exp); + } + else + { + strcpy (q, "0"); + } + + type = gfc_get_real_type (kind); + res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type))); + gfc_free (q); + gfc_free (p); + + return res; +} + + +/* Translate any literal constant to a tree. Constants never have + pre or post chains. Character literal constants are special + special because they have a value and a length, so they cannot be + returned as a single tree. It is up to the caller to set the + length somewhere if necessary. + + Returns the translated constant, or aborts if it gets a type it + can't handle. */ + +tree +gfc_conv_constant_to_tree (gfc_expr * expr) +{ + assert (expr->expr_type == EXPR_CONSTANT); + + switch (expr->ts.type) + { + case BT_INTEGER: + return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind); + + case BT_REAL: + return gfc_conv_mpf_to_tree (expr->value.real, expr->ts.kind); + + case BT_LOGICAL: + return build_int_2 (expr->value.logical, 0); + + case BT_COMPLEX: + { + tree real = gfc_conv_mpf_to_tree (expr->value.complex.r, + expr->ts.kind); + tree imag = gfc_conv_mpf_to_tree (expr->value.complex.i, + expr->ts.kind); + + return build_complex (NULL_TREE, real, imag); + } + + case BT_CHARACTER: + return gfc_build_string_const (expr->value.character.length, + expr->value.character.string); + + default: + fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s", + gfc_typename (&expr->ts)); + } +} + + +/* Like gfc_conv_contrant_to_tree, but for a simplified expression. + We can handle character literal constants here as well. */ + +void +gfc_conv_constant (gfc_se * se, gfc_expr * expr) +{ + assert (expr->expr_type == EXPR_CONSTANT); + + if (se->ss != NULL) + { + assert (se->ss != gfc_ss_terminator); + assert (se->ss->type == GFC_SS_SCALAR); + assert (se->ss->expr == expr); + + se->expr = se->ss->data.scalar.expr; + se->string_length = se->ss->data.scalar.string_length; + gfc_advance_se_ss_chain (se); + return; + } + + /* Translate the constant and put it in the simplifier structure. */ + se->expr = gfc_conv_constant_to_tree (expr); + + /* If this is a CHARACTER string, set it's length in the simplifier + structure, too. */ + if (expr->ts.type == BT_CHARACTER) + se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr))); +} diff --git a/gcc/fortran/trans-const.h b/gcc/fortran/trans-const.h new file mode 100644 index 00000000000..a500ddf8f45 --- /dev/null +++ b/gcc/fortran/trans-const.h @@ -0,0 +1,59 @@ +/* Header for code constant translation functions + Copyright (C) 2002, 2003 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Returns an INT_CST. */ +tree gfc_conv_mpz_to_tree (mpz_t, int); + +/* Returns a REAL_CST. */ +tree gfc_conv_mpf_to_tree (mpf_t, int); + +/* Build a tree for a constant. Must be an EXPR_CONSTANT gfc_expr. + For CHARACTER literal constants, the caller still has to set the + string length as a separate operation. */ +tree gfc_conv_constant_to_tree (gfc_expr *); + +/* Like gfc_conv_noncharacter_constant, but works on simplified expression + structures. Also sets the length of CHARACTER strings in the gfc_se. */ +void gfc_conv_constant (gfc_se *, gfc_expr *); + +tree gfc_build_string_const (int, const char *); + +/* Translate a string constant for a static initializer. */ +tree gfc_conv_string_init (tree, gfc_expr *); + +/* Create a tree node for the string length if it is constant. */ +void gfc_conv_const_charlen (gfc_charlen *); + +/* Initialise the nodes for constants. */ +void gfc_init_constants (void); + +/* Build a constant with given type from an int_cst. */ +tree gfc_build_const (tree, tree); + +/* String constants. */ +extern GTY(()) tree gfc_strconst_current_filename; +extern GTY(()) tree gfc_strconst_bounds; +extern GTY(()) tree gfc_strconst_fault; +extern GTY(()) tree gfc_strconst_wrong_return; + +/* Integer constants 0..GFC_MAX_DIMENSIONS. */ +extern GTY(()) tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1]; +#define gfc_index_zero_node gfc_rank_cst[0] diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c new file mode 100644 index 00000000000..79e8cf6927e --- /dev/null +++ b/gcc/fortran/trans-decl.c @@ -0,0 +1,2137 @@ +/* Backend function setup + Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* trans-decl.c -- Handling of backend function and variable decls, etc */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "tree-dump.h" +#include "tree-simple.h" +#include "ggc.h" +#include "toplev.h" +#include "tm.h" +#include "target.h" +#include "function.h" +#include "errors.h" +#include "flags.h" +#include "cgraph.h" +#include <assert.h> +#include "gfortran.h" +#include "trans.h" +#include "trans-types.h" +#include "trans-array.h" +#include "trans-const.h" +/* Only for gfc_trans_code. Shouldn't need to include this. */ +#include "trans-stmt.h" + +#define MAX_LABEL_VALUE 99999 + + +/* Holds the result of the function if no result variable specified. */ + +static GTY(()) tree current_fake_result_decl; + +static GTY(()) tree current_function_return_label; + + +/* Holds the variable DECLs for the current function. */ + +static GTY(()) tree saved_function_decls = NULL_TREE; +static GTY(()) tree saved_parent_function_decls = NULL_TREE; + + +/* The namespace of the module we're currently generating. Only used while + outputting decls for module variables. Do not rely on this being set. */ + +static gfc_namespace *module_namespace; + + +/* List of static constructor functions. */ + +tree gfc_static_ctors; + + +/* Function declarations for builtin library functions. */ + +tree gfor_fndecl_internal_malloc; +tree gfor_fndecl_internal_malloc64; +tree gfor_fndecl_internal_free; +tree gfor_fndecl_allocate; +tree gfor_fndecl_allocate64; +tree gfor_fndecl_deallocate; +tree gfor_fndecl_pause_numeric; +tree gfor_fndecl_pause_string; +tree gfor_fndecl_stop_numeric; +tree gfor_fndecl_stop_string; +tree gfor_fndecl_select_string; +tree gfor_fndecl_runtime_error; +tree gfor_fndecl_in_pack; +tree gfor_fndecl_in_unpack; +tree gfor_fndecl_associated; + + +/* Math functions. Many other math functions are handled in + trans-intrinsic.c. */ + +tree gfor_fndecl_math_powf; +tree gfor_fndecl_math_pow; +tree gfor_fndecl_math_cpowf; +tree gfor_fndecl_math_cpow; +tree gfor_fndecl_math_cabsf; +tree gfor_fndecl_math_cabs; +tree gfor_fndecl_math_sign4; +tree gfor_fndecl_math_sign8; +tree gfor_fndecl_math_ishftc4; +tree gfor_fndecl_math_ishftc8; +tree gfor_fndecl_math_exponent4; +tree gfor_fndecl_math_exponent8; + + +/* String functions. */ + +tree gfor_fndecl_copy_string; +tree gfor_fndecl_compare_string; +tree gfor_fndecl_concat_string; +tree gfor_fndecl_string_len_trim; +tree gfor_fndecl_string_index; +tree gfor_fndecl_string_scan; +tree gfor_fndecl_string_verify; +tree gfor_fndecl_string_trim; +tree gfor_fndecl_string_repeat; +tree gfor_fndecl_adjustl; +tree gfor_fndecl_adjustr; + + +/* Other misc. runtime library functions. */ + +tree gfor_fndecl_size0; +tree gfor_fndecl_size1; + +/* Intrinsic functions implemented in FORTRAN. */ +tree gfor_fndecl_si_kind; +tree gfor_fndecl_sr_kind; + + +static void +gfc_add_decl_to_parent_function (tree decl) +{ + assert (decl); + DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl); + DECL_NONLOCAL (decl) = 1; + TREE_CHAIN (decl) = saved_parent_function_decls; + saved_parent_function_decls = decl; +} + +void +gfc_add_decl_to_function (tree decl) +{ + assert (decl); + TREE_USED (decl) = 1; + DECL_CONTEXT (decl) = current_function_decl; + TREE_CHAIN (decl) = saved_function_decls; + saved_function_decls = decl; +} + + +/* Build a backend label declaration. + Set TREE_USED for named lables. For artificial labels it's up to the + caller to mark the label as used. */ + +tree +gfc_build_label_decl (tree label_id) +{ + /* 2^32 temporaries should be enough. */ + static unsigned int tmp_num = 1; + tree label_decl; + char *label_name; + + if (label_id == NULL_TREE) + { + /* Build an internal label name. */ + ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++); + label_id = get_identifier (label_name); + } + else + label_name = NULL; + + /* Build the LABEL_DECL node. Labels have no type. */ + label_decl = build_decl (LABEL_DECL, label_id, void_type_node); + DECL_CONTEXT (label_decl) = current_function_decl; + DECL_MODE (label_decl) = VOIDmode; + + if (label_name) + { + DECL_ARTIFICIAL (label_decl) = 1; + } + else + { + /* We always define the label as used, even if the original source + file never references the label. We don't want all kinds of + spurious warnings for old-style Fortran code with too many + labels. */ + TREE_USED (label_decl) = 1; + } + + return label_decl; +} + + +/* Returns the return label for the current function. */ + +tree +gfc_get_return_label (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 10]; + + if (current_function_return_label) + return current_function_return_label; + + sprintf (name, "__return_%s", + IDENTIFIER_POINTER (DECL_NAME (current_function_decl))); + + current_function_return_label = + gfc_build_label_decl (get_identifier (name)); + + DECL_ARTIFICIAL (current_function_return_label) = 1; + + return current_function_return_label; +} + + +/* Return the backend label declaration for a given label structure, + or create it if it doesn't exist yet. */ + +tree +gfc_get_label_decl (gfc_st_label * lp) +{ + + if (lp->backend_decl) + return lp->backend_decl; + else + { + char label_name[GFC_MAX_SYMBOL_LEN + 1]; + tree label_decl; + + /* Validate the label declaration from the front end. */ + assert (lp != NULL && lp->value <= MAX_LABEL_VALUE); + + /* Build a mangled name for the label. */ + sprintf (label_name, "__label_%.6d", lp->value); + + /* Build the LABEL_DECL node. */ + label_decl = gfc_build_label_decl (get_identifier (label_name)); + + /* Tell the debugger where the label came from. */ + if (lp->value <= MAX_LABEL_VALUE) /* An internal label */ + { + DECL_SOURCE_LINE (label_decl) = lp->where.line; + DECL_SOURCE_FILE (label_decl) = lp->where.file->filename; + } + else + DECL_ARTIFICIAL (label_decl) = 1; + + /* Store the label in the label list and return the LABEL_DECL. */ + lp->backend_decl = label_decl; + return label_decl; + } +} + + +/* Convert a gfc_symbol to an identifier of the same name. */ + +static tree +gfc_sym_identifier (gfc_symbol * sym) +{ + return (get_identifier (sym->name)); +} + + +/* Construct mangled name from symbol name. */ + +static tree +gfc_sym_mangled_identifier (gfc_symbol * sym) +{ + char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1]; + + if (sym->module[0] == 0) + return gfc_sym_identifier (sym); + else + { + snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name); + return get_identifier (name); + } +} + + +/* Construct mangled function name from symbol name. */ + +static tree +gfc_sym_mangled_function_id (gfc_symbol * sym) +{ + int has_underscore; + char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1]; + + if (sym->module[0] == 0 || sym->attr.proc == PROC_EXTERNAL + || (sym->module[0] != 0 && sym->attr.if_source == IFSRC_IFBODY)) + { + if (strcmp (sym->name, "MAIN__") == 0 + || sym->attr.proc == PROC_INTRINSIC) + return get_identifier (sym->name); + + if (gfc_option.flag_underscoring) + { + has_underscore = strchr (sym->name, '_') != 0; + if (gfc_option.flag_second_underscore && has_underscore) + snprintf (name, sizeof name, "%s__", sym->name); + else + snprintf (name, sizeof name, "%s_", sym->name); + return get_identifier (name); + } + else + return get_identifier (sym->name); + } + else + { + snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name); + return get_identifier (name); + } +} + + +/* Finish processing of a declaration and install its initial value. */ + +static void +gfc_finish_decl (tree decl, tree init) +{ + if (TREE_CODE (decl) == PARM_DECL) + assert (init == NULL_TREE); + /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se + -- it overlaps DECL_ARG_TYPE. */ + else if (init == NULL_TREE) + assert (DECL_INITIAL (decl) == NULL_TREE); + else + assert (DECL_INITIAL (decl) == error_mark_node); + + if (init != NULL_TREE) + { + if (TREE_CODE (decl) != TYPE_DECL) + DECL_INITIAL (decl) = init; + else + { + /* typedef foo = bar; store the type of bar as the type of foo. */ + TREE_TYPE (decl) = TREE_TYPE (init); + DECL_INITIAL (decl) = init = 0; + } + } + + if (TREE_CODE (decl) == VAR_DECL) + { + if (DECL_SIZE (decl) == NULL_TREE + && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE) + layout_decl (decl, 0); + + /* A static variable with an incomplete type is an error if it is + initialized. Also if it is not file scope. Otherwise, let it + through, but if it is not `extern' then it may cause an error + message later. */ + /* An automatic variable with an incomplete type is an error. */ + if (DECL_SIZE (decl) == NULL_TREE + && (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0 + || DECL_CONTEXT (decl) != 0) + : !DECL_EXTERNAL (decl))) + { + gfc_fatal_error ("storage size not known"); + } + + if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl)) + && (DECL_SIZE (decl) != 0) + && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST)) + { + gfc_fatal_error ("storage size not constant"); + } + } + +} + + +/* Apply symbol attributes to a variable, and add it to the function scope. */ + +static void +gfc_finish_var_decl (tree decl, gfc_symbol * sym) +{ + /* TREE_ADDRESSABLE means the address of this variable is acualy needed. + This is the equivalent of the TARGET variables. + We also need to set this if the variable is passed by reference in a + CALL statement. */ + if (sym->attr.target) + TREE_ADDRESSABLE (decl) = 1; + /* If it wasn't used we wouldn't be getting it. */ + TREE_USED (decl) = 1; + + /* Chain this decl to the pending declarations. Don't do pushdecl() + because this would add them to the current scope rather than the + function scope. */ + if (current_function_decl != NULL_TREE) + { + if (sym->ns->proc_name->backend_decl == current_function_decl) + gfc_add_decl_to_function (decl); + else + gfc_add_decl_to_parent_function (decl); + } + + /* If a variable is USE associated, it's always external. */ + if (sym->attr.use_assoc) + { + DECL_EXTERNAL (decl) = 1; + TREE_PUBLIC (decl) = 1; + } + else if (sym->module[0] && !sym->attr.result) + { + /* TODO: Don't set sym->module for result variables. */ + assert (current_function_decl == NULL_TREE); + /* This is the declaration of a module variable. */ + TREE_PUBLIC (decl) = 1; + TREE_STATIC (decl) = 1; + } + + if ((sym->attr.save || sym->attr.data || sym->value) + && !sym->attr.use_assoc) + TREE_STATIC (decl) = 1; + + /* Keep variables larger than max-stack-var-size off stack. */ + if (!sym->ns->proc_name->attr.recursive + && INTEGER_CST_P (DECL_SIZE_UNIT (decl)) + && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))) + TREE_STATIC (decl) = 1; +} + + +/* Allocate the lang-specific part of a decl. */ + +void +gfc_allocate_lang_decl (tree decl) +{ + DECL_LANG_SPECIFIC (decl) = (struct lang_decl *) + ggc_alloc_cleared (sizeof (struct lang_decl)); +} + +/* Remember a symbol to generate initialization/cleanup code at function + entry/exit. */ + +static void +gfc_defer_symbol_init (gfc_symbol * sym) +{ + gfc_symbol *p; + gfc_symbol *last; + gfc_symbol *head; + + /* Don't add a symbol twice. */ + if (sym->tlink) + return; + + last = head = sym->ns->proc_name; + p = last->tlink; + + /* Make sure that setup code for dummy variables which are used in the + setup of other variables is generated first. */ + if (sym->attr.dummy) + { + /* Find the first dummy arg seen after us, or the first non-dummy arg. + This is a circular list, so don't go past the head. */ + while (p != head + && (!p->attr.dummy || p->dummy_order > sym->dummy_order)) + { + last = p; + p = p->tlink; + } + } + /* Insert in between last and p. */ + last->tlink = sym; + sym->tlink = p; +} + + +/* Create an array index type variable with function scope. */ + +static tree +create_index_var (const char * pfx, int nest) +{ + tree decl; + + decl = gfc_create_var_np (gfc_array_index_type, pfx); + if (nest) + gfc_add_decl_to_parent_function (decl); + else + gfc_add_decl_to_function (decl); + return decl; +} + + +/* Create variables to hold all the non-constant bits of info for a + descriptorless array. Remember these in the lang-specific part of the + type. */ + +static void +gfc_build_qualified_array (tree decl, gfc_symbol * sym) +{ + tree type; + int dim; + int nest; + + type = TREE_TYPE (decl); + + /* We just use the descriptor, if there is one. */ + if (GFC_DESCRIPTOR_TYPE_P (type)) + return; + + assert (GFC_ARRAY_TYPE_P (type)); + nest = (sym->ns->proc_name->backend_decl != current_function_decl) + && !sym->attr.contained; + + for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++) + { + if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE) + GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest); + /* Don't try to use the unkown bound for assumed shape arrays. */ + if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE + && (sym->as->type != AS_ASSUMED_SIZE + || dim < GFC_TYPE_ARRAY_RANK (type) - 1)) + GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest); + + if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE) + GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest); + } + if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE) + { + GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type, + "offset"); + if (nest) + gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type)); + else + gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type)); + } +} + + +/* For some dummy arguments we don't use the actual argument directly. + Instead we create a local decl and use that. This allows us to preform + initialization, and construct full type information. */ + +static tree +gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) +{ + tree decl; + tree type; + gfc_array_spec *as; + char *name; + int packed; + int n; + bool known_size; + + if (sym->attr.pointer || sym->attr.allocatable) + return dummy; + + /* Add to list of variables if not a fake result variable. */ + if (sym->attr.result || sym->attr.dummy) + gfc_defer_symbol_init (sym); + + type = TREE_TYPE (dummy); + assert (TREE_CODE (dummy) == PARM_DECL + && POINTER_TYPE_P (type)); + + /* Do we know the element size. */ + known_size = sym->ts.type != BT_CHARACTER + || INTEGER_CST_P (sym->ts.cl->backend_decl); + + if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type))) + { + /* For descriptorless arrays with known element size the actual + argument is sufficient. */ + assert (GFC_ARRAY_TYPE_P (type)); + gfc_build_qualified_array (dummy, sym); + return dummy; + } + + type = TREE_TYPE (type); + if (GFC_DESCRIPTOR_TYPE_P (type)) + { + /* Create a decriptorless array pointer. */ + as = sym->as; + packed = 0; + if (!gfc_option.flag_repack_arrays) + { + if (as->type == AS_ASSUMED_SIZE) + packed = 2; + } + else + { + if (as->type == AS_EXPLICIT) + { + packed = 2; + for (n = 0; n < as->rank; n++) + { + if (!(as->upper[n] + && as->lower[n] + && as->upper[n]->expr_type == EXPR_CONSTANT + && as->lower[n]->expr_type == EXPR_CONSTANT)) + packed = 1; + } + } + else + packed = 1; + } + + type = gfc_typenode_for_spec (&sym->ts); + type = gfc_get_nodesc_array_type (type, sym->as, packed); + } + else + { + /* We now have an expression for the element size, so create a fully + qualified type. Reset sym->backend decl or this will just return the + old type. */ + sym->backend_decl = NULL_TREE; + type = gfc_sym_type (sym); + packed = 2; + } + + ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0); + decl = build_decl (VAR_DECL, get_identifier (name), type); + + DECL_ARTIFICIAL (decl) = 1; + TREE_PUBLIC (decl) = 0; + TREE_STATIC (decl) = 0; + DECL_EXTERNAL (decl) = 0; + + /* We should never get deferred shape arrays here. We used to because of + frontend bugs. */ + assert (sym->as->type != AS_DEFERRED); + + switch (packed) + { + case 1: + GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1; + break; + + case 2: + GFC_DECL_PACKED_ARRAY (decl) = 1; + break; + } + + gfc_build_qualified_array (decl, sym); + + if (DECL_LANG_SPECIFIC (dummy)) + DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy); + else + gfc_allocate_lang_decl (decl); + + GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy; + + if (sym->ns->proc_name->backend_decl == current_function_decl + || sym->attr.contained) + gfc_add_decl_to_function (decl); + else + gfc_add_decl_to_parent_function (decl); + + return decl; +} + + +/* Return a constant or a variable to use as a string length. Does not + add the decl to the current scope. */ + +static tree +gfc_create_string_length (gfc_symbol * sym) +{ + tree length; + + assert (sym->ts.cl); + gfc_conv_const_charlen (sym->ts.cl); + + if (sym->ts.cl->backend_decl == NULL_TREE) + { + char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2]; + + /* Also prefix the mangled name. */ + strcpy (&name[1], sym->name); + name[0] = '.'; + length = build_decl (VAR_DECL, get_identifier (name), + gfc_strlen_type_node); + DECL_ARTIFICIAL (length) = 1; + TREE_USED (length) = 1; + gfc_defer_symbol_init (sym); + sym->ts.cl->backend_decl = length; + } + + return sym->ts.cl->backend_decl; +} + + +/* Return the decl for a gfc_symbol, create it if it doesn't already + exist. */ + +tree +gfc_get_symbol_decl (gfc_symbol * sym) +{ + tree decl; + tree length = NULL_TREE; + gfc_se se; + int byref; + + assert (sym->attr.referenced); + + if (sym->ns && sym->ns->proc_name->attr.function) + byref = gfc_return_by_reference (sym->ns->proc_name); + else + byref = 0; + + if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref)) + { + /* Return via extra parameter. */ + if (sym->attr.result && byref + && !sym->backend_decl) + { + sym->backend_decl = + DECL_ARGUMENTS (sym->ns->proc_name->backend_decl); + } + + /* Dummy variables should already have been created. */ + assert (sym->backend_decl); + + /* Create a character length variable. */ + if (sym->ts.type == BT_CHARACTER) + { + if (sym->ts.cl->backend_decl == NULL_TREE) + { + length = gfc_create_string_length (sym); + if (TREE_CODE (length) != INTEGER_CST) + { + gfc_finish_var_decl (length, sym); + gfc_defer_symbol_init (sym); + } + } + } + + /* Use a copy of the descriptor for dummy arrays. */ + if (sym->attr.dimension && !TREE_USED (sym->backend_decl)) + { + sym->backend_decl = + gfc_build_dummy_array_decl (sym, sym->backend_decl); + } + + TREE_USED (sym->backend_decl) = 1; + return sym->backend_decl; + } + + if (sym->backend_decl) + return sym->backend_decl; + + if (sym->attr.entry) + gfc_todo_error ("alternate entry"); + + /* Catch function declarations. Only used for actual parameters. */ + if (sym->attr.flavor == FL_PROCEDURE) + { + decl = gfc_get_extern_function_decl (sym); + return decl; + } + + if (sym->attr.intrinsic) + internal_error ("intrinsic variable which isn't a procedure"); + + /* Create string length decl first so that they can be used in the + type declaration. */ + if (sym->ts.type == BT_CHARACTER) + length = gfc_create_string_length (sym); + + /* Create the decl for the variable. */ + decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym)); + + /* Symbols from modules have its assembler name should be mangled. + This is done here rather than in gfc_finish_var_decl because it + is different for string length variables. */ + if (sym->module[0]) + SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym)); + + if (sym->attr.dimension) + { + /* Create variables to hold the non-constant bits of array info. */ + gfc_build_qualified_array (decl, sym); + + /* Remember this variable for allocation/cleanup. */ + gfc_defer_symbol_init (sym); + + if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer) + GFC_DECL_PACKED_ARRAY (decl) = 1; + } + + gfc_finish_var_decl (decl, sym); + + if (sym->attr.assign) + { + gfc_allocate_lang_decl (decl); + GFC_DECL_ASSIGN (decl) = 1; + length = gfc_create_var (gfc_strlen_type_node, sym->name); + GFC_DECL_STRING_LEN (decl) = length; + GFC_DECL_ASSIGN_ADDR (decl) = gfc_create_var (pvoid_type_node, sym->name); + /* TODO: Need to check we don't change TREE_STATIC (decl) later. */ + TREE_STATIC (length) = TREE_STATIC (decl); + /* STRING_LENGTH is also used as flag. Less than -1 means that + ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the + target label's address. Other value is the length of format string + and ASSIGN_ADDR is the address of format string. */ + DECL_INITIAL (length) = build_int_2 (-2, -1); + } + + /* TODO: Initialization of pointer variables. */ + switch (sym->ts.type) + { + case BT_CHARACTER: + /* Character variables need special handling. */ + gfc_allocate_lang_decl (decl); + + if (TREE_CODE (length) == INTEGER_CST) + { + /* Static initializer for string scalars. + Initialization of string arrays is handled elsewhere. */ + if (sym->value && sym->attr.dimension == 0) + { + assert (TREE_STATIC (decl)); + if (sym->attr.pointer) + gfc_todo_error ("initialization of character pointers"); + DECL_INITIAL (decl) = gfc_conv_string_init (length, sym->value); + } + } + else + { + char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2]; + + if (sym->module[0]) + { + /* Also prefix the mangled name for symbols from modules. */ + strcpy (&name[1], sym->name); + name[0] = '.'; + strcpy (&name[1], + IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length))); + SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name)); + } + gfc_finish_var_decl (length, sym); + assert (!sym->value); + } + break; + + case BT_DERIVED: + if (sym->value && ! (sym->attr.use_assoc || sym->attr.dimension)) + { + gfc_init_se (&se, NULL); + gfc_conv_structure (&se, sym->value, 1); + DECL_INITIAL (decl) = se.expr; + } + break; + + default: + /* Static initializers for SAVEd variables. Arrays have already been + remembered. Module variables are initialized when the module is + loaded. */ + if (sym->value && ! (sym->attr.use_assoc || sym->attr.dimension)) + { + assert (TREE_STATIC (decl)); + gfc_init_se (&se, NULL); + gfc_conv_constant (&se, sym->value); + DECL_INITIAL (decl) = se.expr; + } + break; + } + sym->backend_decl = decl; + + return decl; +} + + +/* Get a basic decl for an external function. */ + +tree +gfc_get_extern_function_decl (gfc_symbol * sym) +{ + tree type; + tree fndecl; + gfc_expr e; + gfc_intrinsic_sym *isym; + gfc_expr argexpr; + char s[GFC_MAX_SYMBOL_LEN]; + tree name; + tree mangled_name; + + if (sym->backend_decl) + return sym->backend_decl; + + if (sym->attr.intrinsic) + { + /* Call the resolution function to get the actual name. This is + a nasty hack which relies on the resolution functions only looking + at the first argument. We pass NULL for the second argument + otherwise things like AINT get confused. */ + isym = gfc_find_function (sym->name); + assert (isym->resolve.f0 != NULL); + + memset (&e, 0, sizeof (e)); + e.expr_type = EXPR_FUNCTION; + + memset (&argexpr, 0, sizeof (argexpr)); + assert (isym->formal); + argexpr.ts = isym->formal->ts; + + if (isym->formal->next == NULL) + isym->resolve.f1 (&e, &argexpr); + else + { + /* All specific intrinsics take one or two arguments. */ + assert (isym->formal->next->next == NULL); + isym->resolve.f2 (&e, &argexpr, NULL); + } + sprintf (s, "specific%s", e.value.function.name); + name = get_identifier (s); + mangled_name = name; + } + else + { + name = gfc_sym_identifier (sym); + mangled_name = gfc_sym_mangled_function_id (sym); + } + + type = gfc_get_function_type (sym); + fndecl = build_decl (FUNCTION_DECL, name, type); + + SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name); + /* If the return type is a pointer, avoid alias issues by setting + DECL_IS_MALLOC to nonzero. This means that the function should be + treated as if it were a malloc, meaning it returns a pointer that + is not an alias. */ + if (POINTER_TYPE_P (type)) + DECL_IS_MALLOC (fndecl) = 1; + + /* Set the context of this decl. */ + if (0 && sym->ns && sym->ns->proc_name) + { + /* TODO: Add external decls to the appropriate scope. */ + DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl; + } + else + { + /* Global declaration, eg. intrinsic subroutine. */ + DECL_CONTEXT (fndecl) = NULL_TREE; + } + + DECL_EXTERNAL (fndecl) = 1; + + /* This specifies if a function is globaly addressable, ie. it is + the opposite of declaring static in C. */ + TREE_PUBLIC (fndecl) = 1; + + /* Set attributes for PURE functions. A call to PURE function in the + Fortran 95 sense is both pure and without side effects in the C + sense. */ + if (sym->attr.pure || sym->attr.elemental) + { + DECL_IS_PURE (fndecl) = 1; +/* TODO: check if pure/elemental procedures can have INTENT(OUT) parameters. + TREE_SIDE_EFFECTS (fndecl) = 0;*/ + } + + sym->backend_decl = fndecl; + + if (DECL_CONTEXT (fndecl) == NULL_TREE) + pushdecl_top_level (fndecl); + + return fndecl; +} + + +/* Create a declaration for a procedure. For external functions (in the C + sense) use gfc_get_extern_function_decl. */ + +void +gfc_build_function_decl (gfc_symbol * sym) +{ + tree fndecl, type, result_decl, typelist, arglist; + tree length; + symbol_attribute attr; + gfc_formal_arglist *f; + + assert (!sym->backend_decl); + assert (!sym->attr.external); + + /* Allow only one nesting level. Allow public declarations. */ + assert (current_function_decl == NULL_TREE + || DECL_CONTEXT (current_function_decl) == NULL_TREE); + + type = gfc_get_function_type (sym); + fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type); + + /* Perform name mangling if this is a top level or module procedure. */ + if (current_function_decl == NULL_TREE) + SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym)); + + /* Figure out the return type of the declared function, and build a + RESULT_DECL for it. If this is subroutine with alternate + returns, build a RESULT_DECL for it. */ + attr = sym->attr; + + result_decl = NULL_TREE; + /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */ + if (attr.function) + { + if (gfc_return_by_reference (sym)) + type = void_type_node; + else + { + if (sym->result != sym) + result_decl = gfc_sym_identifier (sym->result); + + type = TREE_TYPE (TREE_TYPE (fndecl)); + } + } + else + { + /* Look for alternate return placeholders. */ + int has_alternate_returns = 0; + for (f = sym->formal; f; f = f->next) + { + if (f->sym == NULL) + { + has_alternate_returns = 1; + break; + } + } + + if (has_alternate_returns) + type = integer_type_node; + else + type = void_type_node; + } + + result_decl = build_decl (RESULT_DECL, result_decl, type); + DECL_CONTEXT (result_decl) = fndecl; + DECL_RESULT (fndecl) = result_decl; + + /* Don't call layout_decl for a RESULT_DECL. + layout_decl (result_decl, 0); */ + + /* If the return type is a pointer, avoid alias issues by setting + DECL_IS_MALLOC to nonzero. This means that the function should be + treated as if it were a malloc, meaning it returns a pointer that + is not an alias. */ + if (POINTER_TYPE_P (type)) + DECL_IS_MALLOC (fndecl) = 1; + + /* Set up all attributes for the function. */ + DECL_CONTEXT (fndecl) = current_function_decl; + DECL_EXTERNAL (fndecl) = 0; + + /* This specifies if a function is globaly addressable, ie. it is + the opposite of decalring static in C. */ + if (DECL_CONTEXT (fndecl) == NULL_TREE || attr.external) + TREE_PUBLIC (fndecl) = 1; + + /* TREE_STATIC means the function body is defined here. */ + if (!attr.external) + TREE_STATIC (fndecl) = 1; + + /* Set attributes for PURE functions. A call to PURE function in the + Fortran 95 sense is both pure and without side effects in the C + sense. */ + if (attr.pure || attr.elemental) + { + DECL_IS_PURE (fndecl) = 1; + TREE_SIDE_EFFECTS (fndecl) = 0; + } + + /* Layout the function declaration and put it in the binding level + of the current function. */ + if (!attr.external) + { + tree parm; + + pushdecl (fndecl); + /* Build formal argument list. Make sure that their TREE_CONTEXT is + the new FUNCTION_DECL node. */ + current_function_decl = fndecl; + arglist = NULL_TREE; + typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl)); + if (gfc_return_by_reference (sym)) + { + type = TREE_VALUE (typelist); + parm = build_decl (PARM_DECL, get_identifier ("__result"), type); + + DECL_CONTEXT (parm) = fndecl; + DECL_ARG_TYPE (parm) = type; + TREE_READONLY (parm) = 1; + gfc_finish_decl (parm, NULL_TREE); + + arglist = chainon (arglist, parm); + typelist = TREE_CHAIN (typelist); + + if (sym->ts.type == BT_CHARACTER) + { + gfc_allocate_lang_decl (parm); + + /* Length of character result */ + type = TREE_VALUE (typelist); + assert (type == gfc_strlen_type_node); + + length = build_decl (PARM_DECL, + get_identifier (".__result"), + type); + if (!sym->ts.cl->length) + { + sym->ts.cl->backend_decl = length; + TREE_USED (length) = 1; + } + assert (TREE_CODE (length) == PARM_DECL); + arglist = chainon (arglist, length); + typelist = TREE_CHAIN (typelist); + DECL_CONTEXT (length) = fndecl; + DECL_ARG_TYPE (length) = type; + TREE_READONLY (length) = 1; + gfc_finish_decl (length, NULL_TREE); + } + } + + for (f = sym->formal; f; f = f->next) + { + if (f->sym != NULL) /* ignore alternate returns. */ + { + length = NULL_TREE; + + type = TREE_VALUE (typelist); + + /* Build a the argument declaration. */ + parm = build_decl (PARM_DECL, + gfc_sym_identifier (f->sym), type); + + /* Fill in arg stuff. */ + DECL_CONTEXT (parm) = fndecl; + DECL_ARG_TYPE (parm) = type; + DECL_ARG_TYPE_AS_WRITTEN (parm) = type; + /* All implementation args are read-only. */ + TREE_READONLY (parm) = 1; + + gfc_finish_decl (parm, NULL_TREE); + + f->sym->backend_decl = parm; + + arglist = chainon (arglist, parm); + typelist = TREE_CHAIN (typelist); + } + } + + /* Add the hidden string length parameters. */ + parm = arglist; + for (f = sym->formal; f; f = f->next) + { + char name[GFC_MAX_SYMBOL_LEN + 2]; + /* Ignore alternate returns. */ + if (f->sym == NULL) + continue; + + if (f->sym->ts.type != BT_CHARACTER) + continue; + + parm = f->sym->backend_decl; + type = TREE_VALUE (typelist); + assert (type == gfc_strlen_type_node); + + strcpy (&name[1], f->sym->name); + name[0] = '_'; + length = build_decl (PARM_DECL, get_identifier (name), type); + + arglist = chainon (arglist, length); + DECL_CONTEXT (length) = fndecl; + DECL_ARG_TYPE (length) = type; + TREE_READONLY (length) = 1; + gfc_finish_decl (length, NULL_TREE); + + /* TODO: Check string lengths when -fbounds-check. */ + + /* Use the passed value for assumed length variables. */ + if (!f->sym->ts.cl->length) + { + TREE_USED (length) = 1; + f->sym->ts.cl->backend_decl = length; + } + + parm = TREE_CHAIN (parm); + typelist = TREE_CHAIN (typelist); + } + + assert (TREE_VALUE (typelist) == void_type_node); + DECL_ARGUMENTS (fndecl) = arglist; + + /* Restore the old context. */ + current_function_decl = DECL_CONTEXT (fndecl); + } + sym->backend_decl = fndecl; +} + + +/* Return the decl used to hold the function return value. */ + +tree +gfc_get_fake_result_decl (gfc_symbol * sym) +{ + tree decl; + tree length; + + char name[GFC_MAX_SYMBOL_LEN + 10]; + + if (current_fake_result_decl != NULL_TREE) + return current_fake_result_decl; + + /* Only when gfc_get_fake_result_decl is called by gfc_trans_return, + sym is NULL. */ + if (!sym) + return NULL_TREE; + + if (sym->ts.type == BT_CHARACTER + && !sym->ts.cl->backend_decl) + { + length = gfc_create_string_length (sym); + gfc_finish_var_decl (length, sym); + } + + if (gfc_return_by_reference (sym)) + { + decl = DECL_ARGUMENTS (sym->backend_decl); + + TREE_USED (decl) = 1; + if (sym->as) + decl = gfc_build_dummy_array_decl (sym, decl); + } + else + { + sprintf (name, "__result_%.20s", + IDENTIFIER_POINTER (DECL_NAME (current_function_decl))); + + decl = build_decl (VAR_DECL, get_identifier (name), + TREE_TYPE (TREE_TYPE (current_function_decl))); + + DECL_ARTIFICIAL (decl) = 1; + DECL_EXTERNAL (decl) = 0; + TREE_PUBLIC (decl) = 0; + TREE_USED (decl) = 1; + + layout_decl (decl, 0); + + gfc_add_decl_to_function (decl); + } + + current_fake_result_decl = decl; + + return decl; +} + + +/* Builds a function decl. The remaining parameters are the types of the + function arguments. Negative nargs indicates a varargs function. */ + +tree +gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...) +{ + tree arglist; + tree argtype; + tree fntype; + tree fndecl; + va_list p; + int n; + + /* Library functions must be declared with global scope. */ + assert (current_function_decl == NULL_TREE); + + va_start (p, nargs); + + + /* Create a list of the argument types. */ + for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--) + { + argtype = va_arg (p, tree); + arglist = gfc_chainon_list (arglist, argtype); + } + + if (nargs >= 0) + { + /* Terminate the list. */ + arglist = gfc_chainon_list (arglist, void_type_node); + } + + /* Build the function type and decl. */ + fntype = build_function_type (rettype, arglist); + fndecl = build_decl (FUNCTION_DECL, name, fntype); + + /* Mark this decl as external. */ + DECL_EXTERNAL (fndecl) = 1; + TREE_PUBLIC (fndecl) = 1; + + va_end (p); + + pushdecl (fndecl); + + rest_of_decl_compilation (fndecl, NULL, 1, 0); + + return fndecl; +} + +static void +gfc_build_intrinsic_function_decls (void) +{ + /* String functions. */ + gfor_fndecl_copy_string = + gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")), + void_type_node, + 4, + gfc_strlen_type_node, pchar_type_node, + gfc_strlen_type_node, pchar_type_node); + + gfor_fndecl_compare_string = + gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")), + gfc_int4_type_node, + 4, + gfc_strlen_type_node, pchar_type_node, + gfc_strlen_type_node, pchar_type_node); + + gfor_fndecl_concat_string = + gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")), + void_type_node, + 6, + gfc_strlen_type_node, pchar_type_node, + gfc_strlen_type_node, pchar_type_node, + gfc_strlen_type_node, pchar_type_node); + + gfor_fndecl_string_len_trim = + gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")), + gfc_int4_type_node, + 2, gfc_strlen_type_node, + pchar_type_node); + + gfor_fndecl_string_index = + gfc_build_library_function_decl (get_identifier (PREFIX("string_index")), + gfc_int4_type_node, + 5, gfc_strlen_type_node, pchar_type_node, + gfc_strlen_type_node, pchar_type_node, + gfc_logical4_type_node); + + gfor_fndecl_string_scan = + gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")), + gfc_int4_type_node, + 5, gfc_strlen_type_node, pchar_type_node, + gfc_strlen_type_node, pchar_type_node, + gfc_logical4_type_node); + + gfor_fndecl_string_verify = + gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")), + gfc_int4_type_node, + 5, gfc_strlen_type_node, pchar_type_node, + gfc_strlen_type_node, pchar_type_node, + gfc_logical4_type_node); + + gfor_fndecl_string_trim = + gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")), + void_type_node, + 4, + build_pointer_type (gfc_strlen_type_node), + ppvoid_type_node, + gfc_strlen_type_node, + pchar_type_node); + + gfor_fndecl_string_repeat = + gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")), + void_type_node, + 4, + pchar_type_node, + gfc_strlen_type_node, + pchar_type_node, + gfc_int4_type_node); + + gfor_fndecl_adjustl = + gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")), + void_type_node, + 3, + pchar_type_node, + gfc_strlen_type_node, pchar_type_node); + + gfor_fndecl_adjustr = + gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")), + void_type_node, + 3, + pchar_type_node, + gfc_strlen_type_node, pchar_type_node); + + gfor_fndecl_si_kind = + gfc_build_library_function_decl (get_identifier ("selected_int_kind"), + gfc_int4_type_node, + 1, + pvoid_type_node); + + gfor_fndecl_sr_kind = + gfc_build_library_function_decl (get_identifier ("selected_real_kind"), + gfc_int4_type_node, + 2, pvoid_type_node, + pvoid_type_node); + + + /* Power functions. */ + gfor_fndecl_math_powf = + gfc_build_library_function_decl (get_identifier ("powf"), + gfc_real4_type_node, + 1, gfc_real4_type_node); + gfor_fndecl_math_pow = + gfc_build_library_function_decl (get_identifier ("pow"), + gfc_real8_type_node, + 1, gfc_real8_type_node); + gfor_fndecl_math_cpowf = + gfc_build_library_function_decl (get_identifier ("cpowf"), + gfc_complex4_type_node, + 1, gfc_complex4_type_node); + gfor_fndecl_math_cpow = + gfc_build_library_function_decl (get_identifier ("cpow"), + gfc_complex8_type_node, + 1, gfc_complex8_type_node); + gfor_fndecl_math_cabsf = + gfc_build_library_function_decl (get_identifier ("cabsf"), + gfc_real4_type_node, + 1, gfc_complex4_type_node); + gfor_fndecl_math_cabs = + gfc_build_library_function_decl (get_identifier ("cabs"), + gfc_real8_type_node, + 1, gfc_complex8_type_node); + gfor_fndecl_math_sign4 = + gfc_build_library_function_decl (get_identifier ("copysignf"), + gfc_real4_type_node, + 1, gfc_real4_type_node); + gfor_fndecl_math_sign8 = + gfc_build_library_function_decl (get_identifier ("copysign"), + gfc_real8_type_node, + 1, gfc_real8_type_node); + gfor_fndecl_math_ishftc4 = + gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")), + gfc_int4_type_node, + 3, gfc_int4_type_node, + gfc_int4_type_node, gfc_int4_type_node); + gfor_fndecl_math_ishftc8 = + gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")), + gfc_int8_type_node, + 3, gfc_int8_type_node, + gfc_int8_type_node, gfc_int8_type_node); + gfor_fndecl_math_exponent4 = + gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")), + gfc_int4_type_node, + 1, gfc_real4_type_node); + gfor_fndecl_math_exponent8 = + gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")), + gfc_int4_type_node, + 1, gfc_real8_type_node); + + /* Other functions. */ + gfor_fndecl_size0 = + gfc_build_library_function_decl (get_identifier (PREFIX("size0")), + gfc_array_index_type, + 1, pvoid_type_node); + gfor_fndecl_size1 = + gfc_build_library_function_decl (get_identifier (PREFIX("size1")), + gfc_array_index_type, + 2, pvoid_type_node, + gfc_array_index_type); +} + + +/* Make prototypes for runtime library functions. */ + +void +gfc_build_builtin_function_decls (void) +{ + gfor_fndecl_internal_malloc = + gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")), + pvoid_type_node, 1, gfc_int4_type_node); + + gfor_fndecl_internal_malloc64 = + gfc_build_library_function_decl (get_identifier + (PREFIX("internal_malloc64")), + pvoid_type_node, 1, gfc_int8_type_node); + + gfor_fndecl_internal_free = + gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")), + void_type_node, 1, pvoid_type_node); + + gfor_fndecl_allocate = + gfc_build_library_function_decl (get_identifier (PREFIX("allocate")), + void_type_node, 2, ppvoid_type_node, + gfc_int4_type_node); + + gfor_fndecl_allocate64 = + gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")), + void_type_node, 2, ppvoid_type_node, + gfc_int8_type_node); + + gfor_fndecl_deallocate = + gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")), + void_type_node, 1, ppvoid_type_node); + + gfor_fndecl_stop_numeric = + gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")), + void_type_node, 1, gfc_int4_type_node); + + gfor_fndecl_stop_string = + gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")), + void_type_node, 2, pchar_type_node, + gfc_int4_type_node); + + gfor_fndecl_pause_numeric = + gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")), + void_type_node, 1, gfc_int4_type_node); + + gfor_fndecl_pause_string = + gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")), + void_type_node, 2, pchar_type_node, + gfc_int4_type_node); + + gfor_fndecl_select_string = + gfc_build_library_function_decl (get_identifier (PREFIX("select_string")), + pvoid_type_node, 0); + + gfor_fndecl_runtime_error = + gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")), + void_type_node, + 3, + pchar_type_node, pchar_type_node, + gfc_int4_type_node); + + gfor_fndecl_in_pack = gfc_build_library_function_decl ( + get_identifier (PREFIX("internal_pack")), + pvoid_type_node, 1, pvoid_type_node); + + gfor_fndecl_in_unpack = gfc_build_library_function_decl ( + get_identifier (PREFIX("internal_unpack")), + pvoid_type_node, 1, pvoid_type_node); + + gfor_fndecl_associated = + gfc_build_library_function_decl ( + get_identifier (PREFIX("associated")), + gfc_logical4_type_node, + 2, + ppvoid_type_node, + ppvoid_type_node); + + gfc_build_intrinsic_function_decls (); + gfc_build_intrinsic_lib_fndecls (); + gfc_build_io_library_fndecls (); +} + + +/* Exaluate the length of dummy character variables. */ + +static tree +gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody) +{ + stmtblock_t body; + + gfc_finish_decl (cl->backend_decl, NULL_TREE); + + gfc_start_block (&body); + + /* Evaluate the string length expression. */ + gfc_trans_init_string_length (cl, &body); + + gfc_add_expr_to_block (&body, fnbody); + return gfc_finish_block (&body); +} + + +/* Allocate and cleanup an automatic character variable. */ + +static tree +gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody) +{ + stmtblock_t body; + tree decl; + tree args; + tree tmp; + + assert (sym->backend_decl); + assert (sym->ts.cl && sym->ts.cl->length); + + gfc_start_block (&body); + + /* Evaluate the string length expression. */ + gfc_trans_init_string_length (sym->ts.cl, &body); + + decl = sym->backend_decl; + + DECL_DEFER_OUTPUT (decl) = 1; + + /* Generate code to allocate the automatic variable. It will be freed + automatically. */ + tmp = gfc_build_addr_expr (NULL, decl); + args = gfc_chainon_list (NULL_TREE, tmp); + args = gfc_chainon_list (args, sym->ts.cl->backend_decl); + tmp = gfc_build_function_call (built_in_decls[BUILT_IN_STACK_ALLOC], args); + gfc_add_expr_to_block (&body, tmp); + gfc_add_expr_to_block (&body, fnbody); + return gfc_finish_block (&body); +} + + +/* Generate function entry and exit code, and add it to the function body. + This includes: + Allocation and initialisation of array variables. + Allocation of character string variables. + Initialization and possibly repacking of dummy arrays. */ + +static tree +gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody) +{ + locus loc; + gfc_symbol *sym; + + /* Deal with implicit return variables. Explicit return variables will + already have been added. */ + if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym) + { + if (!current_fake_result_decl) + { + warning ("Function does not return a value"); + return fnbody; + } + + if (proc_sym->as) + { + fnbody = gfc_trans_dummy_array_bias (proc_sym, + current_fake_result_decl, + fnbody); + } + else if (proc_sym->ts.type == BT_CHARACTER) + { + if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL) + fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody); + } + else + gfc_todo_error ("Deferred non-array return by reference"); + } + + for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink) + { + if (sym->attr.dimension) + { + switch (sym->as->type) + { + case AS_EXPLICIT: + if (sym->attr.dummy || sym->attr.result) + fnbody = + gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody); + else if (sym->attr.pointer || sym->attr.allocatable) + { + if (TREE_STATIC (sym->backend_decl)) + gfc_trans_static_array_pointer (sym); + else + fnbody = gfc_trans_deferred_array (sym, fnbody); + } + else + { + gfc_get_backend_locus (&loc); + gfc_set_backend_locus (&sym->declared_at); + fnbody = gfc_trans_auto_array_allocation (sym->backend_decl, + sym, fnbody); + gfc_set_backend_locus (&loc); + } + break; + + case AS_ASSUMED_SIZE: + /* Must be a dummy parameter. */ + assert (sym->attr.dummy); + + /* We should always pass assumed size arrays the g77 way. */ + assert (TREE_CODE (sym->backend_decl) == PARM_DECL); + fnbody = gfc_trans_g77_array (sym, fnbody); + break; + + case AS_ASSUMED_SHAPE: + /* Must be a dummy parameter. */ + assert (sym->attr.dummy); + + fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl, + fnbody); + break; + + case AS_DEFERRED: + fnbody = gfc_trans_deferred_array (sym, fnbody); + break; + + default: + abort (); + } + } + else if (sym->ts.type == BT_CHARACTER) + { + gfc_get_backend_locus (&loc); + gfc_set_backend_locus (&sym->declared_at); + if (sym->attr.dummy || sym->attr.result) + fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody); + else + fnbody = gfc_trans_auto_character_variable (sym, fnbody); + gfc_set_backend_locus (&loc); + } + else + abort (); + } + + return fnbody; +} + + +/* Output an initialized decl for a module variable. */ + +static void +gfc_create_module_variable (gfc_symbol * sym) +{ + tree decl; + gfc_se se; + + /* Only output symbols from this module. */ + if (sym->ns != module_namespace) + { + /* I don't think this should ever happen. */ + internal_error ("module symbol %s in wrong namespace", sym->name); + } + + /* Don't ouptut symbols from common blocks. */ + if (sym->attr.common) + return; + + /* Only output variables and array valued parametes. */ + if (sym->attr.flavor != FL_VARIABLE + && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0)) + return; + + /* Don't generate variables from other modules. */ + if (sym->attr.use_assoc) + return; + + if (sym->backend_decl) + internal_error ("backend decl for module variable %s already exists", + sym->name); + + /* We always want module variables to be created. */ + sym->attr.referenced = 1; + /* Create the decl. */ + decl = gfc_get_symbol_decl (sym); + + /* We want to allocate storage for this variable. */ + TREE_STATIC (decl) = 1; + + if (sym->attr.dimension) + { + assert (sym->attr.pointer || sym->attr.allocatable + || GFC_ARRAY_TYPE_P (TREE_TYPE (sym->backend_decl))); + if (sym->attr.pointer || sym->attr.allocatable) + gfc_trans_static_array_pointer (sym); + else + gfc_trans_auto_array_allocation (sym->backend_decl, sym, NULL_TREE); + } + else if (sym->ts.type == BT_DERIVED) + { + if (sym->value) + gfc_todo_error ("Initialization of derived type module variables"); + } + else + { + if (sym->value) + { + gfc_init_se (&se, NULL); + gfc_conv_constant (&se, sym->value); + DECL_INITIAL (decl) = se.expr; + } + } + + /* Create the variable. */ + pushdecl (decl); + rest_of_decl_compilation (decl, NULL, 1, 0); + + /* Also add length of strings. */ + if (sym->ts.type == BT_CHARACTER) + { + tree length; + + length = sym->ts.cl->backend_decl; + if (!INTEGER_CST_P (length)) + { + pushdecl (length); + rest_of_decl_compilation (length, NULL, 1, 0); + } + } +} + + +/* Generate all the required code for module variables. */ + +void +gfc_generate_module_vars (gfc_namespace * ns) +{ + module_namespace = ns; + + /* Check the frontend left the namespace in a reasonable state. */ + assert (ns->proc_name && !ns->proc_name->tlink); + + /* Create decls for all the module varuiables. */ + gfc_traverse_ns (ns, gfc_create_module_variable); +} + +static void +gfc_generate_contained_functions (gfc_namespace * parent) +{ + gfc_namespace *ns; + + /* We create all the prototypes before generating any code. */ + for (ns = parent->contained; ns; ns = ns->sibling) + { + /* Skip namespaces from used modules. */ + if (ns->parent != parent) + continue; + + gfc_build_function_decl (ns->proc_name); + } + + for (ns = parent->contained; ns; ns = ns->sibling) + { + /* Skip namespaces from used modules. */ + if (ns->parent != parent) + continue; + + gfc_generate_function_code (ns); + } +} + + +/* Generate decls for all local variables. We do this to ensure correct + handling of expressions which only appear in the specification of + other functions. */ + +static void +generate_local_decl (gfc_symbol * sym) +{ + if (sym->attr.flavor == FL_VARIABLE) + { + /* TODO: The frontend sometimes creates symbols for things which don't + actually exist. E.g. common block names and the names of formal + arguments. The latter are created while attempting to parse + the argument list as a substring reference. + + The proper fix is to avoid adding these symbols in the first place. + For now we hack round it by ignoring anything with an unknown type. + */ + if (sym->ts.type == BT_UNKNOWN) + return; + + if (sym->attr.referenced) + gfc_get_symbol_decl (sym); + else if (sym->attr.dummy) + { + if (warn_unused_parameter) + warning ("unused parameter `%s'", sym->name); + } + else if (warn_unused_variable) + warning ("unused variable `%s'", sym->name); + } +} + +static void +generate_local_vars (gfc_namespace * ns) +{ + gfc_traverse_ns (ns, generate_local_decl); +} + + +/* Finalize DECL and all nested functions with cgraph. */ + +static void +gfc_finalize (tree decl) +{ + struct cgraph_node *cgn; + + cgn = cgraph_node (decl); + for (cgn = cgn->nested; cgn ; cgn = cgn->next_nested) + gfc_finalize (cgn->decl); + + cgraph_finalize_function (decl, false); +} + +/* Generate code for a function. */ + +void +gfc_generate_function_code (gfc_namespace * ns) +{ + tree fndecl; + tree old_context; + tree decl; + tree tmp; + stmtblock_t block; + stmtblock_t body; + tree result; + gfc_symbol *sym; + + sym = ns->proc_name; + /* Check that the frontend isn't still using this. */ + assert (sym->tlink == NULL); + + sym->tlink = sym; + + /* Create the declaration for functions with global scope. */ + if (!sym->backend_decl) + gfc_build_function_decl (ns->proc_name); + + fndecl = sym->backend_decl; + old_context = current_function_decl; + + if (old_context) + { + push_function_context (); + saved_parent_function_decls = saved_function_decls; + saved_function_decls = NULL_TREE; + } + + /* let GCC know the current scope is this function */ + current_function_decl = fndecl; + + /* print function name on the console at compile time + (unless this feature was switched of by command line option "-quiet" */ + announce_function (fndecl); + + if (DECL_CONTEXT (fndecl) == NULL_TREE) + { + /* create RTL for function declaration */ + rest_of_decl_compilation (fndecl, NULL, 1, 0); + } + + /* create RTL for function definition */ + make_decl_rtl (fndecl, NULL); + + /* Set the line and filename. sym->decalred_at seems to point to the last + statement for subroutines, but it'll do for now. */ + gfc_set_backend_locus (&sym->declared_at); + + /* line and file should not be 0 */ + init_function_start (fndecl); + + /* We're in function-at-a-time mode. */ + cfun->x_whole_function_mode_p = 1; + + /* Even though we're inside a function body, we still don't want to + call expand_expr to calculate the size of a variable-sized array. + We haven't necessarily assigned RTL to all variables yet, so it's + not safe to try to expand expressions involving them. */ + immediate_size_expand = 0; + cfun->x_dont_save_pending_sizes_p = 1; + + /* Will be created as needed. */ + current_fake_result_decl = NULL_TREE; + + /* function.c requires a push at the start of the function */ + pushlevel (0); + + gfc_start_block (&block); + + gfc_generate_contained_functions (ns); + + /* Translate COMMON blocks. */ + gfc_trans_common (ns); + + generate_local_vars (ns); + + current_function_return_label = NULL; + + /* Now generate the code for the body of this function. */ + gfc_init_block (&body); + + if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node + && sym->attr.subroutine) + { + tree alternate_return; + alternate_return = gfc_get_fake_result_decl (sym); + gfc_add_modify_expr (&body, alternate_return, integer_zero_node); + } + + tmp = gfc_trans_code (ns->code); + gfc_add_expr_to_block (&body, tmp); + + /* Add a return label if needed. */ + if (current_function_return_label) + { + tmp = build1_v (LABEL_EXPR, current_function_return_label); + gfc_add_expr_to_block (&body, tmp); + } + + tmp = gfc_finish_block (&body); + /* Add code to create and cleanup arrays. */ + tmp = gfc_trans_deferred_vars (sym, tmp); + gfc_add_expr_to_block (&block, tmp); + + if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node) + { + if (sym->attr.subroutine ||sym == sym->result) + { + result = current_fake_result_decl; + current_fake_result_decl = NULL_TREE; + } + else + result = sym->result->backend_decl; + + if (result == NULL_TREE) + warning ("Function return value not set"); + else + { + /* Set the return value to the the dummy result variable. */ + tmp = build (MODIFY_EXPR, TREE_TYPE (result), + DECL_RESULT (fndecl), result); + tmp = build_v (RETURN_EXPR, tmp); + gfc_add_expr_to_block (&block, tmp); + } + } + + /* Add all the decls we created during processing. */ + decl = saved_function_decls; + while (decl) + { + tree next; + + next = TREE_CHAIN (decl); + TREE_CHAIN (decl) = NULL_TREE; + pushdecl (decl); + decl = next; + } + saved_function_decls = NULL_TREE; + + DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block); + + /* Finish off this function and send it for code generation. */ + poplevel (1, 0, 1); + BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; + + /* Output the GENERIC tree. */ + dump_function (TDI_original, fndecl); + + /* Store the end of the function, so that we get good line number + info for the epilogue. */ + cfun->function_end_locus = input_location; + + /* We're leaving the context of this function, so zap cfun. + It's still in DECL_STRUCT_FUNCTION, and we'll restore it in + tree_rest_of_compilation. */ + cfun = NULL; + + if (old_context) + { + pop_function_context (); + saved_function_decls = saved_parent_function_decls; + } + current_function_decl = old_context; + + if (decl_function_context (fndecl)) + { + /* Register this function with cgraph just far enough to get it + added to our parent's nested function list. */ + (void) cgraph_node (fndecl); + + /* Lowering nested functions requires gimple input. */ + gimplify_function_tree (fndecl); + } + else + { + if (cgraph_node (fndecl)->nested) + { + gimplify_function_tree (fndecl); + lower_nested_functions (fndecl); + } + gfc_finalize (fndecl); + } +} + + +void +gfc_generate_constructors (void) +{ + if (gfc_static_ctors != NULL_TREE) + abort (); +#if 0 + tree fnname; + tree type; + tree fndecl; + tree decl; + tree tmp; + + if (gfc_static_ctors == NULL_TREE) + return; + + fnname = get_file_function_name ('I'); + type = build_function_type (void_type_node, + gfc_chainon_list (NULL_TREE, void_type_node)); + + fndecl = build_decl (FUNCTION_DECL, fnname, type); + TREE_PUBLIC (fndecl) = 1; + + decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node); + DECL_CONTEXT (decl) = fndecl; + DECL_RESULT (fndecl) = decl; + + pushdecl (fndecl); + + current_function_decl = fndecl; + + rest_of_decl_compilation (fndecl, NULL, 1, 0); + + make_decl_rtl (fndecl, NULL); + + init_function_start (fndecl, input_filename, input_line); + + cfun->x_whole_function_mode_p = 1; + + immediate_size_expand = 0; + + pushlevel (0); + + for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors)) + { + tmp = + gfc_build_function_call (TREE_VALUE (gfc_static_ctors), NULL_TREE); + DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp); + } + + poplevel (1, 0, 1); + + BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; + + free_after_parsing (cfun); + free_after_compilation (cfun); + + tree_rest_of_compilation (fndecl, 0); + + current_function_decl = NULL_TREE; +#endif +} + +#include "gt-fortran-trans-decl.h" diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c new file mode 100644 index 00000000000..864b006c536 --- /dev/null +++ b/gcc/fortran/trans-expr.c @@ -0,0 +1,1835 @@ +/* Expression translation + Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + and Steven Bosscher <s.bosscher@student.tudelft.nl> + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* trans-expr.c-- generate GENERIC trees for gfc_expr. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "convert.h" +#include <stdio.h> +#include "ggc.h" +#include "toplev.h" +#include "real.h" +#include "tree-simple.h" +#include "flags.h" +#include <gmp.h> +#include <assert.h> +#include "gfortran.h" +#include "trans.h" +#include "trans-const.h" +#include "trans-types.h" +#include "trans-array.h" +/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */ +#include "trans-stmt.h" + + +/* Copy the scalarization loop variables. */ + +static void +gfc_copy_se_loopvars (gfc_se * dest, gfc_se * src) +{ + dest->ss = src->ss; + dest->loop = src->loop; +} + + +/* Initialise a simple expression holder. + + Care must be taken when multiple se are created with the same parent. + The child se must be kept in sync. The easiest way is to delay creation + of a child se until after after the previous se has been translated. */ + +void +gfc_init_se (gfc_se * se, gfc_se * parent) +{ + memset (se, 0, sizeof (gfc_se)); + gfc_init_block (&se->pre); + gfc_init_block (&se->post); + + se->parent = parent; + + if (parent) + gfc_copy_se_loopvars (se, parent); +} + + +/* Advances to the next SS in the chain. Use this rather than setting + se->ss = se->ss->next because all the parent needs to be kept in sync. + See gfc_init_se. */ + +void +gfc_advance_se_ss_chain (gfc_se * se) +{ + gfc_se *p; + + assert (se != NULL && se->ss != NULL && se->ss != gfc_ss_terminator); + + p = se; + /* Walk down the parent chain. */ + while (p != NULL) + { + /* Simple consistancy check. */ + assert (p->parent == NULL || p->parent->ss == p->ss); + + p->ss = p->ss->next; + + p = p->parent; + } +} + + +/* Ensures the result of the expression as either a temporary variable + or a constant so that it can be used repeatedly. */ + +void +gfc_make_safe_expr (gfc_se * se) +{ + tree var; + + if (TREE_CODE_CLASS (TREE_CODE (se->expr)) == 'c') + return; + + /* we need a temporary for this result */ + var = gfc_create_var (TREE_TYPE (se->expr), NULL); + gfc_add_modify_expr (&se->pre, var, se->expr); + se->expr = var; +} + + +/* Return an expression which determines if a dummy parameter is present. */ + +tree +gfc_conv_expr_present (gfc_symbol * sym) +{ + tree decl; + + assert (sym->attr.dummy && sym->attr.optional); + + decl = gfc_get_symbol_decl (sym); + if (TREE_CODE (decl) != PARM_DECL) + { + /* Array parameters use a temporary descriptor, we want the real + parameter. */ + assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) + || GFC_ARRAY_TYPE_P (TREE_TYPE (decl))); + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + } + return build (NE_EXPR, boolean_type_node, decl, null_pointer_node); +} + + +/* Generate code to initialize a string length variable. Returns the + value. */ + +void +gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock) +{ + gfc_se se; + tree tmp; + + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, cl->length, gfc_strlen_type_node); + gfc_add_block_to_block (pblock, &se.pre); + + tmp = cl->backend_decl; + gfc_add_modify_expr (pblock, tmp, se.expr); +} + +static void +gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind) +{ + tree tmp; + tree type; + tree var; + gfc_se start; + gfc_se end; + + type = gfc_get_character_type (kind, ref->u.ss.length); + type = build_pointer_type (type); + + var = NULL_TREE; + gfc_init_se (&start, se); + gfc_conv_expr_type (&start, ref->u.ss.start, gfc_strlen_type_node); + gfc_add_block_to_block (&se->pre, &start.pre); + + if (integer_onep (start.expr)) + { + gfc_conv_string_parameter (se); + } + else + { + /* Change the start of the string. */ + if (TYPE_STRING_FLAG (TREE_TYPE (se->expr))) + tmp = se->expr; + else + tmp = gfc_build_indirect_ref (se->expr); + tmp = gfc_build_array_ref (tmp, start.expr); + se->expr = gfc_build_addr_expr (type, tmp); + } + + /* Length = end + 1 - start. */ + gfc_init_se (&end, se); + if (ref->u.ss.end == NULL) + end.expr = se->string_length; + else + { + gfc_conv_expr_type (&end, ref->u.ss.end, gfc_strlen_type_node); + gfc_add_block_to_block (&se->pre, &end.pre); + } + tmp = + build (MINUS_EXPR, gfc_strlen_type_node, integer_one_node, start.expr); + tmp = build (PLUS_EXPR, gfc_strlen_type_node, end.expr, tmp); + se->string_length = fold (tmp); +} + + +/* Convert a derived type component reference. */ + +static void +gfc_conv_component_ref (gfc_se * se, gfc_ref * ref) +{ + gfc_component *c; + tree tmp; + tree decl; + tree field; + + c = ref->u.c.component; + + assert (c->backend_decl); + + field = c->backend_decl; + assert (TREE_CODE (field) == FIELD_DECL); + decl = se->expr; + tmp = build (COMPONENT_REF, TREE_TYPE (field), decl, field); + + se->expr = tmp; + + if (c->ts.type == BT_CHARACTER) + { + tmp = c->ts.cl->backend_decl; + assert (tmp); + if (!INTEGER_CST_P (tmp)) + gfc_todo_error ("Unknown length character component"); + se->string_length = tmp; + } + + if (c->pointer && c->dimension == 0) + se->expr = gfc_build_indirect_ref (se->expr); +} + + +/* Return the contents of a variable. Also handles reference/pointer + variables (all Fortran pointer references are implicit). */ + +static void +gfc_conv_variable (gfc_se * se, gfc_expr * expr) +{ + gfc_ref *ref; + gfc_symbol *sym; + + sym = expr->symtree->n.sym; + if (se->ss != NULL) + { + /* Check that something hasn't gone horribly wrong. */ + assert (se->ss != gfc_ss_terminator); + assert (se->ss->expr == expr); + + /* A scalarized term. We already know the descriptor. */ + se->expr = se->ss->data.info.descriptor; + ref = se->ss->data.info.ref; + } + else + { + se->expr = gfc_get_symbol_decl (sym); + + /* Procedure actual arguments. */ + if (sym->attr.flavor == FL_PROCEDURE + && se->expr != current_function_decl) + { + assert (se->want_pointer); + if (!sym->attr.dummy) + { + assert (TREE_CODE (se->expr) == FUNCTION_DECL); + se->expr = gfc_build_addr_expr (NULL, se->expr); + } + return; + } + + /* Special case for assigning the return value of a function. + Self recursive functions must have an explicit return value. */ + if (se->expr == current_function_decl && sym->attr.function + && (sym->result == sym)) + { + se->expr = gfc_get_fake_result_decl (sym); + } + + /* Dereference scalar dummy variables. */ + if (sym->attr.dummy + && sym->ts.type != BT_CHARACTER + && !sym->attr.dimension) + se->expr = gfc_build_indirect_ref (se->expr); + + /* Dereference pointer variables. */ + if ((sym->attr.pointer || sym->attr.allocatable) + && (sym->attr.dummy + || sym->attr.result + || sym->attr.function + || !sym->attr.dimension) + && sym->ts.type != BT_CHARACTER) + se->expr = gfc_build_indirect_ref (se->expr); + + ref = expr->ref; + } + + /* For character variables, also get the length. */ + if (sym->ts.type == BT_CHARACTER) + { + se->string_length = sym->ts.cl->backend_decl; + assert (se->string_length); + } + + while (ref) + { + switch (ref->type) + { + case REF_ARRAY: + /* Return the descriptor if that's what we want and this is an array + section reference. */ + if (se->descriptor_only && ref->u.ar.type != AR_ELEMENT) + return; +/* TODO: Pointers to single elements of array sections, eg elemental subs. */ + /* Return the descriptor for array pointers and allocations. */ + if (se->want_pointer + && ref->next == NULL && (se->descriptor_only)) + return; + + gfc_conv_array_ref (se, &ref->u.ar); + /* Return a pointer to an element. */ + break; + + case REF_COMPONENT: + gfc_conv_component_ref (se, ref); + break; + + case REF_SUBSTRING: + gfc_conv_substring (se, ref, expr->ts.kind); + break; + + default: + abort (); + break; + } + ref = ref->next; + } + /* Pointer assignment, allocation or pass by reference. Arrays are handled + seperately. */ + if (se->want_pointer) + { + if (expr->ts.type == BT_CHARACTER) + gfc_conv_string_parameter (se); + else + se->expr = gfc_build_addr_expr (NULL, se->expr); + } + if (se->ss != NULL) + gfc_advance_se_ss_chain (se); +} + + +/* Unary ops are easy... Or they would be if ! was a valid op. */ + +static void +gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr) +{ + gfc_se operand; + tree type; + + assert (expr->ts.type != BT_CHARACTER); + /* Initialize the operand. */ + gfc_init_se (&operand, se); + gfc_conv_expr_val (&operand, expr->op1); + gfc_add_block_to_block (&se->pre, &operand.pre); + + type = gfc_typenode_for_spec (&expr->ts); + + /* TRUTH_NOT_EXPR is not a "true" unary operator in GCC. + We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)). + All other unary operators have an equivalent SIMPLE unary operator */ + if (code == TRUTH_NOT_EXPR) + se->expr = build (EQ_EXPR, type, operand.expr, integer_zero_node); + else + se->expr = build1 (code, type, operand.expr); + +} + + +/* For power op (lhs ** rhs) We generate: + m = lhs + if (rhs > 0) + count = rhs + else if (rhs == 0) + { + count = 0 + m = 1 + } + else // (rhs < 0) + { + count = -rhs + m = 1 / m; + } + // for constant rhs we do the above at compile time + val = m; + for (n = 1; n < count; n++) + val = val * m; + */ + +static void +gfc_conv_integer_power (gfc_se * se, tree lhs, tree rhs) +{ + tree count; + tree result; + tree cond; + tree neg_stmt; + tree pos_stmt; + tree tmp; + tree var; + tree type; + stmtblock_t block; + tree exit_label; + + type = TREE_TYPE (lhs); + + if (INTEGER_CST_P (rhs)) + { + if (integer_zerop (rhs)) + { + se->expr = gfc_build_const (type, integer_one_node); + return; + } + /* Special cases for constant values. */ + if (TREE_INT_CST_HIGH (rhs) == -1) + { + /* x ** (-y) == 1 / (x ** y). */ + if (TREE_CODE (type) == INTEGER_TYPE) + { + se->expr = integer_zero_node; + return; + } + + tmp = gfc_build_const (type, integer_one_node); + lhs = fold (build (RDIV_EXPR, type, tmp, lhs)); + + rhs = fold (build1 (NEGATE_EXPR, TREE_TYPE (rhs), rhs)); + assert (INTEGER_CST_P (rhs)); + } + else + { + /* TODO: really big integer powers. */ + assert (TREE_INT_CST_HIGH (rhs) == 0); + } + + if (integer_onep (rhs)) + { + se->expr = lhs; + return; + } + if (TREE_INT_CST_LOW (rhs) == 2) + { + se->expr = build (MULT_EXPR, type, lhs, lhs); + return; + } + if (TREE_INT_CST_LOW (rhs) == 3) + { + tmp = build (MULT_EXPR, type, lhs, lhs); + se->expr = fold (build (MULT_EXPR, type, tmp, lhs)); + return; + } + + /* Create the loop count variable. */ + count = gfc_create_var (TREE_TYPE (rhs), "count"); + gfc_add_modify_expr (&se->pre, count, rhs); + } + else + { + /* Put the lhs into a temporary variable. */ + var = gfc_create_var (type, "val"); + count = gfc_create_var (TREE_TYPE (rhs), "count"); + gfc_add_modify_expr (&se->pre, var, lhs); + lhs = var; + + /* Generate code for negative rhs. */ + gfc_start_block (&block); + + if (TREE_CODE (TREE_TYPE (lhs)) == INTEGER_TYPE) + { + gfc_add_modify_expr (&block, lhs, integer_zero_node); + gfc_add_modify_expr (&block, count, integer_zero_node); + } + else + { + tmp = gfc_build_const (type, integer_one_node); + tmp = build (RDIV_EXPR, type, tmp, lhs); + gfc_add_modify_expr (&block, var, tmp); + + tmp = build1 (NEGATE_EXPR, TREE_TYPE (rhs), rhs); + gfc_add_modify_expr (&block, count, tmp); + } + neg_stmt = gfc_finish_block (&block); + + pos_stmt = build_v (MODIFY_EXPR, count, rhs); + + /* Code for rhs == 0. */ + gfc_start_block (&block); + + gfc_add_modify_expr (&block, count, integer_zero_node); + tmp = gfc_build_const (type, integer_one_node); + gfc_add_modify_expr (&block, lhs, tmp); + + tmp = gfc_finish_block (&block); + + /* Select the appropriate action. */ + cond = build (EQ_EXPR, boolean_type_node, rhs, integer_zero_node); + tmp = build_v (COND_EXPR, cond, tmp, neg_stmt); + + cond = build (GT_EXPR, boolean_type_node, rhs, integer_zero_node); + tmp = build_v (COND_EXPR, cond, pos_stmt, tmp); + gfc_add_expr_to_block (&se->pre, tmp); + } + + /* Create a variable for the result. */ + result = gfc_create_var (type, "pow"); + gfc_add_modify_expr (&se->pre, result, lhs); + + exit_label = gfc_build_label_decl (NULL_TREE); + TREE_USED (exit_label) = 1; + + /* Create the loop body. */ + gfc_start_block (&block); + + /* First the exit condition (until count <= 1). */ + tmp = build1_v (GOTO_EXPR, exit_label); + cond = build (LE_EXPR, TREE_TYPE (count), count, integer_one_node); + tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ()); + gfc_add_expr_to_block (&block, tmp); + + /* Multiply by the lhs. */ + tmp = build (MULT_EXPR, type, result, lhs); + gfc_add_modify_expr (&block, result, tmp); + + /* Adjust the loop count. */ + tmp = build (MINUS_EXPR, TREE_TYPE (count), count, integer_one_node); + gfc_add_modify_expr (&block, count, tmp); + + tmp = gfc_finish_block (&block); + + /* Create the the loop. */ + tmp = build_v (LOOP_EXPR, tmp); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Add the exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&se->pre, tmp); + + se->expr = result; +} + + +/* Power op (**). Integer rhs has special handling. */ + +static void +gfc_conv_power_op (gfc_se * se, gfc_expr * expr) +{ + int kind; + gfc_se lse; + gfc_se rse; + tree fndecl; + tree tmp; + tree type; + + gfc_init_se (&lse, se); + gfc_conv_expr_val (&lse, expr->op1); + gfc_add_block_to_block (&se->pre, &lse.pre); + + gfc_init_se (&rse, se); + gfc_conv_expr_val (&rse, expr->op2); + gfc_add_block_to_block (&se->pre, &rse.pre); + + type = TREE_TYPE (lse.expr); + + kind = expr->op1->ts.kind; + switch (expr->op2->ts.type) + { + case BT_INTEGER: + /* Integer powers are expanded inline as multiplications. */ + gfc_conv_integer_power (se, lse.expr, rse.expr); + return; + + case BT_REAL: + switch (kind) + { + case 4: + fndecl = gfor_fndecl_math_powf; + break; + case 8: + fndecl = gfor_fndecl_math_pow; + break; + default: + abort (); + } + break; + + case BT_COMPLEX: + switch (kind) + { + case 4: + fndecl = gfor_fndecl_math_cpowf; + break; + case 8: + fndecl = gfor_fndecl_math_cpow; + break; + default: + abort (); + } + break; + + default: + abort (); + break; + } + + tmp = gfc_chainon_list (NULL_TREE, lse.expr); + tmp = gfc_chainon_list (tmp, rse.expr); + se->expr = gfc_build_function_call (fndecl, tmp); +} + + +/* Generate code to allocate a string temporary. */ + +tree +gfc_conv_string_tmp (gfc_se * se, tree type, tree len) +{ + tree var; + tree tmp; + tree args; + + if (gfc_can_put_var_on_stack (len)) + { + /* Create a temporary variable to hold the result. */ + tmp = fold (build (MINUS_EXPR, TREE_TYPE (len), len, integer_one_node)); + tmp = build_range_type (gfc_array_index_type, integer_zero_node, tmp); + tmp = build_array_type (gfc_character1_type_node, tmp); + var = gfc_create_var (tmp, "str"); + var = gfc_build_addr_expr (type, var); + } + else + { + /* Allocate a temporary to hold the result. */ + var = gfc_create_var (type, "pstr"); + args = gfc_chainon_list (NULL_TREE, len); + tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args); + tmp = convert (type, tmp); + gfc_add_modify_expr (&se->pre, var, tmp); + + /* Free the temporary afterwards. */ + tmp = convert (pvoid_type_node, var); + args = gfc_chainon_list (NULL_TREE, tmp); + tmp = gfc_build_function_call (gfor_fndecl_internal_free, args); + gfc_add_expr_to_block (&se->post, tmp); + } + + return var; +} + + +/* Handle a string concatenation operation. A temporary will be allocated to + hold the result. */ + +static void +gfc_conv_concat_op (gfc_se * se, gfc_expr * expr) +{ + gfc_se lse; + gfc_se rse; + tree len; + tree type; + tree var; + tree args; + tree tmp; + + assert (expr->op1->ts.type == BT_CHARACTER + && expr->op2->ts.type == BT_CHARACTER); + + gfc_init_se (&lse, se); + gfc_conv_expr (&lse, expr->op1); + gfc_conv_string_parameter (&lse); + gfc_init_se (&rse, se); + gfc_conv_expr (&rse, expr->op2); + gfc_conv_string_parameter (&rse); + + gfc_add_block_to_block (&se->pre, &lse.pre); + gfc_add_block_to_block (&se->pre, &rse.pre); + + type = gfc_get_character_type (expr->ts.kind, expr->ts.cl); + len = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); + if (len == NULL_TREE) + { + len = fold (build (PLUS_EXPR, TREE_TYPE (lse.string_length), + lse.string_length, rse.string_length)); + } + + type = build_pointer_type (type); + + var = gfc_conv_string_tmp (se, type, len); + + /* Do the actual concatenation. */ + args = NULL_TREE; + args = gfc_chainon_list (args, len); + args = gfc_chainon_list (args, var); + args = gfc_chainon_list (args, lse.string_length); + args = gfc_chainon_list (args, lse.expr); + args = gfc_chainon_list (args, rse.string_length); + args = gfc_chainon_list (args, rse.expr); + tmp = gfc_build_function_call (gfor_fndecl_concat_string, args); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Add the cleanup for the operands. */ + gfc_add_block_to_block (&se->pre, &rse.post); + gfc_add_block_to_block (&se->pre, &lse.post); + + se->expr = var; + se->string_length = len; +} + + +/* Translates an op expression. Common (binary) cases are handled by this + function, others are passed on. Recursion is used in either case. + We use the fact that (op1.ts == op2.ts) (except for the power + operand **). + Operators need no special handling for scalarized expressions as long as + they call gfc_conv_siple_val to get their operands. + Character strings get special handling. */ + +static void +gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) +{ + enum tree_code code; + gfc_se lse; + gfc_se rse; + tree type; + tree tmp; + int lop; + int checkstring; + + checkstring = 0; + lop = 0; + switch (expr->operator) + { + case INTRINSIC_UPLUS: + gfc_conv_expr (se, expr->op1); + return; + + case INTRINSIC_UMINUS: + gfc_conv_unary_op (NEGATE_EXPR, se, expr); + return; + + case INTRINSIC_NOT: + gfc_conv_unary_op (TRUTH_NOT_EXPR, se, expr); + return; + + case INTRINSIC_PLUS: + code = PLUS_EXPR; + break; + + case INTRINSIC_MINUS: + code = MINUS_EXPR; + break; + + case INTRINSIC_TIMES: + code = MULT_EXPR; + break; + + case INTRINSIC_DIVIDE: + /* If expr is a real or complex expr, use an RDIV_EXPR. If op1 is + an integer, we must round towards zero, so we use a + TRUNC_DIV_EXPR. */ + if (expr->ts.type == BT_INTEGER) + code = TRUNC_DIV_EXPR; + else + code = RDIV_EXPR; + break; + + case INTRINSIC_POWER: + gfc_conv_power_op (se, expr); + return; + + case INTRINSIC_CONCAT: + gfc_conv_concat_op (se, expr); + return; + + case INTRINSIC_AND: + code = TRUTH_ANDIF_EXPR; + lop = 1; + break; + + case INTRINSIC_OR: + code = TRUTH_ORIF_EXPR; + lop = 1; + break; + + /* EQV and NEQV only work on logicals, but since we represent them + as integers, we can use EQ_EXPR and NE_EXPR for them in SIMPLE. */ + case INTRINSIC_EQ: + case INTRINSIC_EQV: + code = EQ_EXPR; + checkstring = 1; + lop = 1; + break; + + case INTRINSIC_NE: + case INTRINSIC_NEQV: + code = NE_EXPR; + checkstring = 1; + lop = 1; + break; + + case INTRINSIC_GT: + code = GT_EXPR; + checkstring = 1; + lop = 1; + break; + + case INTRINSIC_GE: + code = GE_EXPR; + checkstring = 1; + lop = 1; + break; + + case INTRINSIC_LT: + code = LT_EXPR; + checkstring = 1; + lop = 1; + break; + + case INTRINSIC_LE: + code = LE_EXPR; + checkstring = 1; + lop = 1; + break; + + case INTRINSIC_USER: + case INTRINSIC_ASSIGN: + /* These should be converted into function calls by the frontend. */ + abort (); + return; + + default: + fatal_error ("Unknown intrinsic op"); + return; + } + + /* The only exception to this is **, which is handled seperately anyway. */ + assert (expr->op1->ts.type == expr->op2->ts.type); + + if (checkstring && expr->op1->ts.type != BT_CHARACTER) + checkstring = 0; + + /* lhs */ + gfc_init_se (&lse, se); + gfc_conv_expr (&lse, expr->op1); + gfc_add_block_to_block (&se->pre, &lse.pre); + + /* rhs */ + gfc_init_se (&rse, se); + gfc_conv_expr (&rse, expr->op2); + gfc_add_block_to_block (&se->pre, &rse.pre); + + /* For string comparisons we generate a library call, and compare the return + value with 0. */ + if (checkstring) + { + gfc_conv_string_parameter (&lse); + gfc_conv_string_parameter (&rse); + tmp = NULL_TREE; + tmp = gfc_chainon_list (tmp, lse.string_length); + tmp = gfc_chainon_list (tmp, lse.expr); + tmp = gfc_chainon_list (tmp, rse.string_length); + tmp = gfc_chainon_list (tmp, rse.expr); + + /* Build a call for the comparison. */ + lse.expr = gfc_build_function_call (gfor_fndecl_compare_string, tmp); + gfc_add_block_to_block (&lse.post, &rse.post); + + rse.expr = integer_zero_node; + } + + type = gfc_typenode_for_spec (&expr->ts); + + if (lop) + { + /* The result of logical ops is always boolean_type_node. */ + tmp = fold (build (code, type, lse.expr, rse.expr)); + se->expr = convert (type, tmp); + } + else + se->expr = fold (build (code, type, lse.expr, rse.expr)); + + + /* Add the post blocks. */ + gfc_add_block_to_block (&se->post, &rse.post); + gfc_add_block_to_block (&se->post, &lse.post); +} + +static void +gfc_conv_function_val (gfc_se * se, gfc_symbol * sym) +{ + tree tmp; + + if (sym->attr.dummy) + { + tmp = gfc_get_symbol_decl (sym); + assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE + && TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE); + + se->expr = tmp; + } + else + { + if (!sym->backend_decl) + sym->backend_decl = gfc_get_extern_function_decl (sym); + + tmp = sym->backend_decl; + assert (TREE_CODE (tmp) == FUNCTION_DECL); + se->expr = gfc_build_addr_expr (NULL, tmp); + } +} + + +/* Generate code for a procedure call. Note can return se->post != NULL. + If se->direct_byref is set then se->expr contains the return parameter. */ + +void +gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, + gfc_actual_arglist * arg) +{ + tree arglist; + tree tmp; + tree fntype; + gfc_se parmse; + gfc_ss *argss; + gfc_ss_info *info; + int byref; + tree type; + tree var; + tree len; + tree stringargs; + gfc_formal_arglist *formal; + + arglist = NULL_TREE; + stringargs = NULL_TREE; + var = NULL_TREE; + len = NULL_TREE; + + if (se->ss != NULL) + { + if (!sym->attr.elemental) + { + assert (se->ss->type == GFC_SS_FUNCTION); + if (se->ss->useflags) + { + assert (gfc_return_by_reference (sym) + && sym->result->attr.dimension); + assert (se->loop != NULL); + + /* Access the previously obtained result. */ + gfc_conv_tmp_array_ref (se); + gfc_advance_se_ss_chain (se); + return; + } + } + info = &se->ss->data.info; + } + else + info = NULL; + + byref = gfc_return_by_reference (sym); + if (byref) + { + if (se->direct_byref) + arglist = gfc_chainon_list (arglist, se->expr); + else if (sym->result->attr.dimension) + { + assert (se->loop && se->ss); + /* Set the type of the array. */ + tmp = gfc_typenode_for_spec (&sym->ts); + info->dimen = se->loop->dimen; + /* Allocate a temporary to store the result. */ + gfc_trans_allocate_temp_array (se->loop, info, tmp, NULL_TREE); + + /* Zero the first stride to indicate a temporary. */ + tmp = + gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]); + gfc_add_modify_expr (&se->pre, tmp, integer_zero_node); + /* Pass the temporary as the first argument. */ + tmp = info->descriptor; + tmp = gfc_build_addr_expr (NULL, tmp); + arglist = gfc_chainon_list (arglist, tmp); + } + else if (sym->ts.type == BT_CHARACTER) + { + assert (sym->ts.cl && sym->ts.cl->length + && sym->ts.cl->length->expr_type == EXPR_CONSTANT); + len = gfc_conv_mpz_to_tree + (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind); + sym->ts.cl->backend_decl = len; + type = gfc_get_character_type (sym->ts.kind, sym->ts.cl); + type = build_pointer_type (type); + + var = gfc_conv_string_tmp (se, type, len); + arglist = gfc_chainon_list (arglist, var); + arglist = gfc_chainon_list (arglist, convert (gfc_strlen_type_node, + len)); + } + else /* TODO: derived type function return values. */ + abort (); + } + + formal = sym->formal; + /* Evaluate the arguments. */ + for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) + { + if (arg->expr == NULL) + { + + if (se->ignore_optional) + { + /* Some intrinsics have already been resolved to the correct + parameters. */ + continue; + } + else if (arg->label) + { + has_alternate_specifier = 1; + continue; + } + else + { + /* Pass a NULL pointer for an absent arg. */ + gfc_init_se (&parmse, NULL); + parmse.expr = null_pointer_node; + if (formal && formal->sym->ts.type == BT_CHARACTER) + { + stringargs = gfc_chainon_list (stringargs, + convert (gfc_strlen_type_node, integer_zero_node)); + } + } + } + else if (se->ss && se->ss->useflags) + { + /* An elemental function inside a scalarized loop. */ + gfc_init_se (&parmse, se); + gfc_conv_expr_reference (&parmse, arg->expr); + } + else + { + /* A scalar or transformational function. */ + gfc_init_se (&parmse, NULL); + argss = gfc_walk_expr (arg->expr); + + if (argss == gfc_ss_terminator) + { + gfc_conv_expr_reference (&parmse, arg->expr); + if (formal && formal->sym->attr.pointer) + { + /* Scalar pointer dummy args require an extra level of + indirection. */ + parmse.expr = gfc_build_addr_expr (NULL, parmse.expr); + } + } + else + { + /* If the procedure requires explicit interface, actual argument + is passed according to corresponing formal argument. We + do not use g77 method and the address of array descriptor + is passed if corresponing formal is pointer or + assumed-shape, Otherwise use g77 method. */ + int f; + f = (formal != NULL) + && !formal->sym->attr.pointer + && formal->sym->as->type != AS_ASSUMED_SHAPE; + f = f || !sym->attr.always_explicit; + gfc_conv_array_parameter (&parmse, arg->expr, argss, f); + } + } + + gfc_add_block_to_block (&se->pre, &parmse.pre); + gfc_add_block_to_block (&se->post, &parmse.post); + + /* Character strings are passed as two paramarers, a length and a + pointer. */ + if (parmse.string_length != NULL_TREE) + stringargs = gfc_chainon_list (stringargs, parmse.string_length); + + arglist = gfc_chainon_list (arglist, parmse.expr); + } + + /* Add the hidden string length parameters to the arguments. */ + arglist = chainon (arglist, stringargs); + + /* Generate the actual call. */ + gfc_conv_function_val (se, sym); + /* If there are alternate return labels, function type should be + integer. */ + if (has_alternate_specifier) + TREE_TYPE (TREE_TYPE (TREE_TYPE (se->expr))) = integer_type_node; + + fntype = TREE_TYPE (TREE_TYPE (se->expr)); + se->expr = build (CALL_EXPR, TREE_TYPE (fntype), se->expr, + arglist, NULL_TREE); + +/* A pure function may still have side-effects - it may modify its + parameters. */ + TREE_SIDE_EFFECTS (se->expr) = 1; +#if 0 + if (!sym->attr.pure) + TREE_SIDE_EFFECTS (se->expr) = 1; +#endif + + if (byref && !se->direct_byref) + { + gfc_add_expr_to_block (&se->pre, se->expr); + + if (sym->result->attr.dimension) + { + if (flag_bounds_check) + { + /* Check the data pointer hasn't been modified. This would happen + in a function returning a pointer. */ + tmp = gfc_conv_descriptor_data (info->descriptor); + tmp = build (NE_EXPR, boolean_type_node, tmp, info->data); + gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre); + } + se->expr = info->descriptor; + } + else if (sym->ts.type == BT_CHARACTER) + { + se->expr = var; + se->string_length = len; + } + else + abort (); + } +} + + +/* Translate a statement function. + The value of a statement function reference is obtained by evaluating the + expression using the values of the actual arguments for the values of the + corresponding dummy arguments. */ + +static void +gfc_conv_statement_function (gfc_se * se, gfc_expr * expr) +{ + gfc_symbol *sym; + gfc_symbol *fsym; + gfc_formal_arglist *fargs; + gfc_actual_arglist *args; + gfc_se lse; + gfc_se rse; + + sym = expr->symtree->n.sym; + args = expr->value.function.actual; + gfc_init_se (&lse, NULL); + gfc_init_se (&rse, NULL); + + for (fargs = sym->formal; fargs; fargs = fargs->next) + { + /* Each dummy shall be specified, explicitly or implicitly, to be + scalar. */ + assert (fargs->sym->attr.dimension == 0); + fsym = fargs->sym; + assert (fsym->backend_decl); + + /* Convert non-pointer string dummy. */ + if (fsym->ts.type == BT_CHARACTER && !fsym->attr.pointer) + { + tree len1; + tree len2; + tree arg; + tree tmp; + tree type; + tree var; + + assert (fsym->ts.cl && fsym->ts.cl->length + && fsym->ts.cl->length->expr_type == EXPR_CONSTANT); + + type = gfc_get_character_type (fsym->ts.kind, fsym->ts.cl); + len1 = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); + var = gfc_build_addr_expr (build_pointer_type (type), + fsym->backend_decl); + + gfc_conv_expr (&rse, args->expr); + gfc_conv_string_parameter (&rse); + len2 = rse.string_length; + gfc_add_block_to_block (&se->pre, &lse.pre); + gfc_add_block_to_block (&se->pre, &rse.pre); + + arg = NULL_TREE; + arg = gfc_chainon_list (arg, len1); + arg = gfc_chainon_list (arg, var); + arg = gfc_chainon_list (arg, len2); + arg = gfc_chainon_list (arg, rse.expr); + tmp = gfc_build_function_call (gfor_fndecl_copy_string, arg); + gfc_add_expr_to_block (&se->pre, tmp); + gfc_add_block_to_block (&se->pre, &lse.post); + gfc_add_block_to_block (&se->pre, &rse.post); + } + else + { + /* For everything else, just evaluate the expression. */ + if (fsym->attr.pointer == 1) + lse.want_pointer = 1; + + gfc_conv_expr (&lse, args->expr); + + gfc_add_block_to_block (&se->pre, &lse.pre); + gfc_add_modify_expr (&se->pre, fsym->backend_decl, lse.expr); + gfc_add_block_to_block (&se->pre, &lse.post); + } + args = args->next; + } + gfc_conv_expr (se, sym->value); +} + + +/* Translate a function expression. */ + +static void +gfc_conv_function_expr (gfc_se * se, gfc_expr * expr) +{ + gfc_symbol *sym; + + if (expr->value.function.isym) + { + gfc_conv_intrinsic_function (se, expr); + return; + } + + /* We distinguish the statement function from general function to improve + runtime performance. */ + if (expr->symtree->n.sym->attr.proc == PROC_ST_FUNCTION) + { + gfc_conv_statement_function (se, expr); + return; + } + + /* expr.value.function.esym is the resolved (specific) function symbol for + most functions. However this isn't set for dummy procedures. */ + sym = expr->value.function.esym; + if (!sym) + sym = expr->symtree->n.sym; + gfc_conv_function_call (se, sym, expr->value.function.actual); +} + +static void +gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr) +{ + assert (se->ss != NULL && se->ss != gfc_ss_terminator); + assert (se->ss->expr == expr && se->ss->type == GFC_SS_CONSTRUCTOR); + + gfc_conv_tmp_array_ref (se); + gfc_advance_se_ss_chain (se); +} + + + +/* Build an expression for a constructor. If init is nonzero then + this is part of a static variable initializer. */ + +void +gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init) +{ + gfc_constructor *c; + gfc_component *cm; + tree head; + tree tail; + tree val; + gfc_se cse; + tree type; + tree arraytype; + + assert (expr->expr_type == EXPR_STRUCTURE); + type = gfc_typenode_for_spec (&expr->ts); + head = build1 (CONSTRUCTOR, type, NULL_TREE); + tail = NULL_TREE; + + cm = expr->ts.derived->components; + for (c = expr->value.constructor; c; c = c->next, cm = cm->next) + { + /* Skip absent members in default initializers. */ + if (!c->expr) + continue; + + gfc_init_se (&cse, se); + /* Evaluate the expression for this component. */ + if (init) + { + switch (c->expr->expr_type) + { + case EXPR_ARRAY: + arraytype = TREE_TYPE (cm->backend_decl); + cse.expr = gfc_conv_array_initializer (arraytype, c->expr); + break; + + case EXPR_STRUCTURE: + gfc_conv_structure (&cse, c->expr, 1); + break; + + default: + gfc_conv_expr (&cse, c->expr); + } + } + else + { + gfc_conv_expr (&cse, c->expr); + gfc_add_block_to_block (&se->pre, &cse.pre); + gfc_add_block_to_block (&se->post, &cse.post); + } + + /* Build a TREE_CHAIN to hold it. */ + val = tree_cons (cm->backend_decl, cse.expr, NULL_TREE); + + /* Add it to the list. */ + if (tail == NULL_TREE) + TREE_OPERAND(head, 0) = tail = val; + else + { + TREE_CHAIN (tail) = val; + tail = val; + } + } + se->expr = head; +} + + +/*translate a substring expression */ + +static void +gfc_conv_substring_expr (gfc_se * se, gfc_expr * expr) +{ + gfc_ref *ref; + + ref = expr->ref; + + assert(ref->type == REF_SUBSTRING); + + se->expr = gfc_build_string_const(expr->value.character.length, + expr->value.character.string); + se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr))); + TYPE_STRING_FLAG (TREE_TYPE (se->expr))=1; + + gfc_conv_substring(se,ref,expr->ts.kind); +} + + +/* Entry point for expression translation. */ + +void +gfc_conv_expr (gfc_se * se, gfc_expr * expr) +{ + if (se->ss && se->ss->expr == expr + && (se->ss->type == GFC_SS_SCALAR || se->ss->type == GFC_SS_REFERENCE)) + { + /* Substiture a scalar expression evaluated outside the scalarization + loop. */ + se->expr = se->ss->data.scalar.expr; + se->string_length = se->ss->data.scalar.string_length; + gfc_advance_se_ss_chain (se); + return; + } + + switch (expr->expr_type) + { + case EXPR_OP: + gfc_conv_expr_op (se, expr); + break; + + case EXPR_FUNCTION: + gfc_conv_function_expr (se, expr); + break; + + case EXPR_CONSTANT: + gfc_conv_constant (se, expr); + break; + + case EXPR_VARIABLE: + gfc_conv_variable (se, expr); + break; + + case EXPR_NULL: + se->expr = null_pointer_node; + break; + + case EXPR_SUBSTRING: + gfc_conv_substring_expr (se, expr); + break; + + case EXPR_STRUCTURE: + gfc_conv_structure (se, expr, 0); + break; + + case EXPR_ARRAY: + gfc_conv_array_constructor_expr (se, expr); + break; + + default: + abort (); + break; + } +} + +void +gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr) +{ + gfc_conv_expr (se, expr); + /* AFAICS all numeric lvalues have empty post chains. If not we need to + figure out a way of rewriting an lvalue so that it has no post chain. */ + assert (expr->ts.type != BT_CHARACTER || !se->post.head); +} + +void +gfc_conv_expr_val (gfc_se * se, gfc_expr * expr) +{ + tree val; + + assert (expr->ts.type != BT_CHARACTER); + gfc_conv_expr (se, expr); + if (se->post.head) + { + val = gfc_create_var (TREE_TYPE (se->expr), NULL); + gfc_add_modify_expr (&se->pre, val, se->expr); + } +} + +void +gfc_conv_expr_type (gfc_se * se, gfc_expr * expr, tree type) +{ + gfc_conv_expr_val (se, expr); + se->expr = convert (type, se->expr); +} + + +/* Converts an expression so that it can be passed by refernece. Scalar + values only. */ + +void +gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) +{ + tree var; + + if (se->ss && se->ss->expr == expr + && se->ss->type == GFC_SS_REFERENCE) + { + se->expr = se->ss->data.scalar.expr; + se->string_length = se->ss->data.scalar.string_length; + gfc_advance_se_ss_chain (se); + return; + } + + if (expr->ts.type == BT_CHARACTER) + { + gfc_conv_expr (se, expr); + gfc_conv_string_parameter (se); + return; + } + + if (expr->expr_type == EXPR_VARIABLE) + { + se->want_pointer = 1; + gfc_conv_expr (se, expr); + if (se->post.head) + { + var = gfc_create_var (TREE_TYPE (se->expr), NULL); + gfc_add_modify_expr (&se->pre, var, se->expr); + gfc_add_block_to_block (&se->pre, &se->post); + se->expr = var; + } + return; + } + + gfc_conv_expr (se, expr); + + /* Create a temporary var to hold the value. */ + var = gfc_create_var (TREE_TYPE (se->expr), NULL); + gfc_add_modify_expr (&se->pre, var, se->expr); + gfc_add_block_to_block (&se->pre, &se->post); + + /* Take the address of that value. */ + se->expr = gfc_build_addr_expr (NULL, var); +} + + +tree +gfc_trans_pointer_assign (gfc_code * code) +{ + return gfc_trans_pointer_assignment (code->expr, code->expr2); +} + + +tree +gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) +{ + gfc_se lse; + gfc_se rse; + gfc_ss *lss; + gfc_ss *rss; + stmtblock_t block; + tree tmp; + + gfc_start_block (&block); + + gfc_init_se (&lse, NULL); + + lss = gfc_walk_expr (expr1); + rss = gfc_walk_expr (expr2); + if (lss == gfc_ss_terminator) + { + lse.want_pointer = 1; + gfc_conv_expr (&lse, expr1); + assert (rss == gfc_ss_terminator); + gfc_init_se (&rse, NULL); + rse.want_pointer = 1; + gfc_conv_expr (&rse, expr2); + gfc_add_block_to_block (&block, &lse.pre); + gfc_add_block_to_block (&block, &rse.pre); + gfc_add_modify_expr (&block, lse.expr, rse.expr); + gfc_add_block_to_block (&block, &rse.post); + gfc_add_block_to_block (&block, &lse.post); + } + else + { + gfc_conv_expr_descriptor (&lse, expr1, lss); + /* Implement Nullify. */ + if (expr2->expr_type == EXPR_NULL) + { + lse.expr = gfc_conv_descriptor_data (lse.expr); + rse.expr = null_pointer_node; + tmp = build_v (MODIFY_EXPR, lse.expr, rse.expr); + gfc_add_expr_to_block (&block, tmp); + } + else + { + lse.direct_byref = 1; + gfc_conv_expr_descriptor (&lse, expr2, rss); + } + gfc_add_block_to_block (&block, &lse.pre); + gfc_add_block_to_block (&block, &lse.post); + } + return gfc_finish_block (&block); +} + + +/* Makes sure se is suitable for passing as a function string parameter. */ +/* TODO: Need to check all callers fo this function. It may be abused. */ + +void +gfc_conv_string_parameter (gfc_se * se) +{ + tree type; + + if (TREE_CODE (se->expr) == STRING_CST) + { + se->expr = gfc_build_addr_expr (pchar_type_node, se->expr); + return; + } + + type = TREE_TYPE (se->expr); + if (TYPE_STRING_FLAG (type)) + { + assert (TREE_CODE (se->expr) != INDIRECT_REF); + se->expr = gfc_build_addr_expr (pchar_type_node, se->expr); + } + + assert (POINTER_TYPE_P (TREE_TYPE (se->expr))); + assert (se->string_length + && TREE_CODE (TREE_TYPE (se->string_length)) == INTEGER_TYPE); +} + + +/* Generate code for assignment of scalar variables. Includes character + strings. */ + +tree +gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, bt type) +{ + tree tmp; + tree args; + stmtblock_t block; + + gfc_init_block (&block); + + + if (type == BT_CHARACTER) + { + args = NULL_TREE; + + assert (lse->string_length != NULL_TREE + && rse->string_length != NULL_TREE); + + gfc_conv_string_parameter (lse); + gfc_conv_string_parameter (rse); + + gfc_add_block_to_block (&block, &lse->pre); + gfc_add_block_to_block (&block, &rse->pre); + + args = gfc_chainon_list (args, lse->string_length); + args = gfc_chainon_list (args, lse->expr); + args = gfc_chainon_list (args, rse->string_length); + args = gfc_chainon_list (args, rse->expr); + + tmp = gfc_build_function_call (gfor_fndecl_copy_string, args); + gfc_add_expr_to_block (&block, tmp); + } + else + { + gfc_add_block_to_block (&block, &lse->pre); + gfc_add_block_to_block (&block, &rse->pre); + + gfc_add_modify_expr (&block, lse->expr, rse->expr); + } + + gfc_add_block_to_block (&block, &lse->post); + gfc_add_block_to_block (&block, &rse->post); + + return gfc_finish_block (&block); +} + + +/* Try to translate array(:) = func (...), where func is a transformational + array function, without using a temporary. Returns NULL is this isn't the + case. */ + +static tree +gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) +{ + gfc_se se; + gfc_ss *ss; + + /* The caller has already checked rank>0 and expr_type == EXPR_FUNCTION. */ + if (expr2->value.function.isym && !gfc_is_intrinsic_libcall (expr2)) + return NULL; + + /* Elemental functions don't need a temporary anyway. */ + if (expr2->symtree->n.sym->attr.elemental) + return NULL; + + /* Check for a dependency. */ + if (gfc_check_fncall_dependency (expr1, expr2)) + return NULL; + + /* The frontend doesn't seem to bother filling in expr->symtree for intrinsic + functions. */ + assert (expr2->value.function.isym + || (gfc_return_by_reference (expr2->symtree->n.sym) + && expr2->symtree->n.sym->result->attr.dimension)); + + ss = gfc_walk_expr (expr1); + assert (ss != gfc_ss_terminator); + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + se.want_pointer = 1; + + gfc_conv_array_parameter (&se, expr1, ss, 0); + + se.direct_byref = 1; + se.ss = gfc_walk_expr (expr2); + assert (se.ss != gfc_ss_terminator); + gfc_conv_function_expr (&se, expr2); + gfc_add_expr_to_block (&se.pre, se.expr); + gfc_add_block_to_block (&se.pre, &se.post); + + return gfc_finish_block (&se.pre); +} + + +/* Translate an assignment. Most of the code is concerned with + setting up the scalarizer. */ + +tree +gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2) +{ + gfc_se lse; + gfc_se rse; + gfc_ss *lss; + gfc_ss *lss_section; + gfc_ss *rss; + gfc_loopinfo loop; + tree tmp; + stmtblock_t block; + stmtblock_t body; + + /* Special case a single function returning an array. */ + if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0) + { + tmp = gfc_trans_arrayfunc_assign (expr1, expr2); + if (tmp) + return tmp; + } + + /* Assignment of the form lhs = rhs. */ + gfc_start_block (&block); + + gfc_init_se (&lse, NULL); + gfc_init_se (&rse, NULL); + + /* Walk the lhs. */ + lss = gfc_walk_expr (expr1); + rss = NULL; + if (lss != gfc_ss_terminator) + { + /* The assignment needs scalarization. */ + lss_section = lss; + + /* Find a non-scalar SS from the lhs. */ + while (lss_section != gfc_ss_terminator + && lss_section->type != GFC_SS_SECTION) + lss_section = lss_section->next; + + assert (lss_section != gfc_ss_terminator); + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + + /* Walk the rhs. */ + rss = gfc_walk_expr (expr2); + if (rss == gfc_ss_terminator) + { + /* The rhs is scalar. Add a ss for the expression. */ + rss = gfc_get_ss (); + rss->next = gfc_ss_terminator; + rss->type = GFC_SS_SCALAR; + rss->expr = expr2; + } + /* Associate the SS with the loop. */ + gfc_add_ss_to_loop (&loop, lss); + gfc_add_ss_to_loop (&loop, rss); + + /* Calculate the bounds of the scalarization. */ + gfc_conv_ss_startstride (&loop); + /* Resolve any data dependencies in the statement. */ + gfc_conv_resolve_dependencies (&loop, lss_section, rss); + /* Setup the scalarizing loops. */ + gfc_conv_loop_setup (&loop); + + /* Setup the gfc_se structures. */ + gfc_copy_loopinfo_to_se (&lse, &loop); + gfc_copy_loopinfo_to_se (&rse, &loop); + + rse.ss = rss; + gfc_mark_ss_chain_used (rss, 1); + if (loop.temp_ss == NULL) + { + lse.ss = lss; + gfc_mark_ss_chain_used (lss, 1); + } + else + { + lse.ss = loop.temp_ss; + gfc_mark_ss_chain_used (lss, 3); + gfc_mark_ss_chain_used (loop.temp_ss, 3); + } + + /* Start the scalarized loop body. */ + gfc_start_scalarized_body (&loop, &body); + } + else + gfc_init_block (&body); + + /* Translate the expression. */ + gfc_conv_expr (&rse, expr2); + + if (lss != gfc_ss_terminator && loop.temp_ss != NULL) + { + gfc_conv_tmp_array_ref (&lse); + gfc_advance_se_ss_chain (&lse); + } + else + gfc_conv_expr (&lse, expr1); + + tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type); + gfc_add_expr_to_block (&body, tmp); + + if (lss == gfc_ss_terminator) + { + /* Use the scalar assignment as is. */ + gfc_add_block_to_block (&block, &body); + } + else + { + if (lse.ss != gfc_ss_terminator) + abort (); + if (rse.ss != gfc_ss_terminator) + abort (); + + if (loop.temp_ss != NULL) + { + gfc_trans_scalarized_loop_boundary (&loop, &body); + + /* We need to copy the temporary to the actual lhs. */ + gfc_init_se (&lse, NULL); + gfc_init_se (&rse, NULL); + gfc_copy_loopinfo_to_se (&lse, &loop); + gfc_copy_loopinfo_to_se (&rse, &loop); + + rse.ss = loop.temp_ss; + lse.ss = lss; + + gfc_conv_tmp_array_ref (&rse); + gfc_advance_se_ss_chain (&rse); + gfc_conv_expr (&lse, expr1); + + if (lse.ss != gfc_ss_terminator) + abort (); + + if (rse.ss != gfc_ss_terminator) + abort (); + + tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type); + gfc_add_expr_to_block (&body, tmp); + } + /* Generate the copying loops. */ + gfc_trans_scalarizing_loops (&loop, &body); + + /* Wrap the whole thing up. */ + gfc_add_block_to_block (&block, &loop.pre); + gfc_add_block_to_block (&block, &loop.post); + + gfc_cleanup_loop (&loop); + } + + return gfc_finish_block (&block); +} + +tree +gfc_trans_assign (gfc_code * code) +{ + return gfc_trans_assignment (code->expr, code->expr2); +} diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c new file mode 100644 index 00000000000..fb3ceb2f6b1 --- /dev/null +++ b/gcc/fortran/trans-intrinsic.c @@ -0,0 +1,3003 @@ +/* Intrinsic translation + Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + and Steven Bosscher <s.bosscher@student.tudelft.nl> + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include <stdio.h> +#include <string.h> +#include "ggc.h" +#include "toplev.h" +#include "real.h" +#include "tree-simple.h" +#include "flags.h" +#include <gmp.h> +#include <assert.h> +#include "gfortran.h" +#include "intrinsic.h" +#include "trans.h" +#include "trans-const.h" +#include "trans-types.h" +#include "trans-array.h" +#include "defaults.h" +/* Only for gfc_trans_assign and gfc_trans_pointer_assign. */ +#include "trans-stmt.h" + +/* This maps fortran intrinsic math functions to external library or GCC + builtin functions. */ +typedef struct gfc_intrinsic_map_t GTY(()) +{ + /* The explicit enum is required to work around inadequacies in the + garbage collection/gengtype parsing mechanism. */ + enum gfc_generic_isym_id id; + + /* Enum value from the "language-independent", aka C-centric, part + of gcc, or END_BUILTINS of no such value set. */ + /* ??? There are now complex variants in builtins.def, though we + don't currently do anything with them. */ + enum built_in_function code4; + enum built_in_function code8; + + /* True if the naming pattern is to prepend "c" for complex and + append "f" for kind=4. False if the naming pattern is to + prepend "_gfortran_" and append "[rc][48]". */ + bool libm_name; + + /* True if a complex version of the function exists. */ + bool complex_available; + + /* True if the function should be marked const. */ + bool is_constant; + + /* The base library name of this function. */ + const char *name; + + /* Cache decls created for the various operand types. */ + tree real4_decl; + tree real8_decl; + tree complex4_decl; + tree complex8_decl; +} +gfc_intrinsic_map_t; + +/* ??? The NARGS==1 hack here is based on the fact that (c99 at least) + defines complex variants of all of the entries in mathbuiltins.def + except for atan2. */ +#define DEFINE_MATH_BUILTIN(ID, NAME, NARGS) \ + { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, true, \ + NARGS == 1, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, + +#define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \ + { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, true, HAVE_COMPLEX, true, \ + NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE } + +#define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \ + { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, false, HAVE_COMPLEX, true, \ + NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE } + +static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] = +{ + /* Functions built into gcc itself. */ +#include "mathbuiltins.def" + + /* Functions in libm. */ + /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the + pattern for other mathbuiltins.def entries. At present we have no + optimizations for this in the common sources. */ + LIBM_FUNCTION (SCALE, "scalbn", false), + + /* Functions in libgfortran. */ + LIBF_FUNCTION (FRACTION, "fraction", false), + LIBF_FUNCTION (NEAREST, "nearest", false), + LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false), + + /* End the list. */ + LIBF_FUNCTION (NONE, NULL, false) +}; +#undef DEFINE_MATH_BUILTIN +#undef LIBM_FUNCTION +#undef LIBF_FUNCTION + +/* Structure for storing components of a floating number to be used by + elemental functions to manipulate reals. */ +typedef struct +{ + tree arg; /* Variable tree to view convert to integer. */ + tree expn; /* Variable tree to save exponent. */ + tree frac; /* Variable tree to save fraction. */ + tree smask; /* Constant tree of sign's mask. */ + tree emask; /* Constant tree of exponent's mask. */ + tree fmask; /* Constant tree of fraction's mask. */ + tree edigits; /* Constant tree of bit numbers of exponent. */ + tree fdigits; /* Constant tree of bit numbers of fraction. */ + tree f1; /* Constant tree of the f1 defined in the real model. */ + tree bias; /* Constant tree of the bias of exponent in the memory. */ + tree type; /* Type tree of arg1. */ + tree mtype; /* Type tree of integer type. Kind is that of arg1. */ +} +real_compnt_info; + + +/* Evaluate the arguments to an intrinsic function. */ + +static tree +gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr) +{ + gfc_actual_arglist *actual; + tree args; + gfc_se argse; + + args = NULL_TREE; + for (actual = expr->value.function.actual; actual; actual = actual->next) + { + /* Skip ommitted optional arguments. */ + if (!actual->expr) + continue; + + /* Evaluate the parameter. This will substitute scalarized + references automatically. */ + gfc_init_se (&argse, se); + + if (actual->expr->ts.type == BT_CHARACTER) + { + gfc_conv_expr (&argse, actual->expr); + gfc_conv_string_parameter (&argse); + args = gfc_chainon_list (args, argse.string_length); + } + else + gfc_conv_expr_val (&argse, actual->expr); + + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + args = gfc_chainon_list (args, argse.expr); + } + return args; +} + + +/* Conversions between different types are output by the frontend as + intrinsic functions. We implement these directly with inline code. */ + +static void +gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr) +{ + tree type; + tree arg; + + /* Evaluate the argument. */ + type = gfc_typenode_for_spec (&expr->ts); + assert (expr->value.function.actual->expr); + arg = gfc_conv_intrinsic_function_args (se, expr); + arg = TREE_VALUE (arg); + + /* Conversion from complex to non-complex involves taking the real + component of the value. */ + if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE + && expr->ts.type != BT_COMPLEX) + { + tree artype; + + artype = TREE_TYPE (TREE_TYPE (arg)); + arg = build1 (REALPART_EXPR, artype, arg); + } + + se->expr = convert (type, arg); +} + + +/* This is needed because the gcc backend only implements FIX_TRUNC_EXPR + TRUNC(x) = INT(x) <= x ? INT(x) : INT(x) - 1 + Similarly for CEILING. */ + +static tree +build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up) +{ + tree tmp; + tree cond; + tree argtype; + tree intval; + + argtype = TREE_TYPE (arg); + arg = gfc_evaluate_now (arg, pblock); + + intval = convert (type, arg); + intval = gfc_evaluate_now (intval, pblock); + + tmp = convert (argtype, intval); + cond = build (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg); + + tmp = build (up ? PLUS_EXPR : MINUS_EXPR, type, intval, integer_one_node); + tmp = build (COND_EXPR, type, cond, intval, tmp); + return tmp; +} + + +/* This is needed because the gcc backend only implements FIX_TRUNC_EXPR + NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)). */ + +static tree +build_round_expr (stmtblock_t * pblock, tree arg, tree type) +{ + tree tmp; + tree cond; + tree neg; + tree pos; + tree argtype; + REAL_VALUE_TYPE r; + + argtype = TREE_TYPE (arg); + arg = gfc_evaluate_now (arg, pblock); + + real_from_string (&r, "0.5"); + pos = build_real (argtype, r); + + real_from_string (&r, "-0.5"); + neg = build_real (argtype, r); + + tmp = gfc_build_const (argtype, integer_zero_node); + cond = fold (build (GT_EXPR, boolean_type_node, arg, tmp)); + + tmp = fold (build (COND_EXPR, argtype, cond, pos, neg)); + tmp = fold (build (PLUS_EXPR, argtype, arg, tmp)); + return fold (build1 (FIX_TRUNC_EXPR, type, tmp)); +} + + +/* Convert a real to an integer using a specific rounding mode. + Ideally we would just build the corresponding GENERIC node, + however the RTL expander only actually supports FIX_TRUNC_EXPR. */ + +static tree +build_fix_expr (stmtblock_t * pblock, tree arg, tree type, int op) +{ + switch (op) + { + case FIX_FLOOR_EXPR: + return build_fixbound_expr (pblock, arg, type, 0); + break; + + case FIX_CEIL_EXPR: + return build_fixbound_expr (pblock, arg, type, 1); + break; + + case FIX_ROUND_EXPR: + return build_round_expr (pblock, arg, type); + + default: + return build1 (op, type, arg); + } +} + + +/* Round a real value using the specified rounding mode. + We use a temporary integer of that same kind size as the result. + Values larger than can be represented by this kind are unchanged, as + will not be accurate enough to represent the rounding. + huge = HUGE (KIND (a)) + aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a + */ + +static void +gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, int op) +{ + tree type; + tree itype; + tree arg; + tree tmp; + tree cond; + mpf_t huge; + int n; + int kind; + + kind = expr->ts.kind; + + n = END_BUILTINS; + /* We have builtin functions for some cases. */ + switch (op) + { + case FIX_ROUND_EXPR: + switch (kind) + { + case 4: + n = BUILT_IN_ROUNDF; + break; + + case 8: + n = BUILT_IN_ROUND; + break; + } + break; + + case FIX_FLOOR_EXPR: + switch (kind) + { + case 4: + n = BUILT_IN_FLOORF; + break; + + case 8: + n = BUILT_IN_FLOOR; + break; + } + } + + /* Evaluate the argument. */ + assert (expr->value.function.actual->expr); + arg = gfc_conv_intrinsic_function_args (se, expr); + + /* Use a builtin function if one exists. */ + if (n != END_BUILTINS) + { + tmp = built_in_decls[n]; + se->expr = gfc_build_function_call (tmp, arg); + return; + } + + /* This code is probably redundant, but we'll keep it lying around just + in case. */ + type = gfc_typenode_for_spec (&expr->ts); + arg = TREE_VALUE (arg); + arg = gfc_evaluate_now (arg, &se->pre); + + /* Test if the value is too large to handle sensibly. */ + mpf_init (huge); + n = gfc_validate_kind (BT_INTEGER, kind); + mpf_set_z (huge, gfc_integer_kinds[n].huge); + tmp = gfc_conv_mpf_to_tree (huge, kind); + cond = build (LT_EXPR, boolean_type_node, arg, tmp); + + mpf_neg (huge, huge); + tmp = gfc_conv_mpf_to_tree (huge, kind); + tmp = build (GT_EXPR, boolean_type_node, arg, tmp); + cond = build (TRUTH_AND_EXPR, boolean_type_node, cond, tmp); + itype = gfc_get_int_type (kind); + + tmp = build_fix_expr (&se->pre, arg, itype, op); + tmp = convert (type, tmp); + se->expr = build (COND_EXPR, type, cond, tmp, arg); +} + + +/* Convert to an integer using the specified rounding mode. */ + +static void +gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, int op) +{ + tree type; + tree arg; + + /* Evaluate the argument. */ + type = gfc_typenode_for_spec (&expr->ts); + assert (expr->value.function.actual->expr); + arg = gfc_conv_intrinsic_function_args (se, expr); + arg = TREE_VALUE (arg); + + if (TREE_CODE (TREE_TYPE (arg)) == INTEGER_TYPE) + { + /* Conversion to a different integer kind. */ + se->expr = convert (type, arg); + } + else + { + /* Conversion from complex to non-complex involves taking the real + component of the value. */ + if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE + && expr->ts.type != BT_COMPLEX) + { + tree artype; + + artype = TREE_TYPE (TREE_TYPE (arg)); + arg = build1 (REALPART_EXPR, artype, arg); + } + + se->expr = build_fix_expr (&se->pre, arg, type, op); + } +} + + +/* Get the imaginary component of a value. */ + +static void +gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr) +{ + tree arg; + + arg = gfc_conv_intrinsic_function_args (se, expr); + arg = TREE_VALUE (arg); + se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg); +} + + +/* Get the complex conjugate of a value. */ + +static void +gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr) +{ + tree arg; + + arg = gfc_conv_intrinsic_function_args (se, expr); + arg = TREE_VALUE (arg); + se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg); +} + + +/* Initialize function decls for library functions. The external functions + are created as required. Builtin functions are added here. */ + +void +gfc_build_intrinsic_lib_fndecls (void) +{ + gfc_intrinsic_map_t *m; + + /* Add GCC builtin functions. */ + for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++) + { + if (m->code4 != END_BUILTINS) + m->real4_decl = built_in_decls[m->code4]; + if (m->code8 != END_BUILTINS) + m->real8_decl = built_in_decls[m->code8]; + } +} + + +/* Create a fndecl for a simple intrinsic library function. */ + +static tree +gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr) +{ + tree type; + tree argtypes; + tree fndecl; + gfc_actual_arglist *actual; + tree *pdecl; + gfc_typespec *ts; + char name[GFC_MAX_SYMBOL_LEN + 3]; + + ts = &expr->ts; + if (ts->type == BT_REAL) + { + switch (ts->kind) + { + case 4: + pdecl = &m->real4_decl; + break; + case 8: + pdecl = &m->real8_decl; + break; + default: + abort (); + } + } + else if (ts->type == BT_COMPLEX) + { + if (!m->complex_available) + abort (); + + switch (ts->kind) + { + case 4: + pdecl = &m->complex4_decl; + break; + case 8: + pdecl = &m->complex8_decl; + break; + default: + abort (); + } + } + else + abort (); + + if (*pdecl) + return *pdecl; + + if (m->libm_name) + { + if (ts->kind != 4 && ts->kind != 8) + abort (); + snprintf (name, sizeof (name), "%s%s%s", + ts->type == BT_COMPLEX ? "c" : "", + m->name, + ts->kind == 4 ? "f" : ""); + } + else + { + snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name, + ts->type == BT_COMPLEX ? 'c' : 'r', + ts->kind); + } + + argtypes = NULL_TREE; + for (actual = expr->value.function.actual; actual; actual = actual->next) + { + type = gfc_typenode_for_spec (&actual->expr->ts); + argtypes = gfc_chainon_list (argtypes, type); + } + argtypes = gfc_chainon_list (argtypes, void_type_node); + type = build_function_type (gfc_typenode_for_spec (ts), argtypes); + fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type); + + /* Mark the decl as external. */ + DECL_EXTERNAL (fndecl) = 1; + TREE_PUBLIC (fndecl) = 1; + + /* Mark it __attribute__((const)), if possible. */ + TREE_READONLY (fndecl) = m->is_constant; + + rest_of_decl_compilation (fndecl, NULL, 1, 0); + + (*pdecl) = fndecl; + return fndecl; +} + + +/* Convert an intrinsic function into an external or builtin call. */ + +static void +gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr) +{ + gfc_intrinsic_map_t *m; + tree args; + tree fndecl; + gfc_generic_isym_id id; + + id = expr->value.function.isym->generic_id; + /* Find the entry for this function. */ + for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++) + { + if (id == m->id) + break; + } + + if (m->id == GFC_ISYM_NONE) + { + internal_error ("Intrinsic function %s(%d) not recognized", + expr->value.function.name, id); + } + + /* Get the decl and generate the call. */ + args = gfc_conv_intrinsic_function_args (se, expr); + fndecl = gfc_get_intrinsic_lib_fndecl (m, expr); + se->expr = gfc_build_function_call (fndecl, args); +} + +/* Generate code for EXPONENT(X) intrinsic function. */ + +static void +gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr) +{ + tree args, fndecl; + gfc_expr *a1; + + args = gfc_conv_intrinsic_function_args (se, expr); + + a1 = expr->value.function.actual->expr; + switch (a1->ts.kind) + { + case 4: + fndecl = gfor_fndecl_math_exponent4; + break; + case 8: + fndecl = gfor_fndecl_math_exponent8; + break; + default: + abort (); + } + + se->expr = gfc_build_function_call (fndecl, args); +} + +/* Evaluate a single upper or lower bound. */ +/* TODO: bound intrinsic generates way too much unneccessary code. */ + +static void +gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) +{ + gfc_actual_arglist *arg; + gfc_actual_arglist *arg2; + tree desc; + tree type; + tree bound; + tree tmp; + tree cond; + gfc_se argse; + gfc_ss *ss; + int i; + + gfc_init_se (&argse, NULL); + arg = expr->value.function.actual; + arg2 = arg->next; + + if (se->ss) + { + /* Create an implicit second parameter from the loop variable. */ + assert (!arg2->expr); + assert (se->loop->dimen == 1); + assert (se->ss->expr == expr); + gfc_advance_se_ss_chain (se); + bound = se->loop->loopvar[0]; + bound = fold (build (MINUS_EXPR, gfc_array_index_type, bound, + se->loop->from[0])); + } + else + { + /* use the passed argument. */ + assert (arg->next->expr); + gfc_init_se (&argse, NULL); + gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type); + gfc_add_block_to_block (&se->pre, &argse.pre); + bound = argse.expr; + /* Convert from one based to zero based. */ + bound = fold (build (MINUS_EXPR, gfc_array_index_type, bound, + integer_one_node)); + } + + /* TODO: don't re-evaluate the descriptor on each iteration. */ + /* Get a descriptor for the first parameter. */ + ss = gfc_walk_expr (arg->expr); + assert (ss != gfc_ss_terminator); + argse.want_pointer = 0; + gfc_conv_expr_descriptor (&argse, arg->expr, ss); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + + desc = argse.expr; + + if (INTEGER_CST_P (bound)) + { + assert (TREE_INT_CST_HIGH (bound) == 0); + i = TREE_INT_CST_LOW (bound); + assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))); + } + else + { + if (flag_bounds_check) + { + bound = gfc_evaluate_now (bound, &se->pre); + cond = fold (build (LT_EXPR, boolean_type_node, bound, + integer_zero_node)); + tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; + tmp = fold (build (GE_EXPR, boolean_type_node, bound, tmp)); + cond = fold(build (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp)); + gfc_trans_runtime_check (cond, gfc_strconst_fault, &se->pre); + } + } + + if (upper) + se->expr = gfc_conv_descriptor_ubound(desc, bound); + else + se->expr = gfc_conv_descriptor_lbound(desc, bound); + + type = gfc_typenode_for_spec (&expr->ts); + se->expr = convert (type, se->expr); +} + + +static void +gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) +{ + tree args; + tree val; + tree fndecl; + + args = gfc_conv_intrinsic_function_args (se, expr); + assert (args && TREE_CHAIN (args) == NULL_TREE); + val = TREE_VALUE (args); + + switch (expr->value.function.actual->expr->ts.type) + { + case BT_INTEGER: + case BT_REAL: + se->expr = build1 (ABS_EXPR, TREE_TYPE (val), val); + break; + + case BT_COMPLEX: + switch (expr->ts.kind) + { + case 4: + fndecl = gfor_fndecl_math_cabsf; + break; + case 8: + fndecl = gfor_fndecl_math_cabs; + break; + default: + abort (); + } + se->expr = gfc_build_function_call (fndecl, args); + break; + + default: + abort (); + } +} + + +/* Create a complex value from one or two real components. */ + +static void +gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both) +{ + tree arg; + tree real; + tree imag; + tree type; + + type = gfc_typenode_for_spec (&expr->ts); + arg = gfc_conv_intrinsic_function_args (se, expr); + real = convert (TREE_TYPE (type), TREE_VALUE (arg)); + if (both) + imag = convert (TREE_TYPE (type), TREE_VALUE (TREE_CHAIN (arg))); + else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg))) == COMPLEX_TYPE) + { + arg = TREE_VALUE (arg); + imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg); + imag = convert (TREE_TYPE (type), imag); + } + else + imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node); + + se->expr = fold (build (COMPLEX_EXPR, type, real, imag)); +} + +/* Remainder function MOD(A, P) = A - INT(A / P) * P. + MODULO(A, P) = (A==0 .or. !(A>0 .xor. P>0))? MOD(A,P):MOD(A,P)+P. */ +/* TODO: MOD(x, 0) */ + +static void +gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) +{ + tree arg; + tree arg2; + tree type; + tree itype; + tree tmp; + tree zero; + tree test; + tree test2; + mpf_t huge; + int n; + + arg = gfc_conv_intrinsic_function_args (se, expr); + arg2 = TREE_VALUE (TREE_CHAIN (arg)); + arg = TREE_VALUE (arg); + type = TREE_TYPE (arg); + + switch (expr->ts.type) + { + case BT_INTEGER: + /* Integer case is easy, we've got a builtin op. */ + se->expr = build (TRUNC_MOD_EXPR, type, arg, arg2); + break; + + case BT_REAL: + /* Real values we have to do the hard way. */ + arg = gfc_evaluate_now (arg, &se->pre); + arg2 = gfc_evaluate_now (arg2, &se->pre); + + tmp = build (RDIV_EXPR, type, arg, arg2); + /* Test if the value is too large to handle sensibly. */ + mpf_init (huge); + n = gfc_validate_kind (BT_INTEGER, expr->ts.kind); + mpf_set_z (huge, gfc_integer_kinds[n].huge); + test = gfc_conv_mpf_to_tree (huge, expr->ts.kind); + test2 = build (LT_EXPR, boolean_type_node, tmp, test); + + mpf_neg (huge, huge); + test = gfc_conv_mpf_to_tree (huge, expr->ts.kind); + test = build (GT_EXPR, boolean_type_node, tmp, test); + test2 = build (TRUTH_AND_EXPR, boolean_type_node, test, test2); + + itype = gfc_get_int_type (expr->ts.kind); + tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR); + tmp = convert (type, tmp); + tmp = build (COND_EXPR, type, test2, tmp, arg); + tmp = build (MULT_EXPR, type, tmp, arg2); + se->expr = build (MINUS_EXPR, type, arg, tmp); + break; + + default: + abort (); + } + + if (modulo) + { + zero = gfc_build_const (type, integer_zero_node); + /* Build !(A > 0 .xor. P > 0). */ + test = build (GT_EXPR, boolean_type_node, arg, zero); + test2 = build (GT_EXPR, boolean_type_node, arg2, zero); + test = build (TRUTH_XOR_EXPR, boolean_type_node, test, test2); + test = build1 (TRUTH_NOT_EXPR, boolean_type_node, test); + /* Build (A == 0) .or. !(A > 0 .xor. P > 0). */ + test2 = build (EQ_EXPR, boolean_type_node, arg, zero); + test = build (TRUTH_OR_EXPR, boolean_type_node, test, test2); + + se->expr = build (COND_EXPR, type, test, se->expr, + build (PLUS_EXPR, type, se->expr, arg2)); + } +} + +/* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */ + +static void +gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr) +{ + tree arg; + tree arg2; + tree val; + tree tmp; + tree type; + tree zero; + + arg = gfc_conv_intrinsic_function_args (se, expr); + arg2 = TREE_VALUE (TREE_CHAIN (arg)); + arg = TREE_VALUE (arg); + type = TREE_TYPE (arg); + + val = build (MINUS_EXPR, type, arg, arg2); + val = gfc_evaluate_now (val, &se->pre); + + zero = gfc_build_const (type, integer_zero_node); + tmp = build (LE_EXPR, boolean_type_node, val, zero); + se->expr = build (COND_EXPR, type, tmp, zero, val); +} + + +/* SIGN(A, B) is absolute value of A times sign of B. + The real value versions use library functions to ensure the correct + handling of negative zero. Integer case implemented as: + SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a + */ + +static void +gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr) +{ + tree tmp; + tree arg; + tree arg2; + tree type; + tree zero; + tree testa; + tree testb; + + + arg = gfc_conv_intrinsic_function_args (se, expr); + if (expr->ts.type == BT_REAL) + { + switch (expr->ts.kind) + { + case 4: + tmp = gfor_fndecl_math_sign4; + break; + case 8: + tmp = gfor_fndecl_math_sign8; + break; + default: + abort (); + } + se->expr = gfc_build_function_call (tmp, arg); + return; + } + + arg2 = TREE_VALUE (TREE_CHAIN (arg)); + arg = TREE_VALUE (arg); + type = TREE_TYPE (arg); + zero = gfc_build_const (type, integer_zero_node); + + testa = fold (build (GE_EXPR, boolean_type_node, arg, zero)); + testb = fold (build (GE_EXPR, boolean_type_node, arg2, zero)); + tmp = fold (build (TRUTH_XOR_EXPR, boolean_type_node, testa, testb)); + se->expr = fold (build (COND_EXPR, type, tmp, + build1 (NEGATE_EXPR, type, arg), arg)); +} + + +/* Test for the presence of an optional argument. */ + +static void +gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr) +{ + gfc_expr *arg; + + arg = expr->value.function.actual->expr; + assert (arg->expr_type == EXPR_VARIABLE); + se->expr = gfc_conv_expr_present (arg->symtree->n.sym); + se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr); +} + + +/* Calculate the double precision product of two single precision values. */ + +static void +gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr) +{ + tree arg; + tree arg2; + tree type; + + arg = gfc_conv_intrinsic_function_args (se, expr); + arg2 = TREE_VALUE (TREE_CHAIN (arg)); + arg = TREE_VALUE (arg); + + /* Convert the args to double precision before multiplying. */ + type = gfc_typenode_for_spec (&expr->ts); + arg = convert (type, arg); + arg2 = convert (type, arg2); + se->expr = build (MULT_EXPR, type, arg, arg2); +} + + +/* Return a length one character string containing an ascii character. */ + +static void +gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr) +{ + tree arg; + tree var; + tree type; + + arg = gfc_conv_intrinsic_function_args (se, expr); + arg = TREE_VALUE (arg); + + /* We currently don't support character types != 1. */ + assert (expr->ts.kind == 1); + type = gfc_character1_type_node; + var = gfc_create_var (type, "char"); + + arg = convert (type, arg); + gfc_add_modify_expr (&se->pre, var, arg); + se->expr = gfc_build_addr_expr (build_pointer_type (type), var); + se->string_length = integer_one_node; +} + + +/* Get the minimum/maximum value of all the parameters. + minmax (a1, a2, a3, ...) + { + if (a2 .op. a1) + mvar = a2; + else + mvar = a1; + if (a3 .op. mvar) + mvar = a3; + ... + return mvar + } + */ + +/* TODO: Mismatching types can occur when specific names are used. + These should be handled during resolution. */ +static void +gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op) +{ + tree limit; + tree tmp; + tree mvar; + tree val; + tree thencase; + tree elsecase; + tree arg; + tree type; + + arg = gfc_conv_intrinsic_function_args (se, expr); + type = gfc_typenode_for_spec (&expr->ts); + + limit = TREE_VALUE (arg); + if (TREE_TYPE (limit) != type) + limit = convert (type, limit); + /* Only evaluate the argument once. */ + if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit)) + limit = gfc_evaluate_now(limit, &se->pre); + + mvar = gfc_create_var (type, "M"); + elsecase = build_v (MODIFY_EXPR, mvar, limit); + for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg)) + { + val = TREE_VALUE (arg); + if (TREE_TYPE (val) != type) + val = convert (type, val); + + /* Only evaluate the argument once. */ + if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val)) + val = gfc_evaluate_now(val, &se->pre); + + thencase = build_v (MODIFY_EXPR, mvar, convert (type, val)); + + tmp = build (op, boolean_type_node, val, limit); + tmp = build_v (COND_EXPR, tmp, thencase, elsecase); + gfc_add_expr_to_block (&se->pre, tmp); + elsecase = build_empty_stmt (); + limit = mvar; + } + se->expr = mvar; +} + + +/* Create a symbol node for this intrinsic. The symbol form the frontend + is for the generic name. */ + +static gfc_symbol * +gfc_get_symbol_for_expr (gfc_expr * expr) +{ + gfc_symbol *sym; + + /* TODO: Add symbols for intrinsic function to the global namespace. */ + assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5); + sym = gfc_new_symbol (expr->value.function.name, NULL); + + sym->ts = expr->ts; + sym->attr.external = 1; + sym->attr.function = 1; + sym->attr.always_explicit = 1; + sym->attr.proc = PROC_INTRINSIC; + sym->attr.flavor = FL_PROCEDURE; + sym->result = sym; + if (expr->rank > 0) + { + sym->attr.dimension = 1; + sym->as = gfc_get_array_spec (); + sym->as->type = AS_ASSUMED_SHAPE; + sym->as->rank = expr->rank; + } + + /* TODO: proper argument lists for external intrinsics. */ + return sym; +} + +/* Generate a call to an external intrinsic function. */ +static void +gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) +{ + gfc_symbol *sym; + + assert (!se->ss || se->ss->expr == expr); + + if (se->ss) + assert (expr->rank > 0); + else + assert (expr->rank == 0); + + sym = gfc_get_symbol_for_expr (expr); + gfc_conv_function_call (se, sym, expr->value.function.actual); + gfc_free (sym); +} + +/* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR. + Implemented as + any(a) + { + forall (i=...) + if (a[i] != 0) + return 1 + end forall + return 0 + } + all(a) + { + forall (i=...) + if (a[i] == 0) + return 0 + end forall + return 1 + } + */ +static void +gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op) +{ + tree resvar; + stmtblock_t block; + stmtblock_t body; + tree type; + tree tmp; + tree found; + gfc_loopinfo loop; + gfc_actual_arglist *actual; + gfc_ss *arrayss; + gfc_se arrayse; + tree exit_label; + + if (se->ss) + { + gfc_conv_intrinsic_funcall (se, expr); + return; + } + + actual = expr->value.function.actual; + type = gfc_typenode_for_spec (&expr->ts); + /* Initialize the result. */ + resvar = gfc_create_var (type, "test"); + if (op == EQ_EXPR) + tmp = convert (type, boolean_true_node); + else + tmp = convert (type, boolean_false_node); + gfc_add_modify_expr (&se->pre, resvar, tmp); + + /* Walk the arguments. */ + arrayss = gfc_walk_expr (actual->expr); + assert (arrayss != gfc_ss_terminator); + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + exit_label = gfc_build_label_decl (NULL_TREE); + TREE_USED (exit_label) = 1; + gfc_add_ss_to_loop (&loop, arrayss); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop); + + gfc_mark_ss_chain_used (arrayss, 1); + /* Generate the loop body. */ + gfc_start_scalarized_body (&loop, &body); + + /* If the condition matches then set the return value. */ + gfc_start_block (&block); + if (op == EQ_EXPR) + tmp = convert (type, boolean_false_node); + else + tmp = convert (type, boolean_true_node); + gfc_add_modify_expr (&block, resvar, tmp); + + /* And break out of the loop. */ + tmp = build1_v (GOTO_EXPR, exit_label); + gfc_add_expr_to_block (&block, tmp); + + found = gfc_finish_block (&block); + + /* Check this element. */ + gfc_init_se (&arrayse, NULL); + gfc_copy_loopinfo_to_se (&arrayse, &loop); + arrayse.ss = arrayss; + gfc_conv_expr_val (&arrayse, actual->expr); + + gfc_add_block_to_block (&body, &arrayse.pre); + tmp = build (op, boolean_type_node, arrayse.expr, integer_zero_node); + tmp = build_v (COND_EXPR, tmp, found, build_empty_stmt ()); + gfc_add_expr_to_block (&body, tmp); + gfc_add_block_to_block (&body, &arrayse.post); + + gfc_trans_scalarizing_loops (&loop, &body); + + /* Add the exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&loop.pre, tmp); + + gfc_add_block_to_block (&se->pre, &loop.pre); + gfc_add_block_to_block (&se->pre, &loop.post); + gfc_cleanup_loop (&loop); + + se->expr = resvar; +} + +/* COUNT(A) = Number of true elements in A. */ +static void +gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr) +{ + tree resvar; + tree type; + stmtblock_t body; + tree tmp; + gfc_loopinfo loop; + gfc_actual_arglist *actual; + gfc_ss *arrayss; + gfc_se arrayse; + + if (se->ss) + { + gfc_conv_intrinsic_funcall (se, expr); + return; + } + + actual = expr->value.function.actual; + + type = gfc_typenode_for_spec (&expr->ts); + /* Initialize the result. */ + resvar = gfc_create_var (type, "count"); + gfc_add_modify_expr (&se->pre, resvar, integer_zero_node); + + /* Walk the arguments. */ + arrayss = gfc_walk_expr (actual->expr); + assert (arrayss != gfc_ss_terminator); + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, arrayss); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop); + + gfc_mark_ss_chain_used (arrayss, 1); + /* Generate the loop body. */ + gfc_start_scalarized_body (&loop, &body); + + tmp = build (PLUS_EXPR, TREE_TYPE (resvar), resvar, integer_one_node); + tmp = build_v (MODIFY_EXPR, resvar, tmp); + + gfc_init_se (&arrayse, NULL); + gfc_copy_loopinfo_to_se (&arrayse, &loop); + arrayse.ss = arrayss; + gfc_conv_expr_val (&arrayse, actual->expr); + tmp = build_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ()); + + gfc_add_block_to_block (&body, &arrayse.pre); + gfc_add_expr_to_block (&body, tmp); + gfc_add_block_to_block (&body, &arrayse.post); + + gfc_trans_scalarizing_loops (&loop, &body); + + gfc_add_block_to_block (&se->pre, &loop.pre); + gfc_add_block_to_block (&se->pre, &loop.post); + gfc_cleanup_loop (&loop); + + se->expr = resvar; +} + +/* Inline implementation of the sum and product intrinsics. */ +static void +gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op) +{ + tree resvar; + tree type; + stmtblock_t body; + stmtblock_t block; + tree tmp; + gfc_loopinfo loop; + gfc_actual_arglist *actual; + gfc_ss *arrayss; + gfc_ss *maskss; + gfc_se arrayse; + gfc_se maskse; + gfc_expr *arrayexpr; + gfc_expr *maskexpr; + + if (se->ss) + { + gfc_conv_intrinsic_funcall (se, expr); + return; + } + + type = gfc_typenode_for_spec (&expr->ts); + /* Initialize the result. */ + resvar = gfc_create_var (type, "val"); + if (op == PLUS_EXPR) + tmp = gfc_build_const (type, integer_zero_node); + else + tmp = gfc_build_const (type, integer_one_node); + + gfc_add_modify_expr (&se->pre, resvar, tmp); + + /* Walk the arguments. */ + actual = expr->value.function.actual; + arrayexpr = actual->expr; + arrayss = gfc_walk_expr (arrayexpr); + assert (arrayss != gfc_ss_terminator); + + actual = actual->next->next; + assert (actual); + maskexpr = actual->expr; + if (maskexpr) + { + maskss = gfc_walk_expr (maskexpr); + assert (maskss != gfc_ss_terminator); + } + else + maskss = NULL; + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, arrayss); + if (maskss) + gfc_add_ss_to_loop (&loop, maskss); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop); + + gfc_mark_ss_chain_used (arrayss, 1); + if (maskss) + gfc_mark_ss_chain_used (maskss, 1); + /* Generate the loop body. */ + gfc_start_scalarized_body (&loop, &body); + + /* If we have a mask, only add this element if the mask is set. */ + if (maskss) + { + gfc_init_se (&maskse, NULL); + gfc_copy_loopinfo_to_se (&maskse, &loop); + maskse.ss = maskss; + gfc_conv_expr_val (&maskse, maskexpr); + gfc_add_block_to_block (&body, &maskse.pre); + + gfc_start_block (&block); + } + else + gfc_init_block (&block); + + /* Do the actual summation/product. */ + gfc_init_se (&arrayse, NULL); + gfc_copy_loopinfo_to_se (&arrayse, &loop); + arrayse.ss = arrayss; + gfc_conv_expr_val (&arrayse, arrayexpr); + gfc_add_block_to_block (&block, &arrayse.pre); + + tmp = build (op, type, resvar, arrayse.expr); + gfc_add_modify_expr (&block, resvar, tmp); + gfc_add_block_to_block (&block, &arrayse.post); + + if (maskss) + { + /* We enclose the above in if (mask) {...} . */ + tmp = gfc_finish_block (&block); + + tmp = build_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); + } + else + tmp = gfc_finish_block (&block); + gfc_add_expr_to_block (&body, tmp); + + gfc_trans_scalarizing_loops (&loop, &body); + gfc_add_block_to_block (&se->pre, &loop.pre); + gfc_add_block_to_block (&se->pre, &loop.post); + gfc_cleanup_loop (&loop); + + se->expr = resvar; +} + +static void +gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) +{ + stmtblock_t body; + stmtblock_t block; + stmtblock_t ifblock; + tree limit; + tree type; + tree tmp; + tree ifbody; + tree cond; + gfc_loopinfo loop; + gfc_actual_arglist *actual; + gfc_ss *arrayss; + gfc_ss *maskss; + gfc_se arrayse; + gfc_se maskse; + gfc_expr *arrayexpr; + gfc_expr *maskexpr; + tree pos; + int n; + + if (se->ss) + { + gfc_conv_intrinsic_funcall (se, expr); + return; + } + + /* Initialize the result. */ + pos = gfc_create_var (gfc_array_index_type, "pos"); + type = gfc_typenode_for_spec (&expr->ts); + + /* Walk the arguments. */ + actual = expr->value.function.actual; + arrayexpr = actual->expr; + arrayss = gfc_walk_expr (arrayexpr); + assert (arrayss != gfc_ss_terminator); + + actual = actual->next->next; + assert (actual); + maskexpr = actual->expr; + if (maskexpr) + { + maskss = gfc_walk_expr (maskexpr); + assert (maskss != gfc_ss_terminator); + } + else + maskss = NULL; + + limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit"); + n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind); + switch (arrayexpr->ts.type) + { + case BT_REAL: + tmp = gfc_conv_mpf_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind); + break; + + case BT_INTEGER: + tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, + arrayexpr->ts.kind); + break; + + default: + abort (); + } + + /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval. */ + if (op == GT_EXPR) + tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp)); + gfc_add_modify_expr (&se->pre, limit, tmp); + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, arrayss); + if (maskss) + gfc_add_ss_to_loop (&loop, maskss); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop); + + assert (loop.dimen == 1); + + /* Initialize the position to the first element. If the array has zero + size we need to return zero. Otherwise use the first element of the + array, in case all elements are equal to the limit. + ie. pos = (ubound >= lbound) ? lbound, lbound - 1; */ + tmp = fold (build (MINUS_EXPR, gfc_array_index_type, + loop.from[0], integer_one_node)); + cond = fold (build (GE_EXPR, boolean_type_node, + loop.to[0], loop.from[0])); + tmp = fold (build (COND_EXPR, gfc_array_index_type, cond, + loop.from[0], tmp)); + gfc_add_modify_expr (&loop.pre, pos, tmp); + + gfc_mark_ss_chain_used (arrayss, 1); + if (maskss) + gfc_mark_ss_chain_used (maskss, 1); + /* Generate the loop body. */ + gfc_start_scalarized_body (&loop, &body); + + /* If we have a mask, only check this element if the mask is set. */ + if (maskss) + { + gfc_init_se (&maskse, NULL); + gfc_copy_loopinfo_to_se (&maskse, &loop); + maskse.ss = maskss; + gfc_conv_expr_val (&maskse, maskexpr); + gfc_add_block_to_block (&body, &maskse.pre); + + gfc_start_block (&block); + } + else + gfc_init_block (&block); + + /* Compare with the current limit. */ + gfc_init_se (&arrayse, NULL); + gfc_copy_loopinfo_to_se (&arrayse, &loop); + arrayse.ss = arrayss; + gfc_conv_expr_val (&arrayse, arrayexpr); + gfc_add_block_to_block (&block, &arrayse.pre); + + /* We do the following if this is a more extreme value. */ + gfc_start_block (&ifblock); + + /* Assign the value to the limit... */ + gfc_add_modify_expr (&ifblock, limit, arrayse.expr); + + /* Remember where we are. */ + gfc_add_modify_expr (&ifblock, pos, loop.loopvar[0]); + + ifbody = gfc_finish_block (&ifblock); + + /* If it is a more extreme value. */ + tmp = build (op, boolean_type_node, arrayse.expr, limit); + tmp = build_v (COND_EXPR, tmp, ifbody, build_empty_stmt ()); + gfc_add_expr_to_block (&block, tmp); + + if (maskss) + { + /* We enclose the above in if (mask) {...}. */ + tmp = gfc_finish_block (&block); + + tmp = build_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); + } + else + tmp = gfc_finish_block (&block); + gfc_add_expr_to_block (&body, tmp); + + gfc_trans_scalarizing_loops (&loop, &body); + + gfc_add_block_to_block (&se->pre, &loop.pre); + gfc_add_block_to_block (&se->pre, &loop.post); + gfc_cleanup_loop (&loop); + + /* Return a value in the range 1..SIZE(array). */ + tmp = fold (build (MINUS_EXPR, gfc_array_index_type, loop.from[0], + integer_one_node)); + tmp = fold (build (MINUS_EXPR, gfc_array_index_type, pos, tmp)); + /* And convert to the required type. */ + se->expr = convert (type, tmp); +} + +static void +gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op) +{ + tree limit; + tree type; + tree tmp; + tree ifbody; + stmtblock_t body; + stmtblock_t block; + gfc_loopinfo loop; + gfc_actual_arglist *actual; + gfc_ss *arrayss; + gfc_ss *maskss; + gfc_se arrayse; + gfc_se maskse; + gfc_expr *arrayexpr; + gfc_expr *maskexpr; + int n; + + if (se->ss) + { + gfc_conv_intrinsic_funcall (se, expr); + return; + } + + type = gfc_typenode_for_spec (&expr->ts); + /* Initialize the result. */ + limit = gfc_create_var (type, "limit"); + n = gfc_validate_kind (expr->ts.type, expr->ts.kind); + switch (expr->ts.type) + { + case BT_REAL: + tmp = gfc_conv_mpf_to_tree (gfc_real_kinds[n].huge, expr->ts.kind); + break; + + case BT_INTEGER: + tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind); + break; + + default: + abort (); + } + + /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval. */ + if (op == GT_EXPR) + tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp)); + gfc_add_modify_expr (&se->pre, limit, tmp); + + /* Walk the arguments. */ + actual = expr->value.function.actual; + arrayexpr = actual->expr; + arrayss = gfc_walk_expr (arrayexpr); + assert (arrayss != gfc_ss_terminator); + + actual = actual->next->next; + assert (actual); + maskexpr = actual->expr; + if (maskexpr) + { + maskss = gfc_walk_expr (maskexpr); + assert (maskss != gfc_ss_terminator); + } + else + maskss = NULL; + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, arrayss); + if (maskss) + gfc_add_ss_to_loop (&loop, maskss); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop); + + gfc_mark_ss_chain_used (arrayss, 1); + if (maskss) + gfc_mark_ss_chain_used (maskss, 1); + /* Generate the loop body. */ + gfc_start_scalarized_body (&loop, &body); + + /* If we have a mask, only add this element if the mask is set. */ + if (maskss) + { + gfc_init_se (&maskse, NULL); + gfc_copy_loopinfo_to_se (&maskse, &loop); + maskse.ss = maskss; + gfc_conv_expr_val (&maskse, maskexpr); + gfc_add_block_to_block (&body, &maskse.pre); + + gfc_start_block (&block); + } + else + gfc_init_block (&block); + + /* Compare with the current limit. */ + gfc_init_se (&arrayse, NULL); + gfc_copy_loopinfo_to_se (&arrayse, &loop); + arrayse.ss = arrayss; + gfc_conv_expr_val (&arrayse, arrayexpr); + gfc_add_block_to_block (&block, &arrayse.pre); + + /* Assign the value to the limit... */ + ifbody = build_v (MODIFY_EXPR, limit, arrayse.expr); + + /* If it is a more extreme value. */ + tmp = build (op, boolean_type_node, arrayse.expr, limit); + tmp = build_v (COND_EXPR, tmp, ifbody, build_empty_stmt ()); + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, &arrayse.post); + + tmp = gfc_finish_block (&block); + if (maskss) + { + /* We enclose the above in if (mask) {...}. */ + tmp = build_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); + } + gfc_add_expr_to_block (&body, tmp); + + gfc_trans_scalarizing_loops (&loop, &body); + + gfc_add_block_to_block (&se->pre, &loop.pre); + gfc_add_block_to_block (&se->pre, &loop.post); + gfc_cleanup_loop (&loop); + + se->expr = limit; +} + +/* BTEST (i, pos) = (i & (1 << pos)) != 0. */ +static void +gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr) +{ + tree arg; + tree arg2; + tree type; + tree tmp; + + arg = gfc_conv_intrinsic_function_args (se, expr); + arg2 = TREE_VALUE (TREE_CHAIN (arg)); + arg = TREE_VALUE (arg); + type = TREE_TYPE (arg); + + tmp = build (LSHIFT_EXPR, type, integer_one_node, arg2); + tmp = build (BIT_AND_EXPR, type, arg, tmp); + tmp = fold (build (NE_EXPR, boolean_type_node, tmp, integer_zero_node)); + type = gfc_typenode_for_spec (&expr->ts); + se->expr = convert (type, tmp); +} + +/* Generate code to perform the specified operation. */ +static void +gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op) +{ + tree arg; + tree arg2; + tree type; + + arg = gfc_conv_intrinsic_function_args (se, expr); + arg2 = TREE_VALUE (TREE_CHAIN (arg)); + arg = TREE_VALUE (arg); + type = TREE_TYPE (arg); + + se->expr = fold (build (op, type, arg, arg2)); +} + +/* Bitwise not. */ +static void +gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr) +{ + tree arg; + + arg = gfc_conv_intrinsic_function_args (se, expr); + arg = TREE_VALUE (arg); + + se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg); +} + +/* Set or clear a single bit. */ +static void +gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set) +{ + tree arg; + tree arg2; + tree type; + tree tmp; + int op; + + arg = gfc_conv_intrinsic_function_args (se, expr); + arg2 = TREE_VALUE (TREE_CHAIN (arg)); + arg = TREE_VALUE (arg); + type = TREE_TYPE (arg); + + tmp = fold (build (LSHIFT_EXPR, type, integer_one_node, arg2)); + if (set) + op = BIT_IOR_EXPR; + else + { + op = BIT_AND_EXPR; + tmp = fold (build1 (BIT_NOT_EXPR, type, tmp)); + } + se->expr = fold (build (op, type, arg, tmp)); +} + +/* Extract a sequence of bits. + IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */ +static void +gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr) +{ + tree arg; + tree arg2; + tree arg3; + tree type; + tree tmp; + tree mask; + + arg = gfc_conv_intrinsic_function_args (se, expr); + arg2 = TREE_CHAIN (arg); + arg3 = TREE_VALUE (TREE_CHAIN (arg2)); + arg = TREE_VALUE (arg); + arg2 = TREE_VALUE (arg2); + type = TREE_TYPE (arg); + + mask = build_int_2 (-1, ~(unsigned HOST_WIDE_INT) 0); + mask = build (LSHIFT_EXPR, type, mask, arg3); + mask = build1 (BIT_NOT_EXPR, type, mask); + + tmp = build (RSHIFT_EXPR, type, arg, arg2); + + se->expr = fold (build (BIT_AND_EXPR, type, tmp, mask)); +} + +/* ISHFT (I, SHIFT) = (shift >= 0) ? i << shift : i >> -shift. */ +static void +gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr) +{ + tree arg; + tree arg2; + tree type; + tree tmp; + tree lshift; + tree rshift; + + arg = gfc_conv_intrinsic_function_args (se, expr); + arg2 = TREE_VALUE (TREE_CHAIN (arg)); + arg = TREE_VALUE (arg); + type = TREE_TYPE (arg); + + /* Left shift if positive. */ + lshift = build (LSHIFT_EXPR, type, arg, arg2); + + /* Right shift if negative. This will perform an arithmetic shift as + we are dealing with signed integers. Section 13.5.7 allows this. */ + tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2); + rshift = build (RSHIFT_EXPR, type, arg, tmp); + + tmp = build (GT_EXPR, boolean_type_node, arg2, integer_zero_node); + rshift = build (COND_EXPR, type, tmp, lshift, rshift); + + /* Do nothing if shift == 0. */ + tmp = build (EQ_EXPR, boolean_type_node, arg2, integer_zero_node); + se->expr = build (COND_EXPR, type, tmp, arg, rshift); +} + +/* Circular shift. AKA rotate or barrel shift. */ +static void +gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) +{ + tree arg; + tree arg2; + tree arg3; + tree type; + tree tmp; + tree lrot; + tree rrot; + + arg = gfc_conv_intrinsic_function_args (se, expr); + arg2 = TREE_CHAIN (arg); + arg3 = TREE_CHAIN (arg2); + if (arg3) + { + /* Use a library function for the 3 parameter version. */ + type = TREE_TYPE (TREE_VALUE (arg)); + /* Convert all args to the same type otherwise we need loads of library + functions. SIZE and SHIFT cannot have values > BIT_SIZE (I) so the + conversion is safe. */ + tmp = convert (type, TREE_VALUE (arg2)); + TREE_VALUE (arg2) = tmp; + tmp = convert (type, TREE_VALUE (arg3)); + TREE_VALUE (arg3) = tmp; + + switch (expr->ts.kind) + { + case 4: + tmp = gfor_fndecl_math_ishftc4; + break; + case 8: + tmp = gfor_fndecl_math_ishftc8; + break; + default: + abort (); + } + se->expr = gfc_build_function_call (tmp, arg); + return; + } + arg = TREE_VALUE (arg); + arg2 = TREE_VALUE (arg2); + type = TREE_TYPE (arg); + + /* Rotate left if positive. */ + lrot = build (LROTATE_EXPR, type, arg, arg2); + + /* Rotate right if negative. */ + tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2); + rrot = build (RROTATE_EXPR, type, arg, tmp); + + tmp = build (GT_EXPR, boolean_type_node, arg2, integer_zero_node); + rrot = build (COND_EXPR, type, tmp, lrot, rrot); + + /* Do nothing if shift == 0. */ + tmp = build (EQ_EXPR, boolean_type_node, arg2, integer_zero_node); + se->expr = build (COND_EXPR, type, tmp, arg, rrot); +} + +/* The length of a character string. */ +static void +gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) +{ + tree len; + tree type; + tree decl; + gfc_symbol *sym; + gfc_se argse; + gfc_expr *arg; + + assert (!se->ss); + + arg = expr->value.function.actual->expr; + + type = gfc_typenode_for_spec (&expr->ts); + switch (arg->expr_type) + { + case EXPR_CONSTANT: + len = build_int_2 (arg->value.character.length, 0); + break; + + default: + if (arg->expr_type == EXPR_VARIABLE && arg->ref == NULL) + { + sym = arg->symtree->n.sym; + decl = gfc_get_symbol_decl (sym); + if (decl == current_function_decl && sym->attr.function + && (sym->result == sym)) + decl = gfc_get_fake_result_decl (sym); + + len = sym->ts.cl->backend_decl; + assert (len); + } + else + { + /* Anybody stupid enough to do this deserves inefficient code. */ + gfc_init_se (&argse, se); + gfc_conv_expr (&argse, arg); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + len = argse.string_length; + } + break; + } + se->expr = convert (type, len); +} + +/* The length of a character string not including trailing blanks. */ +static void +gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr) +{ + tree args; + tree type; + + args = gfc_conv_intrinsic_function_args (se, expr); + type = gfc_typenode_for_spec (&expr->ts); + se->expr = gfc_build_function_call (gfor_fndecl_string_len_trim, args); + se->expr = convert (type, se->expr); +} + + +/* Returns the starting position of a substring within a string. */ + +static void +gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr) +{ + tree args; + tree back; + tree type; + tree tmp; + + args = gfc_conv_intrinsic_function_args (se, expr); + type = gfc_typenode_for_spec (&expr->ts); + tmp = gfc_advance_chain (args, 3); + if (TREE_CHAIN (tmp) == NULL_TREE) + { + back = convert (gfc_logical4_type_node, integer_one_node); + back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE); + TREE_CHAIN (tmp) = back; + } + else + { + back = TREE_CHAIN (tmp); + TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back)); + } + + se->expr = gfc_build_function_call (gfor_fndecl_string_index, args); + se->expr = convert (type, se->expr); +} + +/* The ascii value for a single character. */ +static void +gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr) +{ + tree arg; + tree type; + + arg = gfc_conv_intrinsic_function_args (se, expr); + arg = TREE_VALUE (TREE_CHAIN (arg)); + assert (POINTER_TYPE_P (TREE_TYPE (arg))); + arg = build1 (NOP_EXPR, pchar_type_node, arg); + type = gfc_typenode_for_spec (&expr->ts); + + se->expr = gfc_build_indirect_ref (arg); + se->expr = convert (type, se->expr); +} + + +/* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */ + +static void +gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr) +{ + tree arg; + tree tsource; + tree fsource; + tree mask; + tree type; + + arg = gfc_conv_intrinsic_function_args (se, expr); + tsource = TREE_VALUE (arg); + arg = TREE_CHAIN (arg); + fsource = TREE_VALUE (arg); + arg = TREE_CHAIN (arg); + mask = TREE_VALUE (arg); + + type = TREE_TYPE (tsource); + se->expr = fold (build (COND_EXPR, type, mask, tsource, fsource)); +} + + +static void +gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) +{ + gfc_actual_arglist *actual; + tree args; + tree type; + tree fndecl; + gfc_se argse; + gfc_ss *ss; + + gfc_init_se (&argse, NULL); + actual = expr->value.function.actual; + + ss = gfc_walk_expr (actual->expr); + assert (ss != gfc_ss_terminator); + argse.want_pointer = 1; + gfc_conv_expr_descriptor (&argse, actual->expr, ss); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + args = gfc_chainon_list (NULL_TREE, argse.expr); + + actual = actual->next; + if (actual->expr) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type); + gfc_add_block_to_block (&se->pre, &argse.pre); + args = gfc_chainon_list (args, argse.expr); + fndecl = gfor_fndecl_size1; + } + else + fndecl = gfor_fndecl_size0; + + se->expr = gfc_build_function_call (fndecl, args); + type = gfc_typenode_for_spec (&expr->ts); + se->expr = convert (type, se->expr); +} + + +/* Intrinsic string comparison functions. */ + + static void +gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op) +{ + tree type; + tree args; + + args = gfc_conv_intrinsic_function_args (se, expr); + /* Build a call for the comparison. */ + se->expr = gfc_build_function_call (gfor_fndecl_compare_string, args); + + type = gfc_typenode_for_spec (&expr->ts); + se->expr = build (op, type, se->expr, integer_zero_node); +} + +/* Generate a call to the adjustl/adjustr library function. */ +static void +gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl) +{ + tree args; + tree len; + tree type; + tree var; + tree tmp; + + args = gfc_conv_intrinsic_function_args (se, expr); + len = TREE_VALUE (args); + + type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args))); + var = gfc_conv_string_tmp (se, type, len); + args = tree_cons (NULL_TREE, var, args); + + tmp = gfc_build_function_call (fndecl, args); + gfc_add_expr_to_block (&se->pre, tmp); + se->expr = var; + se->string_length = len; +} + + +/* Scalar transfer statement. + TRANSFER (source, mold) = *(typeof<mould> *)&source */ + +static void +gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) +{ + gfc_actual_arglist *arg; + gfc_se argse; + tree type; + tree ptr; + gfc_ss *ss; + + assert (!se->ss); + + /* Get a pointer to the source. */ + arg = expr->value.function.actual; + ss = gfc_walk_expr (arg->expr); + gfc_init_se (&argse, NULL); + if (ss == gfc_ss_terminator) + gfc_conv_expr_reference (&argse, arg->expr); + else + gfc_conv_array_parameter (&argse, arg->expr, ss, 1); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + ptr = argse.expr; + + arg = arg->next; + type = gfc_typenode_for_spec (&expr->ts); + ptr = convert (build_pointer_type (type), ptr); + if (expr->ts.type == BT_CHARACTER) + { + gfc_init_se (&argse, NULL); + gfc_conv_expr (&argse, arg->expr); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + se->expr = ptr; + se->string_length = argse.string_length; + } + else + { + se->expr = gfc_build_indirect_ref (ptr); + } +} + + +/* Generate code for the ALLOCATED intrinsic. + Generate inline code that directly check the address of the argument. */ + +static void +gfc_conv_allocated (gfc_se *se, gfc_expr *expr) +{ + gfc_actual_arglist *arg1; + gfc_se arg1se; + gfc_ss *ss1; + tree tmp; + + gfc_init_se (&arg1se, NULL); + arg1 = expr->value.function.actual; + ss1 = gfc_walk_expr (arg1->expr); + arg1se.descriptor_only = 1; + gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); + + tmp = gfc_conv_descriptor_data (arg1se.expr); + tmp = build (NE_EXPR, boolean_type_node, tmp, null_pointer_node); + se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); +} + + +/* Generate code for the ASSOCIATED intrinsic. + If both POINTER and TARGET are arrays, generate a call to library function + _gfor_associated, and pass descriptors of POINTER and TARGET to it. + In other cases, generate inline code that directly compare the address of + POINTER with the address of TARGET. */ + +static void +gfc_conv_associated (gfc_se *se, gfc_expr *expr) +{ + gfc_actual_arglist *arg1; + gfc_actual_arglist *arg2; + gfc_se arg1se; + gfc_se arg2se; + tree tmp2; + tree tmp; + tree args, fndecl; + gfc_ss *ss1, *ss2; + + gfc_init_se (&arg1se, NULL); + gfc_init_se (&arg2se, NULL); + arg1 = expr->value.function.actual; + arg2 = arg1->next; + ss1 = gfc_walk_expr (arg1->expr); + + if (!arg2->expr) + { + /* No optional target. */ + if (ss1 == gfc_ss_terminator) + { + /* A pointer to a scalar. */ + arg1se.want_pointer = 1; + gfc_conv_expr (&arg1se, arg1->expr); + tmp2 = arg1se.expr; + } + else + { + /* A pointer to an array. */ + arg1se.descriptor_only = 1; + gfc_conv_expr_lhs (&arg1se, arg1->expr); + tmp2 = gfc_conv_descriptor_data (arg1se.expr); + } + tmp = build (NE_EXPR, boolean_type_node, tmp2, null_pointer_node); + se->expr = tmp; + } + else + { + /* An optional target. */ + ss2 = gfc_walk_expr (arg2->expr); + if (ss1 == gfc_ss_terminator) + { + /* A pointer to a scalar. */ + assert (ss2 == gfc_ss_terminator); + arg1se.want_pointer = 1; + gfc_conv_expr (&arg1se, arg1->expr); + arg2se.want_pointer = 1; + gfc_conv_expr (&arg2se, arg2->expr); + tmp = build (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr); + se->expr = tmp; + } + else + { + /* A pointer to an array, call library function _gfor_associated. */ + assert (ss2 != gfc_ss_terminator); + args = NULL_TREE; + arg1se.want_pointer = 1; + gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); + args = gfc_chainon_list (args, arg1se.expr); + arg2se.want_pointer = 1; + gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2); + gfc_add_block_to_block (&se->pre, &arg2se.pre); + gfc_add_block_to_block (&se->post, &arg2se.post); + args = gfc_chainon_list (args, arg2se.expr); + fndecl = gfor_fndecl_associated; + se->expr = gfc_build_function_call (fndecl, args); + } + } + se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr); +} + + +/* Scan a string for any one of the characters in a set of characters. */ + +static void +gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr) +{ + tree args; + tree back; + tree type; + tree tmp; + + args = gfc_conv_intrinsic_function_args (se, expr); + type = gfc_typenode_for_spec (&expr->ts); + tmp = gfc_advance_chain (args, 3); + if (TREE_CHAIN (tmp) == NULL_TREE) + { + back = convert (gfc_logical4_type_node, integer_one_node); + back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE); + TREE_CHAIN (tmp) = back; + } + else + { + back = TREE_CHAIN (tmp); + TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back)); + } + + se->expr = gfc_build_function_call (gfor_fndecl_string_scan, args); + se->expr = convert (type, se->expr); +} + + +/* Verify that a set of characters contains all the characters in a string + by indentifying the position of the first character in a string of + characters that does not appear in a given set of characters. */ + +static void +gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr) +{ + tree args; + tree back; + tree type; + tree tmp; + + args = gfc_conv_intrinsic_function_args (se, expr); + type = gfc_typenode_for_spec (&expr->ts); + tmp = gfc_advance_chain (args, 3); + if (TREE_CHAIN (tmp) == NULL_TREE) + { + back = convert (gfc_logical4_type_node, integer_one_node); + back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE); + TREE_CHAIN (tmp) = back; + } + else + { + back = TREE_CHAIN (tmp); + TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back)); + } + + se->expr = gfc_build_function_call (gfor_fndecl_string_verify, args); + se->expr = convert (type, se->expr); +} + +/* Prepare components and related information of a real number which is + the first argument of a elemental functions to manipulate reals. */ + +static +void prepare_arg_info (gfc_se * se, gfc_expr * expr, + real_compnt_info * rcs, int all) +{ + tree arg; + tree masktype; + tree tmp; + tree wbits; + tree one; + tree exponent, fraction; + int n; + gfc_expr *a1; + + if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT) + gfc_todo_error ("Non-IEEE floating format"); + + assert (expr->expr_type == EXPR_FUNCTION); + + arg = gfc_conv_intrinsic_function_args (se, expr); + arg = TREE_VALUE (arg); + rcs->type = TREE_TYPE (arg); + + /* Force arg'type to integer by unaffected convert */ + a1 = expr->value.function.actual->expr; + masktype = gfc_get_int_type (a1->ts.kind); + rcs->mtype = masktype; + tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg); + arg = gfc_create_var (masktype, "arg"); + gfc_add_modify_expr(&se->pre, arg, tmp); + rcs->arg = arg; + + /* Caculate the numbers of bits of exponent, fraction and word */ + n = gfc_validate_kind (a1->ts.type, a1->ts.kind); + tmp = build_int_2 (gfc_real_kinds[n].digits - 1, 0); + rcs->fdigits = convert (masktype, tmp); + wbits = build_int_2 (TYPE_PRECISION (rcs->type) - 1, 0); + wbits = convert (masktype, wbits); + rcs->edigits = fold (build (MINUS_EXPR, masktype, wbits, tmp)); + + /* Form masks for exponent/fraction/sign */ + one = gfc_build_const (masktype, integer_one_node); + rcs->smask = fold (build (LSHIFT_EXPR, masktype, one, wbits)); + rcs->f1 = fold (build (LSHIFT_EXPR, masktype, one, rcs->fdigits)); + rcs->emask = fold (build (MINUS_EXPR, masktype, rcs->smask, rcs->f1)); + rcs->fmask = fold (build (MINUS_EXPR, masktype, rcs->f1, one)); + /* Form bias. */ + tmp = fold (build (MINUS_EXPR, masktype, rcs->edigits, one)); + tmp = fold (build (LSHIFT_EXPR, masktype, one, tmp)); + rcs->bias = fold (build (MINUS_EXPR, masktype, tmp ,one)); + + if (all) + { + /* exponent, and fraction */ + tmp = build (BIT_AND_EXPR, masktype, arg, rcs->emask); + tmp = build (RSHIFT_EXPR, masktype, tmp, rcs->fdigits); + exponent = gfc_create_var (masktype, "exponent"); + gfc_add_modify_expr(&se->pre, exponent, tmp); + rcs->expn = exponent; + + tmp = build (BIT_AND_EXPR, masktype, arg, rcs->fmask); + fraction = gfc_create_var (masktype, "fraction"); + gfc_add_modify_expr(&se->pre, fraction, tmp); + rcs->frac = fraction; + } +} + +/* Build a call to __builtin_clz. */ + +static tree +call_builtin_clz (tree result_type, tree op0) +{ + tree fn, parms, call; + enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0)); + + if (op0_mode == TYPE_MODE (integer_type_node)) + fn = built_in_decls[BUILT_IN_CLZ]; + else if (op0_mode == TYPE_MODE (long_integer_type_node)) + fn = built_in_decls[BUILT_IN_CLZL]; + else if (op0_mode == TYPE_MODE (long_long_integer_type_node)) + fn = built_in_decls[BUILT_IN_CLZLL]; + else + abort (); + + parms = tree_cons (NULL, op0, NULL); + call = gfc_build_function_call (fn, parms); + + return convert (result_type, call); +} + +/* Generate code for SPACING (X) intrinsic function. We generate: + + t = expn - (BITS_OF_FRACTION) + res = t << (BITS_OF_FRACTION) + if (t < 0) + res = tiny(X) +*/ + +static void +gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr) +{ + tree arg; + tree masktype; + tree tmp, t1, cond; + tree tiny, zero; + tree fdigits; + real_compnt_info rcs; + + prepare_arg_info (se, expr, &rcs, 0); + arg = rcs.arg; + masktype = rcs.mtype; + fdigits = rcs.fdigits; + tiny = rcs.f1; + zero = gfc_build_const (masktype, integer_zero_node); + tmp = build (BIT_AND_EXPR, masktype, rcs.emask, arg); + tmp = build (RSHIFT_EXPR, masktype, tmp, fdigits); + tmp = build (MINUS_EXPR, masktype, tmp, fdigits); + cond = build (LE_EXPR, boolean_type_node, tmp, zero); + t1 = build (LSHIFT_EXPR, masktype, tmp, fdigits); + tmp = build (COND_EXPR, masktype, cond, tiny, t1); + tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp); + + se->expr = tmp; +} + +/* Generate code for RRSPACING (X) intrinsic function. We generate: + sedigits = edigits + 1; + if (expn == 0) + { + t1 = leadzero (frac); + frac = frac << (t1 + sedigits); + frac = frac >> (sedigits); + } + t = bias + BITS_OF_FRACTION_OF; + res = (t << BITS_OF_FRACTION_OF) | frac; +*/ + +static void +gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr) +{ + tree masktype; + tree tmp, t1, t2, cond; + tree one, zero; + tree fdigits, fraction; + real_compnt_info rcs; + + prepare_arg_info (se, expr, &rcs, 1); + masktype = rcs.mtype; + fdigits = rcs.fdigits; + fraction = rcs.frac; + one = gfc_build_const (masktype, integer_one_node); + zero = gfc_build_const (masktype, integer_zero_node); + t2 = build (PLUS_EXPR, masktype, rcs.edigits, one); + + t1 = call_builtin_clz (masktype, fraction); + tmp = build (PLUS_EXPR, masktype, t1, one); + tmp = build (LSHIFT_EXPR, masktype, fraction, tmp); + tmp = build (RSHIFT_EXPR, masktype, tmp, t2); + cond = build (EQ_EXPR, boolean_type_node, rcs.expn, zero); + fraction = build (COND_EXPR, masktype, cond, tmp, fraction); + + tmp = build (PLUS_EXPR, masktype, rcs.bias, fdigits); + tmp = build (LSHIFT_EXPR, masktype, tmp, fdigits); + tmp = build (BIT_IOR_EXPR, masktype, tmp, fraction); + + tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp); + se->expr = tmp; +} + +/* Generate code for SELECTED_INT_KIND (R) intrinsic function. */ + +static void +gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr) +{ + tree args; + + args = gfc_conv_intrinsic_function_args (se, expr); + args = TREE_VALUE (args); + args = gfc_build_addr_expr (NULL, args); + args = tree_cons (NULL_TREE, args, NULL_TREE); + se->expr = gfc_build_function_call (gfor_fndecl_si_kind, args); +} + +/* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */ + +static void +gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr) +{ + gfc_actual_arglist *actual; + tree args; + gfc_se argse; + + args = NULL_TREE; + for (actual = expr->value.function.actual; actual; actual = actual->next) + { + gfc_init_se (&argse, se); + + /* Pass a NULL pointer for an absent arg. */ + if (actual->expr == NULL) + argse.expr = null_pointer_node; + else + gfc_conv_expr_reference (&argse, actual->expr); + + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + args = gfc_chainon_list (args, argse.expr); + } + se->expr = gfc_build_function_call (gfor_fndecl_sr_kind, args); +} + + +/* Generate code for TRIM (A) intrinsic function. */ + +static void +gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) +{ + tree var; + tree len; + tree addr; + tree tmp; + tree arglist; + tree type; + tree cond; + + arglist = NULL_TREE; + + type = build_pointer_type (gfc_character1_type_node); + var = gfc_create_var (type, "pstr"); + addr = gfc_build_addr_expr (ppvoid_type_node, var); + len = gfc_create_var (gfc_int4_type_node, "len"); + + tmp = gfc_conv_intrinsic_function_args (se, expr); + arglist = gfc_chainon_list (arglist, gfc_build_addr_expr (NULL, len)); + arglist = gfc_chainon_list (arglist, addr); + arglist = chainon (arglist, tmp); + + tmp = gfc_build_function_call (gfor_fndecl_string_trim, arglist); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Free the temporary afterwards, if necessary. */ + cond = build (GT_EXPR, boolean_type_node, len, integer_zero_node); + arglist = gfc_chainon_list (NULL_TREE, var); + tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist); + tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ()); + gfc_add_expr_to_block (&se->post, tmp); + + se->expr = var; + se->string_length = len; +} + + +/* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */ + +static void +gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) +{ + tree tmp; + tree len; + tree args; + tree arglist; + tree ncopies; + tree var; + tree type; + + args = gfc_conv_intrinsic_function_args (se, expr); + len = TREE_VALUE (args); + tmp = gfc_advance_chain (args, 2); + ncopies = TREE_VALUE (tmp); + len = fold (build (MULT_EXPR, gfc_int4_type_node, len, ncopies)); + type = gfc_get_character_type (expr->ts.kind, expr->ts.cl); + var = gfc_conv_string_tmp (se, build_pointer_type (type), len); + + arglist = NULL_TREE; + arglist = gfc_chainon_list (arglist, var); + arglist = chainon (arglist, args); + tmp = gfc_build_function_call (gfor_fndecl_string_repeat, arglist); + gfc_add_expr_to_block (&se->pre, tmp); + + se->expr = var; + se->string_length = len; +} + + +/* Generate code for an intrinsic function. Some map directly to library + calls, others get special handling. In some cases the name of the function + used depends on the type specifiers. */ + +void +gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) +{ + gfc_intrinsic_sym *isym; + char *name; + int lib; + + isym = expr->value.function.isym; + + name = &expr->value.function.name[2]; + + if (expr->rank > 0) + { + lib = gfc_is_intrinsic_libcall (expr); + if (lib != 0) + { + if (lib == 1) + se->ignore_optional = 1; + gfc_conv_intrinsic_funcall (se, expr); + return; + } + } + + switch (expr->value.function.isym->generic_id) + { + case GFC_ISYM_NONE: + abort (); + + case GFC_ISYM_REPEAT: + gfc_conv_intrinsic_repeat (se, expr); + break; + + case GFC_ISYM_TRIM: + gfc_conv_intrinsic_trim (se, expr); + break; + + case GFC_ISYM_SI_KIND: + gfc_conv_intrinsic_si_kind (se, expr); + break; + + case GFC_ISYM_SR_KIND: + gfc_conv_intrinsic_sr_kind (se, expr); + break; + + case GFC_ISYM_EXPONENT: + gfc_conv_intrinsic_exponent (se, expr); + break; + + case GFC_ISYM_SPACING: + gfc_conv_intrinsic_spacing (se, expr); + break; + + case GFC_ISYM_RRSPACING: + gfc_conv_intrinsic_rrspacing (se, expr); + break; + + case GFC_ISYM_SCAN: + gfc_conv_intrinsic_scan (se, expr); + break; + + case GFC_ISYM_VERIFY: + gfc_conv_intrinsic_verify (se, expr); + break; + + case GFC_ISYM_ALLOCATED: + gfc_conv_allocated (se, expr); + break; + + case GFC_ISYM_ASSOCIATED: + gfc_conv_associated(se, expr); + break; + + case GFC_ISYM_ABS: + gfc_conv_intrinsic_abs (se, expr); + break; + + case GFC_ISYM_ADJUSTL: + gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl); + break; + + case GFC_ISYM_ADJUSTR: + gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr); + break; + + case GFC_ISYM_AIMAG: + gfc_conv_intrinsic_imagpart (se, expr); + break; + + case GFC_ISYM_AINT: + gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR); + break; + + case GFC_ISYM_ALL: + gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR); + break; + + case GFC_ISYM_ANINT: + gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR); + break; + + case GFC_ISYM_ANY: + gfc_conv_intrinsic_anyall (se, expr, NE_EXPR); + break; + + case GFC_ISYM_BTEST: + gfc_conv_intrinsic_btest (se, expr); + break; + + case GFC_ISYM_ACHAR: + case GFC_ISYM_CHAR: + gfc_conv_intrinsic_char (se, expr); + break; + + case GFC_ISYM_CONVERSION: + case GFC_ISYM_REAL: + case GFC_ISYM_LOGICAL: + case GFC_ISYM_DBLE: + gfc_conv_intrinsic_conversion (se, expr); + break; + + /* Integer conversions are handled seperately to make sure we get the + correct rounding mode. */ + case GFC_ISYM_INT: + gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR); + break; + + case GFC_ISYM_NINT: + gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR); + break; + + case GFC_ISYM_CEILING: + gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR); + break; + + case GFC_ISYM_FLOOR: + gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR); + break; + + case GFC_ISYM_MOD: + gfc_conv_intrinsic_mod (se, expr, 0); + break; + + case GFC_ISYM_MODULO: + gfc_conv_intrinsic_mod (se, expr, 1); + break; + + case GFC_ISYM_CMPLX: + gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1'); + break; + + case GFC_ISYM_CONJG: + gfc_conv_intrinsic_conjg (se, expr); + break; + + case GFC_ISYM_COUNT: + gfc_conv_intrinsic_count (se, expr); + break; + + case GFC_ISYM_DIM: + gfc_conv_intrinsic_dim (se, expr); + break; + + case GFC_ISYM_DPROD: + gfc_conv_intrinsic_dprod (se, expr); + break; + + case GFC_ISYM_IAND: + gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR); + break; + + case GFC_ISYM_IBCLR: + gfc_conv_intrinsic_singlebitop (se, expr, 0); + break; + + case GFC_ISYM_IBITS: + gfc_conv_intrinsic_ibits (se, expr); + break; + + case GFC_ISYM_IBSET: + gfc_conv_intrinsic_singlebitop (se, expr, 1); + break; + + case GFC_ISYM_IACHAR: + case GFC_ISYM_ICHAR: + /* We assume ASCII character sequence. */ + gfc_conv_intrinsic_ichar (se, expr); + break; + + case GFC_ISYM_IEOR: + gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR); + break; + + case GFC_ISYM_INDEX: + gfc_conv_intrinsic_index (se, expr); + break; + + case GFC_ISYM_IOR: + gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR); + break; + + case GFC_ISYM_ISHFT: + gfc_conv_intrinsic_ishft (se, expr); + break; + + case GFC_ISYM_ISHFTC: + gfc_conv_intrinsic_ishftc (se, expr); + break; + + case GFC_ISYM_LBOUND: + gfc_conv_intrinsic_bound (se, expr, 0); + break; + + case GFC_ISYM_LEN: + gfc_conv_intrinsic_len (se, expr); + break; + + case GFC_ISYM_LEN_TRIM: + gfc_conv_intrinsic_len_trim (se, expr); + break; + + case GFC_ISYM_LGE: + gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR); + break; + + case GFC_ISYM_LGT: + gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR); + break; + + case GFC_ISYM_LLE: + gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR); + break; + + case GFC_ISYM_LLT: + gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR); + break; + + case GFC_ISYM_MAX: + gfc_conv_intrinsic_minmax (se, expr, GT_EXPR); + break; + + case GFC_ISYM_MAXLOC: + gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR); + break; + + case GFC_ISYM_MAXVAL: + gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR); + break; + + case GFC_ISYM_MERGE: + gfc_conv_intrinsic_merge (se, expr); + break; + + case GFC_ISYM_MIN: + gfc_conv_intrinsic_minmax (se, expr, LT_EXPR); + break; + + case GFC_ISYM_MINLOC: + gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR); + break; + + case GFC_ISYM_MINVAL: + gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR); + break; + + case GFC_ISYM_NOT: + gfc_conv_intrinsic_not (se, expr); + break; + + case GFC_ISYM_PRESENT: + gfc_conv_intrinsic_present (se, expr); + break; + + case GFC_ISYM_PRODUCT: + gfc_conv_intrinsic_arith (se, expr, MULT_EXPR); + break; + + case GFC_ISYM_SIGN: + gfc_conv_intrinsic_sign (se, expr); + break; + + case GFC_ISYM_SIZE: + gfc_conv_intrinsic_size (se, expr); + break; + + case GFC_ISYM_SUM: + gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR); + break; + + case GFC_ISYM_TRANSFER: + gfc_conv_intrinsic_transfer (se, expr); + break; + + case GFC_ISYM_UBOUND: + gfc_conv_intrinsic_bound (se, expr, 1); + break; + + case GFC_ISYM_DOT_PRODUCT: + case GFC_ISYM_MATMUL: + gfc_conv_intrinsic_funcall (se, expr); + break; + + default: + gfc_conv_intrinsic_lib_function (se, expr); + break; + } +} + + +/* This generates code to execute before entering the scalarization loop. + Currently does nothing. */ + +void +gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss) +{ + switch (ss->expr->value.function.isym->generic_id) + { + case GFC_ISYM_UBOUND: + case GFC_ISYM_LBOUND: + break; + + default: + abort (); + break; + } +} + + +/* UBOUND and LBOUND intrinsics with one parameter are expanded into code + inside the scalarization loop. */ + +static gfc_ss * +gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr) +{ + gfc_ss *newss; + + /* The two argument version returns a scalar. */ + if (expr->value.function.actual->next->expr) + return ss; + + newss = gfc_get_ss (); + newss->type = GFC_SS_INTRINSIC; + newss->expr = expr; + newss->next = ss; + + return newss; +} + + +/* Walk an intrinsic array libcall. */ + +static gfc_ss * +gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr) +{ + gfc_ss *newss; + + assert (expr->rank > 0); + + newss = gfc_get_ss (); + newss->type = GFC_SS_FUNCTION; + newss->expr = expr; + newss->next = ss; + newss->data.info.dimen = expr->rank; + + return newss; +} + + +/* Returns nonzero if the specified intrinsic function call maps directly to a + an external library call. Should only be used for functions that return + arrays. */ + +int +gfc_is_intrinsic_libcall (gfc_expr * expr) +{ + assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym); + assert (expr->rank > 0); + + switch (expr->value.function.isym->generic_id) + { + case GFC_ISYM_ALL: + case GFC_ISYM_ANY: + case GFC_ISYM_COUNT: + case GFC_ISYM_MATMUL: + case GFC_ISYM_MAXLOC: + case GFC_ISYM_MAXVAL: + case GFC_ISYM_MINLOC: + case GFC_ISYM_MINVAL: + case GFC_ISYM_PRODUCT: + case GFC_ISYM_SUM: + case GFC_ISYM_SHAPE: + case GFC_ISYM_SPREAD: + case GFC_ISYM_TRANSPOSE: + /* Ignore absent optional parameters. */ + return 1; + + case GFC_ISYM_RESHAPE: + case GFC_ISYM_CSHIFT: + case GFC_ISYM_EOSHIFT: + case GFC_ISYM_PACK: + case GFC_ISYM_UNPACK: + /* Pass absent optional parameters. */ + return 2; + + default: + return 0; + } +} + +/* Walk an intrinsic function. */ +gfc_ss * +gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, + gfc_intrinsic_sym * isym) +{ + assert (isym); + + if (isym->elemental) + return gfc_walk_elemental_function_args (ss, expr, GFC_SS_SCALAR); + + if (expr->rank == 0) + return ss; + + if (gfc_is_intrinsic_libcall (expr)) + return gfc_walk_intrinsic_libfunc (ss, expr); + + /* Special cases. */ + switch (isym->generic_id) + { + case GFC_ISYM_LBOUND: + case GFC_ISYM_UBOUND: + return gfc_walk_intrinsic_bound (ss, expr); + + default: + /* This probably meant someone forgot to add an intrinsic to the above + list(s) when they implemented it, or something's gone horribly wrong. + */ + gfc_todo_error ("Scalarization of non-elemental intrinsic: %s", + expr->value.function.name); + } +} + +#include "gt-fortran-trans-intrinsic.h" diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c new file mode 100644 index 00000000000..d18bb794195 --- /dev/null +++ b/gcc/fortran/trans-io.c @@ -0,0 +1,1157 @@ +/* IO Code translation/library interface + Copyright (C) 2002, 2003 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "tree-simple.h" +#include <stdio.h> +#include "ggc.h" +#include "toplev.h" +#include "real.h" +#include <assert.h> +#include <gmp.h> +#include "gfortran.h" +#include "trans.h" +#include "trans-stmt.h" +#include "trans-array.h" +#include "trans-types.h" +#include "trans-const.h" + + +static GTY(()) tree gfc_pint4_type_node; + +/* Members of the ioparm structure. */ + +static GTY(()) tree ioparm_unit; +static GTY(()) tree ioparm_err; +static GTY(()) tree ioparm_end; +static GTY(()) tree ioparm_eor; +static GTY(()) tree ioparm_list_format; +static GTY(()) tree ioparm_library_return; +static GTY(()) tree ioparm_iostat; +static GTY(()) tree ioparm_exist; +static GTY(()) tree ioparm_opened; +static GTY(()) tree ioparm_number; +static GTY(()) tree ioparm_named; +static GTY(()) tree ioparm_rec; +static GTY(()) tree ioparm_nextrec; +static GTY(()) tree ioparm_size; +static GTY(()) tree ioparm_recl_in; +static GTY(()) tree ioparm_recl_out; +static GTY(()) tree ioparm_file; +static GTY(()) tree ioparm_file_len; +static GTY(()) tree ioparm_status; +static GTY(()) tree ioparm_status_len; +static GTY(()) tree ioparm_access; +static GTY(()) tree ioparm_access_len; +static GTY(()) tree ioparm_form; +static GTY(()) tree ioparm_form_len; +static GTY(()) tree ioparm_blank; +static GTY(()) tree ioparm_blank_len; +static GTY(()) tree ioparm_position; +static GTY(()) tree ioparm_position_len; +static GTY(()) tree ioparm_action; +static GTY(()) tree ioparm_action_len; +static GTY(()) tree ioparm_delim; +static GTY(()) tree ioparm_delim_len; +static GTY(()) tree ioparm_pad; +static GTY(()) tree ioparm_pad_len; +static GTY(()) tree ioparm_format; +static GTY(()) tree ioparm_format_len; +static GTY(()) tree ioparm_advance; +static GTY(()) tree ioparm_advance_len; +static GTY(()) tree ioparm_name; +static GTY(()) tree ioparm_name_len; +static GTY(()) tree ioparm_internal_unit; +static GTY(()) tree ioparm_internal_unit_len; +static GTY(()) tree ioparm_sequential; +static GTY(()) tree ioparm_sequential_len; +static GTY(()) tree ioparm_direct; +static GTY(()) tree ioparm_direct_len; +static GTY(()) tree ioparm_formatted; +static GTY(()) tree ioparm_formatted_len; +static GTY(()) tree ioparm_unformatted; +static GTY(()) tree ioparm_unformatted_len; +static GTY(()) tree ioparm_read; +static GTY(()) tree ioparm_read_len; +static GTY(()) tree ioparm_write; +static GTY(()) tree ioparm_write_len; +static GTY(()) tree ioparm_readwrite; +static GTY(()) tree ioparm_readwrite_len; +static GTY(()) tree ioparm_namelist_name; +static GTY(()) tree ioparm_namelist_name_len; +static GTY(()) tree ioparm_namelist_read_mode; + +/* The global I/O variables */ + +static GTY(()) tree ioparm_var; +static GTY(()) tree locus_file; +static GTY(()) tree locus_line; + + +/* Library I/O subroutines */ + +static GTY(()) tree iocall_read; +static GTY(()) tree iocall_read_done; +static GTY(()) tree iocall_write; +static GTY(()) tree iocall_write_done; +static GTY(()) tree iocall_x_integer; +static GTY(()) tree iocall_x_logical; +static GTY(()) tree iocall_x_character; +static GTY(()) tree iocall_x_real; +static GTY(()) tree iocall_x_complex; +static GTY(()) tree iocall_open; +static GTY(()) tree iocall_close; +static GTY(()) tree iocall_inquire; +static GTY(()) tree iocall_rewind; +static GTY(()) tree iocall_backspace; +static GTY(()) tree iocall_endfile; +static GTY(()) tree iocall_set_nml_val_int; +static GTY(()) tree iocall_set_nml_val_float; +static GTY(()) tree iocall_set_nml_val_char; +static GTY(()) tree iocall_set_nml_val_complex; +static GTY(()) tree iocall_set_nml_val_log; + +/* Variable for keeping track of what the last data transfer statement + was. Used for deciding which subroutine to call when the data + transfer is complete. */ +static enum { READ, WRITE } last_dt; + +#define ADD_FIELD(name, type) \ + ioparm_ ## name = gfc_add_field_to_struct \ + (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \ + get_identifier (stringize(name)), type) + +#define ADD_STRING(name) \ + ioparm_ ## name = gfc_add_field_to_struct \ + (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \ + get_identifier (stringize(name)), pchar_type_node); \ + ioparm_ ## name ## _len = gfc_add_field_to_struct \ + (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \ + get_identifier (stringize(name) "_len"), gfc_int4_type_node) + + +/* Create function decls for IO library functions. */ + +void +gfc_build_io_library_fndecls (void) +{ + tree ioparm_type; + + gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node); + +/* Build the st_parameter structure. Information associated with I/O + calls are transferred here. This must match the one defined in the + library exactly. */ + + ioparm_type = make_node (RECORD_TYPE); + TYPE_NAME (ioparm_type) = get_identifier ("_gfc_ioparm"); + + ADD_FIELD (unit, gfc_int4_type_node); + ADD_FIELD (err, gfc_int4_type_node); + ADD_FIELD (end, gfc_int4_type_node); + ADD_FIELD (eor, gfc_int4_type_node); + ADD_FIELD (list_format, gfc_int4_type_node); + ADD_FIELD (library_return, gfc_int4_type_node); + + ADD_FIELD (iostat, gfc_pint4_type_node); + ADD_FIELD (exist, gfc_pint4_type_node); + ADD_FIELD (opened, gfc_pint4_type_node); + ADD_FIELD (number, gfc_pint4_type_node); + ADD_FIELD (named, gfc_pint4_type_node); + ADD_FIELD (rec, gfc_pint4_type_node); + ADD_FIELD (nextrec, gfc_pint4_type_node); + ADD_FIELD (size, gfc_pint4_type_node); + + ADD_FIELD (recl_in, gfc_pint4_type_node); + ADD_FIELD (recl_out, gfc_pint4_type_node); + + ADD_STRING (file); + ADD_STRING (status); + + ADD_STRING (access); + ADD_STRING (form); + ADD_STRING (blank); + ADD_STRING (position); + ADD_STRING (action); + ADD_STRING (delim); + ADD_STRING (pad); + ADD_STRING (format); + ADD_STRING (advance); + ADD_STRING (name); + ADD_STRING (internal_unit); + ADD_STRING (sequential); + + ADD_STRING (direct); + ADD_STRING (formatted); + ADD_STRING (unformatted); + ADD_STRING (read); + ADD_STRING (write); + ADD_STRING (readwrite); + + ADD_STRING (namelist_name); + ADD_FIELD (namelist_read_mode, gfc_int4_type_node); + + gfc_finish_type (ioparm_type); + + ioparm_var = build_decl (VAR_DECL, get_identifier (PREFIX("ioparm")), + ioparm_type); + DECL_EXTERNAL (ioparm_var) = 1; + TREE_PUBLIC (ioparm_var) = 1; + + locus_line = build_decl (VAR_DECL, get_identifier (PREFIX("line")), + gfc_int4_type_node); + DECL_EXTERNAL (locus_line) = 1; + TREE_PUBLIC (locus_line) = 1; + + locus_file = build_decl (VAR_DECL, get_identifier (PREFIX("filename")), + pchar_type_node); + DECL_EXTERNAL (locus_file) = 1; + TREE_PUBLIC (locus_file) = 1; + + /* Define the transfer functions. */ + + iocall_x_integer = + gfc_build_library_function_decl (get_identifier + (PREFIX("transfer_integer")), + void_type_node, 2, pvoid_type_node, + gfc_int4_type_node); + + iocall_x_logical = + gfc_build_library_function_decl (get_identifier + (PREFIX("transfer_logical")), + void_type_node, 2, pvoid_type_node, + gfc_int4_type_node); + + iocall_x_character = + gfc_build_library_function_decl (get_identifier + (PREFIX("transfer_character")), + void_type_node, 2, pvoid_type_node, + gfc_int4_type_node); + + iocall_x_real = + gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")), + void_type_node, 2, + pvoid_type_node, gfc_int4_type_node); + + iocall_x_complex = + gfc_build_library_function_decl (get_identifier + (PREFIX("transfer_complex")), + void_type_node, 2, pvoid_type_node, + gfc_int4_type_node); + + /* Library entry points */ + + iocall_read = + gfc_build_library_function_decl (get_identifier (PREFIX("st_read")), + void_type_node, 0); + + iocall_write = + gfc_build_library_function_decl (get_identifier (PREFIX("st_write")), + void_type_node, 0); + iocall_open = + gfc_build_library_function_decl (get_identifier (PREFIX("st_open")), + void_type_node, 0); + + iocall_close = + gfc_build_library_function_decl (get_identifier (PREFIX("st_close")), + void_type_node, 0); + + iocall_inquire = + gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")), + gfc_int4_type_node, 0); + + iocall_rewind = + gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")), + gfc_int4_type_node, 0); + + iocall_backspace = + gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")), + gfc_int4_type_node, 0); + + iocall_endfile = + gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")), + gfc_int4_type_node, 0); + /* Library helpers */ + + iocall_read_done = + gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")), + gfc_int4_type_node, 0); + + iocall_write_done = + gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")), + gfc_int4_type_node, 0); + iocall_set_nml_val_int = + gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_int")), + void_type_node, 4, + pvoid_type_node, pvoid_type_node, + gfc_int4_type_node,gfc_int4_type_node); + + iocall_set_nml_val_float = + gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_float")), + void_type_node, 4, + pvoid_type_node, pvoid_type_node, + gfc_int4_type_node,gfc_int4_type_node); + iocall_set_nml_val_char = + gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_char")), + void_type_node, 4, + pvoid_type_node, pvoid_type_node, + gfc_int4_type_node,gfc_int4_type_node); + iocall_set_nml_val_complex = + gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")), + void_type_node, 4, + pvoid_type_node, pvoid_type_node, + gfc_int4_type_node,gfc_int4_type_node); + iocall_set_nml_val_log = + gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_log")), + void_type_node, 4, + pvoid_type_node, pvoid_type_node, + gfc_int4_type_node,gfc_int4_type_node); + +} + + +/* Generate code to store an non-string I/O parameter into the + ioparm structure. This is a pass by value. */ + +static void +set_parameter_value (stmtblock_t * block, tree var, gfc_expr * e) +{ + gfc_se se; + tree tmp; + + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, e, TREE_TYPE (var)); + gfc_add_block_to_block (block, &se.pre); + + tmp = build (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var); + gfc_add_modify_expr (block, tmp, se.expr); +} + + +/* Generate code to store an non-string I/O parameter into the + ioparm structure. This is pass by reference. */ + +static void +set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e) +{ + gfc_se se; + tree tmp; + + gfc_init_se (&se, NULL); + se.want_pointer = 1; + + gfc_conv_expr_type (&se, e, TREE_TYPE (var)); + gfc_add_block_to_block (block, &se.pre); + + tmp = build (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var); + gfc_add_modify_expr (block, tmp, se.expr); +} + + +/* Generate code to store a string and its length into the + ioparm structure. */ + +static void +set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, + tree var_len, gfc_expr * e) +{ + gfc_se se; + tree tmp; + tree msg; + tree io; + tree len; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, e); + + io = build (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var); + len = build (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len); + + /* Integer variable assigned a format label. */ + if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1) + { + msg = + gfc_build_string_const (37, "Assigned label is not a format label"); + tmp = GFC_DECL_STRING_LEN (se.expr); + tmp = build (LE_EXPR, boolean_type_node, tmp, integer_minus_one_node); + gfc_trans_runtime_check (tmp, msg, &se.pre); + gfc_add_modify_expr (&se.pre, io, GFC_DECL_ASSIGN_ADDR (se.expr)); + gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr)); + } + else + { + gfc_conv_string_parameter (&se); + gfc_add_modify_expr (&se.pre, io, se.expr); + gfc_add_modify_expr (&se.pre, len, se.string_length); + } + + gfc_add_block_to_block (block, &se.pre); + gfc_add_block_to_block (postblock, &se.post); + +} + + +/* Set a member of the ioparm structure to one. */ +static void +set_flag (stmtblock_t *block, tree var) +{ + tree tmp; + + tmp = build (COMPONENT_REF, TREE_TYPE(var), ioparm_var, var); + gfc_add_modify_expr (block, tmp, integer_one_node); +} + + +/* Add a case to a IO-result switch. */ + +static void +add_case (int label_value, gfc_st_label * label, stmtblock_t * body) +{ + tree tmp, value; + + if (label == NULL) + return; /* No label, no case */ + + value = build_int_2 (label_value, 0); + + /* Make a backend label for this case. */ + tmp = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE); + DECL_CONTEXT (tmp) = current_function_decl; + + /* And the case itself. */ + tmp = build_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp); + gfc_add_expr_to_block (body, tmp); + + /* Jump to the label. */ + tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label)); + gfc_add_expr_to_block (body, tmp); +} + + +/* Generate a switch statement that branches to the correct I/O + result label. The last statement of an I/O call stores the + result into a variable because there is often cleanup that + must be done before the switch, so a temporary would have to + be created anyway. */ + +static void +io_result (stmtblock_t * block, gfc_st_label * err_label, + gfc_st_label * end_label, gfc_st_label * eor_label) +{ + stmtblock_t body; + tree tmp, rc; + + /* If no labels are specified, ignore the result instead + of building an empty switch. */ + if (err_label == NULL + && end_label == NULL + && eor_label == NULL) + return; + + /* Build a switch statement. */ + gfc_start_block (&body); + + /* The label values here must be the same as the values + in the library_return enum in the runtime library */ + add_case (1, err_label, &body); + add_case (2, end_label, &body); + add_case (3, eor_label, &body); + + tmp = gfc_finish_block (&body); + + rc = build (COMPONENT_REF, TREE_TYPE (ioparm_library_return), ioparm_var, + ioparm_library_return); + + tmp = build_v (SWITCH_EXPR, rc, tmp, NULL_TREE); + + gfc_add_expr_to_block (block, tmp); +} + + +/* Store the current file and line number to variables so that if a + library call goes awry, we can tell the user where the problem is. */ + +static void +set_error_locus (stmtblock_t * block, locus * where) +{ + gfc_file *f; + tree tmp; + int line; + + f = where->file; + tmp = gfc_build_string_const (strlen (f->filename) + 1, f->filename); + + tmp = gfc_build_addr_expr (pchar_type_node, tmp); + gfc_add_modify_expr (block, locus_file, tmp); + + line = where->lp->start_line + where->line; + gfc_add_modify_expr (block, locus_line, build_int_2 (line, 0)); +} + + +/* Translate an OPEN statement. */ + +tree +gfc_trans_open (gfc_code * code) +{ + stmtblock_t block, post_block; + gfc_open *p; + tree tmp; + + gfc_init_block (&block); + gfc_init_block (&post_block); + + set_error_locus (&block, &code->loc); + p = code->ext.open; + + if (p->unit) + set_parameter_value (&block, ioparm_unit, p->unit); + + if (p->file) + set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file); + + if (p->status) + set_string (&block, &post_block, ioparm_status, + ioparm_status_len, p->status); + + if (p->access) + set_string (&block, &post_block, ioparm_access, + ioparm_access_len, p->access); + + if (p->form) + set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form); + + if (p->recl) + set_parameter_value (&block, ioparm_recl_in, p->recl); + + if (p->blank) + set_string (&block, &post_block, ioparm_blank, ioparm_blank_len, + p->blank); + + if (p->position) + set_string (&block, &post_block, ioparm_position, + ioparm_position_len, p->position); + + if (p->action) + set_string (&block, &post_block, ioparm_action, + ioparm_action_len, p->action); + + if (p->delim) + set_string (&block, &post_block, ioparm_delim, ioparm_delim_len, + p->delim); + + if (p->pad) + set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad); + + if (p->iostat) + set_parameter_ref (&block, ioparm_iostat, p->iostat); + + if (p->err) + set_flag (&block, ioparm_err); + + tmp = gfc_build_function_call (iocall_open, NULL_TREE); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &post_block); + + io_result (&block, p->err, NULL, NULL); + + return gfc_finish_block (&block); +} + + +/* Translate a CLOSE statement. */ + +tree +gfc_trans_close (gfc_code * code) +{ + stmtblock_t block, post_block; + gfc_close *p; + tree tmp; + + gfc_init_block (&block); + gfc_init_block (&post_block); + + set_error_locus (&block, &code->loc); + p = code->ext.close; + + if (p->unit) + set_parameter_value (&block, ioparm_unit, p->unit); + + if (p->status) + set_string (&block, &post_block, ioparm_status, + ioparm_status_len, p->status); + + if (p->iostat) + set_parameter_ref (&block, ioparm_iostat, p->iostat); + + if (p->err) + set_flag (&block, ioparm_err); + + tmp = gfc_build_function_call (iocall_close, NULL_TREE); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &post_block); + + io_result (&block, p->err, NULL, NULL); + + return gfc_finish_block (&block); +} + + +/* Common subroutine for building a file positioning statement. */ + +static tree +build_filepos (tree function, gfc_code * code) +{ + stmtblock_t block; + gfc_filepos *p; + tree tmp; + + p = code->ext.filepos; + + gfc_init_block (&block); + + set_error_locus (&block, &code->loc); + + if (p->unit) + set_parameter_value (&block, ioparm_unit, p->unit); + + if (p->iostat) + set_parameter_ref (&block, ioparm_iostat, p->iostat); + + if (p->err) + set_flag (&block, ioparm_err); + + tmp = gfc_build_function_call (function, NULL); + gfc_add_expr_to_block (&block, tmp); + + io_result (&block, p->err, NULL, NULL); + + return gfc_finish_block (&block); +} + + +/* Translate a BACKSPACE statement. */ + +tree +gfc_trans_backspace (gfc_code * code) +{ + + return build_filepos (iocall_backspace, code); +} + + +/* Translate an ENDFILE statement. */ + +tree +gfc_trans_endfile (gfc_code * code) +{ + + return build_filepos (iocall_endfile, code); +} + + +/* Translate a REWIND statement. */ + +tree +gfc_trans_rewind (gfc_code * code) +{ + + return build_filepos (iocall_rewind, code); +} + + +/* Translate the non-IOLENGTH form of an INQUIRE statement. */ + +tree +gfc_trans_inquire (gfc_code * code) +{ + stmtblock_t block, post_block; + gfc_inquire *p; + tree tmp; + + gfc_init_block (&block); + gfc_init_block (&post_block); + + set_error_locus (&block, &code->loc); + p = code->ext.inquire; + + if (p->unit) + set_parameter_value (&block, ioparm_unit, p->unit); + + if (p->file) + set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file); + + if (p->iostat) + set_parameter_ref (&block, ioparm_iostat, p->iostat); + + if (p->exist) + set_parameter_ref (&block, ioparm_exist, p->exist); + + if (p->opened) + set_parameter_ref (&block, ioparm_opened, p->opened); + + if (p->number) + set_parameter_ref (&block, ioparm_number, p->number); + + if (p->named) + set_parameter_ref (&block, ioparm_named, p->named); + + if (p->name) + set_string (&block, &post_block, ioparm_name, ioparm_name_len, p->name); + + if (p->access) + set_string (&block, &post_block, ioparm_access, + ioparm_access_len, p->access); + + if (p->sequential) + set_string (&block, &post_block, ioparm_sequential, + ioparm_sequential_len, p->sequential); + + if (p->direct) + set_string (&block, &post_block, ioparm_direct, + ioparm_direct_len, p->direct); + + if (p->form) + set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form); + + if (p->formatted) + set_string (&block, &post_block, ioparm_formatted, + ioparm_formatted_len, p->formatted); + + if (p->unformatted) + set_string (&block, &post_block, ioparm_unformatted, + ioparm_unformatted_len, p->unformatted); + + if (p->recl) + set_parameter_ref (&block, ioparm_recl_out, p->recl); + + if (p->nextrec) + set_parameter_ref (&block, ioparm_nextrec, p->nextrec); + + if (p->blank) + set_string (&block, &post_block, ioparm_blank, ioparm_blank_len, + p->blank); + + if (p->position) + set_string (&block, &post_block, ioparm_position, + ioparm_position_len, p->position); + + if (p->action) + set_string (&block, &post_block, ioparm_action, + ioparm_action_len, p->action); + + if (p->read) + set_string (&block, &post_block, ioparm_read, ioparm_read_len, p->read); + + if (p->write) + set_string (&block, &post_block, ioparm_write, + ioparm_write_len, p->write); + + if (p->readwrite) + set_string (&block, &post_block, ioparm_readwrite, + ioparm_readwrite_len, p->readwrite); + + if (p->delim) + set_string (&block, &post_block, ioparm_delim, ioparm_delim_len, + p->delim); + + if (p->err) + set_flag (&block, ioparm_err); + + tmp = gfc_build_function_call (iocall_inquire, NULL); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &post_block); + + io_result (&block, p->err, NULL, NULL); + + return gfc_finish_block (&block); +} + + +/* Translate the IOLENGTH form of an INQUIRE statement. We treat + this as a third sort of data transfer statement, except that + lengths are summed instead of actually transfering any data. */ + +tree +gfc_trans_iolength (gfc_code * c ATTRIBUTE_UNUSED) +{ + gfc_todo_error ("IOLENGTH statement"); +} + +static gfc_expr * +gfc_new_nml_name_expr (char * name) +{ + gfc_expr * nml_name; + nml_name = gfc_get_expr(); + nml_name->ref = NULL; + nml_name->expr_type = EXPR_CONSTANT; + nml_name->ts.kind = gfc_default_character_kind (); + nml_name->ts.type = BT_CHARACTER; + nml_name->value.character.length = strlen(name); + nml_name->value.character.string = name; + + return nml_name; +} + +static gfc_expr * +get_new_var_expr(gfc_symbol * sym) +{ + gfc_expr * nml_var; + + nml_var = gfc_get_expr(); + nml_var->expr_type = EXPR_VARIABLE; + nml_var->ts = sym->ts; + if (sym->as) + nml_var->rank = sym->as->rank; + nml_var->symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree)); + nml_var->symtree->n.sym = sym; + nml_var->where = sym->declared_at; + sym->attr.referenced = 1; + + return nml_var; +} + + +/* Create a data transfer statement. Not all of the fields are valid + for both reading and writing, but improper use has been filtered + out by now. */ + +static tree +build_dt (tree * function, gfc_code * code) +{ + stmtblock_t block, post_block; + gfc_dt *dt; + tree tmp, args, arg2; + gfc_expr *nmlname, *nmlvar; + gfc_namelist *nml, *nml_tail; + gfc_se se,se2; + int ts_kind, ts_type, name_len; + + gfc_init_block (&block); + gfc_init_block (&post_block); + + set_error_locus (&block, &code->loc); + dt = code->ext.dt; + + if (dt->io_unit) + { + if (dt->io_unit->ts.type == BT_CHARACTER) + { + set_string (&block, &post_block, ioparm_internal_unit, + ioparm_internal_unit_len, dt->io_unit); + } + else + set_parameter_value (&block, ioparm_unit, dt->io_unit); + } + + if (dt->rec) + set_parameter_value (&block, ioparm_rec, dt->rec); + + if (dt->advance) + set_string (&block, &post_block, ioparm_advance, ioparm_advance_len, + dt->advance); + + if (dt->format_expr) + set_string (&block, &post_block, ioparm_format, ioparm_format_len, + dt->format_expr); + + if (dt->format_label) + { + if (dt->format_label == &format_asterisk) + set_flag (&block, ioparm_list_format); + else + set_string (&block, &post_block, ioparm_format, + ioparm_format_len, dt->format_label->format); + } + + if (dt->iostat) + set_parameter_ref (&block, ioparm_iostat, dt->iostat); + + if (dt->size) + set_parameter_ref (&block, ioparm_size, dt->size); + + if (dt->err) + set_flag (&block, ioparm_err); + + if (dt->eor) + set_flag(&block, ioparm_eor); + + if (dt->end) + set_flag(&block, ioparm_end); + + if (dt->namelist) + { + if (dt->format_expr || dt->format_label) + fatal_error("A format cannot be specified with a namelist"); + + nmlname = gfc_new_nml_name_expr(dt->namelist->name); + + set_string (&block, &post_block, ioparm_namelist_name, + ioparm_namelist_name_len, nmlname); + + if (last_dt == READ) + set_flag (&block, ioparm_namelist_read_mode); + + nml = dt->namelist->namelist; + nml_tail = dt->namelist->namelist_tail; + + while(nml != NULL) + { + gfc_init_se (&se, NULL); + gfc_init_se (&se2, NULL); + nmlvar = get_new_var_expr(nml->sym); + nmlname = gfc_new_nml_name_expr(nml->sym->name); + name_len = strlen(nml->sym->name); + ts_kind = nml->sym->ts.kind; + ts_type = nml->sym->ts.type; + + gfc_conv_expr_reference (&se2, nmlname); + gfc_conv_expr_reference (&se, nmlvar); + args = gfc_chainon_list (NULL_TREE, se.expr); + args = gfc_chainon_list (args, se2.expr); + args = gfc_chainon_list (args, se2.string_length); + arg2 = build_int_2 (ts_kind, 0); + args = gfc_chainon_list (args,arg2); + switch (ts_type) + { + case BT_INTEGER: + tmp = gfc_build_function_call (iocall_set_nml_val_int, args); + break; + case BT_CHARACTER: + tmp = gfc_build_function_call (iocall_set_nml_val_char, args); + break; + case BT_REAL: + tmp = gfc_build_function_call (iocall_set_nml_val_float, args); + break; + case BT_LOGICAL: + tmp = gfc_build_function_call (iocall_set_nml_val_log, args); + break; + case BT_COMPLEX: + tmp = gfc_build_function_call (iocall_set_nml_val_complex, args); + break; + default : + internal_error ("Bad namelist IO basetype (%d)", ts_type); + } + + gfc_add_expr_to_block (&block, tmp); + + nml = nml->next; + } + } + + tmp = gfc_build_function_call (*function, NULL_TREE); + gfc_add_expr_to_block (&block, tmp); + + gfc_add_block_to_block (&block, &post_block); + + return gfc_finish_block (&block); +} + + +/* Translate a READ statement. */ + +tree +gfc_trans_read (gfc_code * code) +{ + + last_dt = READ; + return build_dt (&iocall_read, code); +} + + +/* Translate a WRITE statement */ + +tree +gfc_trans_write (gfc_code * code) +{ + + last_dt = WRITE; + return build_dt (&iocall_write, code); +} + + +/* Finish a data transfer statement. */ + +tree +gfc_trans_dt_end (gfc_code * code) +{ + tree function, tmp; + stmtblock_t block; + + gfc_init_block (&block); + + function = (last_dt == READ) ? iocall_read_done : iocall_write_done; + + tmp = gfc_build_function_call (function, NULL); + gfc_add_expr_to_block (&block, tmp); + + io_result (&block, code->ext.dt->err, code->ext.dt->end, code->ext.dt->eor); + + return gfc_finish_block (&block); +} + + +/* Generate the call for a scalar transfer node. */ + +static void +transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr) +{ + tree args, tmp, function, arg2, field, expr; + gfc_component *c; + int kind; + + kind = ts->kind; + function = NULL; + arg2 = NULL; + + switch (ts->type) + { + case BT_INTEGER: + arg2 = build_int_2 (kind, 0); + function = iocall_x_integer; + break; + + case BT_REAL: + arg2 = build_int_2 (kind, 0); + function = iocall_x_real; + break; + + case BT_COMPLEX: + arg2 = build_int_2 (kind, 0); + function = iocall_x_complex; + break; + + case BT_LOGICAL: + arg2 = build_int_2 (kind, 0); + function = iocall_x_logical; + break; + + case BT_CHARACTER: + arg2 = se->string_length; + function = iocall_x_character; + break; + + case BT_DERIVED: + expr = gfc_evaluate_now (addr_expr, &se->pre); + expr = gfc_build_indirect_ref (expr); + + for (c = ts->derived->components; c; c = c->next) + { + field = c->backend_decl; + assert (field && TREE_CODE (field) == FIELD_DECL); + + tmp = build (COMPONENT_REF, TREE_TYPE (field), expr, field); + + if (c->ts.type == BT_CHARACTER) + { + assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); + se->string_length = + TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp))); + } + transfer_expr (se, &c->ts, gfc_build_addr_expr (NULL, tmp)); + } + return; + + default: + internal_error ("Bad IO basetype (%d)", ts->type); + } + + args = gfc_chainon_list (NULL_TREE, addr_expr); + args = gfc_chainon_list (args, arg2); + + tmp = gfc_build_function_call (function, args); + gfc_add_expr_to_block (&se->pre, tmp); + gfc_add_block_to_block (&se->pre, &se->post); +} + + +/* gfc_trans_transfer()-- Translate a TRANSFER code node */ + +tree +gfc_trans_transfer (gfc_code * code) +{ + stmtblock_t block, body; + gfc_loopinfo loop; + gfc_expr *expr; + gfc_ss *ss; + gfc_se se; + tree tmp; + + gfc_start_block (&block); + + expr = code->expr; + ss = gfc_walk_expr (expr); + + gfc_init_se (&se, NULL); + + if (ss == gfc_ss_terminator) + gfc_init_block (&body); + else + { + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, ss); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop); + + /* The main loop body. */ + gfc_mark_ss_chain_used (ss, 1); + gfc_start_scalarized_body (&loop, &body); + + gfc_copy_loopinfo_to_se (&se, &loop); + se.ss = ss; + } + + gfc_conv_expr_reference (&se, expr); + + transfer_expr (&se, &expr->ts, se.expr); + + gfc_add_block_to_block (&body, &se.pre); + gfc_add_block_to_block (&body, &se.post); + + if (se.ss == NULL) + tmp = gfc_finish_block (&body); + else + { + assert (se.ss == gfc_ss_terminator); + gfc_trans_scalarizing_loops (&loop, &body); + + gfc_add_block_to_block (&loop.pre, &loop.post); + tmp = gfc_finish_block (&loop.pre); + gfc_cleanup_loop (&loop); + } + + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block);; +} + +#include "gt-fortran-trans-io.h" + diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c new file mode 100644 index 00000000000..0de62a5367c --- /dev/null +++ b/gcc/fortran/trans-stmt.c @@ -0,0 +1,3159 @@ +/* Statement translation -- generate GCC trees from gfc_code. + Copyright (C) 2002, 2003 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + and Steven Bosscher <s.bosscher@student.tudelft.nl> + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "tree-simple.h" +#include <stdio.h> +#include "ggc.h" +#include "toplev.h" +#include "real.h" +#include <assert.h> +#include <gmp.h> +#include "gfortran.h" +#include "trans.h" +#include "trans-stmt.h" +#include "trans-types.h" +#include "trans-array.h" +#include "trans-const.h" +#include "arith.h" + +int has_alternate_specifier; + +typedef struct iter_info +{ + tree var; + tree start; + tree end; + tree step; + struct iter_info *next; +} +iter_info; + +typedef struct temporary_list +{ + tree temporary; + struct temporary_list *next; +} +temporary_list; + +typedef struct forall_info +{ + iter_info *this_loop; + tree mask; + tree pmask; + tree maskindex; + int nvar; + tree size; + struct forall_info *outer; + struct forall_info *next_nest; +} +forall_info; + +static void gfc_trans_where_2 (gfc_code *, tree, tree, forall_info *, + stmtblock_t *, temporary_list **temp); + +/* Translate a F95 label number to a LABEL_EXPR. */ + +tree +gfc_trans_label_here (gfc_code * code) +{ + return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here)); +} + +/* Translate a label assignment statement. */ +tree +gfc_trans_label_assign (gfc_code * code) +{ + tree label_tree; + gfc_se se; + tree len; + tree addr; + tree len_tree; + char *label_str; + int label_len; + + /* Start a new block. */ + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + gfc_conv_expr (&se, code->expr); + len = GFC_DECL_STRING_LEN (se.expr); + addr = GFC_DECL_ASSIGN_ADDR (se.expr); + + label_tree = gfc_get_label_decl (code->label); + + if (code->label->defined == ST_LABEL_TARGET) + { + label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); + len_tree = integer_minus_one_node; + } + else + { + label_str = code->label->format->value.character.string; + label_len = code->label->format->value.character.length; + len_tree = build_int_2 (label_len, 0); + label_tree = gfc_build_string_const (label_len + 1, label_str); + label_tree = gfc_build_addr_expr (pchar_type_node, label_tree); + } + + gfc_add_modify_expr (&se.pre, len, len_tree); + gfc_add_modify_expr (&se.pre, addr, label_tree); + + return gfc_finish_block (&se.pre); +} + +/* Translate a GOTO statement. */ + +tree +gfc_trans_goto (gfc_code * code) +{ + tree assigned_goto; + tree target; + tree tmp; + tree assign_error; + tree range_error; + gfc_se se; + + + if (code->label != NULL) + return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label)); + + /* ASSIGNED GOTO. */ + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + gfc_conv_expr (&se, code->expr); + assign_error = + gfc_build_string_const (37, "Assigned label is not a target label"); + tmp = GFC_DECL_STRING_LEN (se.expr); + tmp = build (NE_EXPR, boolean_type_node, tmp, integer_minus_one_node); + gfc_trans_runtime_check (tmp, assign_error, &se.pre); + + assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr); + target = build1 (GOTO_EXPR, void_type_node, assigned_goto); + + code = code->block; + if (code == NULL) + { + gfc_add_expr_to_block (&se.pre, target); + return gfc_finish_block (&se.pre); + } + + /* Check the label list. */ + range_error = + gfc_build_string_const (34, "Assigned label is not in the list"); + + do + { + tmp = gfc_get_label_decl (code->label); + tmp = gfc_build_addr_expr (pvoid_type_node, tmp); + tmp = build (EQ_EXPR, boolean_type_node, tmp, assigned_goto); + tmp = build_v (COND_EXPR, tmp, target, build_empty_stmt ()); + gfc_add_expr_to_block (&se.pre, tmp); + code = code->block; + } + while (code != NULL); + gfc_trans_runtime_check (boolean_true_node, range_error, &se.pre); + return gfc_finish_block (&se.pre); +} + + +/* Translate the CALL statement. Builds a call to an F95 subroutine. */ + +tree +gfc_trans_call (gfc_code * code) +{ + gfc_se se; + + /* A CALL starts a new block because the actual arguments may have to + be evaluated first. */ + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + assert (code->resolved_sym); + has_alternate_specifier = 0; + + /* Translate the call. */ + gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual); + + /* A subroutine without side-effect, by definition, does nothing! */ + TREE_SIDE_EFFECTS (se.expr) = 1; + + /* Chain the pieces together and return the block. */ + if (has_alternate_specifier) + { + gfc_code *select_code; + gfc_symbol *sym; + select_code = code->next; + assert(select_code->op == EXEC_SELECT); + sym = select_code->expr->symtree->n.sym; + se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr); + gfc_add_modify_expr (&se.pre, sym->backend_decl, se.expr); + } + else + gfc_add_expr_to_block (&se.pre, se.expr); + + gfc_add_block_to_block (&se.pre, &se.post); + return gfc_finish_block (&se.pre); +} + + +/* Translate the RETURN statement. */ + +tree +gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED) +{ + if (code->expr) + { + gfc_se se; + tree tmp; + tree result; + + /* if code->expr is not NULL, this return statement must appear + in a subroutine and current_fake_result_decl has already + been generated. */ + + result = gfc_get_fake_result_decl (NULL); + if (!result) + { + gfc_warning ("An alternate return at %L without a * dummy argument", + &code->expr->where); + return build1_v (GOTO_EXPR, gfc_get_return_label ()); + } + + /* Start a new block for this statement. */ + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + gfc_conv_expr (&se, code->expr); + + tmp = build (MODIFY_EXPR, TREE_TYPE (result), result, se.expr); + gfc_add_expr_to_block (&se.pre, tmp); + + tmp = build1_v (GOTO_EXPR, gfc_get_return_label ()); + gfc_add_expr_to_block (&se.pre, tmp); + gfc_add_block_to_block (&se.pre, &se.post); + return gfc_finish_block (&se.pre); + } + else + return build1_v (GOTO_EXPR, gfc_get_return_label ()); +} + + +/* Translate the PAUSE statement. We have to translate this statement + to a runtime library call. */ + +tree +gfc_trans_pause (gfc_code * code) +{ + gfc_se se; + tree args; + tree tmp; + tree fndecl; + + /* Start a new block for this statement. */ + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + + if (code->expr == NULL) + { + tmp = build_int_2 (code->ext.stop_code, 0); + TREE_TYPE (tmp) = gfc_int4_type_node; + args = gfc_chainon_list (NULL_TREE, tmp); + fndecl = gfor_fndecl_pause_numeric; + } + else + { + gfc_conv_expr_reference (&se, code->expr); + args = gfc_chainon_list (NULL_TREE, se.expr); + args = gfc_chainon_list (args, se.string_length); + fndecl = gfor_fndecl_pause_string; + } + + tmp = gfc_build_function_call (fndecl, args); + gfc_add_expr_to_block (&se.pre, tmp); + + gfc_add_block_to_block (&se.pre, &se.post); + + return gfc_finish_block (&se.pre); +} + + +/* Translate the STOP statement. We have to translate this statement + to a runtime library call. */ + +tree +gfc_trans_stop (gfc_code * code) +{ + gfc_se se; + tree args; + tree tmp; + tree fndecl; + + /* Start a new block for this statement. */ + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + + if (code->expr == NULL) + { + tmp = build_int_2 (code->ext.stop_code, 0); + TREE_TYPE (tmp) = gfc_int4_type_node; + args = gfc_chainon_list (NULL_TREE, tmp); + fndecl = gfor_fndecl_stop_numeric; + } + else + { + gfc_conv_expr_reference (&se, code->expr); + args = gfc_chainon_list (NULL_TREE, se.expr); + args = gfc_chainon_list (args, se.string_length); + fndecl = gfor_fndecl_stop_string; + } + + tmp = gfc_build_function_call (fndecl, args); + gfc_add_expr_to_block (&se.pre, tmp); + + gfc_add_block_to_block (&se.pre, &se.post); + + return gfc_finish_block (&se.pre); +} + + +/* Generate GENERIC for the IF construct. This function also deals with + the simple IF statement, because the front end translates the IF + statement into an IF construct. + + We translate: + + IF (cond) THEN + then_clause + ELSEIF (cond2) + elseif_clause + ELSE + else_clause + ENDIF + + into: + + pre_cond_s; + if (cond_s) + { + then_clause; + } + else + { + pre_cond_s + if (cond_s) + { + elseif_clause + } + else + { + else_clause; + } + } + + where COND_S is the simplified version of the predicate. PRE_COND_S + are the pre side-effects produced by the translation of the + conditional. + We need to build the chain recursively otherwise we run into + problems with folding incomplete statements. */ + +static tree +gfc_trans_if_1 (gfc_code * code) +{ + gfc_se if_se; + tree stmt, elsestmt; + + /* Check for an unconditional ELSE clause. */ + if (!code->expr) + return gfc_trans_code (code->next); + + /* Initialize a statement builder for each block. Puts in NULL_TREEs. */ + gfc_init_se (&if_se, NULL); + gfc_start_block (&if_se.pre); + + /* Calculate the IF condition expression. */ + gfc_conv_expr_val (&if_se, code->expr); + + /* Translate the THEN clause. */ + stmt = gfc_trans_code (code->next); + + /* Translate the ELSE clause. */ + if (code->block) + elsestmt = gfc_trans_if_1 (code->block); + else + elsestmt = build_empty_stmt (); + + /* Build the condition expression and add it to the condition block. */ + stmt = build_v (COND_EXPR, if_se.expr, stmt, elsestmt); + + gfc_add_expr_to_block (&if_se.pre, stmt); + + /* Finish off this statement. */ + return gfc_finish_block (&if_se.pre); +} + +tree +gfc_trans_if (gfc_code * code) +{ + /* Ignore the top EXEC_IF, it only announces an IF construct. The + actual code we must translate is in code->block. */ + + return gfc_trans_if_1 (code->block); +} + + +/* Translage an arithmetic IF expression. + + IF (cond) label1, label2, label3 translates to + + if (cond <= 0) + { + if (cond < 0) + goto label1; + else // cond == 0 + goto label2; + } + else // cond > 0 + goto label3; +*/ + +tree +gfc_trans_arithmetic_if (gfc_code * code) +{ + gfc_se se; + tree tmp; + tree branch1; + tree branch2; + tree zero; + + /* Start a new block. */ + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + /* Pre-evaluate COND. */ + gfc_conv_expr_val (&se, code->expr); + + /* Build something to compare with. */ + zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node); + + /* If (cond < 0) take branch1 else take branch2. + First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */ + branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label)); + branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2)); + + tmp = build (LT_EXPR, boolean_type_node, se.expr, zero); + branch1 = build_v (COND_EXPR, tmp, branch1, branch2); + + /* if (cond <= 0) take branch1 else take branch2. */ + branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3)); + tmp = build (LE_EXPR, boolean_type_node, se.expr, zero); + branch1 = build_v (COND_EXPR, tmp, branch1, branch2); + + /* Append the COND_EXPR to the evaluation of COND, and return. */ + gfc_add_expr_to_block (&se.pre, branch1); + return gfc_finish_block (&se.pre); +} + + +/* Translate the DO construct. This obviously is one of the most + important ones to get right with any compiler, but especially + so for Fortran. + + Currently we calculate the loop count before entering the loop, but + it may be possible to optimize if step is a constant. The main + advantage is that the loop test is a single GENERIC node + + We translate a do loop from: + + DO dovar = from, to, step + body + END DO + + to: + + pre_dovar; + pre_from; + pre_to; + pre_step; + temp1=to_expr-from_expr; + step_temp=step_expr; + range_temp=step_tmp/range_temp; + for ( ; range_temp > 0 ; range_temp = range_temp - 1) + { + body; +cycle_label: + dovar_temp = dovar + dovar=dovar_temp + step_temp; + } +exit_label: + + Some optimization is done for empty do loops. We can't just let + dovar=to because it's possible for from+range*loopcount!=to. Anyone + who writes empty DO deserves sub-optimal (but correct) code anyway. + + TODO: Large loop counts + Does not work loop counts which do not fit into a signed integer kind, + ie. Does not work for loop counts > 2^31 for integer(kind=4) variables + We must support the full range. */ + +tree +gfc_trans_do (gfc_code * code) +{ + gfc_se se; + tree dovar; + tree from; + tree to; + tree step; + tree count; + tree type; + tree cond; + tree cycle_label; + tree exit_label; + tree tmp; + stmtblock_t block; + stmtblock_t body; + + gfc_start_block (&block); + + /* Create GIMPLE versions of all expressions in the iterator. */ + + gfc_init_se (&se, NULL); + gfc_conv_expr_lhs (&se, code->ext.iterator->var); + gfc_add_block_to_block (&block, &se.pre); + dovar = se.expr; + type = TREE_TYPE (dovar); + + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, code->ext.iterator->start, type); + gfc_add_block_to_block (&block, &se.pre); + from = se.expr; + + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, code->ext.iterator->end, type); + gfc_add_block_to_block (&block, &se.pre); + to = se.expr; + + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, code->ext.iterator->step, type); + + /* We don't want this changing part way through. */ + gfc_make_safe_expr (&se); + gfc_add_block_to_block (&block, &se.pre); + step = se.expr; + + /* Initialise loop count. This code is executed before we enter the + loop body. We generate: count = (to + step - from) / step. */ + + tmp = fold (build (MINUS_EXPR, type, step, from)); + tmp = fold (build (PLUS_EXPR, type, to, tmp)); + tmp = fold (build (TRUNC_DIV_EXPR, type, tmp, step)); + + count = gfc_create_var (type, "count"); + gfc_add_modify_expr (&block, count, tmp); + + /* Initialise the DO variable: dovar = from. */ + gfc_add_modify_expr (&block, dovar, from); + + /* Loop body. */ + gfc_start_block (&body); + + /* Cycle and exit statements are implemented with gotos. */ + cycle_label = gfc_build_label_decl (NULL_TREE); + exit_label = gfc_build_label_decl (NULL_TREE); + + /* Start with the loop condition. Loop until count <= 0. */ + cond = build (LE_EXPR, boolean_type_node, count, integer_zero_node); + tmp = build1_v (GOTO_EXPR, exit_label); + TREE_USED (exit_label) = 1; + tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ()); + gfc_add_expr_to_block (&body, tmp); + + /* Put these labels where they can be found later. We put the + labels in a TREE_LIST node (because TREE_CHAIN is already + used). cycle_label goes in TREE_PURPOSE (backend_decl), exit + label in TREE_VALUE (backend_decl). */ + + code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL); + + /* Main loop body. */ + tmp = gfc_trans_code (code->block->next); + gfc_add_expr_to_block (&body, tmp); + + /* Label for cycle statements (if needed). */ + if (TREE_USED (cycle_label)) + { + tmp = build1_v (LABEL_EXPR, cycle_label); + gfc_add_expr_to_block (&body, tmp); + } + + /* Increment the loop variable. */ + tmp = build (PLUS_EXPR, type, dovar, step); + gfc_add_modify_expr (&body, dovar, tmp); + + /* Decrement the loop count. */ + tmp = build (MINUS_EXPR, type, count, integer_one_node); + gfc_add_modify_expr (&body, count, tmp); + + /* End of loop body. */ + tmp = gfc_finish_block (&body); + + /* The for loop itself. */ + tmp = build_v (LOOP_EXPR, tmp); + gfc_add_expr_to_block (&block, tmp); + + /* Add the exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + + +/* Translate the DO WHILE construct. + + We translate + + DO WHILE (cond) + body + END DO + + to: + + for ( ; ; ) + { + pre_cond; + if (! cond) goto exit_label; + body; +cycle_label: + } +exit_label: + + Because the evaluation of the exit condition `cond' may have side + effects, we can't do much for empty loop bodies. The backend optimizers + should be smart enough to eliminate any dead loops. */ + +tree +gfc_trans_do_while (gfc_code * code) +{ + gfc_se cond; + tree tmp; + tree cycle_label; + tree exit_label; + stmtblock_t block; + + /* Everything we build here is part of the loop body. */ + gfc_start_block (&block); + + /* Cycle and exit statements are implemented with gotos. */ + cycle_label = gfc_build_label_decl (NULL_TREE); + exit_label = gfc_build_label_decl (NULL_TREE); + + /* Put the labels where they can be found later. See gfc_trans_do(). */ + code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL); + + /* Create a GIMPLE version of the exit condition. */ + gfc_init_se (&cond, NULL); + gfc_conv_expr_val (&cond, code->expr); + gfc_add_block_to_block (&block, &cond.pre); + cond.expr = fold (build1 (TRUTH_NOT_EXPR, boolean_type_node, cond.expr)); + + /* Build "IF (! cond) GOTO exit_label". */ + tmp = build1_v (GOTO_EXPR, exit_label); + TREE_USED (exit_label) = 1; + tmp = build_v (COND_EXPR, cond.expr, tmp, build_empty_stmt ()); + gfc_add_expr_to_block (&block, tmp); + + /* The main body of the loop. */ + tmp = gfc_trans_code (code->block->next); + gfc_add_expr_to_block (&block, tmp); + + /* Label for cycle statements (if needed). */ + if (TREE_USED (cycle_label)) + { + tmp = build1_v (LABEL_EXPR, cycle_label); + gfc_add_expr_to_block (&block, tmp); + } + + /* End of loop body. */ + tmp = gfc_finish_block (&block); + + gfc_init_block (&block); + /* Build the loop. */ + tmp = build_v (LOOP_EXPR, tmp); + gfc_add_expr_to_block (&block, tmp); + + /* Add the exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + + +/* Translate the SELECT CASE construct for INTEGER case expressions, + without killing all potential optimizations. The problem is that + Fortran allows unbounded cases, but the back-end does not, so we + need to intercept those before we enter the equivalent SWITCH_EXPR + we can build. + + For example, we translate this, + + SELECT CASE (expr) + CASE (:100,101,105:115) + block_1 + CASE (190:199,200:) + block_2 + CASE (300) + block_3 + CASE DEFAULT + block_4 + END SELECT + + to the GENERIC equivalent, + + switch (expr) + { + case (minimum value for typeof(expr) ... 100: + case 101: + case 105 ... 114: + block1: + goto end_label; + + case 200 ... (maximum value for typeof(expr): + case 190 ... 199: + block2; + goto end_label; + + case 300: + block_3; + goto end_label; + + default: + block_4; + goto end_label; + } + + end_label: */ + +static tree +gfc_trans_integer_select (gfc_code * code) +{ + gfc_code *c; + gfc_case *cp; + tree end_label; + tree tmp; + gfc_se se; + stmtblock_t block; + stmtblock_t body; + + gfc_start_block (&block); + + /* Calculate the switch expression. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, code->expr); + gfc_add_block_to_block (&block, &se.pre); + + end_label = gfc_build_label_decl (NULL_TREE); + + gfc_init_block (&body); + + for (c = code->block; c; c = c->block) + { + for (cp = c->ext.case_list; cp; cp = cp->next) + { + tree low, high; + tree label; + + /* Assume it's the default case. */ + low = high = NULL_TREE; + + if (cp->low) + { + low = gfc_conv_constant_to_tree (cp->low); + + /* If there's only a lower bound, set the high bound to the + maximum value of the case expression. */ + if (!cp->high) + high = TYPE_MAX_VALUE (TREE_TYPE (se.expr)); + } + + if (cp->high) + { + /* Three cases are possible here: + + 1) There is no lower bound, e.g. CASE (:N). + 2) There is a lower bound .NE. high bound, that is + a case range, e.g. CASE (N:M) where M>N (we make + sure that M>N during type resolution). + 3) There is a lower bound, and it has the same value + as the high bound, e.g. CASE (N:N). This is our + internal representation of CASE(N). + + In the first and second case, we need to set a value for + high. In the thirth case, we don't because the GCC middle + end represents a single case value by just letting high be + a NULL_TREE. We can't do that because we need to be able + to represent unbounded cases. */ + + if (!cp->low + || (cp->low + && mpz_cmp (cp->low->value.integer, + cp->high->value.integer) != 0)) + high = gfc_conv_constant_to_tree (cp->high); + + /* Unbounded case. */ + if (!cp->low) + low = TYPE_MIN_VALUE (TREE_TYPE (se.expr)); + } + + /* Build a label. */ + label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE); + DECL_CONTEXT (label) = current_function_decl; + + /* Add this case label. + Add parameter 'label', make it match GCC backend. */ + tmp = build (CASE_LABEL_EXPR, void_type_node, low, high, label); + gfc_add_expr_to_block (&body, tmp); + } + + /* Add the statements for this case. */ + tmp = gfc_trans_code (c->next); + gfc_add_expr_to_block (&body, tmp); + + /* Break to the end of the construct. */ + tmp = build1_v (GOTO_EXPR, end_label); + gfc_add_expr_to_block (&body, tmp); + } + + tmp = gfc_finish_block (&body); + tmp = build_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE); + gfc_add_expr_to_block (&block, tmp); + + tmp = build1_v (LABEL_EXPR, end_label); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + + +/* Translate the SELECT CASE construct for LOGICAL case expressions. + + There are only two cases possible here, even though the standard + does allow three cases in a LOGICAL SELECT CASE construct: .TRUE., + .FALSE., and DEFAULT. + + We never generate more than two blocks here. Instead, we always + try to eliminate the DEFAULT case. This way, we can translate this + kind of SELECT construct to a simple + + if {} else {}; + + expression in GENERIC. */ + +static tree +gfc_trans_logical_select (gfc_code * code) +{ + gfc_code *c; + gfc_code *t, *f, *d; + gfc_case *cp; + gfc_se se; + stmtblock_t block; + + /* Assume we don't have any cases at all. */ + t = f = d = NULL; + + /* Now see which ones we actually do have. We can have at most two + cases in a single case list: one for .TRUE. and one for .FALSE. + The default case is always separate. If the cases for .TRUE. and + .FALSE. are in the same case list, the block for that case list + always executed, and we don't generate code a COND_EXPR. */ + for (c = code->block; c; c = c->block) + { + for (cp = c->ext.case_list; cp; cp = cp->next) + { + if (cp->low) + { + if (cp->low->value.logical == 0) /* .FALSE. */ + f = c; + else /* if (cp->value.logical != 0), thus .TRUE. */ + t = c; + } + else + d = c; + } + } + + /* Start a new block. */ + gfc_start_block (&block); + + /* Calculate the switch expression. We always need to do this + because it may have side effects. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, code->expr); + gfc_add_block_to_block (&block, &se.pre); + + if (t == f && t != NULL) + { + /* Cases for .TRUE. and .FALSE. are in the same block. Just + translate the code for these cases, append it to the current + block. */ + gfc_add_expr_to_block (&block, gfc_trans_code (t->next)); + } + else + { + tree true_tree, false_tree; + + true_tree = build_empty_stmt (); + false_tree = build_empty_stmt (); + + /* If we have a case for .TRUE. and for .FALSE., discard the default case. + Otherwise, if .TRUE. or .FALSE. is missing and there is a default case, + make the missing case the default case. */ + if (t != NULL && f != NULL) + d = NULL; + else if (d != NULL) + { + if (t == NULL) + t = d; + else + f = d; + } + + /* Translate the code for each of these blocks, and append it to + the current block. */ + if (t != NULL) + true_tree = gfc_trans_code (t->next); + + if (f != NULL) + false_tree = gfc_trans_code (f->next); + + gfc_add_expr_to_block (&block, build_v (COND_EXPR, se.expr, + true_tree, false_tree)); + } + + return gfc_finish_block (&block); +} + + +/* Translate the SELECT CASE construct for CHARACTER case expressions. + Instead of generating compares and jumps, it is far simpler to + generate a data structure describing the cases in order and call a + library subroutine that locates the right case. + This is particularly true because this is the only case where we + might have to dispose of a temporary. + The library subroutine returns a pointer to jump to or NULL if no + branches are to be taken. */ + +static tree +gfc_trans_character_select (gfc_code *code) +{ + tree init, node, end_label, tmp, type, args, *labels; + stmtblock_t block, body; + gfc_case *cp, *d; + gfc_code *c; + gfc_se se; + int i, n; + + static tree select_struct; + static tree ss_string1, ss_string1_len; + static tree ss_string2, ss_string2_len; + static tree ss_target; + + if (select_struct == NULL) + { + select_struct = make_node (RECORD_TYPE); + TYPE_NAME (select_struct) = get_identifier ("_jump_struct"); + +#undef ADD_FIELD +#define ADD_FIELD(NAME, TYPE) \ + ss_##NAME = gfc_add_field_to_struct \ + (&(TYPE_FIELDS (select_struct)), select_struct, \ + get_identifier (stringize(NAME)), TYPE) + + ADD_FIELD (string1, pchar_type_node); + ADD_FIELD (string1_len, gfc_int4_type_node); + + ADD_FIELD (string2, pchar_type_node); + ADD_FIELD (string2_len, gfc_int4_type_node); + + ADD_FIELD (target, pvoid_type_node); +#undef ADD_FIELD + + gfc_finish_type (select_struct); + } + + cp = code->block->ext.case_list; + while (cp->left != NULL) + cp = cp->left; + + n = 0; + for (d = cp; d; d = d->right) + d->n = n++; + + if (n != 0) + labels = gfc_getmem (n * sizeof (tree)); + else + labels = NULL; + + for(i = 0; i < n; i++) + { + labels[i] = gfc_build_label_decl (NULL_TREE); + TREE_USED (labels[i]) = 1; + /* TODO: The gimplifier should do this for us, but it has + inadequacies when dealing with static initializers. */ + FORCED_LABEL (labels[i]) = 1; + } + + end_label = gfc_build_label_decl (NULL_TREE); + + /* Generate the body */ + gfc_start_block (&block); + gfc_init_block (&body); + + for (c = code->block; c; c = c->block) + { + for (d = c->ext.case_list; d; d = d->next) + { + tmp = build_v (LABEL_EXPR, labels[d->n]); + gfc_add_expr_to_block (&body, tmp); + } + + tmp = gfc_trans_code (c->next); + gfc_add_expr_to_block (&body, tmp); + + tmp = build_v (GOTO_EXPR, end_label); + gfc_add_expr_to_block (&body, tmp); + } + + /* Generate the structure describing the branches */ + init = NULL_TREE; + i = 0; + + for(d = cp; d; d = d->right, i++) + { + node = NULL_TREE; + + gfc_init_se (&se, NULL); + + if (d->low == NULL) + { + node = tree_cons (ss_string1, null_pointer_node, node); + node = tree_cons (ss_string1_len, integer_zero_node, node); + } + else + { + gfc_conv_expr_reference (&se, d->low); + + node = tree_cons (ss_string1, se.expr, node); + node = tree_cons (ss_string1_len, se.string_length, node); + } + + if (d->high == NULL) + { + node = tree_cons (ss_string2, null_pointer_node, node); + node = tree_cons (ss_string2_len, integer_zero_node, node); + } + else + { + gfc_init_se (&se, NULL); + gfc_conv_expr_reference (&se, d->high); + + node = tree_cons (ss_string2, se.expr, node); + node = tree_cons (ss_string2_len, se.string_length, node); + } + + tmp = gfc_build_addr_expr (pvoid_type_node, labels[i]); + node = tree_cons (ss_target, tmp, node); + + tmp = build1 (CONSTRUCTOR, select_struct, nreverse (node)); + init = tree_cons (NULL_TREE, tmp, init); + } + + type = build_array_type (select_struct, + build_index_type (build_int_2(n - 1, 0))); + + init = build1 (CONSTRUCTOR, type, nreverse(init)); + TREE_CONSTANT (init) = 1; + TREE_INVARIANT (init) = 1; + TREE_STATIC (init) = 1; + /* Create a static variable to hold the jump table. */ + tmp = gfc_create_var (type, "jumptable"); + TREE_CONSTANT (tmp) = 1; + TREE_INVARIANT (tmp) = 1; + TREE_STATIC (tmp) = 1; + DECL_INITIAL (tmp) = init; + init = tmp; + + /* Build an argument list for the library call */ + init = gfc_build_addr_expr (pvoid_type_node, init); + args = gfc_chainon_list (NULL_TREE, init); + + tmp = build_int_2 (n, 0); + args = gfc_chainon_list (args, tmp); + + tmp = gfc_build_addr_expr (pvoid_type_node, end_label); + args = gfc_chainon_list (args, tmp); + + gfc_init_se (&se, NULL); + gfc_conv_expr_reference (&se, code->expr); + + args = gfc_chainon_list (args, se.expr); + args = gfc_chainon_list (args, se.string_length); + + gfc_add_block_to_block (&block, &se.pre); + + tmp = gfc_build_function_call (gfor_fndecl_select_string, args); + tmp = build1 (GOTO_EXPR, void_type_node, tmp); + gfc_add_expr_to_block (&block, tmp); + + tmp = gfc_finish_block (&body); + gfc_add_expr_to_block (&block, tmp); + tmp = build_v (LABEL_EXPR, end_label); + gfc_add_expr_to_block (&block, tmp); + + if (n != 0) + gfc_free (labels); + + return gfc_finish_block (&block); +} + + +/* Translate the three variants of the SELECT CASE construct. + + SELECT CASEs with INTEGER case expressions can be translated to an + equivalent GENERIC switch statement, and for LOGICAL case + expressions we build one or two if-else compares. + + SELECT CASEs with CHARACTER case expressions are a whole different + story, because they don't exist in GENERIC. So we sort them and + do a binary search at runtime. + + Fortran has no BREAK statement, and it does not allow jumps from + one case block to another. That makes things a lot easier for + the optimizers. */ + +tree +gfc_trans_select (gfc_code * code) +{ + assert (code && code->expr); + + /* Empty SELECT constructs are legal. */ + if (code->block == NULL) + return build_empty_stmt (); + + /* Select the correct translation function. */ + switch (code->expr->ts.type) + { + case BT_LOGICAL: return gfc_trans_logical_select (code); + case BT_INTEGER: return gfc_trans_integer_select (code); + case BT_CHARACTER: return gfc_trans_character_select (code); + default: + gfc_internal_error ("gfc_trans_select(): Bad type for case expr."); + /* Not reached */ + } +} + + +/* Generate the loops for a FORALL block. The normal loop format: + count = (end - start + step) / step + loopvar = start + while (1) + { + if (count <=0 ) + goto end_of_loop + <body> + loopvar += step + count -- + } + end_of_loop: */ + +static tree +gfc_trans_forall_loop (forall_info *forall_tmp, int nvar, tree body, int mask_flag) +{ + int n; + tree tmp; + tree cond; + stmtblock_t block; + tree exit_label; + tree count; + tree var, start, end, step, mask, maskindex; + iter_info *iter; + + iter = forall_tmp->this_loop; + for (n = 0; n < nvar; n++) + { + var = iter->var; + start = iter->start; + end = iter->end; + step = iter->step; + + exit_label = gfc_build_label_decl (NULL_TREE); + TREE_USED (exit_label) = 1; + + /* The loop counter. */ + count = gfc_create_var (TREE_TYPE (var), "count"); + + /* The body of the loop. */ + gfc_init_block (&block); + + /* The exit condition. */ + cond = build (LE_EXPR, boolean_type_node, count, integer_zero_node); + tmp = build1_v (GOTO_EXPR, exit_label); + tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ()); + gfc_add_expr_to_block (&block, tmp); + + /* The main loop body. */ + gfc_add_expr_to_block (&block, body); + + /* Increment the loop variable. */ + tmp = build (PLUS_EXPR, TREE_TYPE (var), var, step); + gfc_add_modify_expr (&block, var, tmp); + + /* Advance to the next mask element. */ + if (mask_flag) + { + mask = forall_tmp->mask; + maskindex = forall_tmp->maskindex; + if (mask) + { + tmp = build (PLUS_EXPR, gfc_array_index_type, maskindex, + integer_one_node); + gfc_add_modify_expr (&block, maskindex, tmp); + } + } + /* Decrement the loop counter. */ + tmp = build (MINUS_EXPR, TREE_TYPE (var), count, integer_one_node); + gfc_add_modify_expr (&block, count, tmp); + + body = gfc_finish_block (&block); + + /* Loop var initialization. */ + gfc_init_block (&block); + gfc_add_modify_expr (&block, var, start); + + /* Initialize the loop counter. */ + tmp = fold (build (MINUS_EXPR, TREE_TYPE (var), step, start)); + tmp = fold (build (PLUS_EXPR, TREE_TYPE (var), end, tmp)); + tmp = fold (build (TRUNC_DIV_EXPR, TREE_TYPE (var), tmp, step)); + gfc_add_modify_expr (&block, count, tmp); + + /* The loop expression. */ + tmp = build_v (LOOP_EXPR, body); + gfc_add_expr_to_block (&block, tmp); + + /* The exit label. */ + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&block, tmp); + + body = gfc_finish_block (&block); + iter = iter->next; + } + return body; +} + + +/* Generate the body and loops according to MASK_FLAG and NEST_FLAG. + if MASK_FLAG is non-zero, the body is controlled by maskes in forall + nest, otherwise, the body is not controlled by maskes. + if NEST_FLAG is non-zero, generate loops for nested forall, otherwise, + only generate loops for the current forall level. */ + +static tree +gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body, + int mask_flag, int nest_flag) +{ + tree tmp; + int nvar; + forall_info *forall_tmp; + tree pmask, mask, maskindex; + + forall_tmp = nested_forall_info; + /* Generate loops for nested forall. */ + if (nest_flag) + { + while (forall_tmp->next_nest != NULL) + forall_tmp = forall_tmp->next_nest; + while (forall_tmp != NULL) + { + /* Generate body with masks' control. */ + if (mask_flag) + { + pmask = forall_tmp->pmask; + mask = forall_tmp->mask; + maskindex = forall_tmp->maskindex; + + if (mask) + { + /* If a mask was specified make the assignment contitional. */ + if (pmask) + tmp = gfc_build_indirect_ref (mask); + else + tmp = mask; + tmp = gfc_build_array_ref (tmp, maskindex); + + body = build_v (COND_EXPR, tmp, body, build_empty_stmt ()); + } + } + nvar = forall_tmp->nvar; + body = gfc_trans_forall_loop (forall_tmp, nvar, body, mask_flag); + forall_tmp = forall_tmp->outer; + } + } + else + { + nvar = forall_tmp->nvar; + body = gfc_trans_forall_loop (forall_tmp, nvar, body, mask_flag); + } + + return body; +} + + +/* Allocate data for holding a temporary array. Returns either a local + temporary array or a pointer variable. */ + +static tree +gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock, + tree elem_type) +{ + tree tmpvar; + tree type; + tree tmp; + tree args; + + if (INTEGER_CST_P (size)) + { + tmp = fold (build (MINUS_EXPR, gfc_array_index_type, size, + integer_one_node)); + } + else + tmp = NULL_TREE; + + type = build_range_type (gfc_array_index_type, integer_zero_node, tmp); + type = build_array_type (elem_type, type); + if (gfc_can_put_var_on_stack (bytesize)) + { + assert (INTEGER_CST_P (size)); + tmpvar = gfc_create_var (type, "temp"); + *pdata = NULL_TREE; + } + else + { + tmpvar = gfc_create_var (build_pointer_type (type), "temp"); + *pdata = convert (pvoid_type_node, tmpvar); + + args = gfc_chainon_list (NULL_TREE, bytesize); + if (gfc_index_integer_kind == 4) + tmp = gfor_fndecl_internal_malloc; + else if (gfc_index_integer_kind == 8) + tmp = gfor_fndecl_internal_malloc64; + else + abort (); + tmp = gfc_build_function_call (tmp, args); + tmp = convert (TREE_TYPE (tmpvar), tmp); + gfc_add_modify_expr (pblock, tmpvar, tmp); + } + return tmpvar; +} + + +/* Generate codes to copy the temporary to the actual lhs. */ + +static tree +generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree size, + tree count3, tree count1, tree count2, tree wheremask) +{ + gfc_ss *lss; + gfc_se lse, rse; + stmtblock_t block, body; + gfc_loopinfo loop1; + tree tmp, tmp2; + tree index; + tree wheremaskexpr; + + /* Walk the lhs. */ + lss = gfc_walk_expr (expr); + + if (lss == gfc_ss_terminator) + { + gfc_start_block (&block); + + gfc_init_se (&lse, NULL); + + /* Translate the expression. */ + gfc_conv_expr (&lse, expr); + + /* Form the expression for the temporary. */ + tmp = gfc_build_array_ref (tmp1, count1); + + /* Use the scalar assignment as is. */ + gfc_add_block_to_block (&block, &lse.pre); + gfc_add_modify_expr (&block, lse.expr, tmp); + gfc_add_block_to_block (&block, &lse.post); + + /* Increment the count1. */ + tmp = fold (build (PLUS_EXPR, TREE_TYPE (count1), count1, size)); + gfc_add_modify_expr (&block, count1, tmp); + tmp = gfc_finish_block (&block); + } + else + { + gfc_start_block (&block); + + gfc_init_loopinfo (&loop1); + gfc_init_se (&rse, NULL); + gfc_init_se (&lse, NULL); + + /* Associate the lss with the loop. */ + gfc_add_ss_to_loop (&loop1, lss); + + /* Calculate the bounds of the scalarization. */ + gfc_conv_ss_startstride (&loop1); + /* Setup the scalarizing loops. */ + gfc_conv_loop_setup (&loop1); + + gfc_mark_ss_chain_used (lss, 1); + /* Initialize count2. */ + gfc_add_modify_expr (&block, count2, integer_zero_node); + + /* Start the scalarized loop body. */ + gfc_start_scalarized_body (&loop1, &body); + + /* Setup the gfc_se structures. */ + gfc_copy_loopinfo_to_se (&lse, &loop1); + lse.ss = lss; + + /* Form the expression of the temporary. */ + if (lss != gfc_ss_terminator) + { + index = fold (build (PLUS_EXPR, gfc_array_index_type, + count1, count2)); + rse.expr = gfc_build_array_ref (tmp1, index); + } + /* Translate expr. */ + gfc_conv_expr (&lse, expr); + + /* Use the scalar assignment. */ + tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type); + + /* Form the mask expression according to the mask tree list. */ + if (wheremask) + { + tmp2 = wheremask; + if (tmp2 != NULL) + wheremaskexpr = gfc_build_array_ref (tmp2, count3); + tmp2 = TREE_CHAIN (tmp2); + while (tmp2) + { + tmp1 = gfc_build_array_ref (tmp2, count3); + wheremaskexpr = build (TRUTH_AND_EXPR, TREE_TYPE (tmp1), + wheremaskexpr, tmp1); + tmp2 = TREE_CHAIN (tmp2); + } + tmp = build_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ()); + } + + gfc_add_expr_to_block (&body, tmp); + + /* Increment count2. */ + tmp = fold (build (PLUS_EXPR, TREE_TYPE (count2), count2, + integer_one_node)); + gfc_add_modify_expr (&body, count2, tmp); + + /* Increment count3. */ + if (count3) + { + tmp = fold (build (PLUS_EXPR, TREE_TYPE (count3), count3, + integer_one_node)); + gfc_add_modify_expr (&body, count3, tmp); + } + + /* Generate the copying loops. */ + gfc_trans_scalarizing_loops (&loop1, &body); + gfc_add_block_to_block (&block, &loop1.pre); + gfc_add_block_to_block (&block, &loop1.post); + gfc_cleanup_loop (&loop1); + + /* Increment count1. */ + tmp = fold (build (PLUS_EXPR, TREE_TYPE (count1), count1, size)); + gfc_add_modify_expr (&block, count1, tmp); + tmp = gfc_finish_block (&block); + } + return tmp; +} + + +/* Generate codes to copy rhs to the temporary. TMP1 is the address of temporary + LSS and RSS are formed in function compute_inner_temp_size(), and should + not be freed. */ + +static tree +generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree size, + tree count3, tree count1, tree count2, + gfc_ss *lss, gfc_ss *rss, tree wheremask) +{ + stmtblock_t block, body1; + gfc_loopinfo loop; + gfc_se lse; + gfc_se rse; + tree tmp, tmp2, index; + tree wheremaskexpr; + + gfc_start_block (&block); + + gfc_init_se (&rse, NULL); + gfc_init_se (&lse, NULL); + + if (lss == gfc_ss_terminator) + { + gfc_init_block (&body1); + gfc_conv_expr (&rse, expr2); + lse.expr = gfc_build_array_ref (tmp1, count1); + } + else + { + /* Initilize count2. */ + gfc_add_modify_expr (&block, count2, integer_zero_node); + + /* Initiliaze the loop. */ + gfc_init_loopinfo (&loop); + + /* We may need LSS to determine the shape of the expression. */ + gfc_add_ss_to_loop (&loop, lss); + gfc_add_ss_to_loop (&loop, rss); + + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop); + + gfc_mark_ss_chain_used (rss, 1); + /* Start the loop body. */ + gfc_start_scalarized_body (&loop, &body1); + + /* Translate the expression. */ + gfc_copy_loopinfo_to_se (&rse, &loop); + rse.ss = rss; + gfc_conv_expr (&rse, expr2); + + /* Form the expression of the temporary. */ + index = fold (build (PLUS_EXPR, gfc_array_index_type, count1, count2)); + lse.expr = gfc_build_array_ref (tmp1, index); + } + + /* Use the scalar assignment. */ + tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type); + + /* Form the mask expression according to the mask tree list. */ + if (wheremask) + { + tmp2 = wheremask; + if (tmp2 != NULL) + wheremaskexpr = gfc_build_array_ref (tmp2, count3); + tmp2 = TREE_CHAIN (tmp2); + while (tmp2) + { + tmp1 = gfc_build_array_ref (tmp2, count3); + wheremaskexpr = build (TRUTH_AND_EXPR, TREE_TYPE (tmp1), + wheremaskexpr, tmp1); + tmp2 = TREE_CHAIN (tmp2); + } + tmp = build_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ()); + } + + gfc_add_expr_to_block (&body1, tmp); + + if (lss == gfc_ss_terminator) + { + gfc_add_block_to_block (&block, &body1); + } + else + { + /* Increment count2. */ + tmp = fold (build (PLUS_EXPR, gfc_array_index_type, count2, + integer_one_node)); + gfc_add_modify_expr (&body1, count2, tmp); + + /* Increment count3. */ + if (count3) + { + tmp = fold (build (PLUS_EXPR, gfc_array_index_type, count3, + integer_one_node)); + gfc_add_modify_expr (&body1, count3, tmp); + } + + /* Generate the copying loops. */ + gfc_trans_scalarizing_loops (&loop, &body1); + + gfc_add_block_to_block (&block, &loop.pre); + gfc_add_block_to_block (&block, &loop.post); + + gfc_cleanup_loop (&loop); + /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful + as tree nodes in SS may not be valid in different scope. */ + } + /* Increment count1. */ + tmp = fold (build (PLUS_EXPR, TREE_TYPE (count1), count1, size)); + gfc_add_modify_expr (&block, count1, tmp); + + tmp = gfc_finish_block (&block); + return tmp; +} + + +/* Calculate the size of temporary needed in the assignment inside forall. + LSS and RSS are filled in this function. */ + +static tree +compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2, + stmtblock_t * pblock, + gfc_ss **lss, gfc_ss **rss) +{ + gfc_loopinfo loop; + tree size; + int i; + tree tmp; + + *lss = gfc_walk_expr (expr1); + *rss = NULL; + + size = integer_one_node; + if (*lss != gfc_ss_terminator) + { + gfc_init_loopinfo (&loop); + + /* Walk the RHS of the expression. */ + *rss = gfc_walk_expr (expr2); + if (*rss == gfc_ss_terminator) + { + /* The rhs is scalar. Add a ss for the expression. */ + *rss = gfc_get_ss (); + (*rss)->next = gfc_ss_terminator; + (*rss)->type = GFC_SS_SCALAR; + (*rss)->expr = expr2; + } + + /* Associate the SS with the loop. */ + gfc_add_ss_to_loop (&loop, *lss); + /* We don't actually need to add the rhs at this point, but it might + make guessing the loop bounds a bit easier. */ + gfc_add_ss_to_loop (&loop, *rss); + + /* We only want the shape of the expression, not rest of the junk + generated by the scalarizer. */ + loop.array_parameter = 1; + + /* Calculate the bounds of the scalarization. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop); + + /* Figure out how many elements we need. */ + for (i = 0; i < loop.dimen; i++) + { + tmp = fold (build (MINUS_EXPR, TREE_TYPE (loop.from[i]), + integer_one_node, loop.from[i])); + tmp = fold (build (PLUS_EXPR, TREE_TYPE (tmp), tmp, loop.to[i])); + size = fold (build (MULT_EXPR, TREE_TYPE (size), size, tmp)); + } + gfc_add_block_to_block (pblock, &loop.pre); + size = gfc_evaluate_now (size, pblock); + gfc_add_block_to_block (pblock, &loop.post); + + /* TODO: write a function that cleans up a loopinfo without freeing + the SS chains. Currently a NOP. */ + } + + return size; +} + + +/* Calculate the overall iterator number of the nested forall construct. */ + +static tree +compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size, + stmtblock_t *block) +{ + tree tmp, number; + stmtblock_t body; + + /* TODO: optimizing the computing process. */ + number = gfc_create_var (gfc_array_index_type, "num"); + gfc_add_modify_expr (block, number, integer_zero_node); + + gfc_start_block (&body); + if (nested_forall_info) + tmp = build (PLUS_EXPR, gfc_array_index_type, number, + inner_size); + else + tmp = inner_size; + gfc_add_modify_expr (&body, number, tmp); + tmp = gfc_finish_block (&body); + + /* Generate loops. */ + if (nested_forall_info != NULL) + tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 0, 1); + + gfc_add_expr_to_block (block, tmp); + + return number; +} + + +/* Allocate temporary for forall construct according to the information in + nested_forall_info. INNER_SIZE is the size of temporary needed in the + assignment inside forall. PTEMP1 is returned for space free. */ + +static tree +allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type, + tree inner_size, stmtblock_t * block, + tree * ptemp1) +{ + tree unit; + tree temp1; + tree tmp; + tree bytesize, size; + + /* Calculate the total size of temporary needed in forall construct. */ + size = compute_overall_iter_number (nested_forall_info, inner_size, block); + + unit = TYPE_SIZE_UNIT (type); + bytesize = fold (build (MULT_EXPR, gfc_array_index_type, size, unit)); + + *ptemp1 = NULL; + temp1 = gfc_do_allocate (bytesize, size, ptemp1, block, type); + + if (*ptemp1) + tmp = gfc_build_indirect_ref (temp1); + else + tmp = temp1; + + return tmp; +} + + +/* Handle assignments inside forall which need temporary. */ +static void +gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, tree wheremask, + forall_info * nested_forall_info, + stmtblock_t * block) +{ + tree type; + tree inner_size; + gfc_ss *lss, *rss; + tree count, count1, count2; + tree tmp, tmp1; + tree ptemp1; + tree mask, maskindex; + forall_info *forall_tmp; + + /* Create vars. count1 is the current iterator number of the nested forall. + count2 is the current iterator number of the inner loops needed in the + assignment. */ + count1 = gfc_create_var (gfc_array_index_type, "count1"); + count2 = gfc_create_var (gfc_array_index_type, "count2"); + + /* Count is the wheremask index. */ + if (wheremask) + { + count = gfc_create_var (gfc_array_index_type, "count"); + gfc_add_modify_expr (block, count, integer_zero_node); + } + else + count = NULL; + + /* Initialize count1. */ + gfc_add_modify_expr (block, count1, integer_zero_node); + + /* Calculate the size of temporary needed in the assignment. Return loop, lss + and rss which are used in function generate_loop_for_rhs_to_temp(). */ + inner_size = compute_inner_temp_size (expr1, expr2, block, &lss, &rss); + + /* The type of LHS. Used in function allocate_temp_for_forall_nest */ + type = gfc_typenode_for_spec (&expr1->ts); + + /* Allocate temporary for nested forall construct according to the + information in nested_forall_info and inner_size. */ + tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, + inner_size, block, &ptemp1); + + /* Initialize the maskindexes. */ + forall_tmp = nested_forall_info; + while (forall_tmp != NULL) + { + mask = forall_tmp->mask; + maskindex = forall_tmp->maskindex; + if (mask) + gfc_add_modify_expr (block, maskindex, integer_zero_node); + forall_tmp = forall_tmp->next_nest; + } + + /* Generate codes to copy rhs to the temporary . */ + tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, inner_size, count, + count1, count2, lss, rss, wheremask); + + /* Generate body and loops according to the inforamtion in + nested_forall_info. */ + tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); + gfc_add_expr_to_block (block, tmp); + + /* Reset count1. */ + gfc_add_modify_expr (block, count1, integer_zero_node); + + /* Reset maskindexed. */ + forall_tmp = nested_forall_info; + while (forall_tmp != NULL) + { + mask = forall_tmp->mask; + maskindex = forall_tmp->maskindex; + if (mask) + gfc_add_modify_expr (block, maskindex, integer_zero_node); + forall_tmp = forall_tmp->next_nest; + } + + /* Reset count. */ + if (wheremask) + gfc_add_modify_expr (block, count, integer_zero_node); + + /* Generate codes to copy the temporary to lhs. */ + tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, inner_size, count, + count1, count2, wheremask); + + /* Generate body and loops according to the inforamtion in + nested_forall_info. */ + tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); + gfc_add_expr_to_block (block, tmp); + + if (ptemp1) + { + /* Free the temporary. */ + tmp = gfc_chainon_list (NULL_TREE, ptemp1); + tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp); + gfc_add_expr_to_block (block, tmp); + } +} + + +/* Translate pointer assignment inside FORALL which need temporary. */ + +static void +gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, + forall_info * nested_forall_info, + stmtblock_t * block) +{ + tree type; + tree inner_size; + gfc_ss *lss, *rss; + gfc_se lse; + gfc_se rse; + gfc_ss_info *info; + gfc_loopinfo loop; + tree desc; + tree parm; + tree parmtype; + stmtblock_t body; + tree count; + tree tmp, tmp1, ptemp1; + tree mask, maskindex; + forall_info *forall_tmp; + + count = gfc_create_var (gfc_array_index_type, "count"); + gfc_add_modify_expr (block, count, integer_zero_node); + + inner_size = integer_one_node; + lss = gfc_walk_expr (expr1); + rss = gfc_walk_expr (expr2); + if (lss == gfc_ss_terminator) + { + type = gfc_typenode_for_spec (&expr1->ts); + type = build_pointer_type (type); + + /* Allocate temporary for nested forall construct according to the + information in nested_forall_info and inner_size. */ + tmp1 = allocate_temp_for_forall_nest (nested_forall_info, + type, inner_size, block, &ptemp1); + gfc_start_block (&body); + gfc_init_se (&lse, NULL); + lse.expr = gfc_build_array_ref (tmp1, count); + gfc_init_se (&rse, NULL); + rse.want_pointer = 1; + gfc_conv_expr (&rse, expr2); + gfc_add_block_to_block (&body, &rse.pre); + gfc_add_modify_expr (&body, lse.expr, rse.expr); + gfc_add_block_to_block (&body, &rse.post); + + /* Increment count. */ + tmp = fold (build (PLUS_EXPR, TREE_TYPE (count), count, + integer_one_node)); + gfc_add_modify_expr (&body, count, tmp); + + tmp = gfc_finish_block (&body); + + /* Initialize the maskindexes. */ + forall_tmp = nested_forall_info; + while (forall_tmp != NULL) + { + mask = forall_tmp->mask; + maskindex = forall_tmp->maskindex; + if (mask) + gfc_add_modify_expr (block, maskindex, integer_zero_node); + forall_tmp = forall_tmp->next_nest; + } + + /* Generate body and loops according to the inforamtion in + nested_forall_info. */ + tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); + gfc_add_expr_to_block (block, tmp); + + /* Reset count. */ + gfc_add_modify_expr (block, count, integer_zero_node); + + /* Reset maskindexes. */ + forall_tmp = nested_forall_info; + while (forall_tmp != NULL) + { + mask = forall_tmp->mask; + maskindex = forall_tmp->maskindex; + if (mask) + gfc_add_modify_expr (block, maskindex, integer_zero_node); + forall_tmp = forall_tmp->next_nest; + } + gfc_start_block (&body); + gfc_init_se (&lse, NULL); + gfc_init_se (&rse, NULL); + rse.expr = gfc_build_array_ref (tmp1, count); + lse.want_pointer = 1; + gfc_conv_expr (&lse, expr1); + gfc_add_block_to_block (&body, &lse.pre); + gfc_add_modify_expr (&body, lse.expr, rse.expr); + gfc_add_block_to_block (&body, &lse.post); + /* Increment count. */ + tmp = fold (build (PLUS_EXPR, TREE_TYPE (count), count, + integer_one_node)); + gfc_add_modify_expr (&body, count, tmp); + tmp = gfc_finish_block (&body); + + /* Generate body and loops according to the inforamtion in + nested_forall_info. */ + tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); + gfc_add_expr_to_block (block, tmp); + } + else + { + gfc_init_loopinfo (&loop); + + /* Associate the SS with the loop. */ + gfc_add_ss_to_loop (&loop, rss); + + /* Setup the scalarizing loops and bounds. */ + gfc_conv_ss_startstride (&loop); + + gfc_conv_loop_setup (&loop); + + info = &rss->data.info; + desc = info->descriptor; + + /* Make a new descriptor. */ + parmtype = gfc_get_element_type (TREE_TYPE (desc)); + parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, + loop.from, loop.to, 1); + + /* Allocate temporary for nested forall construct. */ + tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype, + inner_size, block, &ptemp1); + gfc_start_block (&body); + gfc_init_se (&lse, NULL); + lse.expr = gfc_build_array_ref (tmp1, count); + lse.direct_byref = 1; + rss = gfc_walk_expr (expr2); + gfc_conv_expr_descriptor (&lse, expr2, rss); + + gfc_add_block_to_block (&body, &lse.pre); + gfc_add_block_to_block (&body, &lse.post); + + /* Increment count. */ + tmp = fold (build (PLUS_EXPR, TREE_TYPE (count), count, + integer_one_node)); + gfc_add_modify_expr (&body, count, tmp); + + tmp = gfc_finish_block (&body); + + /* Initialize the maskindexes. */ + forall_tmp = nested_forall_info; + while (forall_tmp != NULL) + { + mask = forall_tmp->mask; + maskindex = forall_tmp->maskindex; + if (mask) + gfc_add_modify_expr (block, maskindex, integer_zero_node); + forall_tmp = forall_tmp->next_nest; + } + + /* Generate body and loops according to the inforamtion in + nested_forall_info. */ + tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); + gfc_add_expr_to_block (block, tmp); + + /* Reset count. */ + gfc_add_modify_expr (block, count, integer_zero_node); + + /* Reset maskindexes. */ + forall_tmp = nested_forall_info; + while (forall_tmp != NULL) + { + mask = forall_tmp->mask; + maskindex = forall_tmp->maskindex; + if (mask) + gfc_add_modify_expr (block, maskindex, integer_zero_node); + forall_tmp = forall_tmp->next_nest; + } + parm = gfc_build_array_ref (tmp1, count); + lss = gfc_walk_expr (expr1); + gfc_init_se (&lse, NULL); + gfc_conv_expr_descriptor (&lse, expr1, lss); + gfc_add_modify_expr (&lse.pre, lse.expr, parm); + gfc_start_block (&body); + gfc_add_block_to_block (&body, &lse.pre); + gfc_add_block_to_block (&body, &lse.post); + + /* Increment count. */ + tmp = fold (build (PLUS_EXPR, TREE_TYPE (count), count, + integer_one_node)); + gfc_add_modify_expr (&body, count, tmp); + + tmp = gfc_finish_block (&body); + + tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1); + gfc_add_expr_to_block (block, tmp); + } + /* Free the temporary. */ + if (ptemp1) + { + tmp = gfc_chainon_list (NULL_TREE, ptemp1); + tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp); + gfc_add_expr_to_block (block, tmp); + } +} + + +/* FORALL and WHERE statements are really nasty, especially when you nest + them. All the rhs of a forall assignment must be evaluated before the + actual assignments are performed. Presumably this also applies to all the + assignments in an inner where statement. */ + +/* Generate code for a FORALL statement. Any temporaries are allocated as a + linear array, relying on the fact that we process in the same order in all + loops. + + forall (i=start:end:stride; maskexpr) + e<i> = f<i> + g<i> = h<i> + end forall + (where e,f,g,h<i> are arbitary expressions possibly involving i) + Translates to: + count = ((end + 1 - start) / staride) + masktmp(:) = maskexpr(:) + + maskindex = 0; + for (i = start; i <= end; i += stride) + { + if (masktmp[maskindex++]) + e<i> = f<i> + } + maskindex = 0; + for (i = start; i <= end; i += stride) + { + if (masktmp[maskindex++]) + e<i> = f<i> + } + + Note that this code only works when there are no dependencies. + Forall loop with array assignments and data dependencies are a real pain, + because the size of the temporary cannot always be determined before the + loop is executed. This problem is compouded by the presence of nested + FORALL constructs. + */ + +static tree +gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) +{ + stmtblock_t block; + stmtblock_t body; + tree *var; + tree *start; + tree *end; + tree *step; + gfc_expr **varexpr; + tree tmp; + tree assign; + tree size; + tree bytesize; + tree tmpvar; + tree sizevar; + tree lenvar; + tree maskindex; + tree mask; + tree pmask; + int n; + int nvar; + int need_temp; + gfc_forall_iterator *fa; + gfc_se se; + gfc_code *c; + tree *saved_var_decl; + symbol_attribute *saved_var_attr; + iter_info *this_forall, *iter_tmp; + forall_info *info, *forall_tmp; + temporary_list *temp; + + gfc_start_block (&block); + + n = 0; + /* Count the FORALL index number. */ + for (fa = code->ext.forall_iterator; fa; fa = fa->next) + n++; + nvar = n; + + /* Allocate the space for var, start, end, step, varexpr. */ + var = (tree *) gfc_getmem (nvar * sizeof (tree)); + start = (tree *) gfc_getmem (nvar * sizeof (tree)); + end = (tree *) gfc_getmem (nvar * sizeof (tree)); + step = (tree *) gfc_getmem (nvar * sizeof (tree)); + varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *)); + saved_var_decl = (tree *) gfc_getmem (nvar * sizeof (tree)); + saved_var_attr = (symbol_attribute *) + gfc_getmem (nvar * sizeof (symbol_attribute)); + + /* Allocate the space for info. */ + info = (forall_info *) gfc_getmem (sizeof (forall_info)); + n = 0; + for (fa = code->ext.forall_iterator; fa; fa = fa->next) + { + gfc_symbol *sym = fa->var->symtree->n.sym; + + /* allocate space for this_forall. */ + this_forall = (iter_info *) gfc_getmem (sizeof (iter_info)); + + /* Save the FORALL index's backend_decl. */ + saved_var_decl[n] = sym->backend_decl; + + /* Save the attribute. */ + saved_var_attr[n] = sym->attr; + + /* Set the proper attributes. */ + gfc_clear_attr (&sym->attr); + sym->attr.referenced = 1; + sym->attr.flavor = FL_VARIABLE; + + /* Create a temporary variable for the FORALL index. */ + tmp = gfc_typenode_for_spec (&sym->ts); + var[n] = gfc_create_var (tmp, sym->name); + /* Record it in this_forall. */ + this_forall->var = var[n]; + + /* Replace the index symbol's backend_decl with the temporary decl. */ + sym->backend_decl = var[n]; + + /* Work out the start, end and stride for the loop. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, fa->start); + /* Record it in this_forall. */ + this_forall->start = se.expr; + gfc_add_block_to_block (&block, &se.pre); + start[n] = se.expr; + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, fa->end); + /* Record it in this_forall. */ + this_forall->end = se.expr; + gfc_make_safe_expr (&se); + gfc_add_block_to_block (&block, &se.pre); + end[n] = se.expr; + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, fa->stride); + /* Record it in this_forall. */ + this_forall->step = se.expr; + gfc_make_safe_expr (&se); + gfc_add_block_to_block (&block, &se.pre); + step[n] = se.expr; + + /* Set the NEXT field of this_forall to NULL. */ + this_forall->next = NULL; + /* Link this_forall to the info construct. */ + if (info->this_loop == NULL) + info->this_loop = this_forall; + else + { + iter_tmp = info->this_loop; + while (iter_tmp->next != NULL) + iter_tmp = iter_tmp->next; + iter_tmp->next = this_forall; + } + + n++; + } + nvar = n; + + /* Work out the number of elements in the mask array. */ + tmpvar = NULL_TREE; + lenvar = NULL_TREE; + size = integer_one_node; + sizevar = NULL_TREE; + + for (n = 0; n < nvar; n++) + { + if (lenvar && TREE_TYPE (lenvar) != TREE_TYPE (start[n])) + lenvar = NULL_TREE; + + /* size = (end + step - start) / step. */ + tmp = fold (build (MINUS_EXPR, TREE_TYPE (start[n]), step[n], start[n])); + tmp = fold (build (PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp)); + + tmp = fold (build (FLOOR_DIV_EXPR, TREE_TYPE (tmp), tmp, step[n])); + tmp = convert (gfc_array_index_type, tmp); + + size = fold (build (MULT_EXPR, gfc_array_index_type, size, tmp)); + } + + /* Record the nvar and size of current forall level. */ + info->nvar = nvar; + info->size = size; + + /* Link the current forall level to nested_forall_info. */ + forall_tmp = nested_forall_info; + if (forall_tmp == NULL) + nested_forall_info = info; + else + { + while (forall_tmp->next_nest != NULL) + forall_tmp = forall_tmp->next_nest; + info->outer = forall_tmp; + forall_tmp->next_nest = info; + } + + /* Copy the mask into a temporary variable if required. + For now we assume a mask temporary is needed. */ + if (code->expr) + { + /* Allocate the mask temporary. */ + bytesize = fold (build (MULT_EXPR, gfc_array_index_type, size, + TYPE_SIZE_UNIT (boolean_type_node))); + + mask = gfc_do_allocate (bytesize, size, &pmask, &block, boolean_type_node); + + maskindex = gfc_create_var_np (gfc_array_index_type, "mi"); + /* Record them in the info structure. */ + info->pmask = pmask; + info->mask = mask; + info->maskindex = maskindex; + + gfc_add_modify_expr (&block, maskindex, integer_zero_node); + + /* Start of mask assignment loop body. */ + gfc_start_block (&body); + + /* Evaluate the mask expression. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, code->expr); + gfc_add_block_to_block (&body, &se.pre); + + /* Store the mask. */ + se.expr = convert (boolean_type_node, se.expr); + + if (pmask) + tmp = gfc_build_indirect_ref (mask); + else + tmp = mask; + tmp = gfc_build_array_ref (tmp, maskindex); + gfc_add_modify_expr (&body, tmp, se.expr); + + /* Advance to the next mask element. */ + tmp = build (PLUS_EXPR, gfc_array_index_type, maskindex, + integer_one_node); + gfc_add_modify_expr (&body, maskindex, tmp); + + /* Generate the loops. */ + tmp = gfc_finish_block (&body); + tmp = gfc_trans_nested_forall_loop (info, tmp, 0, 0); + gfc_add_expr_to_block (&block, tmp); + } + else + { + /* No mask was specified. */ + maskindex = NULL_TREE; + mask = pmask = NULL_TREE; + } + + c = code->block->next; + + /* TODO: loop merging in FORALL statements. */ + /* Now that we've got a copy of the mask, generate the assignment loops. */ + while (c) + { + switch (c->op) + { + case EXEC_ASSIGN: + /* A scalar or array assingment. */ + need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar); + /* Teporaries due to array assignment data dependencies introduce + no end of problems. */ + if (need_temp) + gfc_trans_assign_need_temp (c->expr, c->expr2, NULL, + nested_forall_info, &block); + else + { + /* Use the normal assignment copying routines. */ + assign = gfc_trans_assignment (c->expr, c->expr2); + + /* Reset the mask index. */ + if (mask) + gfc_add_modify_expr (&block, maskindex, integer_zero_node); + + /* Generate body and loops. */ + tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1); + gfc_add_expr_to_block (&block, tmp); + } + + break; + + case EXEC_WHERE: + + /* Translate WHERE or WHERE construct nested in FORALL. */ + temp = NULL; + gfc_trans_where_2 (c, NULL, NULL, nested_forall_info, &block, &temp); + + while (temp) + { + tree args; + temporary_list *p; + + /* Free the temporary. */ + args = gfc_chainon_list (NULL_TREE, temp->temporary); + tmp = gfc_build_function_call (gfor_fndecl_internal_free, args); + gfc_add_expr_to_block (&block, tmp); + + p = temp; + temp = temp->next; + gfc_free (p); + } + + break; + + /* Pointer assignment inside FORALL. */ + case EXEC_POINTER_ASSIGN: + need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar); + if (need_temp) + gfc_trans_pointer_assign_need_temp (c->expr, c->expr2, + nested_forall_info, &block); + else + { + /* Use the normal assignment copying routines. */ + assign = gfc_trans_pointer_assignment (c->expr, c->expr2); + + /* Reset the mask index. */ + if (mask) + gfc_add_modify_expr (&block, maskindex, integer_zero_node); + + /* Generate body and loops. */ + tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, + 1, 1); + gfc_add_expr_to_block (&block, tmp); + } + break; + + case EXEC_FORALL: + tmp = gfc_trans_forall_1 (c, nested_forall_info); + gfc_add_expr_to_block (&block, tmp); + break; + + default: + abort (); + break; + } + + c = c->next; + } + + /* Restore the index original backend_decl and the attribute. */ + for (fa = code->ext.forall_iterator, n=0; fa; fa = fa->next, n++) + { + gfc_symbol *sym = fa->var->symtree->n.sym; + sym->backend_decl = saved_var_decl[n]; + sym->attr = saved_var_attr[n]; + } + + /* Free the space for var, start, end, step, varexpr. */ + gfc_free (var); + gfc_free (start); + gfc_free (end); + gfc_free (step); + gfc_free (varexpr); + gfc_free (saved_var_decl); + gfc_free (saved_var_attr); + + if (pmask) + { + /* Free the temporary for the mask. */ + tmp = gfc_chainon_list (NULL_TREE, pmask); + tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp); + gfc_add_expr_to_block (&block, tmp); + } + if (maskindex) + pushdecl (maskindex); + + return gfc_finish_block (&block); +} + + +/* Translate the FORALL statement or construct. */ + +tree gfc_trans_forall (gfc_code * code) +{ + return gfc_trans_forall_1 (code, NULL); +} + + +/* Evaluate the WHERE mask expression, copy its value to a temporary. + If the WHERE construct is nested in FORALL, compute the overall temporary + needed by the WHERE mask expression multiplied by the iterator number of + the nested forall. + ME is the WHERE mask expression. + MASK is the temporary which value is mask's value. + NMASK is another temporary which value is !mask. + TEMP records the temporary's address allocated in this function in order to + free them outside this function. + MASK, NMASK and TEMP are all OUT arguments. */ + +static tree +gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info, + tree * mask, tree * nmask, temporary_list ** temp, + stmtblock_t * block) +{ + tree tmp, tmp1; + gfc_ss *lss, *rss; + gfc_loopinfo loop; + tree ptemp1, ntmp, ptemp2; + tree inner_size; + stmtblock_t body, body1; + gfc_se lse, rse; + tree count; + tree tmpexpr; + + gfc_init_loopinfo (&loop); + + /* Calculate the size of temporary needed by the mask-expr. */ + inner_size = compute_inner_temp_size (me, me, block, &lss, &rss); + + /* Allocate temporary for where mask. */ + tmp = allocate_temp_for_forall_nest (nested_forall_info, boolean_type_node, + inner_size, block, &ptemp1); + /* Record the temporary address in order to free it later. */ + if (ptemp1) + { + temporary_list *tempo; + tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list)); + tempo->temporary = ptemp1; + tempo->next = *temp; + *temp = tempo; + } + + /* Allocate temporary for !mask. */ + ntmp = allocate_temp_for_forall_nest (nested_forall_info, boolean_type_node, + inner_size, block, &ptemp2); + /* Record the temporary in order to free it later. */ + if (ptemp2) + { + temporary_list *tempo; + tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list)); + tempo->temporary = ptemp2; + tempo->next = *temp; + *temp = tempo; + } + + /* Variable to index the temporary. */ + count = gfc_create_var (gfc_array_index_type, "count"); + /* Initilize count. */ + gfc_add_modify_expr (block, count, integer_zero_node); + + gfc_start_block (&body); + + gfc_init_se (&rse, NULL); + gfc_init_se (&lse, NULL); + + if (lss == gfc_ss_terminator) + { + gfc_init_block (&body1); + } + else + { + /* Initiliaze the loop. */ + gfc_init_loopinfo (&loop); + + /* We may need LSS to determine the shape of the expression. */ + gfc_add_ss_to_loop (&loop, lss); + gfc_add_ss_to_loop (&loop, rss); + + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop); + + gfc_mark_ss_chain_used (rss, 1); + /* Start the loop body. */ + gfc_start_scalarized_body (&loop, &body1); + + /* Translate the expression. */ + gfc_copy_loopinfo_to_se (&rse, &loop); + rse.ss = rss; + gfc_conv_expr (&rse, me); + } + /* Form the expression of the temporary. */ + lse.expr = gfc_build_array_ref (tmp, count); + tmpexpr = gfc_build_array_ref (ntmp, count); + + /* Use the scalar assignment to fill temporary TMP. */ + tmp1 = gfc_trans_scalar_assign (&lse, &rse, me->ts.type); + gfc_add_expr_to_block (&body1, tmp1); + + /* Fill temporary NTMP. */ + tmp1 = build1 (TRUTH_NOT_EXPR, TREE_TYPE (lse.expr), lse.expr); + gfc_add_modify_expr (&body1, tmpexpr, tmp1); + + if (lss == gfc_ss_terminator) + { + gfc_add_block_to_block (&body, &body1); + } + else + { + /* Increment count. */ + tmp1 = fold (build (PLUS_EXPR, gfc_array_index_type, count, + integer_one_node)); + gfc_add_modify_expr (&body1, count, tmp1); + + /* Generate the copying loops. */ + gfc_trans_scalarizing_loops (&loop, &body1); + + gfc_add_block_to_block (&body, &loop.pre); + gfc_add_block_to_block (&body, &loop.post); + + gfc_cleanup_loop (&loop); + /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful + as tree nodes in SS may not be valid in different scope. */ + } + + tmp1 = gfc_finish_block (&body); + /* If the WHERE construct is inside FORALL, fill the full temporary. */ + if (nested_forall_info != NULL) + tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1); + + + gfc_add_expr_to_block (block, tmp1); + + *mask = tmp; + *nmask = ntmp; + + return tmp1; +} + + +/* Translate an assignment statement in a WHERE statement or construct + statement. The MASK expression is used to control which elements + of EXPR1 shall be assigned. */ + +static tree +gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, tree mask, + tree count1, tree count2) +{ + gfc_se lse; + gfc_se rse; + gfc_ss *lss; + gfc_ss *lss_section; + gfc_ss *rss; + + gfc_loopinfo loop; + tree tmp; + stmtblock_t block; + stmtblock_t body; + tree index, maskexpr, tmp1; + +#if 0 + /* TODO: handle this special case. + Special case a single function returning an array. */ + if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0) + { + tmp = gfc_trans_arrayfunc_assign (expr1, expr2); + if (tmp) + return tmp; + } +#endif + + /* Assignment of the form lhs = rhs. */ + gfc_start_block (&block); + + gfc_init_se (&lse, NULL); + gfc_init_se (&rse, NULL); + + /* Walk the lhs. */ + lss = gfc_walk_expr (expr1); + rss = NULL; + + /* In each where-assign-stmt, the mask-expr and the variable being + defined shall be arrays of the same shape. */ + assert (lss != gfc_ss_terminator); + + /* The assignment needs scalarization. */ + lss_section = lss; + + /* Find a non-scalar SS from the lhs. */ + while (lss_section != gfc_ss_terminator + && lss_section->type != GFC_SS_SECTION) + lss_section = lss_section->next; + + assert (lss_section != gfc_ss_terminator); + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + + /* Walk the rhs. */ + rss = gfc_walk_expr (expr2); + if (rss == gfc_ss_terminator) + { + /* The rhs is scalar. Add a ss for the expression. */ + rss = gfc_get_ss (); + rss->next = gfc_ss_terminator; + rss->type = GFC_SS_SCALAR; + rss->expr = expr2; + } + + /* Associate the SS with the loop. */ + gfc_add_ss_to_loop (&loop, lss); + gfc_add_ss_to_loop (&loop, rss); + + /* Calculate the bounds of the scalarization. */ + gfc_conv_ss_startstride (&loop); + + /* Resolve any data dependencies in the statement. */ + gfc_conv_resolve_dependencies (&loop, lss_section, rss); + + /* Setup the scalarizing loops. */ + gfc_conv_loop_setup (&loop); + + /* Setup the gfc_se structures. */ + gfc_copy_loopinfo_to_se (&lse, &loop); + gfc_copy_loopinfo_to_se (&rse, &loop); + + rse.ss = rss; + gfc_mark_ss_chain_used (rss, 1); + if (loop.temp_ss == NULL) + { + lse.ss = lss; + gfc_mark_ss_chain_used (lss, 1); + } + else + { + lse.ss = loop.temp_ss; + gfc_mark_ss_chain_used (lss, 3); + gfc_mark_ss_chain_used (loop.temp_ss, 3); + } + + /* Start the scalarized loop body. */ + gfc_start_scalarized_body (&loop, &body); + + /* Translate the expression. */ + gfc_conv_expr (&rse, expr2); + if (lss != gfc_ss_terminator && loop.temp_ss != NULL) + { + gfc_conv_tmp_array_ref (&lse); + gfc_advance_se_ss_chain (&lse); + } + else + gfc_conv_expr (&lse, expr1); + + /* Form the mask expression according to the mask tree list. */ + index = count1; + tmp = mask; + if (tmp != NULL) + maskexpr = gfc_build_array_ref (tmp, index); + else + maskexpr = NULL; + + tmp = TREE_CHAIN (tmp); + while (tmp) + { + tmp1 = gfc_build_array_ref (tmp, index); + maskexpr = build (TRUTH_AND_EXPR, TREE_TYPE (tmp1), maskexpr, tmp1); + tmp = TREE_CHAIN (tmp); + } + /* Use the scalar assignment as is. */ + tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type); + tmp = build_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ()); + + gfc_add_expr_to_block (&body, tmp); + + if (lss == gfc_ss_terminator) + { + /* Increment count1. */ + tmp = fold (build (PLUS_EXPR, TREE_TYPE (count1), count1, + integer_one_node)); + gfc_add_modify_expr (&body, count1, tmp); + + /* Use the scalar assignment as is. */ + gfc_add_block_to_block (&block, &body); + } + else + { + if (lse.ss != gfc_ss_terminator) + abort (); + if (rse.ss != gfc_ss_terminator) + abort (); + + if (loop.temp_ss != NULL) + { + /* Increment count1 before finish the main body of a scalarized + expression. */ + tmp = fold (build (PLUS_EXPR, TREE_TYPE (count1), count1, + integer_one_node)); + gfc_add_modify_expr (&body, count1, tmp); + gfc_trans_scalarized_loop_boundary (&loop, &body); + + /* We need to copy the temporary to the actual lhs. */ + gfc_init_se (&lse, NULL); + gfc_init_se (&rse, NULL); + gfc_copy_loopinfo_to_se (&lse, &loop); + gfc_copy_loopinfo_to_se (&rse, &loop); + + rse.ss = loop.temp_ss; + lse.ss = lss; + + gfc_conv_tmp_array_ref (&rse); + gfc_advance_se_ss_chain (&rse); + gfc_conv_expr (&lse, expr1); + + if (lse.ss != gfc_ss_terminator) + abort (); + + if (rse.ss != gfc_ss_terminator) + abort (); + + /* Form the mask expression according to the mask tree list. */ + index = count2; + tmp = mask; + if (tmp != NULL) + maskexpr = gfc_build_array_ref (tmp, index); + else + maskexpr = NULL; + + tmp = TREE_CHAIN (tmp); + while (tmp) + { + tmp1 = gfc_build_array_ref (tmp, index); + maskexpr = build (TRUTH_AND_EXPR, TREE_TYPE (tmp1), maskexpr, + tmp1); + tmp = TREE_CHAIN (tmp); + } + /* Use the scalar assignment as is. */ + tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type); + tmp = build_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ()); + gfc_add_expr_to_block (&body, tmp); + /* Increment count2. */ + tmp = fold (build (PLUS_EXPR, TREE_TYPE (count2), count2, + integer_one_node)); + gfc_add_modify_expr (&body, count2, tmp); + } + else + { + /* Increment count1. */ + tmp = fold (build (PLUS_EXPR, TREE_TYPE (count1), count1, + integer_one_node)); + gfc_add_modify_expr (&body, count1, tmp); + } + + /* Generate the copying loops. */ + gfc_trans_scalarizing_loops (&loop, &body); + + /* Wrap the whole thing up. */ + gfc_add_block_to_block (&block, &loop.pre); + gfc_add_block_to_block (&block, &loop.post); + gfc_cleanup_loop (&loop); + } + + return gfc_finish_block (&block); +} + + +/* Translate the WHERE construct or statement. + This fuction can be called iteratelly to translate the nested WHERE + construct or statement. + MASK is the control mask, and PMASK is the pending control mask. + TEMP records the temporary address which must be freed later. */ + +static void +gfc_trans_where_2 (gfc_code * code, tree mask, tree pmask, + forall_info * nested_forall_info, stmtblock_t * block, + temporary_list ** temp) +{ + gfc_expr *expr1; + gfc_expr *expr2; + gfc_code *cblock; + gfc_code *cnext; + tree tmp, tmp1, tmp2; + tree count1, count2; + tree mask_copy; + int need_temp; + + /* the WHERE statement or the WHERE construct statement. */ + cblock = code->block; + while (cblock) + { + /* Has mask-expr. */ + if (cblock->expr) + { + /* Ensure that the WHERE mask be evaluated only once. */ + tmp2 = gfc_evaluate_where_mask (cblock->expr, nested_forall_info, + &tmp, &tmp1, temp, block); + + /* Set the control mask and the pending control mask. */ + /* It's a where-stmt. */ + if (mask == NULL) + { + mask = tmp; + pmask = tmp1; + } + /* It's a nested where-stmt. */ + else if (mask && pmask == NULL) + { + tree tmp2; + /* Use the TREE_CHAIN to list the masks. */ + tmp2 = copy_list (mask); + pmask = chainon (mask, tmp1); + mask = chainon (tmp2, tmp); + } + /* It's a masked-elsewhere-stmt. */ + else if (mask && cblock->expr) + { + tree tmp2; + tmp2 = copy_list (pmask); + + mask = pmask; + tmp2 = chainon (tmp2, tmp); + pmask = chainon (mask, tmp1); + mask = tmp2; + } + } + /* It's a elsewhere-stmt. No mask-expr is present. */ + else + mask = pmask; + + /* Get the assignment statement of a WHERE statement, or the first + statement in where-body-construct of a WHERE construct. */ + cnext = cblock->next; + while (cnext) + { + switch (cnext->op) + { + /* WHERE assignment statement. */ + case EXEC_ASSIGN: + expr1 = cnext->expr; + expr2 = cnext->expr2; + if (nested_forall_info != NULL) + { + int nvar; + gfc_expr **varexpr; + + nvar = nested_forall_info->nvar; + varexpr = (gfc_expr **) + gfc_getmem (nvar * sizeof (gfc_expr *)); + need_temp = gfc_check_dependency (expr1, expr2, varexpr, + nvar); + if (need_temp) + gfc_trans_assign_need_temp (expr1, expr2, mask, + nested_forall_info, block); + else + { + /* Variables to control maskexpr. */ + count1 = gfc_create_var (gfc_array_index_type, "count1"); + count2 = gfc_create_var (gfc_array_index_type, "count2"); + gfc_add_modify_expr (block, count1, integer_zero_node); + gfc_add_modify_expr (block, count2, integer_zero_node); + + tmp = gfc_trans_where_assign (expr1, expr2, mask, count1, + count2); + tmp = gfc_trans_nested_forall_loop (nested_forall_info, + tmp, 1, 1); + gfc_add_expr_to_block (block, tmp); + } + } + else + { + /* Variables to control maskexpr. */ + count1 = gfc_create_var (gfc_array_index_type, "count1"); + count2 = gfc_create_var (gfc_array_index_type, "count2"); + gfc_add_modify_expr (block, count1, integer_zero_node); + gfc_add_modify_expr (block, count2, integer_zero_node); + + tmp = gfc_trans_where_assign (expr1, expr2, mask, count1, + count2); + gfc_add_expr_to_block (block, tmp); + + } + break; + + /* WHERE or WHERE construct is part of a where-body-construct. */ + case EXEC_WHERE: + /* Ensure that MASK is not modified by next gfc_trans_where_2. */ + mask_copy = copy_list (mask); + gfc_trans_where_2 (cnext, mask_copy, NULL, nested_forall_info, + block, temp); + break; + + default: + abort (); + } + + /* The next statement within the same where-body-construct. */ + cnext = cnext->next; + } + /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */ + cblock = cblock->block; + } +} + + +/* As the WHERE or WHERE construct statement can be nested, we call + gfc_trans_where_2 to do the translation, and pass the initial + NULL values for both the control mask and the pending control mask. */ + +tree +gfc_trans_where (gfc_code * code) +{ + stmtblock_t block; + temporary_list *temp, *p; + tree args; + tree tmp; + + gfc_start_block (&block); + temp = NULL; + + gfc_trans_where_2 (code, NULL, NULL, NULL, &block, &temp); + + /* Add calls to free temporaries which were dynamically allocated. */ + while (temp) + { + args = gfc_chainon_list (NULL_TREE, temp->temporary); + tmp = gfc_build_function_call (gfor_fndecl_internal_free, args); + gfc_add_expr_to_block (&block, tmp); + + p = temp; + temp = temp->next; + gfc_free (p); + } + return gfc_finish_block (&block); +} + + +/* CYCLE a DO loop. The label decl has already been created by + gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code + node at the head of the loop. We must mark the label as used. */ + +tree +gfc_trans_cycle (gfc_code * code) +{ + tree cycle_label; + + cycle_label = TREE_PURPOSE (code->ext.whichloop->backend_decl); + TREE_USED (cycle_label) = 1; + return build1_v (GOTO_EXPR, cycle_label); +} + + +/* EXIT a DO loop. Similair to CYCLE, but now the label is in + TREE_VALUE (backend_decl) of the gfc_code node at the head of the + loop. */ + +tree +gfc_trans_exit (gfc_code * code) +{ + tree exit_label; + + exit_label = TREE_VALUE (code->ext.whichloop->backend_decl); + TREE_USED (exit_label) = 1; + return build1_v (GOTO_EXPR, exit_label); +} + + +/* Translate the ALLOCATE statement. */ + +tree +gfc_trans_allocate (gfc_code * code) +{ + gfc_alloc *al; + gfc_expr *expr; + gfc_se se; + tree tmp; + tree parm; + gfc_ref *ref; + tree stat; + tree pstat; + tree error_label; + stmtblock_t block; + + if (!code->ext.alloc_list) + return NULL_TREE; + + gfc_start_block (&block); + + if (code->expr) + { + stat = gfc_create_var (gfc_int4_type_node, "stat"); + pstat = gfc_build_addr_expr (NULL, stat); + + error_label = gfc_build_label_decl (NULL_TREE); + TREE_USED (error_label) = 1; + } + else + { + pstat = integer_zero_node; + stat = error_label = NULL_TREE; + } + + + for (al = code->ext.alloc_list; al != NULL; al = al->next) + { + expr = al->expr; + + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + se.want_pointer = 1; + se.descriptor_only = 1; + gfc_conv_expr (&se, expr); + + ref = expr->ref; + + /* Find the last reference in the chain. */ + while (ref && ref->next != NULL) + { + assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT); + ref = ref->next; + } + + if (ref != NULL && ref->type == REF_ARRAY) + { + /* An array. */ + gfc_array_allocate (&se, ref, pstat); + } + else + { + /* A scalar or derived type. */ + tree val; + + val = gfc_create_var (ppvoid_type_node, "ptr"); + tmp = gfc_build_addr_expr (ppvoid_type_node, se.expr); + gfc_add_modify_expr (&se.pre, val, tmp); + + tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); + parm = gfc_chainon_list (NULL_TREE, val); + parm = gfc_chainon_list (parm, tmp); + parm = gfc_chainon_list (parm, pstat); + tmp = gfc_build_function_call (gfor_fndecl_allocate, parm); + gfc_add_expr_to_block (&se.pre, tmp); + + if (code->expr) + { + tmp = build1_v (GOTO_EXPR, error_label); + parm = + build (NE_EXPR, boolean_type_node, stat, integer_zero_node); + tmp = build_v (COND_EXPR, parm, tmp, build_empty_stmt ()); + gfc_add_expr_to_block (&se.pre, tmp); + } + } + + tmp = gfc_finish_block (&se.pre); + gfc_add_expr_to_block (&block, tmp); + } + + /* Assign the value to the status variable. */ + if (code->expr) + { + tmp = build1_v (LABEL_EXPR, error_label); + gfc_add_expr_to_block (&block, tmp); + + gfc_init_se (&se, NULL); + gfc_conv_expr_lhs (&se, code->expr); + tmp = convert (TREE_TYPE (se.expr), stat); + gfc_add_modify_expr (&block, se.expr, tmp); + } + + return gfc_finish_block (&block); +} + + +tree +gfc_trans_deallocate (gfc_code * code) +{ + gfc_se se; + gfc_alloc *al; + gfc_expr *expr; + tree var; + tree tmp; + tree type; + stmtblock_t block; + + gfc_start_block (&block); + + for (al = code->ext.alloc_list; al != NULL; al = al->next) + { + expr = al->expr; + assert (expr->expr_type == EXPR_VARIABLE); + + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + se.want_pointer = 1; + se.descriptor_only = 1; + gfc_conv_expr (&se, expr); + + if (expr->symtree->n.sym->attr.dimension) + { + tmp = gfc_array_deallocate (se.expr); + gfc_add_expr_to_block (&se.pre, tmp); + } + else + { + type = build_pointer_type (TREE_TYPE (se.expr)); + var = gfc_create_var (type, "ptr"); + tmp = gfc_build_addr_expr (type, se.expr); + gfc_add_modify_expr (&se.pre, var, tmp); + + tmp = gfc_chainon_list (NULL_TREE, var); + tmp = gfc_chainon_list (tmp, integer_zero_node); + tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp); + gfc_add_expr_to_block (&se.pre, tmp); + } + tmp = gfc_finish_block (&se.pre); + gfc_add_expr_to_block (&block, tmp); + } + + return gfc_finish_block (&block); +} + diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h new file mode 100644 index 00000000000..ff62dd5b017 --- /dev/null +++ b/gcc/fortran/trans-stmt.h @@ -0,0 +1,65 @@ +/* Header for statement translation functions + Copyright (C) 2002, 2003 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Statement translators (gfc_trans_*) return a fully translated tree. + Calls gfc_trans_*. */ +tree gfc_trans_code (gfc_code *); + +/* All other gfc_trans_* should only need be called by gfc_trans_code */ + +/* trans-expr.c */ +tree gfc_trans_assign (gfc_code *); +tree gfc_trans_pointer_assign (gfc_code *); + +/* trans-stmt.c */ +tree gfc_trans_cycle (gfc_code *); +tree gfc_trans_exit (gfc_code *); +tree gfc_trans_label_assign (gfc_code *); +tree gfc_trans_label_here (gfc_code *); +tree gfc_trans_goto (gfc_code *); +tree gfc_trans_pause (gfc_code *); +tree gfc_trans_stop (gfc_code *); +tree gfc_trans_call (gfc_code *); +tree gfc_trans_return (gfc_code *); +tree gfc_trans_if (gfc_code *); +tree gfc_trans_arithmetic_if (gfc_code *); +tree gfc_trans_do (gfc_code *); +tree gfc_trans_do_while (gfc_code *); +tree gfc_trans_select (gfc_code *); +tree gfc_trans_forall (gfc_code *); +tree gfc_trans_where (gfc_code *); +tree gfc_trans_allocate (gfc_code *); +tree gfc_trans_deallocate (gfc_code *); +tree gfc_trans_deallocate_array (tree); + +/* trans-io.c */ +tree gfc_trans_open (gfc_code *); +tree gfc_trans_close (gfc_code *); +tree gfc_trans_read (gfc_code *); +tree gfc_trans_write (gfc_code *); +tree gfc_trans_iolength (gfc_code *); +tree gfc_trans_backspace (gfc_code *); +tree gfc_trans_endfile (gfc_code *); +tree gfc_trans_inquire (gfc_code *); +tree gfc_trans_rewind (gfc_code *); + +tree gfc_trans_transfer (gfc_code *); +tree gfc_trans_dt_end (gfc_code *); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c new file mode 100644 index 00000000000..12943891582 --- /dev/null +++ b/gcc/fortran/trans-types.c @@ -0,0 +1,1485 @@ +/* Backend support for Fortran 95 basic types and derived types. + Copyright (C) 2002, 2003 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + and Steven Bosscher <s.bosscher@student.tudelft.nl> + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* trans-types.c -- gfortran backend types */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include <stdio.h> +#include "ggc.h" +#include "toplev.h" +#include <assert.h> +#include "gfortran.h" +#include "trans.h" +#include "trans-types.h" +#include "trans-const.h" + + +#if (GFC_MAX_DIMENSIONS < 10) +#define GFC_RANK_DIGITS 1 +#define GFC_RANK_PRINTF_FORMAT "%01d" +#elif (GFC_MAX_DIMENSIONS < 100) +#define GFC_RANK_DIGITS 2 +#define GFC_RANK_PRINTF_FORMAT "%02d" +#else +#error If you really need >99 dimensions, continue the sequence above... +#endif + +static tree gfc_get_derived_type (gfc_symbol * derived); + +tree gfc_type_nodes[NUM_F95_TYPES]; + +tree gfc_array_index_type; +tree pvoid_type_node; +tree ppvoid_type_node; +tree pchar_type_node; + +static GTY(()) tree gfc_desc_dim_type = NULL; + +static GTY(()) tree gfc_max_array_element_size; + +/* Create the backend type nodes. We map them to their + equivalent C type, at least for now. We also give + names to the types here, and we push them in the + global binding level context.*/ +void +gfc_init_types (void) +{ + unsigned n; + unsigned HOST_WIDE_INT hi; + unsigned HOST_WIDE_INT lo; + + /* Name the types. */ +#define PUSH_TYPE(name, node) \ + pushdecl (build_decl (TYPE_DECL, get_identifier (name), node)) + + gfc_int1_type_node = signed_char_type_node; + PUSH_TYPE ("int1", gfc_int1_type_node); + gfc_int2_type_node = short_integer_type_node; + PUSH_TYPE ("int2", gfc_int2_type_node); + gfc_int4_type_node = gfc_type_for_size (32, 0 /*unsigned */ ); + PUSH_TYPE ("int4", gfc_int4_type_node); + gfc_int8_type_node = gfc_type_for_size (64, 0 /*unsigned */ ); + PUSH_TYPE ("int8", gfc_int8_type_node); +#if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64)) + gfc_int16_type_node = gfc_type_for_size (128, 0 /*unsigned */ ); + PUSH_TYPE ("int16", gfc_int16_type_node); +#endif + + gfc_real4_type_node = float_type_node; + PUSH_TYPE ("real4", gfc_real4_type_node); + gfc_real8_type_node = double_type_node; + PUSH_TYPE ("real8", gfc_real8_type_node); +#if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64)) + /* Hmm, this will not work. Ref. g77 */ + gfc_real16_type_node = long_double_type_node; + PUSH_TYPE ("real16", gfc_real16_type_node); +#endif + + gfc_complex4_type_node = complex_float_type_node; + PUSH_TYPE ("complex4", gfc_complex4_type_node); + gfc_complex8_type_node = complex_double_type_node; + PUSH_TYPE ("complex8", gfc_complex8_type_node); +#if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64)) + /* Hmm, this will not work. Ref. g77 */ + gfc_complex16_type_node = complex_long_double_type_node; + PUSH_TYPE ("complex16", gfc_complex16_type_node); +#endif + + gfc_logical1_type_node = make_node (BOOLEAN_TYPE); + TYPE_PRECISION (gfc_logical1_type_node) = 8; + fixup_unsigned_type (gfc_logical1_type_node); + PUSH_TYPE ("logical1", gfc_logical1_type_node); + gfc_logical2_type_node = make_node (BOOLEAN_TYPE); + TYPE_PRECISION (gfc_logical2_type_node) = 16; + fixup_unsigned_type (gfc_logical2_type_node); + PUSH_TYPE ("logical2", gfc_logical2_type_node); + gfc_logical4_type_node = make_node (BOOLEAN_TYPE); + TYPE_PRECISION (gfc_logical4_type_node) = 32; + fixup_unsigned_type (gfc_logical4_type_node); + PUSH_TYPE ("logical4", gfc_logical4_type_node); + gfc_logical8_type_node = make_node (BOOLEAN_TYPE); + TYPE_PRECISION (gfc_logical8_type_node) = 64; + fixup_unsigned_type (gfc_logical8_type_node); + PUSH_TYPE ("logical8", gfc_logical8_type_node); +#if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64)) + gfc_logical16_type_node = make_node (BOOLEAN_TYPE); + TYPE_PRECISION (gfc_logical16_type_node) = 128; + fixup_unsigned_type (gfc_logical16_type_node); + PUSH_TYPE ("logical16", gfc_logical16_type_node); +#endif + + gfc_character1_type_node = build_type_variant (signed_char_type_node, 0, 0); + PUSH_TYPE ("char", gfc_character1_type_node); + + PUSH_TYPE ("byte", unsigned_char_type_node); + PUSH_TYPE ("void", void_type_node); + + /* DBX debugging output gets upset if these aren't set. */ + if (!TYPE_NAME (integer_type_node)) + PUSH_TYPE ("c_integer", integer_type_node); + if (!TYPE_NAME (char_type_node)) + PUSH_TYPE ("c_char", char_type_node); +#undef PUSH_TYPE + + pvoid_type_node = build_pointer_type (void_type_node); + ppvoid_type_node = build_pointer_type (pvoid_type_node); + pchar_type_node = build_pointer_type (gfc_character1_type_node); + + gfc_index_integer_kind = TYPE_PRECISION (long_unsigned_type_node) / 8; + gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind); + + /* The maximum array element size that can be handled is determined + by the number of bits available to store this field in the array + descriptor. */ + + n = TREE_INT_CST_LOW (TYPE_SIZE (gfc_array_index_type)) + - GFC_DTYPE_SIZE_SHIFT; + + if (n > sizeof (HOST_WIDE_INT) * 8) + { + lo = ~(unsigned HOST_WIDE_INT) 0; + hi = lo >> (sizeof (HOST_WIDE_INT) * 16 - n); + } + else + { + hi = 0; + lo = (~(unsigned HOST_WIDE_INT) 0) >> (sizeof (HOST_WIDE_INT) * 8 - n); + } + gfc_max_array_element_size = build_int_2 (lo, hi); + TREE_TYPE (gfc_max_array_element_size) = long_unsigned_type_node; + + size_type_node = gfc_array_index_type; + boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind ()); + + boolean_true_node = build_int_2 (1, 0); + TREE_TYPE (boolean_true_node) = boolean_type_node; + boolean_false_node = build_int_2 (0, 0); + TREE_TYPE (boolean_false_node) = boolean_type_node; +} + +/* Get a type node for an integer kind */ +tree +gfc_get_int_type (int kind) +{ + switch (kind) + { + case 1: + return (gfc_int1_type_node); + case 2: + return (gfc_int2_type_node); + case 4: + return (gfc_int4_type_node); + case 8: + return (gfc_int8_type_node); +#if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64)) + case 16: + return (95 _int16_type_node); +#endif + default: + fatal_error ("integer kind=%d not available", kind); + } +} + +/* Get a type node for a real kind */ +tree +gfc_get_real_type (int kind) +{ + switch (kind) + { + case 4: + return (gfc_real4_type_node); + case 8: + return (gfc_real8_type_node); +#if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64)) + case 16: + return (gfc_real16_type_node); +#endif + default: + fatal_error ("real kind=%d not available", kind); + } +} + +/* Get a type node for a complex kind */ +tree +gfc_get_complex_type (int kind) +{ + switch (kind) + { + case 4: + return (gfc_complex4_type_node); + case 8: + return (gfc_complex8_type_node); +#if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64)) + case 16: + return (gfc_complex16_type_node); +#endif + default: + fatal_error ("complex kind=%d not available", kind); + } +} + +/* Get a type node for a logical kind */ +tree +gfc_get_logical_type (int kind) +{ + switch (kind) + { + case 1: + return (gfc_logical1_type_node); + case 2: + return (gfc_logical2_type_node); + case 4: + return (gfc_logical4_type_node); + case 8: + return (gfc_logical8_type_node); +#if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64)) + case 16: + return (gfc_logical16_type_node); +#endif + default: + fatal_error ("logical kind=%d not available", kind); + } +} + +/* Get a type node for a character kind. */ +tree +gfc_get_character_type (int kind, gfc_charlen * cl) +{ + tree base; + tree type; + tree len; + tree bounds; + + switch (kind) + { + case 1: + base = gfc_character1_type_node; + break; + + default: + fatal_error ("character kind=%d not available", kind); + } + + len = (cl == 0) ? NULL_TREE : cl->backend_decl; + + bounds = build_range_type (gfc_array_index_type, integer_one_node, len); + type = build_array_type (base, bounds); + TYPE_STRING_FLAG (type) = 1; + + return type; +} + +/* Covert a basic type. This will be an array for character types. */ +tree +gfc_typenode_for_spec (gfc_typespec * spec) +{ + tree basetype; + + switch (spec->type) + { + case BT_UNKNOWN: + abort (); + break; + + case BT_INTEGER: + basetype = gfc_get_int_type (spec->kind); + break; + + case BT_REAL: + basetype = gfc_get_real_type (spec->kind); + break; + + case BT_COMPLEX: + basetype = gfc_get_complex_type (spec->kind); + break; + + case BT_LOGICAL: + basetype = gfc_get_logical_type (spec->kind); + break; + + case BT_CHARACTER: + basetype = gfc_get_character_type (spec->kind, spec->cl); + break; + + case BT_DERIVED: + basetype = gfc_get_derived_type (spec->derived); + break; + + default: + abort (); + break; + } + return basetype; +} + +/* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */ +static tree +gfc_conv_array_bound (gfc_expr * expr) +{ + /* If expr is an integer constant, return that. */ + if (expr != NULL && expr->expr_type == EXPR_CONSTANT) + return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind); + + /* Otherwise return NULL. */ + return NULL_TREE; +} + +tree +gfc_get_element_type (tree type) +{ + tree element; + + if (GFC_ARRAY_TYPE_P (type)) + { + if (TREE_CODE (type) == POINTER_TYPE) + type = TREE_TYPE (type); + assert (TREE_CODE (type) == ARRAY_TYPE); + element = TREE_TYPE (type); + } + else + { + assert (GFC_DESCRIPTOR_TYPE_P (type)); + element = TREE_TYPE (TYPE_FIELDS (type)); + + assert (TREE_CODE (element) == POINTER_TYPE); + element = TREE_TYPE (element); + + assert (TREE_CODE (element) == ARRAY_TYPE); + element = TREE_TYPE (element); + } + + return element; +} + +/* Build an array. This function is called from gfc_sym_type(). + Actualy returns array descriptor type. + + Format of array descriptors is as follows: + + struct gfc_array_descriptor + { + array *data + index offset; + index dtype; + struct descriptor_dimension dimension[N_DIM]; + } + + struct descriptor_dimension + { + index stride; + index lbound; + index ubound; + } + + Translation code should use gfc_conv_descriptor_* rather than accessing + the descriptor directly. Any changes to the array descriptor type will + require changes in gfc_conv_descriptor_* and gfc_build_array_initializer. + + This is represented internaly as a RECORD_TYPE. The index nodes are + gfc_array_index_type and the data node is a pointer to the data. See below + for the handling of character types. + + The dtype member is formatted as follows: + rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits + type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits + size = dtype >> GFC_DTYPE_SIZE_SHIFT + + I originaly used nested ARRAY_TYPE nodes to represent arrays, but this + generated poor code for assumed/deferred size arrays. These require + use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of GIMPLE + grammar. Also, there is no way to explicitly set the array stride, so + all data must be packed(1). I've tried to mark all the functions which + would require modification with a GCC ARRAYS comment. + + The data component points to the first element in the array. + The offset field is the position of the origin of the array + (ie element (0, 0 ...)). This may be outsite the bounds of the array. + + An element is accessed by + data[offset + index0*stride0 + index1*stride1 + index2*stride2] + This gives good performance as it computation does not involve the + bounds of the array. For packed arrays, this is optimized further by + substituting the known strides. + + This system has one problem: all array bounds must be withing 2^31 elements + of the origin (2^63 on 64-bit machines). For example + integer, dimension (80000:90000, 80000:90000, 2) :: array + may not work properly on 32-bit machines because 80000*80000 > 2^31, so + the calculation for stride02 would overflow. This may still work, but + I haven't checked, and it relies on the overflow doing the right thing. + + The way to fix this problem is to access alements as follows: + data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1] + Obviously this is much slower. I will make this a compile time option, + something like -fsmall-array-offsets. Mixing code compiled with and without + this switch will work. + + (1) This can be worked around by modifying the upper bound of the previous + dimension. This requires extra fields in the descriptor (both real_ubound + and fake_ubound). In tree.def there is mention of TYPE_SEP, which + may allow us to do this. However I can't find mention of this anywhere + else. + */ + + +/* Returns true if the array sym does not require a descriptor. */ + +int +gfc_is_nodesc_array (gfc_symbol * sym) +{ + assert (sym->attr.dimension); + + /* We only want local arrays. */ + if (sym->attr.pointer || sym->attr.allocatable) + return 0; + + if (sym->attr.dummy) + { + if (sym->as->type != AS_ASSUMED_SHAPE) + return 1; + else + return 0; + } + + if (sym->attr.result || sym->attr.function) + return 0; + + if (sym->attr.pointer || sym->attr.allocatable) + return 0; + + assert (sym->as->type == AS_EXPLICIT); + + return 1; +} + +static tree +gfc_build_array_type (tree type, gfc_array_spec * as) +{ + tree lbound[GFC_MAX_DIMENSIONS]; + tree ubound[GFC_MAX_DIMENSIONS]; + int n; + + for (n = 0; n < as->rank; n++) + { + /* Create expressions for the known bounds of the array. */ + if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL) + lbound[n] = integer_one_node; + else + lbound[n] = gfc_conv_array_bound (as->lower[n]); + ubound[n] = gfc_conv_array_bound (as->upper[n]); + } + + return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0); +} + +/* Returns the struct descriptor_dimension type. */ +static tree +gfc_get_desc_dim_type (void) +{ + tree type; + tree decl; + tree fieldlist; + + if (gfc_desc_dim_type) + return gfc_desc_dim_type; + + /* Build the type node. */ + type = make_node (RECORD_TYPE); + + TYPE_NAME (type) = get_identifier ("descriptor_dimension"); + TYPE_PACKED (type) = 1; + + /* Consists of the stride, lbound and ubound members. */ + decl = build_decl (FIELD_DECL, + get_identifier ("stride"), gfc_array_index_type); + DECL_CONTEXT (decl) = type; + fieldlist = decl; + + decl = build_decl (FIELD_DECL, + get_identifier ("lbound"), gfc_array_index_type); + DECL_CONTEXT (decl) = type; + fieldlist = chainon (fieldlist, decl); + + decl = build_decl (FIELD_DECL, + get_identifier ("ubound"), gfc_array_index_type); + DECL_CONTEXT (decl) = type; + fieldlist = chainon (fieldlist, decl); + + /* Finish off the type. */ + TYPE_FIELDS (type) = fieldlist; + + gfc_finish_type (type); + + gfc_desc_dim_type = type; + return type; +} + +static tree +gfc_get_dtype (tree type, int rank) +{ + tree size; + int n; + HOST_WIDE_INT i; + tree tmp; + tree dtype; + + if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)) + return (GFC_TYPE_ARRAY_DTYPE (type)); + + /* TODO: Correctly identify LOGICAL types. */ + switch (TREE_CODE (type)) + { + case INTEGER_TYPE: + n = GFC_DTYPE_INTEGER; + break; + + case BOOLEAN_TYPE: + n = GFC_DTYPE_LOGICAL; + break; + + case REAL_TYPE: + n = GFC_DTYPE_REAL; + break; + + case COMPLEX_TYPE: + n = GFC_DTYPE_COMPLEX; + break; + + /* Arrays have already been dealt with. */ + case RECORD_TYPE: + n = GFC_DTYPE_DERIVED; + break; + + case ARRAY_TYPE: + n = GFC_DTYPE_CHARACTER; + break; + + default: + abort (); + } + + assert (rank <= GFC_DTYPE_RANK_MASK); + size = TYPE_SIZE_UNIT (type); + + i = rank | (n << GFC_DTYPE_TYPE_SHIFT); + if (size && INTEGER_CST_P (size)) + { + if (tree_int_cst_lt (gfc_max_array_element_size, size)) + internal_error ("Array element size too big"); + + i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT; + } + dtype = build_int_2 (i, 0); + TREE_TYPE (dtype) = gfc_array_index_type; + + if (size && !INTEGER_CST_P (size)) + { + tmp = build_int_2 (GFC_DTYPE_SIZE_SHIFT, 0); + TREE_TYPE (tmp) = gfc_array_index_type; + tmp = fold (build (LSHIFT_EXPR, gfc_array_index_type, size, tmp)); + dtype = fold (build (PLUS_EXPR, gfc_array_index_type, tmp, dtype)); + } + /* If we don't know the size we leave it as zero. This should never happen + for anything that is actually used. */ + /* TODO: Check this is actually true, particularly when repacking + assumed size parameters. */ + + return dtype; +} + + +/* Build an array type for use without a descriptor. Valid values of packed + are 0=no, 1=partial, 2=full, 3=static. */ + +tree +gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed) +{ + tree range; + tree type; + tree tmp; + int n; + int known_stride; + int known_offset; + mpz_t offset; + mpz_t stride; + mpz_t delta; + gfc_expr *expr; + + mpz_init_set_ui (offset, 0); + mpz_init_set_ui (stride, 1); + mpz_init (delta); + + /* We don't use build_array_type because this does not include include + lang-specific information (ie. the bounds of the array) when checking + for duplicates. */ + type = make_node (ARRAY_TYPE); + + GFC_ARRAY_TYPE_P (type) = 1; + TYPE_LANG_SPECIFIC (type) = (struct lang_type *) + ggc_alloc_cleared (sizeof (struct lang_type)); + + known_stride = (packed != 0); + known_offset = 1; + for (n = 0; n < as->rank; n++) + { + /* Fill in the stride and bound components of the type. */ + if (known_stride) + tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind); + else + tmp = NULL_TREE; + GFC_TYPE_ARRAY_STRIDE (type, n) = tmp; + + expr = as->lower[n]; + if (expr->expr_type == EXPR_CONSTANT) + { + tmp = gfc_conv_mpz_to_tree (expr->value.integer, + gfc_index_integer_kind); + } + else + { + known_stride = 0; + tmp = NULL_TREE; + } + GFC_TYPE_ARRAY_LBOUND (type, n) = tmp; + + if (known_stride) + { + /* Calculate the offset. */ + mpz_mul (delta, stride, as->lower[n]->value.integer); + mpz_sub (offset, offset, delta); + } + else + known_offset = 0; + + expr = as->upper[n]; + if (expr && expr->expr_type == EXPR_CONSTANT) + { + tmp = gfc_conv_mpz_to_tree (expr->value.integer, + gfc_index_integer_kind); + } + else + { + tmp = NULL_TREE; + known_stride = 0; + } + GFC_TYPE_ARRAY_UBOUND (type, n) = tmp; + + if (known_stride) + { + /* Calculate the stride. */ + mpz_sub (delta, as->upper[n]->value.integer, + as->lower[n]->value.integer); + mpz_add_ui (delta, delta, 1); + mpz_mul (stride, stride, delta); + } + + /* Only the first stride is known for partial packed arrays. */ + if (packed < 2) + known_stride = 0; + } + + if (known_offset) + { + GFC_TYPE_ARRAY_OFFSET (type) = + gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind); + } + else + GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE; + + if (known_stride) + { + GFC_TYPE_ARRAY_SIZE (type) = + gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind); + } + else + GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE; + + GFC_TYPE_ARRAY_DTYPE (type) = gfc_get_dtype (etype, as->rank); + GFC_TYPE_ARRAY_RANK (type) = as->rank; + range = build_range_type (gfc_array_index_type, integer_zero_node, + NULL_TREE); + /* TODO: use main type if it is unbounded. */ + GFC_TYPE_ARRAY_DATAPTR_TYPE (type) = + build_pointer_type (build_array_type (etype, range)); + + if (known_stride) + { + mpz_sub_ui (stride, stride, 1); + range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind); + } + else + range = NULL_TREE; + + range = build_range_type (gfc_array_index_type, integer_zero_node, range); + TYPE_DOMAIN (type) = range; + + build_pointer_type (etype); + TREE_TYPE (type) = etype; + + layout_type (type); + + mpz_clear (offset); + mpz_clear (stride); + mpz_clear (delta); + + if (packed < 3 || !known_stride) + { + type = build_pointer_type (type); + GFC_ARRAY_TYPE_P (type) = 1; + TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type)); + } + return type; +} + + +/* Build an array (descriptor) type with given bounds. */ + +tree +gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound, + tree * ubound, int packed) +{ + tree fat_type, fat_pointer_type; + tree fieldlist; + tree arraytype; + tree decl; + int n; + char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN]; + const char *typename; + tree lower; + tree upper; + tree stride; + tree tmp; + + /* Build the type node. */ + fat_type = make_node (RECORD_TYPE); + GFC_DESCRIPTOR_TYPE_P (fat_type) = 1; + TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *) + ggc_alloc_cleared (sizeof (struct lang_type)); + GFC_TYPE_ARRAY_RANK (fat_type) = dimen; + GFC_TYPE_ARRAY_DTYPE (fat_type) = gfc_get_dtype (etype, dimen); + + tmp = TYPE_NAME (etype); + if (tmp && TREE_CODE (tmp) == TYPE_DECL) + tmp = DECL_NAME (tmp); + if (tmp) + typename = IDENTIFIER_POINTER (tmp); + else + typename = "unknown"; + + sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen, + GFC_MAX_SYMBOL_LEN, typename); + TYPE_NAME (fat_type) = get_identifier (name); + TYPE_PACKED (fat_type) = 0; + + fat_pointer_type = build_pointer_type (fat_type); + + /* Build an array descriptor record type. */ + if (packed != 0) + stride = integer_one_node; + else + stride = NULL_TREE; + + for (n = 0; n < dimen; n++) + { + GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride; + + if (lbound) + lower = lbound[n]; + else + lower = NULL_TREE; + + if (lower != NULL_TREE) + { + if (INTEGER_CST_P (lower)) + GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower; + else + lower = NULL_TREE; + } + + upper = ubound[n]; + if (upper != NULL_TREE) + { + if (INTEGER_CST_P (upper)) + GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper; + else + upper = NULL_TREE; + } + + if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE) + { + tmp = fold (build (MINUS_EXPR, gfc_array_index_type, upper, lower)); + tmp = fold (build (PLUS_EXPR, gfc_array_index_type, tmp, + integer_one_node)); + stride = + fold (build (MULT_EXPR, gfc_array_index_type, tmp, stride)); + /* Check the folding worked. */ + assert (INTEGER_CST_P (stride)); + } + else + stride = NULL_TREE; + } + GFC_TYPE_ARRAY_SIZE (fat_type) = stride; + /* TODO: known offsets for descriptors. */ + GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE; + + /* We define data as an unknown size array. Much better than doing + pointer arithmetic. */ + arraytype = + build_array_type (etype, + build_range_type (gfc_array_index_type, + integer_zero_node, NULL_TREE)); + arraytype = build_pointer_type (arraytype); + GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype; + + /* The pointer to the array data. */ + decl = build_decl (FIELD_DECL, get_identifier ("data"), arraytype); + + DECL_CONTEXT (decl) = fat_type; + /* Add the data member as the first element of the descriptor. */ + fieldlist = decl; + + /* Add the base component. */ + decl = build_decl (FIELD_DECL, get_identifier ("offset"), + gfc_array_index_type); + DECL_CONTEXT (decl) = fat_type; + fieldlist = chainon (fieldlist, decl); + + /* Add the dtype component. */ + decl = build_decl (FIELD_DECL, get_identifier ("dtype"), + gfc_array_index_type); + DECL_CONTEXT (decl) = fat_type; + fieldlist = chainon (fieldlist, decl); + + /* Build the array type for the stride and bound components. */ + arraytype = + build_array_type (gfc_get_desc_dim_type (), + build_range_type (gfc_array_index_type, + integer_zero_node, + gfc_rank_cst[dimen - 1])); + + decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype); + DECL_CONTEXT (decl) = fat_type; + DECL_INITIAL (decl) = NULL_TREE; + fieldlist = chainon (fieldlist, decl); + + /* Finish off the type. */ + TYPE_FIELDS (fat_type) = fieldlist; + + gfc_finish_type (fat_type); + + return fat_type; +} + +/* Build a pointer type. This function is called from gfc_sym_type(). */ +static tree +gfc_build_pointer_type (gfc_symbol * sym, tree type) +{ + /* Array pointer types aren't actualy pointers. */ + if (sym->attr.dimension) + return type; + else + return build_pointer_type (type); +} + +/* Return the type for a symbol. Special handling is required for character + types to get the correct level of indirection. + For functions return the return type. + For subroutines return void_type_node. + */ +tree +gfc_sym_type (gfc_symbol * sym) +{ + tree type; + int byref; + + if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function) + return void_type_node; + + if (sym->backend_decl) + { + if (sym->attr.function) + return TREE_TYPE (TREE_TYPE (sym->backend_decl)); + else + return TREE_TYPE (sym->backend_decl); + } + + /* The frontend doesn't set all the attributes for a function with an + explicit result value, so we use that instead when present. */ + if (sym->attr.function && sym->result) + sym = sym->result; + + type = gfc_typenode_for_spec (&sym->ts); + + if (sym->attr.dummy && !sym->attr.function) + byref = 1; + else + byref = 0; + + if (sym->attr.dimension) + { + if (gfc_is_nodesc_array (sym)) + { + /* If this is a character argument of unknown length, just use the + base type. */ + if (sym->ts.type != BT_CHARACTER + || !(sym->attr.dummy || sym->attr.function || sym->attr.result) + || sym->ts.cl->backend_decl) + { + type = gfc_get_nodesc_array_type (type, sym->as, + byref ? 2 : 3); + byref = 0; + } + } + else + type = gfc_build_array_type (type, sym->as); + } + else + { + if (sym->attr.allocatable || sym->attr.pointer) + type = gfc_build_pointer_type (sym, type); + } + + /* We currently pass all parameters by reference. + See f95_get_function_decl. For dummy function parameters return the + function type. */ + if (byref) + type = build_reference_type (type); + + return (type); +} + +/* Layout and output debug info for a record type. */ +void +gfc_finish_type (tree type) +{ + tree decl; + + decl = build_decl (TYPE_DECL, NULL_TREE, type); + TYPE_STUB_DECL (type) = decl; + layout_type (type); + rest_of_type_compilation (type, 1); + rest_of_decl_compilation (decl, NULL, 1, 0); +} + +/* Add a field of given NAME and TYPE to the context of a UNION_TYPE + or RECORD_TYPE pointed to by STYPE. The new field is chained + to the fieldlist pointed to by FIELDLIST. + + Returns a pointer to the new field. */ +tree +gfc_add_field_to_struct (tree *fieldlist, tree context, + tree name, tree type) +{ + tree decl; + + decl = build_decl (FIELD_DECL, name, type); + + DECL_CONTEXT (decl) = context; + DECL_INITIAL (decl) = 0; + DECL_ALIGN (decl) = 0; + DECL_USER_ALIGN (decl) = 0; + TREE_CHAIN (decl) = NULL_TREE; + *fieldlist = chainon (*fieldlist, decl); + + return decl; +} + + +/* Build a tree node for a derived type. */ +static tree +gfc_get_derived_type (gfc_symbol * derived) +{ + tree typenode, field, field_type, fieldlist; + gfc_component *c; + + assert (derived && derived->attr.flavor == FL_DERIVED); + + /* derived->backend_decl != 0 means we saw it before, but its + component's backend_decl may have not been built. */ + if (derived->backend_decl) + { + /* Its component's backend_decl has been built. */ + if (TYPE_FIELDS (derived->backend_decl)) + return derived->backend_decl; + else + typenode = derived->backend_decl; + } + else + { + /* We see this derived type first time, so build the type node. */ + typenode = make_node (RECORD_TYPE); + TYPE_NAME (typenode) = get_identifier (derived->name); + TYPE_PACKED (typenode) = gfc_option.flag_pack_derived; + derived->backend_decl = typenode; + } + + /* Build the type member list. Install the newly created RECORD_TYPE + node as DECL_CONTEXT of each FIELD_DECL. */ + fieldlist = NULL_TREE; + for (c = derived->components; c; c = c->next) + { + if (c->ts.type == BT_DERIVED && c->pointer) + { + if (c->ts.derived->backend_decl) + field_type = c->ts.derived->backend_decl; + else + { + /* Build the type node. */ + field_type = make_node (RECORD_TYPE); + TYPE_NAME (field_type) = get_identifier (c->ts.derived->name); + TYPE_PACKED (field_type) = gfc_option.flag_pack_derived; + c->ts.derived->backend_decl = field_type; + } + } + else + { + if (c->ts.type == BT_CHARACTER) + { + /* Evaluate the string length. */ + gfc_conv_const_charlen (c->ts.cl); + assert (c->ts.cl->backend_decl); + } + + field_type = gfc_typenode_for_spec (&c->ts); + } + + /* This returns an array descriptor type. Initialisation may be + required. */ + if (c->dimension) + { + if (c->pointer) + { + /* Pointers to arrays aren't actualy pointer types. The + descriptors are seperate, but the data is common. */ + field_type = gfc_build_array_type (field_type, c->as); + } + else + field_type = gfc_get_nodesc_array_type (field_type, c->as, 3); + } + else if (c->pointer) + field_type = build_pointer_type (field_type); + + field = gfc_add_field_to_struct (&fieldlist, typenode, + get_identifier (c->name), + field_type); + + DECL_PACKED (field) |= TYPE_PACKED (typenode); + + assert (!c->backend_decl); + c->backend_decl = field; + } + + /* Now we have the final fieldlist. Record it, then lay out the + derived type, including the fields. */ + TYPE_FIELDS (typenode) = fieldlist; + + gfc_finish_type (typenode); + + derived->backend_decl = typenode; + + return typenode; +} + +int +gfc_return_by_reference (gfc_symbol * sym) +{ + if (!sym->attr.function) + return 0; + + assert (sym->attr.function); + + if (sym->result) + sym = sym->result; + + if (sym->attr.dimension) + return 1; + + if (sym->ts.type == BT_CHARACTER) + return 1; + + if (sym->ts.type == BT_DERIVED) + gfc_todo_error ("Returning derived types"); + /* Possibly return derived types by reference. */ + return 0; +} + +tree +gfc_get_function_type (gfc_symbol * sym) +{ + tree type; + tree typelist; + gfc_formal_arglist *f; + gfc_symbol *arg; + int nstr; + int alternate_return; + + /* Make sure this symbol is a function or a subroutine. */ + assert (sym->attr.flavor == FL_PROCEDURE); + + if (sym->backend_decl) + return TREE_TYPE (sym->backend_decl); + + nstr = 0; + alternate_return = 0; + typelist = NULL_TREE; + /* Some functions we use an extra parameter for the return value. */ + if (gfc_return_by_reference (sym)) + { + if (sym->result) + arg = sym->result; + else + arg = sym; + + if (arg->ts.type == BT_CHARACTER) + gfc_conv_const_charlen (arg->ts.cl); + + type = gfc_sym_type (arg); + if (arg->ts.type == BT_DERIVED + || arg->attr.dimension + || arg->ts.type == BT_CHARACTER) + type = build_reference_type (type); + + typelist = gfc_chainon_list (typelist, type); + if (arg->ts.type == BT_CHARACTER) + typelist = gfc_chainon_list (typelist, gfc_strlen_type_node); + } + + /* Build the argument types for the function */ + for (f = sym->formal; f; f = f->next) + { + arg = f->sym; + if (arg) + { + /* Evaluate constant character lengths here so that they can be + included in the type. */ + if (arg->ts.type == BT_CHARACTER) + gfc_conv_const_charlen (arg->ts.cl); + + if (arg->attr.flavor == FL_PROCEDURE) + { + type = gfc_get_function_type (arg); + type = build_pointer_type (type); + } + else + type = gfc_sym_type (arg); + + /* Parameter Passing Convention + + We currently pass all parameters by reference. + Parameters with INTENT(IN) could be passed by value. + The problem arises if a function is called via an implicit + prototype. In this situation the INTENT is not known. + For this reason all parameters to global functions must be + passed by reference. Passing by value would potentialy + generate bad code. Worse there would be no way of telling that + this code wad bad, except that it would give incorrect results. + + Contained procedures could pass by value as these are never + used without an explicit interface, and connot be passed as + actual parameters for a dummy procedure. + */ + if (arg->ts.type == BT_CHARACTER) + nstr++; + typelist = gfc_chainon_list (typelist, type); + } + else + { + if (sym->attr.subroutine) + alternate_return = 1; + } + } + + /* Add hidden string length parameters. */ + while (nstr--) + typelist = gfc_chainon_list (typelist, gfc_strlen_type_node); + + typelist = gfc_chainon_list (typelist, void_type_node); + + if (alternate_return) + type = integer_type_node; + else if (!sym->attr.function || gfc_return_by_reference (sym)) + type = void_type_node; + else + type = gfc_sym_type (sym); + + type = build_function_type (type, typelist); + + return type; +} + +/* Routines for getting integer type nodes */ + + +/* Return an integer type with BITS bits of precision, + that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */ + +tree +gfc_type_for_size (unsigned bits, int unsignedp) +{ + if (bits == TYPE_PRECISION (integer_type_node)) + return unsignedp ? unsigned_type_node : integer_type_node; + + if (bits == TYPE_PRECISION (signed_char_type_node)) + return unsignedp ? unsigned_char_type_node : signed_char_type_node; + + if (bits == TYPE_PRECISION (short_integer_type_node)) + return unsignedp ? short_unsigned_type_node : short_integer_type_node; + + if (bits == TYPE_PRECISION (long_integer_type_node)) + return unsignedp ? long_unsigned_type_node : long_integer_type_node; + + if (bits == TYPE_PRECISION (long_long_integer_type_node)) + return (unsignedp ? long_long_unsigned_type_node + : long_long_integer_type_node); +/*TODO: We currently don't initialise this... + if (bits == TYPE_PRECISION (widest_integer_literal_type_node)) + return (unsignedp ? widest_unsigned_literal_type_node + : widest_integer_literal_type_node);*/ + + if (bits <= TYPE_PRECISION (intQI_type_node)) + return unsignedp ? unsigned_intQI_type_node : intQI_type_node; + + if (bits <= TYPE_PRECISION (intHI_type_node)) + return unsignedp ? unsigned_intHI_type_node : intHI_type_node; + + if (bits <= TYPE_PRECISION (intSI_type_node)) + return unsignedp ? unsigned_intSI_type_node : intSI_type_node; + + if (bits <= TYPE_PRECISION (intDI_type_node)) + return unsignedp ? unsigned_intDI_type_node : intDI_type_node; + + return 0; +} + +/* Return a data type that has machine mode MODE. + If the mode is an integer, + then UNSIGNEDP selects between signed and unsigned types. */ + +tree +gfc_type_for_mode (enum machine_mode mode, int unsignedp) +{ + if (mode == TYPE_MODE (integer_type_node)) + return unsignedp ? unsigned_type_node : integer_type_node; + + if (mode == TYPE_MODE (signed_char_type_node)) + return unsignedp ? unsigned_char_type_node : signed_char_type_node; + + if (mode == TYPE_MODE (short_integer_type_node)) + return unsignedp ? short_unsigned_type_node : short_integer_type_node; + + if (mode == TYPE_MODE (long_integer_type_node)) + return unsignedp ? long_unsigned_type_node : long_integer_type_node; + + if (mode == TYPE_MODE (long_long_integer_type_node)) + return unsignedp ? long_long_unsigned_type_node : + long_long_integer_type_node; + +/*TODO: see above + if (mode == TYPE_MODE (widest_integer_literal_type_node)) + return unsignedp ? widest_unsigned_literal_type_node + : widest_integer_literal_type_node; +*/ + + if (mode == QImode) + return unsignedp ? unsigned_intQI_type_node : intQI_type_node; + + if (mode == HImode) + return unsignedp ? unsigned_intHI_type_node : intHI_type_node; + + if (mode == SImode) + return unsignedp ? unsigned_intSI_type_node : intSI_type_node; + + if (mode == DImode) + return unsignedp ? unsigned_intDI_type_node : intDI_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; + + if (mode == TYPE_MODE (double_type_node)) + return double_type_node; + + if (mode == TYPE_MODE (long_double_type_node)) + return long_double_type_node; + + if (mode == TYPE_MODE (build_pointer_type (char_type_node))) + return build_pointer_type (char_type_node); + + if (mode == TYPE_MODE (build_pointer_type (integer_type_node))) + return build_pointer_type (integer_type_node); + +#ifdef VECTOR_MODE_SUPPORTED_P + if (VECTOR_MODE_SUPPORTED_P (mode)) + { + switch (mode) + { + case V16QImode: + return unsignedp ? unsigned_V16QI_type_node : V16QI_type_node; + case V8HImode: + return unsignedp ? unsigned_V8HI_type_node : V8HI_type_node; + case V4SImode: + return unsignedp ? unsigned_V4SI_type_node : V4SI_type_node; + case V2DImode: + return unsignedp ? unsigned_V2DI_type_node : V2DI_type_node; + case V2SImode: + return unsignedp ? unsigned_V2SI_type_node : V2SI_type_node; + case V4HImode: + return unsignedp ? unsigned_V4HI_type_node : V4HI_type_node; + case V8QImode: + return unsignedp ? unsigned_V8QI_type_node : V8QI_type_node; + case V16SFmode: + return V16SF_type_node; + case V4SFmode: + return V4SF_type_node; + case V2SFmode: + return V2SF_type_node; + case V2DFmode: + return V2DF_type_node; + default: + break; + } + } +#endif + + return 0; +} + +/* Return an unsigned type the same as TYPE in other respects. */ +tree +gfc_unsigned_type (tree type) +{ + tree type1 = TYPE_MAIN_VARIANT (type); + if (type1 == signed_char_type_node || type1 == char_type_node) + return unsigned_char_type_node; + if (type1 == integer_type_node) + return unsigned_type_node; + if (type1 == short_integer_type_node) + return short_unsigned_type_node; + if (type1 == long_integer_type_node) + return long_unsigned_type_node; + if (type1 == long_long_integer_type_node) + return long_long_unsigned_type_node; +/*TODO :see others + if (type1 == widest_integer_literal_type_node) + return widest_unsigned_literal_type_node; +*/ +#if HOST_BITS_PER_WIDE_INT >= 64 + if (type1 == intTI_type_node) + return unsigned_intTI_type_node; +#endif + if (type1 == intDI_type_node) + return unsigned_intDI_type_node; + if (type1 == intSI_type_node) + return unsigned_intSI_type_node; + if (type1 == intHI_type_node) + return unsigned_intHI_type_node; + if (type1 == intQI_type_node) + return unsigned_intQI_type_node; + + return gfc_signed_or_unsigned_type (1, type); +} + +/* Return a signed type the same as TYPE in other respects. */ + +tree +gfc_signed_type (tree type) +{ + tree type1 = TYPE_MAIN_VARIANT (type); + if (type1 == unsigned_char_type_node || type1 == char_type_node) + return signed_char_type_node; + if (type1 == unsigned_type_node) + return integer_type_node; + if (type1 == short_unsigned_type_node) + return short_integer_type_node; + if (type1 == long_unsigned_type_node) + return long_integer_type_node; + if (type1 == long_long_unsigned_type_node) + return long_long_integer_type_node; +/*TODO: see others + if (type1 == widest_unsigned_literal_type_node) + return widest_integer_literal_type_node; +*/ +#if HOST_BITS_PER_WIDE_INT >= 64 + if (type1 == unsigned_intTI_type_node) + return intTI_type_node; +#endif + if (type1 == unsigned_intDI_type_node) + return intDI_type_node; + if (type1 == unsigned_intSI_type_node) + return intSI_type_node; + if (type1 == unsigned_intHI_type_node) + return intHI_type_node; + if (type1 == unsigned_intQI_type_node) + return intQI_type_node; + + return gfc_signed_or_unsigned_type (0, type); +} + +/* Return a type the same as TYPE except unsigned or + signed according to UNSIGNEDP. */ + +tree +gfc_signed_or_unsigned_type (int unsignedp, tree type) +{ + if (!INTEGRAL_TYPE_P (type) || TYPE_UNSIGNED (type) == unsignedp) + return type; + + if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node)) + return unsignedp ? unsigned_char_type_node : signed_char_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node)) + return unsignedp ? unsigned_type_node : integer_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node)) + return unsignedp ? short_unsigned_type_node : short_integer_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node)) + return unsignedp ? long_unsigned_type_node : long_integer_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node)) + return (unsignedp ? long_long_unsigned_type_node + : long_long_integer_type_node); +/*TODO: see others + if (TYPE_PRECISION (type) == TYPE_PRECISION (widest_integer_literal_type_node)) + return (unsignedp ? widest_unsigned_literal_type_node + : widest_integer_literal_type_node); +*/ +#if HOST_BITS_PER_WIDE_INT >= 64 + if (TYPE_PRECISION (type) == TYPE_PRECISION (intTI_type_node)) + return unsignedp ? unsigned_intTI_type_node : intTI_type_node; +#endif + if (TYPE_PRECISION (type) == TYPE_PRECISION (intDI_type_node)) + return unsignedp ? unsigned_intDI_type_node : intDI_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (intSI_type_node)) + return unsignedp ? unsigned_intSI_type_node : intSI_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (intHI_type_node)) + return unsignedp ? unsigned_intHI_type_node : intHI_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (intQI_type_node)) + return unsignedp ? unsigned_intQI_type_node : intQI_type_node; + + return type; +} + +#include "gt-fortran-trans-types.h" diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h new file mode 100644 index 00000000000..b401499deb8 --- /dev/null +++ b/gcc/fortran/trans-types.h @@ -0,0 +1,143 @@ +/* Header for Fortran 95 types backend support. + Copyright (C) 2002, 2003 Free Software Foundation, Inc. + Contributed by Paul Brook <paul@nowt.org> + and Steven Bosscher <s.bosscher@student.tudelft.nl> + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#ifndef GFC_BACKEND_H +#define GFC_BACKEND_H + +enum +{ + F95_INT1_TYPE, + F95_INT2_TYPE, + F95_INT4_TYPE, + F95_INT8_TYPE, + F95_INT16_TYPE, + F95_REAL4_TYPE, + F95_REAL8_TYPE, + F95_REAl16_TYPE, + F95_COMPLEX4_TYPE, + F95_COMPLEX8_TYPE, + F95_COMPLEX16_TYPE, + F95_LOGICAL1_TYPE, + F95_LOGICAL2_TYPE, + F95_LOGICAL4_TYPE, + F95_LOGICAL8_TYPE, + F95_LOGICAL16_TYPE, + F95_CHARACTER1_TYPE, + NUM_F95_TYPES +}; + +#define GFC_DTYPE_RANK_MASK 0x07 +#define GFC_DTYPE_TYPE_SHIFT 3 +#define GFC_DTYPE_TYPE_MASK 0x38 +#define GFC_DTYPE_SIZE_SHIFT 6 + +enum +{ + GFC_DTYPE_UNKNOWN = 0, + GFC_DTYPE_INTEGER, + GFC_DTYPE_LOGICAL, + GFC_DTYPE_REAL, + GFC_DTYPE_COMPLEX, + GFC_DTYPE_DERIVED, + GFC_DTYPE_CHARACTER +}; + +extern GTY(()) tree gfc_type_nodes[NUM_F95_TYPES]; + +extern GTY(()) tree gfc_array_index_type; +extern GTY(()) tree ppvoid_type_node; +extern GTY(()) tree pvoid_type_node; +extern GTY(()) tree pchar_type_node; + +#define gfc_int1_type_node gfc_type_nodes[F95_INT1_TYPE] +#define gfc_int2_type_node gfc_type_nodes[F95_INT2_TYPE] +#define gfc_int4_type_node gfc_type_nodes[F95_INT4_TYPE] +#define gfc_int8_type_node gfc_type_nodes[F95_INT8_TYPE] +#define gfc_int16_type_node gfc_type_nodes[F95_INT16_TYPE] + +#define gfc_real4_type_node gfc_type_nodes[F95_REAL4_TYPE] +#define gfc_real8_type_node gfc_type_nodes[F95_REAL8_TYPE] +#define gfc_real16_type_node gfc_type_nodes[F95_REAL16_TYPE] + +#define gfc_complex4_type_node gfc_type_nodes[F95_COMPLEX4_TYPE] +#define gfc_complex8_type_node gfc_type_nodes[F95_COMPLEX8_TYPE] +#define gfc_complex16_type_node gfc_type_nodes[F95_COMPLEX16_TYPE] + +#define gfc_logical1_type_node gfc_type_nodes[F95_LOGICAL1_TYPE] +#define gfc_logical2_type_node gfc_type_nodes[F95_LOGICAL2_TYPE] +#define gfc_logical4_type_node gfc_type_nodes[F95_LOGICAL4_TYPE] +#define gfc_logical8_type_node gfc_type_nodes[F95_LOGICAL8_TYPE] +#define gfc_logical16_type_node gfc_type_nodes[F95_LOGICAL16_TYPE] + +#define gfc_character1_type_node gfc_type_nodes[F95_CHARACTER1_TYPE] + +#define gfc_strlen_kind 4 +#define gfc_strlen_type_node gfc_int4_type_node + +/* These C-specific types are used while building builtin function decls. + For now it doesn't really matter what these are defined to as we don't + need any of the builtins that use them. */ +#define intmax_type_node gfc_int8_type_node +#define string_type_node pchar_type_node +#define const_string_type_node pchar_type_node + +/* be-function.c */ +void gfc_convert_function_code (gfc_namespace *); + +/* trans-types.c */ +void gfc_init_types (void); + +tree gfc_get_int_type (int); +tree gfc_get_real_type (int); +tree gfc_get_complex_type (int); +tree gfc_get_logical_type (int); +tree gfc_get_character_type (int, gfc_charlen *); + +tree gfc_sym_type (gfc_symbol *); +tree gfc_typenode_for_spec (gfc_typespec *); + +tree gfc_get_function_type (gfc_symbol *); + +tree gfc_type_for_size (unsigned, int); +tree gfc_type_for_mode (enum machine_mode, int); +tree gfc_unsigned_type (tree); +tree gfc_signed_type (tree); +tree gfc_signed_or_unsigned_type (int, tree); + +tree gfc_get_element_type (tree); +tree gfc_get_array_type_bounds (tree, int, tree *, tree *, int); +tree gfc_get_nodesc_array_type (tree, gfc_array_spec *, int); + +/* Add a field of given name and type to a UNION_TYPE or RECORD_TYPE. */ +tree gfc_add_field_to_struct (tree *, tree, tree, tree); + +/* Layout and output debugging info for a type. */ +void gfc_finish_type (tree); + +/* Some functions have an extra parameter for the return value. */ +int gfc_return_by_reference (gfc_symbol *); + +/* Returns true if the array sym does not require a descriptor. */ +int gfc_is_nodesc_array (gfc_symbol *); + +#endif diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c new file mode 100644 index 00000000000..aed764d0a36 --- /dev/null +++ b/gcc/fortran/trans.c @@ -0,0 +1,662 @@ +/* Code translation -- generate GCC trees from gfc_code. + Copyright (C) 2002, 2003 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tree.h" +#include "tree-simple.h" +#include <stdio.h> +#include "ggc.h" +#include "toplev.h" +#include "defaults.h" +#include "real.h" +#include <gmp.h> +#include <assert.h> +#include "gfortran.h" +#include "trans.h" +#include "trans-stmt.h" +#include "trans-array.h" +#include "trans-types.h" +#include "trans-const.h" + +/* Naming convention for backend interface code: + + gfc_trans_* translate gfc_code into STMT trees. + + gfc_conv_* expression conversion + + gfc_get_* get a backend tree representation of a decl or type */ + +static gfc_file *gfc_current_backend_file; + + +/* Advance along TREE_CHAIN n times. */ + +tree +gfc_advance_chain (tree t, int n) +{ + for (; n > 0; n--) + { + assert (t != NULL_TREE); + t = TREE_CHAIN (t); + } + return t; +} + + +/* Wrap a node in a TREE_LIST node and add it to the end of a list. */ + +tree +gfc_chainon_list (tree list, tree add) +{ + tree l; + + l = tree_cons (NULL_TREE, add, NULL_TREE); + + return chainon (list, l); +} + + +/* Strip off a legitimate source ending from the input + string NAME of length LEN. */ + +static inline void +remove_suffix (char *name, int len) +{ + int i; + + for (i = 2; i < 8 && len > i; i++) + { + if (name[len - i] == '.') + { + name[len - i] = '\0'; + break; + } + } +} + + +/* Creates a variable declaration with a given TYPE. */ + +tree +gfc_create_var_np (tree type, const char *prefix) +{ + return create_tmp_var_raw (type, prefix); +} + + +/* Like above, but also adds it to the current scope. */ + +tree +gfc_create_var (tree type, const char *prefix) +{ + tree tmp; + + tmp = gfc_create_var_np (type, prefix); + + pushdecl (tmp); + + return tmp; +} + + +/* If the an expression is not constant, evaluate it now. We assign the + result of the expression to an artificially created variable VAR, and + return a pointer to the VAR_DECL node for this variable. */ + +tree +gfc_evaluate_now (tree expr, stmtblock_t * pblock) +{ + tree var; + + if (TREE_CODE_CLASS (TREE_CODE (expr)) == 'c') + return expr; + + var = gfc_create_var (TREE_TYPE (expr), NULL); + gfc_add_modify_expr (pblock, var, expr); + + return var; +} + + +/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK. + A MODIFY_EXPR is an assignment: LHS <- RHS. */ + +void +gfc_add_modify_expr (stmtblock_t * pblock, tree lhs, tree rhs) +{ + tree tmp; + + tmp = fold (build_v (MODIFY_EXPR, lhs, rhs)); + gfc_add_expr_to_block (pblock, tmp); +} + + +/* Create a new scope/binding level and initialize a block. Care must be + taken when translating expessions as any temporaries will be placed in + the innermost scope. */ + +void +gfc_start_block (stmtblock_t * block) +{ + /* Start a new binding level. */ + pushlevel (0); + block->has_scope = 1; + + /* The block is empty. */ + block->head = NULL_TREE; +} + + +/* Initialize a block without creating a new scope. */ + +void +gfc_init_block (stmtblock_t * block) +{ + block->head = NULL_TREE; + block->has_scope = 0; +} + + +/* Sometimes we create a scope but it turns out that we don't actually + need it. This function merges the scope of BLOCK with its parent. + Only variable decls will be merged, you still need to add the code. */ + +void +gfc_merge_block_scope (stmtblock_t * block) +{ + tree decl; + tree next; + + assert (block->has_scope); + block->has_scope = 0; + + /* Remember the decls in this scope. */ + decl = getdecls (); + poplevel (0, 0, 0); + + /* Add them to the parent scope. */ + while (decl != NULL_TREE) + { + next = TREE_CHAIN (decl); + TREE_CHAIN (decl) = NULL_TREE; + + pushdecl (decl); + decl = next; + } +} + + +/* Finish a scope containing a block of statements. */ + +tree +gfc_finish_block (stmtblock_t * stmtblock) +{ + tree decl; + tree expr; + tree block; + + expr = rationalize_compound_expr (stmtblock->head); + stmtblock->head = NULL_TREE; + + if (stmtblock->has_scope) + { + decl = getdecls (); + + if (decl) + { + block = poplevel (1, 0, 0); + expr = build_v (BIND_EXPR, decl, expr, block); + } + else + poplevel (0, 0, 0); + } + + return expr; +} + + +/* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the + natural type is used. */ + +tree +gfc_build_addr_expr (tree type, tree t) +{ + tree base_type = TREE_TYPE (t); + tree natural_type; + + if (type && POINTER_TYPE_P (type) + && TREE_CODE (base_type) == ARRAY_TYPE + && TYPE_MAIN_VARIANT (TREE_TYPE (type)) + == TYPE_MAIN_VARIANT (TREE_TYPE (base_type))) + natural_type = type; + else + natural_type = build_pointer_type (base_type); + + if (TREE_CODE (t) == INDIRECT_REF) + { + if (!type) + type = natural_type; + t = TREE_OPERAND (t, 0); + natural_type = TREE_TYPE (t); + } + else + { + if (DECL_P (t)) + TREE_ADDRESSABLE (t) = 1; + t = build1 (ADDR_EXPR, natural_type, t); + } + + if (type && natural_type != type) + t = convert (type, t); + + return t; +} + + +/* Build an INDIRECT_REF with its natural type. */ + +tree +gfc_build_indirect_ref (tree t) +{ + tree type = TREE_TYPE (t); + if (!POINTER_TYPE_P (type)) + abort (); + type = TREE_TYPE (type); + + if (TREE_CODE (t) == ADDR_EXPR) + return TREE_OPERAND (t, 0); + else + return build1 (INDIRECT_REF, type, t); +} + + +/* Build an ARRAY_REF with its natural type. */ + +tree +gfc_build_array_ref (tree base, tree offset) +{ + tree type = TREE_TYPE (base); + if (TREE_CODE (type) != ARRAY_TYPE) + abort (); + type = TREE_TYPE (type); + + if (DECL_P (base)) + TREE_ADDRESSABLE (base) = 1; + + return build (ARRAY_REF, type, base, offset); +} + + +/* Given a funcion declaration FNDECL and an argument list ARGLIST, + build a CALL_EXPR. */ + +tree +gfc_build_function_call (tree fndecl, tree arglist) +{ + tree fn; + tree call; + + fn = gfc_build_addr_expr (NULL, fndecl); + call = build (CALL_EXPR, TREE_TYPE (TREE_TYPE (fndecl)), fn, arglist, NULL); + TREE_SIDE_EFFECTS (call) = 1; + + return call; +} + + +/* Generate a runtime error if COND is true. */ + +void +gfc_trans_runtime_check (tree cond, tree msg, stmtblock_t * pblock) +{ + stmtblock_t block; + tree body; + tree tmp; + tree args; + + cond = fold (cond); + + if (integer_zerop (cond)) + return; + + /* The code to generate the error. */ + gfc_start_block (&block); + + assert (TREE_CODE (msg) == STRING_CST); + + TREE_USED (msg) = 1; + + tmp = gfc_build_addr_expr (pchar_type_node, msg); + args = gfc_chainon_list (NULL_TREE, tmp); + + tmp = gfc_build_addr_expr (pchar_type_node, gfc_strconst_current_filename); + args = gfc_chainon_list (args, tmp); + + tmp = build_int_2 (input_line, 0); + args = gfc_chainon_list (args, tmp); + + tmp = gfc_build_function_call (gfor_fndecl_runtime_error, args); + gfc_add_expr_to_block (&block, tmp); + + body = gfc_finish_block (&block); + + if (integer_onep (cond)) + { + gfc_add_expr_to_block (pblock, body); + } + else + { + /* Tell the compiler that this isn't likley. */ + tmp = gfc_chainon_list (NULL_TREE, cond); + tmp = gfc_chainon_list (tmp, integer_zero_node); + cond = gfc_build_function_call (built_in_decls[BUILT_IN_EXPECT], tmp); + + tmp = build_v (COND_EXPR, cond, body, build_empty_stmt ()); + gfc_add_expr_to_block (pblock, tmp); + } +} + + +/* Add a statement to a bock. */ + +void +gfc_add_expr_to_block (stmtblock_t * block, tree expr) +{ + assert (block); + + if (expr == NULL_TREE || IS_EMPTY_STMT (expr)) + return; + + expr = fold (expr); + if (block->head) + block->head = build_v (COMPOUND_EXPR, block->head, expr); + else + block->head = expr; +} + + +/* Add a block the end of a block. */ + +void +gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append) +{ + assert (append); + assert (!append->has_scope); + + gfc_add_expr_to_block (block, append->head); + append->head = NULL_TREE; +} + + +/* Get the current locus. The structure may not be complete, and should + only be used with gfc_set_current_locus. */ + +void +gfc_get_backend_locus (locus * loc) +{ + loc->line = input_line - 1; + loc->file = gfc_current_backend_file; +} + + +/* Set the current locus. */ + +void +gfc_set_backend_locus (locus * loc) +{ + input_line = loc->line + 1; + gfc_current_backend_file = loc->file; + input_filename = loc->file->filename; +} + + +/* Translate an executable statement. */ + +tree +gfc_trans_code (gfc_code * code) +{ + stmtblock_t block; + tree res; + + if (!code) + return build_empty_stmt (); + + gfc_start_block (&block); + + /* Translate statements one by one to SIMPLE trees until we reach + the end of this gfc_code branch. */ + for (; code; code = code->next) + { + gfc_set_backend_locus (&code->loc); + + if (code->here != 0) + { + res = gfc_trans_label_here (code); + gfc_add_expr_to_block (&block, res); + } + + switch (code->op) + { + case EXEC_NOP: + res = NULL_TREE; + break; + + case EXEC_ASSIGN: + res = gfc_trans_assign (code); + break; + + case EXEC_LABEL_ASSIGN: + res = gfc_trans_label_assign (code); + break; + + case EXEC_POINTER_ASSIGN: + res = gfc_trans_pointer_assign (code); + break; + + case EXEC_CONTINUE: + res = NULL_TREE; + break; + + case EXEC_CYCLE: + res = gfc_trans_cycle (code); + break; + + case EXEC_EXIT: + res = gfc_trans_exit (code); + break; + + case EXEC_GOTO: + res = gfc_trans_goto (code); + break; + + case EXEC_PAUSE: + res = gfc_trans_pause (code); + break; + + case EXEC_STOP: + res = gfc_trans_stop (code); + break; + + case EXEC_CALL: + res = gfc_trans_call (code); + break; + + case EXEC_RETURN: + res = gfc_trans_return (code); + break; + + case EXEC_IF: + res = gfc_trans_if (code); + break; + + case EXEC_ARITHMETIC_IF: + res = gfc_trans_arithmetic_if (code); + break; + + case EXEC_DO: + res = gfc_trans_do (code); + break; + + case EXEC_DO_WHILE: + res = gfc_trans_do_while (code); + break; + + case EXEC_SELECT: + res = gfc_trans_select (code); + break; + + case EXEC_FORALL: + res = gfc_trans_forall (code); + break; + + case EXEC_WHERE: + res = gfc_trans_where (code); + break; + + case EXEC_ALLOCATE: + res = gfc_trans_allocate (code); + break; + + case EXEC_DEALLOCATE: + res = gfc_trans_deallocate (code); + break; + + case EXEC_OPEN: + res = gfc_trans_open (code); + break; + + case EXEC_CLOSE: + res = gfc_trans_close (code); + break; + + case EXEC_READ: + res = gfc_trans_read (code); + break; + + case EXEC_WRITE: + res = gfc_trans_write (code); + break; + + case EXEC_IOLENGTH: + res = gfc_trans_iolength (code); + break; + + case EXEC_BACKSPACE: + res = gfc_trans_backspace (code); + break; + + case EXEC_ENDFILE: + res = gfc_trans_endfile (code); + break; + + case EXEC_INQUIRE: + res = gfc_trans_inquire (code); + break; + + case EXEC_REWIND: + res = gfc_trans_rewind (code); + break; + + case EXEC_TRANSFER: + res = gfc_trans_transfer (code); + break; + + case EXEC_DT_END: + res = gfc_trans_dt_end (code); + break; + + default: + internal_error ("gfc_trans_code(): Bad statement code"); + } + + if (res != NULL_TREE && ! IS_EMPTY_STMT (res)) + { + annotate_with_locus (res, input_location); + /* Add the new statemment to the block. */ + gfc_add_expr_to_block (&block, res); + } + } + + /* Return the finished block. */ + return gfc_finish_block (&block); +} + + +/* This function is called after a complete program unit has been parsed + and resolved. */ + +void +gfc_generate_code (gfc_namespace * ns) +{ + gfc_symbol *main_program = NULL; + symbol_attribute attr; + + /* Main program subroutine. */ + if (!ns->proc_name) + { + /* Lots of things get upset if a subroutine doesn't have a symbol, so we + make one now. Hopefully we've set all the required fields. */ + gfc_get_symbol ("MAIN__", ns, &main_program); + gfc_clear_attr (&attr); + attr.flavor = FL_PROCEDURE; + attr.proc = PROC_UNKNOWN; + attr.subroutine = 1; + attr.access = ACCESS_PUBLIC; + main_program->attr = attr; + ns->proc_name = main_program; + gfc_commit_symbols (); + } + + gfc_generate_function_code (ns); +} + + +/* This function is called after a complete module has been parsed + and resolved. */ + +void +gfc_generate_module_code (gfc_namespace * ns) +{ + gfc_namespace *n; + + gfc_generate_module_vars (ns); + + /* We need to generate all module function prototypes first, to allow + sibling calls. */ + for (n = ns->contained; n; n = n->sibling) + { + if (!n->proc_name) + continue; + + gfc_build_function_decl (n->proc_name); + } + + for (n = ns->contained; n; n = n->sibling) + { + if (!n->proc_name) + continue; + + gfc_generate_function_code (n); + } +} + diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h new file mode 100644 index 00000000000..d5b31376e81 --- /dev/null +++ b/gcc/fortran/trans.h @@ -0,0 +1,534 @@ +/* Header for code translation functions + Copyright (C) 2002, 2003 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifndef GFC_TRANS_H +#define GFC_TRANS_H + +/* Mangled symbols take the form __module__name. */ +#define GFC_MAX_MANGLED_SYMBOL_LEN (GFC_MAX_SYMBOL_LEN*2+4) + +/* Struct for holding a block of statements. It should be treated as an + opaque entity and not modified directly. This allows us to change the + underlying representation of statement lists. */ +typedef struct +{ + tree head; + int has_scope:1; +} +stmtblock_t; + +/* a simplified expresson */ +typedef struct gfc_se +{ + /* Code blocks to be executed before and after using the value. */ + stmtblock_t pre; + stmtblock_t post; + + /* the result of the expression */ + tree expr; + + /* The length of a character string value. */ + tree string_length; + + /* If set gfc_conv_variable will return an expression for the array + descriptor. When set, want_pointer should also be set. + If not set scalarizing variables will be substituted. */ + unsigned descriptor_only:1; + + /* When this is set gfc_conv_expr returns the address of a variable. Only + applies to EXPR_VARIABLE nodes. + Also used by gfc_conv_array_parameter. When set this indicates a pointer + to the descriptor should be returned, rather than the descriptor itself. + */ + unsigned want_pointer:1; + + /* An array function call returning without a temporary. Also used for array + pointer assignments. */ + unsigned direct_byref:1; + + /* Ignore absent optional arguments. Used for some intrinsics. */ + unsigned ignore_optional:1; + + /* Scalarization parameters. */ + struct gfc_se *parent; + struct gfc_ss *ss; + struct gfc_loopinfo *loop; +} +gfc_se; + + +/* Scalarisation State chain. Created by walking an expression tree before + creating the scalarization loops. Then passed as part of a gfc_se structure + to translate the expression inside the loop. Note that these chains are + terminated by gfc_se_terminator, not NULL. A NULL pointer in a gfc_se + indicates to gfc_conv_* that this is a scalar expression. + Note that some member arrays correspond to scalarizer rank and others + are the variable rank. */ + +typedef struct gfc_ss_info +{ + int dimen; + /* The ref that holds information on this section. */ + gfc_ref *ref; + /* The descriptor of this array. */ + tree descriptor; + /* holds the pointer to the data array. */ + tree data; + /* To move some of the array index calculation out of the innermost loop. */ + tree offset; + tree saved_offset; + tree stride0; + /* Holds the SS for a subscript. Indexed by actual dimension. */ + struct gfc_ss *subscript[GFC_MAX_DIMENSIONS]; + + /* stride and delta are used to access this inside a scalarization loop. + start is used in the calculation of these. Indexed by scalarizer + dimension. */ + tree start[GFC_MAX_DIMENSIONS]; + tree stride[GFC_MAX_DIMENSIONS]; + tree delta[GFC_MAX_DIMENSIONS]; + + /* Translation from scalariser dimensions to actual dimensions. + actual = dim[scalarizer] */ + int dim[GFC_MAX_DIMENSIONS]; +} +gfc_ss_info; + +typedef enum +{ + /* A scalar value. This will be evaluated before entering the + scalarization loop. */ + GFC_SS_SCALAR, + + /* Like GFC_SS_SCALAR except it evaluates a pointer the the expression. + Used for elemental function parameters. */ + GFC_SS_REFERENCE, + + /* An array section. Scalarization indices will be substituted during + expression translation. */ + GFC_SS_SECTION, + + /* A non-elemental function call returning an array. The call is executed + before entering the scalarization loop, storing the result in a + temporary. This temporary is then used inside the scalarization loop. + Simple assignments, eg. a(:) = fn() are handles without a temporary + as a special case. */ + GFC_SS_FUNCTION, + + /* An array constructor. The current implementation is sub-optimal in + many cases. It allocated a temporary, assigns the values to it, then + uses this temporary inside the scalarization loop. */ + GFC_SS_CONSTRUCTOR, + + /* A vector subscript. Only used as the SS chain for a subscript. + Similar int format to a GFC_SS_SECTION. */ + GFC_SS_VECTOR, + + /* A temporary array allocated by the scalarizer. Its rank can be less + than that of the assignment expression. */ + GFC_SS_TEMP, + + /* An intrinsic function call. Many intrinsic functions which map directly + to library calls are created as GFC_SS_FUNCTION nodes. */ + GFC_SS_INTRINSIC +} +gfc_ss_type; + +/* SS structures can only belong to a single loopinfo. They must be added + otherwise they will not get freed. */ +typedef struct gfc_ss +{ + gfc_ss_type type; + gfc_expr *expr; + union + { + /* If type is GFC_SS_SCALAR or GFC_SS_REFERENCE. */ + struct + { + tree expr; + tree string_length; + } + scalar; + + /* GFC_SS_TEMP. */ + struct + { + /* The rank of the temporary. May be less than the rank of the + assigned expression. */ + int dimen; + tree type; + tree string_length; + } + temp; + /* All other types. */ + gfc_ss_info info; + } + data; + + /* All the SS in a loop and linked through loop_chain. The SS for an + expression are linked by the next pointer. */ + struct gfc_ss *loop_chain; + struct gfc_ss *next; + + /* This is used by assignments requiring teporaries. The bits specify which + loops the terms appear in. This will be 1 for the RHS expressions, + 2 for the LHS expressions, and 3(=1|2) for the temporary. */ + unsigned useflags:2; +} +gfc_ss; +#define gfc_get_ss() gfc_getmem(sizeof(gfc_ss)) + +/* The contents of this aren't actualy used. A NULL SS chain indicates a + scalar expression, so this pointer is used to terminate SS chains. */ +extern gfc_ss * const gfc_ss_terminator; + +/* Holds information about an expression while it is being scalarized. */ +typedef struct gfc_loopinfo +{ + stmtblock_t pre; + stmtblock_t post; + + int dimen; + + /* All the SS involved with this loop. */ + gfc_ss *ss; + /* The SS describing the teporary used in an assignment. */ + gfc_ss *temp_ss; + + /* The scalarization loop index variables. */ + tree loopvar[GFC_MAX_DIMENSIONS]; + + /* The bounds of the scalarization loops. */ + tree from[GFC_MAX_DIMENSIONS]; + tree to[GFC_MAX_DIMENSIONS]; + gfc_ss *specloop[GFC_MAX_DIMENSIONS]; + + /* The code member contains the code for the body of the next outer loop. */ + stmtblock_t code[GFC_MAX_DIMENSIONS]; + + /* Order in which the dimensions should be looped, innermost first. */ + int order[GFC_MAX_DIMENSIONS]; + + /* The number of dimensions for which a temporary is used. */ + int temp_dim; + + /* If set we don't need the loop variables. */ + unsigned array_parameter:1; +} +gfc_loopinfo; + +/* Advance the SS chain to the next term. */ +void gfc_advance_se_ss_chain (gfc_se *); + +/* Call this to initialise a gfc_se structure before use + first parameter is structure to initialise, second is + parent to get scalarization data from, or NULL. */ +void gfc_init_se (gfc_se *, gfc_se *); + +/* Create an artificial variable decl and add it to the current scope. */ +tree gfc_create_var (tree, const char *); +/* Like above but doesn't add it to the current scope. */ +tree gfc_create_var_np (tree, const char *); + +/* Store the result of an expression in a temp variable so it can be used + repeatedly even if the original changes */ +void gfc_make_safe_expr (gfc_se * se); + +/* Makes sure se is suitable for passing as a function string parameter. */ +void gfc_conv_string_parameter (gfc_se * se); + +/* Add an item to the end of TREE_LIST. */ +tree gfc_chainon_list (tree, tree); + +/* When using the gfc_conv_* make sure you understand what they do, ie. + when a POST chain may be created, and what the retured expression may be + used for. Note that character strings have special handling. This + should not be a problem as most statements/operations only deal with + numeric/logical types. */ + +/* Entry point for expression translation. */ +void gfc_conv_expr (gfc_se * se, gfc_expr * expr); +/* Like gfc_conv_expr, but the POST block is guaranteed to be empty for + numeric expressions. */ +void gfc_conv_expr_val (gfc_se * se, gfc_expr * expr); +/* Like gfc_conv_expr_val, but the value is also suitable for use in the lhs of + an assignment. */ +void gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr); +/* Converts an expression so that it can be passed be reference. */ +void gfc_conv_expr_reference (gfc_se * se, gfc_expr *); +/* Equivalent to convert(type, gfc_conv_expr_val(se, expr)). */ +void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree); +/* If the value is not constant, Create a temporary and copy the value. */ +tree gfc_evaluate_now (tree, stmtblock_t *); + +/* Intrinsic function handling. */ +void gfc_conv_intrinsic_function (gfc_se *, gfc_expr *); + +/* Does an intrinsic map directly to an external library call. */ +int gfc_is_intrinsic_libcall (gfc_expr *); + +/* Also used to CALL subroutines. */ +void gfc_conv_function_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *); +/* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */ + +/* Generate code for a scalar assignment. */ +tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, bt); + +/* Translate COMMON blocks. */ +void gfc_trans_common (gfc_namespace *); + +/* Translate a derived type constructor. */ +void gfc_conv_structure (gfc_se *, gfc_expr *, int); + +/* Return an expression which determines if a dummy parameter is present. */ +tree gfc_conv_expr_present (gfc_symbol *); + +/* Generate code to allocate a string temporary. */ +tree gfc_conv_string_tmp (gfc_se *, tree, tree); +/* Initialize a string length variable. */ +void gfc_trans_init_string_length (gfc_charlen *, stmtblock_t *); + +/* Add an expression to the end of a block. */ +void gfc_add_expr_to_block (stmtblock_t *, tree); +/* Add a block to the end of a block. */ +void gfc_add_block_to_block (stmtblock_t *, stmtblock_t *); +/* Add a MODIFY_EXPR to a block. */ +void gfc_add_modify_expr (stmtblock_t *, tree, tree); + +/* Initialize a statement block. */ +void gfc_init_block (stmtblock_t *); +/* Start a new satement block. Like gfc_init_block but also starts a new + variable scope. */ +void gfc_start_block (stmtblock_t *); +/* Finish a statement block. Also closes the scope if the block was created + with gfc_start_block. */ +tree gfc_finish_block (stmtblock_t *); +/* Merge the scope of a block with its parent. */ +void gfc_merge_block_scope (stmtblock_t * block); + +/* Return the backend label decl. */ +tree gfc_get_label_decl (gfc_st_label *); + +/* Return the decl for an external function. */ +tree gfc_get_extern_function_decl (gfc_symbol *); + +/* Return the decl for a function. */ +tree gfc_get_function_decl (gfc_symbol *); + +/* Build a CALL_EXPR. */ +tree gfc_build_function_call (tree, tree); + +/* Build an ADDR_EXPR. */ +tree gfc_build_addr_expr (tree, tree); + +/* Build an INDIRECT_REF. */ +tree gfc_build_indirect_ref (tree); + +/* Build an ARRAY_REF. */ +tree gfc_build_array_ref (tree, tree); + +/* Creates an label. Decl is artificial if label_id == NULL_TREE. */ +tree gfc_build_label_decl (tree); + +/* Return the decl used to hold the function return value. + Do not use if the function has an explicit result variable. */ +tree gfc_get_fake_result_decl (gfc_symbol *); + +/* Get the return label for the current function. */ +tree gfc_get_return_label (void); + +/* Add a decl to the binding level for the current function. */ +void gfc_add_decl_to_function (tree); + +/* Make prototypes for runtime library functions. */ +void gfc_build_builtin_function_decls (void); + +/* Return the variable decl for a symbol. */ +tree gfc_get_symbol_decl (gfc_symbol *); + +/* Allocate the lang-spcific part of a decl node. */ +void gfc_allocate_lang_decl (tree); + +/* Advance along a TREE_CHAIN. */ +tree gfc_advance_chain (tree, int); + +/* Create a decl for a function. */ +void gfc_build_function_decl (gfc_symbol *); +/* Generate the code for a function. */ +void gfc_generate_function_code (gfc_namespace *); +/* Output a decl for a module variable. */ +void gfc_generate_module_vars (gfc_namespace *); + +/* Get and set the current location. */ +void gfc_set_backend_locus (locus *); +void gfc_get_backend_locus (locus *); + +/* Handle static constructor functions. */ +extern GTY(()) tree gfc_static_ctors; +void gfc_generate_constructors (void); + +/* Generate a runtime error check. */ +void gfc_trans_runtime_check (tree, tree, stmtblock_t *); + +/* Generate code for an assigment, includes scalarization. */ +tree gfc_trans_assignment (gfc_expr *, gfc_expr *); + +/* Generate code for an pointer assignment. */ +tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *); + +/* Initialize function decls for library functions. */ +void gfc_build_intrinsic_lib_fndecls (void); +/* Create function decls for IO library functions. */ +void gfc_build_io_library_fndecls (void); +/* Build a function decl for a library function. */ +tree gfc_build_library_function_decl (tree, tree, int, ...); + +/* somewhere! */ +tree pushdecl (tree); +tree pushdecl_top_level (tree); +void pushlevel (int); +tree poplevel (int, int, int); +tree getdecls (void); +tree gfc_truthvalue_conversion (tree); + +/* Runtime library function decls. */ +extern GTY(()) tree gfor_fndecl_internal_malloc; +extern GTY(()) tree gfor_fndecl_internal_malloc64; +extern GTY(()) tree gfor_fndecl_internal_free; +extern GTY(()) tree gfor_fndecl_allocate; +extern GTY(()) tree gfor_fndecl_allocate64; +extern GTY(()) tree gfor_fndecl_deallocate; +extern GTY(()) tree gfor_fndecl_pause_numeric; +extern GTY(()) tree gfor_fndecl_pause_string; +extern GTY(()) tree gfor_fndecl_stop_numeric; +extern GTY(()) tree gfor_fndecl_stop_string; +extern GTY(()) tree gfor_fndecl_select_string; +extern GTY(()) tree gfor_fndecl_runtime_error; +extern GTY(()) tree gfor_fndecl_in_pack; +extern GTY(()) tree gfor_fndecl_in_unpack; +extern GTY(()) tree gfor_fndecl_associated; + +/* Math functions. Many other math functions are handled in + trans-intrinsic.c. */ +extern GTY(()) tree gfor_fndecl_math_powf; +extern GTY(()) tree gfor_fndecl_math_pow; +extern GTY(()) tree gfor_fndecl_math_cpowf; +extern GTY(()) tree gfor_fndecl_math_cpow; +extern GTY(()) tree gfor_fndecl_math_cabsf; +extern GTY(()) tree gfor_fndecl_math_cabs; +extern GTY(()) tree gfor_fndecl_math_sign4; +extern GTY(()) tree gfor_fndecl_math_sign8; +extern GTY(()) tree gfor_fndecl_math_ishftc4; +extern GTY(()) tree gfor_fndecl_math_ishftc8; +extern GTY(()) tree gfor_fndecl_math_exponent4; +extern GTY(()) tree gfor_fndecl_math_exponent8; + +/* String functions. */ +extern GTY(()) tree gfor_fndecl_copy_string; +extern GTY(()) tree gfor_fndecl_compare_string; +extern GTY(()) tree gfor_fndecl_concat_string; +extern GTY(()) tree gfor_fndecl_string_len_trim; +extern GTY(()) tree gfor_fndecl_string_index; +extern GTY(()) tree gfor_fndecl_string_scan; +extern GTY(()) tree gfor_fndecl_string_verify; +extern GTY(()) tree gfor_fndecl_string_trim; +extern GTY(()) tree gfor_fndecl_string_repeat; +extern GTY(()) tree gfor_fndecl_adjustl; +extern GTY(()) tree gfor_fndecl_adjustr; + +/* Other misc. runtime library functions. */ +extern GTY(()) tree gfor_fndecl_size0; +extern GTY(()) tree gfor_fndecl_size1; + +/* Implemented in FORTRAN. */ +extern GTY(()) tree gfor_fndecl_si_kind; +extern GTY(()) tree gfor_fndecl_sr_kind; + + +/* True if node is an integer constant. */ +#define INTEGER_CST_P(node) (TREE_CODE(node) == INTEGER_CST) + +/* G95-specific declaration information. */ + +/* Array types only. */ +struct lang_type GTY(()) +{ + int rank; + tree lbound[GFC_MAX_DIMENSIONS]; + tree ubound[GFC_MAX_DIMENSIONS]; + tree stride[GFC_MAX_DIMENSIONS]; + tree size; + tree offset; + tree dtype; + tree dataptr_type; +}; + +struct lang_decl GTY(()) +{ + /* Dummy variables. */ + tree saved_descriptor; + /* Assigned integer nodes. Stringlength is the IO format string's length. + Addr is the address of the string or the target label. Stringlength is + initialized to -2 and assiged to -1 when addr is assigned to the + address of target label. */ + tree stringlen; + tree addr; +}; + + +#define GFC_DECL_ASSIGN_ADDR(node) DECL_LANG_SPECIFIC(node)->addr +#define GFC_DECL_STRING_LEN(node) DECL_LANG_SPECIFIC(node)->stringlen +#define GFC_DECL_SAVED_DESCRIPTOR(node) \ + (DECL_LANG_SPECIFIC(node)->saved_descriptor) +#define GFC_DECL_PACKED_ARRAY(node) DECL_LANG_FLAG_0(node) +#define GFC_DECL_PARTIAL_PACKED_ARRAY(node) DECL_LANG_FLAG_1(node) +#define GFC_DECL_ASSIGN(node) DECL_LANG_FLAG_2(node) + +/* An array descriptor. */ +#define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node) +/* An array without a descriptor. */ +#define GFC_ARRAY_TYPE_P(node) TYPE_LANG_FLAG_2(node) +/* The GFC_TYPE_ARRAY_* members are present in both descriptor and + descriptorless array types. */ +#define GFC_TYPE_ARRAY_LBOUND(node, dim) \ + (TYPE_LANG_SPECIFIC(node)->lbound[dim]) +#define GFC_TYPE_ARRAY_UBOUND(node, dim) \ + (TYPE_LANG_SPECIFIC(node)->ubound[dim]) +#define GFC_TYPE_ARRAY_STRIDE(node, dim) \ + (TYPE_LANG_SPECIFIC(node)->stride[dim]) +#define GFC_TYPE_ARRAY_RANK(node) (TYPE_LANG_SPECIFIC(node)->rank) +#define GFC_TYPE_ARRAY_SIZE(node) (TYPE_LANG_SPECIFIC(node)->size) +#define GFC_TYPE_ARRAY_OFFSET(node) (TYPE_LANG_SPECIFIC(node)->offset) +#define GFC_TYPE_ARRAY_DTYPE(node) (TYPE_LANG_SPECIFIC(node)->dtype) +#define GFC_TYPE_ARRAY_DATAPTR_TYPE(node) \ + (TYPE_LANG_SPECIFIC(node)->dataptr_type) + +/* I changed this from sorry(...) because it should not return. */ +/* TODO: Remove gfc_todo_error before releasing version 1.0. */ +#define gfc_todo_error(args...) fatal_error("gfc_todo: Not Implemented: " args) + +/* Build an expression with void type. */ +#define build1_v(code, arg) build(code, void_type_node, arg) +#define build_v(code, args...) build(code, void_type_node, args) + +/* flag for alternative return labels. */ +extern int has_alternate_specifier; /* for caller */ +#endif /* GFC_TRANS_H */ |